perm 0.2.0.1 → 0.3.0.0

raw patch · 4 files changed

+163/−66 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/Applicative/Perm.hs +2/−2
• Control/Monad/Perm.hs +2/−2
• Control/Monad/Perm/Internal.hs +158/−61
• perm.cabal +1/−1

@@ -13,6 +13,6 @@        ) where  import Control.Monad.Perm.Internal (Perm,-                                    hoistPerm,+                                    runPerm,                                     liftPerm,-                                    runPerm)+                                    hoistPerm)

@@ -13,6 +13,6 @@        ) where  import Control.Monad.Perm.Internal (PermT,+                                    runPermT,                                     liftPerm,-                                    hoistPerm,-                                    runPermT)+                                    hoistPerm)

@@ -38,14 +38,13 @@ #endif import Control.Monad.Trans.Class (MonadTrans (lift)) -import Data.Foldable (foldr) #if MIN_VERSION_base(4, 5, 0)-import Data.Monoid ((<>), mempty)+import Data.Monoid (Monoid (mappend, mempty), (<>)) #else-import Data.Monoid (Monoid, mappend, mempty)+import Data.Monoid (Monoid (mappend, mempty)) #endif -import Prelude (Maybe (..), ($), (.), const, flip, fst, id, map, maybe)+import Prelude (($), (.), const, flip, fst, id, map)  #if !MIN_VERSION_base(4, 5, 0) (<>) :: Monoid m => m -> m -> m@@ -57,83 +56,186 @@ type Perm = PermT  -- | The permutation monad-data PermT m a = Choice (Maybe a) [Branch m a]+data PermT m a = Choice (Option m a) (Branches m a)  data Branch m b where-  Ap :: PermT m (a -> b) -> m a -> Branch m b+  Ap :: Dict m -> PermT m (a -> b) -> m a -> Branch m b   Bind :: Monad m => (a -> PermT m b) -> m a -> Branch m b +data Branches m a+  = Plus (PlusDict m) (Branches m a) (Branches m a)+  | Branch (Branch m a)+  | Nil++data PlusDict m where+  Alternative :: Alternative m => PlusDict m+  MonadPlus :: MonadPlus m => PlusDict m+  Unit :: PlusDict m++mapB :: (Branch m a -> Branch m b) -> Branches m a -> Branches m b+mapB f (Plus dict m n) = Plus dict (mapB f m) (mapB f n)+mapB f (Branch x) = Branch (f x)+mapB _ Nil = Nil++orB :: Alternative m => Branches m a -> Branches m a -> Branches m a+orB = Plus Alternative++mplusB :: MonadPlus m => Branches m a -> Branches m a -> Branches m a+mplusB = Plus MonadPlus++sumB :: (Branch m a -> m a) -> m a -> (m a -> m a -> m a) -> Branches m a -> m a+sumB f zero plus = go+  where+    go (Plus Alternative m n) = go m <|> go n+    go (Plus MonadPlus m n) = go m `mplus` go n+    go (Plus Unit m n) = go m `plus` go n+    go (Branch x) = f x+    go Nil = zero++instance Monoid (Branches m a) where+  mempty = Nil+  mappend = Plus Unit++instance Functor (Branches m) where+  fmap f (Plus dict m n) = Plus dict (fmap f m) (fmap f n)+  fmap f (Branch a) = Branch (fmap f a)+  fmap _ Nil = Nil++data Option m a+  = Zero (PlusDict m)+  | Return (Dict m) a++option :: m a -> Option m a -> m a+option _ (Zero Alternative) = empty+option _ (Zero MonadPlus) = mzero+option n (Zero Unit) = n+option _ (Return Applicative a) = pure a+option _ (Return Monad a) = return a++instance Functor (Option m) where+  fmap _ (Zero dict) = Zero dict+  fmap f (Return dict a) = Return dict (f a)++instance Applicative m => Applicative (Option m) where+  pure = Return Applicative+  Return _ f <*> a = fmap f a+  Zero dict <*> _ = Zero dict++instance Alternative m => Alternative (Option m) where+  empty = Zero Alternative+  Zero _ <|> r = r+  l <|> _ = l++instance Monad m => Monad (Option m) where+  return = Return Monad+  Return _ a >>= k = k a+  Zero dict >>= _ = Zero dict+  Return _ _ >> k = k+  Zero dict >> _ = Zero dict+  fail _ = Zero Unit++instance MonadPlus m => MonadPlus (Option m) where+  mzero = Zero MonadPlus+  Zero _ `mplus` r = r+  l `mplus` _ = l++data Dict m where+  Applicative :: Applicative m => Dict m+  Monad :: Monad m => Dict m+ instance Functor (PermT m) where-  fmap f (Choice a xs) = Choice (f <$> a) (fmap f <$> xs)+  fmap f (Choice a xs) = Choice (f <$> a) (f <$> xs) #if MIN_VERSION_base(4, 2, 0)-  a <$ Choice b xs = Choice (a <$ b) (fmap (a <$) xs)+  a <$ Choice b xs = Choice (a <$ b) (a <$ xs) #endif  instance Functor (Branch m) where-  fmap f (Ap perm m) = Ap (fmap (f .) perm) m+  fmap f (Ap dict perm m) = Ap dict (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 <$ Ap dict perm m = Ap dict (const a <$ perm) m   a <$ Bind k m = Bind ((a <$) . k) m #endif -instance Applicative (PermT m) where+instance Applicative m => 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)+    Choice (f' <*> a') (mapB (`apB` a) fs <> mapB (f `apP`) as) #if MIN_VERSION_base(4, 2, 0)-  (*>) = liftThen (*>)+  m@(Choice m' ms) *> n@(Choice n' ns) =+    Choice (m' *> n') (mapB (`thenBA` n) ms <> mapB (m `thenPA`) ns) #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+apP :: Applicative m => PermT m (a -> b) -> Branch m a -> Branch m b+f `apP` Ap _ perm m = Ap Applicative (f .@ perm) m+f `apP` Bind k m = Bind ((f <*>) . 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+apB :: Applicative m => Branch m (a -> b) -> PermT m a -> Branch m b+Ap _ perm m `apB` a = Ap Applicative (flipA2 perm a) m+Bind k m `apB` a = Bind ((<*> a) . k) m  flipA2 :: Applicative f => f (a -> b -> c) -> f b -> f (a -> c) flipA2 = liftA2 flip -instance Alternative (PermT m) where+#if MIN_VERSION_base(4, 2, 0)+thenPA :: Applicative m => PermT m a -> Branch m b -> Branch m b+m `thenPA` Ap _ perm n = Ap Applicative (m *> perm) n+m `thenPA` Bind k n = Bind ((m *>) . k) n++thenBA :: Applicative m => Branch m a -> PermT m b -> Branch m b+Ap _ perm m `thenBA` n = Ap Applicative (perm *> fmap const n) m+Bind k m `thenBA` n = Bind ((*> n) . k) m+#endif++instance Alternative m => Alternative (PermT m) where   empty = liftZero empty-  (<|>) = plus+  m@(Choice (Return _ _) _) <|> _ = m+  Choice (Zero _) xs <|> Choice b ys = Choice b (xs `orB` ys)  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 (>>)+  Choice (Zero dict) xs >>= k = Choice (Zero dict) (mapB (bindP k) xs)+  Choice (Return _ a) xs >>= k = case k a of+    Choice a' xs' -> Choice a' (mapB (bindP k) xs <> xs')+  m@(Choice m' ms) >> n@(Choice n' ns) =+    Choice (m' >> n') (mapB (`thenBM` n) ms <> mapB (m `thenPM`) ns)   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 (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+thenPM :: Monad m => PermT m a -> Branch m b -> Branch m b+m `thenPM` Ap _ perm n = Ap Monad (m >> perm) n+m `thenPM` Bind k n = Bind ((m >>) . k) n++thenBM :: Monad m => Branch m a -> PermT m b -> Branch m b+Ap _ perm m `thenBM` n = Ap Monad (perm >> fmap const n) m+Bind k m `thenBM` n = Bind ((>> n) . k) m++instance MonadPlus m => MonadPlus (PermT m) where   mzero = liftZero mzero-  mplus = plus+  m@(Choice (Return _ _) _) `mplus` _ = m+  Choice (Zero _) xs `mplus` Choice b ys = Choice b (xs `mplusB` ys)  instance MonadTrans PermT where-  lift = liftPerm+  lift = Choice (Zero Unit) . Branch . Ap Monad (Choice (return id) mempty)  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)+  local f (Choice a xs) = Choice a (mapB (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 (Ap dict perm m) = Ap dict (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@@ -150,56 +252,51 @@   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)+liftZero :: Option m a -> PermT m a+liftZero zeroOption = Choice zeroOption mempty  -- | 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+    lower (Choice a xs) = sumB f (option empty a) (<|>) xs+    f (Ap Monad perm m) = flip ($) `liftM` m `ap` runPerm perm+    f (Ap _ perm 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+    lower (Choice a xs) = sumB f (option mzero a) mplus xs+    f (Ap Applicative perm m) = m <**> runPermT perm+    f (Ap _ perm 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+-- | A version of 'lift' that can be used with just an 'Applicative' for @m@.+liftPerm :: Applicative m => m a -> PermT m a+liftPerm = Choice (Zero Unit) . Branch . liftBranch -liftBranch :: m a -> Branch m a-liftBranch = Ap (Choice (pure id) mempty)+liftBranch :: Applicative m => m a -> Branch m a+liftBranch = Ap Applicative (Choice (pure id) mempty)  {- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'PermT' m@ to @'PermT' 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)+hoistPerm f (Choice a xs) = Choice (hoistOption a) (hoistBranches f xs) +hoistOption :: Monad n => Option m a -> Option n a+hoistOption (Zero _) = Zero Unit+hoistOption (Return _ a) = Return Monad a++hoistBranches :: Monad n =>+                 (forall a . m a -> n a) -> Branches m b -> Branches n b+hoistBranches f (Plus _ m n) = Plus Unit (hoistBranches f m) (hoistBranches f n)+hoistBranches f (Branch x) = Branch (hoistBranch f x)+hoistBranches _ Nil = Nil+ 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 (Ap _ perm m) = Ap Monad (hoistPerm f perm) (f m) hoistBranch f (Bind k m) = Bind (hoistPerm f . k) (f m)

@@ -1,5 +1,5 @@ name:          perm-version:       0.2.0.1+version:       0.3.0.0 cabal-version: >= 1.10 synopsis:      permutation Applicative and Monad with many mtl instances description: