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(-)

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