diff options
| -rw-r--r-- | Unlambda/Interpreter.hs | 64 |
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) |