summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Unlambda/Interpreter.hs64
1 files changed, 39 insertions, 25 deletions
diff --git a/Unlambda/Interpreter.hs b/Unlambda/Interpreter.hs
index c9820f0..362d57a 100644
--- a/Unlambda/Interpreter.hs
+++ b/Unlambda/Interpreter.hs
@@ -3,6 +3,7 @@ module Unlambda.Interpreter (
) where
+import System.IO.Error
import Control.Exception( Exception(..), Handler(..), throw, catches )
import Data.Typeable
import Unlambda.Parser
@@ -19,61 +20,74 @@ instance Control.Exception.Exception UnlambdaException
unlambda :: UnlambdaTerm -> IO UnlambdaTerm
unlambda term =
- catches (eval term)
+ catches (eval Nothing term)
[ Handler ((\e -> return (endTerm e)) :: UnlambdaException -> IO UnlambdaTerm) ]
-eval :: UnlambdaTerm -> IO UnlambdaTerm
-eval term =
+eval :: Maybe Char -> UnlambdaTerm -> IO UnlambdaTerm
+eval ch term =
case term of
App f x -> do
- t <- eval f
- apply t x
+ t <- eval ch f
+ apply ch t x
_ -> return term
-apply :: UnlambdaTerm -> UnlambdaTerm -> IO UnlambdaTerm
-apply firstTerm secondTerm =
+apply :: Maybe Char -> UnlambdaTerm -> UnlambdaTerm -> IO UnlambdaTerm
+apply ch firstTerm secondTerm =
case firstTerm of
- K -> eval secondTerm >>= return . Kpartial
+ K -> eval ch secondTerm >>= return . Kpartial
- Kpartial x -> eval secondTerm >> return x
+ Kpartial x -> eval ch secondTerm >> return x
- S -> eval secondTerm >>= return . Spartial
+ S -> eval ch secondTerm >>= return . Spartial
- Spartial x -> eval secondTerm >>= return . (Sapp x)
+ Spartial x -> eval ch secondTerm >>= return . (Sapp x)
Sapp x y -> do
- z <- eval secondTerm
- result <- eval (App (App x z) (App y z))
+ z <- eval ch secondTerm
+ result <- eval ch (App (App x z) (App y z))
return result
- I -> eval secondTerm
+ I -> eval ch secondTerm
- V -> eval secondTerm >> return V
+ V -> eval ch secondTerm >> return V
C -> return I --placeholder
D -> return (Promise secondTerm)
Promise x -> do
- y <- eval secondTerm
- result <- eval (App x y)
+ y <- eval ch secondTerm
+ result <- eval ch (App x y)
return result
- Dot c -> putChar c >> eval secondTerm
+ Dot c -> putChar c >> eval ch secondTerm
- R -> putChar '\n' >> eval secondTerm
+ R -> putChar '\n' >> eval ch secondTerm
E -> do
- t <- eval secondTerm
+ t <- eval ch secondTerm
throw (UnlambdaException t)
- Reed -> return I --placeholder
-
- Bar -> return I --placeholder
-
- Compare c -> return I --placeholder
+ Reed -> do
+ t <- eval ch secondTerm
+ catchIOError (do
+ ch' <- getChar
+ eval (Just ch') (App t I)
+ ) (\e -> eval Nothing (App t V))
+
+ Bar -> do
+ t <- eval ch secondTerm
+ case ch of
+ Just x -> eval ch (App t (Dot x))
+ Nothing -> eval ch (App t V)
+
+ Compare c -> do
+ t <- eval ch secondTerm
+ case (ch == Just c) of
+ True -> eval ch (App t I)
+ False -> eval ch (App t V)