diff options
| -rw-r--r-- | Unlambda/Interpreter.hs | 56 | ||||
| -rw-r--r-- | Unlambda/Parser.hs | 10 |
2 files changed, 54 insertions, 12 deletions
diff --git a/Unlambda/Interpreter.hs b/Unlambda/Interpreter.hs index 1f0be35..b165887 100644 --- a/Unlambda/Interpreter.hs +++ b/Unlambda/Interpreter.hs @@ -4,30 +4,64 @@ 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 Unlambda.Parser -data UnlambdaException = UnlambdaException { endTerm :: UnlambdaTerm } - deriving (Show, Typeable) +type ULM a = ContT UnlambdaTerm (StateT UnlambdaState IO) a -instance Control.Exception.Exception UnlambdaException +data UnlambdaState = UnlambdaState { exit :: UnlambdaTerm -> ULM UnlambdaTerm + , curChar :: Maybe Char } unlambda :: UnlambdaTerm -> IO UnlambdaTerm -unlambda term = - catches ((`runContT` return) $ eval term) - [ Handler ((\e -> return (endTerm e)) :: UnlambdaException -> IO UnlambdaTerm) ] +unlambda term = (`getResult` return) (callCC $ \cont -> setExit cont >> setCurChar Nothing >> eval term) -eval :: UnlambdaTerm -> ContT UnlambdaTerm IO UnlambdaTerm +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 + + + +setCurChar :: Maybe Char -> ULM () +setCurChar ch = do + state <- lift get + (lift put) (state { curChar = ch }) + return + + + +getCurChar :: ULM (Maybe Char) +getCurChar = do + state <- lift get + return (curChar state) + + + +eval :: UnlambdaTerm -> ULM UnlambdaTerm eval term = case term of App f x -> do @@ -37,7 +71,7 @@ eval term = -apply :: UnlambdaTerm -> UnlambdaTerm -> ContT UnlambdaTerm IO UnlambdaTerm +apply :: UnlambdaTerm -> UnlambdaTerm -> ULM UnlambdaTerm apply firstTerm secondTerm = case firstTerm of K -> eval secondTerm >>= return . Kpartial @@ -74,7 +108,7 @@ apply firstTerm secondTerm = liftIO (putChar '\n') return t - E -> eval secondTerm >>= throw . UnlambdaException + E -> eval secondTerm >>= doExit Reed -> return I --do --t <- eval ch secondTerm diff --git a/Unlambda/Parser.hs b/Unlambda/Parser.hs index ec604cf..851fc01 100644 --- a/Unlambda/Parser.hs +++ b/Unlambda/Parser.hs @@ -9,11 +9,19 @@ module Unlambda.Parser ( import Control.Applicative( some ) import Control.Monad.Trans.Cont import Control.Monad.IO.Class +import Control.Monad.Trans.State.Lazy import Data.Either import Text.ParserCombinators.Parsec +type ULM a = ContT UnlambdaTerm (StateT UnlambdaState IO) a + +data UnlambdaState = UnlambdaState { exit :: UnlambdaTerm -> ULM UnlambdaTerm + , curChar :: Maybe Char } + + + data UnlambdaTerm = S | K | I | V | R | D | C | E | Bar | Reed | Dot Char | Compare Char @@ -22,7 +30,7 @@ data UnlambdaTerm = S | K | I | V | R | D | C | E | Bar | Reed | Spartial UnlambdaTerm | Sapp UnlambdaTerm UnlambdaTerm | Promise UnlambdaTerm - | Continuation (UnlambdaTerm -> ContT UnlambdaTerm IO UnlambdaTerm) + | Continuation (UnlambdaTerm -> ULM UnlambdaTerm) instance Eq UnlambdaTerm where |