implementation module parse

import StdEnv
import qualified _SystemStrictLists as SS
import StdStrictLists
import ast

import Control.Applicative
import Control.Monad
import Control.Monad.State
import Data.Data
import Data.Maybe
import Data.Either
import Data.Func
import Data.Functor
import Data.Bifunctor
import Data.GenCons
import Data.List
import Data.Monoid
import Data.Tuple

derive consName Token, Value

:: Expression | DelayedParse [Token]
:: Token
	= IntToken Int    | BoolToken Bool | CharToken Char | IdentToken String
	| InfixrToken     | InfixlToken    | SemiColonToken | OpenBraceToken
	| CloseBraceToken | EqualsToken    | CodeToken      | LambdaToken
	| ArrowToken      | LetToken       | InToken
:: ParseState = {tokens :: [Token], infixers :: [Infix]}
:: Infix = Infix String Fixity Int
:: Fixity = InfixL | InfixR
:: Parser a :== StateT ParseState (Either [String]) a

instance < Infix where (<) (Infix _ _ s) (Infix _ _ t) = s < t
instance zero ParseState where zero = {tokens=[],infixers=[]}

lex :: [Char] -> [Token]
lex cs = lex` cs
where
	lex` []                            = []
	lex` ['\n':cs]                     = lex` cs
	lex` [c:cs] | isSpace c            = lex` cs
	lex` [';':cs]                      = [SemiColonToken:lex` cs]
	lex` ['=',c:cs] | not (isIdent c)  = [EqualsToken:lex` [c:cs]]
	lex` ['(':cs]                      = [OpenBraceToken:lex` cs]
	lex` [')':cs]                      = [CloseBraceToken:lex` cs]
	lex` ['->':cs]                     = [ArrowToken:lex` cs]
	lex` ['\\':cs]                     = [LambdaToken:lex` cs]
	lex` ['\'',c,'\'':cs]              = [CharToken c:lex` cs]
	lex` ['let':cs]    | whiteOrEnd cs = [LetToken:lex` cs]
	lex` ['in':cs]     | whiteOrEnd cs = [InToken:lex` cs]
	lex` ['code':cs]   | whiteOrEnd cs = [CodeToken:lex` cs]
	lex` ['False':cs]  | whiteOrEnd cs = [BoolToken True:lex` cs]
	lex` ['True':cs]   | whiteOrEnd cs = [BoolToken True:lex` cs]
	lex` ['infixr':cs] | whiteOrEnd cs = [InfixrToken:lex` cs]
	lex` ['infixl':cs] | whiteOrEnd cs = [InfixlToken:lex` cs]
	lex` ['-',c:cs]
		| isDigit c
			= case lex` [c:cs] of
				[IntToken i:ts] = [IntToken (~i):ts]
				ts = ts
	lex` [c:cs]
		| isDigit c
			# (i, cs) = span isDigit [c:cs]
			= [IntToken $ toInt $ toString i:lex` cs]
		| isIdent c
			# (i, cs) = span (\c->isIdent c || isDigit c) cs
			= [IdentToken $ toString [c:i]:lex` cs]
		| isFunny c
			# (i, cs) = span (\c->isFunny c || isDigit c) cs
			= [IdentToken $ toString [c:i]:lex` cs]
		= abort $ "Huh lexer failed on: " +++ toString (toInt c)

whiteOrEnd [] = True
whiteOrEnd [c:cs] = isSpace c

isIdent c = isAlpha c || elem c ['\'`']
isFunny = flip elem ['!@#$%^&*\|+-?/\'<>.:~=']

(<?>) infixl 1 :: a (StateT b (Either (c a)) d) -> StateT b (Either (c a)) d | Semigroup (c a) & Applicative c
(<?>) err p = StateT $ first (flip mappend (pure err)) o runStateT p

top :: Parser Token
top = getState >>= \st=:{tokens}->case tokens of
	[t:ts] = put {st & tokens=ts} >>| pure t
	_ = empty

parseIf :: (a -> Bool) (Parser a) -> Parser a
parseIf pred p = p >>= \a->if (pred a) (pure a) empty

