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
import Data.Func
import Data.List
import StdEnv

import ast

(<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
(<:>) l r = (\xs->[l:xs]) <$> r

:: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTIdent [Char]
derive gEq Token
lex :: [Char] -> Either [String] [Token]
lex [] = pure []
lex ['=':ts] = TTEq <:> lex ts
lex [';':ts] = TTSemiColon <:> lex ts
lex ['\\':ts] = TTLambda <:> lex ts
lex ['.':ts] = TTDot <:> 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
		[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]
		= TTInt (toInt (toString i)) <:> lex ts
	| isIdent t
		# (i, ts) = span isIdent [t:ts]
		= TTIdent i <:> lex ts
	= Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
where
	isIdent c = isAlpha c || isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']

:: Parser a :== StateT ParseState (Either [String]) a
:: ParseState =
	{ tokens :: [Token]
	, infixs :: [(Bool, [Char], Int)]
	}
instance zero ParseState where zero = {tokens=[],infixs=[]}

pTop :: Parser Token
pTop = getState >>= \s->case s.tokens of
	[t:ts] = put {s & tokens=ts} >>| pure t
	[] = liftT (Left ["Fully consumed input"])

pSatisfy :: (Token -> Bool) -> Parser Token
pSatisfy f = pTop >>= \t->if (f t) (pure t) empty

pToken :: (Token -> Parser Token)
pToken = pSatisfy o (===)

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] AST
parse ts = case runStateT pAST {zero & tokens=ts} of
	Right (a, {tokens=[]}) = Right a
	Right (a, _) = Left ["No complete parse result"]
	Left e = Left e
where
	pAST :: Parser AST
	pAST = AST <$> many pFunction

	pId = (\(TTIdent i)->i) <$> pSatisfy (\t->t=:(TTIdent _))
	pOp t` = pId >>= \t->if (t == t`) (pure t) empty

	pFunction :: Parser Function
	pFunction
		=   Function
		<$> pId
		<*> many pId
		<*  pToken TTEq
		<*> pExpression
		<*  pToken TTSemiColon

	pExpression :: Parser Expression
	pExpression = getState >>= \{infixs}->foldr ($) pBasic
		[ pChainl (pure App)
		: [ if ifxr pChainr pChainl $ App o App (Var op) <$ pOp op
		  \\(ifxr, op, _)<-infixs]]

	pBasic :: Parser Expression
	pBasic
		=   Lambda <$ pToken TTLambda <*> pId <* pToken TTDot <*> pExpression
		<|> pToken TTBrackOpen *> pExpression <* pToken TTBrackClose
		<|> (\(TTInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TTInt _))
		<|> (\(TTInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TTInt _))
		<|> (\(TTBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TTBool _))
		<|> Var <$> pId