free 4.10.0.1 → 4.11

raw patch · 9 files changed

+241/−37 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +10/−0
• examples/RetryTH.hs +14/−6
• free.cabal +1/−1
• src/Control/Monad/Free.hs +8/−2
• src/Control/Monad/Free/Church.hs +29/−2
• src/Control/Monad/Free/Class.hs +2/−1
• src/Control/Monad/Free/TH.hs +110/−24
• src/Control/Monad/Trans/Free.hs +62/−1
• src/Control/Monad/Trans/Free/Church.hs +5/−0

@@ -1,3 +1,13 @@+4.11+-----+* Pass Monad[FreeT].fail into underlying monad+* Add `retractT`.+* Added `cutoff` for the church encoded free monad.+* `cutoff` now accepts negative numbers.+* Added `intersperseT` and `intercalateT`.+* Added `foldFree` and `foldF`.+* Added some new `template-haskell` toys.+ 4.10.0.1 ------ * Fix for very old `cabal` versions where the `MIN_VERSION_foo` macros aren't negation friendly.

@@ -13,13 +13,9 @@  -- | A data type representing basic commands for a retriable eDSL. data RetryF next where-  -- | Simple output command.   Output    :: String -> next -> RetryF next-  -- | Get anything readable from input.   Input     :: Read a => (a -> next) -> RetryF next-  -- | Declare a retriable block.   WithRetry :: Retry a -> (a -> next) -> RetryF next-  -- | Force retry command (retries innermost retriable block).   Retry     :: RetryF next  -- | Unfortunately this Functor instance cannot yet be derived@@ -33,8 +29,20 @@ -- | The monad for a retriable eDSL. type Retry = Free RetryF --- automacally generate convenience functions-makeFree ''RetryF+-- | Simple output command.+makeFreeCon 'Output++-- | Get anything readable from input.+makeFreeCon 'Input++-- | Force retry command (retries innermost retriable block).+makeFreeCon 'Retry++makeFreeCon_ 'WithRetry+-- | Run a retryable block.+withRetry :: MonadFree RetryF m =>+             Retry a  -- ^ Computation to retry.+          -> m a      -- ^ Computation that retries until succeeds.  -- The following functions have been made available: --

@@ -1,6 +1,6 @@ name:          free category:      Control, Monads-version:       4.10.0.1+version:       4.11 license:       BSD3 cabal-version: >= 1.10 license-file:  LICENSE

@@ -13,7 +13,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Free--- Copyright   :  (C) 2008-2014 Edward Kmett+-- Copyright   :  (C) 2008-2015 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -30,6 +30,7 @@   , iter   , iterM   , hoistFree+  , foldFree   , toFreeT   , cutoff   , _Pure, _Free@@ -309,6 +310,11 @@ hoistFree _ (Pure a)  = Pure a hoistFree f (Free as) = Free (hoistFree f <$> f as) +-- | The very definition of a free monoid is that given a natural transformation you get a monoid homomorphism.+foldFree :: (Functor m, Monad m) => (forall x . f x -> m x) -> Free f a -> m a+foldFree _ (Pure a)  = return a+foldFree f (Free as) = f as >>= foldFree f+ -- | Convert a 'Free' monad from "Control.Monad.Free" to a 'FreeT.FreeT' monad -- from "Control.Monad.Trans.Free". toFreeT :: (Functor f, Monad m) => Free f a -> FreeT.FreeT f m a@@ -329,7 +335,7 @@ -- Calling 'retract . cutoff n' is always terminating, provided each of the -- steps in the iteration is terminating. cutoff :: (Functor f) => Integer -> Free f a -> Free f (Maybe a)-cutoff 0 _ = return Nothing+cutoff n _ | n <= 0 = return Nothing cutoff n (Free f) = Free $ fmap (cutoff (n - 1)) f cutoff _ m = Just <$> m 

