Add parser

3 files changed, 269 insertions, 17 deletions

diff --git a/Yard.dcl b/Yard.dcl
new file mode 100644
index 0000000..9e42b22
--- /dev/null
+++ b/Yard.dcl
@@ -0,0 +1,55 @@
+definition module Yard
+
+// Taken from https://github.com/dopefishh/cc1516/blob/master/yard.dcl
+// To this file, an other license applies:
+
+/*
+The MIT License (MIT)
+
+Copyright (c) 2016 Pim Jager & Mart Lubbers
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
+of the Software, and to permit persons to whom the Software is furnished to do
+so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+*/
+
+from StdString import class toString
+from Data.Either import :: Either
+from StdClass import class ==, class Eq
+from Data.Functor import class Functor
+from Control.Monad import class Monad
+from Control.Applicative import class Applicative, class Alternative
+from Data.Void import :: Void
+
+:: Parser a b = Parser ([a] -> (Either String b, [a]))
+
+instance Functor (Parser a)
+instance Applicative (Parser a) 
+instance Monad (Parser a)
+instance Alternative (Parser a)
+
+runParser :: (Parser a b) [a] -> (Either String b, [a])
+(<?>) :: (Parser a b) String -> 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 | Eq a
+list :: [a] -> Parser a [a] | Eq a
+eof :: Parser a Void
diff --git a/Yard.icl b/Yard.icl
new file mode 100644
index 0000000..b57f1fa
--- /dev/null
+++ b/Yard.icl
@@ -0,0 +1,117 @@
+implementation module Yard
+
+// Taken from https://github.com/dopefishh/cc1516/blob/master/yard.icl
+// To this file, an other license applies:
+
+/*
+The MIT License (MIT)
+
+Copyright (c) 2016 Pim Jager & Mart Lubbers
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
+of the Software, and to permit persons to whom the Software is furnished to do
+so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+*/
+
+import StdTuple
+import StdClass
+import StdString
+import StdList
+import StdInt
+from Data.List import intersperse
+from Text import instance Text String, class Text(concat)
+import Data.Functor
+import Data.Either
+import Control.Monad
+import Control.Applicative
+from Data.Func import $
+import Data.Void
+
+runParser :: (Parser a b) [a] -> (Either String b, [a])
+runParser (Parser f) i = f i
+ 
+instance Functor (Parser a) where fmap f m = liftM f m
+
+instance Applicative (Parser a)
+where
+	pure a	  = Parser \i -> (Right a, i)
+	(<*>) sf p  = ap sf p
+
+instance Monad (Parser a)
+where
+	bind 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 "" , 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)
+
+//Try parser, if it fails decorate the error with the given String and position
+(<?>) :: (Parser a b) String -> 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 "", [])
+	[x:xs]  = (Right x, xs)
+
+peek :: Parser a a
+peek = Parser \i -> case i of
+	[]	  = (Left "", [])
+	[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)
+
+eof :: Parser a Void
+eof = Parser \i -> case i of 
+	[]	= (Right Void, [])
+	_	= (Left "", i)
+
+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 | Eq a
+item a  = satisfy ((==)a)
+
+list :: [a] -> Parser a [a] | Eq a
+list as = mapM item as
diff --git a/pf.icl b/pf.icl
index 7055898..a548922 100644
--- a/pf.icl
+++ b/pf.icl
@@ -1,7 +1,21 @@
 module pf
 
-import StdEnv
+import StdBool
+from StdFunc import flip
+import StdMisc
+import StdString
+
+import GenEq
+
+import Control.Applicative
+import Control.Monad
+import Data.Either
+from Data.Func import $
+import Data.Functor
 import Data.List
+import Data.Maybe
+
+import Yard
 
 :: Expr
 	= Lambda Ident Expr
@@ -15,6 +29,71 @@ import Data.List
 
 :: Ident :== String
 
