{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
module Recognize.Parsing.Parser
( Parser, runParser
, ParserT, runParserT
) where
import Debug.Trace
import Control.Applicative
import Control.Monad
import Control.Monad.Identity
import Control.Monad.State
import Data.Maybe
import Recognize.Parsing.Parse
import Ideas.Utils.Prelude
newtype ParserT st s m a = PT { runParserT :: st -> [s] -> m [(a, st, [s])] }
instance MonadTrans (ParserT st s) where
lift m = PT $ \st ss -> do
a <- m
return [(a, st, ss)]
instance Monad m => Functor (ParserT st s m) where
fmap f p = return f <*> p
instance Monad m => Applicative (ParserT st s m) where
pure a = PT $ \st ss -> return [(a, st, ss)]
p <*> q = bind ($) p (const q)
instance Monad m => Monad (ParserT st s m) where
(>>=) = bind (const id)
fail _ = empty
instance Monad m => Alternative (ParserT st s m) where
empty = PT $ \_ _ -> return []
p <|> q = PT $ \st ss -> do
xs <- runParserT p st ss
ys <- runParserT q st ss
return (xs ++ ys)
instance Monad m =>Parse (ParserT st s m) s where
p |> q = PT $ \st ss -> do
xs <- runParserT p st ss
case xs of
[] -> runParserT q st ss
_ -> return xs
satisfyWith f = PT $ \st ss ->
case ss of
y:ys -> return [ (a, st, ys) | a <- maybeToList (f y) ]
_ -> return []
withInputList f = PT $ \st ss -> return [ (a, st, ss) | a <- f ss ]
instance Monad m => MonadState st (ParserT st s m) where
state f = PT $ \st ss ->
let (a, st2) = f st
in return [(a, st2, ss)]
instance (Monad m, ParseLog m) => ParseLog (ParserT st s m) where
pLog = lift . pLog
{-# INLINE bind #-}
bind :: Monad m => (a -> b -> c) -> ParserT st s m a -> (a -> ParserT st s m b) -> ParserT st s m c
bind mk p f = PT $ \st ss -> do
xs <- runParserT p st ss
fmap concat $ forM xs $ \(a, st2, ss2) -> do
ys <- runParserT (f a) st2 ss2
return [ (mk a b, st3, rest) | (b, st3, rest) <- ys]
type Parser s = ParserT () s Identity
runParser :: Parser s a -> [s] -> Maybe a
runParser p = fmap fst3 . listToMaybe . runIdentity . runParserT p ()