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

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` ['T','r','u','e':cs] = [BoolToken True:lex` cs]
	lex` ['c','o','d','e':cs] = [CodeToken:lex` cs]
	lex` ['F','a','l','s','e':cs] = [BoolToken True:lex` cs]
	lex` ['i','n','f','i','x','r':cs] = [InfixrToken:lex` cs]
	lex` ['i','n','f','i','x','l':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)

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

:: ParseState =
	{ tokens   :: [Token]
	, infixers :: [Infix]
	}
:: Infix = Infix String Fixity Int
instance < Infix where (<) (Infix _ _ s) (Infix _ _ t) = s < t
:: Fixity = InfixL | InfixR

:: Parser a :== StateT ParseState (Either [String]) a

instance zero ParseState where zero = {tokens=[],infixers=[]}

(<?>) 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 :: [Token] ParseState -> Either [String] AST
parse ts st = 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
		<|> 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
		= (\e op->Apply (Apply fpflip op) e) <$> parseIfx <*> parseExpr
		//Regular Prefix infix
		<|> parseIfx
		//Curried flipped prefix infix
		<|> Apply <$> parseExpr <*> parseIfx
		//Parse regular expression
		<|> parseExpr

	fpflip :: Expression
	fpflip = Lambda "x" $ Lambda "y" $ Lambda "z" $ Apply (Apply (Variable "x") (Variable "z")) (Variable "y")

	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)

Start =
	toString <$> parse (
	lex $
	['id x = x;'] ++
	['const x y = x;'] ++
	['flip x y z = x z y;'] ++
	['. infixr 9 f g x = f $ g x;'] ++
	['$ infixr 0 = id;'] ++
	['& infixr 0 = flip $;'] ++
	['+ infixr 6 = code add;'] ++
	['- infixr 6 = code sub;'] ++
	['* infixr 7 = code mul;'] ++
	['/ infixr 7 = code div;'] ++
	['&& infixl 3 = code and;'] ++
	['|| infixl 2 = code or;'] ++
	['ap = f . g $ x;']
	) zero