From e25f34bbaa5f147dcee7b68397de85ffacdf76c3 Mon Sep 17 00:00:00 2001
From: Camil Staps
Date: Wed, 22 Nov 2017 09:19:47 +0100
Subject: Add parser

---
 pf.icl | 114 +++++++++++++++++++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 97 insertions(+), 17 deletions(-)

(limited to 'pf.icl')

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)
-- 
cgit v1.2.3