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
+ :: Token = TTSemiColon | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int
+ | TTOp [Char] | TTIdent [Char]
derive gEq Token
derive gPrint Token
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
++ <$ pToken (TTOp ['::'])
+ <*> pId
+ <*> many pId
- <* pToken TTEq
- <*> (cons <$> pCons <*> many (pToken TTPipe *> pCons))
++ <* pToken (TTOp ['='])
++ <*> (cons <$> pCons <*> many (pToken (TTOp ['|']) *> 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 _))
pFunction :: Parser ([Char], [[Char]], [Token])
pFunction
- = (\x y z->(x, y, z))
+ = tuple3
<$> (pFunId <|> pId)
<*> many pId
- <* pToken TTEq
+ <* pToken (TTOp ['='])
<*> many (pTop ? ((=!=)TTSemiColon))
<* pToken TTSemiColon