module p

import StdEnv

import Data.Func
import Data.Functor
import Data.Tuple
import Data.Maybe
import Control.Applicative
import Control.Monad

:: Parser m a = Parser (ParseState -> m (a, ParseState))
:: ParseState =
	{ tokens   :: [Char]
	, infixers :: [Infixer]
	}
:: Infixer = Infxer Bool Int [Char]

runParser :: (Parser m a) -> (ParseState -> m (a, ParseState))
runParser (Parser a) = a

instance Functor (Parser m) | Monad m where fmap a b = liftM a b
instance pure (Parser m) | Monad m where pure a = Parser (pure o tuple a)
instance <*> (Parser m) | Monad m where (<*>) a b = ap a b
instance <* (Parser m) | Monad m
instance *> (Parser m) | Monad m
instance Monad (Parser m) | Monad m where
	bind ma a2mb = Parser \c->runParser ma c >>= uncurry (runParser o a2mb)
instance Alternative (Parser m) | Alternative m where
	empty = Parser (pure empty)
	(<|>) l r = Parser \c->runParser l c <|> runParser r c

get :: Parser m ParseState | Alternative, Monad m
get = Parser \c->pure (c, c)

set :: ParseState -> Parser m () | Alternative, Monad m
set c = Parser \_->pure ((), c)

upd :: (ParseState -> ParseState) -> Parser m () | Alternative, Monad m
upd f = f <$> get >>= set

pTop :: Parser m Char | Alternative, Monad m
pTop = get >>= \c->case c.tokens of
	[] = empty
	[t:ts] = set {c & tokens=ts} *> pure t

pSatisfy :: (Char -> Bool) -> Parser m Char | Alternative, Monad m
pSatisfy f = pTop >>= \t->if (f t) (pure t) empty

pToken :: Char -> Parser m Char | Alternative, Monad m
pToken c = pSatisfy ((==)c)

(<:>) infixr 1
(<:>) l r :== (\x xs->[x:xs]) <$> l <*> r

pTokens :: [Char] -> Parser m [Char] | Alternative, Monad m
pTokens ts = foldr (<:>) (pure []) (map pToken ts)

pChainL :: (Parser m (a a -> a)) (Parser m a) -> Parser m a | Alternative, Monad m
pChainL op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)

:: Program :== [([Char], Expr)]
:: Expr
	= Var [Char]
	| Lit Int
	| BinOp [Char] Expr Expr

pProgram :: Parser m Program | Alternative, Monad m
pProgram = many pDecl

pDecl :: Parser m ([Char], Expr) | Alternative, Monad m
pDecl = tuple <$> many (pSatisfy isAlpha) <* pToken '=' <*> pExpr <* pToken '\n'

pInfixer :: Parser m Program | Alternative, Monad m
pInfixer = Infxer o (==) 'r' <$ pTokens ['ifx'] <*> (pToken 'r' <|> pToken 'l') <*> pLit <*> many (pSatisfy isOpChar)
	>>= \_->pure []

pExpr :: Parser m Expr | Alternative, Monad m
pExpr = pChainL (BinOp <$> pTokens ['+']) $
	    Lit <$> pLit
	<|> Var <$> many (pSatisfy isAlpha)
	<|> pToken '(' *> pExpr <* pToken ')'

pLit :: Parser m Int | Alternative, Monad m
pLit = ((~) <$ pToken '-' <|> pure id) <*>
	(toInt <$> toString <$> some (pSatisfy isDigit))

isOpChar :: Char -> Bool
isOpChar c = isMember c ['-+*/%@#$^&=|\'']

printProgram :: [([Char], Expr)] -> String
printProgram p = foldr (+++) ""
	[toString c +++ "=" +++ printExpr e\\(c, e)<-p]

printExpr :: Expr -> String
printExpr (Var i) = toString i
printExpr (Lit i) = toString i
printExpr (BinOp o l r) = "(" +++ printExpr l +++ toString o +++ printExpr r +++ ")"

Start :: Maybe (String, ParseState)
Start = appFst printProgram <$> runParser pProgram {tokens=['y=x+4\n'],infixers=[]}