summaryrefslogtreecommitdiff
path: root/Unlambda
diff options
context:
space:
mode:
authorJed Barber <jjbarber@y7mail.com>2014-03-13 23:40:39 +1100
committerJed Barber <jjbarber@y7mail.com>2014-03-13 23:40:39 +1100
commit0765a9a1ea31b11075731f4f33b68b40b6f15154 (patch)
tree2023781572cb8244e719554f88e82eaf2d4e48ba /Unlambda
parentd6142115006893b806e313bb69b762f1afb3ea44 (diff)
GHC bug of some kind
Diffstat (limited to 'Unlambda')
-rw-r--r--Unlambda/Interpreter.hs56
-rw-r--r--Unlambda/Parser.hs10
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