Module that executes a sequence of actions in any possible order

Question

Below is a module that executes a sequence of actions in any possible order. LANGUAGE_DataKinds and LANGUAGE_DefaultSignatures are predefined cpp symbols.

Is this permutation applicative/monad implementation clear? I am particularly concerned about the use of DataKinds and GADTs, and if I should instead split it in to two separate implementations (one for Applicative/Alternative, one for Monad/MonadPlus).

{-# LANGUAGE CPP #-}
#ifdef LANGUAGE_DataKinds
{-# LANGUAGE DataKinds #-}
#else
{-# LANGUAGE EmptyDataDecls #-}
#endif
{-# LANGUAGE
    FlexibleInstances
  , GADTs
  , MultiParamTypeClasses
  , Rank2Types
  , TypeSynonymInstances
  , UndecidableInstances #-}
{- |
Stability: experimental
Portability: non-portable
-}
module Control.Monad.Perm.Internal
       ( Perm
       , runPerm
       , PermT
       , runPermT
       , PermC
       , liftPerm
       , hoistPerm
       ) where

import Control.Applicative hiding (Applicative)
import qualified Control.Applicative as Applicative (Applicative)
import Control.Monad hiding (Monad)
import qualified Control.Monad as Monad (Monad)
import Control.Monad.Catch.Class
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Trans.Class (MonadTrans (lift))

import Data.Foldable (foldr)
import Data.Monoid ((<>), mempty)

import Prelude (Maybe (..), ($), (.), const, flip, fst, id, map, maybe)

-- | The permutation applicative
type Perm = PermC Applicative

-- | The permutation monad
type PermT = PermC Monad

{- |
The permutation action, available as either an 'Applicative.Applicative'
or a 'Monad.Monad', determined by the combinators used.
-}
data PermC c m a = Choice (Maybe a) [Branch c m a]

data Branch c m b where
  Ap :: PermC c m (a -> b) -> m a -> Branch c m b
  Bind :: (a -> PermT m b) -> m a -> Branch Monad m b

#ifdef LANGUAGE_DataKinds
data Constraint = Applicative | Monad
#else
data Applicative
data Monad
#endif

instance Functor (PermC c m) where
  fmap f (Choice a xs) = Choice (f <$> a) (fmap f <$> xs)

instance Functor (Branch c m) where
  fmap f (Ap perm m) = Ap (fmap (f .) perm) m
  fmap f (Bind k m) = Bind (fmap f . k) m

instance Applicative.Applicative (PermC c 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)
  (*>) = liftThen (*>)

apP :: PermC c m (a -> b) -> Branch c m a -> Branch c m b
f `apP` Ap perm m = (f .@ perm) `Ap` m
f `apP` Bind k m = Bind ((f `ap`) . k) m

(.@) :: Applicative.Applicative f => f (b -> c) -> f (a -> b) -> f (a -> c)
(.@) = liftA2 (.)

apB :: Branch c m (a -> b) -> PermC c m a -> Branch c m b
Ap perm m `apB` a = flipA2 perm a `Ap` m
Bind k m `apB` a = Bind ((`ap` a) . k) m

flipA2 :: Applicative.Applicative f => f (a -> b -> c) -> f b -> f (a -> c)
flipA2 = liftA2 flip

instance Alternative (PermC c m) where
  empty = liftZero empty
  (<|>) = plus

instance Monad.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 _ = Choice mzero mempty

bindP :: (a -> PermT m b) -> Branch Monad m a -> Branch Monad m b
bindP k (Ap perm m) = Bind (\ a -> k . ($ a) =<< perm) m
bindP k (Bind k' m) = Bind (k <=< k') m

instance MonadPlus (PermT m) where
  mzero = liftZero mzero
  mplus = plus

instance MonadTrans (PermC c) 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)

localBranch :: MonadReader r m =>
               (r -> r) -> Branch Monad m a -> Branch Monad 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

#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) ->
            PermC c m a -> PermC c m b -> PermC c 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 :: PermC c m a -> Branch c m b -> Branch c m b
m `thenP` Ap perm m' = (m *> perm) `Ap` m'
m `thenP` Bind k m' = Bind ((m >>) . k) m'

thenB :: Branch c m a -> PermC c m b -> Branch c 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 -> PermC c m a
liftZero zeroMaybe = Choice zeroMaybe mempty

plus :: PermC c m a -> PermC c m a -> PermC c m a
m@(Choice (Just _) _) `plus` _ = m
Choice Nothing xs `plus` Choice b ys = Choice b (xs <> ys)

-- | Unwrap a 'Perm', combining actions using the 'Alternative' for @f@.
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

-- | Unwrap a 'PermC', combining actions using the 'MonadPlus' for @f@.
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

-- | A version of 'lift' without the @'Monad.Monad' m@ constraint
liftPerm :: m a -> PermC c m a
liftPerm = Choice empty . pure . liftBranch

liftBranch :: m a -> Branch c m a
liftBranch = Ap (Choice (pure id) mempty)

{- |
Lift a natural transformation from @m@ to @n@ into a natural transformation
from @'PermC' c m@ to @'PermC' c n@.
-}
hoistPerm :: (forall a . m a -> n a) -> PermC c m b -> PermC c n b
hoistPerm f (Choice a xs) = Choice a (hoistBranch f <$> xs)

hoistBranch :: (forall a . m a -> n a) -> Branch c m b -> Branch c n b
hoistBranch f (perm `Ap` m) = hoistPerm f perm `Ap` f m
hoistBranch f (Bind k m) = Bind (hoistPerm f . k) (f m)

Yes, some example, and perhaps describing how this monad works, would be helpful. — Petr, Commented Oct 17, 2012 at 17:23
With parsec: runPermT $ lift (char 'a') *> lift (char 'b') should match "ab" or "bc" and always return 'b'. The same should happen if >> is used instead of *>, as well as if liftPerm is used instead of lift, assuming the underlying monad's Applicative and Monad instances are coherent. — ScootyPuff, Commented Oct 19, 2012 at 15:52

nponeccop · Accepted Answer · 2012-10-17 23:06:04Z

As Alternative and MonadPlus are both monoids foldMap seems more appropriate than foldr. Note that you need to define the instances using newtypes. Fortunately these instances are defined in reducers package. So:

foldMonadPlus2 f x = getMonadSum $ foldMap (MonadSum . f) x
foldAlternative2 f x = getAlternate $ foldMap (Alternate . f) x

It doesn't look very nice, but you can use newtype package to make it better:

foldMonadPlus3 f x = ala (MonadSum . f) foldMap x
foldAlternate3 f x = ala (Alternate . f) foldMap x

Unfortunately you have to define two instances so it's not any shorter:

instance MonadPlus m => Newtype (MonadSum m a) (m a) where
    pack = MonadSum
    unpack = getMonadSum

instance Alternative m => Newtype (Alternate m a) (m a) where
    pack = Alternate
    unpack = getAlternate

Maybe someone else could exploit this idea further.

Another approach is to use msum and asum:

foldMonadPlus f x = asum $ fmap f x
foldAlternative f x = msum $ fmap f x

You then can define

lower (Choice a xs) = foldMonadPlus f xs `mplus` (maybe mzero return a)

And similar for Applicative. Note that x is not any Foldable but always a list so you may want just to import foldr from Prelude instead.

I use the following code to test:

let a x = Perm2.liftPerm (print x) in runPermT (a 0 >> a 0 >> a 1 >> mzero)

Couldn't invent anything similar for Applicative.

I could extract common code from runPerm and runPermT:

prepare g f (Choice a xs) = maybe id ((:) . g) a $ map f xs

The functions look identical, just lower is respectively:

lower = asum . prepare pure f
lower = msum . prepare return f

Import of Data.Monoid can be removed without a loss of genericity as only the list monoid is actually used. So all <> can be replaced with ++ and mempty with []. Are there any other Foldable a, Monoid a types useful to store branches besides lists?

I think it is a good idea to try to extract a recursor for Choice and write everything else non-recursively if it is possible.

ScootyPuff · Accepted Answer · 2012-10-17 15:14:17Z

Below is what I have now. For modifications to this solution, please add a new answer that I can choose (rather than comment on it). Disadvantages compared to the original implementation include an additional Monad n constraint on hoistPerm. Advantages include a simpler exposed data type (no odd phantom type parameter) and the removal of the dubious use of DataKinds. I am still very open to advice, and will leave the question open. Of particular concern now is how runPermT does not use Applicative m, but instead relies on the equivalent Monad operations - should Ap be changed to include a local Applicative m constraint? Doing so would add another constraint to hoistPerm of Applicative n - which though trivially satisfied, is still kind of odd.

{-# LANGUAGE
    CPP
  , FlexibleInstances
  , GADTs
  , MultiParamTypeClasses
  , Rank2Types
  , UndecidableInstances #-}
{- |
Stability: experimental
Portability: non-portable
-}
module Control.Monad.Perm.Internal
       ( Perm
       , runPerm
       , PermT
       , runPermT
       , liftPerm
       , hoistPerm
       ) where

import Control.Applicative
import Control.Monad
import Control.Monad.Catch.Class
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Trans.Class (MonadTrans (lift))

import Data.Foldable (foldr)
import Data.Monoid (mempty)
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704
import Data.Monoid ((<>))
#else
import Data.Monoid (Monoid, mappend)
#endif

import Prelude (Maybe (..), ($), (.), const, flip, fst, id, map, maybe)

#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 704
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
{-# INLINE (<>) #-}
#endif

-- | The permutation applicative
type Perm = PermT

-- | The permutation monad
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)

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

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)
  (*>) = liftThen (*>)

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 _ = Choice mzero 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)

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

#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)

-- | Unwrap a 'Perm', combining actions using the 'Alternative' for @f@.
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

-- | Unwrap a 'PermT', combining actions using the 'MonadPlus' for @f@.
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

-- | A version of 'lift' without the @'Monad.Monad' m@ constraint
liftPerm :: m a -> PermT m a
liftPerm = Choice empty . pure . liftBranch

liftBranch :: m a -> Branch m a
liftBranch = Ap (Choice (pure id) mempty)

{- |
Lift a natural transformation from @m@ to @n@ into a natural transformation
from @'PermT'' c m@ to @'PermT'' c n@.
-}
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)

Stack Exchange Network

Module that executes a sequence of actions in any possible order

2 Answers 2

Your Answer

Not the answer you're looking for? Browse other questions tagged
haskell
monads
or ask your own question.

Hot Network Questions

Module that executes a sequence of actions in any possible order

2 Answers 2

Your Answer

Sign up or log in

Post as a guest

Not the answer you're looking for? Browse other questions tagged haskellmonads or ask your own question.

Related

Hot Network Questions

Not the answer you're looking for? Browse other questions tagged
haskell
monads
or ask your own question.