import Control.Applicative
import Control.Monad
-import Control.Monad.State
-import Control.Monad.Trans
import Data.Either
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 = TTSemiColon | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTOp [Char] | TTIdent [Char]
-:: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTOp [Char] | TTIdent [Char]
derive gEq Token
-instance toString Token where toString t = printToString t
derive gPrint Token
-lex :: [Char] -> Either [String] [Token]
+
+instance toString Token where toString t = printToString t
+
+lex :: ![Char] -> Either [String] [Token]
lex [] = pure []
+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 [t:ts]
| isSpace t = lex ts
| isDigit t
- # (i, ts) = span isDigit [t:ts]
- = TTInt (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]
- = TTIdent i <:> lex ts
+ # (d, ts) = span isAlpha [t:ts]
+ = TTIdent d <:> lex ts
| isOp t
- # (i, ts) = span isOp [t:ts]
- | i =: ['='] = TTEq <:> lex ts
- | i =: ['.'] = TTDot <:> lex ts
- | i =: ['\\'] = TTLambda <:> lex ts
- = TTOp i <:> lex ts
+ # (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 :== 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"])
+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
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 ts = fst <$> runStateT (pAST <* pEof) {tokens=ts, ifxs=[]}
+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
- pAST :: Parser [Function]
- pAST = many pFunction >>= mapM \(id, args, body)->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
+ <$ pToken (TTOp ['::'])
+ <*> pId
+ <*> many pId
+ <* 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
+ <|> 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
- = (\x y z->(x, y, z))
+ = tuple3
<$> (pFunId <|> pId)
<*> many pId
- <* pToken TTEq
+ <* pToken (TTOp ['='])
<*> many (pTop ? ((=!=)TTSemiColon))
<* pToken TTSemiColon
pFunId :: Parser [Char]
pFunId = pOp
>>= \i->pChainr <$ pId ? ((==) ['ifxr']) <|> pChainl <$ pId ? ((==)['ifxl'])
- >>= \p->(\(TTInt i)->i) <$> pTop ? (\t->t=:(TTInt _))
- >>= \s->modify (\t->{t & ifxs=[(p (App o App (Var i) <$ pOp ? ((==)i)), s):t.ifxs]})
- >>| pure i
+ >>= \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 = getState >>= \{ifxs}->flip (foldr ($))
+ pExpression = getIfx >>= \ifxs->flip (foldr ($))
(map fst $ sortBy (on (<) snd) ifxs)
$ pChainl (pure App)
- $ Lambda <$ pToken TTLambda <*> pId <* pToken TTDot <*> pExpression
- <|> pToken TTBrackOpen *> pExpression <* pToken TTBrackClose
- <|> Lit o Int <$> (\(TTInt i)->i) <$> pTop ? (\t->t=:(TTInt _))
+ $ 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