implementation module parse

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 ast

cons x xs = [x:xs]

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

:: Token = TTSemiColon | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTOp [Char] | TTIdent [Char]

derive gEq Token
derive gPrint 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 ['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
		# (d, ts) = span isDigit [t:ts]
		= TTInt (toInt (toString d)) <:> lex ts
	| isAlpha t
		# (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 (===)

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
	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
		=   tuple3
		<$> (pFunId <|> pId)
		<*> many 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