From ad0344719a1bdca89e01822f83e49905f7475fb0 Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Wed, 27 Mar 2019 15:10:58 +0100
Subject: [PATCH] own parser combinators

---
 Makefile           |  7 +++++-
 minfp.icl          |  4 +---
 parse.icl          | 60 +++++++++++++++++++++++++++-------------------
 tests/preamble.mfp |  2 ++
 4 files changed, 45 insertions(+), 28 deletions(-)

diff --git a/Makefile b/Makefile
index d95f482..df14afd 100644
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,5 @@
 CLM?=clm
-CLMFLAGS?=-nr -pt
+CLMFLAGS?=-nr -aC,-generic_fusion
 CLMLIBS?=-IL Platform
 
 all: minfp
@@ -7,5 +7,10 @@ all: minfp
 %: %.icl
 	$(CLM) $(CLMLIBS) $(CLMFLAGS) $* $(OUTPUT_OPTION)
 
+%.prj:
+	cpm project $* create
+	cpm project $@ set -pt
+	cpm project $@ path add "$$CLEAN_HOME/lib/Platform"
+
 clean:
 	$(RM) -r "Clean System Files" main
diff --git a/minfp.icl b/minfp.icl
index 6036ffd..8673436 100644
--- a/minfp.icl
+++ b/minfp.icl
@@ -46,10 +46,8 @@ Start w
 		MLex = map (nl o toString) <$> lex cs
 		MParse = map (nl o either toString toString) <$> (lex cs >>= parse)
 		MType = map (\(t, s)->nl (toString t +++ " :: " +++ toString s)) o snd <$> (lex cs >>= parse >>= check)
-		MInterpret = pure o toString <$> (lex cs >>= parse >>= check >>= int o fst)
+		MInterpret = pure o nl o toString <$> (lex cs >>= parse >>= check >>= int o fst)
 		MGen = lex cs >>= parse >>= check >>= gen o fst
 	= exit (either (\_->1) (\_->0) mstr) (either id id mstr) io w
 
 nl x = x +++ "\n"
-
-
diff --git a/parse.icl b/parse.icl
index b812ef9..00e0c26 100644
--- a/parse.icl
+++ b/parse.icl
@@ -2,8 +2,6 @@ implementation module parse
 
 import Control.Applicative
 import Control.Monad
-import Control.Monad.State
-import Control.Monad.Trans
 import Data.Either
 import Data.GenEq
 import Data.Functor
