import Control.Applicative
import Control.Monad
import Data.Either
+import Data.GenEq
import Data.Functor
import Data.Func
+import Data.List
+import Data.Tuple
+import Text.GenPrint
import StdEnv
-import Text.Parsers.Simple.ParserCombinators => qualified parse
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 = TTSemiColon | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTOp [Char] | TTIdent [Char]
+
+derive gEq Token
+derive gPrint Token
-:: Token = TEq | TSemiColon | TLambda | TDot | TBrackOpen | TBrackClose | TBool Bool | TChar Char | TInt Int | TIdent [Char]
+instance toString Token where toString t = printToString t
-lex :: [Char] -> Either [String] [Token]
+lex :: ![Char] -> Either [String] [Token]
lex [] = pure []
-lex ['=':ts] = TEq <:> lex ts
-lex [';':ts] = TSemiColon <:> lex ts
-lex ['\\':ts] = TLambda <:> lex ts
-lex ['.':ts] = TDot <:> lex ts
-lex [')':ts] = TBrackClose <:> lex ts
-lex ['(':ts] = TBrackOpen <:> lex ts
-lex ['True':ts] = TBool True <:> lex ts
-lex ['False':ts] = TBool False <:> lex ts
-lex ['\'',c,'\'':ts] = TChar c <:> lex ts
+lex ['//\n':ts] = lex ts
+lex ['//',t:ts] = lex ['/','/':ts]
+lex ['/**/':ts] = lex $ dropWhile ((<>)'\n') ts
+lex ['/*',t:ts] = lex ['/','*':ts]
+lex [';':ts] = TTSemiColon <:> lex ts
+lex [')':ts] = TTBrackClose <:> lex ts
+lex ['(':ts] = TTBrackOpen <:> lex ts
+lex ['True':ts] = TTBool True <:> lex ts
+lex ['False':ts] = TTBool False <:> lex ts
lex ['-',t:ts]
| isDigit t = lex [t:ts] >>= \v->case v of
- [TInt i:rest] = Right [TInt (~i):rest]
+ [TTInt i:rest] = Right [TTInt (~i):rest]
x = pure x
lex [t:ts]
| isSpace t = lex ts
| isDigit t
- # (i, ts) = span isDigit [t:ts]
- = TInt (toInt (toString i)) <:> lex ts
+ # (d, ts) = span isDigit [t:ts]
+ = TTInt (toInt (toString d)) <:> lex ts
| isAlpha t
- # (i, ts) = span isAlpha [t:ts]
- = TIdent i <:> lex ts
+ # (d, ts) = span isAlpha [t:ts]
+ = TTIdent d <:> lex ts
+ | isOp t
+ # (d, ts) = span isOp [t:ts]
+ = TTOp d <:> lex ts
= Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
+where
+ isOp c = isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']
+
+:: 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 = Parser \ts r->case ts of
+ [t:ts] = (Right t, ts, r)
+ [] = (Left ["Fully consumed input"], ts, r)
+
+pEof :: Parser ()
+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
+
+pToken :: (Token -> Parser Token)
+pToken = (?) pTop o (===)
-parse :: ([Token] -> Either [String] AST)
-parse = 'Text.Parsers.Simple.ParserCombinators'.parse (AST <$> many pFunction)
+pChainl :: (Parser (a a -> a)) (Parser a) -> Parser a
+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] [Either TypeDef Function]
+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
- pId = (\(TIdent i)->i) <$> pSatisfy (\t->t=:(TIdent _))
+ 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
+ <$ pToken (TTOp ['::'])
+ <*> pId
+ <*> many pId
+ <* pToken (TTOp ['='])
+ <*> (cons <$> pCons <*> many (pToken (TTOp ['|']) *> pCons))
+ <* pToken TTSemiColon
+
+ pCons = tuple <$> pId <*> many pType
- pFunction :: Parser Token Function
+ pType = TInt <$ pTop ? (\t->t=:(TTIdent ['Int']))
+ <|> TBool <$ pTop ? (\t->t=:(TTIdent ['Bool']))
+ <|> TVar <$> pId
+ <|> pBrack (pChainr ((-->) <$ pToken (TTOp ['->'])) $ pChainl (pure TApp) pType)
+
+ pId = (\(TTIdent i)->i) <$> pTop ? (\t->t=:(TTIdent _))
+ pOp = (\(TTOp i)->i) <$> pTop ? (\t->t=:(TTOp _))
+ pInt = (\(TTInt i)->i) <$> pTop ? (\t->t=:(TTInt _))
+ pBrack p = pToken TTBrackOpen *> p <* pToken TTBrackClose
+
+ pFunction :: Parser ([Char], [[Char]], [Token])
pFunction
- = Function
- <$> pId
+ = tuple3
+ <$> (pFunId <|> pId)
<*> many pId
- <* pSatisfy (\t->t=:TEq)
- <*> pExpression
- <* pSatisfy (\t->t=:TSemiColon)
-
- pExpression :: Parser Token Expression
- pExpression = flip pChainl1 (pure App) $
- (Lambda <$ pSatisfy (\t->t=:TLambda) <*> pId <* pSatisfy (\t->t=:TDot) <*> pExpression)
- <<|> (pSatisfy (\t->t=:TBrackOpen) *> pExpression <* pSatisfy (\t->t=:TBrackClose))
- <<|> ((\(TInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TInt _)))
- <<|> ((\(TChar i)->Lit (Char i)) <$> pSatisfy (\t->t=:(TChar _)))
- <<|> ((\(TBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TBool _)))
- <<|> (Var <$> pId)
+ <* pToken (TTOp ['='])
+ <*> many (pTop ? ((=!=)TTSemiColon))
+ <* pToken TTSemiColon
+
+ pFunId :: Parser [Char]
+ pFunId = pOp
+ >>= \i->pChainr <$ pId ? ((==) ['ifxr']) <|> pChainl <$ pId ? ((==)['ifxl'])
+ >>= \p->pInt
+ >>= \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 = getIfx >>= \ifxs->flip (foldr ($))
+ (map fst $ sortBy (on (<) snd) ifxs)
+ $ pChainl (pure App)
+ $ Lambda <$ pToken (TTOp ['\\']) <*> pId <* pToken (TTOp ['.']) <*> pExpression
+ <|> pBrack (Var <$> pOp <|> pExpression)
+ <|> Lit o Int <$> pInt
+ <|> (\(TTBool i)->Lit (Bool i)) <$> pTop ? (\t->t=:(TTBool _))
+ <|> (\x->Var ['_':x]) <$ pToken (TTIdent ['code']) <*> pId
+ <|> Var <$> pId
repositories / minfp.git / blobdiff