summaryrefslogtreecommitdiff
path: root/Unlambda
diff options
context:
space:
mode:
Diffstat (limited to 'Unlambda')
-rw-r--r--Unlambda/Builtins.hs70
-rw-r--r--Unlambda/Interpreter.hs85
-rw-r--r--Unlambda/Parser.hs125
-rw-r--r--Unlambda/Test.hs103
-rw-r--r--Unlambda/Types.hs108
5 files changed, 0 insertions, 491 deletions
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 _) = "<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-12-23 07:11:47 +0000