module Control.Monad.Perm.Internal
( Perm
, runPerm
, PermT
, runPermT
, liftPerm
, hoistPerm
) where
import Control.Applicative
import Control.Monad
#if LANGUAGE_DefaultSignatures
import Control.Monad.Catch.Class (MonadThrow)
#else
import Control.Monad.Catch.Class (MonadThrow (throw))
#endif
import Control.Monad.IO.Class (MonadIO (liftIO))
#if MIN_VERSION_mtl(2, 1, 0)
import Control.Monad.Reader.Class (MonadReader (ask, local, reader))
import Control.Monad.State.Class (MonadState (get, put, state))
#else
import Control.Monad.Reader.Class (MonadReader (ask, local))
import Control.Monad.State.Class (MonadState (get, put))
#endif
import Control.Monad.Trans.Class (MonadTrans (lift))
import Data.Foldable (foldr)
#if MIN_VERSION_base(4, 5, 0)
import Data.Monoid ((<>), mempty)
#else
import Data.Monoid (Monoid, mappend, mempty)
#endif
import Prelude (Maybe (..), ($), (.), const, flip, fst, id, map, maybe)
#if !MIN_VERSION_base(4, 5, 0)
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
#endif
type Perm = PermT
data PermT m a = Choice (Maybe a) [Branch m a]
data Branch m b where
Ap :: PermT m (a -> b) -> m a -> Branch m b
Bind :: Monad m => (a -> PermT m b) -> m a -> Branch m b
instance Functor (PermT m) where
fmap f (Choice a xs) = Choice (f <$> a) (fmap f <$> xs)
#if MIN_VERSION_base(4, 2, 0)
a <$ Choice b xs = Choice (a <$ b) (fmap (a <$) xs)
#endif
instance Functor (Branch m) where
fmap f (Ap perm m) = Ap (fmap (f .) perm) m
fmap f (Bind k m) = Bind (fmap f . k) m
#if MIN_VERSION_base(4, 2, 0)
a <$ Ap perm m = Ap (const a <$ perm) m
a <$ Bind k m = Bind ((a <$) . k) m
#endif
instance Applicative (PermT m) where
pure a = Choice (pure a) mempty
f@(Choice f' fs) <*> a@(Choice a' as) =
Choice (f' <*> a') (fmap (`apB` a) fs <> fmap (f `apP`) as)
#if MIN_VERSION_base(4, 2, 0)
(*>) = liftThen (*>)
#endif
apP :: PermT m (a -> b) -> Branch m a -> Branch m b
f `apP` Ap perm m = (f .@ perm) `Ap` m
f `apP` Bind k m = Bind ((f `ap`) . k) m
(.@) :: Applicative f => f (b -> c) -> f (a -> b) -> f (a -> c)
(.@) = liftA2 (.)
apB :: Branch m (a -> b) -> PermT m a -> Branch m b
Ap perm m `apB` a = flipA2 perm a `Ap` m
Bind k m `apB` a = Bind ((`ap` a) . k) m
flipA2 :: Applicative f => f (a -> b -> c) -> f b -> f (a -> c)
flipA2 = liftA2 flip
instance Alternative (PermT m) where
empty = liftZero empty
(<|>) = plus
instance Monad m => Monad (PermT m) where
return a = Choice (return a) mempty
Choice Nothing xs >>= k = Choice Nothing (map (bindP k) xs)
Choice (Just a) xs >>= k = case k a of
Choice a' xs' -> Choice a' (map (bindP k) xs <> xs')
(>>) = liftThen (>>)
fail s = Choice (fail s) mempty
bindP :: Monad m => (a -> PermT m b) -> Branch m a -> Branch m b
bindP k (Ap perm m) = Bind (\ a -> k . ($ a) =<< perm) m
bindP k (Bind k' m) = Bind (k <=< k') m
instance Monad m => MonadPlus (PermT m) where
mzero = liftZero mzero
mplus = plus
instance MonadTrans PermT where
lift = liftPerm
instance MonadIO m => MonadIO (PermT m) where
liftIO = lift . liftIO
instance MonadReader r m => MonadReader r (PermT m) where
ask = lift ask
local f (Choice a xs) = Choice a (map (localBranch f) xs)
#if MIN_VERSION_mtl(2, 1, 0)
reader = lift . reader
#endif
localBranch :: MonadReader r m => (r -> r) -> Branch m a -> Branch m a
localBranch f (Ap perm m) = Ap (local f perm) (local f m)
localBranch f (Bind k m) = Bind (local f . k) (local f m)
instance MonadState s m => MonadState s (PermT m) where
get = lift get
put = lift . put
#if MIN_VERSION_mtl(2, 1, 0)
state = lift . state
#endif
#ifdef LANGUAGE_DefaultSignatures
instance MonadThrow e m => MonadThrow e (PermT m)
#else
instance MonadThrow e m => MonadThrow e (PermT m) where
throw = lift . throw
#endif
liftThen :: (Maybe a -> Maybe b -> Maybe b) ->
PermT m a -> PermT m b -> PermT m b
liftThen thenMaybe m@(Choice m' ms) n@(Choice n' ns) =
Choice (m' `thenMaybe` n') (map (`thenB` n) ms <> map (m `thenP`) ns)
thenP :: PermT m a -> Branch m b -> Branch m b
m `thenP` Ap perm m' = (m *> perm) `Ap` m'
m `thenP` Bind k m' = Bind ((m >>) . k) m'
thenB :: Branch m a -> PermT m b -> Branch m b
Ap perm m `thenB` n = (perm *> fmap const n) `Ap` m
Bind k m `thenB` n = Bind ((>> n) . k) m
liftZero :: Maybe a -> PermT m a
liftZero zeroMaybe = Choice zeroMaybe mempty
plus :: PermT m a -> PermT m a -> PermT m a
m@(Choice (Just _) _) `plus` _ = m
Choice Nothing xs `plus` Choice b ys = Choice b (xs <> ys)
runPerm :: Alternative m => Perm m a -> m a
runPerm = lower
where
lower (Choice a xs) = foldr ((<|>) . f) (maybe empty pure a) xs
f (perm `Ap` m) = m <**> runPerm perm
f (Bind k m) = m >>= runPerm . k
runPermT :: MonadPlus m => PermT m a -> m a
runPermT = lower
where
lower (Choice a xs) = foldr (mplus . f) (maybe mzero return a) xs
f (perm `Ap` m) = flip ($) `liftM` m `ap` runPermT perm
f (Bind k m) = m >>= runPermT . k
liftPerm :: m a -> PermT m a
liftPerm = Choice empty . pure . liftBranch
liftBranch :: m a -> Branch m a
liftBranch = Ap (Choice (pure id) mempty)
hoistPerm :: Monad n => (forall a . m a -> n a) -> PermT m b -> PermT n b
hoistPerm f (Choice a xs) = Choice a (hoistBranch f <$> xs)
hoistBranch :: Monad n => (forall a . m a -> n a) -> Branch m b -> Branch n b
hoistBranch f (perm `Ap` m) = hoistPerm f perm `Ap` f m
hoistBranch f (Bind k m) = Bind (hoistPerm f . k) (f m)