Straightforward While lexer, parser and interpreter

14 files changed, 541 insertions, 0 deletions

diff --git a/paper/While/Common.dcl b/paper/While/Common.dcl
new file mode 100644
index 0000000..6945c08
--- /dev/null
+++ b/paper/While/Common.dcl
@@ -0,0 +1,47 @@
+definition module Common
+
+from StdString import class toString
+
+class Functor f where
+	(<$>) infixl 4 :: (a -> b) (f a) -> f b
+
+class Applicative f | Functor f where
+	pure :: a -> f a
+	(<*>) infixl 4 :: (f (a -> b)) (f a) -> f b
+
+class Alternative f | Applicative f where
+	empty :: f a
+	(<|>) infixl 3 :: (f a) (f a) -> f a
+
+class Monad m | Applicative m where
+	(>>=) infixl 1 :: (m a) (a -> m b) -> m b
+
+:: Either l r = Left l | Right r
+
+instance Functor (Either e)
+instance Applicative (Either e)
+instance Monad (Either e)
+
+:: Error = Lextime String
+         | Parsetime String
+         | Runtime String
+         | GenericError String
+
+instance toString Error
+
+(<+) infixr 5 :: a b -> String | toString a & toString b
+
+($) infixr 0 :: (a -> b) a -> b
+
+(*>) infixl 4 :: (f a) (f b) -> f b | Applicative f
+(<*) infixl 4 :: (f a) (f b) -> f a | Applicative f
+
+some :: (f a) -> f [a] | Alternative f
+many :: (f a) -> f [a] | Alternative f
+
+sequence :: [a b] -> a [b] | Monad a
+mapM :: (a -> b c) [a] -> b [c] | Monad b
+foldM :: (a -> (b -> c a)) a [b] -> c a | Monad c
+liftM :: (a -> b) (c a) -> c b | Monad c
+liftM2 :: (a -> (b -> c)) (d a) (d b) -> d c | Monad d
+liftM3 :: (a -> (b -> (c -> d))) (e a) (e b) (e c) -> e d | Monad e
diff --git a/paper/While/Common.icl b/paper/While/Common.icl
new file mode 100644
index 0000000..4f6e4c4
--- /dev/null
+++ b/paper/While/Common.icl
@@ -0,0 +1,67 @@
+implementation module Common
+
+import StdFunc, StdList, StdString
+
+instance Functor (Either e) where
+	(<$>) f (Left err) = Left err
+	(<$>) f (Right x) = Right (f x)
+
+instance Applicative (Either e) where
+	pure x = Right x
+	(<*>) (Left err) _ = Left err
+	(<*>) (Right f) x = f <$> x
+
+instance Monad (Either e) where
+	(>>=) (Left err) f = Left err
+	(>>=) (Right x) f = f x
+
+instance toString Error
+where
+	toString (Lextime e) = "Lexing error: " +++ e +++ "\n"
+	toString (Parsetime e) = "Parsing error: " +++ e +++ "\n"
+	toString (Runtime e) = "Runtime error: " +++ e +++ "\n"
+	toString (GenericError e) = "Error: " +++ e +++ "\n"
+
+(<+) infixr 5 :: a b -> String | toString a & toString b
+(<+) a b = toString a +++ toString b
+
+($) infixr 0 :: (a -> b) a -> b
+($) f x = f x
+
+(*>) infixl 4 :: (f a) (f b) -> f b | Applicative f
+(*>) fa fb = const id <$> fa <*> fb
+
+(<*) infixl 4 :: (f a) (f b) -> f a | Applicative f
+(<*) fa fb = const <$> fa <*> fb
+
+some :: (f a) -> f [a] | Alternative f
+some v = some_v
+where
+	many_v  = some_v <|> pure []
+	some_v  = (\x xs -> [x:xs]) <$> v <*> many_v
+
+many :: (f a) -> f [a] | Alternative f
+many v = many_v
+where
+	many_v  = some_v <|> pure []
+	some_v  = (\x xs -> [x:xs]) <$> v <*> many_v
+
+sequence :: [a b] -> a [b] | Monad a
+sequence ms = foldr k (pure []) ms
+where k m m` = m >>= \x -> m` >>= \xs -> pure [x:xs]
+
+mapM :: (a -> b c) [a] -> b [c] | Monad b
+mapM f as = sequence (map f as)
+
+foldM :: (a -> (b -> c a)) a [b] -> c a | Monad c
+foldM _ a []      = pure a
+foldM f a [x:xs]  = f a x >>= \fax -> foldM f fax xs
+
+liftM :: (a -> b) (c a) -> c b | Monad c
+liftM f m1 = m1 >>= \x1 -> pure (f x1)
+
+liftM2 :: (a -> (b -> c)) (d a) (d b) -> d c | Monad d
+liftM2 f m1 m2 = m1 >>= \x1 -> m2 >>= \x2 -> pure (f x1 x2)
+
+liftM3 :: (a -> (b -> (c -> d))) (e a) (e b) (e c) -> e d | Monad e
+liftM3 f m1 m2 m3 = m1 >>= \x1 -> m2 >>= \x2 -> m3 >>= \x3 -> pure (f x1 x2 x3)
diff --git a/paper/While/Simple.dcl b/paper/While/Simple.dcl
new file mode 100644
index 0000000..5a08e85
--- /dev/null
+++ b/paper/While/Simple.dcl
@@ -0,0 +1,13 @@
+definition module Simple
+
+from StdOverloaded import class toString
+import WhileCommon
+
+:: Stm = Ass Var AExpr
+       | If BExpr Stm Stm
+       | While BExpr Stm
+       | Skip
+       | Compose Stm Stm
+
+instance toString Stm
+instance run Stm
diff --git a/paper/While/Simple.icl b/paper/While/Simple.icl
new file mode 100644
index 0000000..9138f1f
--- /dev/null
+++ b/paper/While/Simple.icl
@@ -0,0 +1,22 @@
+implementation module Simple
+
+import StdString
+
+import WhileCommon
+import Common
+
+instance toString Stm
+where
+	toString (Ass v a) = v <+ " := " <+ a
+	toString (If b s1 s2) = "if " <+ b <+ " then " <+ s1 <+ " else " <+ s2
+	toString (While b s) = "while " <+ b <+ " do " <+ s
+	toString Skip = "skip"
+	toString (Compose s1 s2) = s1 <+ "; " <+ s2
+
+instance run Stm
+where
+	run (Ass v e) st = eval e st >>= \r -> pure (\w -> if (w==v) (pure r) (st w))
+	run (If b s1 s2) st = eval b st >>= \r -> run (if r s1 s2) st
+	run w=:(While b s) st = eval b st >>= \r -> if r (run s st >>= \st` -> run w st`) (pure st)
+	run Skip st = pure st
+	run (Compose s1 s2) st = run s1 st >>= \st` -> run s2 st`
diff --git a/paper/While/SimpleParse.dcl b/paper/While/SimpleParse.dcl
new file mode 100644
index 0000000..12f25e5
--- /dev/null
+++ b/paper/While/SimpleParse.dcl
@@ -0,0 +1,6 @@
+definition module SimpleParse
+
+import WhileCommon
+import Simple
+
+instance parse Stm
diff --git a/paper/While/SimpleParse.icl b/paper/While/SimpleParse.icl
new file mode 100644
index 0000000..eca001a
--- /dev/null
+++ b/paper/While/SimpleParse.icl
@@ -0,0 +1,26 @@
+implementation module SimpleParse
+
+import StdList, StdTuple
+from StdFunc import o
+
+import Yard
+import WhileCommon
+import WhileLexer
+import Simple
+
+instance parse Stm
+where
+	parse cs = fst (runParser parser cs)
+	where
+		parser :: Parser Token Stm
+		parser = liftM2 Compose parser` (item CompToken *> parser) <|> parser`
+
+		parser` :: Parser Token Stm
+		parser` = item ParenOpen *> parser <* item ParenClose
+			<|> item SkipToken *> pure Skip
+			<|> item IfToken *> liftM3 If pbexpr (item ThenToken *> parser) (item ElseToken *> parser`)
+			<|> item WhileToken *> liftM2 While pbexpr (item DoToken *> parser`)
+			<|> liftM2 Ass (toVar <$> satisfy isVarToken) (item AssToken *> paexpr)
+
+		toVar (VarToken v) = v
+		isVarToken (VarToken _) = True; isVarToken _ = False
diff --git a/paper/While/SimpleTest b/paper/While/SimpleTest
new file mode 100755
index 0000000..8460f87
--- /dev/null
+++ b/paper/While/SimpleTest
diff --git a/paper/While/SimpleTest.icl b/paper/While/SimpleTest.icl
new file mode 100644
index 0000000..045eb9e
--- /dev/null
+++ b/paper/While/SimpleTest.icl
@@ -0,0 +1,22 @@
+module SimpleTest
+
+from StdOverloaded import class zero(..), class toString(..)
+import Common
+import WhileLexer
+import Simple
+import SimpleParse
+
+Start = toString <$> parsed
+//Start = val "z"
+where
+	lexed :: Either Error [Token]
+	lexed = lex ['x := 30; z := 0; o := 1; s := 1; while s <= x do (z := z+1; o := o+2; s := s+o)']
+
+	parsed :: Either Error Stm
+	parsed = lexed >>= parse
+
+	ran :: Either Error State
+	ran = parsed >>= \pgm -> run pgm zero
+
+	val :: Var -> Either Error Int
+	val v = ran >>= eval (Var v)
diff --git a/paper/While/WhileCommon.dcl b/paper/While/WhileCommon.dcl
new file mode 100644
index 0000000..b813641
--- /dev/null
+++ b/paper/While/WhileCommon.dcl
@@ -0,0 +1,45 @@
+definition module WhileCommon
+
+from StdOverloaded import class toString, class zero
+from GenEq import generic gEq
+from Common import ::Either, ::Error
+from WhileLexer import ::Token
+from Yard import ::Parser
+
+:: Var :== String
+
+:: State :== Var -> Either Error Int
+
+:: AExpr = Var Var
+         | Lit Int
+         | Op AExpr Operator AExpr
+
+:: Operator = Add | Sub | Mul | Div
+
+:: BExpr = Bool Bool
+         | Not BExpr
+         | And BExpr BExpr
+         | Or BExpr BExpr
+         | Comp AExpr Comparator AExpr
+
+:: Comparator = Eq | Ne | Le | Lt | Ge | Gt
+
+derive gEq AExpr, Operator, BExpr, Comparator
+
+instance zero State
+
+instance toString AExpr
+instance toString Operator
+instance toString BExpr
+instance toString Comparator
+
+class run s :: s State -> Either Error State
+
+class eval i o :: i State -> Either Error o
+instance eval AExpr Int
+instance eval BExpr Bool
+
+class parse o :: [Token] -> Either Error o
+
+paexpr :: Parser Token AExpr
+pbexpr :: Parser Token BExpr
diff --git a/paper/While/WhileCommon.icl b/paper/While/WhileCommon.icl
new file mode 100644
index 0000000..353f997
--- /dev/null
+++ b/paper/While/WhileCommon.icl
@@ -0,0 +1,94 @@
+implementation module WhileCommon
+
+import StdBool, StdInt, StdList, StdClass, StdString
+from StdFunc import o
+from GenEq import generic gEq
+import Common
+import WhileLexer
+import Yard
+
+derive gEq AExpr, Operator, BExpr, Comparator
+
+instance zero State where zero = \v -> Left (Runtime "Undefined variable")
+
+instance toString AExpr
+where
+	toString (Var v) = v
+	toString (Lit i) = toString i
+	toString (Op a1 op a2) = "(" <+ a1 <+ " " <+ op <+ " " <+ a2 <+ ")"
+
+instance toString Operator
+where
+	toString Add = "+"; toString Sub = "-"
+	toString Mul = "*"; toString Div = "/"
+
+instance toString BExpr
+where
+	toString (Bool b) = if b "true" "false"
+	toString (Not b) = "~" <+ b
+	toString (And b1 b2) = "(" <+ b1 <+ " & " <+ b2 <+ ")"
+	toString (Or b1 b2) = "(" <+ b1 <+ " | " <+ b2 <+ ")"
+	toString (Comp a1 cmp a2) = a1 <+ " " <+ cmp <+ " " <+ a2
+
+instance toString Comparator
+where
+	toString Eq = "="; toString Ne = "<>"
+	toString Le = "<="; toString Lt = "<"
+	toString Ge = ">="; toString Gt = ">"
+
+instance eval AExpr Int
+where
+	eval (Var v) st = st v
+	eval (Lit i) st = pure i
+	eval (Op a1 op a2) st = eval a1 st >>= \r1 -> eval a2 st >>= \r2 -> toOp op r1 r2
+	where
+		toOp :: Operator -> Int Int -> Either Error Int
+		toOp Add = \i j -> pure (i + j)
+		toOp Sub = \i j -> pure (i - j)
+		toOp Mul = \i j -> pure (i * j)
+		toOp Div = \i j -> if (j == 0) (Left (Runtime "Division by 0")) (pure (i / j))
+
+instance eval BExpr Bool
+where
+	eval (Bool b) st = pure b
+	eval (Not b) st = eval b st >>= pure o not
+	eval (And b1 b2) st = eval b1 st >>= \r -> eval b2 st >>= pure o ((&&) r)
+	eval (Or b1 b2) st = eval b1 st >>= \r -> eval b2 st >>= pure o ((||) r)
+	eval (Comp a1 cmp a2) st = eval a1 st >>= \r -> eval a2 st >>= pure o (toCmp cmp r)
+	where
+		toCmp :: Comparator -> Int Int -> Bool
+		toCmp Eq = \i j -> i == j
+		toCmp Ne = \i j -> i <> j
+		toCmp Le = \i j -> i <= j
+		toCmp Lt = \i j -> i < j
+		toCmp Ge = \i j -> i >= j
+		toCmp Gt = \i j -> i > j
+
+pbexpr :: Parser Token BExpr
+pbexpr = liftM2 Or pbconj (item OrToken *> pbexpr) <|> pbconj
+pbconj = liftM2 And pbnot (item AndToken *> pbconj) <|> pbnot
+pbnot  = item NotToken *> pbnot <|> pbcomp
+pbcomp = liftM3 Comp paexpr (toComp <$> satisfy isCompToken) paexpr <|> pbconst
+pbconst = toBool <$> satisfy isBoolToken
+	<|> item ParenOpen *> pbexpr <* item ParenClose
+
+paexpr :: Parser Token AExpr
+paexpr = liftOp Add pasub (item AddToken *> paexpr) <|> pasub
+pasub = liftM2 (foldl (\r->Op r Sub)) pamul (many (item SubToken *> pamul))
+pamul = liftOp Mul padiv (item MulToken *> pamul) <|> padiv
+padiv = liftM2 (foldl (\r->Op r Div)) paref (many (item DivToken *> paref))
+paref = Var o toVar <$> satisfy isVarToken
+	<|> (\(LiteralToken i) -> Lit i) <$> satisfy isLiteralToken
+	<|> item ParenOpen *> paexpr <* item ParenClose
+
+toComp EqToken = Eq; toComp NeToken = Ne; toComp LeToken = Le
+toComp LtToken = Lt; toComp GeToken = Ge; toComp GtToken = Lt
+isCompToken t = isMember t [EqToken, NeToken, LeToken, LtToken, GeToken, GtToken]
+toBool (BoolToken b) = Bool b
+isBoolToken (BoolToken _) = True; isBoolToken _ = False
+toVar (VarToken v) = v
+isVarToken (VarToken _) = True; isVarToken _ = False
+isLiteralToken (LiteralToken _) = True; isLiteralToken _ = False
+
+liftOp :: Operator (m AExpr) (m AExpr) -> m AExpr | Monad m
+liftOp op a1 a2 = a1 >>= \r1 -> a2 >>= \r2 -> pure (Op r1 op r2)
diff --git a/paper/While/WhileLexer.dcl b/paper/While/WhileLexer.dcl
new file mode 100644
index 0000000..d4cdc22
--- /dev/null
+++ b/paper/While/WhileLexer.dcl
@@ -0,0 +1,26 @@
+definition module WhileLexer
+
+from StdOverloaded import class ==
+from GenEq import generic gEq
+import WhileCommon
+
+:: Token = SkipToken
+         | IfToken | ThenToken | ElseToken
+         | WhileToken | DoToken
+         | CompToken
+         | AssToken
+
+         | EqToken | NeToken | LtToken | LeToken | GtToken | GeToken
+         | OrToken | AndToken | NotToken
+         | AddToken | SubToken | MulToken | DivToken
+
+         | VarToken Var
+         | LiteralToken Int
+         | BoolToken Bool
+
+         | ParenOpen | ParenClose
+
+derive gEq Token
+instance == Token
+
+lex :: [Char] -> Either Error [Token]
diff --git a/paper/While/WhileLexer.icl b/paper/While/WhileLexer.icl
new file mode 100644
index 0000000..458f260
--- /dev/null
+++ b/paper/While/WhileLexer.icl
@@ -0,0 +1,62 @@
+implementation module WhileLexer
+
+from StdOverloaded import class ==
+import _SystemArray, StdBool, StdChar, StdList, StdString
+import GenEq
+import Common
+import WhileCommon
+
+derive gEq Token
+instance == Token where == a b = a === b
+
+lex :: [Char] -> Either Error [Token]
+lex [] = pure []
+lex ['s':'k':'i':'p':cs]
+	| noident cs = lexyield SkipToken cs
+lex ['i':'f':cs]
+	| noident cs = lexyield IfToken cs
+lex ['t':'h':'e':'n':cs]
+	| noident cs = lexyield ThenToken cs
+lex ['e':'l':'s':'e':cs]
+	| noident cs = lexyield ElseToken cs
+lex ['w':'h':'i':'l':'e':cs]
+	| noident cs = lexyield WhileToken cs
+lex ['d':'o':cs]
+	| noident cs = lexyield DoToken cs
+lex ['t':'r':'u':'e':cs]
+	| noident cs = lexyield (BoolToken True) cs
+lex ['f':'a':'l':'s':'e':cs]
+	| noident cs = lexyield (BoolToken False) cs
+lex [';':cs] = lexyield CompToken cs
+lex [':':'=':cs] = lexyield AssToken cs
+lex ['<':'=':cs] = lexyield LeToken cs
+lex ['<':'>':cs] = lexyield NeToken cs
+lex ['<':cs] = lexyield LtToken cs
+lex ['>':'=':cs] = lexyield GeToken cs
+lex ['>':cs] = lexyield GtToken cs
+lex ['=':cs] = lexyield EqToken cs
+lex ['|':cs] = lexyield OrToken cs
+lex ['&':cs] = lexyield AndToken cs
+lex ['~':cs] = lexyield NotToken cs
+lex ['+':cs] = lexyield AddToken cs
+lex ['-':cs] = lexyield SubToken cs
+lex ['*':cs] = lexyield MulToken cs
+lex ['/':cs] = lexyield DivToken cs
+lex ['(':cs] = lexyield ParenOpen cs
+lex [')':cs] = lexyield ParenClose cs
+lex cs=:[c:rest]
+	| isAlpha c = let (id, cs`) = span isAlpha cs in 
+		lexyield (VarToken (toString id)) cs`
+	| isDigit c = let (lit, cs`) = span isDigit cs in
+		lexyield (LiteralToken (toInt lit)) cs`
+	| isSpace c = lex rest
+lex [c:_] = Left (Lextime ("Unexpected character in input: " +++ {c}))
+
+instance toInt [Char] where toInt cs = toInt (toString cs)
+
+lexyield :: Token [Char] -> Either Error [Token]
+lexyield tk cs = lex cs >>= \cs` -> pure [tk:cs`]
+
+noident :: [Char] -> Bool
+noident [] = True
+noident [c:_] = not (isAlpha c)
diff --git a/paper/While/Yard.dcl b/paper/While/Yard.dcl
new file mode 100644
index 0000000..1fcbfea
--- /dev/null
+++ b/paper/While/Yard.dcl
@@ -0,0 +1,27 @@
+definition module Yard
+
+// Stolen from https://github.com/dopefishh/cc1516/blob/master/yard.dcl;
+// minor changes made to not depend on clean-platform
+
+from StdString import class toString
+from StdClass import class ==
+
+import Common
+
+:: Parser a b = Parser ([a] -> (Either Error b, [a]))
+
+instance Functor (Parser a)
+instance Applicative (Parser a) 
+instance Monad (Parser a)
+instance Alternative (Parser a)
+
+runParser :: (Parser a b) [a] -> (Either Error b, [a])
+(<?>) :: (Parser a b) Error -> Parser a b
+fail :: Parser a b
+top :: Parser a a
+peek :: Parser a a
+satisfy :: (a -> Bool) -> Parser a a
+check :: (a -> Bool) -> Parser a a
+(until) infix 2 :: (Parser a b) (Parser a c) -> Parser a [b]
+item :: a -> Parser a a | == a
+list :: [a] -> Parser a [a] | == a
diff --git a/paper/While/Yard.icl b/paper/While/Yard.icl
new file mode 100644
index 0000000..a97944d
--- /dev/null
+++ b/paper/While/Yard.icl
@@ -0,0 +1,84 @@
+implementation module Yard
+
+import StdTuple
+import StdClass
+import StdString
+import StdList
+import StdInt
+
+import Common
+
+concat :: ([String] -> String)
+concat = foldl (+++) ""
+
+intersperse :: !a ![a] -> [a]
+intersperse i []      = []
+intersperse i [x]     = [x]
+intersperse i [x:xs]  = [x,i:intersperse i xs]
+
+runParser :: (Parser a b) [a] -> (Either Error b, [a])
+runParser (Parser f) i = f i
+ 
+instance Functor (Parser a) where
+	(<$>) f m = m >>= \x -> pure (f x)
+
+instance Applicative (Parser a) where
+	pure a	  = Parser \i -> (Right a, i)
+	(<*>) sf p  = sf >>= \sf` -> p >>= \p` -> pure (sf` p`)
+
+instance Monad (Parser a) where
+	(>>=) p f	= Parser \i -> case runParser p i of
+		(Right r, rest) = runParser (f r) rest
+		(Left e, _)	 = (Left e, i)
+
+instance Alternative (Parser a) where
+	empty	   = Parser \i -> (Left $ GenericError "" , i)
+	(<|>) p1 p2 = Parser \i -> case runParser p1 i of
+		(Right r, rest) = (Right r, rest)
+		(Left e1, rest) = case runParser p2 i of
+			(Left e2, rest)  = (Left e2, i)
+			(Right r, rest)  = (Right r, rest)
+
+(<?>) :: (Parser a b) Error -> Parser a b
+(<?>) p e = Parser \i -> case runParser p i of
+	(Left e1, rest) = (Left e, rest)
+	(Right r, rest) = (Right r, rest)
+
+fail :: Parser a b
+fail = empty
+
+top :: Parser a a
+top = Parser \i -> case i of
+	[]	  = (Left $ GenericError "", [])
+	[x:xs]  = (Right x, xs)
+
+peek :: Parser a a
+peek = Parser \i -> case i of
+	[]	  = (Left $ GenericError "", [])
+	[x:xs]  = (Right x, [x:xs])
+
+(until) infix 2 :: (Parser a b) (Parser a c) -> Parser a [b]
+(until) p guard = try $ until` p guard [] 
+	where
+		until` :: (Parser a b) (Parser a c) [b] -> Parser a [b]
+		until` p guard acc = Parser \i -> case runParser guard i of 
+			(Right _, rest) = (Right acc, rest)
+			(Left _, _)	 = case runParser p i of
+				(Right r, rest) = runParser (until` p guard [r:acc]) rest
+				(Left e, _)	 = (Left e, i)
+		try :: (Parser a b) -> Parser a b
+		try p = Parser \i -> case runParser p i of
+			(Left e, _)	 = (Left e, i)
+			(Right r, rest) = (Right r, rest)
+
+satisfy :: (a -> Bool) -> Parser a a
+satisfy f = top >>= \r -> if (f r) (pure r) fail
+
+check :: (a -> Bool) -> Parser a a
+check f = peek >>= \r -> if (f r) (pure r) fail
+
+item :: a -> Parser a a | == a
+item a  = satisfy ((==)a)
+
+list :: [a] -> Parser a [a] | == a
+list as = mapM item as