summaryrefslogtreecommitdiff
path: root/src/Unlambda
diff options
context:
space:
mode:
Diffstat (limited to 'src/Unlambda')
-rw-r--r--src/Unlambda/Builtins.hs70
-rw-r--r--src/Unlambda/Interpreter.hs85
-rw-r--r--src/Unlambda/Parser.hs125
-rw-r--r--src/Unlambda/Test.hs103
-rw-r--r--src/Unlambda/Types.hs108
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)
+
generated by cgit (git 2.30.0) at 2024-04-29 06:09:13 +0000