categories-1.0.6/0000755000000000000000000000000012160660547012040 5ustar0000000000000000categories-1.0.6/.ghci0000644000000000000000000000012512160660547012751 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h categories-1.0.6/.gitignore0000644000000000000000000000010412160660547014023 0ustar0000000000000000dist docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# categories-1.0.6/.travis.yml0000644000000000000000000000033712160660547014154 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.6/.vim.custom0000644000000000000000000000137712160660547014155 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.6/categories.cabal0000644000000000000000000000312612160660547015153 0ustar0000000000000000name: categories category: Control version: 1.0.6 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-2010, Edward A. Kmett description: Categories build-type: Simple tested-with: GHC == 7.4.1, GHC == 7.6.1 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.6/CHANGELOG.markdown0000644000000000000000000000017212160660547015073 0ustar00000000000000001.0.6 ----- * Marked modules `Trustworthy` 1.0.5 --- * Removed the upper bound on void. * Added `README` and `CHANGELOG` categories-1.0.6/LICENSE0000644000000000000000000000266012160660547013051 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.6/README.markdown0000644000000000000000000000071312160660547014542 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.6/Setup.lhs0000644000000000000000000000016512160660547013652 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain categories-1.0.6/src/0000755000000000000000000000000012160660547012627 5ustar0000000000000000categories-1.0.6/src/Control/0000755000000000000000000000000012160660547014247 5ustar0000000000000000categories-1.0.6/src/Control/Categorical/0000755000000000000000000000000012160660547016464 5ustar0000000000000000categories-1.0.6/src/Control/Categorical/Bifunctor.hs0000644000000000000000000000433512160660547020760 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.6/src/Control/Categorical/Functor.hs0000644000000000000000000001074412160660547020446 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, UndecidableInstances, FlexibleInstances #-} ------------------------------------------------------------------------------------------- -- | -- 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 MIN_VERSION_base(4,4,0) import Data.Typeable (Typeable1(..), TyCon, mkTyCon3, mkTyConApp, gcast1) #else import Data.Typeable (Typeable1(..), TyCon, mkTyCon, mkTyConApp, gcast1) #endif #endif -- TODO Data, Typeable newtype LiftedFunctor f a = LiftedFunctor (f a) deriving (Show, Read) #ifdef __GLASGOW_HASKELL__ 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 #-} liftedConstr :: Constr liftedConstr = mkConstr liftedDataType "LiftedFunctor" [] Prefix {-# NOINLINE liftedConstr #-} liftedDataType :: DataType liftedDataType = mkDataType "Control.Categorical.Fucntor.LiftedFunctor" [liftedConstr] {-# NOINLINE liftedDataType #-} 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 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) #ifdef __GLASGOW_HASKELL__ 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 #-} loweredConstr :: Constr loweredConstr = mkConstr loweredDataType "LoweredFunctor" [] Prefix {-# NOINLINE loweredConstr #-} loweredDataType :: DataType loweredDataType = mkDataType "Control.Categorical.Fucntor.LoweredFunctor" [loweredConstr] {-# NOINLINE loweredDataType #-} 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 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.6/src/Control/Categorical/Object.hs0000644000000000000000000000244612160660547020234 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.6/src/Control/Category/0000755000000000000000000000000012160660547016024 5ustar0000000000000000categories-1.0.6/src/Control/Category/Associative.hs0000644000000000000000000000363012160660547020634 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.6/src/Control/Category/Braided.hs0000644000000000000000000000370412160660547017716 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.6/src/Control/Category/Cartesian.hs0000644000000000000000000001043412160660547020273 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.6/src/Control/Category/Discrete.hs0000644000000000000000000000225212160660547020123 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.6/src/Control/Category/Distributive.hs0000644000000000000000000000264712160660547021046 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.6/src/Control/Category/Dual.hs0000644000000000000000000000416212160660547017250 0ustar0000000000000000{-# LANGUAGE TypeOperators, FlexibleContexts #-} {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #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 Prelude (undefined,const,error) import Control.Category #ifdef __GLASGOW_HASKELL__ import Data.Data (Data(..), mkDataType, DataType, mkConstr, Constr, constrIndex, Fixity(..)) #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 #endif data Dual k a b = Dual { runDual :: k b a } instance Category k => Category (Dual k) where id = Dual id Dual f . Dual g = Dual (g . f) #ifdef __GLASGOW_HASKELL__ 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 #-} 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.6/src/Control/Category/Monoidal.hs0000644000000000000000000000523312160660547020125 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.6/src/Control/Category/Cartesian/0000755000000000000000000000000012160660547017735 5ustar0000000000000000categories-1.0.6/src/Control/Category/Cartesian/Closed.hs0000644000000000000000000000536112160660547021507 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