token t :== parseIf ((=+?=)t) top

(until) infix 5 :: (Parser a) (Parser b) -> Parser ([a], b)
(until) p grd = (tuple [] <$> grd) <|> (appFst o 'SS'._cons <$> p <*> p until grd)

parse :: ParseState [Token] -> Either [String] AST
parse st ts = runStateT parseAST {st & tokens=ts} >>= uncurry parse2

parse2 :: AST ParseState -> Either [String] AST
parse2 (AST fs) ps = AST <$> mapM pfun fs
where
	pfun :: Function -> Either [String] Function
	pfun (Function s a (DelayedParse ts)) =
		Function s a <$> evalStateT parseExpr {ps & tokens=ts}
	pfun x = pure x

cons x xs = [x:xs]

parseExpr :: Parser Expression
parseExpr = gets (\s->sort s.infixers)
	>>= foldr ($) parseBasic o (\x xs->[x:xs]) parseApp o map op2parser
where
	op2parser :: Infix -> ((Parser Expression) -> Parser Expression)
	op2parser (Infix sym dir str) = if (dir =: InfixL) parseLOP parseROP
		(\l op->Apply (Apply op l)) $ Variable <$> parseIf ((==)sym) parseIdent

	parseApp :: ((Parser Expression) -> Parser Expression)
	parseApp = parseLOP (const o Apply) (pure ())

	parseLOP :: (a b a -> a) (c b) (c a) -> c a | Alternative c
	parseLOP comb ops prev = foldl (uncurry o comb) <$> prev <*> many (tuple <$> ops <*> prev)

	parseROP :: (a b a -> a) (c b) (c a) -> c a | Monad c & Alternative c
	parseROP comb ops prev = prev >>= \e1->comb e1 <$> ops <*> parseROP comb ops prev <|> pure e1

	parseBasic :: Parser Expression
	parseBasic
		//Bracketed
		=   token OpenBraceToken *> parseBracketed <* token CloseBraceToken
		<|> Let <$> (token LetToken *> parseIdent <* token EqualsToken) <*> (parseExpr <* token InToken) <*> parseExpr
		<|> Literal <$> Int <$> parseInt
		<|> Code <$> (token CodeToken *> parseIdent)
		<|> flip (foldr Lambda) <$> (token LambdaToken *> some parseIdent <* token ArrowToken) <*> parseExpr
		<|> Variable <$> parseWithIfx ((o) not o flip elem)

	parseBracketed :: Parser Expression
	parseBracketed
		//Curried prefix infix
		= (\op->Lambda "_v" o Apply (Apply op (Variable "v"))) <$> parseIfx <*> parseExpr
		//Regular Prefix infix
		<|> parseIfx
		//Curried flipped prefix infix
		<|> (\e op->Lambda "_v" (Apply (Apply op e) (Variable "v"))) <$> parseExpr <*> parseIfx
		//Parse regular expression
		<|> parseExpr

	parseWithIfx :: ([String] String -> Bool) -> Parser String
	parseWithIfx f = gets (\s->[i\\Infix i _ _<-s.infixers]) >>= flip parseIf parseIdent o f

	parseIfx :: Parser Expression
	parseIfx = Variable <$> parseWithIfx (flip elem)

parseAST :: Parser AST
parseAST = AST <$> many parseFunction

parseFunction :: Parser Function
parseFunction = Function
	<$> (parseIdent >>= \ident->(parseFixity ident <|> pure ()) >>| pure ident)
	<*> many parseIdent
	<*> (DelayedParse o fst <$> (token EqualsToken *> top until token SemiColonToken))

parseFixity :: String -> Parser ()
parseFixity ident = Infix ident
	<$> (token InfixrToken *> pure InfixR <|> token InfixlToken *> pure InfixL)
	<*> parseInt
	>>= \f->modify \s->{s & infixers=[f:s.infixers]}

parseIdent :: Parser String
parseIdent = (\(IdentToken s)->s) <$> token (IdentToken "")

parseInt :: Parser Int
parseInt = (\(IntToken i)->i) <$> token (IntToken 0)