@@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Free.Church--- Copyright   :  (C) 2011-2012 Edward Kmett+-- Copyright   :  (C) 2011-2015 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -60,14 +60,17 @@   , toF   , retract   , hoistF+  , foldF   , MonadFree(..)   , liftF+  , cutoff   ) where  import Control.Applicative import Control.Monad as Monad import Control.Monad.Fix-import Control.Monad.Free hiding (retract, iterM)+import Control.Monad.Free hiding (retract, iterM, cutoff)+import qualified Control.Monad.Free as Free import Control.Monad.Reader.Class import Control.Monad.Writer.Class import Control.Monad.Cont.Class@@ -98,6 +101,7 @@   pure a = F (\kp _ -> kp a)   F f <*> F g = F (\kp kf -> f (\a -> g (kp . a) kf) kf) +-- | This violates the Alternative laws, handle with care. instance Alternative f => Alternative (F f) where   empty = F (\_ kf -> kf empty)   F f <|> F g = F (\kp kf -> kf (pure (f kp kf) <|> pure (g kp kf)))@@ -123,6 +127,7 @@     {-# INLINE foldl' #-} #endif +-- | This violates the MonadPlus laws, handle with care. instance MonadPlus f => MonadPlus (F f) where   mzero = F (\_ kf -> kf mzero)   F f `mplus` F g = F (\kp kf -> kf (return (f kp kf) `mplus` return (g kp kf)))@@ -164,6 +169,10 @@ hoistF :: (forall x. f x -> g x) -> F f a -> F g a hoistF t (F m) = F (\p f -> m p (f . t)) +-- | The very definition of a free monoid is that given a natural transformation you get a monoid homomorphism.+foldF :: Monad m => (forall x. f x -> m x) -> F f a -> m a+foldF f (F m) = m return (Monad.join . f)+ -- | Convert to another free monad representation. fromF :: MonadFree f m => F f a -> m a fromF (F m) = m return wrap@@ -187,3 +196,21 @@ improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a improve m = fromF m {-# INLINE improve #-}+++-- | Cuts off a tree of computations at a given depth.+-- If the depth is 0 or less, no computation nor+-- monadic effects will take place.+--+-- Some examples (@n ≥ 0@):+--+-- prop> cutoff 0     _        == return Nothing+-- prop> cutoff (n+1) . return == return . Just+-- prop> cutoff (n+1) . lift   == lift . liftM Just+-- prop> cutoff (n+1) . wrap   == wrap . fmap (cutoff n)+--+-- Calling @'retract' . 'cutoff' n@ is always terminating, provided each of the+-- steps in the iteration is terminating.+cutoff :: (Functor f) => Integer -> F f a -> F f (Maybe a)+cutoff n = toF . Free.cutoff n . fromF+

@@ -6,10 +6,11 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE TypeFamilies #-} #endif+{-# OPTIONS_GHC -fno-warn-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Monad.Free.Class--- Copyright   :  (C) 2008-2011 Edward Kmett+-- Copyright   :  (C) 2008-2015 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>

@@ -14,10 +14,15 @@ module Control.Monad.Free.TH   (    -- * Free monadic actions-   makeFree+   makeFree,+   makeFree_,+   makeFreeCon,+   makeFreeCon_,++   -- * Documentation    -- $doc -   -- ** Examples+   -- * Examples    -- $examples   ) where @@ -132,8 +137,8 @@ unifyCaptured _ [x, y]   = unifyT x y unifyCaptured _ _ = fail "can't unify more than 2 arguments that use type parameter" -liftCon' :: [TyVarBndr] -> Cxt -> Type -> Name -> [Name] -> Name -> [Type] -> Q [Dec]-liftCon' tvbs cx f n ns cn ts = do+liftCon' :: Bool -> [TyVarBndr] -> Cxt -> Type -> Name -> [Name] -> Name -> [Type] -> Q [Dec]+liftCon' typeSig tvbs cx f n ns cn ts = do   -- prepare some names   opName <- mkName <$> mkOpName (nameBase cn)   m      <- newName "m"@@ -157,43 +162,124 @@       q = tvbs ++ map PlainTV (qa ++ m : ns)       qa = case retType of VarT b | a == b -> [a]; _ -> []       f' = foldl AppT f (map VarT ns)-  return+  return $ concat+    [ if typeSig #if MIN_VERSION_template_haskell(2,10,0)-    [ SigD opName (ForallT q (cx ++ [ConT monadFree `AppT` f' `AppT` VarT m]) opType)+        then [ SigD opName (ForallT q (cx ++ [ConT monadFree `AppT` f' `AppT` VarT m]) opType) ] #else-    [ SigD opName (ForallT q (cx ++ [ClassP monadFree [f', VarT m]]) opType)+        then [ SigD opName (ForallT q (cx ++ [ClassP monadFree [f', VarT m]]) opType) ] #endif-    , FunD opName [ Clause pat (NormalB $ AppE (VarE liftF) fval) [] ] ]+        else []+    , [ FunD opName [ Clause pat (NormalB $ AppE (VarE liftF) fval) [] ] ] ]  -- | Provide free monadic actions for a single value constructor.-liftCon :: [TyVarBndr] -> Cxt -> Type -> Name -> [Name] -> Con -> Q [Dec]-liftCon ts cx f n ns con =+liftCon :: Bool -> [TyVarBndr] -> Cxt -> Type -> Name -> [Name] -> Con -> Q [Dec]+liftCon typeSig ts cx f n ns con =   case con of-    NormalC cName fields -> liftCon' ts cx f n ns cName $ map snd fields-    RecC    cName fields -> liftCon' ts cx f n ns cName $ map (\(_, _, ty) -> ty) fields-    InfixC  (_,t1) cName (_,t2) -> liftCon' ts cx f n ns cName [t1, t2]-    ForallC ts' cx' con' -> liftCon (ts ++ ts') (cx ++ cx') f n ns con'+    NormalC cName fields -> liftCon' typeSig ts cx f n ns cName $ map snd fields+    RecC    cName fields -> liftCon' typeSig ts cx f n ns cName $ map (\(_, _, ty) -> ty) fields+    InfixC  (_,t1) cName (_,t2) -> liftCon' typeSig ts cx f n ns cName [t1, t2]+    ForallC ts' cx' con' -> liftCon typeSig (ts ++ ts') (cx ++ cx') f n ns con'  -- | Provide free monadic actions for a type declaration.-liftDec :: Dec -> Q [Dec]-liftDec (DataD _ tyName tyVarBndrs cons _)+liftDec :: Bool             -- ^ Include type signature?+        -> Maybe [Name]     -- ^ Include only mentioned constructor names. Use all constructors when @Nothing@.+        -> Dec              -- ^ Data type declaration.+        -> Q [Dec]+liftDec typeSig onlyCons (DataD _ tyName tyVarBndrs cons _)   | null tyVarBndrs = fail $ "Type " ++ show tyName ++ " needs at least one free variable"-  | otherwise = concat <$> mapM (liftCon [] [] con nextTyName (init tyNames)) cons+  | otherwise = concat <$> mapM (liftCon typeSig [] [] con nextTyName (init tyNames)) cons'     where+      cons' = case onlyCons of+                Nothing -> cons+                Just ns -> filter (\c -> constructorName c `elem` ns) cons       tyNames    = map tyVarBndrName tyVarBndrs       nextTyName = last tyNames       con        = ConT tyName-liftDec dec = fail $ "liftDec: Don't know how to lift " ++ show dec+liftDec _ _ dec = fail $ "liftDec: Don't know how to lift " ++ show dec --- | @$(makeFree ''Type)@ provides free monadic actions for the--- constructors of the given type.-makeFree :: Name -> Q [Dec]-makeFree tyCon = do+-- | Get construstor name.+constructorName :: Con -> Name+constructorName (NormalC  name _)   = name+constructorName (RecC     name _)   = name+constructorName (InfixC   _ name _) = name+constructorName (ForallC  _ _ c)    = constructorName c++-- | Generate monadic actions for a data type.+genFree :: Bool         -- ^ Include type signature?+        -> Maybe [Name] -- ^ Include only mentioned constructor names. Use all constructors when @Nothing@.+        -> Name         -- ^ Type name.+        -> Q [Dec]      -- ^ Generated declarations.+genFree typeSig cnames tyCon = do   info <- reify tyCon   case info of-    TyConI dec -> liftDec dec+    TyConI dec -> liftDec typeSig cnames dec     _ -> fail "makeFree expects a type constructor" +-- | Generate monadic action for a single constructor of a data type.+genFreeCon :: Bool         -- ^ Include type signature?+           -> Name         -- ^ Constructor name.+           -> Q [Dec]      -- ^ Generated declarations.+genFreeCon typeSig cname = do+  info <- reify cname+  case info of+    DataConI _ _ tname _ -> genFree typeSig (Just [cname]) tname+    _ -> fail "makeFreeCon expects a data constructor"++-- | @$('makeFree' ''T)@ provides free monadic actions for the+-- constructors of the given data type @T@.+makeFree :: Name -> Q [Dec]+makeFree = genFree True Nothing++-- | Like 'makeFreeCon', but does not provide type signatures.+-- This can be used to attach Haddock comments to individual arguments+-- for each generated function.+--+-- @+-- data LangF x = Output String x+--+-- makeFree_ 'LangF+--+-- -- | Output a string.+-- output :: MonadFree LangF m =>+--           String   -- ^ String to output.+--        -> m ()     -- ^ No result.+-- @+--+-- 'makeFree_' must be called *before* the explicit type signatures.+makeFree_ :: Name -> Q [Dec]+makeFree_ = genFree False Nothing++-- | @$('makeFreeCon' 'Con)@ provides free monadic action for a data+-- constructor @Con@. Note that you can attach Haddock comment to the+-- generated function by placing it before the top-level invocation of+-- 'makeFreeCon':+--+-- @+-- -- | Output a string.+-- makeFreeCon 'Output+-- @+makeFreeCon :: Name -> Q [Dec]+makeFreeCon = genFreeCon True++-- | Like 'makeFreeCon', but does not provide a type signature.+-- This can be used to attach Haddock comments to individual arguments.+--+-- @+-- data LangF x = Output String x+--+-- makeFreeCon_ 'Output+--+-- -- | Output a string.+-- output :: MonadFree LangF m =>+--           String   -- ^ String to output.+--        -> m ()     -- ^ No result.+-- @+--+-- 'makeFreeCon_' must be called *before* the explicit type signature.+makeFreeCon_ :: Name -> Q [Dec]+makeFreeCon_ = genFreeCon False+ {- $doc  To generate free monadic actions from a @Type@, it must be a @data@  declaration (maybe GADT) with at least one free variable. For each constructor of the type, a@@ -247,7 +333,7 @@        @a@ is a fresh type variable.       2. If only one argument in the constructor depends on @param@, then-       @ret ≡ (s1, …, sM)@. In particular, f @M == 0@, then @ret ≡ ()@; if @M == 1@, @ret ≡ s1@.+       @ret ≡ (s1, …, sM)@. In particular, if @M == 0@, then @ret ≡ ()@; if @M == 1@, @ret ≡ s1@.       3. If two arguments depend on @param@, (e.g. @u1 -> … -> uL -> param@ and        @v1 -> … -> vM -> param@, then @ret ≡ Either (u1, …, uL) (v1, …, vM)@.

@@ -40,6 +40,10 @@   , hoistFreeT   , transFreeT   , cutoff+  , partialIterT+  , intersperseT+  , intercalateT+  , retractT   -- * Operations of free monad   , retract   , iter@@ -210,6 +214,7 @@   (>>-) = (>>=)  instance (Functor f, Monad m) => Monad (FreeT f m) where+  fail e = FreeT (fail e)   return a = FreeT (return (Pure a))   {-# INLINE return #-}   FreeT m >>= f = FreeT $ m >>= \v -> case v of@@ -349,8 +354,64 @@ -- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the -- steps in the iteration is terminating. cutoff :: (Functor f, Monad m) => Integer -> FreeT f m a -> FreeT f m (Maybe a)-cutoff 0 _ = return Nothing+cutoff n _ | n <= 0 = return Nothing cutoff n (FreeT m) = FreeT $ bimap Just (cutoff (n - 1)) `liftM` m++-- | @partialIterT n phi m@ interprets first @n@ layers of @m@ using @phi@.+-- This is sort of the opposite for @'cutoff'@.+--+-- Some examples (@n ≥ 0@):+--+-- @+-- 'partialIterT' 0 _ m              ≡ m+-- 'partialIterT' (n+1) phi '.' 'return' ≡ 'return'+-- 'partialIterT' (n+1) phi '.' 'lift'   ≡ 'lift'+-- 'partialIterT' (n+1) phi '.' 'wrap'   ≡ 'join' . 'lift' . phi+-- @+partialIterT :: Monad m => Integer -> (forall a. f a -> m a) -> FreeT f m b -> FreeT f m b+partialIterT n phi m+  | n <= 0 = m+  | otherwise = FreeT $ do+      val <- runFreeT m+      case val of+        Pure a -> return (Pure a)+        Free f -> phi f >>= runFreeT . partialIterT (n - 1) phi++-- | @intersperseT f m@ inserts a layer @f@ between every two layers in+-- @m@.+--+-- @+-- 'intersperseT' f '.' 'return' ≡ 'return'+-- 'intersperseT' f '.' 'lift'   ≡ 'lift'+-- 'intersperseT' f '.' 'wrap'   ≡ 'wrap' '.' 'fmap' ('iterTM' ('wrap' '.' ('<$' f) '.' 'wrap'))+-- @+intersperseT :: (Monad m, Functor f) => f a -> FreeT f m b -> FreeT f m b+intersperseT f (FreeT m) = FreeT $ do+  val <- m+  case val of+    Pure x -> return $ Pure x+    Free y -> return . Free $ fmap (iterTM (wrap . (<$ f) . wrap)) y++-- | Tear down a free monad transformer using Monad instance for @t m@.+retractT :: (MonadTrans t, Monad (t m), Monad m) => FreeT (t m) m a -> t m a+retractT (FreeT m) = do+  val <- lift m+  case val of+    Pure x -> return x+    Free y -> y >>= retractT++-- | @intercalateT f m@ inserts a layer @f@ between every two layers in+-- @m@ and then retracts the result.+--+-- @+-- 'intercalateT' f ≡ 'retractT' . 'intersperseT' f+-- @+intercalateT :: (Monad m, MonadTrans t, Monad (t m), Functor (t m)) => t m a -> FreeT (t m) m b -> t m b+intercalateT f (FreeT m) = do+  val <- lift m+  case val of+    Pure x -> return x+    Free y -> y >>= iterTM (\x -> f >> join x)  #if __GLASGOW_HASKELL__ < 707 instance Typeable1 f => Typeable2 (FreeF f) where

@@ -38,6 +38,7 @@   , improve   , fromF, toF   , retract+  , retractT   , iter   , iterM   -- * Free Monads With Class@@ -232,6 +233,10 @@ retract :: (Functor f, Monad f) => F f a -> f a retract m = runF m return join {-# INLINE retract #-}++-- | Tear down a free monad transformer using iteration over a transformer.+retractT :: (MonadTrans t, Monad (t m), Monad m) => FT (t m) m a -> t m a+retractT (FT m) = join . lift $ m (return . return) $ \x -> return $ x >>= join . lift  -- | Tear down an 'F' 'Monad' using iteration. iter :: Functor f => (f a -> a) -> F f a -> a