{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
module Control.Monad.Trans.Choice.Covariant
( ChoiceT ( )
, runChoiceT
, mapChoiceT
, runBacktrackableChoiceT
) where
import Control.Monad.Class.Choice
( MonadChoice (choose)
)
import Control.Arrow
( second
)
import Control.Monad
( (>=>)
)
import Control.Monad.IO.Class
( MonadIO
( liftIO
)
)
import Control.Monad.Reader.Class
( MonadReader
( ask
, local
)
)
import Control.Monad.RWS.Class
( MonadRWS
)
import Control.Monad.State.Class
( MonadState
( state
)
)
import Control.Monad.Trans
( MonadTrans
( lift
)
)
import Control.Monad.Writer.Class
( MonadWriter
( writer
, listen
, pass
)
)
data ChoiceT f m a where
FixedT :: a -> ChoiceT f m a
LiftThenT :: m b -> (b -> ChoiceT f m a) -> ChoiceT f m a
ChooseThenT :: f b -> (b -> ChoiceT f m a) -> ChoiceT f m a
instance Functor (ChoiceT f m) where
fmap f (FixedT value) = FixedT $ f value
fmap f (LiftThenT action next) = LiftThenT action $ fmap f . next
fmap f (ChooseThenT options next) = ChooseThenT options $ fmap f . next
instance Applicative (ChoiceT f m) where
pure = FixedT
(FixedT f) <*> choice = fmap f choice
fChoice <*> (FixedT f) = fmap ($f) fChoice
(LiftThenT fAction nextF) <*> dependentChoice = LiftThenT fAction $ (<*> dependentChoice) . nextF
(ChooseThenT fOptions nextF) <*> dependentChoice = ChooseThenT fOptions $ (<*> dependentChoice) . nextF
instance Monad (ChoiceT f m) where
(FixedT value) >>= f = f value
(LiftThenT action next) >>= f = LiftThenT action $ next >=> f
(ChooseThenT options next) >>= f = ChooseThenT options $ next >=> f
instance MonadChoice f (ChoiceT f m) where
choose options = ChooseThenT options pure
instance MonadTrans (ChoiceT f) where
lift action = LiftThenT action pure
instance MonadReader r m => MonadReader r (ChoiceT f m) where
ask = lift ask
local f = mapChoiceT (local f)
instance MonadState s m => MonadState s (ChoiceT f m) where
state = lift . state
instance MonadWriter w m => MonadWriter w (ChoiceT f m) where
writer = lift . writer
listen (FixedT value) = FixedT (value, mempty)
listen (LiftThenT action next) = LiftThenT (listen action) $ \(result, output) -> fmap (second $ mappend output) $ listen $ next result
listen (ChooseThenT options next) = ChooseThenT options $ listen . next
pass = go mempty
where
go :: w -> ChoiceT f m (a, w -> w) -> ChoiceT f m a
go acc (FixedT (value, f)) = writer (value, f acc)
go acc (LiftThenT action next) = LiftThenT (listen action) (\(a,w)-> go (mappend acc w) $ next a)
go acc (ChooseThenT options next) = ChooseThenT options $ go acc . next
instance MonadRWS r w s m => MonadRWS r w s (ChoiceT f m)
instance MonadIO m => MonadIO (ChoiceT f m) where
liftIO = lift . liftIO
mapChoiceT :: (forall x. m x -> n x) -> ChoiceT f m a -> ChoiceT f n a
mapChoiceT _ (FixedT value) = FixedT value
mapChoiceT f (LiftThenT action next) = LiftThenT (f action) (mapChoiceT f . next)
mapChoiceT f (ChooseThenT options next) = ChooseThenT options (mapChoiceT f . next)
runChoiceT :: Monad m => (forall x. f x -> m x) -> ChoiceT f m a -> m a
runChoiceT _ (FixedT value) = pure value
runChoiceT chooser (LiftThenT action next) = action >>= (runChoiceT chooser . next)
runChoiceT chooser (ChooseThenT options next) = chooser options >>= (runChoiceT chooser . next)
runBacktrackableChoiceT ::
forall f m a. Monad m
=>
(forall x. f x -> m (Maybe x))
-> ChoiceT f m a
-> m (Maybe a)
runBacktrackableChoiceT _ (FixedT firstValue) = return $ Just firstValue
runBacktrackableChoiceT chooser (LiftThenT action next) = action >>= runBacktrackableChoiceT chooser . next
runBacktrackableChoiceT chooser (ChooseThenT options next) =
do
maybeChoice <- chooser options
case maybeChoice of
Nothing -> return Nothing
Just choice -> do
maybeResult <- runBacktrackableChoiceT chooser $ next choice
case maybeResult of
Nothing -> runBacktrackableChoiceT chooser $ ChooseThenT options next
Just result -> return $ Just result