@@ -20,8 +18,7 @@ cons x xs = [x:xs]
 (<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
 (<:>) l r = cons l <$> r
 
-:: Token = TTSemiColon | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int
-	| TTOp [Char] | TTIdent [Char]
+:: Token = TTSemiColon | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTOp [Char] | TTIdent [Char]
 
 derive gEq Token
 derive gPrint Token
@@ -58,21 +55,33 @@ lex [t:ts]
 where
 	isOp c = isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']
 
-:: Parser a :== StateT ParseState (Either [String]) a
-:: ParseState =
-	{ tokens :: [Token]
-	, ifxs   :: [((Parser Expression) -> Parser Expression, Int)]
-	}
+:: Parser a = Parser ([Token] IfxInfo -> (Either [String] a, [Token], IfxInfo))
+:: IfxInfo :== [((Parser Expression) -> Parser Expression, Int)]
+runParser (Parser a) = a
+instance Functor Parser where fmap f a = liftM f a
+instance pure Parser where pure a = Parser \ts r->(Right a, ts, r)
+instance <*> Parser where (<*>) a b = ap a b
+instance <* Parser
+instance *> Parser
+instance Monad Parser where
+	bind ma a2mb = Parser \t r->case runParser ma t r of
+		(Left e, ts, r) = (Left e, ts, r)
+		(Right a, ts, r) = runParser (a2mb a) ts r
+instance Alternative Parser where
+	empty = Parser \ts r->(Left [], ts, r)
+	(<|>) p1 p2 = Parser \ts r->case runParser p1 ts r of
+		(Left e, _, _) = runParser p2 ts r
+		a = a
 
 pTop :: Parser Token
-pTop = getState >>= \s->case s.tokens of
-	[t:ts] = put {s & tokens=ts} >>| pure t
-	[] = liftT (Left ["Fully consumed input"])
+pTop = Parser \ts r->case ts of
+	[t:ts] = (Right t, ts, r)
+	[] = (Left ["Fully consumed input"], ts, r)
 
 pEof :: Parser ()
-pEof = getState >>= \s->case s.tokens of
-	[] = pure ()
-	[t:ts] = liftT (Left ["Expected EOF but got ":map toString [t:ts]])
+pEof = Parser \ts r->case ts of
+	[] = (Right (), [], r)
+	_ = (Left ["Expected EOF but got ":map toString ts], ts, r)
 
 (?) infixl 9 :: (Parser a) (a -> Bool) -> Parser a
 (?) p f = p >>= \v->if (f v) (pure v) empty
@@ -87,12 +96,13 @@ pChainr :: (Parser (a a -> a)) (Parser a) -> Parser a
 pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
 
 parse :: [Token] -> Either [String] [Either TypeDef Function]
-parse ts = fst <$> runStateT (reverse <$> pAST <* pEof) {tokens=ts, ifxs=[]}
+parse ts = case runParser (many (Right <$> pFunction <|> Left <$> pTypeDef) <* pEof) ts [] of
+	(Left e, _, _) = Left e
+	(Right a, _, r) = sequence [reparse r a\\a<-a]
 where
-	pAST :: Parser [Either TypeDef Function]
-	pAST = many (Right <$> pFunction <|> Left <$> pTypeDef)
-		>>= mapM (either (pure o Left) \(id, args, body)->Right o
-			Function id args <$ modify (\t->{t & tokens=body}) <*> pExpression <* pEof)
+	reparse r (Left e) = pure (Left e)
+	reparse r (Right (id, args, body))
+		= Right <$> fst3 (runParser (Function id args <$> pExpression <* pEof) body r)
 
 	pTypeDef :: Parser TypeDef
 	pTypeDef = TypeDef
@@ -109,7 +119,7 @@ where
 		=   TInt  <$ pTop ? (\t->t=:(TTIdent ['Int']))
 		<|> TBool <$ pTop ? (\t->t=:(TTIdent ['Bool']))
 		<|> TVar  <$> pId
-//		<|> 
+		<|> pBrack pType
 
 	pId = (\(TTIdent i)->i) <$> pTop ? (\t->t=:(TTIdent _))
 	pOp = (\(TTOp i)->i) <$> pTop ? (\t->t=:(TTOp _))
@@ -129,11 +139,13 @@ where
 	pFunId = pOp
 		>>= \i->pChainr <$ pId ? ((==) ['ifxr']) <|> pChainl <$ pId ? ((==)['ifxl'])
 		>>= \p->pInt
-		>>= \s->modify (\t->{t & ifxs=[(p (App o App (Var i) <$ pOp ? ((==)i)), s):t.ifxs]})
-		>>| pure i
+		>>= \s->addIfx i (p (App o App (Var i) <$ pOp ? ((==)i)), s)
+
+	addIfx a i = Parser \ts r->(Right a, ts, [i:r])
+	getIfx = Parser \ts r->(Right r, ts, r)
 
 	pExpression :: Parser Expression
-	pExpression = getState >>= \{ifxs}->flip (foldr ($))
+	pExpression = getIfx >>= \ifxs->flip (foldr ($))
 			(map fst $ sortBy (on (<) snd) ifxs)
 		$   pChainl (pure App)
 		$   Lambda <$ pToken (TTOp ['\\']) <*> pId <* pToken (TTOp ['.']) <*> pExpression
diff --git a/tests/preamble.mfp b/tests/preamble.mfp
index 1ddd4e2..250ceb1 100644
--- a/tests/preamble.mfp
+++ b/tests/preamble.mfp
@@ -1,3 +1,5 @@
+:: List a = Nil Int;
+
 //Function application
 $ ifxr 0 x y = x y;
 //Reverse function application
-- 
2.20.1