module Control.Monad.Backtrack(
BacktrackT
, runBacktrackT
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
newtype BacktrackT r m a = BacktrackT {
runBacktrackT :: (String -> m r)
-> (a -> m r)
-> m r
}
instance Functor (BacktrackT r m) where
fmap f m = BacktrackT $ \cf cs -> runBacktrackT m cf $ cs . f
instance Applicative (BacktrackT r m) where
pure x = BacktrackT (\_cf cs -> cs x)
f <*> v = BacktrackT $ \cf cs -> runBacktrackT f cf
$ \r -> runBacktrackT v cf (cs . r)
instance Monad (BacktrackT r m) where
m >>= k = BacktrackT $ \cf cs -> runBacktrackT m cf (\v -> runBacktrackT (k v) cf cs)
fail s = BacktrackT $ \cf _cs -> cf s
instance MonadTrans (BacktrackT r) where
lift m = BacktrackT $ \_cf cs -> m >>= cs
instance (MonadIO m) => MonadIO (BacktrackT r m) where
liftIO = lift . liftIO
instance Alternative (BacktrackT r m) where
empty = BacktrackT $ \cf _cs -> cf "<empty alternative>"
a <|> b = BacktrackT $ \cf cs -> runBacktrackT a (\_s -> runBacktrackT b cf cs) cs
many = munch []
some p = p >>= (\a -> munch [a] p)
munch :: [a] -> BacktrackT r m a -> BacktrackT r m [a]
munch initialAcc p = BacktrackT $ \_cf cs -> go cs initialAcc
where
go cs acc = runBacktrackT p onFailure onSuccess
where
onSuccess a = go cs $ a:acc
onFailure _ = cs $ reverse acc
instance MonadPlus (BacktrackT r m) where
mzero = empty
mplus = (<|>)