diff options
| -rw-r--r-- | Unlambda/Interpreter.hs | 29 | ||||
| -rw-r--r-- | Unlambda/Monad.hs | 108 | ||||
| -rw-r--r-- | Unlambda/Parser.hs | 100 |
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 |