Rearranging files

5 files changed, 491 insertions, 0 deletions

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 _) = "<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)
+