packages feed

free 2.2 → 3.0

raw patch · 9 files changed

+472/−462 lines, 9 filesdep ~basedep ~comonaddep ~comonad-transformersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, comonad, comonad-transformers, comonads-fd, semigroupoids

API changes (from Hackage documentation)

+ Control.Comonad.Cofree: instance ComonadApply f => ComonadApply (Cofree f)

Files

− Control/Comonad/Cofree.hs 
@@ -1,193 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--------------------------------------------------------------------------------- |--- Module      :  Control.Comonad.Cofree--- Copyright   :  (C) 2008-2011 Edward Kmett,--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  MPTCs, fundeps------ Cofree comonads---------------------------------------------------------------------------------module Control.Comonad.Cofree-  ( Cofree(..)-  , section-  , unwrap-  , coiter-  , unfold-  -- * Lenses into cofree comonads-  , extracting-  , unwrapping-  , telescoping-  ) where--import Control.Applicative-import Control.Comonad-import Control.Comonad.Trans.Class-import Control.Comonad.Cofree.Class-import Control.Comonad.Env.Class-import Control.Comonad.Store.Class as Class-import Control.Comonad.Traced.Class-import Control.Category-import Data.Functor.Bind-import Data.Distributive-import Data.Foldable-import Data.Semigroup-import Data.Traversable-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Prelude hiding (id,(.))--#ifdef GHC_TYPEABLE-import Data.Data-#endif--infixr 5 :<--data Cofree f a = a :< f (Cofree f a)--coiter :: Functor f => (a -> f a) -> a -> Cofree f a-coiter psi a = a :< (coiter psi <$> psi a)--unfold :: Functor f => (b -> (a, f b)) -> b -> Cofree f a-unfold f c = case f c of-  (x, d) -> x :< fmap (unfold f) d--instance Functor f => ComonadCofree f (Cofree f) where-  unwrap (_ :< as) = as--instance Distributive f => Distributive (Cofree f) where-  distribute w = fmap extract w :< fmap distribute (collect unwrap w)--instance Functor f => Functor (Cofree f) where-  fmap f (a :< as) = f a :< fmap (fmap f) as-  b <$ (_ :< as) = b :< fmap (b <$) as--instance Functor f => Extend (Cofree f) where-  extend f w = f w :< fmap (extend f) (unwrap w)-  duplicate w = w :< fmap duplicate (unwrap w)--instance Functor f => Comonad (Cofree f) where-  extract (a :< _) = a--instance ComonadTrans Cofree where-  lower (_ :< as) = fmap extract as---- | lower . section = id-section :: Comonad f => f a -> Cofree f a-section as = extract as :< extend section as--instance Apply f => Apply (Cofree f) where-  (f :< fs) <.> (a :< as) = f a :< ((<.>) <$> fs <.> as)-  (f :< fs) <.  (_ :< as) = f :< ((<. ) <$> fs <.> as)-  (_ :< fs)  .> (a :< as) = a :< (( .>) <$> fs <.> as)--instance Applicative f => Applicative (Cofree f) where-  pure a = as where as = a :< pure as-  (f :< fs) <*> (a :< as) = f a :< ((<*>) <$> fs <*> as)-  (f :< fs) <*  (_ :< as) = f :< ((<* ) <$> fs <*> as)-  (_ :< fs)  *> (a :< as) = a :< (( *>) <$> fs <*> 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 (Read (f (Cofree f a)), Read a) => Read (Cofree f a) where-  readsPrec d r = readParen (d > 5)-                          (\r' -> [(u :< v,w) |-                                  (u, s) <- readsPrec 6 r',-                                  (":<", t) <- lex s,-                                  (v, w) <- readsPrec 5 t]) r--instance (Eq (f (Cofree f a)), Eq a) => Eq (Cofree f a) where-  a :< as == b :< bs = a == b && as == bs--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 Foldable f => Foldable (Cofree f) where-  foldMap f (a :< as) = f a `mappend` foldMap (foldMap f) as--instance Foldable1 f => Foldable1 (Cofree f) where-  foldMap1 f (a :< as) = f a <> foldMap1 (foldMap1 f) as--instance Traversable f => Traversable (Cofree f) where-  traverse f (a :< as) = (:<) <$> f a <*> traverse (traverse f) as--instance Traversable1 f => Traversable1 (Cofree f) where-  traverse1 f (a :< as) = (:<) <$> f a <.> traverse1 (traverse1 f) as--#ifdef GHC_TYPEABLE-instance (Typeable1 f) => Typeable1 (Cofree f) where-  typeOf1 dfa = mkTyConApp cofreeTyCon [typeOf1 (f dfa)]-    where-      f :: Cofree f a -> f a-      f = undefined--instance (Typeable1 f, Typeable a) => Typeable (Cofree f a) where-  typeOf = typeOfDefault--cofreeTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-cofreeTyCon = mkTyCon "Control.Comonad.Cofree.Cofree"-#else-cofreeTyCon = mkTyCon3 "free" "Control.Comonad.Cofree" "Cofree"-#endif-{-# NOINLINE cofreeTyCon #-}--instance-  ( Typeable1 f-  , Data (f (Cofree f a))-  , Data a-  ) => Data (Cofree f a) where-    gfoldl f z (a :< as) = z (:<) `f` a `f` as-    toConstr _ = cofreeConstr-    gunfold k z c = case constrIndex c of-        1 -> k (k (z (:<)))-        _ -> error "gunfold"-    dataTypeOf _ = cofreeDataType-    dataCast1 f = gcast1 f--cofreeConstr :: Constr-cofreeConstr = mkConstr cofreeDataType ":<" [] Infix-{-# NOINLINE cofreeConstr #-}--cofreeDataType :: DataType-cofreeDataType = mkDataType "Control.Comonad.Cofree.Cofree" [cofreeConstr]-{-# NOINLINE cofreeDataType #-}-#endif--instance ComonadEnv e w => ComonadEnv e (Cofree w) where-  ask = ask . lower--instance ComonadStore s w => ComonadStore s (Cofree w) where-  pos (_ :< as) = Class.pos as-  peek s (_ :< as) = extract (Class.peek s as)---instance ComonadTraced m w => ComonadTraced m (Cofree w) where-  trace m = trace m . lower--extracting :: Functor f => (a -> f a) -> Cofree g a -> f (Cofree g a)-extracting f (a :< as) = (:< as) <$> f a-{-# INLINE extracting #-}--unwrapping :: Functor f => (g (Cofree g a) -> f (g (Cofree g a))) -> Cofree g a -> f (Cofree g a)-unwrapping f (a :< as) = (a :<) <$> f as-{-# INLINE unwrapping #-}--telescoping :: (Functor f, Functor g) =>-             [(Cofree g a -> f (Cofree g a)) -> g (Cofree g a) -> f (g (Cofree g a))] ->-              (a -> f a) -> Cofree g a -> f (Cofree g a)-telescoping [] = extracting-telescoping (l:ls) = unwrapping . l . telescoping ls
− Control/Comonad/Cofree/Class.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module      :  Control.Comonad.Cofree.Class--- Copyright   :  (C) 2008-2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  experimental--- Portability :  fundeps, MPTCs------------------------------------------------------------------------------module Control.Comonad.Cofree.Class-  ( ComonadCofree(..)-  ) where--import Control.Applicative-import Control.Comonad-import Control.Comonad.Trans.Env-import Control.Comonad.Trans.Store-import Control.Comonad.Trans.Traced-import Control.Comonad.Trans.Identity-import Data.Semigroup--class (Functor f, Comonad w) => ComonadCofree f w | w -> f where-  unwrap :: w a -> f (w a)--instance ComonadCofree f w => ComonadCofree f (IdentityT w) where-  unwrap = fmap IdentityT . unwrap . runIdentityT--instance ComonadCofree f w => ComonadCofree f (EnvT e w) where-  unwrap (EnvT e wa) = EnvT e <$> unwrap wa--instance ComonadCofree f w => ComonadCofree f (StoreT s w) where-  unwrap (StoreT wsa s) = flip StoreT s <$> unwrap wsa--instance (ComonadCofree f w, Semigroup m, Monoid m) => ComonadCofree f (TracedT m w) where-  unwrap (TracedT wma) = TracedT <$> unwrap wma
− Control/Monad/Free.hs 
@@ -1,157 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--------------------------------------------------------------------------------- |--- Module      :  Control.Monad.Free--- Copyright   :  (C) 2008-2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  MPTCs, fundeps------ Free monads---------------------------------------------------------------------------------module Control.Monad.Free-  ( MonadFree(..)-  , Free(..)-  , retract-  , liftF-  , iter-  ) where--import Control.Applicative-import Control.Monad (liftM, MonadPlus(..))-import Control.Monad.Trans.Class-import Control.Monad.Free.Class-import Control.Monad.Reader.Class-import Control.Monad.Writer.Class-import Control.Monad.State.Class-import Control.Monad.Error.Class-import Control.Monad.Cont.Class-import Data.Functor.Bind-import Data.Foldable-import Data.Traversable-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable--data Free f a = Pure a | Free (f (Free f a))--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 (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 (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 (Read (f (Free f a)), Read a) => Read (Free f a) where-  readsPrec 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) <- readsPrec 11 s]) r--instance Functor f => Functor (Free f) where-  fmap f (Pure a)  = Pure (f a)-  fmap f (Free fa) = Free (fmap f <$> fa)--instance Functor f => Apply (Free f) where-  Pure a  <.> Pure b = Pure (a b)-  Pure a  <.> Free fb = Free $ fmap a <$> fb-  Free fa <.> b = Free $ (<.> b) <$> fa--instance Functor f => Applicative (Free f) where-  pure = Pure-  Pure a <*> Pure b = Pure $ a b-  Pure a <*> Free mb = Free $ fmap a <$> mb-  Free ma <*> b = Free $ (<*> b) <$> ma--instance Functor f => Bind (Free f) where-  Pure a >>- f = f a-  Free m >>- f = Free ((>>- f) <$> m)--instance Functor f => Monad (Free f) where-  return = Pure-  Pure a >>= f = f a-  Free m >>= f = Free ((>>= f) <$> m)--instance Alternative v => Alternative (Free v) where-  empty = Free empty-  a <|> b = Free (pure a <|> pure b)--instance (Functor v, MonadPlus v) => MonadPlus (Free v) where-  mzero = Free mzero-  a `mplus` b = Free (return a `mplus` return b)--instance MonadTrans Free where-  lift = Free . liftM Pure--instance Foldable f => Foldable (Free f) where-  foldMap f (Pure a) = f a-  foldMap f (Free fa) = foldMap (foldMap f) fa--instance Foldable1 f => Foldable1 (Free f) where-  foldMap1 f (Pure a) = f a-  foldMap1 f (Free fa) = foldMap1 (foldMap1 f) fa--instance Traversable f => Traversable (Free f) where-  traverse f (Pure a) = Pure <$> f a-  traverse f (Free fa) = Free <$> traverse (traverse f) fa--instance Traversable1 f => Traversable1 (Free f) where-  traverse1 f (Pure a) = Pure <$> f a-  traverse1 f (Free fa) = Free <$> traverse1 (traverse1 f) fa--instance (Functor m, MonadWriter e m) => MonadWriter e (Free m) where-  tell = lift . tell-  listen = lift . listen . retract-  pass = lift . pass . retract--instance (Functor m, MonadReader e m) => MonadReader e (Free m) where-  ask = lift ask-  local f = lift . local f . retract--instance (Functor m, MonadState s m) => MonadState s (Free m) where-  get = lift get-  put s = lift (put s)--instance (Functor m, MonadError e m) => MonadError e (Free m) where-  throwError = lift . throwError-  catchError as f = lift (catchError (retract as) (retract . f))--instance (Functor m, MonadCont m) => MonadCont (Free m) where-  callCC f = lift (callCC (retract . f . liftM lift))--liftF :: Functor f => f a -> Free f a-liftF = Free . fmap Pure--instance Functor f => MonadFree f (Free f) where-  wrap = Free---- |------ > retract . lift = id--- > retract . liftF = id-retract :: Monad f => Free f a -> f a-retract (Pure a) = return a-retract (Free as) = as >>= retract--iter :: Functor f => (f a -> a) -> Free f a -> a-iter _ (Pure a) = a-iter phi (Free m) = phi (iter phi <$> m)
− Control/Monad/Free/Class.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module      :  Control.Monad.Free.Class--- Copyright   :  (C) 2008-2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  experimental--- Portability :  non-portable (fundeps, MPTCs)------------------------------------------------------------------------------module Control.Monad.Free.Class-  ( MonadFree(..)-  ) where--import Control.Applicative-import Control.Monad.Trans.Reader-import qualified Control.Monad.Trans.State.Strict as Strict-import qualified Control.Monad.Trans.State.Lazy as Lazy-import qualified Control.Monad.Trans.Writer.Strict as Strict-import qualified Control.Monad.Trans.Writer.Lazy as Lazy-import qualified Control.Monad.Trans.RWS.Strict as Strict-import qualified Control.Monad.Trans.RWS.Lazy as Lazy-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.List-import Control.Monad.Trans.Error-import Control.Monad.Trans.Identity-import Data.Monoid--class Monad m => MonadFree f m | m -> f where-  wrap :: f (m a) -> m a--instance (Functor f, MonadFree f m) => MonadFree f (ReaderT e m) where-  wrap fm = ReaderT $ \e -> wrap $ flip runReaderT e <$> fm--instance (Functor f, MonadFree f m) => MonadFree f (Lazy.StateT s m) where-  wrap fm = Lazy.StateT $ \s -> wrap $ flip Lazy.runStateT s <$> fm--instance (Functor f, MonadFree f m) => MonadFree f (Strict.StateT s m) where-  wrap fm = Strict.StateT $ \s -> wrap $ flip Strict.runStateT s <$> fm--instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Lazy.WriterT w m) where-  wrap = Lazy.WriterT . wrap . fmap Lazy.runWriterT--instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Strict.WriterT w m) where-  wrap = Strict.WriterT . wrap . fmap Strict.runWriterT--instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Strict.RWST r w s m) where-  wrap fm = Strict.RWST $ \r s -> wrap $ fmap (\m -> Strict.runRWST m r s) fm--instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Lazy.RWST r w s m) where-  wrap fm = Lazy.RWST $ \r s -> wrap $ fmap (\m -> Lazy.runRWST m r s) fm--instance (Functor f, MonadFree f m) => MonadFree f (MaybeT m) where-  wrap = MaybeT . wrap . fmap runMaybeT--instance (Functor f, MonadFree f m) => MonadFree f (IdentityT m) where-  wrap = IdentityT . wrap . fmap runIdentityT--instance (Functor f, MonadFree f m) => MonadFree f (ListT m) where-  wrap = ListT . wrap . fmap runListT--instance (Functor f, MonadFree f m, Error e) => MonadFree f (ErrorT e m) where-  wrap = ErrorT . wrap . fmap runErrorT
free.cabal view
@@ -1,6 +1,6 @@ name:          free category:      Control, Monads-version:       2.2+version:       3.0 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -20,6 +20,8 @@   location: git://github.com/ekmett/free.git  library+  hs-source-dirs: src+   other-extensions:     MultiParamTypeClasses     FunctionalDependencies@@ -31,10 +33,10 @@     distributive         >= 0.2.1   && < 0.3,     transformers         >= 0.2.0   && < 0.4,     mtl                  >= 2.0.1.0 && < 2.2,-    semigroupoids        >= 1.3.1.2 && < 1.4,-    comonad              >= 1.1.1.5 && < 1.2,-    comonad-transformers >= 2.1.1.1 && < 2.2,-    comonads-fd          >= 2.1.1.1 && < 2.2,+    semigroupoids        >= 3.0     && < 3.1,+    comonad              >= 3.0     && < 3.1,+    comonad-transformers >= 3.0     && < 3.1,+    comonads-fd          >= 3.0     && < 3.1,     semigroups           >= 0.8.3.1 && < 0.9    if impl(ghc)
+ src/Control/Comonad/Cofree.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Comonad.Cofree+-- Copyright   :  (C) 2008-2011 Edward Kmett,+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  MPTCs, fundeps+--+-- Cofree comonads+--+----------------------------------------------------------------------------+module Control.Comonad.Cofree+  ( Cofree(..)+  , section+  , unwrap+  , coiter+  , unfold+  -- * Lenses into cofree comonads+  , extracting+  , unwrapping+  , telescoping+  ) where++import Control.Applicative+import Control.Comonad+import Control.Comonad.Trans.Class+import Control.Comonad.Cofree.Class+import Control.Comonad.Env.Class+import Control.Comonad.Store.Class as Class+import Control.Comonad.Traced.Class+import Control.Category+import Data.Functor.Bind+import Data.Functor.Extend+import Data.Distributive+import Data.Foldable+import Data.Semigroup+import Data.Traversable+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Prelude hiding (id,(.))++#ifdef GHC_TYPEABLE+import Data.Data+#endif++infixr 5 :<++data Cofree f a = a :< f (Cofree f a)++coiter :: Functor f => (a -> f a) -> a -> Cofree f a+coiter psi a = a :< (coiter psi <$> psi a)++unfold :: Functor f => (b -> (a, f b)) -> b -> Cofree f a+unfold f c = case f c of+  (x, d) -> x :< fmap (unfold f) d++instance Functor f => ComonadCofree f (Cofree f) where+  unwrap (_ :< as) = as++instance Distributive f => Distributive (Cofree f) where+  distribute w = fmap extract w :< fmap distribute (collect unwrap w)++instance Functor f => Functor (Cofree f) where+  fmap f (a :< as) = f a :< fmap (fmap f) as+  b <$ (_ :< as) = b :< fmap (b <$) as++instance Functor f => Extend (Cofree f) where+  extended = extend+  duplicated = duplicate++instance Functor f => Comonad (Cofree f) where+  extend f w = f w :< fmap (extend f) (unwrap w)+  duplicate w = w :< fmap duplicate (unwrap w)+  extract (a :< _) = a++instance ComonadTrans Cofree where+  lower (_ :< as) = fmap extract as++-- | lower . section = id+section :: Comonad f => f a -> Cofree f a+section as = extract as :< extend section as++instance Apply f => Apply (Cofree f) where+  (f :< fs) <.> (a :< as) = f a :< ((<.>) <$> fs <.> as)+  (f :< fs) <.  (_ :< as) = f :< ((<. ) <$> fs <.> as)+  (_ :< fs)  .> (a :< as) = a :< (( .>) <$> fs <.> as)++instance ComonadApply f => ComonadApply (Cofree f) where+  (f :< fs) <@> (a :< as) = f a :< ((<@>) <$> fs <@> as)+  (f :< fs) <@  (_ :< as) = f :< ((<@ ) <$> fs <@> as)+  (_ :< fs)  @> (a :< as) = a :< (( @>) <$> fs <@> as)++instance Applicative f => Applicative (Cofree f) where+  pure a = as where as = a :< pure as+  (f :< fs) <*> (a :< as) = f a :< ((<*>) <$> fs <*> as)+  (f :< fs) <*  (_ :< as) = f :< ((<* ) <$> fs <*> as)+  (_ :< fs)  *> (a :< as) = a :< (( *>) <$> fs <*> 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 (Read (f (Cofree f a)), Read a) => Read (Cofree f a) where+  readsPrec d r = readParen (d > 5)+                          (\r' -> [(u :< v,w) |+                                  (u, s) <- readsPrec 6 r',+                                  (":<", t) <- lex s,+                                  (v, w) <- readsPrec 5 t]) r++instance (Eq (f (Cofree f a)), Eq a) => Eq (Cofree f a) where+  a :< as == b :< bs = a == b && as == bs++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 Foldable f => Foldable (Cofree f) where+  foldMap f (a :< as) = f a `mappend` foldMap (foldMap f) as++instance Foldable1 f => Foldable1 (Cofree f) where+  foldMap1 f (a :< as) = f a <> foldMap1 (foldMap1 f) as++instance Traversable f => Traversable (Cofree f) where+  traverse f (a :< as) = (:<) <$> f a <*> traverse (traverse f) as++instance Traversable1 f => Traversable1 (Cofree f) where+  traverse1 f (a :< as) = (:<) <$> f a <.> traverse1 (traverse1 f) as++#ifdef GHC_TYPEABLE+instance (Typeable1 f) => Typeable1 (Cofree f) where+  typeOf1 dfa = mkTyConApp cofreeTyCon [typeOf1 (f dfa)]+    where+      f :: Cofree f a -> f a+      f = undefined++instance (Typeable1 f, Typeable a) => Typeable (Cofree f a) where+  typeOf = typeOfDefault++cofreeTyCon :: TyCon+#if __GLASGOW_HASKELL__ < 704+cofreeTyCon = mkTyCon "Control.Comonad.Cofree.Cofree"+#else+cofreeTyCon = mkTyCon3 "free" "Control.Comonad.Cofree" "Cofree"+#endif+{-# NOINLINE cofreeTyCon #-}++instance+  ( Typeable1 f+  , Data (f (Cofree f a))+  , Data a+  ) => Data (Cofree f a) where+    gfoldl f z (a :< as) = z (:<) `f` a `f` as+    toConstr _ = cofreeConstr+    gunfold k z c = case constrIndex c of+        1 -> k (k (z (:<)))+        _ -> error "gunfold"+    dataTypeOf _ = cofreeDataType+    dataCast1 f = gcast1 f++cofreeConstr :: Constr+cofreeConstr = mkConstr cofreeDataType ":<" [] Infix+{-# NOINLINE cofreeConstr #-}++cofreeDataType :: DataType+cofreeDataType = mkDataType "Control.Comonad.Cofree.Cofree" [cofreeConstr]+{-# NOINLINE cofreeDataType #-}+#endif++instance ComonadEnv e w => ComonadEnv e (Cofree w) where+  ask = ask . lower++instance ComonadStore s w => ComonadStore s (Cofree w) where+  pos (_ :< as) = Class.pos as+  peek s (_ :< as) = extract (Class.peek s as)+++instance ComonadTraced m w => ComonadTraced m (Cofree w) where+  trace m = trace m . lower++extracting :: Functor f => (a -> f a) -> Cofree g a -> f (Cofree g a)+extracting f (a :< as) = (:< as) <$> f a+{-# INLINE extracting #-}++unwrapping :: Functor f => (g (Cofree g a) -> f (g (Cofree g a))) -> Cofree g a -> f (Cofree g a)+unwrapping f (a :< as) = (a :<) <$> f as+{-# INLINE unwrapping #-}++telescoping :: (Functor f, Functor g) =>+             [(Cofree g a -> f (Cofree g a)) -> g (Cofree g a) -> f (g (Cofree g a))] ->+              (a -> f a) -> Cofree g a -> f (Cofree g a)+telescoping [] = extracting+telescoping (l:ls) = unwrapping . l . telescoping ls
+ src/Control/Comonad/Cofree/Class.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Comonad.Cofree.Class+-- Copyright   :  (C) 2008-2011 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  fundeps, MPTCs+----------------------------------------------------------------------------+module Control.Comonad.Cofree.Class+  ( ComonadCofree(..)+  ) where++import Control.Applicative+import Control.Comonad+import Control.Comonad.Trans.Env+import Control.Comonad.Trans.Store+import Control.Comonad.Trans.Traced+import Control.Comonad.Trans.Identity+import Data.Semigroup++class (Functor f, Comonad w) => ComonadCofree f w | w -> f where+  unwrap :: w a -> f (w a)++instance ComonadCofree f w => ComonadCofree f (IdentityT w) where+  unwrap = fmap IdentityT . unwrap . runIdentityT++instance ComonadCofree f w => ComonadCofree f (EnvT e w) where+  unwrap (EnvT e wa) = EnvT e <$> unwrap wa++instance ComonadCofree f w => ComonadCofree f (StoreT s w) where+  unwrap (StoreT wsa s) = flip StoreT s <$> unwrap wsa++instance (ComonadCofree f w, Semigroup m, Monoid m) => ComonadCofree f (TracedT m w) where+  unwrap (TracedT wma) = TracedT <$> unwrap wma
+ src/Control/Monad/Free.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Free+-- Copyright   :  (C) 2008-2011 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  MPTCs, fundeps+--+-- Free monads+--+----------------------------------------------------------------------------+module Control.Monad.Free+  ( MonadFree(..)+  , Free(..)+  , retract+  , liftF+  , iter+  ) where++import Control.Applicative+import Control.Monad (liftM, MonadPlus(..))+import Control.Monad.Trans.Class+import Control.Monad.Free.Class+import Control.Monad.Reader.Class+import Control.Monad.Writer.Class+import Control.Monad.State.Class+import Control.Monad.Error.Class+import Control.Monad.Cont.Class+import Data.Functor.Bind+import Data.Foldable+import Data.Traversable+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable++data Free f a = Pure a | Free (f (Free f a))++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 (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 (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 (Read (f (Free f a)), Read a) => Read (Free f a) where+  readsPrec 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) <- readsPrec 11 s]) r++instance Functor f => Functor (Free f) where+  fmap f (Pure a)  = Pure (f a)+  fmap f (Free fa) = Free (fmap f <$> fa)++instance Functor f => Apply (Free f) where+  Pure a  <.> Pure b = Pure (a b)+  Pure a  <.> Free fb = Free $ fmap a <$> fb+  Free fa <.> b = Free $ (<.> b) <$> fa++instance Functor f => Applicative (Free f) where+  pure = Pure+  Pure a <*> Pure b = Pure $ a b+  Pure a <*> Free mb = Free $ fmap a <$> mb+  Free ma <*> b = Free $ (<*> b) <$> ma++instance Functor f => Bind (Free f) where+  Pure a >>- f = f a+  Free m >>- f = Free ((>>- f) <$> m)++instance Functor f => Monad (Free f) where+  return = Pure+  Pure a >>= f = f a+  Free m >>= f = Free ((>>= f) <$> m)++instance Alternative v => Alternative (Free v) where+  empty = Free empty+  a <|> b = Free (pure a <|> pure b)++instance (Functor v, MonadPlus v) => MonadPlus (Free v) where+  mzero = Free mzero+  a `mplus` b = Free (return a `mplus` return b)++instance MonadTrans Free where+  lift = Free . liftM Pure++instance Foldable f => Foldable (Free f) where+  foldMap f (Pure a) = f a+  foldMap f (Free fa) = foldMap (foldMap f) fa++instance Foldable1 f => Foldable1 (Free f) where+  foldMap1 f (Pure a) = f a+  foldMap1 f (Free fa) = foldMap1 (foldMap1 f) fa++instance Traversable f => Traversable (Free f) where+  traverse f (Pure a) = Pure <$> f a+  traverse f (Free fa) = Free <$> traverse (traverse f) fa++instance Traversable1 f => Traversable1 (Free f) where+  traverse1 f (Pure a) = Pure <$> f a+  traverse1 f (Free fa) = Free <$> traverse1 (traverse1 f) fa++instance (Functor m, MonadWriter e m) => MonadWriter e (Free m) where+  tell = lift . tell+  listen = lift . listen . retract+  pass = lift . pass . retract++instance (Functor m, MonadReader e m) => MonadReader e (Free m) where+  ask = lift ask+  local f = lift . local f . retract++instance (Functor m, MonadState s m) => MonadState s (Free m) where+  get = lift get+  put s = lift (put s)++instance (Functor m, MonadError e m) => MonadError e (Free m) where+  throwError = lift . throwError+  catchError as f = lift (catchError (retract as) (retract . f))++instance (Functor m, MonadCont m) => MonadCont (Free m) where+  callCC f = lift (callCC (retract . f . liftM lift))++liftF :: Functor f => f a -> Free f a+liftF = Free . fmap Pure++instance Functor f => MonadFree f (Free f) where+  wrap = Free++-- |+--+-- > retract . lift = id+-- > retract . liftF = id+retract :: Monad f => Free f a -> f a+retract (Pure a) = return a+retract (Free as) = as >>= retract++iter :: Functor f => (f a -> a) -> Free f a -> a+iter _ (Pure a) = a+iter phi (Free m) = phi (iter phi <$> m)
+ src/Control/Monad/Free/Class.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Free.Class+-- Copyright   :  (C) 2008-2011 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (fundeps, MPTCs)+----------------------------------------------------------------------------+module Control.Monad.Free.Class+  ( MonadFree(..)+  ) where++import Control.Applicative+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.List+import Control.Monad.Trans.Error+import Control.Monad.Trans.Identity+import Data.Monoid++class Monad m => MonadFree f m | m -> f where+  wrap :: f (m a) -> m a++instance (Functor f, MonadFree f m) => MonadFree f (ReaderT e m) where+  wrap fm = ReaderT $ \e -> wrap $ flip runReaderT e <$> fm++instance (Functor f, MonadFree f m) => MonadFree f (Lazy.StateT s m) where+  wrap fm = Lazy.StateT $ \s -> wrap $ flip Lazy.runStateT s <$> fm++instance (Functor f, MonadFree f m) => MonadFree f (Strict.StateT s m) where+  wrap fm = Strict.StateT $ \s -> wrap $ flip Strict.runStateT s <$> fm++instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Lazy.WriterT w m) where+  wrap = Lazy.WriterT . wrap . fmap Lazy.runWriterT++instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Strict.WriterT w m) where+  wrap = Strict.WriterT . wrap . fmap Strict.runWriterT++instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Strict.RWST r w s m) where+  wrap fm = Strict.RWST $ \r s -> wrap $ fmap (\m -> Strict.runRWST m r s) fm++instance (Functor f, MonadFree f m, Monoid w) => MonadFree f (Lazy.RWST r w s m) where+  wrap fm = Lazy.RWST $ \r s -> wrap $ fmap (\m -> Lazy.runRWST m r s) fm++instance (Functor f, MonadFree f m) => MonadFree f (MaybeT m) where+  wrap = MaybeT . wrap . fmap runMaybeT++instance (Functor f, MonadFree f m) => MonadFree f (IdentityT m) where+  wrap = IdentityT . wrap . fmap runIdentityT++instance (Functor f, MonadFree f m) => MonadFree f (ListT m) where+  wrap = ListT . wrap . fmap runListT++instance (Functor f, MonadFree f m, Error e) => MonadFree f (ErrorT e m) where+  wrap = ErrorT . wrap . fmap runErrorT