start with adts

[minfp.git] / parse.icl

diff --git a/parse.icl b/parse.icl
index 956ca60..50539f8 100644 (file)
--- a/parse.icl
+++ b/parse.icl
@@ -9,17 +9,21 @@ import Data.GenEq
 import Data.Functor
 import Data.Func
 import Data.List
+import Data.Tuple
 import Text.GenPrint
 import StdEnv
 
 import ast
 
+cons x xs = [x:xs]
+
 (<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
-(<:>) l r = (\xs->[l:xs]) <$> r
+(<:>) l r = cons l <$> r
 
 :: Token
        = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose
        | TTComma | TTBool Bool | TTInt Int | TTOp [Char] | TTIdent [Char]
+       | TTDColon | TTPipe
 
 derive gEq Token
 derive gPrint Token
@@ -55,6 +59,8 @@ lex [t:ts]
                | i =: [','] = TTComma <:> lex ts
                | i =: ['.'] = TTDot <:> lex ts
                | i =: ['\\'] = TTLambda <:> lex ts
+               | i =: ['::'] = TTDColon <:> lex ts
+               | i =: ['|'] = TTPipe <:> lex ts
                = TTOp i <:> lex ts
        = Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
 where
@@ -88,12 +94,36 @@ pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
 pChainr :: (Parser (a a -> a)) (Parser a) -> Parser a
 pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
 
-parse :: [Token] -> Either [String] [Function]
+parse :: [Token] -> Either [String] [Either TypeDef Function]
 parse ts = fst <$> runStateT (reverse <$> pAST <* pEof) {tokens=ts, ifxs=[]}
 where
-       pAST :: Parser [Function]
-       pAST = many pFunction >>= mapM \(id, args, body)->Function id args <$
-               modify (\t->{t & tokens=body}) <*> pExpression <* pEof
+       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)
+
+       pTypeDef :: Parser TypeDef
+       pTypeDef = TypeDef
+               <$  pToken TTDColon
+               <*> pId
+               <*> many pId
+               <*  pToken TTEq
+               <*> (cons <$> pCons <*> many (pToken TTPipe *> pCons))
+               <*  pToken TTSemiColon
+
+       pCons = tuple <$> pId <*> many pType
+
+       pType
+               =   TInt  <$ pTop ? (\t->t=:(TTIdent ['Int']))
+               <|> TBool <$ pTop ? (\t->t=:(TTIdent ['Bool']))
+               <|> TVar  <$> pId
+               <|> 
+:: Type
+       = TVar [Char]
+       | TTuple Type Type
+       | TInt
+       | TBool
+       | (-->) infixr 9 Type Type
 
        pId = (\(TTIdent i)->i) <$> pTop ? (\t->t=:(TTIdent _))
        pOp = (\(TTOp i)->i) <$> pTop ? (\t->t=:(TTOp _))
@@ -101,7 +131,7 @@ where
 
        pFunction :: Parser ([Char], [[Char]], [Token])
        pFunction
-               =   (\x y z->(x, y, z))
+               =   tuple3
                <$> (pFunId <|> pId)
                <*> many pId
                <*  pToken TTEq