diff --git a/Control/Comonad.hs b/Control/Comonad.hs deleted file mode 100644 --- a/Control/Comonad.hs +++ /dev/null @@ -1,149 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Comonad --- Copyright : 2004 Dave Menendez --- License : BSD3 --- --- Maintainer : dan.doel@gmail.com --- Stability : experimental --- Portability : portable --- --- This module declares the 'Comonad' class, with instances for --- 'Identity' and @((,) a)@, and defines the 'CoKleisli' arrow. ------------------------------------------------------------------------------ - -module Control.Comonad - ( - -- * The Comonad class - Comonad(..) - , (=>>) - , (.>>) - , liftW - - -- * The coKleisli arrow - , CoKleisli(..) - - -- * The product comonad - , local - - -- * Additional functions - , sequenceW - , mapW - , parallelW - , unfoldW - )where - -import Control.Arrow -import Control.Functor() - -import Control.Monad.Identity - -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 => Comonad w where - extract :: w a -> a - duplicate :: w a -> w (w a) - extend :: (w a -> b) -> (w a -> w b) - - extend f = fmap f . duplicate - duplicate = extend id - --- | 'fmap' defined in terms of 'extend' -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 - - --- - -instance Comonad Identity where - extract (Identity x) = x - duplicate y = Identity y - extend c w = Identity (c w) - -instance Comonad ((,) a) where - extract (_,x) = x - duplicate (c,x) = (c,(c,x)) - --- | Calls a comonadic function in a modified context -local :: (c -> c') -> ((c',a) -> a) -> ((c,a) -> a) -local g f (c,x) = f (g c, x) - --- - -newtype CoKleisli w a b = CoKleisli { unCoKleisli :: 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 (b . fmap a . duplicate) - - CoKleisli a &&& CoKleisli b - = CoKleisli (a &&& b) - - CoKleisli a *** CoKleisli b - = CoKleisli (a . fmap fst &&& b . fmap snd) - - first a = a *** arr id - second a = arr id *** a - --- - -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 diff --git a/Control/Comonad/Cofree.hs b/Control/Comonad/Cofree.hs deleted file mode 100644 --- a/Control/Comonad/Cofree.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE Rank2Types #-} - ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Free --- Copyright : 2004 Dave Menendez --- License : BSD3 --- --- Maintainer : dan.doel@gmail.com --- Stability : experimental --- Portability : portable --- --- An implementation of the cofree comonad of a functor, used in --- histomorphisms and chronomorphisms in Control.Recursion. The --- cofree comonad can also be seen as a stream parameterized by a --- functor that controls its branching factor. --- ------------------------------------------------------------------------------ - -module Control.Comonad.Cofree - ( Cofree(..) - , headCofree - , tailCofree - , anaCofree - , cofreeToList - , distribCofree - ) where - -import Control.Arrow ((&&&),(***),(>>>), second) -import Control.Comonad - -{-| -The cofree comonad of a functor @h@ (also known as an H-branching stream). -Various comonads are a special instance of the cofree comonad: - -* @Cofree Identity@ is an infinite stream - -* @Cofree Maybe@ is a non-empty stream - -* @Cofree []@ is a rose tree - -formally: - -> Cofree H A = nu X. A * HX --} -data Cofree h a = Cofree { unCofree :: (a, h (Cofree h a)) } - --- | anamorphism for building a cofree comonad from a seed -anaCofree :: Functor h => (a -> b) -> (a -> h a) -> a -> Cofree h b -anaCofree g1 g2 = g1 &&& fmap (anaCofree g1 g2) . g2 >>> Cofree - -headCofree :: Cofree h a -> a -headCofree = fst . unCofree - -tailCofree :: Cofree h a -> h (Cofree h a) -tailCofree = snd . unCofree - -instance Functor h => Functor (Cofree h) where - fmap g = unCofree >>> g *** fmap (fmap g) >>> Cofree - -instance Functor h => Comonad (Cofree h) where - extract = headCofree - duplicate = anaCofree id tailCofree - --- | Converts a value of the cofree comonad over Maybe into a non-empty list. -cofreeToList :: Cofree Maybe a -> [a] -cofreeToList = unCofree >>> second (maybe [] cofreeToList) >>> uncurry (:) - --- | Lifts a distributive law of @f@ over @h@ to a distributive law --- of @f@ over @Cofree h@. -distribCofree :: (Functor h, Functor f) => - (forall a. f (h a) -> h (f a)) - -> (forall a. f (Cofree h a) -> Cofree h (f a)) -distribCofree d = anaCofree (fmap headCofree) (d . fmap tailCofree) diff --git a/Control/Comonad/Context.hs b/Control/Comonad/Context.hs deleted file mode 100644 --- a/Control/Comonad/Context.hs +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Comonad.Context --- Copyright : 2004 Dave Menendez --- License : BSD3 --- --- Maintainer : dan.doel@gmail.com --- Stability : experimental --- Portability : portable --- --- Defines the state-in-context comonad, which is dual to the state monad. --- Each operation in the context comonad runs in a context determined --- by /later/ operations. (Observe, for example, 'experiment', which runs --- the preceeding operations multiple times in different contexts and --- returns a list of results.) --- ------------------------------------------------------------------------------ - -module Control.Comonad.Context - ( Context(..) - , get - , modify - , experiment - , liftCtx - ) where - -import Control.Comonad - -data Context c a = Context (c -> a) c - -instance Functor (Context c) where - fmap g (Context f c) = Context (g . f) c - -instance Comonad (Context c) where - extract (Context f c) = f c - duplicate (Context f c) = Context (Context f) c - --- | Returns the context -get :: Context c a -> c -get (Context _ c) = c - --- | Returns the result of the preceeding operations running in --- a modified context -modify :: (c -> c) -> Context c a -> a -modify m (Context f c) = f (m c) - --- | Returns a list of results created by running prior operations --- in modified contexts created by the list of context-modifiers. -experiment :: [c -> c] -> Context c a -> [a] -experiment ms (Context f c) = map (\m -> f (m c)) ms - -{-| -Lifts an operation into the context comonad. Syntactic sugar -for @fmap@ when chaining comonad operations. - -@ - liftCtx == extract . fmap f - w =>> liftCtx f == fmap f w -@ --} -liftCtx :: (a -> b) -> Context c a -> b -liftCtx g (Context f c) = g (f c) - -{- -inContext :: ((c -> a) -> c -> b) -> Context c a -> b -inContext op (Context f c) = op f c - -get = inContext (\f c -> c) -modify m = inContext (\f c -> f (m c)) --} diff --git a/Control/Functor.hs b/Control/Functor.hs deleted file mode 100644 --- a/Control/Functor.hs +++ /dev/null @@ -1,113 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Functor --- Copyright : 2004 Dave Menendez --- License : BSD3 --- --- Maintainer : dan.doel@gmail.com --- Stability : experimental --- Portability : portable --- --- Functor composition, standard functors, and more. --- ------------------------------------------------------------------------------ - -module Control.Functor - ( - -- * Unary functors - -- ** Composition - O(..) - , lComp - , rComp - -- ** Basic Instances - -- *** Unit - , Unit(..) - - -- *** Const - , Const(..) - - -- * Binary functors - , Bifunctor(..) - - -- * Trinary functors - , Trifunctor(..) - ) where - -infixr 2 `O` - -{-| -Functor composition. - -(Note: Some compilers will let you write @f \`O\` g@ rather than @O f g@; -we'll be doing so here for readability.) - -Functor composition is associative, so @f \`O\` (g \`O\` h)@ and @(f \`O\` g) \`O\` h@ -are equivalent. The functions 'lComp' and 'rComp' convert between the two. -(Operationally, they are equivalent to @id@. Their only purpose is to affect -the type system.) --} -newtype (O f g) a = Comp { deComp :: f (g a) } - -instance (Functor f, Functor g) => Functor (O f g) where - fmap f = Comp . fmap (fmap f) . deComp - -lComp :: (Functor f) => (O f (O g h)) a -> (O (O f g) h) a -lComp = Comp . Comp . fmap deComp . deComp - -rComp :: (Functor f) => (O (O f g) h) a -> (O f (O g h)) a -rComp = Comp . fmap Comp . deComp . deComp - -{-| -The unit functor. - -(Note: this is not the same as @()@. In fact, 'Unit' is the -fixpoint of @()@.) --} -data Unit a = Unit deriving (Show) - -instance Functor Unit where - fmap _ _ = Unit - -instance Monad Unit where - return _ = Unit - _ >>= _ = Unit - -{-| -Constant functors. Essentially the same as 'Unit', except that they also -carry a value. --} -data Const t a = Const { unConst :: t } deriving (Show) - -instance Functor (Const t) where - fmap _ (Const t) = Const t - -{-| -A type constructor which takes two arguments and an associated map function. - -Informally, @Bifunctor f@ implies @Functor (f a)@ with @fmap = bimap id@. --} -class Bifunctor f where - bimap :: (a -> c) -> (b -> d) -> (f a b -> f c d) - -instance Bifunctor (,) where - bimap f g (x,y) = (f x, g y) - -instance Bifunctor Either where - bimap f _ (Left x) = Left (f x) - bimap _ g (Right x) = Right (g x) - -{- -instance (Trifunctor f) => Bifunctor (f a) where - bimap = trimap id --} -{-| -A type constructor which takes three arguments and an associated map function. - -Informally, @Trifunctor f@ implies @Bifunctor (f a)@ with @bimap = trimap id@. --} - -class Trifunctor f where - trimap :: (a -> a') -> (b -> b') -> (c -> c') -> (f a b c -> f a' b' c') - -instance Trifunctor (,,) where - trimap f g h (x,y,z) = (f x, g y, h z) diff --git a/Control/Functor/Adjunction.hs b/Control/Functor/Adjunction.hs deleted file mode 100644 --- a/Control/Functor/Adjunction.hs +++ /dev/null @@ -1,51 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.Adjunction --- Copyright : 2004 Dave Menendez --- License : BSD3 --- --- Maintainer : dan.doel@gmail.com --- Stability : experimental --- Portability : non-portable (fundeps) --- ------------------------------------------------------------------------------ - -module Control.Functor.Adjunction where - -import Control.Functor -import Control.Comonad - -{-| -Minimal definitions: - -1. @leftAdjunct@ and @rightAdjunct@ - -2. @unit@ and @counit@ - -Given functors @f@ and @g@, @Adjunction f g@ implies @Monad (g `'O'` f)@ and -@'Comonad' (f `'O'` g)@. - --} -class (Functor f, Functor g) => Adjunction f g | f -> g, g -> f where - leftAdjunct :: (f a -> b) -> a -> g b - rightAdjunct :: (a -> g b) -> f a -> b - - unit :: a -> g (f a) - counit :: f (g a) -> a - - unit = leftAdjunct id - counit = rightAdjunct id - leftAdjunct f = fmap f . unit - rightAdjunct g = counit . fmap g - -instance (Adjunction f g) => Monad (O g f) where - return = Comp . unit - m >>= k = Comp . fmap (rightAdjunct (deComp . k)) . deComp $ m - -instance (Adjunction f g) => Comonad (O f g) where - extract = counit . deComp - extend f = Comp . fmap (leftAdjunct (f . Comp)) . deComp - -instance Adjunction ((,) a) ((->) a) where - unit t = \x -> (x,t) - counit (x,f) = f x diff --git a/Control/Functor/Transform.hs b/Control/Functor/Transform.hs deleted file mode 100644 --- a/Control/Functor/Transform.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE Rank2Types, TypeOperators #-} - ------------------------------------------------------------------------------ --- | --- Module : Control.Functor.Transform --- Copyright : 2004 Dave Menendez --- License : BSD3 --- --- Maintainer : dan.doel@gmail.com --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism, infix type constructors) --- --- Description ------------------------------------------------------------------------------ - -module Control.Functor.Transform - ( module Control.Functor - , (:>) - , funcTrans - , transFunc - , (.>) - ) where - -import Control.Functor - -{- -Let F,G: C -> D be functors. Then t: F -> G is a natural transformation from -F to G iff: - 1. forall a in Ob(C). t[a] in D[F(a),G(a)] - 2. forall f in C[a,b]. t[b] . F(f) = G(f) . t[a] - -Thus, a transformation t must satisfy: - t . fmap f = fmap f . t -for any f --} - -infix 1 :> - -type f :> g = forall a. f a -> g a - -{- -maybeToList :: Maybe :> [] -listToMaybe :: [] :> Maybe --} - -transFunc :: (Functor k) => f :> g -> k `O` f :> k `O` g -transFunc t = Comp . fmap t . deComp - -funcTrans :: f :> g -> f `O` h :> g `O` h -funcTrans t = Comp . t . deComp - - -(.>) :: (Functor k) => h :> k -> f :> g -> h `O` f :> k `O` g -s .> t = Comp . fmap t . s . deComp diff --git a/Control/Monad/Free.hs b/Control/Monad/Free.hs deleted file mode 100644 --- a/Control/Monad/Free.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE Rank2Types #-} - ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Free --- Copyright : 2008 Dan Doel, Edward Kmett --- License : BSD3 --- --- Maintainer : dan.doel@gmail.com --- Stability : experimental --- Portability : non-portable (rank-2 types) --- --- An implementation of the free monad of a functor, used in (at the least) --- futumorphisms and chronomorphisms in Control.Recursion --- ------------------------------------------------------------------------------ - -module Control.Monad.Free - ( Free() - , inFree - , cataFree - , distribFree - ) where - -import Control.Arrow ((|||), (+++), (>>>)) -import Control.Applicative -import Control.Monad - --- | The free monad of a functor 'f', formally, --- --- > Free F A = mu X. A + FX -newtype Free f a = Free { unFree :: Either a (f (Free f a)) } - -instance (Functor f) => Functor (Free f) where - fmap f = unFree >>> f +++ fmap (fmap f) >>> Free - - -instance (Functor f) => Applicative (Free f) where - pure = return - (<*>) = ap - -instance (Functor f) => Monad (Free f) where - return = Free . Left - (Free e) >>= f = either f (inFree . fmap (>>= f)) e - --- | The catamorphism for the free monad -cataFree :: Functor f => (a -> b) -> (f b -> b) -> Free f a -> b -cataFree f g = unFree >>> f ||| g . fmap (cataFree f g) - -inFree :: f (Free f a) -> Free f a -inFree = Free . Right - --- | Lifts a distributive law of @h@ over @f@ to a distributive --- law of @Free h@ over @f@ -distribFree :: (Functor f, Functor h) => - (forall a. h (f a) -> f (h a)) - -> (forall a. Free h (f a) -> f (Free h a)) -distribFree d = cataFree (fmap return) (fmap inFree . d) diff --git a/Control/Recursion.hs b/Control/Recursion.hs deleted file mode 100644 --- a/Control/Recursion.hs +++ /dev/null @@ -1,527 +0,0 @@ -{-# LANGUAGE - Rank2Types - , MultiParamTypeClasses - , FunctionalDependencies - , FlexibleInstances - #-} - ------------------------------------------------------------------------------ --- | --- Module : Control.Recursion --- Copyright : 2004 Dave Menendez --- License : BSD3 --- --- Maintainer : dan.doel@gmail.com --- Stability : experimental --- Portability : non-portable (rank-2 polymorphism, fundeps) --- --- Provides implementations of /catamorphisms/ ('fold'), --- /anamorphisms/ ('unfold'), and /hylomorphisms/ ('refold'), --- along with many generalizations implementing various --- forms of iteration and coiteration. --- --- Also provided is a type class for transforming a functor --- to its fixpoint type and back ('Fixpoint'), along with --- standard functors for natural numbers and lists ('ConsPair'), --- and a fixpoint type for arbitrary functors ('Fix'). --- --- Several combinators herein ((g_)futu, (g_)chrono, refoldWith, ...) --- are due to substantial help by Edward Kmett. --- ------------------------------------------------------------------------------ - -module Control.Recursion - ( - -- * Folding - fold - , para - , zygo - , histo - , g_histo - , foldWith - - -- * Unfolding - , unfold - , apo - , g_apo - , unfoldWith - , futu - , g_futu - - -- * Transforming - , refold - , refoldWith - , chrono - , g_chrono - - -- * Dynamic Programming - , dyna - , g_dyna - , codyna - , g_codyna - - -- * Functor fixpoints - , Fixpoint(..) - , Fix(..) - , ConsPair(..) - , cons - - ) where - ----- -import Control.Arrow -import Control.Functor -import Control.Monad.Identity -import Control.Monad.Free -import Control.Comonad -import Control.Comonad.Cofree - -class Functor f => Fixpoint f t | t -> f where - inF :: f t -> t - -- ^ formally, @in[f]: f -> mu f@ - - outF :: t -> f t - -- ^ formally, @in^-1[f]: mu f -> f@ - --- | Creates a fixpoint for any functor. -newtype Fix f = In (f (Fix f)) - -instance Functor f => Fixpoint f (Fix f) where - inF = In - outF (In f) = f - -instance Fixpoint Unit () where - inF Unit = () - outF () = Unit - -instance Fixpoint Maybe Int where - inF Nothing = 0 - inF (Just n) = n + 1 - - outF n | n > 0 = Just (n - 1) - | otherwise = Nothing - -instance Fixpoint Maybe Integer where - inF Nothing = 0 - inF (Just n) = n + 1 - - outF n | n > 0 = Just (n - 1) - | otherwise = Nothing - --- | Fixpoint of lists -data ConsPair a b = Nil | Pair a b deriving (Eq, Show) - -instance Functor (ConsPair a) where - fmap _ Nil = Nil - fmap f (Pair a b) = Pair a (f b) - -instance Fixpoint (ConsPair a) [a] where - inF Nil = [] - inF (Pair a b) = a : b - - outF [] = Nil - outF (x:xs) = Pair x xs - - --- | Deconstructor for 'ConsPair' -cons :: c -> (a -> b -> c) -> (ConsPair a b -> c) -cons d _ Nil = d -cons _ f (Pair a b) = f a b - -{-| -A generalized @map@, known formally as a /hylomorphism/ and written [| f, g |]. - -@ - refold f g == 'fold' f . 'unfold' g -@ --} -refold :: Functor f => (f b -> b) -> (a -> f a) -> a -> b -refold f g = f . fmap (refold f g) . g - -{-| -A generalized @foldr@, known formally as a /catmorphism/ and written (| f |). - -@ - fold f == 'refold' f 'outF' - fold f == 'foldWith' ('Identity' . fmap 'runIdentity') (f . fmap 'runIdentity') -@ --} -fold :: Fixpoint f t => (f a -> a) -> t -> a -fold f = refold f outF - -{-| -A generalized @unfoldr@, known formally as an /anamorphism/ and written [( f )]. - -@ - unfold f == 'refold' 'inF' f - unfold f == 'unfoldWith' (fmap 'Identity' . 'unIdentity') (fmap 'Identity' . f) -@ --} -unfold :: Fixpoint f t => (a -> f a) -> a -> t -unfold f = refold inF f - -{-| -A variant of 'fold' where the function /f/ also receives the result of the -inner recursive calls. Formally known as a /paramorphism/ and written \<| f |\>. -Dual to 'apo'. - -@ - para == 'zygo' 'inF' - para f == 'refold' f (fmap (id &&& id) . 'outF') - para f == f . fmap (id &&& para f) . 'outF' -@ - -Example: Computing the factorials. - -> fact :: Integer -> Integer -> fact = para g -> where -> g Nothing = 1 -> g (Just (n,f)) = f * (n + 1) - -* For the base case 0!, @g@ is passed @Nothing@. (Note that @'inF' Nothing == 0@.) - -* For subsequent cases (/n/+1)!, @g@ is passed /n/ and /n/!. -(Note that @'inF' (Just n) == n + 1@.) - -Point-free version: @fact = para $ maybe 1 (uncurry (*) . first (+1))@. - -Example: @dropWhile@ - -> dropWhile :: (a -> Bool) -> [a] -> [a] -> dropWhile p = para f -> where -> f Nil = [] -> f (Pair x xs) = if p x then snd xs else x : fst xs - -Point-free version: - -> dropWhile p = para $ cons [] (\x xs -> if p x then snd xs else x : fst xs) --} -para :: Fixpoint f t => (f (t,a) -> a) -> t -> a -para = zygo inF - - -{-| -Implements course-of-value recursion. At each step, the function -receives an F-branching stream ('Cofree') containing the previous -values. Formally known as a /histomorphism/ and written {| f |}. - -@ - histo == 'g_histo' id -@ - -Example: Computing Fibonacci numbers. - -> fibo :: Integer -> Integer -> fibo = histo next -> where -> next :: Maybe (Cofree Maybe Integer) -> Integer -> next Nothing = 0 -> next (Just (Consf _ Nothing)) = 1 -> next (Just (Consf m (Just (Consf n _)))) = m + n - -* For the base case F(0), @next@ is passed @Nothing@ and returns 0. -(Note that @'inF' Nothing == 0@) - -* For F(1), @next@ is passed a one-element stream, and returns 1. - -* For subsequent cases F(/n/), @next@ is passed a the stream -[F(/n/-1), F(/n/-2), ..., F(0)] and returns F(/n/-1)+F(/n/-2). - --} - -histo :: Fixpoint f t => (f (Cofree f a) -> a) -> t -> a -histo = g_histo id - ------ - -{-| -A generalization of 'para' implementing \"semi-mutual\" recursion. -Known formally as a /zygomorphism/ and written \<| f |\>^g, where /g/ is an -auxiliary function. Dual to 'g_apo'. - -@ - zygo g == 'foldWith' (g . fmap fst &&& fmap snd) -@ --} -zygo :: Fixpoint f t => (f b -> b) -> (f (b,a) -> a) -> t -> a -zygo g f = snd . fold (g . fmap fst &&& f) - - -{-| -Generalizes 'histo' to cases where the recursion functor and the -stream functor are distinct. Known as a /g-histomorphism/. - -@ - g_histo g == 'foldWith' ('anaCofree' (fmap 'headCofree') (g . fmap 'tailCofree')) -@ --} -g_histo :: (Functor h, Fixpoint f t) - => (forall b. f (h b) -> h (f b)) -- distributive law for /h/ and /f/ - -> (f (Cofree h a) -> a) -> t -> a -g_histo = foldWith . distribCofree - - -{-| -Generalizes 'fold', 'zygo', and 'g_histo'. Formally known as a /g-catamorphism/ -and written (| f |)^(w,k), where /w/ is a 'Comonad' and /k/ is a distributive law between -/n/ and the functor /f/. - -The behavior of @foldWith@ is determined by the comonad /w/. - -* 'Identity' recovers 'fold' - -* @((,) a)@ recovers 'zygo' (and 'para') - -* 'Cofree' recovers 'g_histo' (and 'histo') - --} -foldWith :: (Fixpoint f t, Comonad w) - => (forall b. f (w b) -> w (f b)) -- distributive law for /f/ and /w/ - -> (f (w a) -> a) -> t -> a -foldWith k f = extract . fold (fmap f . k . fmap duplicate) - ----- - -{-| /apomorphisms/, dual to 'para' - -@ - apo == 'g_apo' 'outF' - apo f == 'inF' . fmap (id ||| apo f) . f -@ - -Example: Appending a list to another list - -> append :: [a] -> [a] -> [a] -> append = curry (apo f) -> where -> f :: ([a],[a]) -> ConsPair a (Either [a] ([a],[a])) -> f ([], []) = Nil -> f ([], y:ys) = Pair y (Left ys) -> f (x:xs, ys) = Pair x (Right (xs,ys)) - --} -apo :: Fixpoint f t => (a -> f (Either t a)) -> a -> t -apo = g_apo outF - -{-| -Generalized apomorphisms, dual to 'zygo' - -@ - g_apo g == 'unfoldWith' (fmap Left . g ||| fmap Right) -@ --} -g_apo :: Fixpoint f t => (b -> f b) -> (a -> f (Either b a)) -> a -> t -g_apo g f = unfold (fmap Left . g ||| f) . Right - - -{-| -Generalized anamorphisms parameterized by a monad, dual to 'foldWith' - - * @Identity@ recovers 'unfold' - - * @(Either a)@ recovers 'g_apo' (and 'apo') --} -unfoldWith :: (Fixpoint f t, Monad m) - => (forall b. m (f b) -> f (m b)) -> (a -> f (m a)) -> a -> t -unfoldWith k f = unfold (fmap join . k . liftM f) . return - - -{-| -Generalized hylomorphisms parameterized by both a monad and a comonad. -This one combinator subsumes most-if-not-all the other combinators in -this library. - - * @w = Identity@ yields 'unfoldWith' - - * @m = Identity@ yields 'foldWith' - - * @Free m@ and @Cofree w@ yields 'g_chrono', and therefore 'g_histo' and 'g_futu' - -@e@ and @g@ are additional functors related to @f@ by natural transformations -that have been fused into the distributive laws. --} -refoldWith :: (Comonad w, Functor f, Monad m) => - (forall c. f (w c) -> w (g c)) -> - (forall c. m (e c) -> f (m c)) -> - (g (w b) -> b) -> - (a -> e (m a)) -> - a -> b -refoldWith w m f g = extract . refoldWith' w m f g . return - --- | The kernel of the generalized hylomorphism. -refoldWith' :: (Comonad w, Functor f, Monad m) => - (forall c. f (w c) -> w (g c)) -> - (forall c. m (e c) -> f (m c)) -> - (g (w b) -> b) -> - (a -> e (m a)) -> - (m a -> w b) -refoldWith' w m f g = liftW f . w . fmap (duplicate . refoldWith' w m f g . join) . m . liftM g - -{-| -Futumorphism: course of argument coiteration - -@ - futu == 'chrono' ('inF' . fmap 'headCofree') - futu == 'g_futu' id -@ - -Example, translated from /Primitive (Co)Recursion and Course-of-Value -(Co)Iteration, Categorically/ -(): - -> phi (x:y:zs) = Pair y . inFree . Pair x $ return zs - -> exch = futu phi - -> l = exch [1..] -- [2,1,4,3,6,5,8,7,10,9..] --} -futu :: (Fixpoint f t) => (a -> f (Free f a)) -> a -> t -futu = g_futu id - -{-| -Generalized futumorphism - -@ - g_futu m == 'g_chrono' (const 'Unit') m ('inF' . fmap 'headCofree') - g_futu m == 'unfoldWith' ('distribFree' m) -@ --} -g_futu :: (Functor h, Fixpoint f t) => - (forall b. h (f b) -> f (h b)) -> - (a -> f (Free h a)) -> - a -> t -g_futu = unfoldWith . distribFree - --- | a chronomorphism, coined by Edward Kmett, subsumes both histo --- and futumorphisms. -chrono :: Functor f => - (f (Cofree f b) -> b) -> - (a -> f (Free f a)) -> - a -> b -chrono = g_chrono id id - -{-| -Generalized chronomorphism. The recursion functor is separated from -the Free and Cofree functors, and related by distributive laws. - -@ - g_chrono w m == 'refoldWith' ('distribCofree' w) ('distribFree' m) -@ --} -g_chrono :: (Functor f, Functor m, Functor w) => - (forall c. f (w c) -> w (f c)) -> - (forall c. m (f c) -> f (m c)) -> - (f (Cofree w b) -> b) -> - (a -> f (Free m a)) -> - a -> b -g_chrono w m = refoldWith (distribCofree w) (distribFree m) - -{-| -Dynamorphisms: a hylomorphism like combinator that captures dynamic -programming. - -@ - dyna f g == 'g_dyna' id (fmap Identity . runIdentity) f (fmap Identity . g) - dyna f g == 'chrono' f (fmap return . g) -@ - -Example, translated from /Recursion Schemes for Dynamic Programming/ -() section 4.2: - -> data Poly a = Term | Single a | Double a a - -> instance Functor Poly where -> fmap _ Term = Term -> fmap f (Single a) = Single (f a) -> fmap f (Double a b) = Double (f a) (f b) - -> psi 0 = Term -> psi n -> | odd n = Single (n-1) -> | even n = Double (n-1) (n `div` 2) - -> phi Term = 1 -> phi (Single n) = n -> phi (Double m n) = m + n - -> bp1 = refold phi psi -- hylo version; ineffcient - -> zeta 0 = Nil -> zeta n = Pair n (n-1) - -> epsilon = headCofree - -> theta = tailCofree - -> pie x = let (Pair m y) = theta x in y - -> pieN 0 x = x -> pieN n x = pieN (n-1) (pie x) - -> sigma Nil = Term -> sigma (Pair n x) -> | odd n = Single (epsilon x) -> | even n = Double (epsilon x) (epsilon (pieN (n`div`2 - 1) x)) - -> bp2 = dyna (phi . sigma) zeta -- dynamically programmed - --} -dyna :: (Functor f) => - (f (Cofree f b) -> b) -> - (a -> f a) -> - a -> b -dyna f g = extract . dyna' f g - --- | Kernel of the dynamorphism -dyna' :: (Functor f) => - (f (Cofree f b) -> b) -> - (a -> f a) -> - a -> Cofree f b -dyna' f g = refold (f &&& id >>> Cofree) g - -{-| -Generalized dynamorphism - -@ - g_dyna w == 'refoldWith' ('distribCofree' w) -@ --} -g_dyna :: (Functor f, Functor h, Monad m) => - (forall c. f (h c) -> h (f c)) -> - (forall c. m (e c) -> f (m c)) -> - (f (Cofree h b) -> b) -> - (a -> e (m a)) -> - a -> b -g_dyna = refoldWith . distribCofree - -{- Generalized dynamorphism kernel -g_dyna' :: (Functor f, Functor h, Monad m) => - (forall c. f (h c) -> h (f c)) -> - (forall c. m (e c) -> f (m c)) -> - (f (Cofree h b) -> b) -> - (a -> e (m a)) -> - m a -> Cofree h b -g_dyna' = refoldWith' . distribCofree --} - -{-| -The dual of dynamorphisms. --} -codyna :: (Functor f) => - (f b -> b) -> - (a -> f (Free f a)) -> - a -> b -codyna f g = chrono (f . fmap extract) g - -{-| -Generalized codynamorphisms. --} -g_codyna :: (Functor f, Functor h, Comonad w) => - (forall c. f (w c) -> w (g c)) -> - (forall c. h (f c) -> f (h c)) -> - (g (w b) -> b) -> - (a -> f (Free h a)) -> - a -> b -g_codyna w = refoldWith w . distribFree diff --git a/Data/InfiniteSeq.hs b/Data/InfiniteSeq.hs deleted file mode 100644 --- a/Data/InfiniteSeq.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Data.InfiniteSeq - ( Seq - , Nat - , head - , tail - , cons - , elemAt - , drop - , toStream - , toList - ) where - -import Prelude hiding (head, tail, drop) -import Control.Comonad -import Data.Stream (Stream, mkStream) - -type Nat = Int -type Seq a = Nat -> a - --- instance Functor ((->) w) where --- fmap f = (f .) - -instance Comonad ((->) Nat) where - extract s = s 0 - duplicate s = \i -> drop i s - -head :: Seq a -> a -head s = s 0 - -tail :: Seq a -> Seq a -tail s = \i -> s (i + 1) - -cons :: a -> Seq a -> Seq a -cons x s = \i -> if i == 0 then x else s (i - 1) - -elemAt :: Nat -> Seq a -> a -elemAt i s = s i - -drop :: Nat -> Seq a -> Seq a -drop n s = \i -> s (i+n) - -toStream :: Seq a -> Stream a -toStream s = mkStream s head tail - -toList :: Seq a -> [a] -toList s = map s [0..] - - diff --git a/Data/InfiniteTree.hs b/Data/InfiniteTree.hs deleted file mode 100644 --- a/Data/InfiniteTree.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} - -module Data.InfiniteTree - ( Tree - , mkTree - , root - , left - , right - , branchF - , surreals - , showTree - , showTreeWide - , showTree' - , showWide - , rotateR - , rotateL - ) where - -import Control.Arrow ((&&&)) -import Control.Comonad - -data Tree a = forall b. T b (b -> a) (b -> b) (b -> b) - -mkTree :: seed -> (seed -> a) -> (seed -> seed) -> (seed -> seed) -> Tree a -mkTree seed v l r = T seed v l r - -root :: Tree a -> a -root (T s v _ _) = v s - -left :: Tree a -> Tree a -left (T s v l r) = T (l s) v l r - -right :: Tree a -> Tree a -right (T s v l r) = T (r s) v l r - -instance Functor Tree where - fmap f (T s v l r) = T s (f . v) l r - -instance Comonad Tree where - extract = root - extend f (T s v l r) = T s (\s' -> f (T s' v l r)) l r - -branchF :: Functor f => f (Tree a) -> Tree (f a) -branchF f = mkTree f (fmap root) (fmap left) (fmap right) - -surreals :: Fractional a => Tree a -surreals = mkTree (Nothing, Nothing) avg (fst &&& Just . avg) (Just . avg &&& snd) - where - avg (Nothing, Nothing) = 0 - avg (Just x, Nothing) = x + 1 - avg (Nothing, Just y) = y - 1 - avg (Just x, Just y) = (x + y) / 2 - -{- -infix 1 &&& -f &&& g = \x -> (f x, g x) --} - -showTree :: Show a => Int -> Tree a -> String -showTree = showTreeWide True - -showTreeWide :: Show a => Bool -> Int -> Tree a -> String -showTreeWide wide d t = showTree' wide [] [] t d "" - -showTree' :: Show a => Bool -> [String] -> [String] -> Tree a -> Int -> ShowS -showTree' _ _ _ _ 0 = id -showTree' _ lbars _ t 1 - = showBars lbars . shows (root t) . showString "...\n" -showTree' wide lbars rbars t d - = showTree' wide (withBar rbars) (withEmpty rbars) (right t) (d - 1) . - showWide wide rbars . - showBars lbars . shows (root t) . showChar '\n' . - showWide wide lbars . - showTree' wide (withEmpty lbars) (withBar lbars) (left t) (d - 1) - -showWide :: Bool -> [String] -> ShowS -showWide wide bars - | wide = showString (concat (reverse bars)) . showString "|\n" - | otherwise = id - -showBars :: [String] -> ShowS -showBars [] = id -showBars bars = showString (concat (reverse (tail bars))) . showString node - -node :: String -node = "+--" - -withBar, withEmpty :: [String] -> [String] -withBar bars = "| " :bars -withEmpty bars = " " :bars - -data Rot = Zero | One | Two | Three - - -rotateL :: Tree a -> Tree a -rotateL t' = mkTree (t',Two) n l r - where - n (t,Two) = root (right t) - n (t,One) = root t - n (t,Zero) = root t - n (_,Three) = error "rotateL n Three" - - l (t,Two) = (t, One) - l (t,One) = (left t, Zero) - l (t,Zero) = (left t, Zero) - l (_,Three) = error "rotateL l Three" - - r (t,Two) = (right (right t), Zero) - r (t,One) = (left (right t), Zero) - r (t,Zero) = (right t, Zero) - r (_,Three) = error "rotateL r Three" - -rotateR :: Tree a -> Tree a -rotateR t' = mkTree (t',Two) n l r - where - n (t,Two) = root (left t) - n (t,One) = root t - n (t,Zero) = root t - n (_,Three) = error "rotateR n Three" - - l (t,Two) = (left (left t), Zero) - l (t,One) = (right (left t), Zero) - l (t,Zero) = (left t, Zero) - l (_,Three) = error "rotateR l Three" - - r (t,Two) = (t, One) - r (t,One) = (right t, Zero) - r (t,Zero) = (right t, Zero) - r (_,Three) = error "rotateR r Three" diff --git a/Data/Stream.hs b/Data/Stream.hs deleted file mode 100644 --- a/Data/Stream.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE Rank2Types, ExistentialQuantification #-} - -module Data.Stream - ( Stream - , mkStream - , head - , tail - , cons - , elemAt - , toSeq - , toList - , mapStreamSt - , fibs - ) where - -import Prelude hiding (head, tail, drop) -import Control.Comonad -import Control.Arrow ((&&&)) - -data Stream a = forall b. S b (b -> a) (b -> b) - -mkStream :: b -> (b -> a) -> (b -> b) -> Stream a -mkStream x f g = S x f g - -instance Functor Stream where - fmap = liftW - -instance Comonad Stream where - extract (S s f _) = f s - extend h (S s f g) = S s (\s' -> h (S s' f g)) g - -head :: Stream a -> a -head (S x f _) = f x - -tail :: Stream a -> Stream a -tail (S x f g) = S (g x) f g - -cons :: a -> Stream a -> Stream a -cons x s = mkStream (x,s) fst ((head &&& tail) . snd) - -elemAt :: Integral i => i -> Stream a -> a -elemAt n = head . drop n - -drop :: Integral i => i -> Stream a -> Stream a -drop 0 = id -drop n = drop (n - 1) . tail - -toSeq :: Stream a -> Int -> a -toSeq = flip elemAt - -toList :: Stream a -> [a] -toList = map head . iterate tail - -mapStreamSt :: (a -> s -> b) -> (a -> s -> s) -> s -> Stream a -> Stream b -mapStreamSt f1 f2 s0 xs - = mkStream (xs,s0) - (\(x,s) -> f1 (head x) s) - (\(x,s) -> (tail x, f2 (head x) s)) - -fibs :: Stream Integer -fibs = mkStream (1,1) fst (\(i,j) -> (j,i+j)) - -{- ------- --- A stream can be pulled from any comonad - -parallelW :: Comonad w => w (Stream a) -> Stream (w a) -parallelW w = mkStream w (fmap head) (fmap tail) - --- in fact, from any functor -parallelF :: (Functor f) => f (Stream a) -> Stream (f a) -parallelF f = mkStream f (fmap head) (fmap tail) - - ------- --- What good are these? - -mapW :: Comonad w => (w a -> b) -> w (Stream a) -> Stream b -mapW f = fmap f . parallelW - -unfold :: (b -> (a,b)) -> b -> Stream a -unfold f i = mkStream i (fst . f) (snd . f) - -unfoldW :: Comonad w => (w b -> (a,b)) -> w b -> Stream a -unfoldW f w = mkStream w (fst . f) (=>> snd . f) - -mkStreamW :: Comonad w => w b -> (w b -> a) -> (w b -> b) -> Stream a -mkStreamW w f g = mkStream w f (=>> g) --} diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,27 +1,27 @@ -Copyright (c) David Menendez 2004 - +Copyright (c) 2008, Edward Kmett +Copyright (c) 2007, Iavor Diatchki +Copyright (c) 2004-2008, Dave Menendez All rights reserved. -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: -THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Edward Kmett nor the names of its other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,4 +1,3 @@ #!/usr/bin/env runhaskell - > import Distribution.Simple -> main = defaultMain +> main = defaultMainWithHooks simpleUserHooks diff --git a/category-extras.cabal b/category-extras.cabal --- a/category-extras.cabal +++ b/category-extras.cabal @@ -1,39 +1,106 @@ -Name: category-extras -Version: 0.2 -Description: A collection of modules implementing various ideas from - category theory. Notable bits include: comonads, adjunctions, - functor fixedpoints and various recursion operaters ala - /Functional Programming with Bananas, Lenses, Envelopes - and Barbed Wire/. -Synopsis: Various modules and constructs inspired by category theory. -Category: Control, Data -License: BSD3 -License-File: LICENSE -Copyright: Copyright (c) 2004--2008 Dave Menendez -Author: Dave Menendez -Maintainer: dan.doel@gmail.com -Homepage: http://code.haskell.org/~dolio/category-extras +name: category-extras +category: Control, Monads, Comonads +version: 0.44.1 +license: BSD3 +license-file: LICENSE +build-depends: base -any, mtl -any, array -any +author: Edward A. Kmett, Dave Menendez +maintainer: ekmett@gmail.com +stability: experimental +homepage: http://comonad.com/reader/ +synopsis: Various modules and constructs inspired by category theory. +build-type: Simple +copyright: 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, functor fixedpoints and various recursion + operaters ala /Functional Programming with Bananas, Lenses, + Envelopes and Barbed Wire/. -Stability: Experimental -Tested-With: GHC -Build-Depends: base, mtl -Build-Type: Simple +extensions: + CPP, + EmptyDataDecls, + FlexibleContexts, + FlexibleInstances, + FunctionalDependencies, + MultiParamTypeClasses, + TypeOperators, + UndecidableInstances, + ExistentialQuantification, + Rank2Types -Exposed-Modules: Control.Comonad - Control.Comonad.Context - Control.Comonad.Cofree - Control.Functor - Control.Functor.Adjunction - Control.Functor.Transform - Control.Recursion - Control.Monad.Free - Data.InfiniteSeq - Data.InfiniteTree - Data.Stream -Extensions: Rank2Types, - MultiParamTypeClasses, - FunctionalDependencies, - TypeOperators, - FlexibleInstances, - ExistentialQuantification -GHC-Options: -O2 -Wall + +exposed-modules: + Control.Arrow.BiKleisli, + Control.Arrow.CoKleisli, + Control.Bifunctor, + Control.Bifunctor.Associative, + Control.Bifunctor.Braided, + Control.Bifunctor.Composition, + Control.Bifunctor.Either, + Control.Bifunctor.Fix, + Control.Bifunctor.HigherOrder, + Control.Bifunctor.Monoidal, + Control.Bifunctor.Pair, + Control.Comonad, + Control.Comonad.Cofree, + Control.Comonad.Composition, + Control.Comonad.Context, + Control.Comonad.Context.Class, + Control.Comonad.Identity, + Control.Comonad.Indexed, + Control.Comonad.HigherOrder, + Control.Comonad.Parameterized, + Control.Comonad.Parameterized.Class, + Control.Comonad.Pointer, + Control.Comonad.Reader, + Control.Comonad.Reader.Class, + Control.Comonad.Supply + Control.Functor.Adjunction, + Control.Functor.Algebra, + Control.Functor.Bifunctor, + Control.Functor.Composition + Control.Functor.Composition.Class + Control.Functor.Contravariant, + Control.Functor.Constant, + Control.Functor.Derivative, + Control.Functor.Extras, + Control.Functor.Exponential, + Control.Functor.Fix, + Control.Functor.Full, + Control.Functor.HigherOrder, + Control.Functor.Indexed, + Control.Functor.KanExtension, + Control.Functor.Strong, + Control.Functor.Pointed, + Control.Functor.Pointed.Composition, + Control.Functor.Representable, + Control.Functor.Zip, + Control.Functor.Zap, + Control.Monad.Composition, + Control.Monad.Free, + Control.Monad.HigherOrder, + Control.Monad.Indexed, + Control.Monad.Indexed.State, + Control.Monad.Indexed.Cont, + Control.Monad.Parameterized, + Control.Monad.Parameterized.Class, + Control.Monad.Hyper, + Control.Monad.Either, + Control.Morphism.Hylo, + Control.Morphism.Cata, + Control.Morphism.Ana, + Control.Morphism.Meta, + Control.Morphism.Futu, + Control.Morphism.Chrono, + Control.Morphism.Para, + Control.Morphism.Dyna, + Control.Morphism.Apo, + Control.Morphism.Zygo, + Control.Morphism.Histo, + Data.Void + +ghc-options: -O2 -funbox-strict-fields +hs-source-dirs: src diff --git a/src/Control/Arrow/BiKleisli.hs b/src/Control/Arrow/BiKleisli.hs new file mode 100644 --- /dev/null +++ b/src/Control/Arrow/BiKleisli.hs @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Arrow.BiKleisli +-- Copyright : 2008 Edward Kmett +-- License : BSD3 +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------------------- + +module Control.Arrow.BiKleisli where + +#if __GLASGOW_HASKELL__ >= 609 +import Prelude hiding (id,(.)) +import Control.Category +#endif +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) +#else +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) +#endif diff --git a/src/Control/Arrow/CoKleisli.hs b/src/Control/Arrow/CoKleisli.hs new file mode 100644 --- /dev/null +++ b/src/Control/Arrow/CoKleisli.hs @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Arrow.CoKleisli +-- Copyright : 2008 Edward Kmett +-- License : BSD3 +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------------------- +module Control.Arrow.CoKleisli where + +#if __GLASGOW_HASKELL__ >= 609 +import Prelude hiding (id,(.)) +import Control.Category +#endif +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 +instance Comonad w => Category (CoKleisli w) where + id = CoKleisli extract + CoKleisli b . CoKleisli a = CoKleisli (b . fmap a . duplicate) +#else + CoKleisli a >>> CoKleisli b = CoKleisli (b . fmap a . duplicate) +#endif + diff --git a/src/Control/Bifunctor.hs b/src/Control/Bifunctor.hs new file mode 100644 --- /dev/null +++ b/src/Control/Bifunctor.hs @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Bifunctor +-- Copyright : 2008 Edward Kmett +-- License : BSD3 +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable (functional-dependencies) +-- +------------------------------------------------------------------------------------------- +module Control.Bifunctor where + +class Bifunctor f where + bimap :: (a -> c) -> (b -> d) -> f a b -> f c d + first :: (a -> c) -> f a b -> f c b + first f = bimap f id + second :: (b -> d) -> f a b -> f a d + second = bimap id diff --git a/src/Control/Bifunctor/Associative.hs b/src/Control/Bifunctor/Associative.hs new file mode 100644 --- /dev/null +++ b/src/Control/Bifunctor/Associative.hs @@ -0,0 +1,39 @@ +-- {-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-} +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Bifunctor.Associative +-- Copyright : 2008 Edward Kmett +-- License : BSD +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable (class-associated types) +-- +-- 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.Bifunctor.Associative where + +import Control.Bifunctor + +{- | 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 => Associative p where + associate :: 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 => Coassociative s where + coassociate :: 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 + #-} + + diff --git a/src/Control/Bifunctor/Braided.hs b/src/Control/Bifunctor/Braided.hs new file mode 100644 --- /dev/null +++ b/src/Control/Bifunctor/Braided.hs @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Bifunctor.Braided +-- Copyright : 2008 Edward Kmett +-- License : BSD +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------------------- +module Control.Bifunctor.Braided where + +import Control.Bifunctor +import Control.Bifunctor.Associative + +{- | 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 Bifunctor p => Braided p where + braid :: p a b -> p b a + +{- | +If we have a symmetric (co)'Monoidal' category, you get the additional law: + +> swap . swap = id + -} +class Braided p => Symmetric p + +swap :: Symmetric p => 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 + #-} diff --git a/src/Control/Bifunctor/Composition.hs b/src/Control/Bifunctor/Composition.hs new file mode 100644 --- /dev/null +++ b/src/Control/Bifunctor/Composition.hs @@ -0,0 +1,141 @@ +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Bifunctor.Composition +-- Copyright : 2008 Edward Kmett +-- License : BSD3 +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------------------- + +module Control.Bifunctor.Composition where + + +import Control.Comonad +import Control.Bifunctor +import Control.Bifunctor.Associative +import Control.Bifunctor.Braided +import Control.Bifunctor.Monoidal +import Control.Functor.Pointed +import Control.Functor.Exponential +import Control.Functor.Contravariant + +newtype ArrowB f g a b = ArrowB { runArrowB :: f a b -> g a b } + + + +newtype ConstB t a b = ConstB { runConstB :: t } + +instance Bifunctor (ConstB t) where + bimap f g = ConstB . runConstB +instance Functor (ConstB t a) where + fmap f = ConstB . runConstB + + + +newtype FstB a b = FstB { runFstB :: a } + +instance Bifunctor FstB where + bimap f g = FstB . f . runFstB + +instance Associative FstB where + associate = FstB . runFstB . runFstB + +instance Functor (FstB a) where + fmap f (FstB a) = FstB a + +instance ContravariantFunctor (FstB a) where + contramap f (FstB a) = FstB a + +instance ExpFunctor (FstB a) where + xmap f g (FstB a) = FstB a + + +newtype SndB a b = SndB { runSndB :: b } + +instance Bifunctor SndB where + bimap f g = SndB . g . runSndB + +-- instance Coassociative SndB where +-- coassociate = SndB . SndB . runSndB + +-- as a functor its a family of identity functors with a type-level parameter (a) +instance Functor (SndB a) where + fmap = bimap id + +-- bifunctor composition + +newtype CompB p f g a b = CompB { runCompB :: p (f a b) (g a b) } + +instance (Bifunctor p, Bifunctor f, Bifunctor g) => Bifunctor (CompB p f g) where + bimap f g = CompB . bimap (bimap f g) (bimap f g) . runCompB + +liftCompB :: Bifunctor p => (f a b -> f c d) -> (g a b -> g c d) -> CompB p f g a b -> CompB p f g c d +liftCompB f g = CompB . bimap f g . runCompB + +instance (Bifunctor p, Braided f, Braided g) => Braided (CompB p f g) where + braid = liftCompB braid braid + +instance (Bifunctor p, Symmetric f, Symmetric g) => Symmetric (CompB p f g) + +instance (Bifunctor p, Bifunctor f, Bifunctor g) => Functor (CompB p f g a) where + fmap = bimap id + + + + + +newtype SwapB p a b = SwapB { runSwapB :: p b a } + +liftSwapB :: Bifunctor p => (p a b -> p c d) -> SwapB p b a -> SwapB p d c +liftSwapB f = SwapB . f . runSwapB + +instance Bifunctor p => Bifunctor (SwapB p) where + bimap f g = liftSwapB (bimap g f) + +instance Braided p => Braided (SwapB p) where + braid = liftSwapB braid + +instance Symmetric p => Symmetric (SwapB p) + +instance Bifunctor p => Functor (SwapB p a) where + fmap = bimap id + + + + +-- a functor composed around a bifunctor + +newtype FunctorB f p a b = FunctorB { runFunctorB :: f (p a b) } + +liftFunctorB :: Functor f => (p a b -> p c d) -> FunctorB f p a b -> FunctorB f p c d +liftFunctorB f = FunctorB . fmap f . runFunctorB + +instance (Functor f, Bifunctor p) => Bifunctor (FunctorB f p) where + bimap f g = liftFunctorB (bimap f g) + +instance (Functor f, Braided p) => Braided (FunctorB f p) where + braid = liftFunctorB braid + +instance (Functor f, Symmetric p) => Symmetric (FunctorB f p) + +instance (Functor f, Bifunctor p) => Functor (FunctorB f p a) where + fmap = bimap id + + +-- a bifunctor wrapping a pair of functors with different values + +newtype BiffB p f g a b = BiffB { runBiffB :: p (f a) (g b) } + +instance (Functor f, Bifunctor p, Functor g) => Bifunctor (BiffB p f g) where + bimap f g = BiffB . bimap (fmap f) (fmap g) . runBiffB + +instance (Functor f, Braided p) => Braided (BiffB p f f) where + braid = BiffB . braid . runBiffB + +instance (Functor f, Symmetric p) => Symmetric (BiffB p f f) + +instance (Functor f, Bifunctor p, Functor g) => Functor (BiffB p f g a) where + fmap f = bimap id f diff --git a/src/Control/Bifunctor/Either.hs b/src/Control/Bifunctor/Either.hs new file mode 100644 --- /dev/null +++ b/src/Control/Bifunctor/Either.hs @@ -0,0 +1,39 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Bifunctor.Either +-- Copyright : (C) 2008 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Control.Bifunctor.Either where + +import Control.Bifunctor +import Control.Bifunctor.Associative +import Control.Bifunctor.Monoidal +import Control.Bifunctor.Braided +import Data.Void +import Control.Arrow ((***), (+++)) + +instance Bifunctor Either where + bimap = (+++) + +instance Associative Either where + associate (Left (Left a)) = Left a + associate (Left (Right b)) = Right (Left b) + associate (Right c) = Right (Right c) + +instance Coassociative Either where + coassociate (Left a) = Left (Left a) + coassociate (Right (Left b)) = Left (Right b) + coassociate (Right (Right c)) = Right c + +instance Braided Either where + braid (Left a) = Right a + braid (Right b) = Left b + +instance Symmetric Either diff --git a/src/Control/Bifunctor/Fix.hs b/src/Control/Bifunctor/Fix.hs new file mode 100644 --- /dev/null +++ b/src/Control/Bifunctor/Fix.hs @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Bifunctor.Fix +-- Copyright : 2008 Edward Kmett +-- License : BSD +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------------------- +module Control.Bifunctor.Fix where + +import Control.Bifunctor + +newtype FixB s a = InB { outB :: s a (FixB s a) } + +instance Bifunctor s => Functor (FixB s) where + fmap f = InB . bimap f (fmap f) . outB diff --git a/src/Control/Bifunctor/HigherOrder.hs b/src/Control/Bifunctor/HigherOrder.hs new file mode 100644 --- /dev/null +++ b/src/Control/Bifunctor/HigherOrder.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Bifunctor.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.Bifunctor.HigherOrder where + +import Control.Bifunctor +import Control.Functor.Extras + +{- +type BiNatural p q = forall a b. p a b -> q a b + +class HBifunctor p where + fbimap :: Bifunctor q => (a -> b) -> (c -> d) -> p q a c -> p q b d + hbimap :: BiNatural g h -> BiNatural (p g) (p h) + +newtype MuHB p a b = InHB { outHB :: p (MuHB p) a b } +type NuHB p a b = MuHB p a b +-} diff --git a/src/Control/Bifunctor/Monoidal.hs b/src/Control/Bifunctor/Monoidal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Bifunctor/Monoidal.hs @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Bifunctor.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. +------------------------------------------------------------------------------------------- +module Control.Bifunctor.Monoidal where + +import Control.Bifunctor +import Control.Bifunctor.Associative +import Control.Bifunctor.Braided + +-- | 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 => HasIdentity p i | 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 p, HasIdentity p i) => Monoidal p i | p -> i where + idl :: p i a -> a + idr :: 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 p, HasIdentity p i) => Comonoidal p i | p -> i where + coidl :: a -> p i a + coidr :: 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 + #-} + diff --git a/src/Control/Bifunctor/Pair.hs b/src/Control/Bifunctor/Pair.hs new file mode 100644 --- /dev/null +++ b/src/Control/Bifunctor/Pair.hs @@ -0,0 +1,41 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Bifunctor.Pair +-- Copyright : (C) 2008 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Control.Bifunctor.Pair where + +import Control.Bifunctor +import Control.Bifunctor.Associative +import Control.Bifunctor.Monoidal +import Control.Bifunctor.Braided +import Data.Void +import Control.Arrow ((***), (+++)) + +instance Bifunctor (,) where + bimap = (***) + +instance Associative (,) where + associate ((a,b),c) = (a,(b,c)) + +instance Coassociative (,) where + coassociate (a,(b,c)) = ((a,b),c) + +instance HasIdentity (,) Void + +instance Monoidal (,) Void where + idl = snd + idr = fst + +instance Braided (,) where + braid ~(a,b) = (b,a) + +instance Symmetric (,) + diff --git a/src/Control/Comonad.hs b/src/Control/Comonad.hs new file mode 100644 --- /dev/null +++ b/src/Control/Comonad.hs @@ -0,0 +1,91 @@ +{-# OPTIONS -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 where + +import Control.Monad +import Control.Arrow ((|||), (&&&), (+++), (***)) + +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 => Comonad w where + duplicate :: w a -> w (w a) + extend :: (w a -> b) -> w a -> w b + extract :: w a -> a + 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 + diff --git a/src/Control/Comonad/Cofree.hs b/src/Control/Comonad/Cofree.hs new file mode 100644 --- /dev/null +++ b/src/Control/Comonad/Cofree.hs @@ -0,0 +1,50 @@ +{-# OPTIONS -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 +-- +---------------------------------------------------------------------------- +module Control.Comonad.Cofree where + +import Control.Arrow ((&&&)) +import Control.Bifunctor +import Control.Bifunctor.Fix +import Control.Bifunctor.Composition +import Control.Bifunctor.Pair +import Control.Comonad +import Control.Comonad.Parameterized +import Control.Comonad.Parameterized.Class +import Control.Functor.Extras +import Control.Monad.Identity +import Control.Monad.Parameterized +import Control.Monad.Parameterized.Class + +type CofreeB f a b = BiffB (,) Identity f a b +type Cofree f a = FixB (BiffB (,) Identity f) a + +instance Functor f => PComonad (BiffB (,) Identity f) where + pextract = runIdentity . fst . runBiffB + pextend f = BiffB . (Identity . f &&& snd . runBiffB) + +instance FunctorPlus f => PMonad (BiffB (,) Identity f) where + preturn a = BiffB (Identity a,fzero) + pbind k (BiffB ~(Identity a,as)) = BiffB (ib, fplus as bs) where BiffB (ib,bs) = k a + +outCofree :: Cofree f a -> f (Cofree f a) +outCofree = snd . runBiffB . outB + +runCofree :: Cofree f a -> (a, f (Cofree f a)) +runCofree = first runIdentity . runBiffB . outB + +anaCofree :: Functor f => (a -> c) -> (a -> f a) -> a -> Cofree f c +anaCofree h t = InB . BiffB . (Identity . h &&& fmap (anaCofree h t) . t) + +cofree :: a -> f (Cofree f a) -> Cofree f a +cofree a as = InB $ BiffB (Identity a,as) + diff --git a/src/Control/Comonad/Composition.hs b/src/Control/Comonad/Composition.hs new file mode 100644 --- /dev/null +++ b/src/Control/Comonad/Composition.hs @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Comonad.Composition +-- Copyright : 2008 Edward Kmett +-- License : BSD +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable (functional-dependencies) +-- +-- composing a comonad with a copointed endofunctor yields a comonad given a distributive law +------------------------------------------------------------------------------------------- + +module Control.Comonad.Composition where + +import Control.Comonad +import Control.Functor.Composition +import Control.Functor.Composition.Class +import Control.Functor.Extras +import Control.Functor.Pointed +import Control.Functor.Pointed.Composition + +-- postDuplicate :: (Comonad w, PostUnfold w f) => w (f a) -> w (f (w (f a))) +-- postDuplicate = fmap postUnfold . duplicate + +instance (Comonad w, Copointed f, PostUnfold w f) => Comonad (PostCompF w f) where + extract = copoint . extract . decompose + duplicate = compose . liftW (fmap compose . postUnfold) . duplicate . decompose + +-- preDuplicate :: (Comonad w, Functor f, PreUnfold f w) => f (w a) -> f (w (f (w a))) +-- preDuplicate = preUnfold . fmap duplicate + +instance (Copointed f, Comonad w, PreUnfold f w) => Comonad (PreCompF f w) where + extract = extract . copoint . decompose + duplicate = compose . fmap (liftW compose) . preUnfold . fmap (duplicate) . decompose + +instance (Comonad f, Comonad g, Distributes f g) => Comonad (DistCompF f g) where + extract = extract . extract . decompose + duplicate = compose . fmap (fmap compose . dist) . duplicate . fmap duplicate . decompose +-- join = compose . fmap join . join . fmap dist . fmap (fmap decompose) . decompose diff --git a/src/Control/Comonad/Context.hs b/src/Control/Comonad/Context.hs new file mode 100644 --- /dev/null +++ b/src/Control/Comonad/Context.hs @@ -0,0 +1,51 @@ +{-# OPTIONS -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 state-in-context comonad and comonad transformer +---------------------------------------------------------------------------- +module Control.Comonad.Context where + +import Control.Arrow ((&&&), first) +import Control.Comonad +import Control.Comonad.Context.Class + + +data Context s a = Context (s -> a) s + +runContext f s = (a b, b) where + Context a b = f (Context id s) + +instance ComonadContext s (Context s) where + getC (Context f 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 Comonad (Context s) where + extract (Context f a) = f a + 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 Comonad w => Comonad (ContextT b w) where + extract = uncurry id . runContextT + duplicate (ContextT (f,ws)) = ContextT (ContextT . (,) f, ws) diff --git a/src/Control/Comonad/Context/Class.hs b/src/Control/Comonad/Context/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Comonad/Context/Class.hs @@ -0,0 +1,25 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Comonad.Context.Class +-- Copyright : (C) 2008 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Control.Comonad.Context.Class where + +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 diff --git a/src/Control/Comonad/HigherOrder.hs b/src/Control/Comonad/HigherOrder.hs new file mode 100644 --- /dev/null +++ b/src/Control/Comonad/HigherOrder.hs @@ -0,0 +1,20 @@ +----------------------------------------------------------------------------- +-- | +-- 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 where + +import Control.Functor.Extras +import Control.Functor.HigherOrder + +class HFunctor w => HComonad w where + hextract :: Functor f => Natural (w f) f + hextend :: (Functor f, Functor g) => Natural (w f) g -> Natural (w f) (w g) diff --git a/src/Control/Comonad/Identity.hs b/src/Control/Comonad/Identity.hs new file mode 100644 --- /dev/null +++ b/src/Control/Comonad/Identity.hs @@ -0,0 +1,21 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Comonad.Identity +-- Copyright : (C) 2008 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Control.Comonad.Identity where + +import Control.Monad.Identity +import Control.Comonad + +instance Comonad Identity where + extract = runIdentity + extend f x = Identity (f x) + duplicate = Identity diff --git a/src/Control/Comonad/Indexed.hs b/src/Control/Comonad/Indexed.hs new file mode 100644 --- /dev/null +++ b/src/Control/Comonad/Indexed.hs @@ -0,0 +1,30 @@ +----------------------------------------------------------------------------- +-- | +-- 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 where + +import Control.Comonad +import Control.Arrow +import Control.Functor.Extras +import Control.Functor.HigherOrder +import Control.Functor.Indexed +import Control.Monad + +class IxFunctor w => IxComonad w where + iextract :: w i i a -> a + 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 + +instance Comonad w => IxComonad (LiftIx w) where + iextract = extract . lowerIx + iextend f = LiftIx . extend (f . LiftIx) . lowerIx diff --git a/src/Control/Comonad/Parameterized.hs b/src/Control/Comonad/Parameterized.hs new file mode 100644 --- /dev/null +++ b/src/Control/Comonad/Parameterized.hs @@ -0,0 +1,26 @@ +{-# OPTIONS -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 where + +import Control.Bifunctor +import Control.Bifunctor.Fix +import Control.Comonad +import Control.Comonad.Parameterized.Class +import Control.Morphism.Ana + +copaugment :: PComonad f => ((FixB f a -> f b (FixB f a)) -> FixB f b) -> (FixB f a -> b) -> FixB f b +copaugment g k = g (pextend (k . InB) . outB) + +instance PComonad f => Comonad (FixB f) where + extract = pextract . outB + extend k w = copaugment (flip biana w) k diff --git a/src/Control/Comonad/Parameterized/Class.hs b/src/Control/Comonad/Parameterized/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Comonad/Parameterized/Class.hs @@ -0,0 +1,40 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Comonad.Parameterized.Class +-- Copyright : (C) 2008 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Control.Comonad.Parameterized.Class where + +import Control.Arrow ((|||), (+++)) +import Control.Monad +import Control.Bifunctor + +class Bifunctor f => PComonad f where + pextract :: f a c -> a + 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 + +-} + +#ifndef __HADDOCK__ +{-# RULES +"pextend pextract" pextend pextract = id +"pextract . pextend g" forall g. pextract . pextend g = g +"pextract . bimap id g" forall g. pextract . bimap id g = pextract +"bimap _ _ . pextract" forall j g. bimap id g . pextend (j . bimap id g) = pextend j . bimap id g + #-} +#endif diff --git a/src/Control/Comonad/Pointer.hs b/src/Control/Comonad/Pointer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Comonad/Pointer.hs @@ -0,0 +1,37 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Comonad.Pointer +-- Copyright : (C) 2008 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable (MPTCs) +-- +-- SIGFPE (Dan Piponi)'s Pointer Comonad +---------------------------------------------------------------------------- +module Control.Comonad.Pointer where + +import Control.Functor.Extras +import Control.Arrow ((&&&), first) +import Data.Array +import Data.Foldable +import Control.Monad +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 => Comonad (Pointer i) where + extract (Pointer i a) = a ! i + 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 new file mode 100644 --- /dev/null +++ b/src/Control/Comonad/Reader.hs @@ -0,0 +1,67 @@ +{-# OPTIONS -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 +-- +---------------------------------------------------------------------------- +module Control.Comonad.Reader where + +import Control.Bifunctor +import Control.Bifunctor.Pair +import Control.Monad.Instances -- for Functor ((,)e) +import Control.Comonad.Reader.Class +import Control.Comonad +import Control.Arrow ((&&&)) + +data ReaderC r a = ReaderC r a +runReaderC (ReaderC r a) = (r,a) + +instance ComonadReader r (ReaderC r) where + askC (ReaderC r _) = r + +instance Functor (ReaderC r) where + fmap f = uncurry ReaderC . second f . runReaderC + +instance Comonad (ReaderC r) where + extract (ReaderC _ a) = a + duplicate (ReaderC e a) = ReaderC e (ReaderC e a) + +instance Bifunctor ReaderC where + bimap f g = uncurry ReaderC . bimap f g . runReaderC + + +newtype ReaderCT w r a = ReaderCT { runReaderCT :: w (r, a) } + +instance Comonad w => ComonadReader r (ReaderCT w r) where + askC = fst . extract . runReaderCT + +instance Functor f => Functor (ReaderCT f b) where + fmap f = ReaderCT . fmap (fmap f) . runReaderCT + +instance Comonad w => Comonad (ReaderCT w b) where + extract = snd . extract . runReaderCT + duplicate = ReaderCT . liftW (fst . extract &&& ReaderCT) . duplicate . runReaderCT + +instance Functor f => Bifunctor (ReaderCT f) where + bimap f g = ReaderCT . fmap (bimap f g) . runReaderCT + + +instance Comonad ((,)e) where + extract = snd + duplicate ~(e,a) = (e,(e,a)) + +instance ComonadReader e ((,)e) where + askC = fst + +-- instance Functor ((,)e) where +-- fmap f = second f + +-- instance Bifunctor (,) where +-- bimap f g = uncurry ReaderC . bimap f g . runReaderC + diff --git a/src/Control/Comonad/Reader/Class.hs b/src/Control/Comonad/Reader/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Comonad/Reader/Class.hs @@ -0,0 +1,18 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Comonad.Reader.Class +-- Copyright : (C) 2008 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Control.Comonad.Reader.Class where + +import Control.Comonad + +class Comonad w => ComonadReader r w | w -> r where + askC :: w a -> r diff --git a/src/Control/Comonad/Supply.hs b/src/Control/Comonad/Supply.hs new file mode 100644 --- /dev/null +++ b/src/Control/Comonad/Supply.hs @@ -0,0 +1,147 @@ +-------------------------------------------------------------------- +-- | +-- 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 + ( + + -- * 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) form 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 Comonad Supply where + extract = supplyValue + 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/Functor/Adjunction.hs b/src/Control/Functor/Adjunction.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Adjunction.hs @@ -0,0 +1,61 @@ +{-# OPTIONS -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 where + +import Control.Comonad +import Control.Functor.Composition +import Control.Functor.Composition.Class +import Control.Functor.Exponential +import Control.Functor.Full +import Control.Functor.Pointed +import Control.Monad + +-- | An 'Adjunction' formed by the 'Functor' f and 'Functor' g. + +-- Minimal definition: + +-- 1. @leftAdjunct@ and @rightAdjunct@ + +-- 2. @unit@ and @counit@ + +class (Functor f, Functor g) => Adjunction f g 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 + + + + +-- adjunction-oriented composition +newtype ACompF f g a = ACompF (CompF f g a) deriving (Functor, ExpFunctor, Full, Composition) + +instance Adjunction f g => Pointed (ACompF g f) where + point = compose . unit + +instance Adjunction f g => Copointed (ACompF f g) where + copoint = counit . decompose + +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 + extract = copoint + extend f = compose . fmap (leftAdjunct (f . compose)) . decompose diff --git a/src/Control/Functor/Algebra.hs b/src/Control/Functor/Algebra.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Algebra.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- 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) +-- +---------------------------------------------------------------------------- +module Control.Functor.Algebra where + +import Control.Comonad + +type Alg f a = f a -> a +type CoAlg f a = a -> f a +type AlgW f w a = f (w a) -> a +type CoAlgM f m a = a -> f (m a) + +liftAlg :: (Functor f, Comonad w) => Alg f a -> AlgW f w a +liftAlg f = f . fmap extract + +liftCoAlg :: (Functor f, Monad m) => CoAlg f a -> CoAlgM f m a +liftCoAlg f = fmap return . f + diff --git a/src/Control/Functor/Bifunctor.hs b/src/Control/Functor/Bifunctor.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Bifunctor.hs @@ -0,0 +1,65 @@ +{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-} +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Functor.Bifunctor +-- 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.Bifunctor where + +import Control.Bifunctor +import Control.Bifunctor.Pair +import Control.Bifunctor.Either +import Control.Functor.Contravariant +import Control.Functor.Exponential +import Control.Functor.Full +import Control.Functor.Pointed +import Control.Arrow ((***),(&&&),(|||),(+++)) + +-- * Bifunctor functor transformer + +newtype BifunctorF p f g a = BifunctorF { runBifunctorF :: p (f a) (g a) } + +instance (Bifunctor p, Functor f ,Functor g) => Functor (BifunctorF p f g) where + fmap f = BifunctorF . bimap (fmap f) (fmap f) . runBifunctorF + +instance (Bifunctor p, ContravariantFunctor f ,ContravariantFunctor g) => ContravariantFunctor (BifunctorF p f g) where + contramap f = BifunctorF . bimap (contramap f) (contramap f) . runBifunctorF + +instance (Bifunctor p, ExpFunctor f ,ExpFunctor g) => ExpFunctor (BifunctorF p f g) where + xmap f g = BifunctorF . bimap (xmap f g) (xmap f g) . runBifunctorF + + + +#ifndef __HADDOCK__ +type (f :*: g) a = BifunctorF (,) f g a +#endif + + +runProductF :: BifunctorF (,) f g a -> (f a, g a) +runProductF = runBifunctorF + +instance (Pointed f, Pointed g) => Pointed (BifunctorF (,) f g) where + point = BifunctorF . (point &&& point) + +instance (Faithful f, Faithful g) => Faithful (BifunctorF (,) f g) + +#ifndef __HADDOCK__ +type (f :+: g) a = BifunctorF Either f g a +#endif + + +runCoproductF :: BifunctorF Either f g a -> Either (f a) (g a) +runCoproductF = runBifunctorF + +instance (Copointed f, Copointed g) => Copointed (BifunctorF Either f g) where + copoint = (copoint ||| copoint) . runBifunctorF + diff --git a/src/Control/Functor/Composition.hs b/src/Control/Functor/Composition.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Composition.hs @@ -0,0 +1,45 @@ +{-# OPTIONS -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 composeosition. +------------------------------------------------------------------------------------------- + +module Control.Functor.Composition where + +import Control.Functor.Composition.Class +import Control.Functor.Exponential +import Control.Functor.Full + +newtype CompF f g a = CompF { runCompF :: f (g a) } + +instance Composition CompF where + compose = CompF + decompose = runCompF + +#ifndef __HADDOCK__ +type (f :.: g) a = CompF f g a +#endif + +-- 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 + +associateComp :: (Functor f, Composition c) => (c (c f g) h) a -> (c f (c g h)) a +associateComp = compose . fmap compose . decompose . decompose + +coassociateComp :: (Functor f, Composition c) => (c f (c g h)) a -> (c (c f g) h) a +coassociateComp = compose . compose . fmap decompose . decompose diff --git a/src/Control/Functor/Composition/Class.hs b/src/Control/Functor/Composition/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Composition/Class.hs @@ -0,0 +1,20 @@ +{-# OPTIONS -fglasgow-exts #-} +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Functor.Composition.Class +-- Copyright : 2008 Edward Kmett +-- License : BSD +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable (class-associated types) +-- +------------------------------------------------------------------------------------------- + +module Control.Functor.Composition.Class where + +class Composition c where + decompose :: c f g x -> f (g x) + compose :: f (g x) -> c f g x + + diff --git a/src/Control/Functor/Constant.hs b/src/Control/Functor/Constant.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Constant.hs @@ -0,0 +1,33 @@ +{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-} +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Functor.Constant +-- Copyright : 2008 Edward Kmett +-- License : BSD +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable (functional-dependencies) +-- +------------------------------------------------------------------------------------------- + +module Control.Functor.Constant where + +import Control.Functor.Exponential +import Control.Functor.Contravariant +import Data.Void + +-- this is also the 'Fst' bifunctor + +newtype ConstantF a b = ConstantF a + +instance Functor (ConstantF a) where + fmap f (ConstantF a) = ConstantF a + +instance ContravariantFunctor (ConstantF a) where + contramap f (ConstantF a) = ConstantF a + +instance ExpFunctor (ConstantF a) where + xmap f g (ConstantF a) = ConstantF a + +type VoidF a = ConstantF Void a diff --git a/src/Control/Functor/Contravariant.hs b/src/Control/Functor/Contravariant.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Contravariant.hs @@ -0,0 +1,22 @@ +{-# OPTIONS -fglasgow-exts #-} +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Functor.Contravariant +-- Copyright : 2008 Edward Kmett +-- License : BSD +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable (class-associated types) +-- +------------------------------------------------------------------------------------------- + +module Control.Functor.Contravariant where + +class ContravariantFunctor f where + contramap :: (a -> b) -> f b -> f a + +newtype ContraF a b = ContraF { runContraF :: b -> a } + +instance ContravariantFunctor (ContraF a) where + contramap g (ContraF f) = ContraF (f . g) diff --git a/src/Control/Functor/Derivative.hs b/src/Control/Functor/Derivative.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Derivative.hs @@ -0,0 +1,13 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Functor.Derivative +-- 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.Derivative where + diff --git a/src/Control/Functor/Exponential.hs b/src/Control/Functor/Exponential.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Exponential.hs @@ -0,0 +1,19 @@ +{-# OPTIONS -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 where + +class ExpFunctor f where + xmap :: (a -> b) -> (b -> a) -> f a -> f b + diff --git a/src/Control/Functor/Extras.hs b/src/Control/Functor/Extras.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Extras.hs @@ -0,0 +1,43 @@ +{-# OPTIONS -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 + +type Dist f g = forall a. f (g a) -> g (f a) +type Natural f g = forall a. f a -> g 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) diff --git a/src/Control/Functor/Fix.hs b/src/Control/Functor/Fix.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Fix.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- | +-- 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) +-- +---------------------------------------------------------------------------- +module Control.Functor.Fix where + +import Control.Monad +import Control.Comonad +import Control.Functor.Algebra + +newtype Fix f = InF { outF :: f (Fix f) } + +outM :: (Functor f, Monad m) => CoAlgM f m (Fix f) +outM = liftCoAlg outF + +inW :: (Functor f, Comonad w) => AlgW f w (Fix f) +inW = liftAlg InF + diff --git a/src/Control/Functor/Full.hs b/src/Control/Functor/Full.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Full.hs @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------------------- +-- | +-- 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 + + +{- | + 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 + +{-# RULES + "fmap/premap" map . premap = id + #-} + +class Functor f => Faithful f + +{- | + +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 new file mode 100644 --- /dev/null +++ b/src/Control/Functor/HigherOrder.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- | +-- 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 where + +import Control.Functor.Extras + +type AlgH f g = Natural (f g) g +type CoAlgH f g = Natural g (f g) + +class HFunctor f where + ffmap :: Functor g => (a -> b) -> f g a -> f g b + hfmap :: Natural g h -> Natural (f g) (f h) + +newtype FixH f a = InH { outH :: f (FixH f) a } diff --git a/src/Control/Functor/Indexed.hs b/src/Control/Functor/Indexed.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Indexed.hs @@ -0,0 +1,31 @@ +----------------------------------------------------------------------------- +-- | +-- 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 where + +import Control.Comonad +import Control.Arrow +import Control.Functor.Extras +import Control.Functor.HigherOrder +import Control.Monad + +class IxFunctor f where + imap :: (a -> b) -> f j k a -> f j k b + +newtype LiftIx m i j a = LiftIx { lowerIx :: m a } + +instance Functor f => IxFunctor (LiftIx f) where + imap f = LiftIx . fmap f . lowerIx + +newtype LowerIx m i a = LowerIx { liftIx :: m i i a } + +instance IxFunctor f => Functor (LowerIx f i) where + fmap f = LowerIx . imap f . liftIx diff --git a/src/Control/Functor/KanExtension.hs b/src/Control/Functor/KanExtension.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/KanExtension.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- 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) +-- +---------------------------------------------------------------------------- +module Control.Functor.KanExtension where + +import Control.Functor.Composition.Class +import Control.Functor.Extras + +-- Right Kan Extension +newtype Ran g h a = Ran { runRan :: forall b. (a -> g b) -> h b } + +toRan :: (Composition c, Functor k) => Natural (c k g) h -> Natural k (Ran g h) +toRan s t = Ran (s . compose . flip fmap t) + +fromRan :: Composition c => Natural k (Ran g h) -> Natural (c k g) h +fromRan s = flip runRan id . s . decompose + +-- Left Kan Extension +data Lan g h a = forall b. Lan (g b -> a) (h b) + +toLan :: (Composition c, Functor f) => Natural h (c f g) -> Natural (Lan g h) f +toLan s (Lan f v) = fmap f . decompose $ s v + +fromLan :: Composition c => Natural (Lan g h) f -> Natural h (c f g) +fromLan s t = compose . s $ Lan id t diff --git a/src/Control/Functor/Pointed.hs b/src/Control/Functor/Pointed.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Pointed.hs @@ -0,0 +1,27 @@ +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Functor.Pointed +-- Copyright : 2008 Edward Kmett +-- License : BSD +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable (functional-dependencies) +-- +------------------------------------------------------------------------------------------- + +module Control.Functor.Pointed where + +-- return +class Functor f => Pointed f where + point :: a -> f a + +-- extract +class Functor f => Copointed f where + copoint :: f a -> a + +{-# RULES +"copoint/point" copoint . point = id +"point/copoint" point . copoint = id + #-} + diff --git a/src/Control/Functor/Pointed/Composition.hs b/src/Control/Functor/Pointed/Composition.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Pointed/Composition.hs @@ -0,0 +1,33 @@ +{-# OPTIONS -fglasgow-exts #-} +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Functor.Pointed.Composition +-- Copyright : 2008 Edward Kmett +-- License : BSD +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable (functional-dependencies) +-- +------------------------------------------------------------------------------------------- + +module Control.Functor.Pointed.Composition where + +import Control.Functor.Pointed +import Control.Functor.Composition.Class +import Control.Functor.Composition +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 + copoint = copoint . copoint . decompose + +newtype PostCompF mw f a = PostCompF (PointedCompF mw f a) deriving (Functor, ExpFunctor, Full, Composition, Pointed, Copointed) +newtype PreCompF f mw a = PreCompF (PointedCompF f mw a) deriving (Functor, ExpFunctor, Full, Composition, Pointed, Copointed) +newtype DistCompF f g a = DistCompF (PointedCompF f g a) deriving (Functor, ExpFunctor, Full, Composition, Pointed, Copointed) + diff --git a/src/Control/Functor/Representable.hs b/src/Control/Functor/Representable.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Representable.hs @@ -0,0 +1,33 @@ +{-# OPTIONS -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 where + +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 + #-} + +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 + diff --git a/src/Control/Functor/Strong.hs b/src/Control/Functor/Strong.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Strong.hs @@ -0,0 +1,24 @@ +{-# OPTIONS -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) +import Data.Traversable +import Control.Monad.Either + +strength :: Functor f => f a -> b -> f (a,b) +strength fa b = fmap (\a -> (a,b)) fa + +costrength :: Traversable f => f (Either a b) -> Either a (f b) +costrength = sequence diff --git a/src/Control/Functor/Zap.hs b/src/Control/Functor/Zap.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Zap.hs @@ -0,0 +1,64 @@ +{-# OPTIONS -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 Functors +------------------------------------------------------------------------------------------- + +module Control.Functor.Zap where + +import Control.Bifunctor +import Control.Bifunctor.Composition +import Control.Comonad.Cofree +import Control.Monad.Either +import Control.Monad.Free +import Control.Monad.Identity +import Data.Traversable + +{- | Minimum definition: zapWith -} + +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 (Functor f, Functor g, Zap f g) => BiZap (CofreeB f) (FreeB g) where +-- bizapWith l r (CofreeB fs) (FreeB as) = bizapWith l (zapWith r) fs as + +-- instance (Functor f, Functor g, Zap f g) => BiZap (FreeB f) (CofreeB g) where +-- bizapWith l r (FreeB fs) (CofreeB as) = bizapWith l (zapWith r) fs as + +instance (BiZap p q, Zap f g, Zap i j) => BiZap (BiffB p f i) (BiffB q g j) where + bizapWith l r fs as = bizapWith (zapWith l) (zapWith r) (runBiffB fs) (runBiffB as) diff --git a/src/Control/Functor/Zip.hs b/src/Control/Functor/Zip.hs new file mode 100644 --- /dev/null +++ b/src/Control/Functor/Zip.hs @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Functor.Zip +-- Copyright : 2008 Edward Kmett +-- License : BSD +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------------------- + +module Control.Functor.Zip where + +import Control.Arrow ((&&&)) +import Control.Bifunctor +import Control.Bifunctor.Composition +import Control.Bifunctor.Pair -- Bifunctor (,) +import Control.Bifunctor.Fix +import Control.Comonad.Cofree +import Control.Monad.Free +import Control.Monad.Identity +import Data.Monoid + +unfzip :: Functor f => f (a, b) -> (f a, f b) +unfzip = fmap fst &&& fmap snd + +unbizip :: Bifunctor p => p (a, c) (b, d) -> (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 => 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 f _ _ = 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) + +-- comes for free with BiffB +-- instance Zip f => Bizip (CofreeB f) where +-- bizipWith f g (CofreeB as) (CofreeB bs) = CofreeB $ bizipWith f (fzipWith g) as bs + +instance (Bizip p, Zip f, Zip g) => Bizip (BiffB p f g) where + bizipWith f g as bs = BiffB $ bizipWith (fzipWith f) (fzipWith g) (runBiffB as) (runBiffB bs) + +instance (Zip f, Bizip p) => Bizip (FunctorB f p) where + bizipWith f g as bs = FunctorB $ fzipWith (bizipWith f g) (runFunctorB as) (runFunctorB bs) + +instance Bizip p => Zip (FixB p) where + fzipWith f as bs = InB $ bizipWith f (fzipWith f) (outB as) (outB bs) + +instance Monoid a => Zip (Either a) where + fzipWith f (Left a) (Left b) = Left (mappend a b) + fzipWith f (Right a) (Left b) = Left b + fzipWith f (Left a) (Right b) = 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 +-} diff --git a/src/Control/Monad/Composition.hs b/src/Control/Monad/Composition.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Composition.hs @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Composition +-- Copyright : 2008 Edward Kmett +-- License : BSD +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable (functional-dependencies) +-- +------------------------------------------------------------------------------------------- + +module Control.Monad.Composition where + +import Control.Monad +-- import Control.Functor.Composition +import Control.Functor.Composition.Class +import Control.Functor.Extras +import Control.Functor.Pointed +import Control.Functor.Pointed.Composition + +postJoin :: (Monad m, PostFold m f) => m (f (m (f a))) -> m (f a) +postJoin = join . liftM postFold + +instance (Monad m, Pointed f, PostFold m f) => Monad (PostCompF m f) where + return = compose . return . point + m >>= k = undefined -- TODO: dualize the comonad version + +preJoin :: (Monad m, Functor f, PreFold f m) => f (m (f (m a))) -> f (m a) +preJoin = fmap join . preFold + +instance (Pointed f, Monad m, PreFold f m) => Monad (PreCompF f m) where + return = compose . point . return + m >>= k = undefined + + +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/Monad/Either.hs b/src/Control/Monad/Either.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Either.hs @@ -0,0 +1,41 @@ +{-# OPTIONS -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 where + +import Data.Either +import Control.Monad + +newtype EitherT a m b = EitherT { runEitherT :: m (Either a b) } + +instance Functor (Either e) where + fmap _ (Left a) = Left a + fmap f (Right a) = Right (f a) + +instance Monad (Either e) where + return = Right + Right m >>= k = k m + Left e >>= _ = Left e + +instance Functor f => Functor (EitherT b f) where + fmap f = EitherT . fmap (fmap f) . runEitherT + +instance Monad m => Monad (EitherT b 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) diff --git a/src/Control/Monad/Free.hs b/src/Control/Monad/Free.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Free.hs @@ -0,0 +1,47 @@ +{-# OPTIONS -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 +-- +---------------------------------------------------------------------------- +module Control.Monad.Free where + +import Control.Arrow ((|||), (+++)) +import Control.Bifunctor +import Control.Bifunctor.Either +import Control.Bifunctor.Fix +import Control.Bifunctor.Composition +import Control.Functor.Extras +import Control.Functor.Exponential +import Control.Functor.Contravariant +import Control.Monad +import Control.Monad.Identity +import Control.Monad.Parameterized +import Control.Monad.Parameterized.Class +import Control.Comonad.Parameterized +import Control.Comonad.Parameterized.Class + +instance Functor f => PMonad (BiffB Either Identity f) where + preturn = BiffB . Left . Identity + pbind k = (k . runIdentity ||| BiffB . Right) . runBiffB + +type FreeB f a b = BiffB Either Identity f a b +type Free f a = FixB (BiffB Either Identity f) a + +inFree :: f (Free f a) -> Free f a +inFree = InB . BiffB . Right + +runFree :: Free f a -> Either a (f (Free f a)) +runFree = first runIdentity . runBiffB . outB + +cataFree :: Functor f => (c -> a) -> (f a -> a) -> Free f c -> a +cataFree l r = (l . runIdentity ||| r . fmap (cataFree l r)) . runBiffB . outB + +free :: Either a (f (Free f a)) -> Free f a +free = InB . BiffB . first Identity diff --git a/src/Control/Monad/HigherOrder.hs b/src/Control/Monad/HigherOrder.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/HigherOrder.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- 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 where + +import Control.Functor.Extras +import Control.Functor.HigherOrder + +class HFunctor m => HMonad m where + hreturn :: Functor f => Natural f (m f) + hbind :: (Functor f, Functor g) => Natural f (m g) -> Natural (m f) (m g) + --hbind k = hjoin . hfmap k + +hjoin :: (HMonad m, Functor (m g), Functor g) => Natural (m (m g)) (m g) +hjoin = hbind id + +(>>**=) :: (HMonad m, Functor f, Functor g) => m f a -> Natural f (m g) -> m g a +m >>**= k = hbind k m diff --git a/src/Control/Monad/Hyper.hs b/src/Control/Monad/Hyper.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Hyper.hs @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------------------- +-- | +-- 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 where + +import Control.Bifunctor +import Control.Bifunctor.Fix +import Control.Monad.Parameterized.Class +import Control.Functor.Contravariant +import Control.Monad.Instances + +newtype HyperB h a b = HyperB { runHyperB :: h b -> a } + +instance ContravariantFunctor h => Bifunctor (HyperB h) where + bimap f g h = HyperB (f . runHyperB h . contramap g) + +instance ContravariantFunctor h => PMonad (HyperB h) where + preturn = HyperB . const + pbind k (HyperB h) = HyperB (k . h >>= runHyperB) -- the bind is in the (->)e monad + +-- | A generic recursive hyperfunction-like combinator +type Hyper h a = FixB (HyperB h) + +-- | Traditional Hyper functions +type Hyp e a = Hyper (ContraF e) a + diff --git a/src/Control/Monad/Indexed.hs b/src/Control/Monad/Indexed.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Indexed.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- | +-- 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 where + +import Control.Comonad +import Control.Arrow +import Control.Functor.Extras +import Control.Functor.HigherOrder +import Control.Functor.Indexed +import Control.Monad + +class IxFunctor m => IxMonad m where + ireturn :: a -> m i i a + 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 + +infixl 1 >>>= + +(>>>=) :: IxMonad m => m i j a -> (a -> m j k b) -> m i k b +m >>>= k = ibind k m + +instance (Functor m, Monad m) => IxMonad (LiftIx m) where + ireturn = LiftIx . return + ibind f m = LiftIx (lowerIx m >>= lowerIx . f) + +instance (IxMonad m) => Monad (LowerIx m i) where + return = LowerIx . ireturn + m >>= f = LowerIx (liftIx m >>>= liftIx . f) diff --git a/src/Control/Monad/Indexed/Cont.hs b/src/Control/Monad/Indexed/Cont.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Indexed/Cont.hs @@ -0,0 +1,53 @@ +{-# OPTIONS -fglasgow-exts #-} +------------------------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Indexed.Cont +-- Copyright : 2008 Edward Kmett +-- 2008 Dan Doel +-- License : BSD +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------------------- + +module Control.Monad.Indexed.Cont where + +import Control.Monad.Identity +import Control.Functor.Indexed +import Control.Monad.Indexed + + +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 + +-- runIxContT :: Monad m => IxContT m r a a -> m r +-- runIxContT m = unIxContT m return + +instance IxFunctor (IxContT m) where + imap f m = IxContT $ \c -> runIxContT m (c . f) + + +instance Monad m => IxMonad (IxContT m) where + ireturn a = IxContT ($a) + ibind f c = IxContT $ \k -> runIxContT c $ \a -> runIxContT (f a) k + +class IxMonad m => IxContMonad m where + reset :: m a o o -> m r r a + shift :: ((a -> m i i o) -> m r j j) -> m r o a + + +instance Monad m => IxContMonad (IxContT m) where + reset e = IxContT $ \k -> runIxContT e return >>= k + shift e = IxContT $ \k -> e (\a -> IxContT (\k' -> k a >>= k')) `runIxContT` return + +newtype IxCont r o a = IxCont (IxContT Identity r o a) deriving (IxFunctor, IxMonad, IxContMonad) + +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 diff --git a/src/Control/Monad/Indexed/State.hs b/src/Control/Monad/Indexed/State.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Indexed/State.hs @@ -0,0 +1,29 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Indexed.State +-- 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.State where + +import Control.Comonad +import Control.Arrow +import Control.Functor.Extras +import Control.Functor.HigherOrder +import Control.Functor.Indexed +import Control.Monad +import Control.Monad.Indexed + +newtype IxState i j a = IxState { runIxState :: i -> (a, j) } + +instance IxFunctor IxState where + imap f (IxState m) = IxState (first f . m) + +instance IxMonad IxState where + ireturn = IxState . (,) + ibind f (IxState m) = IxState $ \s1 -> let (a,s2) = m s1 in runIxState (f a) s2 diff --git a/src/Control/Monad/Parameterized.hs b/src/Control/Monad/Parameterized.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Parameterized.hs @@ -0,0 +1,28 @@ +{-# OPTIONS -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 where + +import Control.Arrow ((|||), (+++)) +import Control.Monad +import Control.Bifunctor +import Control.Bifunctor.Fix +import Control.Monad.Parameterized.Class +import Control.Morphism.Cata + +paugment :: PMonad f => (forall c. (f a c -> c) -> c) -> (a -> FixB f b) -> FixB f b +paugment g k = g (InB . pbind (outB . k)) + +instance PMonad f => Monad (FixB f) where + return = InB . preturn + m >>= k = paugment (flip bicata m) k + diff --git a/src/Control/Monad/Parameterized/Class.hs b/src/Control/Monad/Parameterized/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Parameterized/Class.hs @@ -0,0 +1,57 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Paramterized.Class +-- Copyright : (C) 2008 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : portable +-- +-- The notation >>*= was selected to indicate the kind of the parameter +-- in this case a simple type as opposed to >>*->*= for higher order monads. +---------------------------------------------------------------------------- +module Control.Monad.Parameterized.Class where + +import Control.Arrow ((|||), (+++)) +-- import Control.Functor.Exponential +-- import Control.Functor.Contravariant +import Control.Monad +import Control.Bifunctor +import Control.Bifunctor.Fix + +{- | Minimum definition: + +1. preturn & pbind +2. preturn & pjoin + +-} + +class Bifunctor f => PMonad f where + preturn :: a -> f a c + pbind :: (a -> f b c) -> f a c -> f b c + pbind f = pjoin . bimap f id + pjoin :: f (f a b) b -> f a b + pjoin = pbind id + +(>>*=) :: 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 + +-- bimapPMonad :: (PMonad f, Functor (f a)) => (a -> c) -> (b -> d) -> f a b -> f c d +-- bimapPMonad f g xs = second g xs >>*= preturn . f + +{- 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 new file mode 100644 --- /dev/null +++ b/src/Control/Morphism/Ana.hs @@ -0,0 +1,47 @@ +{-# OPTIONS -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 where + +import Control.Functor.Algebra +import Control.Functor.Extras +import Control.Functor.Fix +import Control.Functor.HigherOrder +import Control.Bifunctor +import Control.Bifunctor.Fix +import Control.Comonad () +import Control.Monad.Identity +import Control.Comonad.Identity () + +-- | Anamorphisms are a generalized form of 'unfoldr' +ana :: Functor f => CoAlg f a -> a -> Fix f +ana g = InF . fmap (ana g) . g +-- ana g = g_ana distAna (liftCoAlg g) + +-- | Generalized anamorphisms allow you to work with a monad given a distributive law +g_ana :: (Functor f, Monad m) => Dist m f -> CoAlgM f m a -> a -> Fix 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 :: Bifunctor f => CoAlg (f b) a -> a -> FixB f b +biana g = InB . bimap id (biana g) . g + +g_biana :: (Bifunctor f, Monad m) => Dist m (f b) -> CoAlgM (f b) m a -> a -> FixB f b +g_biana k g = a . return where a = InB . bimap id (a . join) . k . liftM g + +-- | A higher-order anamorphism for constructing higher order functors. +hana :: HFunctor f => CoAlgH f a -> Natural a (FixH f) +hana g = InH . hfmap (hana g) . g diff --git a/src/Control/Morphism/Apo.hs b/src/Control/Morphism/Apo.hs new file mode 100644 --- /dev/null +++ b/src/Control/Morphism/Apo.hs @@ -0,0 +1,49 @@ +{-# OPTIONS -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 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.Arrow ((|||)) + +-- * Unfold Sugar + +apo :: Functor f => CoAlgM f (Apo f) a -> a -> Fix f +apo = g_apo outF + +g_apo :: Functor f => CoAlg f b -> CoAlgM f (GApo b) a -> a -> Fix f +g_apo g = g_ana (distGApo g) + +type Apo f a = Either (Fix f) a +type ApoT f m a = EitherT (Fix f) m a + +type GApo b a = Either b a +type GApoT b m a = EitherT b m a + +-- * Distributive Law Combinators + +distGApo :: Functor f => CoAlg f b -> Dist (Either b) f +distGApo f = fmap Left . f ||| fmap Right + +distGApoT :: (Functor f, Monad m) => CoAlgM 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 (liftCoAlg outF) + diff --git a/src/Control/Morphism/Cata.hs b/src/Control/Morphism/Cata.hs new file mode 100644 --- /dev/null +++ b/src/Control/Morphism/Cata.hs @@ -0,0 +1,43 @@ +{-# OPTIONS -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 where + +import Control.Bifunctor +import Control.Bifunctor.Fix +import Control.Comonad +import Control.Comonad.Identity +import Control.Functor.Algebra +import Control.Functor.HigherOrder +import Control.Functor.Extras +import Control.Functor.Fix +import Control.Monad.Identity + +cata :: Functor f => Alg f a -> Fix f -> a +-- cata f = g_cata distCata (liftAlg f) +cata f = f . fmap (cata f) . outF + +g_cata :: (Functor f, Comonad w) => Dist f w -> AlgW f w a -> Fix f -> a +-- g_cata k f = g_hylo k distAna f id outM +g_cata k g = extract . c where c = liftW g . k . fmap (duplicate . c) . outF + +distCata :: Functor f => Dist f Identity +distCata = Identity . fmap runIdentity + +bicata :: Bifunctor f => Alg (f b) a -> FixB f b -> a +bicata f = f . bimap id (bicata f) . outB + +g_bicata :: (Bifunctor f, Comonad w) => Dist (f b) w -> AlgW (f b) w a -> FixB f b -> a +g_bicata k g = extract . c where c = liftW g . k . bimap id (duplicate . c) . outB + +hcata :: HFunctor f => AlgH f a -> Natural (FixH f) a +hcata f = f . hfmap (hcata f) . outH diff --git a/src/Control/Morphism/Chrono.hs b/src/Control/Morphism/Chrono.hs new file mode 100644 --- /dev/null +++ b/src/Control/Morphism/Chrono.hs @@ -0,0 +1,30 @@ +{-# OPTIONS -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.Functor.Fix +import Control.Monad.Free +import Control.Morphism.Hylo +import Control.Morphism.Futu +import Control.Morphism.Histo + +chrono :: (Functor f, Functor g) => AlgW g (Cofree g) b -> Natural f g -> CoAlgM f (Free f) a -> a -> b +chrono = g_hylo (distHisto id) (distFutu id) + +g_chrono :: (Functor f, Functor g, Functor h, Functor j) => + Dist g h -> Dist j f -> AlgW g (Cofree h) b -> Natural f g -> CoAlgM f (Free j) a -> a -> b +g_chrono h f = g_hylo (distHisto h) (distFutu f) diff --git a/src/Control/Morphism/Dyna.hs b/src/Control/Morphism/Dyna.hs new file mode 100644 --- /dev/null +++ b/src/Control/Morphism/Dyna.hs @@ -0,0 +1,25 @@ +{-# OPTIONS -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.Functor.Fix +import Control.Comonad +import Control.Comonad.Cofree +import Control.Morphism.Hylo +import Control.Morphism.Histo +import Control.Morphism.Ana + +dyna :: (Functor f, Functor g) => AlgW g (Cofree g) b -> Natural f g -> CoAlg f a -> a -> b +dyna f e g = g_hylo (distHisto id) distAna f e (liftCoAlg g) diff --git a/src/Control/Morphism/Futu.hs b/src/Control/Morphism/Futu.hs new file mode 100644 --- /dev/null +++ b/src/Control/Morphism/Futu.hs @@ -0,0 +1,31 @@ +{-# OPTIONS -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 where + +import Control.Functor.Algebra +import Control.Functor.Extras +import Control.Functor.Fix +import Control.Comonad () +import Control.Monad.Free +import Control.Morphism.Ana + +futu :: Functor f => CoAlgM f (Free f) a -> a -> Fix f +futu = g_ana (distFutu id) + +g_futu :: (Functor f, Functor h) => Dist h f -> CoAlgM f (Free h) a -> a -> Fix f +g_futu k = g_ana (distFutu k) + +distFutu :: (Functor f, Functor h) => Dist h f -> Dist (Free h) f +distFutu k = cataFree (fmap return) (fmap inFree . k) + diff --git a/src/Control/Morphism/Histo.hs b/src/Control/Morphism/Histo.hs new file mode 100644 --- /dev/null +++ b/src/Control/Morphism/Histo.hs @@ -0,0 +1,30 @@ +{-# OPTIONS -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 where + +import Control.Functor.Algebra +import Control.Functor.Extras +import Control.Functor.Fix +import Control.Comonad +import Control.Comonad.Cofree +import Control.Morphism.Cata + +histo :: Functor f => AlgW f (Cofree f) a -> Fix f -> a +histo = g_cata (distHisto id) + +g_histo :: (Functor f, Functor h) => Dist f h -> AlgW f (Cofree h) a -> Fix f -> a +g_histo k = g_cata (distHisto k) + +distHisto :: (Functor f, Functor h) => Dist f h -> Dist f (Cofree h) +distHisto k = anaCofree (fmap extract) (k . fmap outCofree) diff --git a/src/Control/Morphism/Hylo.hs b/src/Control/Morphism/Hylo.hs new file mode 100644 --- /dev/null +++ b/src/Control/Morphism/Hylo.hs @@ -0,0 +1,46 @@ +{-# OPTIONS -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.Bifunctor +import Control.Bifunctor.HigherOrder +import Control.Comonad +import Control.Monad +import Control.Functor.Algebra +import Control.Functor.Extras +import Control.Functor.Fix +import Control.Functor.HigherOrder + +hylo :: Functor f => Alg g b -> Natural f g -> CoAlg f a -> a -> b +hylo f e g = f . e . fmap (hylo f e g). g + +g_hylo :: (Comonad w, Functor f, Monad m) => + Dist g w -> Dist m f -> AlgW g w b -> Natural f g -> CoAlgM 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 + + +-- A more "Jeremy Gibbons"-style bifunctor-based version has the same expressive power + +bihylo :: (Bifunctor f, Bifunctor g) => Alg (g d) b -> Natural (f c) (g d) -> CoAlg (f c) a -> a -> b +bihylo f e g = f . e . bimap id (bihylo f e g). g + +g_bihylo :: (Comonad w, Bifunctor f, Monad m) => + Dist (g d) w -> Dist m (f c) -> AlgW (g d) w b -> Natural (f c) (g d) -> CoAlgM (f c) m a -> a -> b +g_bihylo w m f e g = extract . h . return where h = liftW f . w . e . bimap id (duplicate . h . join) . m . liftM g + + +-- | higher order hylomorphisms for use in building up and tearing down higher order functors +hhylo :: HFunctor f => AlgH f b -> CoAlgH f a -> Natural a b +hhylo f g = f . hfmap (hhylo f g) . g + diff --git a/src/Control/Morphism/Meta.hs b/src/Control/Morphism/Meta.hs new file mode 100644 --- /dev/null +++ b/src/Control/Morphism/Meta.hs @@ -0,0 +1,33 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Morphism.Meta +-- Copyright : (C) 2008 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable (rank-2 polymorphism) +-- +-- Generalized metamorphisms +---------------------------------------------------------------------------- +module Control.Morphism.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 + + +meta :: (Functor f, Functor g) => + CoAlg f b -> (a -> b) -> Alg g a -> Fix g -> Fix f +meta f e g = ana f . e . cata g + +g_meta :: (Monad m, Functor f, Comonad w, Functor g) => + Dist m f -> Dist g w -> CoAlgM f m b -> (a -> b) -> AlgW g w a -> Fix g -> Fix 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 new file mode 100644 --- /dev/null +++ b/src/Control/Morphism/Para.hs @@ -0,0 +1,35 @@ +{-# OPTIONS -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 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 + +-- * Refold Sugar + +para :: Functor f => AlgW f (Para f) a -> Fix f -> a +para = zygo InF + +g_para :: (Functor f, Comonad w) => Dist f w -> AlgW f (ParaT w f) a -> Fix f -> a +g_para f = g_cata (distParaT f) + +type Para f a = (Fix f, a) +type ParaT w f a = ReaderCT w (Fix f) a + +distParaT :: (Functor f, Comonad w) => Dist f w -> Dist f (ParaT w f) +distParaT = distZygoT (liftAlg InF) diff --git a/src/Control/Morphism/Zygo.hs b/src/Control/Morphism/Zygo.hs new file mode 100644 --- /dev/null +++ b/src/Control/Morphism/Zygo.hs @@ -0,0 +1,39 @@ +{-# OPTIONS -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 where + +import Control.Arrow ((&&&)) +import Control.Bifunctor.Pair +import Control.Comonad +import Control.Comonad.Reader +import Control.Functor.Algebra +import Control.Functor.Extras +import Control.Functor.Fix +import Control.Morphism.Cata + +type Zygo b a = (b,a) + +zygo :: Functor f => Alg f b -> AlgW f (Zygo b) a -> Fix f -> a +zygo f = g_cata (distZygo f) + +g_zygo :: (Functor f, Comonad w) => AlgW f w b -> Dist f w -> AlgW f (ReaderCT w b) a -> Fix f -> a +g_zygo f w = g_cata (distZygoT f w) + +-- * Distributive Law Combinators + +distZygo :: Functor f => Alg f b -> Dist f (Zygo b) +distZygo g = g . fmap fst &&& fmap snd + +distZygoT :: (Functor f, Comonad w) => AlgW f w b -> Dist f w -> Dist f (ReaderCT w b) +distZygoT g k = ReaderCT . liftW (g . fmap (liftW fst) &&& fmap (snd . extract)) . k . fmap (duplicate . runReaderCT) + diff --git a/src/Data/Void.hs b/src/Data/Void.hs new file mode 100644 --- /dev/null +++ b/src/Data/Void.hs @@ -0,0 +1,18 @@ +{-# OPTIONS -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