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

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` ['\'',c,'\'':cs] = [CharToken c:lex` cs]
	lex` ['T','r','u','e':cs] = [BoolToken True: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]

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

:: 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)
	>>= flip seq parseBasic o cons parseApp o reverse o map op2parser
where
	op2parser (Infix sym dir str) = if (dir =: InfixL) parseLOP parseROP
		(\l op->Apply $ Apply op l) (Variable <$> parseIf ((==)sym) parseIdent)

	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
		=   (token OpenBraceToken *> parseExpr <* token CloseBraceToken)
		<|> Literal <$> Int <$> parseInt
		<|> (gets (\s->[i\\Infix i _ _<-s.infixers])
			>>= \ifs->Variable <$> parseIf (not o flip elem ifs) parseIdent)

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 ['+ infixr 6 a b = 0; * infixr 7 a b = 0; ap = a + b * c + d;']) zero