module Text.Chatty.Parser.Nondeterministic where
import Control.Applicative
import Control.Monad
import Data.List
import qualified Data.Foldable as F
import Text.Chatty.Parser
import Text.Chatty.Scanner
data ForkerT m a = Result (m a) (Char -> ForkerT m a) | Failed
instance (MonadPlus m,F.Foldable m) => Monad (ForkerT m) where
return a = Result (return a) $ const Failed
(Result as f) >>= m = Result (results >>= rResult) (\k -> F.foldl (???) (f k >>= m) (liftM (flip rFunction k) results))
where isResult (Result _ _) = True
isResult _ = False
rResult (Result x _) = x
rFunction (Result _ f) = f
results = mfilter isResult $ liftM m as
Failed >>= m = Failed
fail _ = Failed
instance (MonadPlus m,F.Foldable m) => Functor (ForkerT m) where
fmap = liftM
instance (MonadPlus m,F.Foldable m) => Applicative (ForkerT m) where
(<*>) = ap
pure = return
instance (MonadPlus m,F.Foldable m) => ChParser (ForkerT m) where
pabort = Failed
Failed ?? b = b
a ?? Failed = a
(Result as f) ?? (Result bs g) = Result (msum $ liftM return $ nub $ F.foldr (:) [] $ mplus as bs) $ \k -> f k ?? g k
Failed ??? b = b
a ??? Failed = a
(Result as f) ??? (Result bs g) = Result (mplus as bs) $ \k -> f k ??? g k
ptry Failed = Failed
ptry (Result as f) = Result (msum $ liftM return [msum $ liftM return $ F.foldr (:) [] as]) $ \k -> ptry $ f k
instance (MonadPlus m,F.Foldable m) => ChScanner (ForkerT m) where
mscan1 = Result mzero return
mscanL = do
c <- mscan1
cs <- mscanL
return (c:cs)
mscannable = return True
mready = return False
feedForkerT1 :: (MonadPlus m,F.Foldable m) => Char -> ForkerT m a -> ForkerT m a
feedForkerT1 _ Failed = Failed
feedForkerT1 c (Result _ f) = f c
feedForkerT :: (MonadPlus m,F.Foldable m) => String -> ForkerT m a -> ForkerT m a
feedForkerT [] = id
feedForkerT (c:cs) = feedForkerT cs . feedForkerT1 c
embedForkerT :: (MonadPlus n,F.Foldable n,ChScanner m) => ForkerT n a -> m (n a)
embedForkerT f = do
b <- mscannable
if not b then
case f of
Failed -> return mzero
Result xs _ -> return xs
else do
k <- mscan1
embedForkerT $ feedForkerT1 k f