packages feed

free 4.6.1 → 4.7

raw patch · 12 files changed

+170/−56 lines, 12 filesdep +prelude-extrasdep ~base

Dependencies added: prelude-extras

Dependency ranges changed: base

Files

.gitignore view
@@ -11,3 +11,5 @@ *.hi *~ *#+.cabal-sandbox/+cabal.sandbox.config
CHANGELOG.markdown view
@@ -1,3 +1,8 @@+4.7+---+* Added `prelude-extras` support. This makes it possible to work without `UndecidableInstances` for most operations.+* Removed the `GHC_TYPEABLE` flag.+ 4.6.1 ----- * Added `hoistF`
free.cabal view
@@ -1,6 +1,6 @@ name:          free category:      Control, Monads-version:       4.6.1+version:       4.7 license:       BSD3 cabal-version: >= 1.10 license-file:  LICENSE@@ -14,16 +14,22 @@ description:   Free monads are useful for many tree-like structures and domain specific languages.   .-  A 'Monad' @n@ is a free 'Monad' for @f@ if every 'Monad' homomorphism-  from @n@ to another monad @m@ is equivalent to a natural transformation-  from @f@ to @m@.+  If @f@ is a 'Functor' then the free 'Monad' on @f@ is the type+  of trees whose nodes are labeled with the constructors of @f@. The word+  \"free\" is used in the sense of \"unrestricted\" rather than \"zero-cost\":+  @Free f@ makes no constraining assumptions beyond those given by @f@ and the+  definition of 'Monad'. As used here it is a standard term from the+  mathematical theory of adjoint functors.   .-  Cofree comonads provide convenient ways to talk about branching streams and rose-trees,-  and can be used to annotate syntax trees.+  Cofree comonads are dual to free monads. They provide convenient ways to talk+  about branching streams and rose-trees, and can be used to annotate syntax+  trees. The cofree comonad can be seen as a stream parameterized by a 'Functor'+  that controls its branching factor.   .-  A 'Comonad' @v@ is a cofree 'Comonad' for @f@ if every 'Comonad' homomorphism-  another comonad @w@ to @v@ is equivalent to a natural transformation-  from @w@ to @f@.+  More information on free monads, including examples, can be found in the+  following blog posts:+  <http://comonad.com/reader/2008/monads-for-free/>+  <http://comonad.com/reader/2011/free-monads-for-less/>  build-type:    Simple extra-source-files:@@ -60,14 +66,12 @@     comonad              == 4.*,     distributive         >= 0.2.1,     mtl                  >= 2.0.1.0 && < 2.2,+    prelude-extras       >= 0.4 && < 1,     profunctors          == 4.*,     semigroupoids        == 4.*,     semigroups           >= 0.8.3.1 && < 1,     transformers         >= 0.2.0   && < 0.4,     template-haskell     >= 2.7.0.0 && < 3--  if impl(ghc)-    cpp-options: -DGHC_TYPEABLE    exposed-modules:     Control.Applicative.Free
src/Control/Alternative/Free.hs view
@@ -30,10 +30,7 @@ import Control.Applicative import Data.Functor.Apply import Data.Semigroup--#ifdef GHC_TYPEABLE import Data.Typeable-#endif  infixl 3 `Ap` @@ -129,7 +126,7 @@ hoistAlt f (Alt as) = Alt (map (hoistAltF f) as) {-# INLINE hoistAlt #-} -#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707+#if __GLASGOW_HASKELL__ < 707 instance Typeable1 f => Typeable1 (Alt f) where   typeOf1 t = mkTyConApp altTyCon [typeOf1 (f t)] where     f :: Alt f a -> f a
src/Control/Applicative/Free.hs view
@@ -35,17 +35,14 @@  import Control.Applicative import Data.Functor.Apply--#ifdef GHC_TYPEABLE import Data.Typeable-#endif  -- | The free 'Applicative' for a 'Functor' @f@. data Ap f a where   Pure :: a -> Ap f a   Ap   :: f a -> Ap f (a -> b) -> Ap f b #if __GLASGOW_HASKELL__ >= 707-  deriving (Typeable)+  deriving Typeable #endif  -- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@.@@ -86,7 +83,7 @@ retractAp (Pure a) = pure a retractAp (Ap x y) = x <**> retractAp y -#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707+#if __GLASGOW_HASKELL__ < 707 instance Typeable1 f => Typeable1 (Ap f) where   typeOf1 t = mkTyConApp apTyCon [typeOf1 (f t)] where     f :: Ap f a -> f a
src/Control/Comonad/Cofree.hs view
@@ -43,6 +43,7 @@ import Control.Monad.Zip import Data.Functor.Bind import Data.Functor.Extend+import Data.Data import Data.Distributive import Data.Foldable import Data.Semigroup@@ -50,10 +51,8 @@ import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Prelude hiding (id,(.))+import Prelude.Extras -#ifdef GHC_TYPEABLE-import Data.Data-#endif  infixr 5 :< @@ -178,10 +177,21 @@   (<*>) = ap   {-# INLINE (<*>) #-} +instance (Functor f, Show1 f) => Show1 (Cofree f) where+  showsPrec1 d (a :< as) = showParen (d > 5) $+    showsPrec 6 a . showString " :< " . showsPrec1 5 (fmap Lift1 as)+ instance (Show (f (Cofree f a)), Show a) => Show (Cofree f a) where   showsPrec d (a :< as) = showParen (d > 5) $     showsPrec 6 a . showString " :< " . showsPrec 5 as +instance (Functor f, Read1 f) => Read1 (Cofree f) where+  readsPrec1 d r = readParen (d > 5)+                          (\r' -> [(u :< fmap lower1 v,w) |+                                  (u, s) <- readsPrec 6 r',+                                  (":<", t) <- lex s,+                                  (v, w) <- readsPrec1 5 t]) r+ instance (Read (f (Cofree f a)), Read a) => Read (Cofree f a) where   readsPrec d r = readParen (d > 5)                           (\r' -> [(u :< v,w) |@@ -194,12 +204,23 @@   a :< as == b :< bs = a == b && as == bs #endif +instance (Functor f, Eq1 f) => Eq1 (Cofree f) where+#ifndef HLINT+  a :< as ==# b :< bs = a == b && fmap Lift1 as ==# fmap Lift1 bs+#endif+ instance (Ord (f (Cofree f a)), Ord a) => Ord (Cofree f a) where   compare (a :< as) (b :< bs) = case compare a b of     LT -> LT     EQ -> compare as bs     GT -> GT +instance (Functor f, Ord1 f) => Ord1 (Cofree f) where+  compare1 (a :< as) (b :< bs) = case compare a b of+    LT -> LT+    EQ -> compare1 (fmap Lift1 as) (fmap Lift1 bs)+    GT -> GT+ instance Foldable f => Foldable (Cofree f) where   foldMap f = go where     go (a :< as) = f a `mappend` foldMap go as@@ -220,7 +241,7 @@     go (a :< as) = (:<) <$> f a <.> traverse1 go as   {-# INLINE traverse1 #-} -#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707+#if __GLASGOW_HASKELL__ < 707 instance (Typeable1 f) => Typeable1 (Cofree f) where   typeOf1 dfa = mkTyConApp cofreeTyCon [typeOf1 (f dfa)]     where
src/Control/Comonad/Trans/Cofree.hs view
@@ -45,10 +45,7 @@ import Control.Monad.Trans import Control.Monad.Zip import Prelude hiding (id,(.))--#if defined(GHC_TYPEABLE) || __GLASGOW_HASKELL__ >= 707 import Data.Data-#endif  infixr 5 :< @@ -184,8 +181,6 @@ coiterT :: (Functor f, Comonad w) => (w a -> f (w a)) -> w a -> CofreeT f w a coiterT psi = CofreeT . extend (\w -> extract w :< fmap (coiterT psi) (psi w)) -#if defined(GHC_TYPEABLE) - #if __GLASGOW_HASKELL__ < 707  instance Typeable1 f => Typeable2 (CofreeF f) where@@ -251,7 +246,6 @@ cofreeTDataType = mkDataType "Control.Comonad.Trans.Cofree.CofreeT" [cofreeTConstr] {-# NOINLINE cofreeFDataType #-} {-# NOINLINE cofreeTDataType #-}-#endif  -- lowerF :: (Functor f, Comonad w) => CofreeT f w a -> f a -- lowerF = fmap extract . unwrap
src/Control/Comonad/Trans/Coiter.hs view
@@ -56,21 +56,34 @@ import Data.Bifunctor import Data.Bifoldable import Data.Bitraversable+import Data.Data import Data.Foldable+import Data.Function (on) import Data.Functor.Identity import Data.Traversable import Prelude hiding (id,(.))--#if defined(GHC_TYPEABLE) || __GLASGOW_HASKELL__ >= 707-import Data.Data-#endif+import Prelude.Extras  -- | This is the coiterative comonad generated by a comonad newtype CoiterT w a = CoiterT { runCoiterT :: w (a, CoiterT w a) }-#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ >= 707+#if __GLASGOW_HASKELL__ >= 707   deriving Typeable #endif +instance (Functor w, Eq1 w) => Eq1 (CoiterT w) where+  (==#) = on (==#) (fmap (fmap Lift1) . runCoiterT)++instance (Functor w, Ord1 w) => Ord1 (CoiterT w) where+  compare1 = on compare1 (fmap (fmap Lift1) . runCoiterT)++instance (Functor w, Show1 w) => Show1 (CoiterT w) where+  showsPrec1 d (CoiterT as) = showParen (d > 10) $+    showString "CoiterT " . showsPrec1 11 (fmap (fmap Lift1) as)++instance (Functor w, Read1 w) => Read1 (CoiterT w) where+  readsPrec1 d =  readParen (d > 10) $ \r ->+    [ (CoiterT (fmap (fmap lower1) m),t) | ("CoiterT",s) <- lex r, (m,t) <- readsPrec1 11 s]+ -- | The coiterative comonad type Coiter = CoiterT Identity @@ -154,7 +167,6 @@ unfold :: Comonad w => (w a -> a) -> w a -> CoiterT w a unfold psi = CoiterT . extend (extract &&& unfold psi . extend psi) -#if defined(GHC_TYPEABLE) #if __GLASGOW_HASKELL__ < 707  instance Typeable1 w => Typeable1 (CoiterT w) where@@ -194,8 +206,6 @@ coiterTDataType :: DataType coiterTDataType = mkDataType "Control.Comonad.Trans.Coiter.CoiterT" [coiterTConstr] {-# NOINLINE coiterTDataType #-}--#endif  -- BEGIN Coiter.lhs {- $example
src/Control/Monad/Free.hs view
@@ -48,10 +48,8 @@ import Data.Traversable import Data.Semigroup.Foldable import Data.Semigroup.Traversable--#ifdef GHC_TYPEABLE import Data.Data-#endif+import Prelude.Extras  -- | The 'Free' 'Monad' for a 'Functor' @f@. --@@ -102,23 +100,50 @@   deriving (Typeable) #endif +instance (Functor f, Eq1 f) => Eq1 (Free f) where+  Pure a  ==# Pure b  = a == b+  Free fa ==# Free fb = fmap Lift1 fa ==# fmap Lift1 fb+  _       ==# _ = False+ instance (Eq (f (Free f a)), Eq a) => Eq (Free f a) where   Pure a == Pure b = a == b   Free fa == Free fb = fa == fb   _ == _ = False +instance (Functor f, Ord1 f) => Ord1 (Free f) where+  Pure a `compare1` Pure b = a `compare` b+  Pure _ `compare1` Free _ = LT+  Free _ `compare1` Pure _ = GT+  Free fa `compare1` Free fb = fmap Lift1 fa `compare1` fmap Lift1 fb+ instance (Ord (f (Free f a)), Ord a) => Ord (Free f a) where   Pure a `compare` Pure b = a `compare` b   Pure _ `compare` Free _ = LT   Free _ `compare` Pure _ = GT   Free fa `compare` Free fb = fa `compare` fb +instance (Functor f, Show1 f) => Show1 (Free f) where+  showsPrec1 d (Pure a) = showParen (d > 10) $+    showString "Pure " . showsPrec 11 a+  showsPrec1 d (Free m) = showParen (d > 10) $+    showString "Free " . showsPrec1 11 (fmap Lift1 m)+ instance (Show (f (Free f a)), Show a) => Show (Free f a) where   showsPrec d (Pure a) = showParen (d > 10) $     showString "Pure " . showsPrec 11 a   showsPrec d (Free m) = showParen (d > 10) $     showString "Free " . showsPrec 11 m +instance (Functor f, Read1 f) => Read1 (Free f) where+  readsPrec1 d r = readParen (d > 10)+      (\r' -> [ (Pure m, t)+             | ("Pure", s) <- lex r'+             , (m, t) <- readsPrec 11 s]) r+    ++ readParen (d > 10)+      (\r' -> [ (Free (fmap lower1 m), t)+             | ("Free", s) <- lex r'+             , (m, t) <- readsPrec1 11 s]) r+ instance (Read (f (Free f a)), Read a) => Read (Free f a) where   readsPrec d r = readParen (d > 10)       (\r' -> [ (Pure m, t)@@ -302,7 +327,7 @@ {-# INLINE _Free #-}  -#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707+#if __GLASGOW_HASKELL__ < 707 instance Typeable1 f => Typeable1 (Free f) where   typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where     f :: Free f a -> f a
src/Control/Monad/Free/TH.hs view
@@ -158,7 +158,7 @@       qa = case retType of VarT b | a == b -> [a]; _ -> []       f' = foldl AppT f (map VarT ns)   return-#if __GLASGOW_HASKELL__ >= 709+#if MIN_VERSION_template_haskell(2,10,0)     [ SigD opName (ForallT q [ConT monadFree `AppT` f' `AppT` VarT m] opType) #else     [ SigD opName (ForallT q [ClassP monadFree [f', VarT m]] opType)
src/Control/Monad/Trans/Free.hs view
@@ -60,14 +60,14 @@ import Data.Functor.Bind hiding (join) import Data.Monoid import Data.Foldable+import Data.Function (on) import Data.Functor.Identity import Data.Traversable import Data.Bifunctor import Data.Bifoldable import Data.Bitraversable-#ifdef GHC_TYPEABLE import Data.Data-#endif+import Prelude.Extras  -- | The base functor for a free monad. data FreeF f a b = Pure a | Free (f b)@@ -77,6 +77,43 @@ #endif            ) +instance Show1 f => Show2 (FreeF f) where+  showsPrec2 d (Pure a)  = showParen (d > 10) $ showString "Pure " . showsPrec 11 a+  showsPrec2 d (Free as) = showParen (d > 10) $ showString "Free " . showsPrec1 11 as++instance (Show1 f, Show a) => Show1 (FreeF f a) where+  showsPrec1 = showsPrec2++instance Read1 f => Read2 (FreeF f) where+  readsPrec2 d r = readParen (d > 10)+      (\r' -> [ (Pure m, t)+             | ("Pure", s) <- lex r'+             , (m, t) <- readsPrec 11 s]) r+    ++ readParen (d > 10)+      (\r' -> [ (Free m, t)+             | ("Free", s) <- lex r'+             , (m, t) <- readsPrec1 11 s]) r++instance (Read1 f, Read a) => Read1 (FreeF f a) where+  readsPrec1 = readsPrec2++instance Eq1 f => Eq2 (FreeF f) where+  Pure a  ==## Pure b = a == b+  Free as ==## Free bs = as ==# bs+  _       ==## _ = False++instance (Eq1 f, Eq a) => Eq1 (FreeF f a) where+  (==#) = (==##)++instance Ord1 f => Ord2 (FreeF f) where+  Pure a `compare2` Pure b = a `compare` b+  Pure _ `compare2` Free _ = LT+  Free _ `compare2` Pure _ = GT+  Free fa `compare2` Free fb = fa `compare1` fb++instance (Ord1 f, Ord a) => Ord1 (FreeF f a) where+  compare1 = compare2+ instance Functor f => Functor (FreeF f a) where   fmap _ (Pure a)  = Pure a   fmap f (Free as) = Free (fmap f as)@@ -129,12 +166,27 @@ {-# INLINE free #-}  deriving instance Eq (m (FreeF f a (FreeT f m a))) => Eq (FreeT f m a)++instance (Functor f, Eq1 f, Functor m, Eq1 m) => Eq1 (FreeT f m) where+  (==#) = on (==#) (fmap (Lift1 . fmap Lift1) . runFreeT)+ deriving instance Ord (m (FreeF f a (FreeT f m a))) => Ord (FreeT f m a) +instance (Functor f, Ord1 f, Functor m, Ord1 m) => Ord1 (FreeT f m) where+  compare1 = on compare1 (fmap (Lift1 . fmap Lift1) . runFreeT)++instance (Functor f, Show1 f, Functor m, Show1 m) => Show1 (FreeT f m) where+  showsPrec1 d (FreeT m) = showParen (d > 10) $+    showString "FreeT " . showsPrec1 11 (Lift1 . fmap Lift1 <$> m)+ instance Show (m (FreeF f a (FreeT f m a))) => Show (FreeT f m a) where   showsPrec d (FreeT m) = showParen (d > 10) $     showString "FreeT " . showsPrec 11 m +instance (Functor f, Read1 f, Functor m, Read1 m) => Read1 (FreeT f m) where+  readsPrec1 d =  readParen (d > 10) $ \r ->+    [ (FreeT (fmap lower1 . lower1 <$> m),t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec1 11 s]+ instance Read (m (FreeF f a (FreeT f m a))) => Read (FreeT f m a) where   readsPrec d =  readParen (d > 10) $ \r ->     [ (FreeT m,t) | ("FreeT",s) <- lex r, (m,t) <- readsPrec 11 s]@@ -280,7 +332,7 @@ iterM :: (Functor f, Monad m) => (f (m a) -> m a) -> Free f a -> m a iterM phi = iterT phi . hoistFreeT (return . runIdentity) -#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707+#if __GLASGOW_HASKELL__ < 707 instance Typeable1 f => Typeable2 (FreeF f) where   typeOf2 t = mkTyConApp freeFTyCon [typeOf1 (f t)] where     f :: FreeF f a b -> f a
src/Control/Monad/Trans/Iter.hs view
@@ -79,15 +79,14 @@ import Data.Functor.Bind hiding (join) import Data.Functor.Identity import Data.Foldable hiding (fold)+import Data.Function (on) import Data.Traversable hiding (mapM) import Data.Monoid import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Typeable--#ifdef GHC_TYPEABLE import Data.Data-#endif+import Prelude.Extras  -- | The monad supporting iteration based over a base monad @m@. --@@ -116,16 +115,30 @@ runIter = runIdentity . runIterT {-# INLINE runIter #-} +instance (Functor m, Eq1 m) => Eq1 (IterT m) where+  (==#) = on (==#) (fmap (fmap Lift1) . runIterT)+ instance Eq (m (Either a (IterT m a))) => Eq (IterT m a) where   IterT m == IterT n = m == n +instance (Functor m, Ord1 m) => Ord1 (IterT m) where+  compare1 = on compare1 (fmap (fmap Lift1) . runIterT)+ instance Ord (m (Either a (IterT m a))) => Ord (IterT m a) where   compare (IterT m) (IterT n) = compare m n +instance (Functor m, Show1 m) => Show1 (IterT m) where+  showsPrec1 d (IterT m) = showParen (d > 10) $+    showString "IterT " . showsPrec1 11 (fmap (fmap Lift1) m)+ instance Show (m (Either a (IterT m a))) => Show (IterT m a) where   showsPrec d (IterT m) = showParen (d > 10) $     showString "IterT " . showsPrec 11 m +instance (Functor m, Read1 m) => Read1 (IterT m) where+  readsPrec1 d =  readParen (d > 10) $ \r ->+    [ (IterT (fmap (fmap lower1) m),t) | ("IterT",s) <- lex r, (m,t) <- readsPrec1 11 s]+ instance Read (m (Either a (IterT m a))) => Read (IterT m a) where   readsPrec d =  readParen (d > 10) $ \r ->     [ (IterT m,t) | ("IterT",s) <- lex r, (m,t) <- readsPrec 11 s]@@ -360,8 +373,6 @@       compact' a (r@(Right _):xs) = (Left a):(r:(compact xs))       compact' a (  (Left a'):xs) = compact' (a <> a') xs -#if defined(GHC_TYPEABLE)- #if __GLASGOW_HASKELL__ < 707 instance Typeable1 m => Typeable1 (IterT m) where   typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where@@ -377,9 +388,7 @@ {-# NOINLINE freeTyCon #-}  #else- #define Typeable1 Typeable- #endif  instance@@ -402,8 +411,6 @@ iterDataType :: DataType iterDataType = mkDataType "Control.Monad.Iter.IterT" [iterConstr] {-# NOINLINE iterDataType #-}--#endif  -- BEGIN MandelbrotIter.lhs {- $example