From 281425310c5db21f87981eeb9601a71d1974d98d Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Thu, 10 Apr 2014 05:25:03 +1000 Subject: Rearranging files --- src/Unlambda/Builtins.hs | 70 +++++++++++++++++++++++++ src/Unlambda/Interpreter.hs | 85 ++++++++++++++++++++++++++++++ src/Unlambda/Parser.hs | 125 ++++++++++++++++++++++++++++++++++++++++++++ src/Unlambda/Test.hs | 103 ++++++++++++++++++++++++++++++++++++ src/Unlambda/Types.hs | 108 ++++++++++++++++++++++++++++++++++++++ 5 files changed, 491 insertions(+) create mode 100644 src/Unlambda/Builtins.hs create mode 100644 src/Unlambda/Interpreter.hs create mode 100644 src/Unlambda/Parser.hs create mode 100644 src/Unlambda/Test.hs create mode 100644 src/Unlambda/Types.hs (limited to 'src/Unlambda') diff --git a/src/Unlambda/Builtins.hs b/src/Unlambda/Builtins.hs new file mode 100644 index 0000000..bb054a1 --- /dev/null +++ b/src/Unlambda/Builtins.hs @@ -0,0 +1,70 @@ +module Unlambda.Builtins ( + k, + s, + i, + dot, + r, + d, + c, + e + ) where + + +import Control.Exception( Exception(..), throw ) + + + +data MyException = MyException { func :: a -> b } + deriving (Show, Eq) + +instance Exception MyException + + + +k :: a -> b -> a +k x y = x + + + +s :: (a -> b -> c) -> (a -> b) -> a -> c +s x y z = (x z) (y z) + + + +i :: a -> a +i = id + + + +class Void a where + v :: a -> r + +instance Void v => Void (a -> r) where + v x = v + + + +dot :: Char -> a -> IO a +dot ch f = putChar ch >> return f + + + +r :: a -> IO a +r f = putChar '\n' >> return f + + + +-- may not work as per unlambda lazy semantics +d :: (a -> b) -> (a -> b) +d x = (\y -> x y) + + + +c :: (a -> b) -> (a -> b) +c x = (`runCont` id) (callCC $ \cont -> x cont) + + + +e :: a -> b +e x = throw (MyException x) + diff --git a/src/Unlambda/Interpreter.hs b/src/Unlambda/Interpreter.hs new file mode 100644 index 0000000..f1dcf05 --- /dev/null +++ b/src/Unlambda/Interpreter.hs @@ -0,0 +1,85 @@ +module Unlambda.Interpreter ( + unlambda + ) where + + +import System.IO.Error +import Control.Monad.Trans.Cont +import Control.Monad.IO.Class +import Data.Maybe +import Unlambda.Parser +import Unlambda.Types + + + + +unlambda :: UnlambdaTerm -> IO UnlambdaTerm +unlambda term = getResult $ eval term + + + +eval :: UnlambdaTerm -> ULM UnlambdaTerm +eval term = + case term of + App f x -> do + t <- eval f + apply t x + _ -> return term + + + +apply :: UnlambdaTerm -> UnlambdaTerm -> ULM UnlambdaTerm +apply firstTerm secondTerm = + case firstTerm of + K -> eval secondTerm >>= return . Kpartial + + Kpartial x -> eval secondTerm >> return x + + S -> eval secondTerm >>= return . Spartial + + Spartial x -> eval secondTerm >>= return . (Sapp x) + + Sapp x y -> do + z <- eval secondTerm + eval (App (App x z) (App y z)) + + I -> eval secondTerm + + V -> eval secondTerm >> return V + + C -> callCC $ \cont -> eval (App secondTerm (Continuation cont)) + + Continuation cont -> eval secondTerm >>= cont + + D -> return (Promise secondTerm) + + Promise x -> eval secondTerm >>= eval . (App x) + + Dot c -> do + t <- eval secondTerm + liftIO (putChar c) + return t + + R -> do + t <- eval secondTerm + liftIO (putChar '\n') + return t + + E -> eval secondTerm >>= doExit + + Reed -> do + t <- eval secondTerm + ch <- liftIO (catchIOError (getChar >>= return . Just) (\e -> return Nothing)) + setCurChar ch + if (isNothing ch) then eval (App t V) else eval (App t I) + + Bar -> do + t <- eval secondTerm + ch <- getCurChar + if (isNothing ch) then eval (App t V) else eval (App t I) + + Compare c -> do + t <- eval secondTerm + ch <- getCurChar + if (ch /= Just c) then eval (App t V) else eval (App t I) + diff --git a/src/Unlambda/Parser.hs b/src/Unlambda/Parser.hs new file mode 100644 index 0000000..23bf723 --- /dev/null +++ b/src/Unlambda/Parser.hs @@ -0,0 +1,125 @@ +module Unlambda.Parser ( + parseUnlambda, + parseUnlambda1 + ) where + + +import Control.Applicative( some ) +import Data.Either +import Text.ParserCombinators.Parsec +import Unlambda.Types + + + + +parseUnlambda :: String -> Either ParseError UnlambdaTerm +parseUnlambda input = + let firstPass = parse removeComments "error" input + in case firstPass of + Left e -> Left e + Right o -> parse unlambda "error" o + + + +parseUnlambda1 :: String -> Either ParseError UnlambdaTerm +parseUnlambda1 input = + let firstPass = parse removeComments "error" input + in case firstPass of + Left e -> Left e + Right o -> parse unlambda1 "error" o + + + + +removeComments = uline `sepEndBy` eol >>= (return . concat) + + +uline = do + l <- many (builtin <|> (oneOf " \t" >>= return . (:[]))) + optional (char '#' >> many (noneOf "\r\n")) + return . concat $ l + + +builtin = (oneOf "`skivrdce|@" >>= return . (:[])) + <|> (char '.' >> anyChar >>= return . ('.':) . (:[])) + <|> (char '?' >> anyChar >>= return . ('?':) . (:[])) + "unlambda builtin function" + + +eol = try (string "\r\n") + <|> try (string "\n\r") + <|> try (string "\r") + <|> try (string "\n") + "end of line" + + +unlambda = do + whiteSpace + t <- term + eof + return t + + +unlambda1 = do + whiteSpace + t <- term1 + eof + 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" + + +app = do + char '`' + whiteSpace + f <- term + x <- term + return (App f x) + + +s = char 's' >> whiteSpace >> return S +k = char 'k' >> whiteSpace >> return K +i = char 'i' >> whiteSpace >> return I +v = char 'v' >> whiteSpace >> return V +r = char 'r' >> whiteSpace >> return R +d = char 'd' >> whiteSpace >> return D +c = char 'c' >> whiteSpace >> return C +e = char 'e' >> whiteSpace >> return E +reed = char '@' >> whiteSpace >> return Reed +bar = char '|' >> whiteSpace >> return Bar + + +comp = do + char '?' + c <- anyChar + whiteSpace + return (Compare c) + + +dot = do + char '.' + c <- anyChar + whiteSpace + return (Dot c) + + +whiteSpace = many (oneOf "\t\n\r ") + diff --git a/src/Unlambda/Test.hs b/src/Unlambda/Test.hs new file mode 100644 index 0000000..f049b59 --- /dev/null +++ b/src/Unlambda/Test.hs @@ -0,0 +1,103 @@ +module Unlambda.Test ( + parserTests, + interpreterTests, + tests, + ioTests + ) where + + +import Test.HUnit +import Text.Parsec.Error +import Control.Monad +import System.IO.Silently +import Unlambda.Types +import Unlambda.Parser +import Unlambda.Interpreter + + +instance Eq Text.Parsec.Error.ParseError + + + + +parser0 = (Right S) ~=? (parseUnlambda "s") + +parser1 = (Right K) ~=? (parseUnlambda "k") + +parser2 = (Right I) ~=? (parseUnlambda "i") + +parser3 = (Right V) ~=? (parseUnlambda "v") + +parser4 = (Right R) ~=? (parseUnlambda "r") + +parser5 = (Right D) ~=? (parseUnlambda "d") + +parser6 = (Right C) ~=? (parseUnlambda "c") + +parser7 = (Right E) ~=? (parseUnlambda "e") + +parser8 = (Right (App S K)) ~=? (parseUnlambda "`sk") + +parser9 = (Right (Dot 'c')) ~=? (parseUnlambda ".c") + +parser10 = (Right (Compare '?')) ~=? (parseUnlambda "??") + +parser11 = (Right Bar) ~=? (parseUnlambda "|") + +parser12 = (Right Reed) ~=? (parseUnlambda "@") + + + +interpretString :: String -> IO (Maybe (String,UnlambdaTerm)) +interpretString input = + let t = parseUnlambda input + in case t of + Left _ -> return Nothing + Right term -> do + c <- capture (unlambda term) + return (Just c) + + + +interpreter0 = (liftM2 (~=?)) + (return (Just ("\n", R)) ) + (interpretString "``cir") + +interpreter1 = (liftM2 (~=?)) + (return (Just ("", I)) ) + (interpretString "`c``s`kr``si`ki") + +interpreter2 = (liftM2 (~=?)) + (return (Just ("", Promise (App R I))) ) + (interpretString "`d`ri") + +interpreter3 = (liftM2 (~=?)) + (return (Just ("\n", Promise I)) ) + (interpretString "``dd`ri") + + + +parserTests :: Test +parserTests = TestList [parser0, parser1, parser2, parser3, parser4, parser5, parser6, parser7, parser8 + ,parser9, parser10, parser11, parser12] + + + +interpreterTests :: IO Test +interpreterTests = do + t0 <- interpreter0 + t1 <- interpreter1 + t2 <- interpreter2 + t3 <- interpreter3 + return (TestList [t0,t1,t2,t3]) + + + +tests :: Test +tests = parserTests + + + +ioTests :: IO Test +ioTests = interpreterTests + diff --git a/src/Unlambda/Types.hs b/src/Unlambda/Types.hs new file mode 100644 index 0000000..825a624 --- /dev/null +++ b/src/Unlambda/Types.hs @@ -0,0 +1,108 @@ +module Unlambda.Types ( + 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 _) = "" + + + + +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) + -- cgit