implementation module parse

import Control.Applicative
import Control.Monad
import Data.Either
import Data.Functor
import Data.Func
import StdEnv
import Text.Parsers.Simple.ParserCombinators => qualified parse

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 | TTChar Char | TTInt Int | TTIdent [Char]

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 ['\'',c,'\'':ts] = TTChar c <:> 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
	| isAlpha t
		# (i, ts) = span isAlpha [t:ts]
		= TTIdent i <:> lex ts
	= Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]

parse :: ([Token] -> Either [String] AST)
parse = 'Text.Parsers.Simple.ParserCombinators'.parse (AST <$> many pFunction)
where
	pId = (\(TTIdent i)->i) <$> pSatisfy (\t->t=:(TTIdent _))

	pFunction :: Parser Token Function
	pFunction
		=   Function
		<$> pId
		<*> many pId
		<*  pSatisfy (\t->t=:TTEq)
		<*> pExpression
		<*  pSatisfy (\t->t=:TTSemiColon)

	pExpression :: Parser Token Expression
	pExpression = flip pChainl1 (pure App) $
		     (Lambda <$ pSatisfy (\t->t=:TTLambda) <*> pId <* pSatisfy (\t->t=:TTDot) <*> pExpression)
		<<|> (pSatisfy (\t->t=:TTBrackOpen) *> pExpression <* pSatisfy (\t->t=:TTBrackClose))
		<<|> ((\(TTInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TTInt _)))
		<<|> ((\(TTChar i)->Lit (Char i)) <$> pSatisfy (\t->t=:(TTChar _)))
		<<|> ((\(TTBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TTBool _)))
		<<|> (Var <$> pId)