diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMainWithHooks simpleUserHooks diff --git a/category-extras.cabal b/category-extras.cabal --- a/category-extras.cabal +++ b/category-extras.cabal @@ -1,167 +1,182 @@ name: category-extras category: Control, Monads, Comonads -version: 0.53.5.1 +version: 1.0 license: BSD3 -cabal-version: >= 1.2.3 +cabal-version: >= 1.2 license-file: LICENSE author: Edward A. Kmett -maintainer: Edward A. Kmett -stability: experimental +maintainer: Daniel Wagner +stability: provisional homepage: http://comonad.com/reader/ -synopsis: Various modules and constructs inspired by category theory -copyright: Copyright (C) 2008 Edward A. Kmett, +synopsis: A meta-package documenting various packages inspired by category theory +copyright: Copyright (C) 2012 Daniel Wagner, + Copyright (C) 2008 Edward A. Kmett, Copyright (C) 2004--2008 Dave Menendez, Copyright (C) 2007 Iavor Diatchki -description: A vastly expanded collection of modules implementing various - ideas from category theory. Notable bits include: comonads, - adjunctions, and various recursion schemes ala - /Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire/. +description: The obsolete @category-extras@ package provided a monolithic set + of modules designed for the use of category theory in Haskell. + It was exploded into more focused, self-contained packages + (listed in the dependencies below); this meta-package documents + where the code has gone. In addition to the core definitions, + the original category-extras library included several concrete + data types as instances of the core concepts. These are now + available from the following packages: + . + * data-lens + . + * data-lens-fd + . + * data-lens-template + . + * eq + . + * representable-tries + . + * streams + . + * vector-instances + . + A quick overview of the packages in dependency order is + available from + . A more + detailed (but very incomplete -- help me complete it!) overview + mapping each module in the old package into its new location in + the new hierarchy follows. Not all modules have exact analogs; + where possible, similar alternatives are listed. + . + > Control + > Control.Allegory: use alternative profunctors-Data.Profunctor + > Applicative + > Control.Applicative.Parameterized + > Arrow + > Control.Arrow.BiKleisli + > Control.Arrow.CoKleisli: comonad-Control.Comonad + > Control.Category: base-Control.Category + > Control.Category.Associative: categories-Control.Category.Associative + > Control.Category.Braided: categories-Control.Category.Braided + > Control.Category.Cartesian: categories-Control.Category.Cartesian + > Control.Category.Cartesian.Closed: categories-Control.Category.Cartesian.Closed + > Control.Category.Discrete: categories-Control.Category.Discrete + > Control.Category.Distributive: categories-Control.Category.Distributive + > Control.Category.Dual: categories-Control.Category.Dual + > Control.Category.Hask: just use "(->)" instead of "Hask" + > Control.Category.Monoidal: categories-Control.Category.Monoidal + > Control.Category.Object: categories-Control.Categorical.Object + > Control.Comonad: comonad-Control.Comonad + > Control.Comonad.Cofree: free-Control.Comonad.Cofree + > Control.Comonad.Coideal + > Control.Comonad.Context: comonad-transformers-Control.Comonad.Trans.Store + > Control.Comonad.Density: kan-extensions-Control.Comonad.Density + > Control.Comonad.Exponent: comonad-transformers-Control.Comonad.Trans.Trace + > Control.Comonad.Fix: comonad-Control.Comonad + > Control.Comonad.HigherOrder + > Control.Comonad.Indexed + > Control.Comonad.Parameterized + > Control.Comonad.Pointer: comonad-extras-Control.Comonad.Store.Pointer + > Control.Comonad.Reader: comonad-transformers-Control.Comonad.Trans.Env + > Control.Comonad.Stream: use alternative package streams + > Control.Comonad.Supply + > Control.Comonad.Trans: comonad-transformers-Control.Comonad.Trans.Class + > Control.Dyad + > Control.Functor: bifunctors-Data.Bifunctor + > Control.Functor.Adjunction: adjunctions-Data.Functor.Adjunction + > Control.Functor.Adjunction.HigherOrder + > Control.Functor.Algebra + > Control.Functor.Algebra.Elgot: recursion-schemes-Data.Functor.Foldable + > Control.Functor.Categorical: categories-Control.Categorical.Functor + > Combinators + > Control.Functor.Combinators.Biff + > Control.Functor.Combinators.Const + > Control.Functor.Combinators.Flip + > Control.Functor.Combinators.Join + > Control.Functor.Combinators.Lift + > Control.Functor.Combinators.Of + > Control.Functor.Composition: transformers-Data.Functor.Compose and comonad-transformers-Data.Functor.Composition + > Control.Functor.Cone + > Control.Functor.Contra: contravariant-Data.Functor.Contravariant + > Control.Functor.Exponential + > Control.Functor.Extras: distributive-Data.Distributive, semigroupoids-Data.Functor.Plus, and semigroupoids-Data.Functor.Alt + > Control.Functor.Fix: recursion-schemes-Data.Functor.Foldable + > Control.Functor.Full + > Control.Functor.HigherOrder + > Control.Functor.HigherOrder.Composition + > Control.Functor.Indexed + > Control.Functor.KanExtension: kan-extensions-Data.Functor.KanExtension + > Control.Functor.KanExtension.Interpreter + > Control.Functor.Lambek + > Control.Functor.Limit + > Control.Functor.Pointed: pointed-Data.Pointed and pointed-Data.Copointed + > Control.Functor.Pointed.Composition: pointed-Data.Pointed and pointed-Data.Copointed + > Control.Functor.Representable: representable-functors-Data.Functor.Representable + > Control.Functor.Strong + > Control.Functor.Yoneda: kan-extensions-Data.Functor.Yoneda + > Control.Functor.Zap: keys-Data.Key + > Control.Functor.Zip: keys-Data.Key + > Monad + > Control.Monad.Categorical: pointed-Data.Pointed and semigroupoids-Data.Functor.Bind + > Control.Monad.Codensity: kan-extensions-Control.Monad.Codensity + > Control.Monad.Either: either-Control.Monad.Trans.Either + > Control.Monad.Free: free-Control.Monad.Free + > Control.Monad.HigherOrder + > Control.Monad.Hyper + > Control.Monad.Ideal + > Control.Monad.Indexed + > Control.Monad.Indexed.Cont + > Control.Monad.Indexed.Fix + > Control.Monad.Indexed.State + > Control.Monad.Indexed.Trans + > Control.Monad.Parameterized + > Morphism + > Control.Morphism.Ana: recursion-schemes-Data.Functor.Foldable + > Control.Morphism.Apo: recursion-schemes-Data.Functor.Foldable + > Control.Morphism.Build + > Control.Morphism.Cata: recursion-schemes-Data.Functor.Foldable + > Control.Morphism.Chrono + > Control.Morphism.Destroy + > Control.Morphism.Dyna + > Control.Morphism.Exo + > Control.Morphism.Futu: recursion-schemes-Data.Functor.Foldable + > Control.Morphism.Histo: recursion-schemes-Data.Functor.Foldable + > Control.Morphism.Hylo: recursion-schemes-Data.Functor.Foldable + > Meta + > Control.Morphism.Meta.Erwig + > Control.Morphism.Meta.Gibbons + > Control.Morphism.Para: recursion-schemes-Data.Functor.Foldable + > Control.Morphism.Postpro: recursion-schemes-Data.Functor.Foldable + > Control.Morphism.Prepro: recursion-schemes-Data.Functor.Foldable + > Control.Morphism.Span + > Control.Morphism.Synchro + > Control.Morphism.Universal + > Control.Morphism.Zygo: recursion-schemes-Data.Functor.Foldable + > Data + > Data.Void: void-Data.Void build-type: Simple -flag ArrowSubclassesCategory - description: Indicates Control.Category is available and that the standard library has - its arrows subclass Control.Category.Category - default: True - -flag TypeFamilies - description: Support for Type Families is available to us - -flag Optimize - description: Enable optimizations - default: False - library - build-depends: mtl >= 1.1 && < 2 - extensions: - CPP, - EmptyDataDecls, - FlexibleContexts, - FlexibleInstances, - FunctionalDependencies, - MultiParamTypeClasses, - TypeOperators, - TypeSynonymInstances - UndecidableInstances, - ExistentialQuantification, - Rank2Types - - other-modules: - Control.Functor.Internal.Adjunction, - Control.Functor.Internal.Ideal - - exposed-modules: - Control.Category.Monoidal, - Control.Category.Cartesian, - Control.Category.Cartesian.Closed, - Control.Applicative.Parameterized, - Control.Allegory, - Control.Arrow.BiKleisli, - Control.Arrow.CoKleisli, - Control.Category.Associative, - Control.Category.Braided, - Control.Category.Discrete, - Control.Category.Distributive, - Control.Category.Dual, - Control.Category.Hask, - Control.Category.Object, - Control.Comonad, - Control.Comonad.Cofree, - Control.Comonad.Context, - Control.Comonad.Coideal, - Control.Comonad.Density, - Control.Comonad.Exponent, - Control.Comonad.Fix, - Control.Comonad.Indexed, - Control.Comonad.HigherOrder, - Control.Comonad.Parameterized, - Control.Comonad.Pointer, - Control.Comonad.Reader, - Control.Comonad.Stream, - Control.Comonad.Supply, - Control.Comonad.Trans, - Control.Dyad, - Control.Functor, - Control.Functor.Adjunction, - Control.Functor.Adjunction.HigherOrder, - Control.Functor.Algebra, - Control.Functor.Algebra.Elgot, - Control.Functor.Categorical, - Control.Functor.Cone, - Control.Functor.Composition, - Control.Functor.Combinators.Const, - Control.Functor.Combinators.Lift, - Control.Functor.Combinators.Join, - Control.Functor.Combinators.Biff, - Control.Functor.Combinators.Flip, - Control.Functor.Combinators.Of, - Control.Functor.Contra, - Control.Functor.Extras, - Control.Functor.Exponential, - Control.Functor.Fix, - Control.Functor.Full, - Control.Functor.HigherOrder, - Control.Functor.HigherOrder.Composition, - Control.Functor.Indexed, - Control.Functor.KanExtension, - Control.Functor.KanExtension.Interpreter, - Control.Functor.Lambek, - Control.Functor.Limit, - Control.Functor.Pointed, - Control.Functor.Pointed.Composition, - Control.Functor.Representable, - Control.Functor.Strong, - Control.Functor.Yoneda, - Control.Functor.Zip, - Control.Functor.Zap, - Control.Monad.Categorical, - Control.Monad.Codensity, - Control.Monad.Free, - Control.Monad.HigherOrder, - Control.Monad.Ideal, - Control.Monad.Indexed, - Control.Monad.Indexed.Cont, - Control.Monad.Indexed.Fix, - Control.Monad.Indexed.State, - Control.Monad.Indexed.Trans, - Control.Monad.Parameterized, - Control.Monad.Hyper, - Control.Monad.Either, - Control.Morphism.Ana, - Control.Morphism.Apo, - Control.Morphism.Build, - Control.Morphism.Cata, - Control.Morphism.Chrono, - Control.Morphism.Destroy, - Control.Morphism.Dyna, - Control.Morphism.Exo, - Control.Morphism.Futu, - Control.Morphism.Histo, - Control.Morphism.Hylo, - Control.Morphism.Meta.Gibbons, - Control.Morphism.Meta.Erwig, - Control.Morphism.Para, - Control.Morphism.Postpro, - Control.Morphism.Prepro, - Control.Morphism.Span, - Control.Morphism.Synchro, - Control.Morphism.Universal, - Control.Morphism.Zygo, - Data.Void - - hs-source-dirs: src - ghc-options: -Wall - - if flag(ArrowSubclassesCategory) - build-depends: ghc >= 6.9, base > 3 && < 5, array - cpp-options: -D__ARROW_SUBCLASSES_CATEGORY__=1 - else - build-depends: ghc < 6.9, base < 5, array - hs-source-dirs: pre-6.9 - exposed-modules: Control.Category - - if flag(TypeFamilies) - extensions: TypeFamilies - cpp-options: -D__TYPE_FAMILIES__=1 - - if flag(Optimize) - ghc-options: -funbox-strict-fields -O2 + build-depends: + adjunctions, + bifunctors, + categories, + comonad, + comonad-extras, + comonads-fd, + comonad-transformers, + contravariant, + distributive, + either, + free, + groupoids, + kan-extensions, + keys, + monad-products, + pointed, + profunctor-extras, + profunctors, + recursion-schemes, + reducers, + representable-functors, + representable-profunctors, + semigroupoid-extras, + semigroupoids, + semigroups, + void diff --git a/pre-6.9/Control/Category.hs b/pre-6.9/Control/Category.hs deleted file mode 100644 --- a/pre-6.9/Control/Category.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Control.Category - ( (>>>), (<<<), Category ((.), id) - ) where - -import Prelude hiding (id,(.)) -import qualified Prelude hiding (flip) - -class Category (~>) where - (.) :: (b ~> c) -> (a ~> b) -> a ~> c - id :: a ~> a - -(<<<) :: Category (~>) => (b ~> c) -> (a ~> b) -> a ~> c -(<<<) = (.) - -(>>>) :: Category (~>) => (a ~> b) -> (b ~> c) -> a ~> c -(>>>) = flip (.) - -instance Category (->) where - (.) = (Prelude..) - id = Prelude.id diff --git a/src/Control/Allegory.hs b/src/Control/Allegory.hs deleted file mode 100644 --- a/src/Control/Allegory.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE GADTs #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Allegory --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- --- Allegories are generalizations of categories to cover relations. -------------------------------------------------------------------------------------------- -module Control.Allegory where - -import Prelude hiding (id,(.),all) -import Control.Category -import Control.Functor.Categorical -infix 5 .<=. - -{- - An allegory is a category in which every arrow has a partial ordering, meet and converse such that: - converse f . converse g = converse (f . g) - f .<=. converse g = converse f .<=. g - - Allegories are to relations what categories are to functions --} -class Category k => Allegory k where - (.<=.) :: k a b -> k a b -> Bool - meet :: k a b -> k a b -> k a b - converse :: k a b -> k b a - - isSimple :: k a b -> Bool - isSimple r = r . converse r .<=. id - - isTotal :: k a b -> Bool - isTotal r = id .<=. converse r . r - - isMap :: k a b -> Bool - isMap r = isSimple r && isTotal r - -class Allegory k => TabulatedAllegory k f where - tabulateLeft :: k a b -> k a (f a b) - tabulateRight :: k a b -> k b (f a b) - -class Allegory k => UnitalAllegory k i | k -> i where - -- unit of the allegory - all :: k a i - - rightDomain :: k b a -> k b b - rightDomain f = converse all . all . f - - leftDomain :: k b a -> k a a - leftDomain f = f . converse all . all - -class (Allegory k1, Allegory k2, CFunctor f k1 k2) => Relator f k1 k2 - -data Map k a b = Map { runMap :: k a b } - --- the sub-category of maps in an Allegory -instance Allegory k => Category (Map k) where - id = Map id - Map f . Map g = Map (f . g) - -extractMap :: Allegory k => k a b -> Maybe (Map k a b) -extractMap f = if isMap f then Just (Map f) else Nothing diff --git a/src/Control/Applicative/Parameterized.hs b/src/Control/Applicative/Parameterized.hs deleted file mode 100644 --- a/src/Control/Applicative/Parameterized.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Applicative.Paramterized --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- ----------------------------------------------------------------------------- -module Control.Applicative.Parameterized - ( PApplicative(..) - , PPointed(..) - ) where - -import Control.Functor.Pointed - -class PPointed f => PApplicative f where - pap :: f (a -> b) c -> f a c -> f b c diff --git a/src/Control/Arrow/BiKleisli.hs b/src/Control/Arrow/BiKleisli.hs deleted file mode 100644 --- a/src/Control/Arrow/BiKleisli.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# OPTIONS_GHC -cpp #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Arrow.BiKleisli --- Copyright : 2008 Edward Kmett --- License : BSD3 --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------------- - -module Control.Arrow.BiKleisli - ( BiKleisli(..) - ) where - -import Prelude hiding (id,(.)) -import Control.Category -import Control.Monad (liftM) -import Control.Comonad -import Control.Arrow -import Control.Functor.Extras - -newtype BiKleisli w m a b = BiKleisli { runBiKleisli :: w a -> m b } - -instance Monad m => Functor (BiKleisli w m a) where - fmap f (BiKleisli g) = BiKleisli (liftM f . g) - -instance (Comonad w, Monad m, Distributes w m) => Arrow (BiKleisli w m) where - arr f = BiKleisli (return . f . extract) - first (BiKleisli f) = BiKleisli $ \x -> do - u <- f (fmap fst x) - return (u, extract (fmap snd x)) -#if __GLASGOW_HASKELL__ < 609 - BiKleisli g >>> BiKleisli f = BiKleisli ((>>= f) . dist . extend g) -#endif - -instance (Comonad w, Monad m, Distributes w m) => Category (BiKleisli w m) where - BiKleisli f . BiKleisli g = BiKleisli ((>>=f) . dist . extend g) - id = BiKleisli (return . extract) diff --git a/src/Control/Arrow/CoKleisli.hs b/src/Control/Arrow/CoKleisli.hs deleted file mode 100644 --- a/src/Control/Arrow/CoKleisli.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# OPTIONS_GHC -cpp #-} - -------------------------------------------------------------------------------------------- --- | --- Module : Control.Arrow.CoKleisli --- Copyright : 2008 Edward Kmett --- License : BSD3 --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------------- -module Control.Arrow.CoKleisli - ( CoKleisli(..) - ) where - - -import Prelude hiding (id,(.)) -import Control.Category -import Control.Comonad -import Control.Arrow - -newtype CoKleisli w a b = CoKleisli { runCoKleisli :: w a -> b } - -instance Functor (CoKleisli w a) where - fmap f (CoKleisli g) = CoKleisli (f . g) - -instance Comonad w => Arrow (CoKleisli w) where - arr f = CoKleisli (f . extract) - CoKleisli a &&& CoKleisli b = CoKleisli (a &&& b) - CoKleisli a *** CoKleisli b = CoKleisli (a . fmap fst &&& b . fmap snd) - first a = a *** CoKleisli extract - second a = CoKleisli extract *** a -#if __GLASGOW_HASKELL__ < 609 - CoKleisli a >>> CoKleisli b = CoKleisli (b . fmap a . duplicate) -#endif - -instance Comonad w => Category (CoKleisli w) where - id = CoKleisli extract - CoKleisli b . CoKleisli a = CoKleisli (b . fmap a . duplicate) diff --git a/src/Control/Category/Associative.hs b/src/Control/Category/Associative.hs deleted file mode 100644 --- a/src/Control/Category/Associative.hs +++ /dev/null @@ -1,57 +0,0 @@ --- {-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Category.Associative --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- --- NB: this contradicts another common meaning for an 'Associative' 'Category', which is one --- where the pentagonal condition does not hold, but for which there is an identity. --- -------------------------------------------------------------------------------------------- -module Control.Category.Associative - ( Associative(..) - , Coassociative(..) - ) where - -import Control.Functor -import Control.Category.Hask - -{- | A category with an associative bifunctor satisfying Mac Lane\'s pentagonal coherence identity law: - -> bimap id associate . associate . bimap associate id = associate . associate --} -class Bifunctor p k k k => Associative k p where - associate :: k (p (p a b) c) (p a (p b c)) - -{- | A category with a coassociative bifunctor satisyfing the dual of Mac Lane's pentagonal coherence identity law: - -> bimap coassociate id . coassociate . bimap id coassociate = coassociate . coassociate --} -class Bifunctor s k k k => Coassociative k s where - coassociate :: k (s a (s b c)) (s (s a b) c) - -{-# RULES -"copentagonal coherence" bimap coassociate id . coassociate . bimap id coassociate = coassociate . coassociate -"pentagonal coherence" bimap id associate . associate . bimap associate id = associate . associate - #-} - -instance Associative Hask (,) where - associate ((a,b),c) = (a,(b,c)) - -instance Coassociative Hask (,) where - coassociate (a,(b,c)) = ((a,b),c) - -instance Associative Hask Either where - associate (Left (Left a)) = Left a - associate (Left (Right b)) = Right (Left b) - associate (Right c) = Right (Right c) - -instance Coassociative Hask Either where - coassociate (Left a) = Left (Left a) - coassociate (Right (Left b)) = Left (Right b) - coassociate (Right (Right c)) = Right c diff --git a/src/Control/Category/Braided.hs b/src/Control/Category/Braided.hs deleted file mode 100644 --- a/src/Control/Category/Braided.hs +++ /dev/null @@ -1,62 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Category.Braided --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------------- -module Control.Category.Braided - ( Braided(..) - , Symmetric - , swap - ) where - -import Control.Functor -import Control.Category.Associative -import Control.Category.Hask - -{- | A braided (co)(monoidal or associative) category can commute the arguments of its bi-endofunctor. Obeys the laws: - -> idr . braid = idl -> idl . braid = idr -> braid . coidr = coidl -> braid . coidl = coidr -> associate . braid . associate = second braid . associate . first braid -> coassociate . braid . coassociate = first braid . coassociate . second braid - --} - -class Braided k p where - braid :: k (p a b) (p b a) - -{- | -If we have a symmetric (co)'Monoidal' category, you get the additional law: - -> swap . swap = id - -} -class Braided k p => Symmetric k p - -swap :: Symmetric k p => k (p a b) (p b a) -swap = braid - -{-# RULES -"swap/swap" swap . swap = id -"braid/associate/braid" bimap id braid . associate . bimap braid id = associate . braid . associate -"braid/coassociate/braid" bimap braid id . coassociate . bimap id braid = coassociate . braid . coassociate - #-} - -instance Braided Hask Either where - braid (Left a) = Right a - braid (Right b) = Left b - -instance Symmetric Hask Either - -instance Braided Hask (,) where - braid ~(a,b) = (b,a) - -instance Symmetric Hask (,) - diff --git a/src/Control/Category/Cartesian.hs b/src/Control/Category/Cartesian.hs deleted file mode 100644 --- a/src/Control/Category/Cartesian.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Category.Cartesian --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (class-associated types) --- -------------------------------------------------------------------------------------------- -module Control.Category.Cartesian - ( module Control.Category.Associative - , module Control.Category.Monoidal - -- * Pre-(Co)Cartesian categories - , PreCartesian(..) - , bimapPreCartesian, braidPreCartesian, associatePreCartesian, coassociatePreCartesian - , PreCoCartesian(..) - , bimapPreCoCartesian, braidPreCoCartesian, associatePreCoCartesian, coassociatePreCoCartesian - -- * (Co)Cartesian categories - , Cartesian - , CoCartesian - ) where - -import Control.Category.Hask -import Control.Category.Associative -import Control.Category.Monoidal -import Prelude hiding (Functor, map, (.), id, fst, snd, curry, uncurry) -import qualified Prelude (fst,snd) -import Control.Functor -import Control.Category - -infixr 3 &&& -infixr 2 ||| - -{- | -NB: This is weaker than traditional category with products! That is Cartesian, below. -The problem is @(->)@ lacks an initial object, since every type is inhabited in Haskell. -Consequently its coproduct is merely a semigroup, not a monoid as it has no identity, and -since we want to be able to describe its dual category, which has this non-traditional -form being built over a category with an associative bifunctor rather than as a monoidal category -for the product monoid. - -Minimum definition: - -> fst, snd, diag -> fst, snd, (&&&) --} -class (Associative k p, Coassociative k p, Braided k p) => PreCartesian k p | k -> p where - fst :: k (p a b) a - snd :: k (p a b) b - diag :: k a (p a a) - (&&&) :: k a b -> k a c -> k a (p b c) - - diag = id &&& id - f &&& g = bimap f g . diag - - -{-# RULES -"fst . diag" fst . diag = id -"snd . diag" snd . diag = id -"fst . f &&& g" forall f g. fst . (f &&& g) = f -"snd . f &&& g" forall f g. snd . (f &&& g) = g - #-} - -instance PreCartesian Hask (,) where - fst = Prelude.fst - snd = Prelude.snd - diag a = (a,a) - (f &&& g) a = (f a, g a) - --- alias -class (Monoidal k p i, PreCartesian k p) => Cartesian k p i | k -> p i -instance (Monoidal k p i, PreCartesian k p) => Cartesian k p i - --- | free construction of 'Bifunctor' for the product 'Bifunctor' @Prod k@ if @(&&&)@ is known -bimapPreCartesian :: PreCartesian k p => k a c -> k b d -> k (p a b) (p c d) -bimapPreCartesian f g = (f . fst) &&& (g . snd) - --- | free construction of 'Braided' for the product 'Bifunctor' @Prod k@ -braidPreCartesian :: PreCartesian k p => k (p a b) (p b a) -braidPreCartesian = snd &&& fst - --- | free construction of 'Associative' for the product 'Bifunctor' @Prod k@ -associatePreCartesian :: PreCartesian k p => k (p (p a b) c) (p a (p b c)) -associatePreCartesian = (fst . fst) &&& first snd - --- | free construction of 'Coassociative' for the product 'Bifunctor' @Prod k@ -coassociatePreCartesian :: PreCartesian k p => k (p a (p b c)) (p (p a b) c) -coassociatePreCartesian = braid . second braid . associatePreCartesian . first braid . braid - --- * Co-PreCartesian categories - --- a category that has finite coproducts, weakened the same way as PreCartesian above was weakened -class (Associative k s, Coassociative k s , Braided k s) => PreCoCartesian k s | k -> s where - inl :: k a (s a b) - inr :: k b (s a b) - codiag :: k (s a a) a - (|||) :: k a c -> k b c -> k (s a b) c - - codiag = id ||| id - f ||| g = codiag . bimap f g - -{-# RULES -"codiag . inl" codiag . inl = id -"codiag . inr" codiag . inr = id -"(f ||| g) . inl" forall f g. (f ||| g) . inl = f -"(f ||| g) . inr" forall f g. (f ||| g) . inr = g - #-} - -instance PreCoCartesian Hask Either where - inl = Left - inr = Right - codiag (Left a) = a - codiag (Right a) = a - (f ||| _) (Left a) = f a - (_ ||| g) (Right a) = g a - --- | free construction of 'Bifunctor' for the coproduct 'Bifunctor' @Sum k@ if @(|||)@ is known -bimapPreCoCartesian :: PreCoCartesian k s => k a c -> k b d -> k (s a b) (s c d) -bimapPreCoCartesian f g = (inl . f) ||| (inr . g) - --- | free construction of 'Braided' for the coproduct 'Bifunctor' @Sum k@ -braidPreCoCartesian :: PreCoCartesian k s => k (s a b) (s b a) -braidPreCoCartesian = inr ||| inl - --- | free construction of 'Associative' for the coproduct 'Bifunctor' @Sum k@ -associatePreCoCartesian :: PreCoCartesian k s => k (s (s a b) c) (s a (s b c)) -associatePreCoCartesian = braid . first braid . coassociatePreCoCartesian . second braid . braid - --- | free construction of 'Coassociative' for the coproduct 'Bifunctor' @Sum k@ -coassociatePreCoCartesian :: PreCoCartesian k s => k (s a (s b c)) (s (s a b) c) -coassociatePreCoCartesian = (inl . inl) ||| first inr - -class (Comonoidal k s i, PreCoCartesian k s) => CoCartesian k s i | k -> s i -instance (Comonoidal k s i, PreCoCartesian k s) => CoCartesian k s i diff --git a/src/Control/Category/Cartesian/Closed.hs b/src/Control/Category/Cartesian/Closed.hs deleted file mode 100644 --- a/src/Control/Category/Cartesian/Closed.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Category.Cartesian.Closed --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (class-associated types) --- --- NB: Some rewrite rules are disabled pending resolution of: --- -------------------------------------------------------------------------------------------- -module Control.Category.Cartesian.Closed - ( - -- * Cartesian Closed Category - CCC(..) - , unitCCC, counitCCC - -- * Co-(Cartesian Closed Category) - , CoCCC(..) - , unitCoCCC, counitCoCCC - ) where - -import Prelude hiding ((.), id, fst, snd, curry, uncurry) - -import Control.Category -import Control.Category.Cartesian -import Control.Category.Monoidal - --- * Closed Cartesian Category - --- | A 'CCC' has full-fledged monoidal finite products and exponentials - --- Ideally you also want an instance for @'Bifunctor' ('Exp' hom) ('Dual' hom) hom hom@. --- or at least @'Functor' ('Exp' hom a) hom hom@, which cannot be expressed in the constraints here. - -class (Monoidal hom prod i, Cartesian hom prod i) => CCC hom prod exp i | hom -> prod exp i where - apply :: hom (prod (exp a b) a) b - curry :: hom (prod a b) c -> hom a (exp b c) - uncurry :: hom a (exp b c) -> hom (prod a b) c - -{-# RULES -"curry apply" curry apply = id --- "curry . uncurry" curry . uncurry = id :: CCC hom => hom a (exp b c) -> hom a (exp b c) --- "uncurry . curry" uncurry . curry = id :: CCC hom => hom (prod a b) c -> hom (prod a b) c - #-} - --- * Free 'Adjunction' (prod a) (exp a) hom hom - -unitCCC :: CCC hom prod exp i => hom a (exp b (prod b a)) -unitCCC = curry braid - -counitCCC :: CCC hom prod exp i => hom (prod b (exp b a)) a -counitCCC = apply . braid - --- * A Co-(Closed Cartesian Category) - --- | A Co-CCC has full-fledged comonoidal finite coproducts and coexponentials - --- You probably also want an instance for @'Bifunctor' ('coexp' hom) ('Dual' hom) hom hom@. - -class (Comonoidal hom sum i, CoCartesian hom sum i) => CoCCC hom sum coexp i | hom -> sum coexp i where - coapply :: hom b (sum (coexp hom a b) a) - cocurry :: hom c (sum a b) -> hom (coexp hom b c) a - uncocurry :: hom (coexp hom b c) a -> hom c (sum a b) - -{-# RULES -"cocurry coapply" cocurry coapply = id --- "cocurry . uncocurry" cocurry . uncocurry = id --- "uncocurry . cocurry" uncocurry . cocurry = id - #-} - --- * Free 'Adjunction' (coexp hom a) (sum a) hom hom - -unitCoCCC :: CoCCC hom sum coexp i => hom a (sum b (coexp hom b a)) -unitCoCCC = braid . coapply - -counitCoCCC :: CoCCC hom sum coexp i => hom (coexp hom b (sum b a)) a -counitCoCCC = cocurry braid diff --git a/src/Control/Category/Discrete.hs b/src/Control/Category/Discrete.hs deleted file mode 100644 --- a/src/Control/Category/Discrete.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE GADTs #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Category.Discrete --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------------- -module Control.Category.Discrete - ( Discrete(Refl) - , mapDiscrete - , cast - , invDiscrete - ) where - -import Prelude hiding (id,(.)) -import Control.Category -import Unsafe.Coerce (unsafeCoerce) --- import Control.Functor.Categorical - -data Discrete a b where - Refl :: Discrete a a - -instance Category Discrete where - id = Refl - Refl . Refl = Refl - --- instance CFunctor f Discrete Discrete where cmap = mapDiscrete - -mapDiscrete :: Discrete a b -> Discrete (f a) (f b) -mapDiscrete Refl = Refl - -cast :: Discrete a b -> a -> b -cast Refl = unsafeCoerce - -invDiscrete :: Discrete a b -> Discrete b a -invDiscrete Refl = Refl diff --git a/src/Control/Category/Distributive.hs b/src/Control/Category/Distributive.hs deleted file mode 100644 --- a/src/Control/Category/Distributive.hs +++ /dev/null @@ -1,40 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Category.Distributive --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (class-associated types) --- -------------------------------------------------------------------------------------------- -module Control.Category.Distributive - ( - -- * Distributive Categories - factor - , Distributive(..) - ) where - -import Prelude hiding (Functor, map, (.), id, fst, snd, curry, uncurry) -import Control.Functor -import Control.Category -import Control.Category.Hask -import Control.Category.Cartesian - --- | the canonical factoring morphism -factor :: (PreCartesian hom prod, PreCoCartesian hom sum) => hom (sum (prod a b) (prod a c)) (prod a (sum b c)) -factor = second inl ||| second inr - --- | A category in which 'factor' is an isomorphism -class (PreCartesian hom prod, PreCoCartesian hom sum) => Distributive hom prod sum where - distribute :: hom (prod a (sum b c)) (sum (prod a b) (prod a c)) - -instance Distributive Hask (,) Either where - distribute (a,Left b) = Left (a,b) - distribute (a,Right c) = Right (a,c) - -{-# RULES -"factor . distribute" factor . distribute = id -"distribute . factor" distribute . factor = id - #-} diff --git a/src/Control/Category/Dual.hs b/src/Control/Category/Dual.hs deleted file mode 100644 --- a/src/Control/Category/Dual.hs +++ /dev/null @@ -1,23 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Category.Dual --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : semi-portable (optional class-associated types) --- -------------------------------------------------------------------------------------------- -module Control.Category.Dual - ( Dual(..) - ) where - -import Prelude hiding ((.), id) -import Control.Category - -data Dual k a b = Dual { runDual :: k b a } - -instance Category k => Category (Dual k) where - id = Dual id - Dual f . Dual g = Dual (g . f) diff --git a/src/Control/Category/Hask.hs b/src/Control/Category/Hask.hs deleted file mode 100644 --- a/src/Control/Category/Hask.hs +++ /dev/null @@ -1,16 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Category.Hask --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- --- Make it clearer when we are dealing with the category (->) that we mean the category --- of haskell types via its Hom bifunctor (->) -------------------------------------------------------------------------------------------- -module Control.Category.Hask (Hask) where - -type Hask = (->) diff --git a/src/Control/Category/Monoidal.hs b/src/Control/Category/Monoidal.hs deleted file mode 100644 --- a/src/Control/Category/Monoidal.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Category.Monoidal --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (class-associated types) --- --- A 'Monoidal' category is a category with an associated biendofunctor that has an identity, --- which satisfies Mac Lane''s pentagonal and triangular coherence conditions --- Technically we usually say that category is 'monoidal', but since --- most interesting categories in our world have multiple candidate bifunctors that you can --- use to enrich their structure, we choose here to think of the bifunctor as being --- monoidal. This lets us reuse the same Bifunctor over different categories without --- painful type annotations. - --- The use of class associated types here makes Control.Category.Cartesian FAR more palatable -------------------------------------------------------------------------------------------- - -module Control.Category.Monoidal - ( module Control.Category.Braided - , HasIdentity - , Monoidal(..) - , Comonoidal(..) - ) where - -import Control.Category.Braided -import Control.Category.Hask -import Control.Category.Associative -import Control.Functor -import Data.Void - --- | Denotes that we have some reasonable notion of 'Identity' for a particular 'Bifunctor' in this 'Category'. This --- notion is currently used by both 'Monoidal' and 'Comonoidal' -class Bifunctor p k k k => HasIdentity k p i | k p -> i - -{- | A monoidal category. 'idl' and 'idr' are traditionally denoted lambda and rho - the triangle identity holds: - -> bimap idr id = bimap id idl . associate -> bimap id idl = bimap idr id . associate --} - -class (Associative k p, HasIdentity k p i) => Monoidal k p i | k p -> i where - idl :: k (p i a) a - idr :: k (p a i) a - -{- | A comonoidal category satisfies the dual form of the triangle identities - -> bimap idr id = coassociate . bimap id idl -> bimap id idl = coassociate . bimap idr id - -This type class is also (ab)used for the inverse operations needed for a strict (co)monoidal category. -A strict (co)monoidal category is one that is both 'Monoidal' and 'Comonoidal' and satisfies the following laws: - -> idr . coidr = id -> idl . coidl = id -> coidl . idl = id -> coidr . idr = id - --} -class (Coassociative k p, HasIdentity k p i) => Comonoidal k p i | k p -> i where - coidl :: k a (p i a) - coidr :: k a (p a i) - -{-# RULES --- "bimap id idl/associate" bimap id idl . associate = bimap idr id --- "bimap idr id/associate" bimap idr id . associate = bimap id idl --- "coassociate/bimap id idl" coassociate . bimap id idl = bimap idr id --- "coassociate/bimap idr id" coassociate . bimap idr id = bimap id idl -"idr/coidr" idr . coidr = id -"idl/coidl" idl . coidl = id -"coidl/idl" coidl . idl = id -"coidr/idr" coidr . idr = id -"idr/braid" idr . braid = idl -"idl/braid" idl . braid = idr -"braid/coidr" braid . coidr = coidl -"braid/coidl" braid . coidl = coidr - #-} - -instance HasIdentity Hask (,) Void - - -instance Monoidal Hask (,) Void where - idl = snd - idr = fst - diff --git a/src/Control/Category/Object.hs b/src/Control/Category/Object.hs deleted file mode 100644 --- a/src/Control/Category/Object.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Category.Object --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (either class-associated types or MPTCs with fundeps) --- --- This module declares the 'HasTerminalObject' and 'HasInitialObject' classes. --- These are defined in terms of class-associated types rather than functional dependencies --- because most of the time when you are manipulating a category you don't care about them; --- this gets them out of the signature of most functions that use the category. --- Both of these are special cases of the idea of a (co)limit. -------------------------------------------------------------------------------------------- - -module Control.Category.Object - ( HasTerminalObject(..) - , HasInitialObject(..) - ) where - -import Control.Category - --- | The @Category k@ has a terminal object @Terminal k@ such that for all objects @a@ in @k@, --- there exists a unique morphism from @a@ to @Terminal k@. -#ifdef USE_TYPE_FAMILIES -class Category k => HasTerminalObject k where - type Terminal k :: * - terminate :: k a (Terminal k) -#else -class Category k => HasTerminalObject k t | k -> t where - terminate :: k a t -#endif - --- | The @Category k@ has an initial (coterminal) object @Initial k@ such that for all objects --- @a@ in @k@, there exists a unique morphism from @Initial k @ to @a@. - -#ifdef USE_TYPE_FAMILIES -class Category k => HasInitialObject k where - type Initial k :: * - initiate :: k (Initial k) a -#else -class Category k => HasInitialObject k i | k -> i where - initiate :: k i a -#endif diff --git a/src/Control/Comonad.hs b/src/Control/Comonad.hs deleted file mode 100644 --- a/src/Control/Comonad.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Comonad --- Copyright : (C) 2008 Edward Kmett --- (C) 2004 Dave Menendez --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- --- This module declares the 'Comonad' class ----------------------------------------------------------------------------- -module Control.Comonad - ( module Control.Functor.Pointed - , Comonad(..) - , liftW - , (=>>) - , (.>>) - , liftCtx - , mapW - , parallelW - , unfoldW - , sequenceW - ) where - -import Data.Monoid -import Control.Monad.Identity -import Control.Functor.Pointed - -infixl 1 =>>, .>> - -{-| -There are two ways to define a comonad: - -I. Provide definitions for 'fmap', 'extract', and 'duplicate' -satisfying these laws: - -> extract . duplicate == id -> fmap extract . duplicate == id -> duplicate . duplicate == fmap duplicate . duplicate - -II. Provide definitions for 'extract' and 'extend' -satisfying these laws: - -> extend extract == id -> extract . extend f == f -> extend f . extend g == extend (f . extend g) - -('fmap' cannot be defaulted, but a comonad which defines -'extend' may simply set 'fmap' equal to 'liftW'.) - -A comonad providing definitions for 'extend' /and/ 'duplicate', -must also satisfy these laws: - -> extend f == fmap f . duplicate -> duplicate == extend id -> fmap f == extend (f . duplicate) - -(The first two are the defaults for 'extend' and 'duplicate', -and the third is the definition of 'liftW'.) --} - --- class Functor w => Extendable w where --- duplicate :: w a -> w (w a) --- extend :: (w a -> b) -> w a -> w b --- extend f = fmap f . duplicate --- duplicate = extend id --- class (Copointed w, Extendable w) => Comonad w --- instance (Copointed w, Extendable w) => Comonad w - -class Copointed w => Comonad w where - duplicate :: w a -> w (w a) - extend :: (w a -> b) -> w a -> w b - extend f = fmap f . duplicate - duplicate = extend id - -liftW :: Comonad w => (a -> b) -> w a -> w b -liftW f = extend (f . extract) - --- | 'extend' with the arguments swapped. Dual to '>>=' for monads. -(=>>) :: Comonad w => w a -> (w a -> b) -> w b -(=>>) = flip extend - --- | Injects a value into the comonad. -(.>>) :: Comonad w => w a -> b -> w b -w .>> b = extend (\_ -> b) w - --- | Transform a function into a comonadic action -liftCtx :: Comonad w => (a -> b) -> w a -> b -liftCtx f = extract . fmap f - -mapW :: Comonad w => (w a -> b) -> w [a] -> [b] -mapW f w | null (extract w) = [] - | otherwise = f (fmap head w) : mapW f (fmap tail w) - -parallelW :: Comonad w => w [a] -> [w a] -parallelW w | null (extract w) = [] - | otherwise = fmap head w : parallelW (fmap tail w) - -unfoldW :: Comonad w => (w b -> (a,b)) -> w b -> [a] -unfoldW f w = fst (f w) : unfoldW f (w =>> snd . f) - --- | Converts a list of comonadic functions into a single function --- returning a list of values -sequenceW :: Comonad w => [w a -> b] -> w a -> [b] -sequenceW [] _ = [] -sequenceW (f:fs) w = f w : sequenceW fs w - -instance Comonad Identity where - extend f x = Identity (f x) - duplicate = Identity - -instance Comonad ((,)e) where - duplicate ~(e,a) = (e,(e,a)) - --- the anonymous exponent comonad -instance Monoid m => Copointed ((->)m) where - extract f = f mempty - -instance Monoid m => Comonad ((->)m) where - duplicate f m = f . mappend m diff --git a/src/Control/Comonad/Cofree.hs b/src/Control/Comonad/Cofree.hs deleted file mode 100644 --- a/src/Control/Comonad/Cofree.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Comonad.Cofree --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : rank-2 types --- --- Examples: --- type LV = Cofree Maybe --- type Stream = Cofree Identity - ----------------------------------------------------------------------------- -module Control.Comonad.Cofree - ( Cofree - , runCofree, cofree - , ComonadCofree(outCofree) - , RunComonadCofree(anaCofree) - ) where - -import Control.Arrow ((&&&)) -import Control.Comonad -import Control.Functor.Fix -import Control.Functor.Combinators.Biff -import Control.Monad.Identity -import Control.Comonad.Reader - -type Cofree f = Fix (PCofree f) - -runCofree :: Cofree f a -> (a, f (Cofree f a)) -runCofree = runPCofree . outB - -cofree :: a -> f (Cofree f a) -> Cofree f a -cofree a as = InB $ Biff (Identity a,as) - -class (Functor f, Comonad w) => ComonadCofree f w | w -> f where - outCofree :: w a -> f (w a) - -instance Functor f => ComonadCofree f (Cofree f) where - outCofree = snd . runCofree - -instance ComonadCofree f w => ComonadCofree f (CoreaderT w e) where - outCofree = fmap CoreaderT . outCofree . runCoreaderT - -class ComonadCofree f w => RunComonadCofree f w | w -> f where - anaCofree :: Functor f => (a -> c) -> (a -> f a) -> a -> w c - -instance Functor f => RunComonadCofree f (Cofree f) where - anaCofree h t = InB . Biff . (Identity . h &&& fmap (anaCofree h t) . t) diff --git a/src/Control/Comonad/Coideal.hs b/src/Control/Comonad/Coideal.hs deleted file mode 100644 --- a/src/Control/Comonad/Coideal.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Comonad.Coideal --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- ----------------------------------------------------------------------------- -module Control.Comonad.Coideal - ( - -- * Coideal Comonads - ComonadCoideal(..) - , Coideal - , coideal - , buildCoideal - -- * Mutual recursion for (co)ideal (co)monad (co)products - , Mutual(..) - -- * Coideal Comonad Product - , (:*) - ) where - -import Control.Functor.Internal.Ideal diff --git a/src/Control/Comonad/Context.hs b/src/Control/Comonad/Context.hs deleted file mode 100644 --- a/src/Control/Comonad/Context.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Comonad.Context --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (MPTCs) --- --- The Context Comonad Transformer is related to the left Kan Extension 'Lan' of --- a comonad along itself, except the type of the context is fixed, and --- not existentially quantified. - --- The context comonad can more traditionally be derived from the 'hom-prod' --- adjunction between (->) and (,) ----------------------------------------------------------------------------- -module Control.Comonad.Context - ( module Control.Comonad - , ComonadContext(..) - , putC - , experiment - , Context(..) - , runContext - , ContextT(..) - ) where - -import Control.Functor (first) -import Control.Comonad - -class Comonad w => ComonadContext s w | w -> s where - getC :: w a -> s - modifyC :: (s -> s) -> w a -> a - -putC :: ComonadContext s w => s -> w a -> a -putC = modifyC . const - -experiment :: (ComonadContext s w, Functor f) => f (s -> s) -> w a -> f a -experiment ms a = fmap (flip modifyC a) ms - -data Context s a = Context (s -> a) s - -runContext :: (Context s s -> Context s b) -> s -> (b, s) -runContext f s = (a b, b) where - Context a b = f (Context id s) - -instance ComonadContext s (Context s) where - getC (Context _ s) = s - modifyC m (Context f c) = f (m c) - -instance Functor (Context s) where - fmap f (Context f' s) = Context (f . f') s - -instance Copointed (Context s) where - extract (Context f a) = f a - -instance Comonad (Context s) where - duplicate (Context f a) = Context (Context f) a - -newtype ContextT s w a = ContextT { runContextT :: (w s -> a, w s) } - -instance Comonad w => ComonadContext s (ContextT s w) where - getC = extract . snd . runContextT - modifyC m (ContextT (f,c)) = f (fmap m c) - -instance Functor (ContextT b f) where - fmap f = ContextT . first (f .) . runContextT - -instance Copointed (ContextT b w) where - extract = uncurry id . runContextT - -instance Comonad w => Comonad (ContextT b w) where - duplicate (ContextT (f,ws)) = ContextT (ContextT . (,) f, ws) diff --git a/src/Control/Comonad/Density.hs b/src/Control/Comonad/Density.hs deleted file mode 100644 --- a/src/Control/Comonad/Density.hs +++ /dev/null @@ -1,100 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Comonad.Density --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- The density comonad for a functor. aka the comonad cogenerated by a functor --- The ''density'' term dates back to Dubuc''s 1974 thesis. The term --- ''monad genererated by a functor'' dates back to 1972 in Street''s --- ''Formal Theory of Monads''. ----------------------------------------------------------------------------- -module Control.Comonad.Density - ( Density(..) - , densityToLan, lanToDensity - , toDensity, fromDensity - , liftDensity, lowerDensity - , densityToAdjunction, adjunctionToDensity - , densityToComposedAdjunction, composedAdjunctionToDensity - , improveCofree - ) where - -import Prelude hiding (abs) -import Control.Comonad.Context -import Control.Comonad.Cofree -import Control.Comonad.Trans -import Control.Comonad.Reader -import Control.Functor.Adjunction -import Control.Functor.Composition -import Control.Functor.Extras -import Control.Functor.Pointed () -import Control.Functor.KanExtension -import Control.Monad.Identity - -data Density k a = forall b. Density (k b -> a) (k b) - -densityToLan :: Density k a -> Lan k k a -densityToLan (Density f v) = Lan f v - -lanToDensity :: Lan k k a -> Density k a -lanToDensity (Lan f v) = Density f v - --- | @Nat(k, s.k)@ is isomorphic to @Nat (Density k, s)@ (forwards) -toDensity :: Functor s => (forall a. k a -> s (k a)) -> Density k :~> s -toDensity s (Density f v) = fmap f $ s v - --- | @Nat(k, s.k)@ is isomorphic to @Nat (Density k, s)@ (backwards) -fromDensity :: (Density k :~> s) -> k a -> s (k a) -fromDensity s = s . Density id - -instance ComonadTrans Density where - colift = liftDensity - -instance Functor (Density f) where - fmap f (Density g h) = Density (f . g) h - -instance Copointed (Density f) where - extract (Density f a) = f a - -instance Comonad (Density f) where - duplicate (Density f ws) = Density (Density f) ws - --- | The natural isomorphism between a comonad w and the comonad generated by w (forwards). -liftDensity :: Comonad w => w a -> Density w a -liftDensity = Density extract - --- | The natural isomorphism between a comonad w and the comonad generated by w (backwards). -lowerDensity :: Comonad w => Density w a -> w a -lowerDensity (Density f c) = extend f c - -densityToAdjunction :: Adjunction f g => Density f a -> f (g a) -densityToAdjunction (Density f v) = fmap (leftAdjunct f) v - -adjunctionToDensity :: Adjunction f g => f (g a) -> Density f a -adjunctionToDensity = Density counit - -densityToComposedAdjunction :: (Composition o, Adjunction f g) => Density f :~> (f `o` g) -densityToComposedAdjunction (Density f v) = compose (fmap (leftAdjunct f) v) - -composedAdjunctionToDensity :: (Composition o, Adjunction f g) => (f `o` g) :~> Density f -composedAdjunctionToDensity = Density counit . decompose - -instance ComonadReader e w => ComonadReader e (Density w) where - askC = askC . lowerDensity - -instance ComonadContext e w => ComonadContext e (Density w) where - getC = getC . lowerDensity - modifyC f = modifyC f . lowerDensity - -instance ComonadCofree f w => ComonadCofree f (Density w) where - outCofree (Density f c) = fmap (Density f) (outCofree c) - -instance RunComonadCofree f w => RunComonadCofree f (Density w) where - anaCofree l r = liftDensity . anaCofree l r - -improveCofree :: Functor f => (forall w. ComonadCofree f w => w a) -> Cofree f a -improveCofree m = lowerDensity m diff --git a/src/Control/Comonad/Exponent.hs b/src/Control/Comonad/Exponent.hs deleted file mode 100644 --- a/src/Control/Comonad/Exponent.hs +++ /dev/null @@ -1,29 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Comonad.Exponent --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- ----------------------------------------------------------------------------- -module Control.Comonad.Exponent - ( Exp(..) - ) where - -import Data.Monoid -import Control.Comonad - -data Exp m a = Exp { runExp :: m -> a } - -instance Functor (Exp m) where - fmap f (Exp g) = Exp (f . g) - -instance Monoid m => Copointed (Exp m) where - extract (Exp f) = f mempty - -instance Monoid m => Comonad (Exp m) where - duplicate f = Exp $ \m -> Exp $ runExp f . mappend m - diff --git a/src/Control/Comonad/Fix.hs b/src/Control/Comonad/Fix.hs deleted file mode 100644 --- a/src/Control/Comonad/Fix.hs +++ /dev/null @@ -1,31 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Comonad.Fix --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------------- -module Control.Comonad.Fix - ( cofix - ) where - -import Control.Comonad --- import Control.Monad.Identity - ---class Comonad w => ComonadFix w where --- cofix :: w (w a -> a) -> a - ---instance ComonadFix Identity where --- cofix (Identity f) = fix (f . Identity) - ---instance ComonadFix ((,)e) where --- cofix ~(e,f) = let x = f (e,x) in x - - -cofix :: Comonad w => w (w a -> a) -> a -cofix w = extract w (extend cofix w) - diff --git a/src/Control/Comonad/HigherOrder.hs b/src/Control/Comonad/HigherOrder.hs deleted file mode 100644 --- a/src/Control/Comonad/HigherOrder.hs +++ /dev/null @@ -1,28 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Comonad.HigherOrder --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- extending Neil Ghani and Patrician Johann's HFunctor to higher order comonads ----------------------------------------------------------------------------- -module Control.Comonad.HigherOrder - ( HFunctor(..) - , HCopointed(..) - , HComonad(..) - , hduplicate - ) where - -import Control.Functor.Extras -import Control.Functor.HigherOrder - -class HCopointed w => HComonad w where - hextend :: (Functor f, Functor g) => (w f :~> g) -> w f :~> w g - - -hduplicate :: (HComonad w, Functor (w g), Functor g) => w g :~> w (w g) -hduplicate = hextend id diff --git a/src/Control/Comonad/Indexed.hs b/src/Control/Comonad/Indexed.hs deleted file mode 100644 --- a/src/Control/Comonad/Indexed.hs +++ /dev/null @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Comonad.Indexed --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- ----------------------------------------------------------------------------- -module Control.Comonad.Indexed - ( IxFunctor(..) - , IxCopointed(..) - , IxComonad(..) - , iduplicate - ) where - -import Control.Functor.Indexed - -class IxCopointed w => IxComonad w where - iextend :: (w j k a -> b) -> w i k a -> w i j b - -iduplicate :: IxComonad w => w i k a -> w i j (w j k a) -iduplicate = iextend id - diff --git a/src/Control/Comonad/Parameterized.hs b/src/Control/Comonad/Parameterized.hs deleted file mode 100644 --- a/src/Control/Comonad/Parameterized.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Comonad.Parameterized --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- ----------------------------------------------------------------------------- -module Control.Comonad.Parameterized - ( PCopointed(..) - , PComonad(..) - ) where - -import Control.Functor -import Control.Functor.Pointed - -class PCopointed f => PComonad f where - pextend :: (f b c -> a) -> f b c -> f a c - -{- Parameterized comonad laws: - -> pextend pextract = id -> pextract . pextend g = g -> pextend (g . pextend j) = pextend g . pextend j -> pextract . second g = pextract -> second g . pextend (j . second g) = pextend j . second g - --} - -{-# RULES -"pextend pextract" pextend pextract = id -"pextract . pextend g" forall g. pextract . pextend g = g -"bimap _ _ . pextract" forall j g. bimap id g . pextend (j . bimap id g) = pextend j . bimap id g - #-} diff --git a/src/Control/Comonad/Pointer.hs b/src/Control/Comonad/Pointer.hs deleted file mode 100644 --- a/src/Control/Comonad/Pointer.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Comonad.Pointer --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- --- SIGFPE (Dan Piponi)'s Pointer Comonad ----------------------------------------------------------------------------- -module Control.Comonad.Pointer - ( module Control.Comonad - , Pointer(..) - , distPointer - ) where - -import Control.Functor.Extras -import Data.Array -import Control.Comonad - -data Pointer i a = Pointer { index :: i, array :: Array i a } deriving (Show,Read) - -instance Ix i => Functor (Pointer i) where - fmap f (Pointer i a) = Pointer i (fmap f a) - -instance Ix i => Copointed (Pointer i) where - extract (Pointer i a) = a ! i - -instance Ix i => Comonad (Pointer i) where - extend f (Pointer i a) = Pointer i . listArray bds $ fmap (f . flip Pointer a) (range bds) where - bds = bounds a - -distPointer :: (Monad m, Ix i) => Dist (Pointer i) m -distPointer (Pointer i ma) = do - let bds = bounds ma - a <- sequence (elems ma) - return $ Pointer i (listArray bds a) diff --git a/src/Control/Comonad/Reader.hs b/src/Control/Comonad/Reader.hs deleted file mode 100644 --- a/src/Control/Comonad/Reader.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Comonad.Reader --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- --- If you look at the reader arrow: --- @(e, a) -> a@ you can see that all the interesting bits are bunched --- on the left. This is that comonad. Flipping the pair and currying the --- arguments yields @a -> (e -> a)@, and you can recognize the (e -> a) as --- the reader monad. In more technical language the Reader comonad is --- left adjoint to the Reader monad. ----------------------------------------------------------------------------- -module Control.Comonad.Reader - ( Coreader(..) - , runCoreader - , CoreaderT(..) - , ComonadReader(..) - ) where - -import Control.Arrow ((&&&)) -import Control.Functor -import Control.Category.Hask -import Control.Comonad -import Control.Monad.Instances - -class Comonad w => ComonadReader r w | w -> r where - askC :: w a -> r - -data Coreader r a = Coreader r a - -runCoreader :: Coreader r a -> (r, a) -runCoreader (Coreader r a) = (r,a) - -instance ComonadReader r (Coreader r) where - askC (Coreader r _) = r - -instance Functor (Coreader r) where - fmap f = uncurry Coreader . second f . runCoreader - -instance Copointed (Coreader r) where - extract (Coreader _ a) = a - -instance Comonad (Coreader r) where - duplicate (Coreader e a) = Coreader e (Coreader e a) - -instance PFunctor Coreader Hask Hask where - first = first' - -instance QFunctor Coreader Hask Hask where - second = second' - -instance Bifunctor Coreader Hask Hask Hask where - bimap f g = uncurry Coreader . bimap f g . runCoreader - - -newtype CoreaderT w r a = CoreaderT { runCoreaderT :: w (r, a) } - -instance Comonad w => ComonadReader r (CoreaderT w r) where - askC = fst . extract . runCoreaderT - -instance Functor f => Functor (CoreaderT f b) where - fmap f = CoreaderT . fmap (fmap f) . runCoreaderT - -instance Copointed w => Copointed (CoreaderT w b) where - extract = snd . extract . runCoreaderT - -instance Comonad w => Comonad (CoreaderT w b) where - duplicate = CoreaderT . liftW (fst . extract &&& CoreaderT) . duplicate . runCoreaderT - -instance Functor f => PFunctor (CoreaderT f) Hask Hask where - first = first' - -instance Functor f => QFunctor (CoreaderT f) Hask Hask where - second = second' - -instance Functor f => Bifunctor (CoreaderT f) Hask Hask Hask where - bimap f g = CoreaderT . fmap (bimap f g) . runCoreaderT - -instance ComonadReader e ((,)e) where - askC = fst diff --git a/src/Control/Comonad/Stream.hs b/src/Control/Comonad/Stream.hs deleted file mode 100644 --- a/src/Control/Comonad/Stream.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Comonad.Stream --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- ----------------------------------------------------------------------------- -module Control.Comonad.Stream - ( Stream - ) where - - -import Control.Comonad.Cofree -import Control.Monad.Identity -type Stream = Cofree Identity - --- class ComonadStream w where fby :: a -> (w a -> a) --- next :: w a -> w a --- run :: (ComonadStream w, ComonadContext Int c) => (c a -> b) -> w a -> w b diff --git a/src/Control/Comonad/Supply.hs b/src/Control/Comonad/Supply.hs deleted file mode 100644 --- a/src/Control/Comonad/Supply.hs +++ /dev/null @@ -1,150 +0,0 @@ --------------------------------------------------------------------- --- | --- Module : Control.Comonad.Supply --- Copyright : (c) Edward Kmett 2008 --- (c) Iavor S. Diatchki, 2007 --- License : BSD3 --- --- Maintainer: Edward Kmett --- Stability : provisional --- Portability: portable --- --- The technique for generating new values is based on the paper --- ''On Generating Unique Names'' --- by Lennart Augustsson, Mikael Rittri, and Dan Synek. --- --- Integrated from value-supply-0.1 --- --- TODO: a SupplyT Comonad Transformer --------------------------------------------------------------------- - -module Control.Comonad.Supply - ( module Control.Comonad - - - -- * Creating supplies - , Supply - , newSupply - , newEnumSupply - , newNumSupply - - -- * Obtaining values from supplies - , supplyValue - - -- * Generating new supplies from old - , supplyLeft - , supplyRight - , modifySupply - , split - , split2 - , split3 - , split4 - ) where - -import Control.Comonad --- Using 'MVar's might be a bit heavy but it ensures that --- multiple threads that share a supply will get distinct names. -import Control.Concurrent.MVar -import Control.Functor.Extras -import System.IO.Unsafe(unsafePerformIO) - --- Basics ---------------------------------------------------------------------- - --- | A type that can be used to generate values on demand. --- A supply may be turned into two different supplies by using --- the functions 'supplyLeft' and 'supplyRight'. -data Supply a = Node - { -- | Get the value of a supply. This function, together with - -- 'modifySupply' forms a comonad on 'Supply'. - supplyValue :: a - - -- | Generate a new supply. This supply is different from the one - -- generated with 'supplyRight'. - , supplyLeft :: Supply a - - -- | Generate a new supply. This supply is different from the one - -- generated with 'supplyLeft'. - , supplyRight :: Supply a - } - -instance Functor Supply where - fmap f s = modifySupply s (f . supplyValue) - --- | Creates a new supply of values. --- The arguments specify how to generate values: --- the first argument is an initial value, the --- second specifies how to generate a new value from an existing one. -newSupply :: a -> (a -> a) -> IO (Supply a) -newSupply x f = fmap (gen True) (newMVar (iterate f x)) - - -- The extra argument to ``gen'' is passed because without - -- it Hugs spots that the recursive calls are the same but does - -- not know that unsafePerformIO is unsafe. - where gen _ r = Node { supplyValue = unsafePerformIO (genSym r), - supplyLeft = gen False r, - supplyRight = gen True r } - - genSym :: MVar [a] -> IO a - genSym r = do a : as <- takeMVar r - putMVar r as - return a - --- | Generate a new supply by systematically applying a function --- to an existing supply. This function, together with 'supplyValue' --- form a comonad on 'Supply'. -modifySupply :: Supply a -> (Supply a -> b) -> Supply b -modifySupply = flip extend - --- (Supply, supplyValue, modifySupply) forms a comonad: -{- -law1 s = [ modifySupply s supplyValue, s ] -law2 s f = [ supplyValue (modifySupply s f), f s ] -law3 s f g = [ (s `modifySupply` f) `modifySupply` g - , s `modifySupply` \s1 -> g (s1 `modifySupply` f) - ] --} - - --- Derived functions ----------------------------------------------------------- - --- | A supply of values that are in the 'Enum' class. --- The initial value is @toEnum 0@, new values are generates with 'succ'. -newEnumSupply :: (Enum a) => IO (Supply a) -newEnumSupply = newSupply (toEnum 0) succ - --- | A supply of values that are in the 'Num' class. --- The initial value is 0, new values are generated by adding 1. -newNumSupply :: (Num a) => IO (Supply a) -newNumSupply = newSupply 0 (1+) - --- | Generate an infinite list of supplies by using 'supplyLeft' and --- 'supplyRight' repeatedly. -split :: Supply a -> [Supply a] -split s = supplyLeft s : split (supplyRight s) - --- | Split a supply into two different supplies. --- The resulting supplies are different from the input supply. -split2 :: Supply a -> (Supply a, Supply a) -split2 s = (supplyLeft s, supplyRight s) - --- | Split a supply into three different supplies. -split3 :: Supply a -> (Supply a, Supply a, Supply a) -split3 s = let s1 : s2 : s3 : _ = split s - in (s1,s2,s3) - --- | Split a supply into four different supplies. -split4 :: Supply a -> (Supply a, Supply a, Supply a, Supply a) -split4 s = let s1 : s2 : s3 : s4 : _ = split s - in (s1,s2,s3,s4) - -instance Copointed Supply where - extract = supplyValue - -instance Comonad Supply where - extend f s = Node { supplyValue = f s - , supplyLeft = modifySupply (supplyLeft s) f - , supplyRight = modifySupply (supplyRight s) f - } - -instance FunctorSplit Supply where - fsplit = split2 diff --git a/src/Control/Comonad/Trans.hs b/src/Control/Comonad/Trans.hs deleted file mode 100644 --- a/src/Control/Comonad/Trans.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Comonad.Trans --- Copyright : (C) 2008 Edward Kmett --- (C) 2004 Dave Menendez --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable ----------------------------------------------------------------------------- -module Control.Comonad.Trans - ( ComonadTrans(colift) - ) where - -import Control.Comonad - -class ComonadTrans t where - colift :: Comonad w => w a -> t w a diff --git a/src/Control/Dyad.hs b/src/Control/Dyad.hs deleted file mode 100644 --- a/src/Control/Dyad.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# OPTIONS_GHC -cpp #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Dyad --- Copyright : 2008 Edward Kmett --- License : BSD3 --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- --- Working Towards Maarten Fokkinga's Dyads -------------------------------------------------------------------------------------------- - -module Control.Dyad where - -import Prelude hiding (id,(.)) -import Control.Category -import Control.Functor.Categorical - -class (CDistributes w m (~>), CDistributes m w (~>), CExtend w (~>), CBind m (~>)) => CDyad w m (~>) where - cdyid :: w a ~> m a - -newtype DiKleisli w m (~>) a b = DiKleisli { runDiKleisli :: w a ~> m b } - --- instance CMonad m k => CFunctor (DiKleisli w m k a) k k where --- cmap f (DiKleisli x) = DiKleisli (cmap f . x) - --- instance CMonad m k => QFunctor (DiKleisli w m k) k k where second g = --- instance CComonad w k => PFunctor (DiKleisli w m k) (Dual k) k where first f = --- instance (CMonad m k, CComonad w k) => Bifunctor (DiKleisli w m k) (Dual Hask) Hask Hask where bimap f g - -instance CDyad w m k => Category (DiKleisli w m k) where - DiKleisli f . DiKleisli g = DiKleisli (cbind f . cdist . cextend g) - id = DiKleisli cdyid diff --git a/src/Control/Functor.hs b/src/Control/Functor.hs deleted file mode 100644 --- a/src/Control/Functor.hs +++ /dev/null @@ -1,66 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor --- Copyright : 2008 Edward Kmett --- License : BSD3 --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (functional-dependencies) --- --- A more categorical definition of Functor than endofunctors in the category Hask -------------------------------------------------------------------------------------------- -module Control.Functor - ( PFunctor (first), first' - , QFunctor (second), second' - , Bifunctor (bimap) - , dimap - ) where - -import Prelude hiding (id,(.)) -import Control.Category -import Control.Category.Dual -import Control.Category.Hask - -class (Category r, Category t) => PFunctor p r t | p r -> t, p t -> r where - first :: r a b -> t (p a c) (p b c) - -{-# INLINE first' #-} -first' :: Bifunctor p r s t => r a b -> t (p a c) (p b c) -first' f = bimap f id - -class (Category s, Category t) => QFunctor q s t | q s -> t, q t -> s where - second :: s a b -> t (q c a) (q c b) - -{-# INLINE second' #-} -second' :: Bifunctor p r s t => s a b -> t (p c a) (p c b) -second' = bimap id - -instance PFunctor Either Hask Hask where - first = first' - -instance QFunctor Either Hask Hask where - second = second' - -instance Bifunctor Either Hask Hask Hask where - bimap f _ (Left a) = Left (f a) - bimap _ g (Right a) = Right (g a) - -instance QFunctor (->) Hask Hask where - second = (.) - -instance PFunctor (,) Hask Hask where - first = first' - -instance QFunctor (,) Hask Hask where - second = second' - -instance Bifunctor (,) Hask Hask Hask where - bimap f g ~(a,b)= (f a, g b) - -class (PFunctor p r t, QFunctor p s t) => Bifunctor p r s t | p r -> s t, p s -> r t, p t -> r s where - bimap :: r a b -> s c d -> t (p a c) (p b d) - --- map for difunctors -dimap :: Bifunctor f (Dual k) k k => k b a -> k c d -> k (f a c) (f b d) -dimap f = bimap (Dual f) diff --git a/src/Control/Functor/Adjunction.hs b/src/Control/Functor/Adjunction.hs deleted file mode 100644 --- a/src/Control/Functor/Adjunction.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Adjunction --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (functional-dependencies) --- -------------------------------------------------------------------------------------------- - -module Control.Functor.Adjunction - ( Adjunction (unit, counit, leftAdjunct, rightAdjunct) - , ACompF(ACompF) - -- * Every Right Adjoint is Representable - , repAdjunction, unrepAdjunction - ) where - -import Control.Functor.Internal.Adjunction diff --git a/src/Control/Functor/Adjunction/HigherOrder.hs b/src/Control/Functor/Adjunction/HigherOrder.hs deleted file mode 100644 --- a/src/Control/Functor/Adjunction/HigherOrder.hs +++ /dev/null @@ -1,35 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.Adjunction.HigherOrder --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Higher-Order Adjunctions ----------------------------------------------------------------------------- -module Control.Functor.Adjunction.HigherOrder - ( HAdjunction(..) - ) where - -import Control.Functor.HigherOrder -import Control.Functor.HigherOrder.Composition -import Control.Functor.Extras - -class (HFunctor f, HFunctor g) => HAdjunction f g where - hunit :: a :~> g (f a) - hcounit :: f (g b) :~> b - hleftAdjunct :: (f a :~> b) -> a :~> g b - hrightAdjunct :: (a :~> g b) -> f a :~> b - - hunit = hleftAdjunct id - hcounit = hrightAdjunct id - hleftAdjunct f = hfmap f . hunit - hrightAdjunct f = hcounit . hfmap f - - -instance (HAdjunction f1 g1, HAdjunction f2 g2) => HAdjunction (CompH f2 f1) (CompH g1 g2) where - hcounit = hcounit . hfmap (hcounit . hfmap hdecompose) . hdecompose - hunit = hcompose . hfmap (hfmap hcompose . hunit) . hunit diff --git a/src/Control/Functor/Algebra.hs b/src/Control/Functor/Algebra.hs deleted file mode 100644 --- a/src/Control/Functor/Algebra.hs +++ /dev/null @@ -1,78 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.Algebra --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Algebras, Coalgebras, Bialgebras, and Dialgebras and their (co)monadic --- variants ----------------------------------------------------------------------------- -module Control.Functor.Algebra - ( Dialgebra, GDialgebra - , Bialgebra, GBialgebra - , Algebra, GAlgebra - , Coalgebra, GCoalgebra - , Trialgebra - , liftAlgebra - , liftCoalgebra - , liftDialgebra - , fromCoalgebra - , fromAlgebra - , fromBialgebra - ) where - -import Control.Comonad -import Control.Monad.Identity -import Control.Functor -import Control.Functor.Extras -import Control.Functor.Combinators.Lift - - --- | F-G-bialgebras are representable by @DiAlg (f :+: Identity) (Identity :+: g) a@ --- and so add no expressive power, but are a lot more convenient. -type Bialgebra f g a = (Algebra f a, Coalgebra g a) -type GBialgebra f g w m a = (GAlgebra f w a, GCoalgebra g m a) - --- | Martin Erwig's trialgebras for indexed data types -type Trialgebra f g h a = (Algebra f a, Dialgebra g h a) - --- | F-Algebras -type Algebra f a = f a -> a - --- | F-Coalgebras -type Coalgebra f a = a -> f a - --- | F-W-Comonadic Algebras for a given comonad W -type GAlgebra f w a = f (w a) -> a - --- | F-M-Monadic Coalgebras for a given monad M -type GCoalgebra f m a = a -> f (m a) - --- | Turn an F-algebra into a F-W-algebra by throwing away the comonad -liftAlgebra :: (Functor f, Comonad w) => Algebra f :~> GAlgebra f w -liftAlgebra phi = phi . fmap extract - --- | Turn a F-coalgebra into a F-M-coalgebra by returning into a monad -liftCoalgebra :: (Functor f, Monad m) => Coalgebra f :~> GCoalgebra f m -liftCoalgebra psi = fmap return . psi - -liftDialgebra :: (Functor g, Functor f, Comonad w, Monad m) => Dialgebra f g :~> GDialgebra f g w m -liftDialgebra phi = fmap return . phi . fmap extract - -fromAlgebra :: Algebra f :~> Dialgebra f Identity -fromAlgebra phi = Identity . phi - -fromCoalgebra :: Coalgebra f :~> Dialgebra Identity f -fromCoalgebra psi = psi . runIdentity - -fromBialgebra :: Bialgebra f g :~> Dialgebra (f :*: Identity) (Identity :*: g) -fromBialgebra (phi,psi) = Lift . bimap (Identity . phi) (psi . runIdentity) . runLift - --- | F,G-dialgebras generalize algebras and coalgebras --- NB: these definitions are actually wrong. -type Dialgebra f g a = f a -> g a -type GDialgebra f g w m a = f (w a) -> g (m a) diff --git a/src/Control/Functor/Algebra/Elgot.hs b/src/Control/Functor/Algebra/Elgot.hs deleted file mode 100644 --- a/src/Control/Functor/Algebra/Elgot.hs +++ /dev/null @@ -1,34 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.Algebra.Elgot --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Elgot algebras, and their obvious dual, based on: --- --- --- Elgot algebras given you a shortcircuitable hylomorphism where you --- can directly return a sub-answer to the catamorphism. --- --- Elgot coalgebras are defined in: --- ----------------------------------------------------------------------------- -module Control.Functor.Algebra.Elgot - ( elgot - , coelgot - ) where - -import Control.Arrow ((|||),(&&&)) -import Control.Functor.Algebra - --- | Elgot algebra -elgot :: Functor f => Algebra f a -> (b -> Either a (f b)) -> b -> a -elgot phi psi = h where h = (id ||| phi . fmap h) . psi - --- | Elgot coalgebra -coelgot :: Functor f => ((a, f b) -> b) -> Coalgebra f a -> a -> b -coelgot phi psi = h where h = phi . (id &&& fmap h . psi) diff --git a/src/Control/Functor/Categorical.hs b/src/Control/Functor/Categorical.hs deleted file mode 100644 --- a/src/Control/Functor/Categorical.hs +++ /dev/null @@ -1,100 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Categorical --- Copyright : 2008 Edward Kmett --- License : BSD3 --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (functional-dependencies) --- --- A more categorical definition of Functor than endofunctors in the category Hask -------------------------------------------------------------------------------------------- -module Control.Functor.Categorical - ( CFunctor (cmap) - , CPointed (creturn) - , CCopointed (cextract) - , CBind (cbind, cjoin) - , CExtend (cextend, cduplicate) - , CDistributes (cdist) - , CMonad - , CComonad - ) where - -import Prelude hiding (id,(.)) -import Control.Category -import Control.Category.Hask -import Control.Monad.Identity -import Control.Monad.List -import Control.Monad.Cont - -import Control.Monad.Reader -import Control.Monad.Writer as LW -import Control.Monad.State as LS - -import Control.Monad.RWS as LRWS -#if __GLASGOW_HASKELL__ >= 608 -import Control.Monad.Writer.Strict as SW -import Control.Monad.State.Strict as SS -import Control.Monad.RWS.Strict as SRWS -#endif - -class (Category r, Category s) => CFunctor f r s | f r -> s, f s -> r where - cmap :: r a b -> s (f a) (f b) - -instance CFunctor ([]) Hask Hask where cmap = fmap -instance CFunctor Maybe Hask Hask where cmap = fmap -instance CFunctor (Either a) Hask Hask where cmap = fmap -instance CFunctor Identity Hask Hask where cmap = fmap -instance CFunctor ((,)e) Hask Hask where cmap = fmap -instance CFunctor (Reader e) Hask Hask where cmap = fmap -instance CFunctor (LW.Writer e) Hask Hask where cmap = fmap -instance CFunctor (LS.State s) Hask Hask where cmap = fmap -instance CFunctor (Cont e) Hask Hask where cmap = fmap -instance CFunctor (LRWS.RWS r w s) Hask Hask where cmap = fmap -instance CFunctor IO Hask Hask where cmap = fmap - -instance Monad m => CFunctor (ReaderT e m) Hask Hask where cmap = fmap -instance Monad m => CFunctor (LW.WriterT e m) Hask Hask where cmap = fmap -instance Monad m => CFunctor (LS.StateT e m) Hask Hask where cmap = fmap -instance Monad m => CFunctor (ContT r m) Hask Hask where cmap = fmap -instance Monad m => CFunctor (ListT m) Hask Hask where cmap = fmap -instance Monad m => CFunctor (LRWS.RWST r w s m) Hask Hask where cmap = fmap - -#if __GLASGOW_HASKELL__ >= 608 -instance CFunctor (SW.Writer e) Hask Hask where cmap = fmap -instance CFunctor (SS.State s) Hask Hask where cmap = fmap -instance CFunctor (SRWS.RWS r w s) Hask Hask where cmap = fmap -instance Monad m => CFunctor (SW.WriterT w m) Hask Hask where cmap = fmap -instance Monad m => CFunctor (SS.StateT s m) Hask Hask where cmap = fmap -instance Monad m => CFunctor (SRWS.RWST r w s m) Hask Hask where cmap = fmap -#endif - -class CFunctor m (~>) (~>) => CBind m (~>) where - cjoin :: m (m a) ~> m a - cbind :: (a ~> m b) -> (m a ~> m b) - - cjoin = cbind id - cbind f = cjoin . cmap f - -class CFunctor w (~>) (~>) => CExtend w (~>) where - cduplicate :: w a ~> w (w a) - cextend :: (w a ~> b) -> (w a ~> w b) - - cduplicate = cextend id - cextend f = cmap f . cduplicate - -class CFunctor m (~>) (~>) => CPointed m (~>) where - creturn :: a ~> m a - -class CFunctor w (~>) (~>) => CCopointed w (~>) where - cextract :: w a ~> a - -class (CFunctor f (~>) (~>), CFunctor g (~>) (~>)) => CDistributes f g (~>) where - cdist :: f (g a) ~> g (f a) - -class (CPointed m (~>), CBind m (~>)) => CMonad m (~>) -instance (CPointed m (~>), CBind m (~>)) => CMonad m (~>) - -class (CCopointed m (~>), CExtend m (~>)) => CComonad m (~>) -instance (CCopointed m (~>), CExtend m (~>)) => CComonad m (~>) diff --git a/src/Control/Functor/Combinators/Biff.hs b/src/Control/Functor/Combinators/Biff.hs deleted file mode 100644 --- a/src/Control/Functor/Combinators/Biff.hs +++ /dev/null @@ -1,114 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Combinators.Biff --- Copyright : 2008 Edward Kmett --- License : BSD3 --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------------- - -module Control.Functor.Combinators.Biff - ( Biff(..) - -- Parameterized Type level 'On' - , On, runOn, mkOn - -- Parameterized Type Level 'Ap' - , PAp, runPAp, mkPAp - -- Parameterized Cofree Comonad - , PCofree, runPCofree, pcofree - -- Parameterized Free Monad - , PFree, runPFree, pfree - ) where - -import Control.Category.Hask -import Control.Arrow ((|||),(&&&)) -import Control.Monad.Identity -import Control.Category.Braided -import Control.Functor -import Control.Functor.Extras -import Control.Monad.Parameterized -import Control.Comonad.Parameterized - -newtype Biff p f g a b = Biff { runBiff :: p (f a) (g b) } - -type PAp p = Biff p Identity - -runPAp :: PFunctor p Hask Hask => PAp p f a b -> p a (f b) -runPAp = first runIdentity . runBiff - -mkPAp :: PFunctor p Hask Hask => p a (f b) -> PAp p f a b -mkPAp = Biff . first Identity - -type PFree = PAp Either - -pfree :: Either a (f b) -> PFree f a b -pfree = mkPAp - -runPFree :: PFree f a b -> Either a (f b) -runPFree = runPAp - -type PCofree = PAp (,) - -runPCofree :: PCofree f a b -> (a, f b) -runPCofree = runPAp - -pcofree :: (a, f b) -> PCofree f a b -pcofree = mkPAp - -type On p f = Biff p f f - -runOn :: On p f a b -> p (f a) (f b) -runOn = runBiff - -mkOn :: p (f a) (f b) -> On p f a b -mkOn = Biff - -{- -type Joker = Biff (,) VoidF -type Clown f = Biff (,) f VoidF -type Fst = Biff (,) VoidF Identity -type Snd = Biff (,) Identity VoidF --} - -instance (Functor f, PFunctor p Hask Hask) => PFunctor (Biff p f g) Hask Hask where - first f = Biff . first (fmap f) . runBiff - -instance (QFunctor q Hask Hask, Functor g) => QFunctor (Biff q f g) Hask Hask where - second g = Biff . second (fmap g) . runBiff - -instance (Functor f, Bifunctor p Hask Hask Hask, Functor g) => Bifunctor (Biff p f g) Hask Hask Hask where - bimap f g = Biff . bimap (fmap f) (fmap g) . runBiff - -instance (Functor f, Braided Hask p) => Braided Hask (Biff p f f) where - braid = Biff . braid . runBiff - -instance (Functor f, Symmetric Hask p) => Symmetric Hask (Biff p f f) - -instance (Functor f, Bifunctor p Hask Hask Hask, Functor g) => Functor (Biff p f g a) where - fmap f = bimap id f - -instance FunctorPlus f => PPointed (PCofree f) where - preturn a = Biff (Identity a,fzero) - -instance Functor f => PPointed (PFree f) where - preturn = Biff . Left . Identity - -instance Functor f => PCopointed (PCofree f) where - pextract = runIdentity . fst . runBiff - -instance Functor f => PApplicative (PFree f) where - pap = papPMonad - -instance Functor f => PMonad (PFree f) where - pbind k = (k . runIdentity ||| Biff . Right) . runBiff - -instance FunctorPlus f => PApplicative (PCofree f) where - pap = papPMonad - -instance FunctorPlus f => PMonad (PCofree f) where - pbind k (Biff ~(Identity a,as)) = Biff (ib, fplus as bs) where Biff (ib,bs) = k a - -instance Functor f => PComonad (PCofree f) where - pextend f = Biff . (Identity . f &&& snd . runBiff) diff --git a/src/Control/Functor/Combinators/Const.hs b/src/Control/Functor/Combinators/Const.hs deleted file mode 100644 --- a/src/Control/Functor/Combinators/Const.hs +++ /dev/null @@ -1,95 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Combinators.Const --- Copyright : 2008 Edward Kmett --- License : BSD3 --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------------- - -module Control.Functor.Combinators.Const - ( Const2(Const2,runConst2) - ) where - -import Data.Monoid -import Control.Applicative -import Control.Applicative.Parameterized () -import Control.Monad -import Control.Category.Hask -import Control.Category.Associative -import Control.Category.Braided -import Control.Functor -import Control.Functor.Exponential -import Control.Functor.Contra -import Control.Functor.Zip -import Control.Functor.Pointed -import Control.Monad.Parameterized -import Control.Comonad.Parameterized () - -newtype Const2 t a b = Const2 { runConst2 :: t } - -instance QFunctor (Const2 t) Hask Hask where - second _ = Const2 . runConst2 - -instance PFunctor (Const2 t) Hask Hask where - first _ = Const2 . runConst2 - -instance Bifunctor (Const2 t) Hask Hask Hask where - bimap _ _ = Const2 . runConst2 - -instance Associative Hask (Const2 t) where - associate = Const2 . runConst2 - -instance Coassociative Hask (Const2 t) where - coassociate = Const2 . runConst2 - -instance Braided Hask (Const2 t) where - braid = Const2 . runConst2 - -instance Symmetric Hask (Const2 t) - -instance Monoid t => Zip (Const2 t a) where - fzipWith _ a b = Const2 (runConst2 a `mappend` runConst2 b) - -instance Monoid t => Bizip (Const2 t) where - bizipWith _ _ a b = Const2 (runConst2 a `mappend` runConst2 b) - -instance Functor (Const2 t a) where - fmap _ = Const2 . runConst2 - -instance ContraFunctor (Const2 t a) where - contramap _ = Const2 . runConst2 - -instance ExpFunctor (Const2 t a) where - xmap _ _ = Const2 . runConst2 - -instance Monoid t => Pointed (Const2 t a) where - point _ = Const2 mempty - -instance Monoid t => PPointed (Const2 t) where - preturn _ = Const2 mempty - -instance Monoid t => Applicative (Const2 t a) where - pure _ = Const2 mempty - f <*> a = Const2 (runConst2 f `mappend` runConst2 a) - -instance Monoid t => PApplicative (Const2 t) where - pap f a = Const2 (runConst2 f `mappend` runConst2 a) - -instance Monoid t => Monad (Const2 t a) where - return _ = Const2 mempty - m >>= _ = Const2 $ runConst2 m - -instance Monoid t => PMonad (Const2 t) where - pbind _ = Const2 . runConst2 - -instance Monoid t => Monoid (Const2 t a b) where - mempty = Const2 mempty - mappend a b = Const2 (runConst2 a `mappend` runConst2 b) - -instance Monoid t => MonadPlus (Const2 t a) where - mzero = Const2 mempty - mplus a b = Const2 (runConst2 a `mappend` runConst2 b) diff --git a/src/Control/Functor/Combinators/Flip.hs b/src/Control/Functor/Combinators/Flip.hs deleted file mode 100644 --- a/src/Control/Functor/Combinators/Flip.hs +++ /dev/null @@ -1,66 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Combinators.Flip --- Copyright : 2008 Edward Kmett --- License : BSD3 --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------------- - -module Control.Functor.Combinators.Flip - ( Flip(..) - , liftFlip - ) where - -import Control.Monad.Identity -import Control.Functor -import Control.Category.Hask -import Control.Category.Associative -import Control.Category.Monoidal - -newtype Flip p a b = Flip { runFlip :: p b a } - -liftFlip :: (p a b -> p c d) -> Flip p b a -> Flip p d c -liftFlip f = Flip . f . runFlip - -instance PFunctor p Hask Hask => QFunctor (Flip p) Hask Hask where - second g = liftFlip (first g) - -instance QFunctor p Hask Hask => PFunctor (Flip p) Hask Hask where - first f = liftFlip (second f) - -instance Bifunctor p Hask Hask Hask => Bifunctor (Flip p) Hask Hask Hask where - bimap f g = liftFlip (bimap g f) - -instance Braided Hask p => Braided Hask (Flip p) where - braid = liftFlip braid - -instance Symmetric Hask p => Symmetric Hask (Flip p) - -instance Bifunctor p Hask Hask Hask => Functor (Flip p a) where - fmap = bimap id - -instance HasIdentity Hask p i => HasIdentity Hask (Flip p) i where - -instance Associative Hask p => Coassociative Hask (Flip p) where - coassociate = Flip . second Flip . associate . first runFlip . runFlip - -- Flip p a (Flip p b c) >- runFlip -> - -- p (Flip p b c) a >- first runFlip -> - -- p (p c b) a >- associate -> - -- p c (p b a) >- second Flip -> - -- p c (Flip p a b) >- Flip -> - -- Flip p (Flip p a b) c - -instance Coassociative Hask p => Associative Hask (Flip p) where - associate = Flip . first Flip . coassociate . second runFlip . runFlip - -instance (Coassociative Hask p, Monoidal Hask p i) => Monoidal Hask (Flip p) i where - idl = idr . runFlip - idr = idl . runFlip - -instance (Associative Hask p, Comonoidal Hask p i) => Comonoidal Hask (Flip p) i where - coidl = Flip . coidr - coidr = Flip . coidl diff --git a/src/Control/Functor/Combinators/Join.hs b/src/Control/Functor/Combinators/Join.hs deleted file mode 100644 --- a/src/Control/Functor/Combinators/Join.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.Combinators.Join --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- ----------------------------------------------------------------------------- -module Control.Functor.Combinators.Join - ( Join(..) - ) where - -import Control.Functor -import Control.Category.Hask - -newtype Join p a = Join { runJoin :: p a a } - -instance Bifunctor p Hask Hask Hask => Functor (Join p) where - fmap f = Join . bimap f f . runJoin diff --git a/src/Control/Functor/Combinators/Lift.hs b/src/Control/Functor/Combinators/Lift.hs deleted file mode 100644 --- a/src/Control/Functor/Combinators/Lift.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# OPTIONS_GHC -cpp -fglasgow-exts -fallow-undecidable-instances #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Combinators.Lift --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (functional-dependencies) --- --- transform a pair of functors with a bifunctor deriving a new functor. --- this subsumes functor product and functor coproduct -------------------------------------------------------------------------------------------- - -module Control.Functor.Combinators.Lift - ( Lift(Lift,runLift) - , (:*:), runProductF - , (:+:), runCoproductF - , Ap, runAp, mkAp - ) where - -import Control.Applicative -import Control.Category.Hask -import Control.Functor -import Control.Functor.Contra -import Control.Functor.Exponential -import Control.Functor.Full -import Control.Functor.HigherOrder -import Control.Monad.Identity -import Control.Functor.Pointed -import Control.Arrow ((&&&),(|||)) - --- * Bifunctor functor transformer - --- type-level LiftA2 -newtype Lift p f g a = Lift { runLift :: p (f a) (g a) } -type Ap p = Lift p Identity - -runAp :: Bifunctor p Hask Hask Hask => Ap p f a -> p a (f a) -runAp = first runIdentity . runLift - -mkAp :: Bifunctor p Hask Hask Hask => p a (f a) -> Ap p f a -mkAp = Lift . first Identity - -instance (Bifunctor p Hask Hask Hask, Functor f ,Functor g) => Functor (Lift p f g) where - fmap f = Lift . bimap (fmap f) (fmap f) . runLift - -instance (Bifunctor p Hask Hask Hask, ContraFunctor f ,ContraFunctor g) => ContraFunctor (Lift p f g) where - contramap f = Lift . bimap (contramap f) (contramap f) . runLift - -instance (Bifunctor p Hask Hask Hask, ExpFunctor f ,ExpFunctor g) => ExpFunctor (Lift p f g) where - xmap f g = Lift . bimap (xmap f g) (xmap f g) . runLift - -instance (Bifunctor p Hask Hask Hask) => HFunctor (Ap p) where - ffmap f = Lift . bimap (fmap f) (fmap f) . runLift - hfmap f = Lift . second f . runLift - - -type (f :*: g) = Lift (,) f g - -runProductF :: (f :*: g) a -> (f a, g a) -runProductF = runLift - -instance (Pointed f, Pointed g) => Pointed (f :*: g) where - point = Lift . (point &&& point) - -instance (Applicative f, Applicative g) => Applicative (f :*: g) where - pure b = Lift (pure b, pure b) - Lift (f,g) <*> Lift (a,b) = Lift (f <*> a, g <*> b) - -instance (Faithful f, Faithful g) => Faithful (f :*: g) - -type (f :+: g) = Lift Either f g - -runCoproductF :: (f :+: g) a -> Either (f a) (g a) -runCoproductF = runLift - -instance (Copointed f, Copointed g) => Copointed (f :+: g) where - extract = (extract ||| extract) . runLift diff --git a/src/Control/Functor/Combinators/Of.hs b/src/Control/Functor/Combinators/Of.hs deleted file mode 100644 --- a/src/Control/Functor/Combinators/Of.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.Combinators.Of --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- ----------------------------------------------------------------------------- -module Control.Functor.Combinators.Of - ( Of(Of,runOf), liftOf - ) where - -import Prelude hiding ((.),id) -import Control.Category -import Control.Category.Hask -import Control.Category.Braided -import Control.Functor -import Control.Functor.Pointed --- import Control.Functor.Zip --- import Control.Functor.Zap - -newtype Of f p a b = Of { runOf :: f (p a b) } - -liftOf :: Functor f => (p a b -> p c d) -> Of f p a b -> Of f p c d -liftOf f = Of . fmap f . runOf - -instance (Functor f, PFunctor p Hask Hask) => PFunctor (f `Of` p) Hask Hask where - first f = liftOf (first f) -instance (Functor f, QFunctor p Hask Hask) => QFunctor (f `Of` p) Hask Hask where - second g = liftOf (second g) -instance (Functor f, Bifunctor p Hask Hask Hask) => Bifunctor (f `Of` p) Hask Hask Hask where - bimap f g = liftOf (bimap f g) - -instance (Functor f, Braided Hask p ) => Braided Hask (f `Of` p) where - braid = liftOf braid - -instance (Functor f, Symmetric Hask p) => Symmetric Hask (f `Of` p) - -instance (Functor f, Functor (p a)) => Functor (Of f p a) where - fmap f = Of . fmap (fmap f) . runOf - -instance (Pointed f, PPointed p) => PPointed (f `Of` p) where - preturn = Of . point . preturn - -instance (Copointed f, PCopointed p) => PCopointed (f `Of` p) where - pextract = pextract . extract . runOf - -instance (Pointed f, Pointed (p a)) => Pointed (Of f p a) where - point = Of . point . point - -instance (Copointed f, Copointed (p a)) => Copointed (Of f p a) where - extract = extract . extract . runOf - -{- -instance (Zip f, Bizip p) => Bizip (f `Of` p) where - bizipWith f g = Of . fzipWith (bizipWith f g) . runOf - -instance (Zip f, Zip (p a)) => Zip (Of f p a) where - fzipWith f = Of . fzipWith (fzipWith f) . runOf - -instance (Bizap p q, Zap f g) => Bizap (f `Of` p) (g `Of` q) where - bizapWith f g = Of . zapWith (bizapWith f g) . runOf --} diff --git a/src/Control/Functor/Composition.hs b/src/Control/Functor/Composition.hs deleted file mode 100644 --- a/src/Control/Functor/Composition.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# OPTIONS_GHC -cpp -fglasgow-exts #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Composition --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (class-associated types) --- --- Generalized functor composition. --- Since we have many reasons for which you might want to compose a functor, and many --- expected results. i.e. monads via adjunctions, monads via composition with a pointed --- endofunctor, etc. we have to make multiple composition operators. -------------------------------------------------------------------------------------------- - -module Control.Functor.Composition - ( CompF(..) - , Composition(..) - , associateComposition - , coassociateComposition - , (:.:) - , preTransform - , postTransform - , Comp - , (:++:) - , (:**:) - , liftComp - ) where - -import Control.Functor -import Control.Functor.Extras -import Control.Functor.Exponential -import Control.Functor.Full -import Control.Functor.HigherOrder -import Control.Category.Hask -import Control.Category.Braided - -class Composition o where - decompose :: (f `o` g) x -> f (g x) - compose :: f (g x) -> (f `o` g) x - --- | Basic functor composition -newtype CompF f g a = CompF { runCompF :: f (g a) } - -instance Composition CompF where - compose = CompF - decompose = runCompF - -instance Functor f => HFunctor (CompF f) where - ffmap = fmap - hfmap f = compose . fmap f . decompose - --- | An infix alias for functor composition -type (:.:) = CompF - --- common functor composition traits -instance (Functor f, Functor g) => Functor (CompF f g) where - fmap f = compose . fmap (fmap f) . decompose - -instance (ExpFunctor f, ExpFunctor g) => ExpFunctor (CompF f g) where - xmap f g = compose . xmap (xmap f g) (xmap g f) . decompose - -instance (Full f, Full g) => Full (CompF f g) where - premap f = premap . premap $ decompose . f . compose - -preTransform :: Composition o => (f :~> g) -> (f `o` k) :~> (g `o` k) -preTransform f x = compose (f (decompose x)) - -postTransform :: (Functor k, Composition o) => (f :~> g) -> (k `o` f) :~> (k `o` g) -postTransform f x = compose (fmap f (decompose x)) - --- | The only reason the compositions are all the same is for type inference. This can be liberalized. -associateComposition :: (Functor f, Composition o) => ((f `o` g) `o` h) :~> (f `o` (g `o` h)) -associateComposition = compose . fmap compose . decompose . decompose - -coassociateComposition :: (Functor f, Composition o) => (f `o` (g `o` h)) :~> ((f `o` g) `o` h) -coassociateComposition = compose . compose . fmap decompose . decompose - - --- | Bifunctor composition -newtype Comp p f g a b = Comp { runComp :: p (f a b) (g a b) } --- | Bifunctor coproduct -type (:++:) = Comp Either --- | Bifunctor product -type (:**:) = Comp (,) - -instance (Bifunctor p c d Hask, PFunctor f a c, PFunctor g a d) => PFunctor (Comp p f g) a Hask where - first f = Comp . bimap (first f) (first f) . runComp - -instance (Bifunctor p c d Hask, QFunctor f b c, QFunctor g b d) => QFunctor (Comp p f g) b Hask where - second g = Comp . bimap (second g) (second g) . runComp - -instance (Bifunctor p c d Hask, Bifunctor f a b c, Bifunctor g a b d) => Bifunctor (Comp p f g) a b Hask where - bimap f g = Comp . bimap (bimap f g) (bimap f g) . runComp - -liftComp :: Bifunctor p r s Hask => r (f a b) (f c d) -> s (g a b) (g c d) -> Comp p f g a b -> Comp p f g c d -liftComp f g = Comp . bimap f g . runComp - -instance (Bifunctor p Hask Hask Hask, Braided Hask f, Braided Hask g) => Braided Hask (Comp p f g) where - braid = liftComp braid braid - -instance (Bifunctor p Hask Hask Hask, Symmetric Hask f, Symmetric Hask g) => Symmetric Hask (Comp p f g) - -instance (Bifunctor p Hask Hask Hask, Bifunctor f Hask Hask Hask, Bifunctor g Hask Hask Hask) => Functor (Comp p f g a) where - fmap = bimap id diff --git a/src/Control/Functor/Cone.hs b/src/Control/Functor/Cone.hs deleted file mode 100644 --- a/src/Control/Functor/Cone.hs +++ /dev/null @@ -1,32 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.Cone --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism/existentials) --- ----------------------------------------------------------------------------- -module Control.Functor.Cone - ( Cone, Cocone(..) - ) where - -import Control.Monad.Reader -import Control.Functor.Limit - -type Cone n f = n -> forall a. f a - -newtype Cocone f n = Cocone { runCocone :: forall a. f a -> n } - -instance Functor (Cocone f) where - fmap f (Cocone g) = Cocone (f . g) - -instance Monad (Cocone f) where - return x = Cocone (\_ -> x) - Cocone r >>= f = Cocone (\e -> runCocone (f (r e)) e) - -instance MonadReader (Colimit f) (Cocone f) where - ask = Cocone Colimit - local f (Cocone r) = Cocone (\e -> case f (Colimit e) of Colimit e' -> r e') diff --git a/src/Control/Functor/Contra.hs b/src/Control/Functor/Contra.hs deleted file mode 100644 --- a/src/Control/Functor/Contra.hs +++ /dev/null @@ -1,29 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Contra --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------------- - -module Control.Functor.Contra - ( ContraFunctor(..) - , ContraF(..) - ) where - -import Control.Applicative - -class ContraFunctor f where - contramap :: (a -> b) -> f b -> f a - -newtype ContraF a b = ContraF { runContraF :: b -> a } - -instance ContraFunctor (ContraF a) where - contramap g (ContraF f) = ContraF (f . g) - -instance ContraFunctor (Const a) where - contramap _ (Const a) = Const a diff --git a/src/Control/Functor/Exponential.hs b/src/Control/Functor/Exponential.hs deleted file mode 100644 --- a/src/Control/Functor/Exponential.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Exponential --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (class-associated types) --- --- Exponential functors, see -------------------------------------------------------------------------------------------- - -module Control.Functor.Exponential - ( ExpFunctor(xmap) - ) where - -import Control.Applicative (Const(..)) - -class ExpFunctor f where - xmap :: (a -> b) -> (b -> a) -> f a -> f b - -instance ExpFunctor (Const a) where - xmap _ _ (Const a) = Const a diff --git a/src/Control/Functor/Extras.hs b/src/Control/Functor/Extras.hs deleted file mode 100644 --- a/src/Control/Functor/Extras.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.Extras --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- ----------------------------------------------------------------------------- -module Control.Functor.Extras where - -import Control.Monad - -infixr 0 :~>, :~~> -- to match ->'s fixity - -type Dist f g = forall a. f (g a) -> g (f a) - --- | A natural transformation between functors f and g. -type f :~> g = forall a. f a -> g a -type Natural f g = f :~> g - --- | A transformation natural in both sides of a bifunctor. -type f :~~> g = forall a b. f a b -> g a b - --- | Dinatural transformations -type Dinatural f g = forall a. f a a -> g a a - -class PostFold m f where - postFold :: f (m (f a)) -> m (f a) - -class PostUnfold w f where - postUnfold :: w (f a) -> f (w (f a)) - -class PreFold f m where - preFold :: f (m (f a)) -> f (m a) - -class PreUnfold f w where - preUnfold :: f (w a) -> f (w (f a)) - -class Distributes f g where - dist :: f (g a) -> g (f a) - -class Functor f => FunctorZero f where - fzero :: f a - --- monoid -class FunctorZero f => FunctorPlus f where - fplus :: f a -> f a -> f a - -class Functor f => FunctorSplit f where - fsplit :: f a -> (f a, f a) - -instance FunctorZero Maybe where - fzero = Nothing - -instance FunctorPlus Maybe where - fplus = mplus - -instance FunctorZero [] where - fzero = [] - -instance FunctorPlus [] where - fplus = (++) - diff --git a/src/Control/Functor/Fix.hs b/src/Control/Functor/Fix.hs deleted file mode 100644 --- a/src/Control/Functor/Fix.hs +++ /dev/null @@ -1,102 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.Fix --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Since in Hask, Mu = Nu, we don't bother to distinguish them here ----------------------------------------------------------------------------- -module Control.Functor.Fix - ( - -- * Functor fixpoint - FixF(InF,outF) - , outM, inW - , identityBialgebraF - -- * Bifunctor fixpoint - , Fix(InB,outB) - , identityBialgebraB - , paugment, pcoaugment - -- Final and initial dialgebras - -- , NuD(..) - -- , MuD(..) - ) where - -import Control.Monad -import Control.Comonad -import Control.Functor.Algebra -import Control.Functor.Limit -import Control.Monad.Parameterized -import Control.Comonad.Parameterized -import Control.Comonad -import Control.Category.Hask -import Control.Morphism.Hylo - -newtype FixF f = InF { outF :: f (FixF f) } - -outM :: (Functor f, Monad m) => GCoalgebra f m (FixF f) -outM = liftCoalgebra outF - -inW :: (Functor f, Comonad w) => GAlgebra f w (FixF f) -inW = liftAlgebra InF - -identityBialgebraF :: Bialgebra f f (FixF f) -identityBialgebraF = (InF,outF) - --- * Fixpoint of a bifunctor -newtype Fix s a = InB { outB :: s a (Fix s a) } - -instance Bifunctor s Hask Hask Hask => Functor (Fix s) where - fmap f = InB . bimap f (fmap f) . outB - -instance (Bifunctor f Hask Hask Hask, PCopointed f) => Copointed (Fix f) where - extract = pextract . outB - -instance (Bifunctor f Hask Hask Hask, PPointed f) => Pointed (Fix f) where - point = InB . preturn - -instance (Bifunctor f Hask Hask Hask, PComonad f) => Comonad (Fix f) where - extend k w = pcoaugment (\g -> bihylo InB id g w) k - -instance (Bifunctor f Hask Hask Hask, PMonad f) => Monad (Fix f) where - return = InB . preturn - m >>= k = paugment (\f -> bihylo f id outB m) k - -identityBialgebraB :: Bialgebra (f a) (f a) (Fix f a) -identityBialgebraB = (InB,outB) - -paugment :: PMonad f => (forall c. (f a c -> c) -> c) -> (a -> Fix f b) -> Fix f b -paugment g k = g (InB . pbind (outB . k)) - -pcoaugment :: PComonad f => ((Fix f a -> f b (Fix f a)) -> Fix f b) -> (Fix f a -> b) -> Fix f b -pcoaugment g k = g (pextend (k . InB) . outB) - -{- --- data NuF f = forall a. NuF (a -> f a) a --- data NuB f b = forall b. NuF (a -> f b a) a --- data NuDT f g a b = NuDT (f a -> g b) b --- type NuD f g = Coend (NuDT f g) -data NuD f g = forall a. NuD (f a -> g a) a -outD :: (Functor f, Functor g) => NuD f g -> Colimit f -> g (NuD f g) -outD (NuD f a) (Colim bs) = fmap (NuD f) (f (fmap (const a) bs)) - -outD :: (Functor f, Functor g) => f (NuD f g) -> g (NuD f g) - - -diana :: (f a -> g a) -> a -> NuD f g -diana = NuD - --- newtype MuF f g = MuF (forall a. (f a -> a) -> a) --- newtype MuDT f g a b = MuDT ((f b -> g a) -> b) --- type NuD f g = End (MuDT f g) -newtype MuD f g = MuD (forall a. (f a -> g a) -> a) -inD :: f (MuD f g) -> g (MuD f g) -inD -inD :: MuD f g -> Limit f -> g (MuD f g) - -dicata :: (f a -> g a) -> MuD f g -> a -dicata = MuD --} diff --git a/src/Control/Functor/Full.hs b/src/Control/Functor/Full.hs deleted file mode 100644 --- a/src/Control/Functor/Full.hs +++ /dev/null @@ -1,55 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Full --- Copyright : 2008 Edward Kmett --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (class-associated types) --- -------------------------------------------------------------------------------------------- - -module Control.Functor.Full where - -import Control.Monad.Identity - -{- | - A 'Full' 'Functor' @F : C -> D@ provides for every pair of objects @c@, @c'@ in @C@ - and every morphism @g : F c -> F c'l@ in @D@, a morphism @g' : c -> c'@ in @C@. In short - map has a right-inverse under composition. - -> fmap . premap = id --} - -class Functor f => Full f where - premap :: (f a -> f b) -> a -> b -instance Full Identity where - premap f = runIdentity . f . Identity - -{-# RULES - "fmap/premap" map . premap = id - #-} - -class Functor f => Faithful f -instance Faithful Identity - -{- | - -For every pair of objects @a@ and @b@ in @C@ a 'Full' 'Faithful' 'Functor' @F : C -> D@ maps every morphism -@f : a -> b@ onto a distinct morphism @f : T a -> T b@ (since it is faithful) and every morphism from -@g : T a -> T b@ can be obtained from some @f@. (It maps Hom-sets bijectively, or in short @fmap@ has both -a left and right inverse under composition. - -> unmap . fmap = id --} - -unmap :: (Full f, Faithful f) => (f a -> f b) -> a -> b -unmap = premap - -{-# RULES - "unmap/fmap" unmap . fmap = id - #-} - - - diff --git a/src/Control/Functor/HigherOrder.hs b/src/Control/Functor/HigherOrder.hs deleted file mode 100644 --- a/src/Control/Functor/HigherOrder.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.HigherOrder --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Neil Ghani and Particia Johann''s higher order functors from --- ----------------------------------------------------------------------------- -module Control.Functor.HigherOrder - ( HFunctor(..) - , HPointed(..) - , HCopointed(..) - , HAlgebra - , HCoalgebra - , FixH(..) - , LowerH(..) - ) where - -import Control.Functor -import Control.Functor.Pointed -import Control.Functor.Extras -import Control.Monad.Reader -import Control.Monad.State.Lazy -import Control.Monad.Writer.Lazy -import Control.Monad.List - -type HAlgebra f g = f g :~> g -type HCoalgebra f g = g :~> f g - -class HFunctor f where - ffmap :: Functor g => (a -> b) -> f g a -> f g b - hfmap :: (g :~> h) -> f g :~> f h - -newtype FixH f a = InH { outH :: f (FixH f) a } - -class HFunctor m => HPointed m where - hreturn :: Functor f => f a -> m f a - -class HFunctor w => HCopointed w where - hextract :: Functor f => w f a -> f a - -newtype LowerH - (h :: (* -> *) -> * -> *) - (f :: * -> *) - (a :: *) = LowerH { liftH :: h f a } - -instance (HFunctor h, Functor f) => Functor (LowerH h f) where - fmap f = LowerH . ffmap f . liftH - -instance (HPointed h, Pointed f) => Pointed (LowerH h f) where - point = LowerH . hreturn . point - -instance (HCopointed h, Copointed f) => Copointed (LowerH h f) where - extract = extract . hextract . liftH - -instance HFunctor (ReaderT e) where - ffmap f g = ReaderT (fmap f . runReaderT g) - hfmap f g = ReaderT (f . runReaderT g) - -instance HPointed (ReaderT e) where - hreturn = ReaderT . const - -instance HFunctor (StateT e) where - ffmap f (StateT g) = StateT (fmap (first f) . g) - hfmap f (StateT g) = StateT (f . g) - -instance HPointed (StateT e) where - hreturn m = StateT (\s -> fmap (\a -> (a,s)) m) - -instance HFunctor (WriterT e) where - ffmap f = WriterT . fmap (first f) . runWriterT - hfmap f = WriterT . f . runWriterT - -instance Monoid e => HPointed (WriterT e) where - hreturn = WriterT . fmap (\a -> (a,mempty)) - -instance HFunctor ListT where - ffmap f = ListT . fmap (fmap f) . runListT - hfmap f = ListT . f . runListT - -instance HPointed ListT where - hreturn = ListT . fmap return - -{-# RULES -"hextract/hreturn" hextract . hreturn = id - #-} diff --git a/src/Control/Functor/HigherOrder/Composition.hs b/src/Control/Functor/HigherOrder/Composition.hs deleted file mode 100644 --- a/src/Control/Functor/HigherOrder/Composition.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# OPTIONS_GHC -cpp -fglasgow-exts #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.HigherOrder.Composition --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (kind annotations, rank-2 types) --- --- Composition of higher order functors -------------------------------------------------------------------------------------------- - -module Control.Functor.HigherOrder.Composition - ( CompH(..) - , HComposition(..) - , hassociateComposition - , hcoassociateComposition - ) where - -import Control.Functor.HigherOrder - -class HComposition - (o :: ((* -> *) -> * -> *) -> - ((* -> *) -> * -> *) -> - ((* -> *) -> * -> *)) where - hcompose :: f (g h) a -> (f `o` g) h a - hdecompose :: (f `o` g) h a -> f (g h) a - -newtype CompH - (f :: ((* -> *) -> * -> *)) - (g :: ((* -> *) -> * -> *)) - (a :: (* -> *)) (b :: *) = CompH { runCompH :: f (g a) b } - -instance HComposition CompH where - hcompose = CompH - hdecompose = runCompH - -instance (HFunctor f, HFunctor g) => HFunctor (CompH f g) where - hfmap f = hcompose . hfmap (hfmap f) . hdecompose - ffmap f = hcompose . hfmap liftH . ffmap f . hfmap LowerH . hdecompose - -instance (HFunctor f, HFunctor g, Functor h) => Functor (CompH f g h) where - fmap = ffmap - -hassociateComposition :: (HFunctor f, HComposition o) => ((f `o` g) `o` h) a b -> (f `o` (g `o` h)) a b -hassociateComposition = hcompose . hfmap hcompose . hdecompose . hdecompose - -hcoassociateComposition :: (HFunctor f, HComposition o) => (f `o` (g `o` h)) a b -> ((f `o` g) `o` h) a b -hcoassociateComposition = hcompose . hcompose . hfmap hdecompose . hdecompose diff --git a/src/Control/Functor/Indexed.hs b/src/Control/Functor/Indexed.hs deleted file mode 100644 --- a/src/Control/Functor/Indexed.hs +++ /dev/null @@ -1,33 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.Indexed --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- ----------------------------------------------------------------------------- -module Control.Functor.Indexed - ( IxFunctor(..) - , IxCopointed(..) - , IxPointed(..) - , IxApplicative(..) - ) where - -class IxFunctor f where - imap :: (a -> b) -> f j k a -> f j k b - -class IxPointed m => IxApplicative m where - iap :: m i j (a -> b) -> m j k a -> m i k b - -class IxFunctor m => IxPointed m where - ireturn :: a -> m i i a - -class IxFunctor w => IxCopointed w where - iextract :: w i i a -> a - -{-# RULES -"iextract/ireturn" iextract . ireturn = id - #-} diff --git a/src/Control/Functor/Internal/Adjunction.hs b/src/Control/Functor/Internal/Adjunction.hs deleted file mode 100644 --- a/src/Control/Functor/Internal/Adjunction.hs +++ /dev/null @@ -1,240 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Internal.Adjunction --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (functional-dependencies) --- -------------------------------------------------------------------------------------------- - -module Control.Functor.Internal.Adjunction - ( - -- * Adjunction - Adjunction (unit, counit, leftAdjunct, rightAdjunct) - , ACompF(ACompF) - , repAdjunction, unrepAdjunction - -- * Representability - , Representable, rep, unrep - , Corepresentable, corep, uncorep - , Both(..), EitherF(..) - -- * Zapping - , Zap(..), (>$<) - , Bizap(..), (>>$<<) - ) where - -import Control.Comonad.Reader -import Control.Comonad.Context -import Control.Functor.Combinators.Biff -import Control.Functor.Contra -import Control.Functor.Composition -import Control.Functor.Exponential -import Control.Functor.Full -import Control.Functor.Strong -import Control.Functor.HigherOrder -import Control.Applicative -import Control.Monad.Either () -import Control.Monad.Identity -import Control.Monad.Reader -import Control.Monad.State - --- | An 'Adjunction' formed by the 'Functor' f and 'Functor' g. - --- Minimal definition: - --- 1. @leftAdjunct@ and @rightAdjunct@ - --- 2. @unit@ and @counit@ - --- The following ambiguous instances prevent the requirement that (Zap f g, Zap g f) be --- a prerequisite for Adjunction: - --- instance (Adjunction f1 g1, Adjunction f2 g2) => Zap (CompF g1 g2) (CompF f2 f1) where ... --- instance (Adjunction f1 g1, Adjunction f2 g2) => Zap (CompF f2 f1) (CompF g1 g2) where ... --- instance (Zap f g, Zap f' g') => Zap (CompF f f') (Comp g g') --- zapWith f a b = zapWith (zapWith f) (decompose a) (decompose b) --- instance (Zap f g, Zap g f, Representable g (f ()), Functor f) => Adjunction f g | f -> g, g -> f where -class (Representable g (f ()), Functor f) => Adjunction f g | f -> g, g -> f where - unit :: a -> g (f a) - counit :: f (g a) -> a - leftAdjunct :: (f a -> b) -> a -> g b - rightAdjunct :: (a -> g b) -> f a -> b - - unit = leftAdjunct id - counit = rightAdjunct id - leftAdjunct f = fmap f . unit - rightAdjunct f = counit . fmap f - -zapWithGF :: Adjunction g f => (a -> b -> c) -> f a -> g b -> c -zapWithGF f a b = uncurry (flip f) . counit . fmap (uncurry (flip strength)) $ strength a b - --- more appropriate to use 'data Empty' or a (co)limit to ground out f ? -repAdjunction :: Adjunction f g => (f () -> a) -> g a -repAdjunction f = leftAdjunct f () - -unrepAdjunction :: Adjunction f g => g a -> (f () -> a) -unrepAdjunction = rightAdjunct . const - --- TODO: widen? -instance (Adjunction f1 g1, Adjunction f2 g2) => Representable (CompF g1 g2) (CompF f2 f1 ()) where - rep = repAdjunction - unrep = unrepAdjunction - -instance (Adjunction f1 g1, Adjunction f2 g2) => Adjunction (CompF f2 f1) (CompF g1 g2) where - counit = counit . fmap (counit . fmap decompose) . decompose - unit = compose . fmap (fmap compose . unit) . unit - --- | Adjunction-oriented composition, yields monads and comonads from adjunctions -newtype ACompF f g a = ACompF (CompF f g a) deriving (Functor, ExpFunctor, Full, Composition, HFunctor) - -instance Adjunction f g => Pointed (ACompF g f) where - point = compose . unit - -instance Adjunction f g => Copointed (ACompF f g) where - extract = counit . decompose - -instance Adjunction f g => Applicative (ACompF g f) where - pure = point - (<*>) = ap - -instance Adjunction f g => Monad (ACompF g f) where - return = point - m >>= f = compose . fmap (rightAdjunct (decompose . f)) $ decompose m - -instance Adjunction f g => Comonad (ACompF f g) where - extend f = compose . fmap (leftAdjunct (f . compose)) . decompose - -instance Zap ((->)e) ((,)e) where - zapWith = zapWithGF - -instance Representable ((->)e) (e,()) where - rep = repAdjunction - unrep = unrepAdjunction - -instance Representable ((->)e) e where - rep = id - unrep = id - -instance Adjunction ((,)e) ((->)e) where - leftAdjunct f a e = f (e,a) - rightAdjunct f ~(e,a) = f a e - unit a e = (e,a) - counit (x,f) = f x - -instance Representable Identity (Identity ()) where - rep = repAdjunction - unrep = unrepAdjunction - -instance Adjunction Identity Identity where - unit = Identity . Identity - counit = runIdentity . runIdentity - -instance Zap (Reader e) (Coreader e) where - zapWith = zapWithGF - -instance Representable (Reader e) (Coreader e ()) where - rep = repAdjunction - unrep = unrepAdjunction - -instance Adjunction (Coreader e) (Reader e) where - unit a = Reader (\e -> Coreader e a) - counit (Coreader x f) = runReader f x - -instance ComonadContext e ((,)e `ACompF` (->)e) where - getC = fst . decompose - modifyC f = uncurry (flip id . f) . decompose - -instance MonadState e ((->)e `ACompF` (,)e) where - get = compose $ \s -> (s,s) - put s = compose $ const (s,()) -class ContraFunctor f => Corepresentable f x where - corep :: (a -> x) -> f a - uncorep :: f a -> (a -> x) - -class Functor f => Representable f x where - rep :: (x -> a) -> f a - unrep :: f a -> (x -> a) - -{-# RULES -"rep/unrep" rep . unrep = id -"unrep/rep" unrep . rep = id -"corep/uncorep" corep . uncorep = id -"uncorep/corep" unrep . corep = id - #-} - ---repAdjunction :: Adjunction f g => (f () -> a) -> g a ---repAdjunction f = leftAdjunct f () - ---unrepAdjunction :: Adjunction f g => g a -> (f () -> a) ---unrepAdjunction = rightAdjunction . const - -data EitherF a b c = EitherF (a -> c) (b -> c) - -instance Functor (EitherF a b) where - fmap f (EitherF l r) = EitherF (f . l) (f . r) - -instance Representable (EitherF a b) (Either a b) where - rep f = EitherF (f . Left) (f . Right) - unrep (EitherF l r) = either l r - -instance Representable Identity () where - rep f = Identity (f ()) - unrep (Identity a) = const a - -data Both a = Both a a - -instance Functor Both where - fmap f (Both a b) = Both (f a) (f b) - -instance Representable Both Bool where - rep f = Both (f False) (f True) - unrep (Both x _) False = x - unrep (Both _ y) True = y - --- instance Adjunction f g => Representable g (f ()) where --- instance Representable (Cofree Identity) (Free Identity ()) where - - -{- | Minimum definition: zapWith -} - --- zapWith :: Adjunction f g => (a -> b -> c) -> f a -> g b -> c --- zapWith f a b = uncurry (flip f) . counit . fmap (uncurry (flip strength)) $ strength a b - --- zap :: Adjunction f g => f (a -> b) -> g a -> b --- zap = zapWith id - -class Zap f g | f -> g, g -> f where - zapWith :: (a -> b -> c) -> f a -> g b -> c - zap :: f (a -> b) -> g a -> b - zap = zapWith id - -(>$<) :: Zap f g => f (a -> b) -> g a -> b -(>$<) = zap - -instance Zap Identity Identity where - zapWith f (Identity a) (Identity b) = f a b - -{- | Minimum definition: bizapWith -} - -class Bizap p q | p -> q, q -> p where - bizapWith :: (a -> c -> e) -> (b -> d -> e) -> p a b -> q c d -> e - - bizap :: p (a -> c) (b -> c) -> q a b -> c - bizap = bizapWith id id - -(>>$<<) :: Bizap p q => p (a -> c) (b -> c) -> q a b -> c -(>>$<<) = bizap - -instance Bizap (,) Either where - bizapWith l _ (f,_) (Left a) = l f a - bizapWith _ r (_,g) (Right b) = r g b - -instance Bizap Either (,) where - bizapWith l _ (Left f) (a,_) = l f a - bizapWith _ r (Right g) (_,b) = r g b - -instance (Bizap p q, Zap f g, Zap i j) => Bizap (Biff p f i) (Biff q g j) where - bizapWith l r fs as = bizapWith (zapWith l) (zapWith r) (runBiff fs) (runBiff as) diff --git a/src/Control/Functor/Internal/Ideal.hs b/src/Control/Functor/Internal/Ideal.hs deleted file mode 100644 --- a/src/Control/Functor/Internal/Ideal.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.Internal.Ideal --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- ----------------------------------------------------------------------------- -module Control.Functor.Internal.Ideal - ( - -- * Ideal Monads - MonadIdeal(..) - , Ideal - , ideal - , destroyIdeal - -- * Coideal Comonads - , ComonadCoideal(..) - , Coideal - , coideal - , buildCoideal - -- * Mutual recursion for (co)ideal (co)monad (co)products - , Mutual(..) - -- * Coideal Comonad Product - , (:*) - -- * Ideal Monad Coproduct - , (:+) - ) where - -import Prelude hiding (fst, snd) -import Control.Category.Cartesian -import Control.Category.Hask -import Control.Comonad -import Control.Functor -import Control.Functor.Algebra -import Control.Functor.Combinators.Lift -import Control.Monad.Identity - -type Ideal = Ap Either --- type Ideal f = Join (PFree f) -type Coideal = Ap (,) --- type Coideal f = Join (PCofree f) - -ideal :: Either a (f a) -> Ideal f a -ideal = mkAp - -coideal :: (a, f a) -> Coideal f a -coideal = mkAp - -runIdeal :: Ideal f a -> Either a (f a) -runIdeal = runAp - -runCoideal :: Coideal f a -> (a, f a) -runCoideal = runAp - -class Functor m => MonadIdeal m where - idealize :: m (Either a (m a)) -> m a - -instance Functor f => Pointed (Ideal f) where - point = Lift . Left . Identity - --- this only really needs 'ap' but there is no 'unpointed/pre- applicative' -{- -instance Applicative f => Applicative (Ideal f) where - pure = point - Ideal (Left f) <*> Ideal (Left a) = Ideal $ Left (f a) - Ideal (Left f) <*> Ideal (Right bs) = Ideal $ Right (fmap f bs) - Ideal (Right fs) <*> Ideal (Left a) = Ideal $ Right (fmap ($a) fs) - Ideal (Right fs) <*> Ideal (Right bs) = Ideal $ Right (fs <*> bs) --} - -instance MonadIdeal m => Monad (Ideal m) where - return = point - m >>= f = ideal . (id ||| Right . idealize) . runIdeal $ fmap (runIdeal . f) m - -destroyIdeal :: Algebra m a -> Ideal m a -> a -destroyIdeal phi = (id ||| phi) . runIdeal - - --- instance MonadIdeal (Fst k) where --- idealize = mkFst . runFst - -class Functor w => ComonadCoideal w where - coidealize :: w a -> w (a, w a) - -instance Functor f => Copointed (Coideal f) where - extract = runIdentity . fst . runLift - -instance ComonadCoideal w => Comonad (Coideal w) where - extend f = fmap (f . coideal) . coideal . (id &&& coidealize . snd) . runCoideal - -buildCoideal :: Coalgebra m a -> a -> Coideal m a -buildCoideal phi = coideal . (id &&& phi) - --- instance ComonadCoideal (Fst k) where --- coidealize = mkFst . runFst - --- * (Co)ideal (Co)products - -newtype Mutual p m n a = Mutual { runMutual :: m (p a (Mutual p n m a)) } -type Mutual' p m n = Lift p (Mutual p m n) (Mutual p n m) -type (m :+ n) = Mutual' Either m n -type (m :* n) = Mutual' (,) m n - -instance (Bifunctor p Hask Hask Hask, Functor m, Functor n) => Functor (Mutual p m n) where - fmap f = Mutual . fmap (bimap f (fmap f)) . runMutual - -{- -instance (MonadIdeal m, MonadIdeal n) => MonadIdeal (m :+ n) where - idealize = undefined --} - -{- -instance (ComonadCoideal w, ComonadCoideal v) => ComonadCoideal (w :* v) where - coidealize = undefined --} diff --git a/src/Control/Functor/KanExtension.hs b/src/Control/Functor/KanExtension.hs deleted file mode 100644 --- a/src/Control/Functor/KanExtension.hs +++ /dev/null @@ -1,133 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.KanExtension --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Left and right Kan extensions, expressed as higher order functors --- --- See --- and --- for motivation. --- --- NB: @Yoneda@, @CoYoneda@, @Density@, @Codensity@ have been factored --- out into separate modules. ----------------------------------------------------------------------------- -module Control.Functor.KanExtension - ( - -- * Right Kan Extensions - Ran(..) - , toRan, fromRan - , adjointToRan, ranToAdjoint - , ranToComposedAdjoint, composedAdjointToRan - , composeRan, decomposeRan - -- * Left Kan Extensions - , Lan(..) - , toLan, fromLan - , adjointToLan, lanToAdjoint - , composeLan, decomposeLan - , lanToComposedAdjoint, composedAdjointToLan - ) where - -import Prelude hiding (abs) -import Control.Functor.Composition -import Control.Functor.Extras -import Control.Functor.Pointed () -import Control.Functor.HigherOrder -import Control.Functor.Adjunction -import Control.Monad.Identity - - --- | The right Kan Extension of h along g. --- An alternative definition in terms of Ends. --- --- @newtype RanT g h a b b' { (a -> g b) -> h b' }@ --- --- @type Ran g h a = End (RanT g h a)@ -newtype Ran g h a = Ran { runRan :: forall b. (a -> g b) -> h b } - --- | Nat(k `o` g, h) is isomorphic to Nat(k, Ran g h) (forwards) -toRan :: (Composition o, Functor k) => (k `o` g :~> h) -> k :~> Ran g h -toRan s t = Ran (s . compose . flip fmap t) - --- | Nat(k `o` g, h) is isomorphic to Nat(k, Ran g h) (backwards) -fromRan :: Composition o => (k :~> Ran g h) -> (k `o` g) :~> h -fromRan s = flip runRan id . s . decompose - -instance HFunctor (Ran g) where - hfmap f (Ran m) = Ran (f . m) - ffmap f m = Ran (\k -> runRan m (k . f)) - -instance Functor (Ran g h) where - fmap f m = Ran (\k -> runRan m (k . f)) - --- | The natural isomorphism from @Ran f (Ran g h)@ to @Ran (f `o` g) h@ (forwards) -composeRan :: Composition o => Ran f (Ran g h) :~> Ran (f `o` g) h -composeRan r = Ran (\f -> runRan (runRan r (decompose . f)) id) - --- | The natural isomorphism from @Ran f (Ran g h)@ to @Ran (f `o` g) h@ (backwards) -decomposeRan :: (Functor f, Composition o) => Ran (f `o` g) h :~> Ran f (Ran g h) -decomposeRan r = Ran (\f -> Ran (\g -> runRan r (compose . fmap g . f))) - --- | @f -| g@ iff @Ran g Identity@ exists (forward) -adjointToRan :: Adjunction f g => f :~> Ran g Identity -adjointToRan f = Ran (\a -> Identity $ rightAdjunct a f) - --- | @f -| g@ iff @Ran g Identity@ exists (backwards) -ranToAdjoint :: Adjunction f g => Ran g Identity :~> f -ranToAdjoint r = runIdentity (runRan r unit) - -ranToComposedAdjoint :: (Composition o, Adjunction f g) => Ran g h :~> (h `o` f) -ranToComposedAdjoint r = compose (runRan r unit) - -composedAdjointToRan :: (Functor h, Composition o, Adjunction f g) => (h `o` f) :~> Ran g h -composedAdjointToRan f = Ran (\a -> fmap (rightAdjunct a) (decompose f)) - --- | Left Kan Extension --- --- @newtype LanT g h a b b' { (g b -> a, h b') }@ --- --- @type Lan g h a = Coend (LanT g h a)@ -data Lan g h a = forall b. Lan (g b -> a) (h b) - --- | @Nat(h, f.g)@ is isomorphic to @Nat (Lan g h, f)@ (forwards) -toLan :: (Composition o, Functor f) => (h :~> (f `o` g)) -> Lan g h :~> f -toLan s (Lan f v) = fmap f . decompose $ s v - --- | @Nat(h, f.g)@ is isomorphic to @Nat (Lan g h, f)@ (backwards) -fromLan :: Composition o => (Lan g h :~> f) -> h :~> (f `o` g) -fromLan s = compose . s . Lan id - -instance Functor g => HFunctor (Lan g) where - ffmap f (Lan g h) = Lan (f . g) h - hfmap f (Lan g h) = Lan g (f h) - -instance Functor (Lan f g) where - fmap f (Lan g h) = Lan (f . g) h - --- | f -| g iff Lan f Identity is inhabited (forwards) -adjointToLan :: Adjunction f g => g :~> Lan f Identity -adjointToLan = Lan counit . Identity - --- | f -| g iff Lan f Identity is inhabited (backwards) -lanToAdjoint :: Adjunction f g => Lan f Identity :~> g -lanToAdjoint (Lan f v) = leftAdjunct f (runIdentity v) - -lanToComposedAdjoint :: (Functor h, Composition o, Adjunction f g) => Lan f h :~> (h `o` g) -lanToComposedAdjoint (Lan f v) = compose (fmap (leftAdjunct f) v) - -composedAdjointToLan :: (Composition o, Adjunction f g) => (h `o` g) :~> Lan f h -composedAdjointToLan = Lan counit . decompose - --- | the natural isomorphism from @Lan f (Lan g h)@ to @Lan (f `o` g) h@ (forwards) -composeLan :: (Functor f, Composition o) => Lan f (Lan g h) :~> Lan (f `o` g) h -composeLan (Lan f (Lan g h)) = Lan (f . fmap g . decompose) h - --- | the natural isomorphism from @Lan f (Lan g h)@ to @Lan (f `o` g) h@ (backwards) -decomposeLan :: Composition o => Lan (f `o` g) h :~> Lan f (Lan g h) -decomposeLan (Lan f h) = Lan (f . compose) (Lan id h) - diff --git a/src/Control/Functor/KanExtension/Interpreter.hs b/src/Control/Functor/KanExtension/Interpreter.hs deleted file mode 100644 --- a/src/Control/Functor/KanExtension/Interpreter.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.KanExtension.Interpreter --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Ghani and Johann's Interp/InterpT types from ''Initial Algebra Semantics is Enough!'' --- and its dual. ----------------------------------------------------------------------------- -module Control.Functor.KanExtension.Interpreter - ( Interpreter, InterpreterT - , interpreterAlgebra, algebraInterpreter - , Cointerpreter, CointerpreterT - , cointerpreterCoalgebra, coalgebraCointerpreter - ) where - -import Control.Functor.Extras -import Control.Functor.HigherOrder -import Control.Functor.KanExtension - -type Interpreter y g h = y :~> Ran g h -type InterpreterT f g h = forall y. Functor y => Interpreter y g h -> Interpreter (f y) g h - -interpreterAlgebra :: InterpreterT f g h -> HAlgebra f (Ran g h) -interpreterAlgebra i = i id - -algebraInterpreter :: HFunctor f => HAlgebra f (Ran g h) -> InterpreterT f g h -algebraInterpreter h i = h . hfmap i - -type Cointerpreter y g h = Lan g h :~> y -type CointerpreterT f g h = forall y. Functor y => Cointerpreter y g h -> Cointerpreter (f y) g h - -cointerpreterCoalgebra :: CointerpreterT f g h -> HCoalgebra f (Lan g h) -cointerpreterCoalgebra i = i id - -coalgebraCointerpreter :: HFunctor f => HCoalgebra f (Lan g h) -> CointerpreterT f g h -coalgebraCointerpreter h i = hfmap i . h diff --git a/src/Control/Functor/Lambek.hs b/src/Control/Functor/Lambek.hs deleted file mode 100644 --- a/src/Control/Functor/Lambek.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.Lambek --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- ----------------------------------------------------------------------------- -module Control.Functor.Lambek - ( - -- * Lambek's Lemma - lambek - , hlambek - , colambek - , hcolambek - ) where - -import Control.Functor.Algebra -import Control.Functor.Fix -import Control.Functor.HigherOrder -import Control.Morphism.Cata -import Control.Morphism.Ana - --- Lambek's lemma -lambek :: Functor f => Algebra f (FixF f) -> Coalgebra f (FixF f) -lambek inF = cata (fmap inF) - -hlambek :: HFunctor f => HAlgebra f (FixH f) -> HCoalgebra f (FixH f) -hlambek inH = hcata (hfmap inH) - -colambek :: Functor f => Coalgebra f (FixF f) -> Algebra f (FixF f) -colambek out = ana (fmap out) - -hcolambek :: HFunctor f => HCoalgebra f (FixH f) -> HAlgebra f (FixH f) -hcolambek out = hana (hfmap out) - diff --git a/src/Control/Functor/Limit.hs b/src/Control/Functor/Limit.hs deleted file mode 100644 --- a/src/Control/Functor/Limit.hs +++ /dev/null @@ -1,45 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.Limit --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism/existentials) --- ----------------------------------------------------------------------------- -module Control.Functor.Limit - ( Limit, HasLimit(limit) - , Colimit(..) - , liftLimit, liftColimit - ) where - -import Prelude hiding (abs) -import Control.Functor.Extras -import Data.Monoid - --- | @type Limit = Ran (Const Void)@ --- Limit { runLimit :: forall a. f a } -type Limit f = forall a. f a - -class HasLimit f where - limit :: f a - -instance HasLimit Maybe where - limit = Nothing - -instance HasLimit [] where - limit = [] - -instance Monoid a => HasLimit (Either a) where - limit = (Left mempty) - -liftLimit :: (f :~> g) -> Limit f -> Limit g -liftLimit f a = f a - --- | @type Colimit = Lan (Const Void)@ -data Colimit f = forall b. Colimit (f b) - -liftColimit :: (f :~> g) -> Colimit f -> Colimit g -liftColimit f (Colimit a) = Colimit (f a) diff --git a/src/Control/Functor/Pointed.hs b/src/Control/Functor/Pointed.hs deleted file mode 100644 --- a/src/Control/Functor/Pointed.hs +++ /dev/null @@ -1,69 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Pointed --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------------- - -module Control.Functor.Pointed - ( Pointed(..) - , Copointed(..) - , PPointed(..) - , PCopointed(..) - ) where - -import Control.Category -import Control.Category.Hask -import Control.Functor --- import Control.Functor.Algebra -import Control.Monad.Identity -import Prelude hiding ((.),id) - --- return -class Functor f => Pointed f where - point :: a -> f a -- Coalgebra f a - -class Functor f => Copointed f where - extract :: f a -> a -- Algebra f a - -{-# RULES -"extract/point" extract . point = id - #-} - -instance Pointed Identity where - point = Identity - -instance Pointed Maybe where - point = Just - -instance Pointed (Either a) where - point = Right - -instance Pointed [] where - point a = [a] - -instance Copointed Identity where - extract = runIdentity - -instance Copointed ((,)e) where - extract = snd - -class PFunctor f Hask Hask => PPointed f where - preturn :: a -> f a c - -- preturn :: k a (f a c) - -class PFunctor f Hask Hask => PCopointed f where - pextract :: f a c -> a - -- pextract :: k (f a c) a - -{-# RULES -"bimap id g . preturn" forall g. bimap id g . preturn = preturn -"pextract . bimap id g" forall g. pextract . bimap id g = pextract -"preturn/pextract" preturn . pextract = id -"pextract/preturn" pextract. preturn = id - #-} diff --git a/src/Control/Functor/Pointed/Composition.hs b/src/Control/Functor/Pointed/Composition.hs deleted file mode 100644 --- a/src/Control/Functor/Pointed/Composition.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Pointed.Composition --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (functional-dependencies) --- --- TODO: finish the monad instances -------------------------------------------------------------------------------------------- - -module Control.Functor.Pointed.Composition - ( PointedCompF(..) - , PostCompF(..) - , PreCompF(..) - , DistCompF(..) - ) where - -import Control.Functor.Extras -import Control.Functor.Composition -import Control.Comonad -import Control.Monad -import Control.Functor.Exponential -import Control.Functor.Full - -newtype PointedCompF f g a = PointedCompF (CompF f g a) deriving (Functor, ExpFunctor, Full, Composition) - -instance (Pointed f, Pointed g) => Pointed (PointedCompF f g) where - point = compose . point . point - -instance (Copointed f, Copointed g) => Copointed (PointedCompF f g) where - extract = extract . extract . decompose - -newtype PostCompF mw f a = PostCompF (PointedCompF mw f a) deriving (Functor, ExpFunctor, Full, Composition, Pointed, Copointed) - -instance (Comonad w, Copointed f, PostUnfold w f) => Comonad (PostCompF w f) where - duplicate = compose . liftW (fmap compose . postUnfold) . duplicate . decompose - -{- -instance (Monad m, Pointed f, PostFold m f) => Monad (PostCompF m f) where - return = compose . return . point - m >>= k = undefined where - postJoin :: (Monad m, PostFold m f) => m (f (m (f a))) -> m (f a) - postJoin = join . liftM postFold --} - - -newtype PreCompF f mw a = PreCompF (PointedCompF f mw a) deriving (Functor, ExpFunctor, Full, Composition, Pointed, Copointed) - -instance (Copointed f, Comonad w, PreUnfold f w) => Comonad (PreCompF f w) where - duplicate = compose . fmap (liftW compose) . preUnfold . fmap (duplicate) . decompose - -{- -instance (Pointed f, Monad m, PreFold f m) => Monad (PreCompF f m) where - return = compose . point . return - m >>= k = undefined where - preJoin :: (Monad m, Functor f, PreFold f m) => f (m (f (m a))) -> f (m a) - preJoin = fmap join . preFold --} - - -newtype DistCompF f g a = DistCompF (PointedCompF f g a) deriving (Functor, ExpFunctor, Full, Composition, Pointed, Copointed) - -instance (Comonad f, Comonad g, Distributes f g) => Comonad (DistCompF f g) where - duplicate = compose . fmap (fmap compose . dist) . duplicate . fmap duplicate . decompose - -{- -instance (Monad m, Monad n, Distributes m n) => Monad (DistCompF m n) where - return = compose . return . return - m >>= k = undefined --} diff --git a/src/Control/Functor/Representable.hs b/src/Control/Functor/Representable.hs deleted file mode 100644 --- a/src/Control/Functor/Representable.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Representable --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (class-associated types) --- -------------------------------------------------------------------------------------------- - -module Control.Functor.Representable - ( Representable, rep, unrep - , Corepresentable, corep, uncorep - , Both(..), EitherF(..) - ) where - -import Control.Functor.Internal.Adjunction diff --git a/src/Control/Functor/Strong.hs b/src/Control/Functor/Strong.hs deleted file mode 100644 --- a/src/Control/Functor/Strong.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Strong --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (functional-dependencies) --- -------------------------------------------------------------------------------------------- - -module Control.Functor.Strong where - -import Prelude hiding (sequence,Either) -import Data.Traversable -import Control.Monad.Either (Either(..)) - -strength :: Functor f => a -> f b -> f (a,b) -strength = fmap . (,) - -costrength :: Traversable f => f (Either a b) -> Either a (f b) -costrength = Data.Traversable.sequence diff --git a/src/Control/Functor/Yoneda.hs b/src/Control/Functor/Yoneda.hs deleted file mode 100644 --- a/src/Control/Functor/Yoneda.hs +++ /dev/null @@ -1,227 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Yoneda --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- --- The Yoneda lemma can be realized as the Kan extension along Identity --- However, having this special instance allows us to define Yoneda f as a monad, --- comonad, etc. based on whatever properties the base functor has, without --- limiting ourselves to what Ran f f can manage. --- --- Performance wise, Yoneda may make your monad more efficient at handling a bunch of --- fmaps, while CoYoneda may do the same for a comonad assuming you require a greater than --- linear amount of time to fmap over your structure. You can apply each in either role --- but the asymptotics will probably not be in your favor. --- -------------------------------------------------------------------------------------------- - -module Control.Functor.Yoneda - ( Yoneda(Yoneda,runYoneda), ranToYoneda, yonedaToRan, lowerYoneda - , CoYoneda(CoYoneda), lanToCoYoneda, coYonedaToLan, liftCoYoneda - ) where - -import Control.Applicative -import Control.Comonad.HigherOrder -import Control.Comonad.Cofree -import Control.Comonad.Context -import Control.Comonad.Reader -import Control.Comonad.Trans -import Control.Functor.Extras -import Control.Functor.KanExtension -import Control.Functor.Pointed -import Control.Functor.HigherOrder -import Control.Monad.Identity -import Control.Monad.HigherOrder -import Control.Monad.Free -import Control.Monad.Trans -import Control.Monad.Reader.Class -import Control.Monad.State.Class -import Control.Monad.Writer.Class - --- Yoneda ~ Ran Identity -newtype Yoneda f a = Yoneda { runYoneda :: forall b. ((a -> b) -> f b) } - -ranToYoneda :: Ran Identity f :~> Yoneda f -ranToYoneda r = Yoneda (\f -> runRan r (Identity . f)) - -yonedaToRan :: Yoneda f :~> Ran Identity f -yonedaToRan y = Ran (\f -> runYoneda y (runIdentity . f)) - -lowerYoneda :: Yoneda f :~> f -lowerYoneda m = runYoneda m id - -instance Functor (Yoneda f) where - fmap f m = Yoneda (\k -> runYoneda m (k . f)) - -instance Pointed f => Pointed (Yoneda f) where - point a = Yoneda (\f -> point (f a)) - -instance Applicative f => Applicative (Yoneda f) where - pure a = Yoneda (\f -> pure (f a)) - m <*> n = Yoneda (\f -> runYoneda m (f .) <*> runYoneda n id) - -instance Monad f => Monad (Yoneda f) where - return a = Yoneda (\f -> return (f a)) - m >>= k = Yoneda (\f -> runYoneda m id >>= \a -> runYoneda (k a) f) - -instance HFunctor Yoneda where - ffmap = fmap - hfmap f y = Yoneda (f . runYoneda y) - --- f a -> Yoneda f a -instance HPointed Yoneda where - hreturn a = Yoneda (\f -> fmap f a) - --- exists because Monad doesn't require Functor! -instance MonadTrans Yoneda where - lift a = Yoneda (\f -> liftM f a) - -instance ComonadTrans Yoneda where - colift = hreturn - --- Yoneda f a -> f a -instance HCopointed Yoneda where - hextract t = runYoneda t id - -instance HMonad Yoneda where - hbind f = f . hextract - -instance HComonad Yoneda where - hextend f = hreturn . f - -instance Copointed f => Copointed (Yoneda f) where - extract = extract . hextract - -instance Comonad f => Comonad (Yoneda f) where - extend k m = Yoneda (\f -> extend (f . k . hreturn) (hextract m)) - -instance MonadState e m => MonadState e (Yoneda m) where - get = lift get - put = lift . put - -instance MonadReader e m => MonadReader e (Yoneda m) where - ask = lift ask - local r = lift . local r . lowerYoneda - -instance MonadWriter e m => MonadWriter e (Yoneda m) where - tell = lift . tell - listen = lift . listen . flip runYoneda id - pass = lift . pass . lowerYoneda - -instance MonadFree f m => MonadFree f (Yoneda m) where - inFree = lift . inFree . fmap lowerYoneda - -instance RunMonadFree f m => RunMonadFree f (Yoneda m) where - cataFree l r = cataFree l r . lowerYoneda - -instance ComonadCofree f m => ComonadCofree f (Yoneda m) where - outCofree = fmap colift . outCofree . lowerYoneda - -instance RunComonadCofree f m => RunComonadCofree f (Yoneda m) where - anaCofree l r = colift . anaCofree l r - -instance ComonadContext e m => ComonadContext e (Yoneda m) where - getC = getC . lowerYoneda - modifyC s = modifyC s . lowerYoneda - -instance ComonadReader e m => ComonadReader e (Yoneda m) where - askC = askC . lowerYoneda - - --- | Left Kan Extensions --- CoYoneda ~ Lan Identity -data CoYoneda f a = forall b. CoYoneda (b -> a) (f b) - -lanToCoYoneda :: Lan Identity f :~> CoYoneda f -lanToCoYoneda (Lan f v) = CoYoneda (f . Identity) v - -coYonedaToLan :: CoYoneda f :~> Lan Identity f -coYonedaToLan (CoYoneda f v) = Lan (f . runIdentity) v - -instance Functor (CoYoneda f) where - fmap f (CoYoneda g v) = CoYoneda (f . g) v - -instance Pointed f => Pointed (CoYoneda f) where - point = hreturn . point - -instance Applicative f => Applicative (CoYoneda f) where - pure = hreturn . pure - m <*> n = CoYoneda id (hextract m <*> hextract n) - -instance Monad m => Monad (CoYoneda m) where - return = CoYoneda id . return - CoYoneda f v >>= k = CoYoneda id (v >>= (\(CoYoneda f' v') -> liftM f' v') . k . f) - -instance HFunctor CoYoneda where - ffmap = fmap - hfmap f (CoYoneda g v) = CoYoneda g (f v) - -instance HPointed CoYoneda where - hreturn = CoYoneda id - -instance HMonad CoYoneda where - hbind f = f . hextract - -instance HComonad CoYoneda where - hextend f = hreturn . f - -instance HCopointed CoYoneda where - hextract (CoYoneda f v) = fmap f v - -liftCoYoneda :: f :~> CoYoneda f -liftCoYoneda = CoYoneda id - --- | Just a conceptual nicety for monads since they aren't functors in Haskell. this is otherwise just hextract -lowerCoYoneda :: Monad f => CoYoneda f :~> f -lowerCoYoneda (CoYoneda f v) = liftM f v - -instance Copointed w => Copointed (CoYoneda w) where - extract (CoYoneda f v) = f (extract v) - -instance Comonad w => Comonad (CoYoneda w) where - extend k (CoYoneda f v) = CoYoneda id $ extend (k . CoYoneda f) v - -instance MonadTrans CoYoneda where - lift = CoYoneda id - -instance ComonadTrans CoYoneda where - colift = CoYoneda id - --- All the (Co)monadFoo CoYoneda instances - -instance ComonadCofree f m => ComonadCofree f (CoYoneda m) where - outCofree = fmap colift . outCofree . hextract - -instance RunComonadCofree f m => RunComonadCofree f (CoYoneda m) where - anaCofree l r = colift . anaCofree l r - -instance ComonadContext e m => ComonadContext e (CoYoneda m) where - getC = getC . hextract - modifyC s = modifyC s . hextract - -instance ComonadReader e m => ComonadReader e (CoYoneda m) where - askC = askC . hextract - -instance MonadState e m => MonadState e (CoYoneda m) where - get = lift get - put = lift . put - -instance MonadReader e m => MonadReader e (CoYoneda m) where - ask = lift ask - local r = lift . local r . lowerCoYoneda - -instance MonadWriter e m => MonadWriter e (CoYoneda m) where - tell = lift . tell - listen = lift . listen . lowerCoYoneda - pass = lift . pass . lowerCoYoneda - -instance MonadFree f m => MonadFree f (CoYoneda m) where - inFree = lift . inFree . fmap lowerCoYoneda - -instance RunMonadFree f m => RunMonadFree f (CoYoneda m) where - cataFree l r = cataFree l r . lowerCoYoneda diff --git a/src/Control/Functor/Zap.hs b/src/Control/Functor/Zap.hs deleted file mode 100644 --- a/src/Control/Functor/Zap.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Zap --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (functional-dependencies) --- --- Dual (bi)Functors -------------------------------------------------------------------------------------------- - -module Control.Functor.Zap - ( Zap(..), (>$<) - , Bizap(..), (>>$<<) - ) where - -import Control.Functor.Internal.Adjunction diff --git a/src/Control/Functor/Zip.hs b/src/Control/Functor/Zip.hs deleted file mode 100644 --- a/src/Control/Functor/Zip.hs +++ /dev/null @@ -1,127 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Functor.Zip --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- --- Described in and --- -------------------------------------------------------------------------------------------- - -module Control.Functor.Zip - ( unfzip, unbizip - , counzip, counbizip - , Zip(..) - , Bizip(..) - , Cozip(..) - ) where - -import Prelude hiding ((.),id,fst,snd) -import Control.Category -import Control.Category.Hask -import Control.Category.Cartesian -import Control.Functor -import Control.Functor.Fix -import Control.Functor.Combinators.Biff -import Control.Monad.Identity -import Data.Monoid (Monoid(..)) - -unfzip :: Functor f => f (a, b) -> (f a, f b) -unfzip = fmap fst &&& fmap snd - -unbizip :: (PreCartesian r pr , PreCartesian s ps, PreCartesian t pt, Bifunctor p r s t) => - t (p (pr a c) (ps b d)) (pt (p a b) (p c d)) -unbizip = bimap fst fst &&& bimap snd snd - -{- | Minimum definition: - -1. fzipWith - -2. fzip - --} - -class Functor f => Zip f where - fzip :: f a -> f b -> f (a, b) - fzip = fzipWith (,) - fzipWith :: (a -> b -> c) -> f a -> f b -> f c - fzipWith f as bs = fmap (uncurry f) (fzip as bs) - -{- | Minimum definition: - -1. bizipWith - -2. bizip - --} - -class Bifunctor p Hask Hask Hask => Bizip p where - bizip :: p a c -> p b d -> p (a,b) (c,d) - bizip = bizipWith (,) (,) - bizipWith :: (a -> b -> e) -> (c -> d -> f) -> p a c -> p b d -> p e f - bizipWith f g as bs = bimap (uncurry f) (uncurry g) (bizip as bs) - -instance Zip Identity where - fzipWith f (Identity a) (Identity b) = Identity (f a b) - -instance Zip [] where - fzip = zip - fzipWith = zipWith - -instance Zip Maybe where - fzipWith f (Just a) (Just b) = Just (f a b) - fzipWith _ _ _ = Nothing - -instance Monoid a => Zip ((,)a) where - fzipWith f (a, c) (b, d) = (mappend a b, f c d) - -instance Bizip (,) where - bizipWith f g (a,b) (c,d) = (f a c, g b d) - -instance (Bizip p, Zip f, Zip g) => Bizip (Biff p f g) where - bizipWith f g as bs = Biff $ bizipWith (fzipWith f) (fzipWith g) (runBiff as) (runBiff bs) - -instance Bizip p => Zip (Fix p) where - fzipWith f as bs = InB $ bizipWith f (fzipWith f) (outB as) (outB bs) - -instance Monoid a => Zip (Either a) where - fzipWith _ (Left a) (Left b) = Left (mappend a b) - fzipWith _ (Right _) (Left b) = Left b - fzipWith _ (Left a) (Right _) = Left a - fzipWith f (Right a) (Right b) = Right (f a b) - - -{- -- fails because Either cannot be made an instance of Bizip! -instance Zip f => Bizip (FreeB f) where - bizipWith f g (FreeB as) (FreeB bs) = FreeB $ bizipWith f (fzipWith g) as bs --} - -counzip :: Functor f => Either (f a) (f b) -> f (Either a b) -counzip = fmap Left ||| fmap Right - -counbizip :: (PreCoCartesian r sr, PreCoCartesian s ss, PreCoCartesian t st, Bifunctor q r s t) => - t (st (q a c) (q b d)) (q (sr a b) (ss c d)) -counbizip = bimap inl inl ||| bimap inr inr - -class Functor f => Cozip f where - cozip :: f (Either a b) -> Either (f a) (f b) - -instance Cozip Identity where - cozip = bimap Identity Identity . runIdentity - -instance Cozip ((,)c) where - cozip (c,ab) = bimap ((,)c) ((,)c) ab - --- ambiguous choice -instance Cozip Maybe where - cozip = maybe (Left Nothing) (bimap Just Just) --- cozip = maybe (Right Nothing) (bimap Just Just) - --- ambiguous choice -instance Cozip (Either c) where - cozip = (Left . Left) ||| bimap Right Right --- cozip = (Right . Left) ||| bimap Right Right diff --git a/src/Control/Monad/Categorical.hs b/src/Control/Monad/Categorical.hs deleted file mode 100644 --- a/src/Control/Monad/Categorical.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Control.Monad.Categorical - (CMonad, CBind(..), CPointed(..)) where - -import Prelude hiding (id,(.)) -import Control.Functor.Categorical diff --git a/src/Control/Monad/Codensity.hs b/src/Control/Monad/Codensity.hs deleted file mode 100644 --- a/src/Control/Monad/Codensity.hs +++ /dev/null @@ -1,86 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Codensity --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- ----------------------------------------------------------------------------- -module Control.Monad.Codensity - ( Codensity, liftCodensity, lowerCodensity - , codensityToRan, ranToCodensity - , toCodensity, fromCodensity - , codensityToAdjunction - , adjunctionToCodensity - , improveFree - ) where - -import Prelude hiding (abs) -import Control.Comonad.Context -import Control.Functor.Extras -import Control.Functor.Pointed () -import Control.Functor.Adjunction -import Control.Functor.KanExtension -import Control.Monad.State -import Control.Monad.Reader -import Control.Monad.Identity -import Control.Monad.Free - -newtype Codensity m a = Codensity { runCodensity :: forall b. (a -> m b) -> m b } - -codensityToRan :: Codensity m :~> Ran m m -codensityToRan x = Ran (runCodensity x) - -ranToCodensity :: Ran m m :~> Codensity m -ranToCodensity x = Codensity (runRan x) - -liftCodensity :: Monad m => m :~> Codensity m -liftCodensity m = Codensity (m >>=) - -lowerCodensity :: Monad m => Codensity m :~> m -lowerCodensity a = runCodensity a return - -toCodensity :: Functor s => (forall a. s (k a) -> k a) -> s :~> Codensity k -toCodensity s t = Codensity (s . flip fmap t) - -fromCodensity :: (s :~> Codensity k) -> s (k a) -> k a -fromCodensity s = flip runCodensity id . s - -instance Functor (Codensity k) where - fmap f m = Codensity (\k -> runCodensity m (k . f)) - -instance Pointed (Codensity f) where - point x = Codensity (\k -> k x) - -instance Monad (Codensity f) where - return = point - m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c)) - -instance MonadReader r m => MonadReader r (Codensity m) where - ask = liftCodensity ask - local f m = Codensity (\c -> ask >>= \r -> local f (runCodensity m (local (const r) . c))) - -instance MonadIO m => MonadIO (Codensity m) where - liftIO = liftCodensity . liftIO - -instance MonadState s m => MonadState s (Codensity m) where - get = liftCodensity get - put = liftCodensity . put - -instance MonadFree f m => MonadFree f (Codensity m) where - inFree t = Codensity (inFree . flip fmap t . flip runCodensity) - -instance RunMonadFree f m => RunMonadFree f (Codensity m) where - cataFree l r = cataFree l r . lowerCodensity - -codensityToAdjunction :: Adjunction f g => Codensity g a -> g (f a) -codensityToAdjunction r = runCodensity r unit - -adjunctionToCodensity :: Adjunction f g => g (f a) -> Codensity g a -adjunctionToCodensity f = Codensity (\a -> fmap (rightAdjunct a) f) - -improveFree :: Functor f => (forall m. MonadFree f m => m a) -> Free f a -improveFree m = lowerCodensity m diff --git a/src/Control/Monad/Either.hs b/src/Control/Monad/Either.hs deleted file mode 100644 --- a/src/Control/Monad/Either.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Either --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- --- Incompatible with Control.Monad.Error, but removes the Error restriction --- that prevents a natural encoding of Apomorphisms. This module is --- therefore incompatible with Control.Monad.Error ----------------------------------------------------------------------------- -module Control.Monad.Either - ( Either(Left,Right) - , EitherT(EitherT,runEitherT) - ) where - -import Control.Functor.Pointed -import Control.Applicative -import Control.Monad.Fix - -#if __BROKEN_EITHER__ -import Prelude hiding (Either(Left,Right)) -#endif - --- we have to define our own because the Control.Monad.Error instance is --- baked into the prelude on old versions. -#if __BROKEN_EITHER__ -data Either a b = Left a | Right b -instance Functor (Either e) where - fmap _ (Left a) = Left a - fmap f (Right a) = Right (f a) -#endif - -newtype EitherT a m b = EitherT { runEitherT :: m (Either a b) } - --- defined in Control.Functor.Pointed ---instance Pointed (Either e) where --- point = Right - -instance Monad (Either e) where - return = Right - Right m >>= k = k m - Left e >>= _ = Left e - -instance Applicative (Either e) where - pure = Right - a <*> b = do x <- a; y <- b; return (x y) - -instance MonadFix (Either e) where - mfix f = let - a = f $ case a of - Right r -> r - _ -> error "empty mfix argument" - in a - -instance Functor f => Functor (EitherT a f) where - fmap f = EitherT . fmap (fmap f) . runEitherT - -instance Pointed f => Pointed (EitherT a f) where - point = EitherT . point . Right - -instance Monad m => Monad (EitherT a m) where - return = EitherT . return . return - m >>= k = EitherT $ do - a <- runEitherT m - case a of - Left l -> return (Left l) - Right r -> runEitherT (k r) - -instance MonadFix m => MonadFix (EitherT a m) where - mfix f = EitherT $ mfix $ \a -> runEitherT $ f $ case a of - Right r -> r - _ -> error "empty mfix argument" diff --git a/src/Control/Monad/Free.hs b/src/Control/Monad/Free.hs deleted file mode 100644 --- a/src/Control/Monad/Free.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Free --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- --- See for --- the background on rep, abs and improve and their use. NB: the C type --- in that paper is just the right Kan extension of a monad --- along itself, also known as the monad generated by a functor: --- ----------------------------------------------------------------------------- -module Control.Monad.Free - ( module Control.Monad.Parameterized - , PFree - , Free - , runFree - , free - , MonadFree(inFree) - , RunMonadFree(cataFree) - ) where - -import Prelude hiding ((.),id) -import Control.Category -import Control.Category.Cartesian -import Control.Functor -import Control.Functor.Algebra -import Control.Functor.Combinators.Biff -import Control.Functor.Fix -import Control.Monad.Parameterized -import Control.Monad.Identity -import Control.Monad.Reader - -type Free f = Fix (PFree f) - -runFree :: Free f a -> Either a (f (Free f a)) -runFree = first runIdentity . runBiff . outB - -free :: Either a (f (Free f a)) -> Free f a -free = InB . Biff . first Identity - -class MonadFree f m => RunMonadFree f m | m -> f where - cataFree :: (c -> a) -> Algebra f a -> m c -> a - -instance Functor f => RunMonadFree f (Free f) where - cataFree l r = (l . runIdentity ||| r . fmap (cataFree l r)) . runBiff . outB - -class (Functor f, Monad m) => MonadFree f m | m -> f where - inFree :: f (m a) -> m a - -instance Functor f => MonadFree f (Free f) where - inFree = InB . Biff . Right - -instance MonadFree f m => MonadFree f (ReaderT e m) where - inFree fma = ReaderT (\e -> inFree $ fmap (flip runReaderT e) fma) - --- instance (MonadFree f m, Traversable f) => MonadFree f (StateT e m) where diff --git a/src/Control/Monad/HigherOrder.hs b/src/Control/Monad/HigherOrder.hs deleted file mode 100644 --- a/src/Control/Monad/HigherOrder.hs +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.HigherOrder --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- ----------------------------------------------------------------------------- -module Control.Monad.HigherOrder - ( HFunctor(..) - , HPointed(..) - , HMonad(..) - , hjoin - , (>>**=), (=**<<) - ) where - -import Control.Functor.Extras -import Control.Functor.HigherOrder - -infixl 1 >>**= -infixr 1 =**<< - -class HPointed m => HMonad m where - hbind :: (Functor f, Functor g) => (f :~> m g) -> m f :~> m g - -hjoin :: (HMonad m, Functor (m g), Functor g) => m (m g) :~> m g -hjoin = hbind id - -(>>**=) :: (HMonad m, Functor f, Functor g) => m f a -> (f :~> m g) -> m g a -m >>**= k = hbind k m - -(=**<<) :: (HMonad m, Functor f, Functor g) => (f :~> m g) -> m f :~> m g -(=**<<) = hbind diff --git a/src/Control/Monad/Hyper.hs b/src/Control/Monad/Hyper.hs deleted file mode 100644 --- a/src/Control/Monad/Hyper.hs +++ /dev/null @@ -1,53 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Monad.Hyper --- Copyright : 2008 Edward Kmett --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (functional-dependencies) --- --- Based on the construction of hyperfunctions as parameterized monads in --- -------------------------------------------------------------------------------------------- - -module Control.Monad.Hyper - ( ContraFunctor(..) - , Hyper - , Hyp - , PHyper(..) - ) where - -import Control.Category.Hask -import Control.Functor -import Control.Functor.Fix -import Control.Functor.Contra -import Control.Monad.Instances -import Control.Monad.Parameterized - -newtype PHyper h a b = PHyper { runPHyper :: h b -> a } - -instance PFunctor (PHyper h) Hask Hask where - first f h = PHyper (f . runPHyper h) - -instance ContraFunctor h => QFunctor (PHyper h) Hask Hask where - second g h = PHyper (runPHyper h . contramap g) - -instance ContraFunctor h => Bifunctor (PHyper h) Hask Hask Hask where - bimap f g h = PHyper (f . runPHyper h . contramap g) - -instance ContraFunctor h => PPointed (PHyper h) where - preturn = PHyper . const - -instance ContraFunctor h => PApplicative (PHyper h) where - pap = papPMonad - -instance ContraFunctor h => PMonad (PHyper h) where - pbind k (PHyper h) = PHyper (k . h >>= runPHyper) - --- | A generic recursive hyperfunction-like combinator -type Hyper h a = Fix (PHyper h) - --- | Traditional Hyper functions -type Hyp e a = Hyper (ContraF e) a diff --git a/src/Control/Monad/Ideal.hs b/src/Control/Monad/Ideal.hs deleted file mode 100644 --- a/src/Control/Monad/Ideal.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Ideal --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- ----------------------------------------------------------------------------- -module Control.Monad.Ideal - ( - -- * Ideal Monads - MonadIdeal(..) - , Ideal - , ideal - , destroyIdeal - -- * Mutual recursion for (co)ideal (co)monad (co)products - , Mutual(..) - -- * Ideal Monad Coproduct - , (:+) - ) where - -import Control.Functor.Internal.Ideal diff --git a/src/Control/Monad/Indexed.hs b/src/Control/Monad/Indexed.hs deleted file mode 100644 --- a/src/Control/Monad/Indexed.hs +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Indexed --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- ----------------------------------------------------------------------------- -module Control.Monad.Indexed - ( IxFunctor(..) - , IxPointed(..) - , IxApplicative(..) - , IxMonad(..) - , IxMonadZero(..) - , IxMonadPlus(..) - , ijoin, (>>>=), (=<<<) - , iapIxMonad - ) where - -import Control.Functor.Indexed - -class IxApplicative m => IxMonad m where - ibind :: (a -> m j k b) -> m i j a -> m i k b - -ijoin :: IxMonad m => m i j (m j k a) -> m i k a -ijoin = ibind id - -infixr 1 =<<< -infixl 1 >>>= - -(>>>=) :: IxMonad m => m i j a -> (a -> m j k b) -> m i k b -m >>>= k = ibind k m - -(=<<<) :: IxMonad m => (a -> m j k b) -> m i j a -> m i k b -(=<<<) = ibind - -iapIxMonad :: IxMonad m => m i j (a -> b) -> m j k a -> m i k b -iapIxMonad f x = f >>>= \ f' -> x >>>= \x' -> ireturn (f' x') - -class IxMonad m => IxMonadZero m where - imzero :: m i j a - -class IxMonadZero m => IxMonadPlus m where - implus :: m i j a -> m i j a -> m i j a diff --git a/src/Control/Monad/Indexed/Cont.hs b/src/Control/Monad/Indexed/Cont.hs deleted file mode 100644 --- a/src/Control/Monad/Indexed/Cont.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -------------------------------------------------------------------------------------------- --- | --- Module : Control.Monad.Indexed.Cont --- Copyright : 2008 Edward Kmett, Dan Doel --- License : BSD --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : rank-2 Types required for correctness of shift, but they can be removed -------------------------------------------------------------------------------------------- - -module Control.Monad.Indexed.Cont - ( IxMonadCont(reset, shift) - , IxContT(IxContT, runIxContT) - , runIxContT_ - , IxCont(IxCont) - , runIxCont - , runIxCont_ - ) where - -import Control.Applicative -import Control.Functor.Pointed --- import Control.Monad.Trans -import Control.Monad.Identity -import Control.Monad.Indexed -import Control.Monad.State -import Control.Monad.Reader -import Control.Monad.Indexed.Trans - -class IxMonad m => IxMonadCont m where - reset :: m a o o -> m r r a - shift :: (forall i. (a -> m i i o) -> m r j j) -> m r o a --- shift :: ((a -> m i i o) -> m r j j) -> m r o a - -newtype IxContT m r o a = IxContT { runIxContT :: (a -> m o) -> m r } - -runIxContT_ :: Monad m => IxContT m r a a -> m r -runIxContT_ m = runIxContT m return - -instance IxFunctor (IxContT m) where - imap f m = IxContT $ \c -> runIxContT m (c . f) - -instance IxPointed (IxContT m) where - ireturn a = IxContT ($a) - -instance Monad m => IxApplicative (IxContT m) where - iap = iapIxMonad - -instance Monad m => IxMonad (IxContT m) where - ibind f c = IxContT $ \k -> runIxContT c $ \a -> runIxContT (f a) k - -instance Monad m => IxMonadCont (IxContT m) where - reset e = IxContT $ \k -> runIxContT e return >>= k - shift e = IxContT $ \k -> e (\a -> IxContT (\k' -> k a >>= k')) `runIxContT` return - -instance Monad m => Functor (IxContT m i j) where - fmap = imap - -instance Monad m => Pointed (IxContT m i i) where - point = ireturn - -instance Monad m => Applicative (IxContT m i i) where - pure = ireturn - (<*>) = iap - -instance Monad m => Monad (IxContT m i i) where - return = ireturn - m >>= k = ibind k m - ---instance Monad m => MonadCont (IxContT m i i) where --- callCC f = shift (\k -> f k >>>= k) - -instance IxMonadTrans IxContT where - ilift m = IxContT (m >>=) - -instance MonadReader e m => MonadReader e (IxContT m i i) where - ask = ilift ask - local f m = IxContT $ \c -> do - r <- ask - local f (runIxContT m (local (const r) . c)) - -instance MonadState e m => MonadState e (IxContT m i i) where - get = ilift get - put = ilift . put - -instance MonadIO m => MonadIO (IxContT m i i) where - liftIO = ilift . liftIO - -newtype IxCont r o a = IxCont (IxContT Identity r o a) - deriving (IxFunctor, IxPointed, IxApplicative, IxMonad, IxMonadCont) - - -runIxCont :: IxCont r o a -> (a -> o) -> r -runIxCont (IxCont k) f = runIdentity $ runIxContT k (return . f) - -runIxCont_ :: IxCont r a a -> r -runIxCont_ m = runIxCont m id - --- instance MonadCont (IxCont i i) where --- callCC f = shift (\k -> f k >>>= k) - -instance Functor (IxCont i j) where - fmap = imap - -instance Pointed (IxCont i i) where - point = ireturn - -instance Applicative (IxCont i i) where - pure = ireturn - (<*>) = iap - -instance Monad (IxCont i i) where - return = ireturn - m >>= k = ibind k m - diff --git a/src/Control/Monad/Indexed/Fix.hs b/src/Control/Monad/Indexed/Fix.hs deleted file mode 100644 --- a/src/Control/Monad/Indexed/Fix.hs +++ /dev/null @@ -1,20 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Indexed.Fix --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- ----------------------------------------------------------------------------- -module Control.Monad.Indexed.Fix - ( IxMonadFix(..) - ) where - -import Control.Monad.Indexed - -class IxMonad m => IxMonadFix m where - imfix :: (a -> m i i a) -> m i i a - diff --git a/src/Control/Monad/Indexed/State.hs b/src/Control/Monad/Indexed/State.hs deleted file mode 100644 --- a/src/Control/Monad/Indexed/State.hs +++ /dev/null @@ -1,175 +0,0 @@ -{-# OPTIONS_GHC -fallow-undecidable-instances #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Indexed.State --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable (although the MTL instances aren't!) --- ----------------------------------------------------------------------------- -module Control.Monad.Indexed.State - ( IxMonadState(..) - , imodify - , igets - , IxStateT(..) - , IxState(..) - ) where - -import Control.Applicative -import Control.Category.Hask --- import Control.Category.Cartesian -import Control.Functor -import Control.Monad.Indexed -import Control.Monad.Indexed.Trans -import Control.Monad.Indexed.Fix -import Control.Monad.State -import Control.Monad.Writer -import Control.Monad.Reader -import Control.Monad.Cont -import Control.Monad.Error.Class - -class IxMonad m => IxMonadState m where - iget :: m i i i - iput :: j -> m i j () - -imodify :: IxMonadState m => (i -> j) -> m i j () -imodify f = iget >>>= iput . f - -igets :: IxMonadState m => (i -> a) -> m i i a -igets f = iget >>>= ireturn . f - --- Indexed State Monad - -newtype IxState i j a = IxState { runIxState :: i -> (a, j) } - -instance Functor (IxState i j) where - fmap = imap - -instance IxFunctor IxState where - imap f m = IxState (first f . runIxState m) - -instance IxPointed IxState where - ireturn = IxState . (,) - -instance IxApplicative IxState where - iap = iapIxMonad - -instance IxMonad IxState where - ibind f m = IxState $ \s1 -> let (a,s2) = runIxState m s1 in runIxState (f a) s2 - -instance IxMonadState IxState where - iget = IxState (\x -> (x,x)) - iput x = IxState (\_ -> ((),x)) - -instance PFunctor (IxState i) Hask Hask where - first = first' - -instance QFunctor (IxState i) Hask Hask where - second = second' - -instance Bifunctor (IxState i) Hask Hask Hask where - bimap f g m = IxState $ bimap g f . runIxState m - -instance Monad (IxState i i) where - return = ireturn - m >>= k = ibind k m - -instance Applicative (IxState i i) where - pure = ireturn - (<*>) = iap - -instance MonadState i (IxState i i) where - get = iget - put = iput - -instance MonadFix (IxState i i) where - mfix = imfix - -instance IxMonadFix IxState where - imfix f = IxState $ \s -> let (a, s') = runIxState (f a) s in (a, s') - - --- Indexed State Monad Transformer - -newtype IxStateT m i j a = IxStateT { runIxStateT :: i -> m (a, j) } - -instance Monad m => Functor (IxStateT m i j) where - fmap = imap - -instance Monad m => IxFunctor (IxStateT m) where - imap f m = IxStateT $ \s -> runIxStateT m s >>= \(x,s') -> return (f x, s') - -instance Monad m => IxPointed (IxStateT m) where - ireturn a = IxStateT $ \s -> return (a, s) - -instance Monad m => IxApplicative (IxStateT m) where - iap = iapIxMonad - -instance Monad m => IxMonad (IxStateT m) where - ibind k m = IxStateT $ \s -> runIxStateT m s >>= \ ~(a, s') -> runIxStateT (k a) s' - -instance Monad m => PFunctor (IxStateT m i) Hask Hask where - first = first' - -instance Monad m => QFunctor (IxStateT m i) Hask Hask where - second = second' - -instance Monad m => Bifunctor (IxStateT m i) Hask Hask Hask where - bimap f g m = IxStateT $ liftM (bimap g f) . runIxStateT m - -instance Monad m => IxMonadState (IxStateT m) where - iget = IxStateT $ \s -> return (s, s) - iput s = IxStateT $ \_ -> return ((), s) - -instance MonadPlus m => IxMonadZero (IxStateT m) where - imzero = IxStateT $ const mzero - -instance MonadPlus m => IxMonadPlus (IxStateT m) where - m `implus` n = IxStateT $ \s -> runIxStateT m s `mplus` runIxStateT n s - -instance MonadFix m => IxMonadFix (IxStateT m) where - imfix f = IxStateT $ \s -> mfix $ \ ~(a, _) -> runIxStateT (f a) s - -instance MonadFix m => MonadFix (IxStateT m i i) where - mfix = imfix - -instance Monad m => Monad (IxStateT m i i) where - return = ireturn - m >>= k = ibind k m - -instance Monad m => Applicative (IxStateT m i i) where - pure = ireturn - (<*>) = iap - -instance Monad m => MonadState i (IxStateT m i i) where - get = iget - put = iput - -instance IxMonadTrans IxStateT where - ilift m = IxStateT $ \s -> m >>= \a -> return (a, s) - -instance MonadIO m => MonadIO (IxStateT m i i) where - liftIO = ilift . liftIO - -instance MonadReader r m => MonadReader r (IxStateT m i i) where - ask = ilift ask - local f m = IxStateT (local f . runIxStateT m) - -instance MonadCont m => MonadCont (IxStateT m i i) where - callCC f = IxStateT $ \s -> callCC $ \k -> runIxStateT (f (\a -> IxStateT $ \s' -> k (a,s'))) s - -instance MonadError e m => MonadError e (IxStateT m i i) where - throwError = ilift . throwError - m `catchError` h = IxStateT $ \s -> runIxStateT m s `catchError` \e -> runIxStateT (h e) s - -instance MonadWriter w m => MonadWriter w (IxStateT m i i) where - tell = ilift . tell - listen m = IxStateT $ \s -> do - ~((a,s'),w) <- listen (runIxStateT m s) - return ((a,w),s') - pass m = IxStateT $ \s -> pass $ do - ~((a,f),s') <- runIxStateT m s - return ((a,s'),f) diff --git a/src/Control/Monad/Indexed/Trans.hs b/src/Control/Monad/Indexed/Trans.hs deleted file mode 100644 --- a/src/Control/Monad/Indexed/Trans.hs +++ /dev/null @@ -1,18 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Indexed.Trans --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable (indexed monad transfomers) --- --- TODO: figure out a meaningful way for indexed monads to transform indexed --- monads ----------------------------------------------------------------------------- -module Control.Monad.Indexed.Trans where - -class IxMonadTrans t where - ilift :: Monad m => m a -> t m i i a - diff --git a/src/Control/Monad/Parameterized.hs b/src/Control/Monad/Parameterized.hs deleted file mode 100644 --- a/src/Control/Monad/Parameterized.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Paramterized --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- ----------------------------------------------------------------------------- -module Control.Monad.Parameterized - ( Bifunctor(..) - , PPointed(..) - , PApplicative(..) - , PMonad(..) - , (>>*=), (=*<<), (>>*) - , papPMonad - ) where - -import Control.Functor -import Control.Applicative.Parameterized - -infixl 1 >>*=, >>* -infixr 1 =*<< - -class PApplicative f => PMonad f where - pbind :: (a -> f b c) -> f a c -> f b c - pbind f = pjoin . first f - pjoin :: f (f a b) b -> f a b - pjoin = pbind id - -papPMonad :: PMonad f => f (a -> b) c -> f a c -> f b c -papPMonad f x = f >>*= \ f' -> x >>*= \x' -> preturn (f' x') - -(>>*=) :: PMonad f => f a c -> (a -> f b c) -> f b c -(>>*=) = flip pbind - -(=*<<) :: PMonad f => (a -> f b c) -> f a c -> f b c -(=*<<) = pbind - -(>>*) :: PMonad f => f a c -> f b c -> f b c -m >>* n = m >>*= const n - -{- Parameterized monad laws (from ) -> pbind preturn = id -> pbind g . preturn = g -> pbind (pbind g . j) = pbind g . pbind j -> pmap g . preturn = preturn -> pbind (pmap g . j) . pmap g = pmap g . pbind j --} - diff --git a/src/Control/Morphism/Ana.hs b/src/Control/Morphism/Ana.hs deleted file mode 100644 --- a/src/Control/Morphism/Ana.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Ana --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- ----------------------------------------------------------------------------- -module Control.Morphism.Ana - ( ana, g_ana, distAna - , biana, g_biana - , hana - , kana, runkana - ) where - -import Control.Category.Hask -import Control.Functor -import Control.Functor.Algebra -import Control.Functor.Extras -import Control.Functor.Fix -import Control.Functor.HigherOrder -import Control.Functor.KanExtension -import Control.Functor.KanExtension.Interpreter -import Control.Comonad () -import Control.Monad.Identity - --- | Anamorphisms are a generalized form of 'unfoldr' -ana :: Functor f => Coalgebra f a -> a -> FixF f -ana g = InF . fmap (ana g) . g --- ana g = g_ana distAna (liftCoAlgebra g) - --- | Generalized anamorphisms allow you to work with a monad given a distributive law -g_ana :: (Functor f, Monad m) => Dist m f -> GCoalgebra f m a -> a -> FixF f --- g_ana k g = g_hylo distCata k inW id g -g_ana k g = a . return where a = InF . fmap (a . join) . k . liftM g - --- | The distributive law for the identity monad -distAna :: Functor f => Dist Identity f -distAna = fmap Identity . runIdentity - -biana :: QFunctor f Hask Hask => Coalgebra (f b) a -> a -> Fix f b -biana g = InB . second (biana g) . g - -g_biana :: (QFunctor f Hask Hask, Monad m) => Dist m (f b) -> GCoalgebra (f b) m a -> a -> Fix f b -g_biana k g = a . return where a = InB . second (a . join) . k . liftM g - --- | A higher-order anamorphism for constructing higher order functors. -hana :: HFunctor f => HCoalgebra f a -> a :~> FixH f -hana g = InH . hfmap (hana g) . g - -kana :: HFunctor f => CointerpreterT f g h -> Lan g h :~> FixH f -kana i = hana (cointerpreterCoalgebra i) - -runkana :: HFunctor f => CointerpreterT f g h -> (g b -> a) -> h b -> FixH f a -runkana i f v = kana i (Lan f v) diff --git a/src/Control/Morphism/Apo.hs b/src/Control/Morphism/Apo.hs deleted file mode 100644 --- a/src/Control/Morphism/Apo.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Apo --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Traditional operators, shown here to show how to roll your own ----------------------------------------------------------------------------- -module Control.Morphism.Apo - ( apo, g_apo - , postpro_apo, g_postpro_apo - , Apo, ApoT - , distApoT - , GApo, GApoT - , distGApo, distGApoT - ) where - -import Control.Functor.Algebra -import Control.Functor.Extras -import Control.Functor.Fix -import Control.Monad -import Control.Monad.Either -import Control.Morphism.Ana -import Control.Morphism.Postpro -import Control.Arrow ((|||)) - --- * Unfold Sugar - -apo :: Functor f => GCoalgebra f (Apo f) a -> a -> FixF f -apo = g_apo outF - -g_apo :: Functor f => Coalgebra f b -> GCoalgebra f (GApo b) a -> a -> FixF f -g_apo g = g_ana (distGApo g) - -postpro_apo :: Functor f => GCoalgebra f (Apo f) a -> (f :~> f) -> a -> FixF f -postpro_apo = g_postpro_apo outF - -g_postpro_apo :: Functor f => Coalgebra f b -> GCoalgebra f (GApo b) a -> (f :~> f) -> a -> FixF f -g_postpro_apo g = g_postpro (distGApo g) - -type Apo f a = Either (FixF f) a -type ApoT f m a = EitherT (FixF f) m a - -type GApo b a = Either b a -type GApoT b m a = EitherT b m a - --- * Distributive Law Combinators for apomorphisms --- NB: we don't actually have simple recursion combinators for all of these - -distGApo :: Functor f => Coalgebra f b -> Dist (Either b) f -distGApo f = fmap Left . f ||| fmap Right - -distGApoT :: (Functor f, Monad m) => GCoalgebra f m b -> Dist m f -> Dist (EitherT b m) f -distGApoT g k = fmap (EitherT . join) . k . liftM (fmap (liftM Left) . g ||| fmap (return . Right)) . runEitherT - -distApoT :: (Functor f, Monad m) => Dist m f -> Dist (ApoT f m) f -distApoT = distGApoT (liftCoalgebra outF) diff --git a/src/Control/Morphism/Build.hs b/src/Control/Morphism/Build.hs deleted file mode 100644 --- a/src/Control/Morphism/Build.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Build --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- ----------------------------------------------------------------------------- -module Control.Morphism.Build where - -import Control.Functor.Extras -import Control.Functor.HigherOrder -import Control.Functor.KanExtension --- import Control.Functor.KanExtension.Interpreter --- import Control.Morphism.Cata --- prepro/preprobuild fusion? - --- | @forall h g. hcata h . hbuild g = g h@ cannot be realized as a RULE because --- h and g are not monotypes. --- Kan extended build, gbuild in Ghani/Johann parlance, but g_foo currently denotes --- generalized in the 'has a parameterizing (co)monad' sense. -hbuild :: (HFunctor f, Functor c) => (forall x. HAlgebra f x -> c :~> x) -> c :~> FixH f -hbuild g = g InH - --- | @ forall h g. kcata h . kbuild g = g (interpreterAlgebra h)@ cannot be realized as --- a RULE because h and g are not monotypes. -kbuild :: HFunctor f => (forall x. HAlgebra f x -> Lan g h :~> x) -> Lan g h :~> FixH f -kbuild = hbuild diff --git a/src/Control/Morphism/Cata.hs b/src/Control/Morphism/Cata.hs deleted file mode 100644 --- a/src/Control/Morphism/Cata.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Cata --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- ----------------------------------------------------------------------------- -module Control.Morphism.Cata - ( cata, g_cata, distCata - , bicata, g_bicata - , hcata - , kcata, runkcata - ) where - -import Control.Comonad -import Control.Category.Hask -import Control.Functor -import Control.Functor.Pointed -import Control.Functor.Algebra -import Control.Functor.Extras -import Control.Functor.Fix -import Control.Functor.HigherOrder -import Control.Functor.KanExtension -import Control.Functor.KanExtension.Interpreter -import Control.Monad.Identity - -cata :: Functor f => Algebra f a -> FixF f -> a -cata f = f . fmap (cata f) . outF --- cata f = g_cata distCata (liftAlgebra f) - -g_cata :: (Functor f, Comonad w) => Dist f w -> GAlgebra f w a -> FixF f -> a -g_cata k g = extract . c where c = liftW g . k . fmap (duplicate . c) . outF --- g_cata k f = g_hylo k distAna f id outM - -distCata :: Functor f => Dist f Identity -distCata = Identity . fmap runIdentity - -bicata :: QFunctor f Hask Hask => Algebra (f b) a -> Fix f b -> a -bicata f = f . second (bicata f) . outB - -g_bicata :: (QFunctor f Hask Hask, Comonad w) => Dist (f b) w -> GAlgebra (f b) w a -> Fix f b -> a -g_bicata k g = extract . c where c = liftW g . k . second (duplicate . c) . outB - -hcata :: HFunctor f => HAlgebra f a -> FixH f :~> a -hcata f = f . hfmap (hcata f) . outH - -kcata :: HFunctor f => InterpreterT f g h -> FixH f :~> Ran g h -kcata i = hcata (interpreterAlgebra i) - -runkcata :: HFunctor f => InterpreterT f g h -> FixH f a -> (a -> g b) -> h b -runkcata i = runRan . kcata i diff --git a/src/Control/Morphism/Chrono.hs b/src/Control/Morphism/Chrono.hs deleted file mode 100644 --- a/src/Control/Morphism/Chrono.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Chrono --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Chronomorphisms from ----------------------------------------------------------------------------- -module Control.Morphism.Chrono where - -import Control.Comonad.Cofree -import Control.Functor.Algebra -import Control.Functor.Extras -import Control.Monad.Free -import Control.Morphism.Hylo -import Control.Morphism.Futu -import Control.Morphism.Histo - -chrono :: (RunMonadFree f m, RunComonadCofree g w) => GAlgebra g w b -> (f :~> g) -> GCoalgebra f m a -> a -> b -chrono = g_hylo (distHisto id) (distFutu id) - -g_chrono :: (Functor f, Functor g, RunComonadCofree h w, RunMonadFree j m) => - Dist g h -> Dist j f -> GAlgebra g w b -> (f :~> g) -> GCoalgebra f m a -> a -> b -g_chrono h f = g_hylo (distHisto h) (distFutu f) diff --git a/src/Control/Morphism/Destroy.hs b/src/Control/Morphism/Destroy.hs deleted file mode 100644 --- a/src/Control/Morphism/Destroy.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Destroy --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- ----------------------------------------------------------------------------- -module Control.Morphism.Destroy where - -import Control.Functor.Extras -import Control.Functor.HigherOrder -import Control.Functor.KanExtension --- import Control.Morphism.Ana - --- | @forall h g . hdestroy g . hana h = g h@ cannot be realized as a RULE. -hdestroy :: (HFunctor f, Functor c) => (forall g. HCoalgebra f g -> g :~> c) -> FixH f :~> c -hdestroy g = g outH - --- | @forall h g . kdestroy g . kana h = g (cointerpreterCoalgebra h)@ cannot be realized as a RULE -kdestroy :: HFunctor f => (forall x. HCoalgebra f x -> x :~> Ran g h) -> FixH f :~> Ran g h -kdestroy = kdestroy diff --git a/src/Control/Morphism/Dyna.hs b/src/Control/Morphism/Dyna.hs deleted file mode 100644 --- a/src/Control/Morphism/Dyna.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Dyna --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- ----------------------------------------------------------------------------- -module Control.Morphism.Dyna where - -import Control.Functor.Algebra -import Control.Functor.Extras -import Control.Comonad.Cofree -import Control.Morphism.Hylo -import Control.Morphism.Histo -import Control.Morphism.Ana - -dyna :: (Functor f, RunComonadCofree g w) => GAlgebra g w b -> (f :~> g) -> Coalgebra f a -> a -> b -dyna f e g = g_hylo (distHisto id) distAna f e (liftCoalgebra g) diff --git a/src/Control/Morphism/Exo.hs b/src/Control/Morphism/Exo.hs deleted file mode 100644 --- a/src/Control/Morphism/Exo.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Exo --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Martin Erwig's exomorphism ----------------------------------------------------------------------------- -module Control.Morphism.Exo - ( exo - ) where - -import Control.Functor.Algebra -import Control.Morphism.Hylo - --- | Martin Erwig's exomorphism from d to d' -exo :: Functor h => Bialgebra m n b -> (h b -> m b) -> (h a -> h (g a)) -> Trialgebra f g h a -> g a -> b -exo d' f g d = hylo (fst d' . f) id (g . snd d) - diff --git a/src/Control/Morphism/Futu.hs b/src/Control/Morphism/Futu.hs deleted file mode 100644 --- a/src/Control/Morphism/Futu.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Futu --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Traditional operators, shown here to show how to roll your own ----------------------------------------------------------------------------- -module Control.Morphism.Futu - ( futu, g_futu - , postpro_futu, g_postpro_futu - , distFutu - ) where - -import Control.Functor.Algebra -import Control.Functor.Extras -import Control.Functor.Fix -import Control.Monad.Free -import Control.Morphism.Ana -import Control.Morphism.Postpro - --- | Generalized from @futu :: Functor f => GCoalgebra f (Free f) a -> a -> FixF f@ -futu :: (RunMonadFree f m) => GCoalgebra f m a -> a -> FixF f -futu = g_ana (distFutu id) - -g_futu :: (Functor f, RunMonadFree h m) => Dist h f -> GCoalgebra f m a -> a -> FixF f -g_futu k = g_ana (distFutu k) - --- | A futumorphic postpromorphism -postpro_futu :: (RunMonadFree f m) => GCoalgebra f m a -> (f :~> f) -> a -> FixF f -postpro_futu = g_postpro (distFutu id) - --- | A generalized-futumorphic postpromorphism -g_postpro_futu :: (Functor f, RunMonadFree h m) => Dist h f -> GCoalgebra f m a -> (f :~> f) -> a -> FixF f -g_postpro_futu k = g_postpro (distFutu k) - --- | Turn a distributive law for a functor into a distributive law for the free monad of that functor. --- This has been generalized to support generating distributive laws for a number of related free-monad-like --- constructions such as the Codensity monad of the free monad of a functor. -distFutu :: (Functor f, RunMonadFree h m) => Dist h f -> Dist m f -distFutu k = cataFree (fmap return) (fmap inFree . k) diff --git a/src/Control/Morphism/Histo.hs b/src/Control/Morphism/Histo.hs deleted file mode 100644 --- a/src/Control/Morphism/Histo.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Histo --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Traditional operators, shown here to show how to roll your own ----------------------------------------------------------------------------- -module Control.Morphism.Histo - ( distHisto - , histo, g_histo - , prepro_histo, g_prepro_histo - ) where - -import Control.Functor.Algebra -import Control.Functor.Extras -import Control.Functor.Fix -import Control.Comonad -import Control.Comonad.Cofree -import Control.Morphism.Cata -import Control.Morphism.Prepro - -distHisto :: (RunComonadCofree h w, Functor f) => Dist f h -> Dist f w -distHisto k = anaCofree (fmap extract) (k . fmap outCofree) - -histo :: (RunComonadCofree f w) => GAlgebra f w a -> FixF f -> a -histo = g_cata (distHisto id) - -g_histo :: (RunComonadCofree h w, Functor f) => Dist f h -> GAlgebra f w a -> FixF f -> a -g_histo k = g_cata (distHisto k) - --- A histomorphic prepromorphism -prepro_histo :: (RunComonadCofree f w) => GAlgebra f w a -> (f :~> f) -> FixF f -> a -prepro_histo = g_prepro (distHisto id) - --- A generalized histomorphic prepromorphism -g_prepro_histo :: (RunComonadCofree h w, Functor f) => Dist f h -> GAlgebra f w a -> (f :~> f) -> FixF f -> a -g_prepro_histo k = g_prepro (distHisto k) diff --git a/src/Control/Morphism/Hylo.hs b/src/Control/Morphism/Hylo.hs deleted file mode 100644 --- a/src/Control/Morphism/Hylo.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Hylo --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Generalized hylomorphisms ----------------------------------------------------------------------------- -module Control.Morphism.Hylo where - -import Control.Functor -import Control.Category -import Control.Category.Hask -import Prelude hiding ((.),id) -import Control.Comonad -import Control.Monad -import Control.Functor.Algebra -import Control.Functor.Extras -import Control.Functor.HigherOrder - --- | hylo :: (g b -> b) -> (forall c. f c -> g c) -> (a -> f b) -> a -> b -hylo :: Functor f => Algebra g b -> (f :~> g) -> Coalgebra f a -> a -> b -hylo f e g = f . e . fmap (hylo f e g). g - --- | g_hylo :: (Comonad w, Functor f, Monad m) => (forall d. g (w d) -> w (g d)) -> (forall e. m (f e) -> f (m e)) -> (g (w b) -> b) -> (forall c. f c -> g c) -> a -> f (m a) -> a -> b -g_hylo :: (Comonad w, Functor f, Monad m) => Dist g w -> Dist m f -> GAlgebra g w b -> (f :~> g) -> GCoalgebra f m a -> a -> b -g_hylo w m f e g = extract . h . return where h = liftW f . w . e . fmap (duplicate . h . join) . m . liftM g - --- The Jeremy Gibbons-style bifunctor-based version has the same expressive power, but may fuse with bimaps better - -bihylo :: (QFunctor f Hask Hask) => Algebra (g d) b -> (f c :~> g d) -> Coalgebra (f c) a -> a -> b -bihylo f e g = f . e . second (bihylo f e g). g - -g_bihylo :: (Comonad w, QFunctor f Hask Hask, Monad m) => - Dist (g d) w -> Dist m (f c) -> GAlgebra (g d) w b -> (f c :~> g d) -> GCoalgebra (f c) m a -> a -> b -g_bihylo w m f e g = extract . h . return where h = liftW f . w . e . second (duplicate . h . join) . m . liftM g - --- | higher order hylomorphisms for use in building up and tearing down higher order functors -hhylo :: HFunctor f => HAlgebra f b -> HCoalgebra f a -> a :~> b -hhylo f g = f . hfmap (hhylo f g) . g - diff --git a/src/Control/Morphism/Meta/Erwig.hs b/src/Control/Morphism/Meta/Erwig.hs deleted file mode 100644 --- a/src/Control/Morphism/Meta/Erwig.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Meta.Erwig --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Martin Erwig's metamorphisms for indexed data types. --- --- ADT fusion: @snd c . fst c == id => erwig d id c . erwig c id d' = erwig d id d'@ --- --- FreeMeta: @l strict, snd c == snd c' == phi', fst d == fst d' == alpha, l . fst c = fst c' . fmap l, snd d' . rr = fmap r . snd d ==> l . (erwig d id c) = (erwig d' id c') . r@ ----------------------------------------------------------------------------- -module Control.Morphism.Meta.Erwig - ( meta - ) where - -import Control.Functor.Algebra -import Control.Functor.Extras -import Control.Morphism.Hylo - --- | @meta d f c@ is Martin Erwig's metamorphism from @c@ to @d@ -meta :: Functor h => Bialgebra m n b -> (h :~> m) -> Bialgebra f h a -> a -> b -meta d f c = hylo (fst d) f (snd c) - diff --git a/src/Control/Morphism/Meta/Gibbons.hs b/src/Control/Morphism/Meta/Gibbons.hs deleted file mode 100644 --- a/src/Control/Morphism/Meta/Gibbons.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Meta.Gibbons --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- A very basic Jeremy Gibbons metamorphism, without all --- the productive stream stuff. See: --- --- TODO: Add some support for spigot algorithms over streams/lists. ----------------------------------------------------------------------------- -module Control.Morphism.Meta.Gibbons - ( meta - , g_meta - ) where - -import Control.Functor.Algebra -import Control.Functor.Extras -import Control.Functor.Fix -import Control.Comonad -import Control.Monad.Identity -import Control.Morphism.Ana -import Control.Morphism.Cata - --- Jeremy Gibbons' metamorphism -meta :: (Functor f, Functor g) => - Coalgebra f b -> (a -> b) -> Algebra g a -> FixF g -> FixF f -meta f e g = ana f . e . cata g - --- | Generalized Jeremy Gibbons metamorphism -g_meta :: (Monad m, Functor f, Comonad w, Functor g) => - Dist m f -> Dist g w -> GCoalgebra f m b -> (a -> b) -> GAlgebra g w a -> FixF g -> FixF f -g_meta m w f e g = g_ana m f . e . g_cata w g - diff --git a/src/Control/Morphism/Para.hs b/src/Control/Morphism/Para.hs deleted file mode 100644 --- a/src/Control/Morphism/Para.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Para --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- ----------------------------------------------------------------------------- -module Control.Morphism.Para - ( Para - , ParaT - , distParaT - , para, g_para - , prepro_para, g_prepro_para - ) where - -import Control.Comonad -import Control.Comonad.Reader -import Control.Functor.Algebra -import Control.Functor.Extras -import Control.Functor.Fix -import Control.Morphism.Cata -import Control.Morphism.Zygo -import Control.Morphism.Prepro - --- * Paramorphisms use Reader Comonads -type Para f = (,) (FixF f) -type ParaT w f = CoreaderT w (FixF f) - --- * Distributive Laws -distParaT :: (Functor f, Comonad w) => Dist f w -> Dist f (ParaT w f) -distParaT = distZygoT (liftAlgebra InF) - --- * Paramorphism -para :: Functor f => GAlgebra f (Para f) a -> FixF f -> a -para = zygo InF - --- | Generalized paramorphisms using a comonad reader transformer to carry the primitive recursive state -g_para :: (Functor f, Comonad w) => Dist f w -> GAlgebra f (ParaT w f) a -> FixF f -> a -g_para f = g_cata (distParaT f) - --- | A paramorphic prepromorphism -prepro_para :: Functor f => GAlgebra f (Para f) a -> (f :~> f) -> FixF f -> a -prepro_para = prepro_zygo InF - --- | A generalized paramorphic prepromorphism -g_prepro_para :: (Functor f, Comonad w) => Dist f w -> GAlgebra f (ParaT w f) a -> (f :~> f) -> FixF f -> a -g_prepro_para f = g_prepro (distParaT f) diff --git a/src/Control/Morphism/Postpro.hs b/src/Control/Morphism/Postpro.hs deleted file mode 100644 --- a/src/Control/Morphism/Postpro.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Postpro --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- See Maarten Fokkinga''s PhD Dissertation for postpro. g_postpro is --- an obvious generalization. ----------------------------------------------------------------------------- -module Control.Morphism.Postpro - ( postpro - , g_postpro - , bipostpro - , g_bipostpro - ) where - -import Control.Monad -import Control.Category.Hask -import Control.Functor -import Control.Functor.Algebra -import Control.Functor.Extras -import Control.Functor.Fix -import Control.Morphism.Ana - --- prepro f e = x where x = f . fmap (x . cata (InF . e)) . outF -postpro :: Functor f => Coalgebra f c -> (f :~> f) -> c -> FixF f -postpro g e = x where x = InF . fmap (ana (e . outF) . x) . g - --- | Generalized postpromorphisms -g_postpro :: (Functor f, Monad m) => Dist m f -> GCoalgebra f m a -> (f :~> f) -> a -> FixF f -g_postpro k g e = a . return where a = InF . fmap (ana (e . outF) . a . join) . k . liftM g - -bipostpro :: Bifunctor f Hask Hask Hask => Coalgebra (f a) c -> (f a :~> f a) -> c -> Fix f a -bipostpro g e = x where x = InB . bimap id (biana (e . outB) . x) . g - -g_bipostpro :: (Bifunctor f Hask Hask Hask, Monad m) => Dist m (f a) -> GCoalgebra (f a) m c -> (f a :~> f a) -> c -> Fix f a -g_bipostpro k g e = a . return where a = InB . bimap id (biana (e . outB) . a . join) . k . liftM g diff --git a/src/Control/Morphism/Prepro.hs b/src/Control/Morphism/Prepro.hs deleted file mode 100644 --- a/src/Control/Morphism/Prepro.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Prepro --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- See Maarten Fokkinga''s PhD Dissertation for cascade and prepro. --- g_prepro is an obvious generalization. The prepro variants of other --- morphisms are distributed through the corresponding files. ----------------------------------------------------------------------------- -module Control.Morphism.Prepro - ( prepro, g_prepro, cascade, biprepro, g_biprepro - ) where - -import Control.Comonad -import Control.Category.Hask -import Control.Functor -import Control.Functor.Pointed -import Control.Functor.Algebra -import Control.Functor.Extras -import Control.Functor.Fix -import Control.Monad.Identity -import Control.Morphism.Cata - --- | @cascade f . map f = map f . cascade f@ --- --- @cascade f = biprepro InB (first f)@ --- --- @cascade f = x where x = InB . bimap id (x . fmap f) . outB@ --- --- @cascade f = x where x = InB . bimap id (fmap f . x) . outB@ - --- @cascade f = biprepro InB (first f)@ -cascade :: Bifunctor s Hask Hask Hask => (a -> a) -> Fix s a -> Fix s a -cascade f = x where x = InB . bimap id (x . fmap f) . outB - --- | Fokkinga's Prepromorphism -prepro :: Functor f => Algebra f c -> (f :~> f) -> FixF f -> c -prepro f e = x where x = f . fmap (x . cata (InF . e)) . outF - --- | Generalized prepromorphisms, parameterized by a comonad --- This is used to generate most of the specialized prepromorphisms in other modules. --- You can use the distributive law combinators to build up analogues of other recursion --- schemes. -g_prepro :: (Functor f, Comonad w) => Dist f w -> GAlgebra f w a -> (f :~> f) -> FixF f -> a -g_prepro k g e = extract . c where c = liftW g . k . fmap (duplicate . c . cata (InF . e)) . outF - --- | Prepromorphisms for bifunctors -biprepro :: Bifunctor f Hask Hask Hask => Algebra (f a) c -> (f a :~> f a) -> Fix f a -> c -biprepro f e = x where x = f . bimap id (x . bicata (InB . e)) . outB - --- | Generalized bifunctor prepromorphism, parameterized by a comonad -g_biprepro :: (Bifunctor f Hask Hask Hask, Comonad w) => Dist (f a) w -> GAlgebra (f a) w c -> (f a :~> f a) -> Fix f a -> c -g_biprepro k g e = extract . c where c = liftW g . k . bimap id (duplicate . c . bicata (InB . e)) . outB diff --git a/src/Control/Morphism/Span.hs b/src/Control/Morphism/Span.hs deleted file mode 100644 --- a/src/Control/Morphism/Span.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Span --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Spans and Cospans --- ----------------------------------------------------------------------------- -module Control.Morphism.Span - ( Span(..) - , Cospan(..) - ) where - -newtype Span (~>) x y z = Span { runSpan :: (y ~> x, y ~> z) } -newtype Cospan (~>) x y z = Cospan { runCospan :: (x ~> y, z ~> y) } diff --git a/src/Control/Morphism/Synchro.hs b/src/Control/Morphism/Synchro.hs deleted file mode 100644 --- a/src/Control/Morphism/Synchro.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Synchro --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- --- Martin Erwig's synchromorphisms. ----------------------------------------------------------------------------- -module Control.Morphism.Synchro where - -import Control.Category.Cartesian ((&&&)) -import Control.Category.Hask -import Control.Functor -import Control.Functor.Algebra - --- | @synchro d' f d g1 g2 d''@ is Martin Erwig's @d,d''-synchromorphism to d'@. Mostly useful for graph algorithms. -synchro :: - QFunctor h Hask Hask => - Bialgebra m n c -> - (h x (Either a c) -> m c) -> - Trialgebra (f x) (g x) (h x) a -> - ((h x a, b) -> k x b) -> - ((h x a, j x b) -> h x (Either a (g x a, b))) -> - Bialgebra (k x) (j x) b -> - (g x a, b) -> c - --- g1 --- h = D' <- D <-> D'' --- f g2 --- dfs = List <- Graph <-> Stack -- depth-first search --- bfs = List <- Graph <-> Queue -- breadth-first search - -synchro d' f d g1 g2 d'' = h where - h = fst d' . f . second (second h) . g2 . (fst &&& (snd d'' . fst d'' . g1)) . first (snd d) - -- (g x a, b) >- first (snd d) -> - -- (h x a, b) >- (fst &&& g1) -> - -- (h x a, k x b) >- second (fst d'') -> - -- (h x a, b) >- second (snd d'') -> - -- (h x a, j x b) >- g2 -> - -- (h x (Either a (g x a, b)) >- second (second h) -> - -- (h x (Either a c)) >- f -> - -- m c >- fst d' - -- c diff --git a/src/Control/Morphism/Universal.hs b/src/Control/Morphism/Universal.hs deleted file mode 100644 --- a/src/Control/Morphism/Universal.hs +++ /dev/null @@ -1,46 +0,0 @@ -------------------------------------------------------------------------------------------- --- | --- Module : Control.Morphism.Universal --- Copyright : 2008 Edward Kmett --- License : BSD3 --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : portable --- --- Note the choice of which is universal and which is couniversal is chosen to --- make the definitions consistent with limits and colimits. - -------------------------------------------------------------------------------------------- - -module Control.Morphism.Universal - ( Couniversal(..), extractCouniversal, couniversalize - , couniversalIdentity - , Universal(..), extractUniversal, universalize - , universalIdentity - ) where - -import Control.Monad.Identity - -data Couniversal a f x = Couniversal (a -> f x) (forall z. (a -> f z) -> x -> z) - -extractCouniversal :: Couniversal a f x -> a -> f x -extractCouniversal (Couniversal f _) = f - -couniversalize :: (a -> f z) -> Couniversal a f x -> x -> z -couniversalize f (Couniversal _ s) = s f - -couniversalIdentity :: Couniversal a Identity a -couniversalIdentity = Couniversal Identity (runIdentity .) - -data Universal a f x = Universal (f x -> a) (forall z. (f z -> a) -> z -> x) - -extractUniversal :: Universal a f x -> f x -> a -extractUniversal (Universal f _) = f - -universalize :: Universal a f x -> (f z -> a) -> z -> x -universalize (Universal _ s) f = s f - -universalIdentity :: Universal a Identity a -universalIdentity = Universal runIdentity (. Identity) - diff --git a/src/Control/Morphism/Zygo.hs b/src/Control/Morphism/Zygo.hs deleted file mode 100644 --- a/src/Control/Morphism/Zygo.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Morphism.Zygo --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism) --- ----------------------------------------------------------------------------- -module Control.Morphism.Zygo - ( Zygo, ZygoT - , distZygo, distZygoT - , zygo - , g_zygo - , prepro_zygo - , g_prepro_zygo - ) where - -import Control.Arrow ((&&&)) -import Control.Comonad -import Control.Comonad.Reader -import Control.Functor.Algebra -import Control.Functor.Extras -import Control.Functor.Fix -import Control.Morphism.Cata -import Control.Morphism.Prepro - -type Zygo = (,) -type ZygoT = CoreaderT - --- * Distributive Law Combinators - -distZygo :: Functor f => Algebra f b -> Dist f (Zygo b) -distZygo g = g . fmap fst &&& fmap snd - -distZygoT :: (Functor f, Comonad w) => GAlgebra f w b -> Dist f w -> Dist f (ZygoT w b) -distZygoT g k = CoreaderT . liftW (g . fmap (liftW fst) &&& fmap (snd . extract)) . k . fmap (duplicate . runCoreaderT) - -zygo :: Functor f => Algebra f b -> GAlgebra f (Zygo b) a -> FixF f -> a -zygo f = g_cata (distZygo f) - -g_zygo :: (Functor f, Comonad w) => GAlgebra f w b -> Dist f w -> GAlgebra f (ZygoT w b) a -> FixF f -> a -g_zygo f w = g_cata (distZygoT f w) - --- | a zygomorphic prepromorphism -prepro_zygo :: Functor f => Algebra f b -> GAlgebra f (Zygo b) a -> (f :~> f) -> FixF f -> a -prepro_zygo f = g_prepro (distZygo f) - --- | a generalized zygomorphic prepromorphism -g_prepro_zygo :: (Functor f, Comonad w) => GAlgebra f w b -> Dist f w -> GAlgebra f (ZygoT w b) a -> (f :~> f) -> FixF f -> a -g_prepro_zygo f w = g_prepro (distZygoT f w) diff --git a/src/Data/Void.hs b/src/Data/Void.hs deleted file mode 100644 --- a/src/Data/Void.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Void --- Copyright : (C) 2008 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable (empty data declaration) --- ----------------------------------------------------------------------------- -module Data.Void where - -data Void - -void :: Void -> a -void = undefined