From 281425310c5db21f87981eeb9601a71d1974d98d Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Thu, 10 Apr 2014 05:25:03 +1000 Subject: Rearranging files --- Unlambda/Builtins.hs | 70 --------------------------- Unlambda/Interpreter.hs | 85 -------------------------------- Unlambda/Parser.hs | 125 ------------------------------------------------ Unlambda/Test.hs | 103 --------------------------------------- Unlambda/Types.hs | 108 ----------------------------------------- 5 files changed, 491 deletions(-) delete mode 100644 Unlambda/Builtins.hs delete mode 100644 Unlambda/Interpreter.hs delete mode 100644 Unlambda/Parser.hs delete mode 100644 Unlambda/Test.hs delete mode 100644 Unlambda/Types.hs (limited to 'Unlambda') diff --git a/Unlambda/Builtins.hs b/Unlambda/Builtins.hs deleted file mode 100644 index bb054a1..0000000 --- a/Unlambda/Builtins.hs +++ /dev/null @@ -1,70 +0,0 @@ -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/Unlambda/Interpreter.hs b/Unlambda/Interpreter.hs deleted file mode 100644 index f1dcf05..0000000 --- a/Unlambda/Interpreter.hs +++ /dev/null @@ -1,85 +0,0 @@ -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/Unlambda/Parser.hs b/Unlambda/Parser.hs deleted file mode 100644 index 23bf723..0000000 --- a/Unlambda/Parser.hs +++ /dev/null @@ -1,125 +0,0 @@ -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/Unlambda/Test.hs b/Unlambda/Test.hs deleted file mode 100644 index f049b59..0000000 --- a/Unlambda/Test.hs +++ /dev/null @@ -1,103 +0,0 @@ -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/Unlambda/Types.hs b/Unlambda/Types.hs deleted file mode 100644 index 825a624..0000000 --- a/Unlambda/Types.hs +++ /dev/null @@ -1,108 +0,0 @@ -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