module Text.Chatty.Parser.Carrier where
import Control.Applicative
import Control.Monad
import Data.List
import Data.Monoid
import qualified Data.Foldable as F
import Text.Chatty.Parser
import Text.Chatty.Scanner
data CarrierT m a = Carry { carry :: String -> m (a,String) }
instance (MonadPlus m,F.Foldable m) => Monad (CarrierT m) where
return a = Carry $ \s -> return (a,s)
m >>= f = Carry $ \s -> msum [carry (f a) cs' | (a,cs') <- F.foldr (:) [] $ carry m s]
fail _ = Carry $ const mzero
instance (MonadPlus m,F.Foldable m) => Functor (CarrierT m) where
fmap = liftM
instance (MonadPlus m,F.Foldable m) => Applicative (CarrierT m) where
pure = return
f <*> a = f `ap` a
instance (MonadPlus m,F.Foldable m) => Alternative (CarrierT m) where
empty = pabort
a <|> b = a ??? b
instance (MonadPlus m,F.Foldable m) => MonadPlus (CarrierT m) where
mzero = empty
a `mplus` b = a <|> b
instance (MonadPlus m,F.Foldable m) => Monoid (CarrierT m a) where
mempty = empty
a `mappend` b = a <|> b
instance (MonadPlus m,F.Foldable m) => ChScanner (CarrierT m) where
mscan1 = Carry $ \cx -> case cx of
c:cs -> return (c,cs)
[] -> mzero
mscanL = Carry $ \cs -> return (cs,[])
mscannable = Carry $ \cs -> return (not (null cs), cs)
mready = mscannable
instance (MonadPlus m,F.Foldable m) => ChParser (CarrierT m) where
pabort = Carry $ \s -> mzero
p ??? q = Carry $ \cs -> carry p cs `mplus` carry q cs
p ?? q = Carry $ \cs -> msum $ liftM return $ nub $ F.foldr (:) [] (carry p cs `mplus` carry q cs)
ptry p = Carry $ \cs -> msum $ liftM return
$ map (\((a,s):as) -> (msum $ liftM return (a:map fst as), s))
$ groupBy (\a b -> snd a == snd b)
$ sortBy (\a b -> snd a `compare` snd b)
$ F.foldr (:) []
$ carry p cs
runCarrierT :: (MonadPlus m,F.Foldable m) => String -> CarrierT m a -> m a
runCarrierT s c = liftM fst $ mfilter (\x -> null (snd x)) $ carry c s
embedCarrierT :: (MonadPlus n,F.Foldable n,ChScanner m) => CarrierT n a -> m (n a)
embedCarrierT f = do
s <- mscanL
return $ runCarrierT s f