module StateParser where

infixl 2 `opt`
infixl 3 <|>, <||>
infixl 4 <$>, <$, <*>, *>, <*, <**>, <??>, <->>

newtype Parser s t a = P (s -> [t] -> [(a,s,[t])])

instance Monad (Parser s t) where
  return = pSucceed
  fail _ = pFail
  (>>=)  = (<->>)

parse :: Parser s t a -> s -> [t] -> [(a,s,[t])]
parse (P p) = p


modify :: (s -> s) -> Parser s t s
modify upd = P (\s ts -> [(s,upd s,ts)])

fetch :: Parser s t s
fetch = modify id

store :: s -> Parser s t s
store = modify . const


pSucceed :: a -> Parser s t a
pSucceed v = P (\s ts -> [(v,s,ts)])

pFail :: Parser s t a
pFail = P (\_ _ -> [])

pPred :: (t -> Bool) -> Parser s t t
pPred pred = P p
 where
  p _ [] = []
  p s (t:ts)
    | pred t    = [(t,s,ts)]
    | otherwise = []

pSym :: Eq t => t -> Parser s t t
pSym t = pPred (t==)

pAnyOf :: Eq t => [t] -> Parser s t t
pAnyOf = foldr (<|>) pFail . map pSym

opt :: Parser s t a -> a -> Parser s t a
p `opt` x = p <|> pSucceed x

(<|>) :: Parser s t a -> Parser s t a -> Parser s t a
P p <|> P q = P (\s ts -> p s ts ++ q s ts)

(<||>) :: Parser s t a -> Parser s t a -> Parser s t a
P p <||> P q = P (\s ts -> let res = p s ts in if null res then q s ts else res)

(<*>) :: Parser s t (a -> b) -> Parser s t a -> Parser s t b
P p <*> P q
  = P (\s ts -> [ (f x,s2,ts2) | (f,s1,ts1) <- p s ts, (x,s2,ts2) <- q s1 ts1 ])

(<$>) :: (a -> b) -> Parser s t a -> Parser s t b
f <$> p = pSucceed f <*> p

(<$) :: a -> Parser s t b -> Parser s t a
f <$ p = const f <$> p

(*>) :: Parser s t a -> Parser s t b -> Parser s t b
p *> q = const id <$> p <*> q

(<*) :: Parser s t a -> Parser s t b -> Parser s t a
p <* q = flip (const id) <$> p <*> q

(<**>) :: Parser s t a -> Parser s t (a -> b) -> Parser s t b
p <**> q = flip ($) <$> p <*> q

(<??>) :: Parser s t a -> Parser s t (a->a) -> Parser s t a
p <??> q = p <**> (q `opt` id)

pFoldr :: (a -> b -> b) -> b -> Parser s t a -> Parser s t b
pFoldr op e p = q where q = (op <$> p <*> q) `opt` e

pFoldrSep :: (a -> b -> b) -> b -> Parser s t c -> Parser s t a -> Parser s t b
pFoldrSep op e sep p = (op <$> p <*> pFoldr op e (sep *> p)) `opt` e

pList :: Parser s t a -> Parser s t [a]
pList = pFoldr (:) []

pListSep :: Parser s t a -> Parser s t b -> Parser s t [b]
pListSep = pFoldrSep (:) []

pSome :: Parser s t a -> Parser s t [a]
pSome p = (:) <$> p <*> pList p

(<->>) :: Parser s t a -> (a -> Parser s t b) -> Parser s t b
P p <->> f
  = P (\s ts -> [ res | (x,s',ts') <- p s ts, res <- parse (f x) s' ts' ])

check :: (a -> Bool) -> Parser s t a -> Parser s t a
check pred (P p) = P (\s ts -> filter (pred.(\ (x,_,_) -> x)) (p s ts))