categories-1.0.7/0000755000000000000000000000000012453036423012034 5ustar0000000000000000categories-1.0.7/.ghci0000644000000000000000000000012512453036423012745 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h categories-1.0.7/.gitignore0000644000000000000000000000010412453036423014017 0ustar0000000000000000dist docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# categories-1.0.7/.travis.yml0000644000000000000000000000033712453036423014150 0ustar0000000000000000language: haskell notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313categories\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" categories-1.0.7/.vim.custom0000644000000000000000000000137712453036423014151 0ustar0000000000000000" Add the following to your .vimrc to automatically load this on startup " if filereadable(".vim.custom") " so .vim.custom " endif function StripTrailingWhitespace() let myline=line(".") let mycolumn = col(".") silent %s/ *$// call cursor(myline, mycolumn) endfunction " enable syntax highlighting syntax on " search for the tags file anywhere between here and / set tags=TAGS;/ " highlight tabs and trailing spaces set listchars=tab:‗‗,trail:‗ set list " f2 runs hasktags map :exec ":!hasktags -x -c --ignore src" " strip trailing whitespace before saving " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() " rebuild hasktags after saving au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" categories-1.0.7/categories.cabal0000644000000000000000000000314412453036423015147 0ustar0000000000000000name: categories category: Control version: 1.0.7 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: experimental homepage: http://github.com/ekmett/categories bug-reports: http://github.com/ekmett/categories/issues synopsis: Categories copyright: Copyright (C) 2008-2014, Edward A. Kmett description: Categories build-type: Simple tested-with: GHC == 7.4.1, GHC == 7.6.1, GHC == 7.8.3 extra-source-files: .ghci .gitignore .travis.yml .vim.custom README.markdown CHANGELOG.markdown flag Optimize description: Enable optimizations default: False library default-language: Haskell2010 default-extensions: CPP other-extensions: MultiParamTypeClasses FunctionalDependencies FlexibleContexts FlexibleInstances UndecidableInstances TypeOperators TypeFamilies GADTs -- these extensions aren't yet known by my version of Cabal: -- other-extensions: DefaultSignatures ConstraintKinds exposed-modules: Control.Categorical.Functor, Control.Categorical.Bifunctor, Control.Categorical.Object, Control.Category.Monoidal, Control.Category.Cartesian, Control.Category.Cartesian.Closed, Control.Category.Associative, Control.Category.Braided, Control.Category.Discrete, Control.Category.Distributive, Control.Category.Dual build-depends: base >= 4 && < 5, void >= 0.5.4.2 hs-source-dirs: src ghc-options: -Wall if flag(Optimize) ghc-options: -funbox-strict-fields -O2 categories-1.0.7/CHANGELOG.markdown0000644000000000000000000000032012453036423015062 0ustar00000000000000001.0.7 ----- * Build fixes for GHC 7.8.x to support the current version of `Typeable` 1.0.6 ----- * Marked modules `Trustworthy` 1.0.5 --- * Removed the upper bound on void. * Added `README` and `CHANGELOG` categories-1.0.7/LICENSE0000644000000000000000000000266012453036423013045 0ustar0000000000000000Copyright 2008-2010 Edward Kmett 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. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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. categories-1.0.7/README.markdown0000644000000000000000000000071312453036423014536 0ustar0000000000000000categories ========== [![Build Status](https://secure.travis-ci.org/ekmett/categories.png?branch=master)](http://travis-ci.org/ekmett/categories) This package provides a number of classes for working with `Category` instances with more structure in Haskell. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett categories-1.0.7/Setup.lhs0000644000000000000000000000016512453036423013646 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain categories-1.0.7/src/0000755000000000000000000000000012453036423012623 5ustar0000000000000000categories-1.0.7/src/Control/0000755000000000000000000000000012453036423014243 5ustar0000000000000000categories-1.0.7/src/Control/Categorical/0000755000000000000000000000000012453036423016460 5ustar0000000000000000categories-1.0.7/src/Control/Categorical/Bifunctor.hs0000644000000000000000000000433512453036423020754 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-} ------------------------------------------------------------------------------------------- -- | -- Module : Control.Categorical.Bifunctor -- Copyright: 2008-2010 Edward Kmett -- License : BSD3 -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability: non-portable (functional-dependencies) -- -- A more categorical definition of 'Bifunctor' ------------------------------------------------------------------------------------------- module Control.Categorical.Bifunctor ( PFunctor (first) , QFunctor (second) , Bifunctor (bimap) , dimap , difirst ) where import Prelude hiding (id, (.)) import Control.Category import Control.Category.Dual class (Category r, Category t) => PFunctor p r t | p r -> t, p t -> r where first :: r a b -> t (p a c) (p b c) -- default first :: Bifunctor p r s t => r a b -> t (p a c) (p b c) -- first f = bimap f id class (Category s, Category t) => QFunctor q s t | q s -> t, q t -> s where second :: s a b -> t (q c a) (q c b) -- default second :: Bifunctor q r s t => s a b -> t (q c a) (q c b) -- second = bimap id -- | Minimal definition: @bimap@ -- or both @first@ and @second@ class (PFunctor p r t, QFunctor p s t) => Bifunctor p r s t | p r -> s t, p s -> r t, p t -> r s where bimap :: r a b -> s c d -> t (p a c) (p b d) -- bimap f g = second g . first f instance PFunctor (,) (->) (->) where first f = bimap f id instance QFunctor (,) (->) (->) where second = bimap id instance Bifunctor (,) (->) (->) (->) where bimap f g (a,b)= (f a, g b) instance PFunctor Either (->) (->) where first f = bimap f id instance QFunctor Either (->) (->) where second = bimap id instance Bifunctor Either (->) (->) (->) where bimap f _ (Left a) = Left (f a) bimap _ g (Right a) = Right (g a) instance QFunctor (->) (->) (->) where second = (.) difirst :: PFunctor f (Dual s) t => s b a -> t (f a c) (f b c) difirst = first . Dual dimap :: Bifunctor f (Dual s) t u => s b a -> t c d -> u (f a c) (f b d) dimap = bimap . Dual categories-1.0.7/src/Control/Categorical/Functor.hs0000644000000000000000000001150612453036423020437 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, UndecidableInstances, FlexibleInstances #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} #endif ------------------------------------------------------------------------------------------- -- | -- Module : Control.Categorical.Functor -- Copyright : 2008-2010 Edward Kmett -- License : BSD3 -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable (functional-dependencies) -- -- A more categorical definition of 'Functor' ------------------------------------------------------------------------------------------- module Control.Categorical.Functor ( Functor(fmap) , Endofunctor , LiftedFunctor(..) , LoweredFunctor(..) ) where #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif import Control.Category import Prelude hiding (id, (.), Functor(..)) import qualified Prelude #ifdef __GLASGOW_HASKELL__ import Data.Data (Data(..), mkDataType, DataType, mkConstr, Constr, constrIndex, Fixity(..)) #if __GLASGOW_HASKELL__ < 708 #if MIN_VERSION_base(4,4,0) import Data.Typeable (Typeable1(..), TyCon, mkTyCon3, mkTyConApp, gcast1) #else import Data.Typeable (Typeable1(..), TyCon, mkTyCon, mkTyConApp, gcast1) #endif #else import Data.Typeable (Typeable, gcast1) #endif #endif -- TODO Data, Typeable newtype LiftedFunctor f a = LiftedFunctor (f a) deriving ( Show , Read #if __GLASGOW_HASKELL__ >= 708 , Typeable #endif ) #ifdef __GLASGOW_HASKELL__ liftedConstr :: Constr liftedConstr = mkConstr liftedDataType "LiftedFunctor" [] Prefix {-# NOINLINE liftedConstr #-} liftedDataType :: DataType liftedDataType = mkDataType "Control.Categorical.Fucntor.LiftedFunctor" [liftedConstr] {-# NOINLINE liftedDataType #-} #if __GLASGOW_HASKELL__ < 708 instance Typeable1 f => Typeable1 (LiftedFunctor f) where typeOf1 tfa = mkTyConApp liftedTyCon [typeOf1 (undefined `asArgsType` tfa)] where asArgsType :: f a -> t f a -> f a asArgsType = const liftedTyCon :: TyCon #if MIN_VERSION_base(4,4,0) liftedTyCon = mkTyCon3 "categories" "Control.Categorical.Functor" "LiftedFunctor" #else liftedTyCon = mkTyCon "Control.Categorical.Functor.LiftedFunctor" #endif {-# NOINLINE liftedTyCon #-} #else #define Typeable1 Typeable #endif instance (Typeable1 f, Data (f a), Data a) => Data (LiftedFunctor f a) where gfoldl f z (LiftedFunctor a) = z LiftedFunctor `f` a toConstr _ = liftedConstr gunfold k z c = case constrIndex c of 1 -> k (z LiftedFunctor) _ -> error "gunfold" dataTypeOf _ = liftedDataType dataCast1 f = gcast1 f #endif newtype LoweredFunctor f a = LoweredFunctor (f a) deriving ( Show , Read #if __GLASGOW_HASKELL__ >= 708 , Typeable #endif ) #ifdef __GLASGOW_HASKELL__ loweredConstr :: Constr loweredConstr = mkConstr loweredDataType "LoweredFunctor" [] Prefix {-# NOINLINE loweredConstr #-} loweredDataType :: DataType loweredDataType = mkDataType "Control.Categorical.Fucntor.LoweredFunctor" [loweredConstr] {-# NOINLINE loweredDataType #-} #if __GLASGOW_HASKELL__ < 708 instance Typeable1 f => Typeable1 (LoweredFunctor f) where typeOf1 tfa = mkTyConApp loweredTyCon [typeOf1 (undefined `asArgsType` tfa)] where asArgsType :: f a -> t f a -> f a asArgsType = const loweredTyCon :: TyCon #if MIN_VERSION_base(4,4,0) loweredTyCon = mkTyCon3 "categories" "Control.Categorical.Functor" "LoweredFunctor" #else loweredTyCon = mkTyCon "Control.Categorical.Functor.LoweredFunctor" #endif {-# NOINLINE loweredTyCon #-} #endif instance (Typeable1 f, Data (f a), Data a) => Data (LoweredFunctor f a) where gfoldl f z (LoweredFunctor a) = z LoweredFunctor `f` a toConstr _ = loweredConstr gunfold k z c = case constrIndex c of 1 -> k (z LoweredFunctor) _ -> error "gunfold" dataTypeOf _ = loweredDataType dataCast1 f = gcast1 f #endif class (Category r, Category t) => Functor f r t | f r -> t, f t -> r where fmap :: r a b -> t (f a) (f b) -- default fmap :: Prelude.Functor f => (a -> b) -> f a -> f b -- fmap = Prelude.fmap instance Functor f (->) (->) => Prelude.Functor (LoweredFunctor f) where fmap f (LoweredFunctor a) = LoweredFunctor (Control.Categorical.Functor.fmap f a) instance Prelude.Functor f => Functor (LiftedFunctor f) (->) (->) where fmap f (LiftedFunctor a) = LiftedFunctor (Prelude.fmap f a) instance Functor ((,) a) (->) (->) where fmap f (a, b) = (a, f b) instance Functor (Either a) (->) (->) where fmap _ (Left a) = Left a fmap f (Right a) = Right (f a) instance Functor Maybe (->) (->) where fmap = Prelude.fmap instance Functor [] (->) (->) where fmap = Prelude.fmap instance Functor IO (->) (->) where fmap = Prelude.fmap class Functor f a a => Endofunctor f a instance Functor f a a => Endofunctor f a categories-1.0.7/src/Control/Categorical/Object.hs0000644000000000000000000000244612453036423020230 0ustar0000000000000000{-# LANGUAGE TypeFamilies, TypeOperators #-} ------------------------------------------------------------------------------------------- -- | -- Module : Control.Category.Object -- Copyright: 2010-2012 Edward Kmett -- License : BSD -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability: non-portable (either class-associated types or MPTCs with fundeps) -- -- This module declares the 'HasTerminalObject' and 'HasInitialObject' classes. -- -- These are both special cases of the idea of a (co)limit. ------------------------------------------------------------------------------------------- module Control.Categorical.Object ( HasTerminalObject(..) , HasInitialObject(..) ) where import Control.Category -- | The @Category (~>)@ has a terminal object @Terminal (~>)@ such that for all objects @a@ in @(~>)@, -- there exists a unique morphism from @a@ to @Terminal (~>)@. class Category k => HasTerminalObject k where type Terminal k :: * terminate :: a `k` Terminal k -- | The @Category (~>)@ has an initial (coterminal) object @Initial (~>)@ such that for all objects -- @a@ in @(~>)@, there exists a unique morphism from @Initial (~>) @ to @a@. class Category k => HasInitialObject k where type Initial k :: * initiate :: Initial k `k` a categories-1.0.7/src/Control/Category/0000755000000000000000000000000012453036423016020 5ustar0000000000000000categories-1.0.7/src/Control/Category/Associative.hs0000644000000000000000000000363012453036423020630 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE MultiParamTypeClasses #-} ------------------------------------------------------------------------------------------- -- | -- Module : Control.Category.Associative -- Copyright : 2008 Edward Kmett -- License : BSD -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : portable -- -- NB: this contradicts another common meaning for an 'Associative' 'Category', which is one -- where the pentagonal condition does not hold, but for which there is an identity. -- ------------------------------------------------------------------------------------------- module Control.Category.Associative ( Associative(..) ) where import Control.Categorical.Bifunctor {- | A category with an associative bifunctor satisfying Mac Lane\'s pentagonal coherence identity law: > bimap id associate . associate . bimap associate id = associate . associate > bimap disassociate id . disassociate . bimap id disassociate = disassociate . disassociate -} class Bifunctor p k k k => Associative k p where associate :: k (p (p a b) c) (p a (p b c)) disassociate :: k (p a (p b c)) (p (p a b) c) {-- RULES "copentagonal coherence" first disassociate . disassociate . second disassociate = disassociate . disassociate "pentagonal coherence" second associate . associate . first associate = associate . associate --} instance Associative (->) (,) where associate ((a,b),c) = (a,(b,c)) disassociate (a,(b,c)) = ((a,b),c) instance Associative (->) Either where associate (Left (Left a)) = Left a associate (Left (Right b)) = Right (Left b) associate (Right c) = Right (Right c) disassociate (Left a) = Left (Left a) disassociate (Right (Left b)) = Left (Right b) disassociate (Right (Right c)) = Right c categories-1.0.7/src/Control/Category/Braided.hs0000644000000000000000000000370412453036423017712 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE MultiParamTypeClasses #-} ------------------------------------------------------------------------------------------- -- | -- Module : Control.Category.Braided -- Copyright : 2008-2012 Edward Kmett -- License : BSD -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability: portable -- ------------------------------------------------------------------------------------------- module Control.Category.Braided ( Braided(..) , Symmetric , swap ) where -- import Control.Categorical.Bifunctor import Control.Category.Associative {- | A braided (co)(monoidal or associative) category can commute the arguments of its bi-endofunctor. Obeys the laws: > associate . braid . associate = second braid . associate . first braid > disassociate . braid . disassociate = first braid . disassociate . second braid If the category is Monoidal the following laws should be satisfied > idr . braid = idl > idl . braid = idr If the category is Comonoidal the following laws should be satisfied > braid . coidr = coidl > braid . coidl = coidr -} class Associative k p => Braided k p where braid :: k (p a b) (p b a) instance Braided (->) Either where braid (Left a) = Right a braid (Right b) = Left b instance Braided (->) (,) where braid ~(a,b) = (b,a) {-- RULES "braid/associate/braid" second braid . associate . first braid = associate . braid . associate "braid/disassociate/braid" first braid . disassociate . second braid = disassociate . braid . disassociate --} {- | If we have a symmetric (co)'Monoidal' category, you get the additional law: > swap . swap = id -} class Braided k p => Symmetric k p swap :: Symmetric k p => k (p a b) (p b a) swap = braid {-- RULES "swap/swap" swap . swap = id --} instance Symmetric (->) Either instance Symmetric (->) (,) categories-1.0.7/src/Control/Category/Cartesian.hs0000644000000000000000000001043412453036423020267 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE TypeFamilies, MultiParamTypeClasses, TypeOperators, FlexibleContexts, FlexibleInstances, UndecidableInstances #-} ------------------------------------------------------------------------------------------- -- | -- Module : Control.Category.Cartesian -- Copyright : 2008-2010 Edward Kmett -- License : BSD -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable (class-associated types) -- ------------------------------------------------------------------------------------------- module Control.Category.Cartesian ( -- * (Co)Cartesian categories Cartesian(..) , bimapProduct, braidProduct, associateProduct, disassociateProduct , CoCartesian(..) , bimapSum, braidSum, associateSum, disassociateSum ) where import Control.Category.Braided import Control.Category.Monoidal import Prelude hiding (Functor, map, (.), id, fst, snd, curry, uncurry) import qualified Prelude (fst,snd) import Control.Categorical.Bifunctor import Control.Category infixr 3 &&& infixr 2 ||| {- | Minimum definition: > fst, snd, diag > fst, snd, (&&&) -} class (Symmetric k (Product k), Monoidal k (Product k)) => Cartesian k where type Product k :: * -> * -> * fst :: Product k a b `k` a snd :: Product k a b `k` b diag :: a `k` Product k a a (&&&) :: (a `k` b) -> (a `k` c) -> a `k` Product k b c diag = id &&& id f &&& g = bimap f g . diag {-- RULES "fst . diag" fst . diag = id "snd . diag" snd . diag = id "fst . f &&& g" forall f g. fst . (f &&& g) = f "snd . f &&& g" forall f g. snd . (f &&& g) = g --} instance Cartesian (->) where type Product (->) = (,) fst = Prelude.fst snd = Prelude.snd diag a = (a,a) (f &&& g) a = (f a, g a) -- | free construction of 'Bifunctor' for the product 'Bifunctor' @Product k@ if @(&&&)@ is known bimapProduct :: Cartesian k => k a c -> k b d -> Product k a b `k` Product k c d bimapProduct f g = (f . fst) &&& (g . snd) -- | free construction of 'Braided' for the product 'Bifunctor' @Product k@ braidProduct :: Cartesian k => k (Product k a b) (Product k b a) braidProduct = snd &&& fst -- | free construction of 'Associative' for the product 'Bifunctor' @Product k@ associateProduct :: Cartesian k => Product k (Product k a b) c `k` Product k a (Product k b c) associateProduct = (fst . fst) &&& first snd -- | free construction of 'Disassociative' for the product 'Bifunctor' @Product k@ disassociateProduct:: Cartesian k => Product k a (Product k b c) `k` Product k (Product k a b) c disassociateProduct= braid . second braid . associateProduct . first braid . braid -- * Co-Cartesian categories -- a category that has finite coproducts, weakened the same way as PreCartesian above was weakened class (Monoidal k (Sum k), Symmetric k (Sum k)) => CoCartesian k where type Sum k :: * -> * -> * inl :: a `k` Sum k a b inr :: b `k` Sum k a b codiag :: Sum k a a `k` a (|||) :: k a c -> k b c -> Sum k a b `k` c codiag = id ||| id f ||| g = codiag . bimap f g {-- RULES "codiag . inl" codiag . inl = id "codiag . inr" codiag . inr = id "(f ||| g) . inl" forall f g. (f ||| g) . inl = f "(f ||| g) . inr" forall f g. (f ||| g) . inr = g --} instance CoCartesian (->) where type Sum (->) = Either inl = Left inr = Right codiag (Left a) = a codiag (Right a) = a (f ||| _) (Left a) = f a (_ ||| g) (Right a) = g a -- | free construction of 'Bifunctor' for the coproduct 'Bifunctor' @Sum k@ if @(|||)@ is known bimapSum :: CoCartesian k => k a c -> k b d -> Sum k a b `k` Sum k c d bimapSum f g = (inl . f) ||| (inr . g) -- | free construction of 'Braided' for the coproduct 'Bifunctor' @Sum k@ braidSum :: CoCartesian k => Sum k a b `k` Sum k b a braidSum = inr ||| inl -- | free construction of 'Associative' for the coproduct 'Bifunctor' @Sum k@ associateSum :: CoCartesian k => Sum k (Sum k a b) c `k` Sum k a (Sum k b c) associateSum = braid . first braid . disassociateSum . second braid . braid -- | free construction of 'Disassociative' for the coproduct 'Bifunctor' @Sum k@ disassociateSum :: CoCartesian k => Sum k a (Sum k b c) `k` Sum k (Sum k a b) c disassociateSum = (inl . inl) ||| first inr categories-1.0.7/src/Control/Category/Discrete.hs0000644000000000000000000000225212453036423020117 0ustar0000000000000000{-# LANGUAGE GADTs, TypeOperators #-} ------------------------------------------------------------------------------------------- -- | -- Module : Control.Category.Discrete -- Copyright : 2008-2010 Edward Kmett -- License : BSD -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : portable -- ------------------------------------------------------------------------------------------- module Control.Category.Discrete ( Discrete(Refl) , liftDiscrete , cast , inverse ) where import Prelude () import Control.Category -- | Category of discrete objects. The only arrows are identity arrows. data Discrete a b where Refl :: Discrete a a instance Category Discrete where id = Refl Refl . Refl = Refl -- instance Groupoid Discrete where -- inv Refl = Refl -- | Discrete a b acts as a proof that a = b, lift that proof into something of kind * -> * liftDiscrete :: Discrete a b -> Discrete (f a) (f b) liftDiscrete Refl = Refl -- | Lower the proof that a ~ b to an arbitrary category. cast :: Category k => Discrete a b -> k a b cast Refl = id -- | inverse :: Discrete a b -> Discrete b a inverse Refl = Refl categories-1.0.7/src/Control/Category/Distributive.hs0000644000000000000000000000264712453036423021042 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------------------- -- | -- Module : Control.Category.Distributive -- Copyright: 2008 Edward Kmett -- License : BSD -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability: non-portable (class-associated types) -- ------------------------------------------------------------------------------------------- module Control.Category.Distributive ( -- * Distributive Categories factor , Distributive(..) ) where import Prelude hiding (Functor, map, (.), id, fst, snd, curry, uncurry) import Control.Categorical.Bifunctor import Control.Category.Cartesian -- | The canonical factoring morphism. factor :: (Cartesian k, CoCartesian k) => Sum k (Product k a b) (Product k a c) `k` Product k a (Sum k b c) factor = second inl ||| second inr -- | A category in which 'factor' is an isomorphism class (Cartesian k, CoCartesian k) => Distributive k where distribute :: Product k a (Sum k b c) `k` Sum k (Product k a b) (Product k a c) instance Distributive (->) where distribute (a, Left b) = Left (a,b) distribute (a, Right c) = Right (a,c) {-- RULES "factor . distribute" factor . distribute = id "distribute . factor" distribute . factor = id --} categories-1.0.7/src/Control/Category/Dual.hs0000644000000000000000000000460212453036423017243 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators, FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} #endif ------------------------------------------------------------------------------------------- -- | -- Module : Control.Category.Dual -- Copyright: 2008-2010 Edward Kmett -- License : BSD -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability: portable -- ------------------------------------------------------------------------------------------- module Control.Category.Dual ( Dual(..) ) where #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif import Control.Category #ifdef __GLASGOW_HASKELL__ import Data.Data (Data(..), mkDataType, DataType, mkConstr, Constr, constrIndex, Fixity(..)) #if __GLASGOW_HASKELL__ < 708 #if MIN_VERSION_base(4,4,0) import Data.Typeable (Typeable2(..), TyCon, mkTyCon3, mkTyConApp, gcast1) #else import Data.Typeable (Typeable2(..), TyCon, mkTyCon, mkTyConApp, gcast1) #endif import Prelude (undefined,const,error) #else import Prelude (error) import Data.Typeable (Typeable, gcast1) #endif #endif data Dual k a b = Dual { runDual :: k b a } #if __GLASGOW_HASKELL__ >= 708 deriving Typeable #define Typeable2 Typeable #endif instance Category k => Category (Dual k) where id = Dual id Dual f . Dual g = Dual (g . f) #ifdef __GLASGOW_HASKELL__ #if __GLASGOW_HASKELL__ < 707 instance Typeable2 k => Typeable2 (Dual k) where typeOf2 tfab = mkTyConApp dataTyCon [typeOf2 (undefined `asDualArgsType` tfab)] where asDualArgsType :: f b a -> t f a b -> f b a asDualArgsType = const dataTyCon :: TyCon #if MIN_VERSION_base(4,4,0) dataTyCon = mkTyCon3 "categories" "Control.Category.Dual" "Dual" #else dataTyCon = mkTyCon "Control.Category.Dual.Dual" #endif {-# NOINLINE dataTyCon #-} #endif dualConstr :: Constr dualConstr = mkConstr dataDataType "Dual" [] Prefix {-# NOINLINE dualConstr #-} dataDataType :: DataType dataDataType = mkDataType "Control.Category.Dual.Dual" [dualConstr] {-# NOINLINE dataDataType #-} instance (Typeable2 k, Data a, Data b, Data (k b a)) => Data (Dual k a b) where gfoldl f z (Dual a) = z Dual `f` a toConstr _ = dualConstr gunfold k z c = case constrIndex c of 1 -> k (z Dual) _ -> error "gunfold" dataTypeOf _ = dataDataType dataCast1 f = gcast1 f #endif categories-1.0.7/src/Control/Category/Monoidal.hs0000644000000000000000000000523312453036423020121 0ustar0000000000000000{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} ------------------------------------------------------------------------------------------- -- | -- Module : Control.Category.Monoidal -- Copyright : 2008,2012 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 newtype wrapping. ------------------------------------------------------------------------------------------- module Control.Category.Monoidal ( Monoidal(..) ) where import Control.Category.Associative import Data.Void -- | Denotes that we have some reasonable notion of 'Identity' for a particular 'Bifunctor' in this 'Category'. This -- notion is currently used by both 'Monoidal' and 'Comonoidal' {- | A monoidal category. 'idl' and 'idr' are traditionally denoted lambda and rho the triangle identities hold: > first idr = second idl . associate > second idl = first idr . associate > first idr = disassociate . second idl > second idl = disassociate . first idr > idr . coidr = id > idl . coidl = id > coidl . idl = id > coidr . idr = id -} class Associative k p => Monoidal (k :: * -> * -> *) (p :: * -> * -> *) where type Id (k :: * -> * -> *) (p :: * -> * -> *) :: * idl :: k (p (Id k p) a) a idr :: k (p a (Id k p)) a coidl :: k a (p (Id k p) a) coidr :: k a (p a (Id k p)) instance Monoidal (->) (,) where type Id (->) (,) = () idl = snd idr = fst coidl a = ((),a) coidr a = (a,()) instance Monoidal (->) Either where type Id (->) Either = Void idl = either absurd id idr = either id absurd coidl = Right coidr = Left {-- RULES -- "bimap id idl/associate" second idl . associate = first idr -- "bimap idr id/associate" first idr . associate = second idl -- "disassociate/bimap id idl" disassociate . second idl = first idr -- "disassociate/bimap idr id" disassociate . first idr = second 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 --} categories-1.0.7/src/Control/Category/Cartesian/0000755000000000000000000000000012453036423017731 5ustar0000000000000000categories-1.0.7/src/Control/Category/Cartesian/Closed.hs0000644000000000000000000000536112453036423021503 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE TypeFamilies, MultiParamTypeClasses, TypeOperators, FlexibleContexts #-} ------------------------------------------------------------------------------------------- -- | -- Module : Control.Category.Cartesian.Closed -- Copyright : 2008 Edward Kmett -- License : BSD -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability: non-portable (class-associated types) -- ------------------------------------------------------------------------------------------- module Control.Category.Cartesian.Closed ( -- * Cartesian Closed Category CCC(..) , unitCCC, counitCCC -- * Co-(Cartesian Closed Category) , CoCCC(..) , unitCoCCC, counitCoCCC ) where import Prelude () import qualified Prelude import Control.Category import Control.Category.Braided import Control.Category.Cartesian -- * Closed Cartesian Category -- | A 'CCC' has full-fledged monoidal finite products and exponentials -- Ideally you also want an instance for @'Bifunctor' ('Exp' hom) ('Dual' hom) hom hom@. -- or at least @'Functor' ('Exp' hom a) hom hom@, which cannot be expressed in the constraints here. class Cartesian k => CCC k where type Exp k :: * -> * -> * apply :: Product k (Exp k a b) a `k` b curry :: Product k a b `k` c -> a `k` Exp k b c uncurry :: a `k` Exp k b c -> Product k a b `k` c instance CCC (->) where type Exp (->) = (->) apply (f,a) = f a curry = Prelude.curry uncurry = Prelude.uncurry {-# RULES "curry apply" curry apply = id -- "curry . uncurry" curry . uncurry = id -- "uncurry . curry" uncurry . curry = id #-} -- * Free @'Adjunction' (Product (<=) a) (Exp (<=) a) (<=) (<=)@ unitCCC :: CCC k => a `k` Exp k b (Product k b a) unitCCC = curry braid counitCCC :: CCC k => Product k b (Exp k b a) `k` a counitCCC = apply . braid -- * A Co-(Closed Cartesian Category) -- | A Co-CCC has full-fledged comonoidal finite coproducts and coexponentials -- You probably also want an instance for @'Bifunctor' ('coexp' hom) ('Dual' hom) hom hom@. class CoCartesian k => CoCCC k where type Coexp k :: * -> * -> * coapply :: b `k` Sum k (Coexp k a b) a cocurry :: c `k` Sum k a b -> Coexp k b c `k` a uncocurry :: Coexp k b c `k` a -> c `k` Sum k a b {-# RULES "cocurry coapply" cocurry coapply = id -- "cocurry . uncocurry" cocurry . uncocurry = id -- "uncocurry . cocurry" uncocurry . cocurry = id #-} -- * Free @'Adjunction' ('Coexp' (<=) a) ('Sum' (<=) a) (<=) (<=)@ unitCoCCC :: CoCCC k => a `k` Sum k b (Coexp k b a) unitCoCCC = swap . coapply counitCoCCC :: CoCCC k => Coexp k b (Sum k b a) `k` a counitCoCCC = cocurry swap