From f309a14ee66ca569d8f763f02c750f088165fe95 Mon Sep 17 00:00:00 2001
From: Jed Barber <jjbarber@y7mail.com>
Date: Fri, 14 Mar 2014 01:03:03 +1100
Subject: Unlambda interpreter complete
---
Unlambda/Interpreter.hs | 81 ++++++++++++++++++-------------------------------
Unlambda/Parser.hs | 6 +---
2 files changed, 30 insertions(+), 57 deletions(-)
(limited to 'Unlambda')
diff --git a/Unlambda/Interpreter.hs b/Unlambda/Interpreter.hs
index b165887..26050e6 100644
--- a/Unlambda/Interpreter.hs
+++ b/Unlambda/Interpreter.hs
@@ -4,60 +4,40 @@ module Unlambda.Interpreter (
import System.IO.Error
+import Control.Exception( Exception(..), Handler(..), throw, catches )
import Control.Monad.Trans.Class
import Control.Monad.Trans.Cont
import Control.Monad.Trans.State.Lazy
import Control.Monad.IO.Class
+import Data.Typeable
+import Data.Maybe
import Unlambda.Parser
-type ULM a = ContT UnlambdaTerm (StateT UnlambdaState IO) a
+type ULM a = ContT UnlambdaTerm (StateT (Maybe Char) IO) a
-data UnlambdaState = UnlambdaState { exit :: UnlambdaTerm -> ULM UnlambdaTerm
- , curChar :: Maybe Char }
+data UnlambdaException = UnlambdaException { exitValue :: UnlambdaTerm }
+ deriving (Show, Typeable)
+instance Exception UnlambdaException
-unlambda :: UnlambdaTerm -> IO UnlambdaTerm
-unlambda term = (`getResult` return) (callCC $ \cont -> setExit cont >> setCurChar Nothing >> eval term)
-
-
-
-getResult :: (Monad m) => ULM a -> (a -> m a) -> m a
-getResult m f = f . runStateT . runContT $ m
-
-
-
-setExit :: (UnlambdaTerm -> ULM UnlambdaTerm) -> ULM ()
-setExit cont = do
- state <- lift get
- (lift put) (state { exit = cont })
- return
-
-
-doExit :: UnlambdaTerm -> ULM UnlambdaTerm
-doExit term = do
- state <- lift get
- (exit state) term
- return
+unlambda :: UnlambdaTerm -> IO UnlambdaTerm
+unlambda term = catches ((`evalStateT` Nothing) . (`runContT` return) $ eval term)
+ [ Handler ((\e -> return . exitValue $ e) :: UnlambdaException -> IO UnlambdaTerm) ]
setCurChar :: Maybe Char -> ULM ()
-setCurChar ch = do
- state <- lift get
- (lift put) (state { curChar = ch })
- return
+setCurChar x = lift (put x)
getCurChar :: ULM (Maybe Char)
-getCurChar = do
- state <- lift get
- return (curChar state)
+getCurChar = lift (get)
@@ -108,24 +88,21 @@ apply firstTerm secondTerm =
liftIO (putChar '\n')
return t
- E -> eval secondTerm >>= doExit
-
- Reed -> return I --do
- --t <- eval ch secondTerm
- --catchIOError (do
- -- ch' <- getChar
- -- eval (Just ch') (App t I)
- -- ) (\e -> eval Nothing (App t V))
-
- Bar -> return I --do
- --t <- eval ch secondTerm
- --case ch of
- -- Just x -> eval ch (App t (Dot x))
- -- Nothing -> eval ch (App t V)
-
- Compare c -> return I --do
- --t <- eval ch secondTerm
- --case (ch == Just c) of
- -- True -> eval ch (App t I)
- -- False -> eval ch (App t V)
+ E -> eval secondTerm >>= throw . UnlambdaException
+
+ Reed -> do
+ t <- eval secondTerm
+ ch <- liftIO (catchIOError (getChar >>= return . Just) (\e -> return Nothing))
+ setCurChar ch
+ if (isNothing ch) then eval (App t V) else eval (App t I)
+
+ Bar -> do
+ t <- eval secondTerm
+ ch <- getCurChar
+ if (isNothing ch) then eval (App t V) else eval (App t I)
+
+ Compare c -> do
+ t <- eval secondTerm
+ ch <- getCurChar
+ if (ch /= Just c) then eval (App t V) else eval (App t I)
diff --git a/Unlambda/Parser.hs b/Unlambda/Parser.hs
index 851fc01..59fc5e3 100644
--- a/Unlambda/Parser.hs
+++ b/Unlambda/Parser.hs
@@ -15,11 +15,7 @@ import Text.ParserCombinators.Parsec
-type ULM a = ContT UnlambdaTerm (StateT UnlambdaState IO) a
-
-data UnlambdaState = UnlambdaState { exit :: UnlambdaTerm -> ULM UnlambdaTerm
- , curChar :: Maybe Char }
-
+type ULM a = ContT UnlambdaTerm (StateT (Maybe Char) IO) a
data UnlambdaTerm = S | K | I | V | R | D | C | E | Bar | Reed
--
cgit