own parser combinators

diff --git a/Makefile b/Makefile
index d95f482..df14afd 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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