summaryrefslogtreecommitdiff
path: root/Unlambda
diff options
context:
space:
mode:
Diffstat (limited to 'Unlambda')
-rw-r--r--Unlambda/Interpreter.hs29
-rw-r--r--Unlambda/Monad.hs108
-rw-r--r--Unlambda/Parser.hs100
3 files changed, 131 insertions, 106 deletions
diff --git a/Unlambda/Interpreter.hs b/Unlambda/Interpreter.hs
index 26050e6..44dcad9 100644
--- a/Unlambda/Interpreter.hs
+++ b/Unlambda/Interpreter.hs
@@ -4,40 +4,17 @@ 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
+import Unlambda.Monad
-type ULM a = ContT UnlambdaTerm (StateT (Maybe Char) IO) a
-
-
-data UnlambdaException = UnlambdaException { exitValue :: UnlambdaTerm }
- deriving (Show, Typeable)
-
-instance Exception UnlambdaException
-
-
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 x = lift (put x)
-
-
-
-getCurChar :: ULM (Maybe Char)
-getCurChar = lift (get)
+unlambda term = getResult $ eval term
@@ -88,7 +65,7 @@ apply firstTerm secondTerm =
liftIO (putChar '\n')
return t
- E -> eval secondTerm >>= throw . UnlambdaException
+ E -> eval secondTerm >>= doExit
Reed -> do
t <- eval secondTerm
diff --git a/Unlambda/Monad.hs b/Unlambda/Monad.hs
new file mode 100644
index 0000000..c432c08
--- /dev/null
+++ b/Unlambda/Monad.hs
@@ -0,0 +1,108 @@
+module Unlambda.Monad (
+ ULM,
+ UnlambdaTerm(..),
+
+ getResult,
+ doExit,
+ setCurChar,
+ getCurChar
+ ) where
+
+
+import Control.Exception
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.State.Lazy
+import Control.Monad.IO.Class
+import Data.Typeable
+
+
+
+
+data UnlambdaException = UnlambdaException { exitTerm :: UnlambdaTerm }
+ deriving (Show, Typeable)
+
+instance Exception UnlambdaException
+
+
+
+
+type ULM a = ContT UnlambdaTerm (StateT (Maybe Char) IO) a
+
+
+
+
+data UnlambdaTerm = S | K | I | V | R | D | C | E | Bar | Reed
+ | Dot Char
+ | Compare Char
+ | App UnlambdaTerm UnlambdaTerm
+ | Kpartial UnlambdaTerm
+ | Spartial UnlambdaTerm
+ | Sapp UnlambdaTerm UnlambdaTerm
+ | Promise UnlambdaTerm
+ | Continuation (UnlambdaTerm -> ULM UnlambdaTerm)
+
+
+instance Eq UnlambdaTerm where
+ S == S = True
+ K == K = True
+ I == I = True
+ V == V = True
+ R == R = True
+ D == D = True
+ C == C = True
+ E == E = True
+ Bar == Bar = True
+ Reed == Reed = True
+ Dot x == Dot y = x == y
+ Compare x == Compare y = x == y
+ App a b == App x y = a == x && b == y
+ Kpartial x == Kpartial y = x == y
+ Spartial x == Spartial y = x == y
+ Sapp a b == Sapp x y = a == x && b == y
+ Promise x == Promise y = x == y
+ _ == _ = False
+
+
+instance Show UnlambdaTerm where
+ show S = "s"
+ show K = "k"
+ show I = "i"
+ show V = "v"
+ show R = "r"
+ show D = "d"
+ show C = "c"
+ show E = "e"
+ show Bar = "|"
+ show Reed = "@"
+ show (Dot x) = ['.', x]
+ show (Compare x) = ['?', x]
+ show (App x y) = "`" ++ (show x) ++ (show y)
+ show (Kpartial x) = "`k" ++ (show x)
+ show (Spartial x) = "`s" ++ (show x)
+ show (Sapp x y) = "``s" ++ (show x) ++ (show y)
+ show (Promise x) = "`d" ++ (show x)
+ show (Continuation _) = "<cont>"
+
+
+
+
+getResult :: ULM UnlambdaTerm -> IO UnlambdaTerm
+getResult m = catches (liftIO ((`evalStateT` Nothing) . (`runContT` return) $ m))
+ [ Handler ((\e -> return (exitTerm e)) :: UnlambdaException -> IO UnlambdaTerm) ]
+
+
+
+doExit :: UnlambdaTerm -> ULM UnlambdaTerm
+doExit term = throw (UnlambdaException term)
+
+
+
+setCurChar :: Maybe Char -> ULM ()
+setCurChar x = lift (put x)
+
+
+
+getCurChar :: ULM (Maybe Char)
+getCurChar = lift (get)
+
diff --git a/Unlambda/Parser.hs b/Unlambda/Parser.hs
index 59fc5e3..5921f29 100644
--- a/Unlambda/Parser.hs
+++ b/Unlambda/Parser.hs
@@ -1,74 +1,13 @@
module Unlambda.Parser (
- UnlambdaTerm(..),
-
parseUnlambda,
parseUnlambda1
) where
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 (Maybe Char) IO) a
-
-
-data UnlambdaTerm = S | K | I | V | R | D | C | E | Bar | Reed
- | Dot Char
- | Compare Char
- | App UnlambdaTerm UnlambdaTerm
- | Kpartial UnlambdaTerm
- | Spartial UnlambdaTerm
- | Sapp UnlambdaTerm UnlambdaTerm
- | Promise UnlambdaTerm
- | Continuation (UnlambdaTerm -> ULM UnlambdaTerm)
-
-
-instance Eq UnlambdaTerm where
- S == S = True
- K == K = True
- I == I = True
- V == V = True
- R == R = True
- D == D = True
- C == C = True
- E == E = True
- Bar == Bar = True
- Reed == Reed = True
- Dot x == Dot y = x == y
- Compare x == Compare y = x == y
- App a b == App x y = a == x && b == y
- Kpartial x == Kpartial y = x == y
- Spartial x == Spartial y = x == y
- Sapp a b == Sapp x y = a == x && b == y
- Promise x == Promise y = x == y
- _ == _ = False
-
-
-instance Show UnlambdaTerm where
- show S = "s"
- show K = "k"
- show I = "i"
- show V = "v"
- show R = "r"
- show D = "d"
- show C = "c"
- show E = "e"
- show Bar = "|"
- show Reed = "@"
- show (Dot x) = ['.', x]
- show (Compare x) = ['?', x]
- show (App x y) = "`" ++ (show x) ++ (show y)
- show (Kpartial x) = "`k" ++ (show x)
- show (Spartial x) = "`s" ++ (show x)
- show (Sapp x y) = "``s" ++ (show x) ++ (show y)
- show (Promise x) = "`d" ++ (show x)
- show (Continuation _) = "<cont>"
+import Unlambda.Monad
@@ -91,6 +30,7 @@ parseUnlambda1 input =
+
removeComments = uline `sepEndBy` eol >>= (return . concat)
@@ -127,24 +67,24 @@ unlambda1 = do
return t
-term = (try term1)
- <|> (try e)
- <|> (try reed)
- <|> (try comp)
- <|> (try bar)
- <?> "unlambda term"
-
-
-term1 = (try app)
- <|> (try s)
- <|> (try k)
- <|> (try i)
- <|> (try v)
- <|> (try r)
- <|> (try d)
- <|> (try c)
- <|> (try dot)
- <?> "unlambda term"
+term = (try term1)
+ <|> (try e)
+ <|> (try reed)
+ <|> (try comp)
+ <|> (try bar)
+ <?> "unlambda term"
+
+
+term1 = (try app)
+ <|> (try s)
+ <|> (try k)
+ <|> (try i)
+ <|> (try v)
+ <|> (try r)
+ <|> (try d)
+ <|> (try c)
+ <|> (try dot)
+ <?> "unlambda term"
app = do