+:: Token
+	= TBackSlash
+	| TParenOpen
+	| TParenClose
+	| TArrow
+	| TBool Bool
+	| TInt Int
+	| TIdent Ident
+
+derive gEq Token; instance == Token where == a b = a === b
+
+tokenize :: ([Char] -> [Token])
+tokenize = flip tok []
+where
+	tok :: [Char] [Token] -> [Token]
+	tok []           tks = reverse tks
+	tok ['\\':cs]    tks = tok cs [TBackSlash:tks]
+	tok ['(':cs]     tks = tok cs [TParenOpen:tks]
+	tok [')':cs]     tks = tok cs [TParenClose:tks]
+	tok ['-':'>':cs] tks = tok cs [TArrow:tks]
+	tok ['T':'r':'u':'e':cs]     tks = tok cs [TBool True:tks]
+	tok ['F':'a':'l':'s':'e':cs] tks = tok cs [TBool False:tks]
+	tok [c:cs]       tks
+	| isSpace c          = tok cs tks
+	| isDigit c          = tok rest [TInt (toInt (toString digs)):tks]
+		with (digs,rest) = span isDigit [c:cs]
+	| isIdentChar c      = tok rest [TIdent (toString ids):tks]
+		with (ids,rest) = span isIdentChar [c:cs]
+
+	isIdentChar :: Char -> Bool
+	isIdentChar c = isAlpha c || c == '_'
+
+parse :: String -> Maybe Expr
+parse s = case runParser expr (tokenize $ fromString s) of
+	(Right e, []) -> Just e
+	_             -> Nothing
+where
+	simple :: Parser Token Expr
+	simple = liftM2 lambda (item TBackSlash *> some ident <* item TArrow) expr
+		<|> Literal <$> LitInt  <$> int
+		<|> Literal <$> LitBool <$> bool
+		<|> item TParenOpen *> expr <* item TParenClose
+		<|> Ident <$> ident
+	where
+		lambda :: [Ident] Expr -> Expr
+		lambda [x]    e = Lambda x e
+		lambda [x:xs] e = Lambda x (lambda xs e)
+
+	expr :: Parser Token Expr
+	expr = liftM2 (\f xs -> app [Ident f:xs]) ident (some simple)
+		<|> simple
+	where
+		app :: [Expr] -> Expr
+		app [e] = e
+		app es = app (init es) @ last es
+
+	ident :: Parser Token Ident
+	ident = (\(TIdent t) -> t) <$> satisfy (\t -> t=:(TIdent _))
+
+	int :: Parser Token Int
+	int = (\(TInt i) -> i) <$> satisfy (\t -> t=:(TInt _))
+
+	bool :: Parser Token Bool
+	bool = (\(TBool b) -> b) <$> satisfy (\t -> t=:(TBool _))
+
 hasIdent :: Ident Expr -> Bool
 hasIdent id (Ident n) = id == n
 hasIdent id (Literal _) = False
@@ -75,21 +154,22 @@ moveOutside id (f @ x)
 moveOutside _ (Lambda x e) = Lambda x e // TODO
 
 Start = map do
-	[ Lambda "x" (Literal (LitInt 5))
-	, Lambda "x" (Ident "x")
-	, Lambda "x" (Ident "y")
-	, Lambda "x" (Lambda "y" (Ident "x"))
-	, Lambda "x" (Lambda "y" (Ident "y"))
-	, Lambda "x" (Lambda "y" (Literal (LitInt 37)))
-	, Lambda "x" (Lambda "y" (Lambda "z" (Ident "x")))
-	, Lambda "x" (Lambda "y" (Lambda "z" (Ident "y")))
-	, Lambda "x" (Lambda "y" (Lambda "z" (Ident "z")))
-	, Lambda "x" (Lambda "y" (Lambda "z" (Literal (LitInt 37))))
-	, Lambda "x" (Lambda "y" (Ident "x" @ Ident "y"))
-	, Lambda "x" (Lambda "y" (Ident "y" @ Ident "x"))
-	, Lambda "x" (Lambda "y" (Ident "y" @ Literal (LitInt 10)))
-	, Lambda "f" (Lambda "a" (Lambda "b" (Lambda "c" (Lambda "d" (Ident "f" @ Ident "b" @ Ident "c" @ Ident "d" @ Ident "a")))))
-	, Lambda "f" (Lambda "x" (Ident "f" @ Ident "x" @ Ident "x"))
+	[ "\\x -> 5"
+	, "\\x -> x"
+	, "\\x -> y"
+	, "\\x y -> x"
+	, "\\x y -> y"
+	, "\\x y -> 37"
+	, "\\x y z -> x"
+	, "\\x y z -> y"
+	, "\\x y z -> z"
+	, "\\x y z -> 37"
+	, "\\x y -> x y"
+	, "\\x y -> y x"
+	, "\\x y -> y 10"
+	, "\\f a b c d -> f b c d a"
+	, "\\f x -> f x x"
 	]
 where
-	do e = (print e, " ==> ", print (optim e), "\n")
+	do e = (print pe, " ==> ", print (optim pe), "\n")
+	where pe = fromJust (parse e)