module a7

import StdEnv

import qualified Data.Map as Map

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

:: Gram
	= Lit String
	| Idn
	| Int
	| Seq [Gram]
	| Alt [Gram]
	| Def Name Gram Gram
	| Var Name
:: Name :== String
:: State = {input :: [String], store :: Store}
:: Store :== 'Map'.Map Name Gram
:: Parse a = Parse (State -> (Maybe a, State))
:: TREE = LIT String | IDN String | INT Int | SEQ [TREE]

runParse :: (Parse a) -> (State -> (Maybe a, State))
runParse (Parse a) = a

instance Functor Parse where fmap f a = Parse (appFst (fmap f) <$> runParse a)
instance Applicative Parse
where
	pure a = Parse (tuple (pure a))
	<*> fab fb = Parse \s->let
		   (mab, (mb, s`)) = appSnd (runParse fb) (runParse fab s)
		in (mab <*> mb, s`)
instance Monad Parse
where
	bind ma a2mb = Parse \s->case runParse ma s of
		(Just a, s`) = runParse (a2mb a) s`
		(Nothing, s`) = (Nothing, s`)

instance Alternative Parse
where
	empty = Parse (tuple Nothing)
	<|> ma mb = Parse \s->case runParse ma s of
		(Nothing, _) = runParse mb s
		t = t

next :: Parse String
next = Parse \s->case s.input of
	[] = (Nothing, s)
	[i:is] = (Just i, {s & input=is})

setGram :: Name Gram -> Parse Gram
setGram n g = Parse \s->(Just g, {s & store='Map'.put n g s.store})

getGram :: Name -> Parse Gram
getGram n = Parse \s->('Map'.get n s.store, s)

(?) infix 5 :: (a -> Bool) (Parse a) -> Parse a
(?) p pa = pa >>= \a->if (p a) (pure a) empty

parse :: Gram -> Parse TREE
parse (Lit s) = LIT <$> ((==)s) ? next
parse Idn = IDN <$> (\s->isAlpha s.[0]) ? next
parse Int = INT o toInt <$> (\s->toString (toInt s) == s) ? next
parse (Seq gs) = SEQ <$> sequence (map parse gs)
parse (Alt as) = foldr (<|>) empty (map parse as)
parse (Def n g1 g2) = setGram n g1 *> parse g2
parse (Var n) = getGram n >>= parse
parse _ = empty

run :: Gram [String] -> Maybe TREE
run g t = fst (runParse (parse g) {store='Map'.newMap,input=t})

Start = (evalList <$> run listIntGram listIntInput, evalArith <$> run arithGram arithInput)
where
	listIntInput = ["mylist","=","[","7",":","[","42",":","[]","]","]"]
	arithInput = ["12","*","2","+","4","*","3","*","2","-","6"]

listIntGram :: Gram
listIntGram
	= Def "list" (Alt [Lit "[]",Seq [Lit "[",Int,Lit ":",Var "list",Lit "]"]])
	$ Seq [Idn,Lit "=",Var "list"]

arithGram :: Gram
arithGram
	= Def "fac" (Alt [Seq [Int, Lit "*", Var "fac"], Int])
	$ Def "exp" (Alt [Seq [Var "fac", Lit "+", Var "exp"], Var "fac"])
	$ Var "exp"

evalList :: TREE -> Maybe [Int]
evalList (LIT "[]") = Just []
evalList (SEQ [LIT "[", INT i, LIT ":", r, LIT "]"]) = evalList r >>= \r->pure [i:r]
evalList (SEQ [IDN _, LIT "=", l]) = evalList l
evalList _ = Nothing

evalArith :: TREE -> Maybe Int
evalArith (INT i) = Just i
evalArith (SEQ [a, LIT op, b]) = toOp op <*> evalArith a <*> evalArith b
where
	toOp :: String -> Maybe (Int Int -> Int)
	toOp "+" = Just (+)
	toOp "*" = Just (*)
	toOp _ = Nothing
evalArith _ = Nothing