├── cabal.project ├── tests ├── Spec.hs └── GenericsSpec.hs ├── Setup.lhs ├── cabal.haskell-ci ├── src ├── Data │ ├── Functor1 │ │ └── Applied.hs │ ├── Functor1.hs │ └── Functor │ │ ├── Contravariant │ │ ├── Yoneda.hs │ │ ├── Adjunction.hs │ │ └── Rep.hs │ │ ├── Adjunction.hs │ │ └── Rep.hs └── Control │ ├── Comonad │ ├── Contra │ │ └── Adjoint.hs │ ├── Trans │ │ └── Adjoint.hs │ └── Representable │ │ └── Store.hs │ └── Monad │ ├── Contra │ └── Adjoint.hs │ ├── Trans │ ├── Adjoint.hs │ ├── Contravariant │ │ └── Adjoint.hs │ └── Conts.hs │ └── Representable │ ├── Reader.hs │ └── State.hs ├── .hlint.yaml ├── .gitignore ├── README.markdown ├── .vim.custom ├── LICENSE ├── adjunctions.cabal ├── CHANGELOG.markdown └── .github └── workflows └── haskell-ci.yml /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | > module Main (main) where 3 | 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | no-tests-no-benchmarks: False 2 | unconstrained: False 3 | -- irc-channels: irc.freenode.org#haskell-lens 4 | irc-if-in-origin-repo: True 5 | -------------------------------------------------------------------------------- /src/Data/Functor1/Applied.hs: -------------------------------------------------------------------------------- 1 | module Data.Functor1.Applied where 2 | 3 | import Data.Functor1 4 | 5 | newtype Applied a f = Applied { runApplied :: f a } 6 | 7 | instance Functor1 (Applied a) where 8 | map1 f = Applied . f . runApplied 9 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # - ignore: {name: Use let} 2 | # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules 3 | 4 | - ignore: 5 | name: Avoid lambda 6 | 7 | - ignore: 8 | name: Use section 9 | 10 | - ignore: 11 | name: Use fmap 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | docs 4 | wiki 5 | TAGS 6 | tags 7 | wip 8 | .DS_Store 9 | .*.swp 10 | .*.swo 11 | *.o 12 | *.hi 13 | *~ 14 | *# 15 | .stack-work/ 16 | cabal-dev 17 | *.chi 18 | *.chs.h 19 | *.dyn_o 20 | *.dyn_hi 21 | .hpc 22 | .hsenv 23 | .cabal-sandbox/ 24 | cabal.sandbox.config 25 | *.prof 26 | *.aux 27 | *.hp 28 | *.eventlog 29 | cabal.project.local 30 | cabal.project.local~ 31 | .HTF/ 32 | .ghc.environment.* 33 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | adjunctions 2 | ========== 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/adjunctions.svg)](https://hackage.haskell.org/package/adjunctions) [![Build Status](https://github.com/ekmett/adjunctions/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/adjunctions/actions?query=workflow%3AHaskell-CI) 5 | 6 | This package provides adjunctions for Haskell. 7 | 8 | Contact Information 9 | ------------------- 10 | 11 | Contributions and bug reports are welcome! 12 | 13 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 14 | 15 | -Edward Kmett 16 | -------------------------------------------------------------------------------- /src/Data/Functor1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | module Data.Functor1 where 5 | 6 | import Control.Applicative (Const(..)) 7 | import Data.Functor.Identity 8 | import Data.Proxy 9 | 10 | class Functor1 w where 11 | -- | @ 12 | -- 'map1' f . 'map1' g = 'map1' (f . g) 13 | -- 'map1' id = id 14 | -- @ 15 | map1 :: (forall a. f a -> g a) -> w f -> w g 16 | 17 | map1Identity :: Functor1 w => (forall x. f x -> x) -> w f -> w Identity 18 | map1Identity f = map1 (Identity . f) 19 | 20 | instance Functor1 Proxy where 21 | map1 _ Proxy = Proxy 22 | 23 | instance Functor1 (Const a) where 24 | map1 _ = Const . getConst 25 | -------------------------------------------------------------------------------- /.vim.custom: -------------------------------------------------------------------------------- 1 | " Add the following to your .vimrc to automatically load this on startup 2 | 3 | " if filereadable(".vim.custom") 4 | " so .vim.custom 5 | " endif 6 | 7 | function StripTrailingWhitespace() 8 | let myline=line(".") 9 | let mycolumn = col(".") 10 | silent %s/ *$// 11 | call cursor(myline, mycolumn) 12 | endfunction 13 | 14 | " enable syntax highlighting 15 | syntax on 16 | 17 | " search for the tags file anywhere between here and / 18 | set tags=TAGS;/ 19 | 20 | " highlight tabs and trailing spaces 21 | set listchars=tab:‗‗,trail:‗ 22 | set list 23 | 24 | " f2 runs hasktags 25 | map :exec ":!hasktags -x -c --ignore src" 26 | 27 | " strip trailing whitespace before saving 28 | " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() 29 | 30 | " rebuild hasktags after saving 31 | au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" 32 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2011-2014 Edward Kmett 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 20 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 22 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 23 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 24 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 25 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 26 | POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /src/Control/Comonad/Contra/Adjoint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Copyright : (C) 2011-2013 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- 8 | -- Maintainer : Edward Kmett 9 | -- Stability : provisional 10 | -- Portability : MPTCs 11 | -- 12 | -- Use a contravariant dual adjunction from Hask^op to build a 'Monad' to 13 | -- 'Comonad' transformer. 14 | ---------------------------------------------------------------------------- 15 | 16 | module Control.Comonad.Contra.Adjoint 17 | ( Adjoint 18 | , runAdjoint 19 | , adjoint 20 | , AdjointT(..) 21 | ) where 22 | 23 | import Control.Comonad 24 | import Control.Monad (liftM) 25 | import Data.Functor.Identity 26 | import Data.Functor.Contravariant 27 | import Data.Functor.Contravariant.DualAdjunction 28 | 29 | type Adjoint f g = AdjointT f g Identity 30 | 31 | newtype AdjointT f g m a = AdjointT { runAdjointT :: f (m (g a)) } 32 | 33 | adjoint :: Contravariant f => f (g a) -> Adjoint f g a 34 | adjoint = AdjointT . contramap runIdentity 35 | 36 | runAdjoint :: Contravariant f => Adjoint f g a -> f (g a) 37 | runAdjoint = contramap Identity . runAdjointT 38 | 39 | instance (Contravariant f, Contravariant g, Monad m) => Functor (AdjointT f g m) where 40 | fmap f (AdjointT g) = AdjointT $ contramap (liftM (contramap f)) g 41 | 42 | instance (DualAdjunction f g, Monad m) => Comonad (AdjointT f g m) where 43 | extract = rightAdjunct return . runAdjointT 44 | extend f = AdjointT . contramap (>>= leftAdjunct (f . AdjointT)) . runAdjointT 45 | -------------------------------------------------------------------------------- /src/Control/Monad/Contra/Adjoint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Copyright : (C) 2011-2013 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- 8 | -- Maintainer : Edward Kmett 9 | -- Stability : provisional 10 | -- Portability : MPTCs, fundeps 11 | -- 12 | -- Use a contravariant adjunction to Hask^op to build a 'Comonad' to 13 | -- 'Monad' transformer. 14 | ---------------------------------------------------------------------------- 15 | 16 | module Control.Monad.Contra.Adjoint 17 | ( Adjoint 18 | , runAdjoint 19 | , adjoint 20 | , AdjointT(..) 21 | ) where 22 | 23 | import Control.Applicative 24 | import Control.Comonad 25 | import Control.Monad (ap) 26 | import Data.Functor.Identity 27 | import Data.Functor.Contravariant 28 | import Data.Functor.Contravariant.Adjunction 29 | 30 | type Adjoint f g = AdjointT f g Identity 31 | 32 | newtype AdjointT f g w a = AdjointT { runAdjointT :: g (w (f a)) } 33 | 34 | adjoint :: Contravariant g => g (f a) -> Adjoint f g a 35 | adjoint = AdjointT . contramap runIdentity 36 | 37 | runAdjoint :: Contravariant g => Adjoint f g a -> g (f a) 38 | runAdjoint = contramap Identity . runAdjointT 39 | 40 | instance (Adjunction f g, Functor w) => Functor (AdjointT f g w) where 41 | fmap f (AdjointT g) = AdjointT $ contramap (fmap (contramap f)) g 42 | 43 | instance (Adjunction f g, Comonad w) => Applicative (AdjointT f g w) where 44 | pure = AdjointT . leftAdjunct extract 45 | (<*>) = ap 46 | 47 | instance (Adjunction f g, Comonad w) => Monad (AdjointT f g w) where 48 | return = AdjointT . leftAdjunct extract 49 | AdjointT m >>= f = AdjointT $ contramap (extend (rightAdjunct (runAdjointT . f))) m 50 | 51 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/Adjoint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Copyright : (C) 2011-2013 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : Edward Kmett 8 | -- Stability : provisional 9 | -- Portability : MPTCs, fundeps 10 | -- 11 | ---------------------------------------------------------------------------- 12 | 13 | module Control.Monad.Trans.Adjoint 14 | ( Adjoint 15 | , runAdjoint 16 | , adjoint 17 | , AdjointT(..) 18 | ) where 19 | 20 | import Prelude hiding (sequence) 21 | import Control.Monad (ap, liftM) 22 | import Control.Monad.Trans.Class 23 | import Data.Traversable 24 | import Data.Functor.Adjunction 25 | import Data.Functor.Identity 26 | 27 | type Adjoint f g = AdjointT f g Identity 28 | 29 | newtype AdjointT f g m a = AdjointT { runAdjointT :: g (m (f a)) } 30 | 31 | adjoint :: Functor g => g (f a) -> Adjoint f g a 32 | adjoint = AdjointT . fmap Identity 33 | 34 | runAdjoint :: Functor g => Adjoint f g a -> g (f a) 35 | runAdjoint = fmap runIdentity . runAdjointT 36 | 37 | instance (Adjunction f g, Monad m) => Functor (AdjointT f g m) where 38 | fmap f (AdjointT g) = AdjointT $ fmap (liftM (fmap f)) g 39 | b <$ AdjointT g = AdjointT $ fmap (liftM (b <$)) g 40 | 41 | instance (Adjunction f g, Monad m) => Applicative (AdjointT f g m) where 42 | pure = AdjointT . leftAdjunct return 43 | (<*>) = ap 44 | 45 | instance (Adjunction f g, Monad m) => Monad (AdjointT f g m) where 46 | return = pure 47 | AdjointT m >>= f = AdjointT $ fmap (>>= rightAdjunct (runAdjointT . f)) m 48 | 49 | -- | Exploiting this instance requires that we have the missing Traversables for Identity, (,)e and IdentityT 50 | instance (Adjunction f g, Traversable f) => MonadTrans (AdjointT f g) where 51 | lift = AdjointT . fmap sequence . unit 52 | -------------------------------------------------------------------------------- /src/Control/Comonad/Trans/Adjoint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Copyright : (C) 2011-2013 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : Edward Kmett 8 | -- Stability : provisional 9 | -- Portability : MPTCs, fundeps 10 | -- 11 | ---------------------------------------------------------------------------- 12 | 13 | module Control.Comonad.Trans.Adjoint 14 | ( Adjoint 15 | , runAdjoint 16 | , adjoint 17 | , AdjointT(..) 18 | ) where 19 | 20 | import Control.Comonad 21 | import Control.Comonad.Trans.Class 22 | import Data.Functor.Adjunction 23 | import Data.Functor.Extend 24 | import Data.Functor.Identity 25 | import Data.Distributive 26 | 27 | type Adjoint f g = AdjointT f g Identity 28 | 29 | newtype AdjointT f g w a = AdjointT { runAdjointT :: f (w (g a)) } 30 | 31 | adjoint :: Functor f => f (g a) -> Adjoint f g a 32 | adjoint = AdjointT . fmap Identity 33 | 34 | runAdjoint :: Functor f => Adjoint f g a -> f (g a) 35 | runAdjoint = fmap runIdentity . runAdjointT 36 | 37 | instance (Adjunction f g, Functor w) => Functor (AdjointT f g w) where 38 | fmap f (AdjointT g) = AdjointT $ fmap (fmap (fmap f)) g 39 | b <$ (AdjointT g) = AdjointT $ fmap (fmap (b <$)) g 40 | 41 | instance (Adjunction f g, Extend w) => Extend (AdjointT f g w) where 42 | extended f (AdjointT m) = AdjointT $ fmap (extended $ leftAdjunct (f . AdjointT)) m 43 | 44 | instance (Adjunction f g, Comonad w) => Comonad (AdjointT f g w) where 45 | extend f (AdjointT m) = AdjointT $ fmap (extend $ leftAdjunct (f . AdjointT)) m 46 | extract = rightAdjunct extract . runAdjointT 47 | 48 | {- 49 | instance (Adjunction f g, Monad m) => Applicative (AdjointT f g m) where 50 | pure = AdjointT . leftAdjunct return 51 | (<*>) = ap 52 | -} 53 | 54 | instance (Adjunction f g, Distributive g) => ComonadTrans (AdjointT f g) where 55 | lower = counit . fmap distribute . runAdjointT 56 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/Contravariant/Adjoint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Control.Monad.Trans.Contravariant.Adjoint 5 | -- Copyright : (C) 2011 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- 8 | -- Maintainer : Edward Kmett 9 | -- Stability : provisional 10 | -- Portability : MPTCs, fundeps 11 | -- 12 | -- Uses a contravariant adjunction: 13 | -- 14 | -- f -| g : Hask^op -> Hask 15 | -- 16 | -- to build a 'Comonad' to 'Monad' transformer. Sadly, the dual construction, 17 | -- which builds a 'Comonad' out of a 'Monad', is uninhabited, because any 18 | -- 'Adjunction' of the form 19 | -- 20 | -- > f -| g : Hask -> Hask^op 21 | -- 22 | -- would trivially admit unsafePerformIO. 23 | -- 24 | ---------------------------------------------------------------------------- 25 | 26 | module Control.Monad.Trans.Contravariant.Adjoint 27 | ( Adjoint 28 | , runAdjoint 29 | , adjoint 30 | , AdjointT(..) 31 | ) where 32 | 33 | import Prelude 34 | import Control.Comonad 35 | import Control.Monad (ap) 36 | import Data.Functor.Identity 37 | import Data.Functor.Contravariant 38 | import Data.Functor.Contravariant.Adjunction 39 | 40 | type Adjoint f g = AdjointT f g Identity 41 | 42 | newtype AdjointT f g w a = AdjointT { runAdjointT :: g (w (f a)) } 43 | 44 | adjoint :: Contravariant g => g (f a) -> Adjoint f g a 45 | adjoint = AdjointT . contramap runIdentity 46 | 47 | runAdjoint :: Contravariant g => Adjoint f g a -> g (f a) 48 | runAdjoint = contramap Identity . runAdjointT 49 | 50 | instance (Adjunction f g, Functor w) => Functor (AdjointT f g w) where 51 | fmap f (AdjointT g) = AdjointT $ contramap (fmap (contramap f)) g 52 | 53 | instance (Adjunction f g, Comonad w) => Applicative (AdjointT f g w) where 54 | pure = AdjointT . leftAdjunct extract 55 | (<*>) = ap 56 | 57 | instance (Adjunction f g, Comonad w) => Monad (AdjointT f g w) where 58 | return = pure 59 | AdjointT m >>= f = AdjointT $ contramap (extend (rightAdjunct (runAdjointT . f))) m 60 | -------------------------------------------------------------------------------- /src/Data/Functor/Contravariant/Yoneda.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, Rank2Types, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Copyright : (C) 2011-2013 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- 8 | -- Maintainer : Edward Kmett 9 | -- Stability : provisional 10 | -- Portability : MPTCs, fundeps 11 | -- 12 | ---------------------------------------------------------------------------- 13 | 14 | module Data.Functor.Contravariant.Yoneda 15 | ( YonedaT(..) 16 | , liftYonedaT 17 | , lowerYonedaT 18 | , maxF, minF 19 | ) where 20 | 21 | import Prelude 22 | import Data.Functor.Identity 23 | import Data.Functor.Contravariant.Adjunction 24 | import Data.Functor.Contravariant.DualAdjunction 25 | import Data.Functor.Contravariant 26 | import Data.Distributive 27 | import Text.Read 28 | 29 | -- | The covariant Yoneda lemma applied to a contravariant functor 30 | 31 | newtype YonedaT f a = YonedaT { runYonedaT :: forall b. (b -> a) -> f b } 32 | 33 | liftYonedaT :: Contravariant f => f a -> YonedaT f a 34 | liftYonedaT a = YonedaT (\f -> contramap f a) 35 | 36 | lowerYonedaT :: YonedaT f a -> f a 37 | lowerYonedaT (YonedaT f) = f id 38 | 39 | instance Contravariant (YonedaT f) where 40 | contramap f m = YonedaT (\k -> runYonedaT m (f . k)) 41 | 42 | instance Adjunction f g => Adjunction (YonedaT f) (YonedaT g) where 43 | unit = liftYonedaT . contramap lowerYonedaT . unit 44 | counit = liftYonedaT . contramap lowerYonedaT . counit 45 | 46 | instance DualAdjunction f g => DualAdjunction (YonedaT f) (YonedaT g) where 47 | unitOp = unitOp . contramap liftYonedaT . lowerYonedaT 48 | counitOp = counitOp . contramap liftYonedaT . lowerYonedaT 49 | 50 | instance Eq (f a) => Eq (YonedaT f a) where 51 | YonedaT f == YonedaT g = f id == g id 52 | 53 | instance Ord (f a) => Ord (YonedaT f a) where 54 | YonedaT f `compare` YonedaT g = f id `compare` g id 55 | 56 | maxF :: (Contravariant f, Ord (f a)) => YonedaT f a -> YonedaT f a -> YonedaT f a 57 | YonedaT f `maxF` YonedaT g = liftYonedaT $ f id `max` g id 58 | -- {-# RULES "max/maxF" max = maxF #-} 59 | {-# INLINE maxF #-} 60 | 61 | minF :: (Contravariant f, Ord (f a)) => YonedaT f a -> YonedaT f a -> YonedaT f a 62 | YonedaT f `minF` YonedaT g = liftYonedaT $ f id `min` g id 63 | -- {-# RULES "min/minF" min = minF #-} 64 | {-# INLINE minF #-} 65 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/Conts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Copyright : (C) 2011-2013 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : Edward Kmett 8 | -- Stability : provisional 9 | -- Portability : MPTCs, fundeps 10 | -- 11 | -- > Cont r ~ Contravariant.Adjoint (Op r) (Op r) 12 | -- > Conts r ~ Contravariant.AdjointT (Op r) (Op r) 13 | -- > ContsT r w m ~ Contravariant.AdjointT (Op (m r)) (Op (m r)) w 14 | ---------------------------------------------------------------------------- 15 | 16 | module Control.Monad.Trans.Conts 17 | ( 18 | -- * Continuation passing style 19 | Cont 20 | , cont 21 | , runCont 22 | -- * Multiple-continuation passing style 23 | , Conts 24 | , runConts 25 | , conts 26 | -- * Multiple-continuation passing style transformer 27 | , ContsT(..) 28 | , callCC 29 | ) where 30 | 31 | import Prelude 32 | import Control.Comonad 33 | import Control.Monad.Trans.Class 34 | import Control.Monad (ap) 35 | import Data.Functor.Apply 36 | import Data.Functor.Identity 37 | 38 | type Cont r = ContsT r Identity Identity 39 | 40 | cont :: ((a -> r) -> r) -> Cont r a 41 | cont f = ContsT $ \ (Identity k) -> Identity $ f $ runIdentity . k 42 | 43 | runCont :: Cont r a -> (a -> r) -> r 44 | runCont (ContsT k) f = runIdentity $ k $ Identity (Identity . f) 45 | 46 | type Conts r w = ContsT r w Identity 47 | 48 | conts :: Functor w => (w (a -> r) -> r) -> Conts r w a 49 | conts k = ContsT $ Identity . k . fmap (runIdentity .) 50 | 51 | runConts :: Functor w => Conts r w a -> w (a -> r) -> r 52 | runConts (ContsT k) = runIdentity . k . fmap (Identity .) 53 | 54 | newtype ContsT r w m a = ContsT { runContsT :: w (a -> m r) -> m r } 55 | 56 | instance Functor w => Functor (ContsT r w m) where 57 | fmap f (ContsT k) = ContsT $ k . fmap (. f) 58 | 59 | instance Comonad w => Apply (ContsT r w m) where 60 | (<.>) = ap 61 | 62 | instance Comonad w => Applicative (ContsT r w m) where 63 | pure x = ContsT $ \f -> extract f x 64 | (<*>) = ap 65 | 66 | instance Comonad w => Monad (ContsT r w m) where 67 | return = pure 68 | ContsT k >>= f = ContsT $ k . extend (\wa a -> runContsT (f a) wa) 69 | 70 | callCC :: Comonad w => ((a -> ContsT r w m b) -> ContsT r w m a) -> ContsT r w m a 71 | callCC f = ContsT $ \wamr -> runContsT (f (\a -> ContsT $ \_ -> extract wamr a)) wamr 72 | 73 | {- 74 | callCCs :: Comonad w => (w (a -> ContsT r w m b) -> ContsT r w m a) -> ContsT r w m a 75 | callCCs f = 76 | -} 77 | 78 | instance Comonad w => MonadTrans (ContsT r w) where 79 | lift m = ContsT $ extract . fmap (m >>=) 80 | -------------------------------------------------------------------------------- /src/Data/Functor/Contravariant/Adjunction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Copyright : (C) 2011-2013 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- 8 | -- Maintainer : Edward Kmett 9 | -- Stability : provisional 10 | -- Portability : MPTCs 11 | -- 12 | ---------------------------------------------------------------------------- 13 | 14 | module Data.Functor.Contravariant.Adjunction 15 | ( Adjunction(..) 16 | , adjuncted 17 | , contrarepAdjunction 18 | , coindexAdjunction 19 | ) where 20 | 21 | import Data.Functor.Contravariant 22 | import Data.Functor.Contravariant.Rep 23 | import Data.Profunctor 24 | 25 | -- | An adjunction from @Hask^op@ to @Hask@ 26 | -- 27 | -- @'Op' (f a) b ~ 'Hask' a (g b)@ 28 | -- 29 | -- @ 30 | -- 'rightAdjunct' 'unit' = 'id' 31 | -- 'leftAdjunct' 'counit' = 'id' 32 | -- @ 33 | -- 34 | -- Any adjunction from @Hask@ to @Hask^op@ would indirectly 35 | -- permit @unsafePerformIO@, and therefore does not exist. 36 | 37 | class (Contravariant f, Representable g) => Adjunction f g | f -> g, g -> f where 38 | {-# MINIMAL (unit | leftAdjunct), (rightAdjunct | counit) #-} 39 | unit :: a -> g (f a) -- monad in Hask 40 | counit :: a -> f (g a) -- comonad in Hask^op 41 | leftAdjunct :: (b -> f a) -> a -> g b 42 | rightAdjunct :: (a -> g b) -> b -> f a 43 | 44 | unit = leftAdjunct id 45 | counit = rightAdjunct id 46 | leftAdjunct f = contramap f . unit 47 | rightAdjunct f = contramap f . counit 48 | 49 | -- | 'leftAdjunct' and 'rightAdjunct' form two halves of an isomorphism. 50 | -- 51 | -- This can be used with the combinators from the @lens@ package. 52 | -- 53 | -- @'adjuncted' :: 'Adjunction' f g => 'Iso'' (b -> f a) (a -> g b)@ 54 | adjuncted :: (Adjunction f g, Profunctor p, Functor h) 55 | => p (a -> g b) (h (c -> g d)) -> p (b -> f a) (h (d -> f c)) 56 | adjuncted = dimap leftAdjunct (fmap rightAdjunct) 57 | {-# INLINE adjuncted #-} 58 | 59 | -- | This 'Adjunction' gives rise to the @Cont@ 'Monad' 60 | instance Adjunction (Op r) (Op r) where 61 | unit a = Op (\k -> getOp k a) 62 | counit = unit 63 | 64 | -- | This gives rise to the @Cont Bool@ 'Monad' 65 | instance Adjunction Predicate Predicate where 66 | unit a = Predicate (\k -> getPredicate k a) 67 | counit = unit 68 | 69 | -- | Represent a 'Contravariant' functor that has a left adjoint 70 | contrarepAdjunction :: Adjunction f g => (a -> f ()) -> g a 71 | contrarepAdjunction = flip leftAdjunct () 72 | 73 | coindexAdjunction :: Adjunction f g => g a -> a -> f () 74 | coindexAdjunction = rightAdjunct . const 75 | -------------------------------------------------------------------------------- /adjunctions.cabal: -------------------------------------------------------------------------------- 1 | name: adjunctions 2 | category: Data Structures, Adjunctions 3 | version: 4.4 4 | license: BSD2 5 | cabal-version: >= 1.10 6 | license-file: LICENSE 7 | author: Edward A. Kmett 8 | maintainer: Edward A. Kmett 9 | stability: provisional 10 | homepage: http://github.com/ekmett/adjunctions/ 11 | bug-reports: http://github.com/ekmett/adjunctions/issues 12 | copyright: Copyright (C) 2011-2014 Edward A. Kmett 13 | synopsis: Adjunctions and representable functors 14 | description: Adjunctions and representable functors. 15 | build-type: Simple 16 | extra-source-files: 17 | .gitignore 18 | .hlint.yaml 19 | .vim.custom 20 | CHANGELOG.markdown 21 | README.markdown 22 | tested-with: GHC == 8.0.2 23 | , GHC == 8.2.2 24 | , GHC == 8.4.4 25 | , GHC == 8.6.5 26 | , GHC == 8.8.4 27 | , GHC == 8.10.7 28 | , GHC == 9.0.2 29 | , GHC == 9.2.8 30 | , GHC == 9.4.8 31 | , GHC == 9.6.7 32 | , GHC == 9.8.4 33 | , GHC == 9.10.3 34 | , GHC == 9.12.2 35 | 36 | source-repository head 37 | type: git 38 | location: https://github.com/ekmett/adjunctions.git 39 | 40 | library 41 | hs-source-dirs: src 42 | 43 | other-extensions: 44 | CPP 45 | FunctionalDependencies 46 | FlexibleContexts 47 | MultiParamTypeClasses 48 | Rank2Types 49 | UndecidableInstances 50 | 51 | build-depends: 52 | base >= 4.9 && < 5, 53 | comonad >= 4 && < 6, 54 | containers >= 0.3 && < 0.9, 55 | distributive >= 0.6.2 && < 1, 56 | free >= 4 && < 6, 57 | mtl >= 2.0.1 && < 2.4, 58 | profunctors >= 4 && < 6, 59 | tagged >= 0.7 && < 1, 60 | semigroupoids >= 4 && < 7, 61 | transformers >= 0.5.2 && < 0.7 62 | 63 | if !impl(ghc>=8.6) 64 | build-depends: contravariant (>=1.5 && <2) 65 | 66 | exposed-modules: 67 | Control.Comonad.Representable.Store 68 | Control.Comonad.Trans.Adjoint 69 | Control.Monad.Representable.Reader 70 | Control.Monad.Representable.State 71 | Control.Monad.Trans.Adjoint 72 | Control.Monad.Trans.Contravariant.Adjoint 73 | Control.Monad.Trans.Conts 74 | Data.Functor.Adjunction 75 | Data.Functor.Contravariant.Adjunction 76 | Data.Functor.Contravariant.Rep 77 | Data.Functor.Rep 78 | Data.Functor1 79 | Data.Functor1.Applied 80 | 81 | ghc-options: -Wall 82 | 83 | default-language: Haskell2010 84 | 85 | -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0 86 | ghc-options: -Wcompat -Wnoncanonical-monad-instances 87 | ghc-options: -Wno-trustworthy-safe -Wno-inline-rule-shadowing 88 | 89 | if !impl(ghc >= 8.8) 90 | ghc-options: -Wnoncanonical-monadfail-instances 91 | 92 | if impl(ghc >= 8.6) 93 | ghc-options: -Wno-star-is-type 94 | 95 | test-suite spec 96 | type: exitcode-stdio-1.0 97 | hs-source-dirs: tests 98 | 99 | build-tool-depends: hspec-discover:hspec-discover >=2 && <3 100 | build-depends: 101 | adjunctions, 102 | base >= 4 && < 5, 103 | distributive >= 0.5.1 && < 1, 104 | hspec >= 2 && < 3 105 | 106 | main-is: Spec.hs 107 | other-modules: GenericsSpec 108 | 109 | ghc-options: -Wall -threaded -rtsopts 110 | default-language: Haskell2010 111 | -------------------------------------------------------------------------------- /tests/GenericsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE EmptyDataDecls #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | ---------------------------------------------------------------------- 6 | -- | 7 | -- Copyright : (c) Edward Kmett 2011-2014 8 | -- License : BSD3 9 | -- 10 | -- Maintainer : ekmett@gmail.com 11 | -- Stability : experimental 12 | -- 13 | -- Tests for generically derived 'Representable' instances. 14 | ---------------------------------------------------------------------- 15 | module GenericsSpec (main, spec) where 16 | 17 | import Data.Distributive (Distributive(..)) 18 | import Data.Functor.Rep (Representable(..), WrappedRep(..)) 19 | 20 | import GHC.Generics hiding (Rep) 21 | 22 | import Test.Hspec 23 | 24 | main :: IO () 25 | main = hspec spec 26 | 27 | spec :: Spec 28 | spec = do 29 | describe "Id" $ 30 | itIndexes "idExample" "idRep" idExample idRep 42 31 | describe "Stream" $ do 32 | let streamIndexes :: String -> Rep Stream -> Int -> Spec 33 | streamIndexes repNum = itIndexes "streamExample" ("streamRep" ++ repNum) streamExample 34 | streamIndexes "1" streamRep1 0 35 | streamIndexes "2" streamRep2 1 36 | streamIndexes "3" streamRep3 2 37 | describe "PolyRec" $ do 38 | let polyRecIndexes :: String -> Rep PolyRec -> Int -> Spec 39 | polyRecIndexes repNum = itIndexes "polyRecExample" ("polyRecRep" ++ repNum) 40 | polyRecExample 41 | polyRecIndexes "1" polyRecRep1 1 42 | polyRecIndexes "2" polyRecRep2 2 43 | polyRecIndexes "3" polyRecRep3 0 44 | 45 | itIndexes :: (Eq a, Representable f, Show a) 46 | => String -> String -> f a -> Rep f -> a -> Spec 47 | itIndexes exampleStr repStr exampleVal rep res = 48 | it ("index " ++ exampleStr ++ " " ++ repStr ++ " = " ++ show res) $ 49 | index exampleVal rep `shouldBe` res 50 | 51 | ------------------------------------------------------------------------------- 52 | 53 | newtype Id a = Id { runId :: a } 54 | deriving Functor 55 | instance Distributive Id where 56 | collect f = Id . fmap (runId . f) 57 | distribute = Id . fmap runId 58 | instance Representable Id 59 | -- type Rep Id = () 60 | 61 | idExample :: Id Int 62 | idExample = Id 42 63 | 64 | idRep :: Rep Id 65 | idRep = () 66 | 67 | data Stream a = (:>) { shead :: a, stail :: Stream a } 68 | deriving Functor 69 | instance Distributive Stream where 70 | distribute w = fmap shead w :> distribute (fmap stail w) 71 | instance Representable Stream 72 | -- type Rep Stream = Either () (WrappedRep Stream) 73 | 74 | streamExample :: Stream Int 75 | streamExample = let s = 0 :> fmap (+1) s in s 76 | 77 | streamRep1, streamRep2, streamRep3 :: Rep Stream 78 | streamRep1 = Left () 79 | streamRep2 = Right $ WrapRep $ Left () 80 | streamRep3 = Right $ WrapRep $ Right $ WrapRep $ Left () 81 | 82 | data PolyRec a = PolyRec (Id (PolyRec a)) a 83 | deriving Functor 84 | instance Distributive PolyRec where 85 | distribute fpa = PolyRec (Id $ distribute fpa) (fmap (\(PolyRec _ a) -> a) fpa) 86 | instance Representable PolyRec 87 | -- type Rep PolyRec = Either (WrappedRep Id, WrappedRep PolyRec) () 88 | 89 | polyRecExample :: PolyRec Int 90 | polyRecExample = let p = PolyRec (Id (fmap (+1) p)) 0 in p 91 | 92 | polyRecRep1, polyRecRep2, polyRecRep3 :: Rep PolyRec 93 | polyRecRep1 = Left (WrapRep (), WrapRep $ Right ()) 94 | polyRecRep2 = Left (WrapRep (), WrapRep $ Left (WrapRep (), WrapRep $ Right ())) 95 | polyRecRep3 = Right () 96 | 97 | deriving instance Generic1 Id 98 | deriving instance Generic1 Stream 99 | deriving instance Generic1 PolyRec 100 | -------------------------------------------------------------------------------- /CHANGELOG.markdown: -------------------------------------------------------------------------------- 1 | next [????.??.??] 2 | ----------------- 3 | * Define the `Functor` instance for `Co` with `fmap = fmapRep`. This brings 4 | the `Functor` instance in line with `Co`'s other instances, which also have a 5 | `Representable` constraint in the instance context. Previously, it used the 6 | underlying `Functor` instance, which made it easy to write looping code if 7 | one were to write `deriving (Functor, Applicative, ..) via Co F`. 8 | * The `(<*)` and `(*>)` methods in the `Applicative` instance for `Co` are 9 | now defined to be `as <* _ = as` and `_ *> bs = bs`, which run in _O(1)_ 10 | time. These implementations follow from the `Representable` laws. 11 | * Use more concise `MINIMAL` defaults for the `Adjunction` classes. 12 | * TODO: Describe `cotraverse1`-related changes 13 | * The dependencies on `semigroups` and `void` are both now conditional 14 | on the GHC version being old enough that they're not in `base`. 15 | 16 | 4.4.3 [2025.03.03] 17 | ------------------ 18 | * Drop support for pre-8.0 versions of GHC. 19 | 20 | 4.4.2 [2022.08.15] 21 | ------------------ 22 | * Fix the build with `mtl-2.3.1`. 23 | 24 | 4.4.1 [2022.05.07] 25 | ------------------ 26 | * Allow building with `transformers-0.6.*` and `mtl-2.3.*`. 27 | 28 | 4.4 [2018.01.28] 29 | ---------------- 30 | * Added `imapRep`, `ifoldMapRep`, `itraverseRep` to make it easier to define representable `FunctorWithIndex`, `FoldableWithIndex`, `TraversableWithIndex` instances from the `lens` package. 31 | * Add `GHC.Generics`-based default implementation for `Data.Functor.Rep.Representable` instances 32 | * Add `Data.Functor.Rep.Representable` instances for `Backwards`, `Reverse`, and the datatypes in `GHC.Generics`. 33 | * Add `Data.Functor.Adjunction.Adjunction` instances for some datatypes in `GHC.Generics` 34 | * Add `Data.Functor.Contravariant.Rep.Representable` instances for `U1` and `(:*:)` from `GHC.Generics` 35 | * Add `collectRep` and `imapRep` functions to `Data.Functor.Rep`. 36 | * Add `MINIMAL` pragmas to the `Adjunction` classes. 37 | * Allow `free-5`. 38 | 39 | 4.3 40 | --- 41 | * Removed a spurious superclass constraint for `Applicative (StoreT g w)` 42 | * GHC 8 support 43 | * `comonad` 5 support 44 | 45 | 4.2.2 46 | ----- 47 | * Builds clean on GHC 7.10 48 | 49 | 4.2.1 50 | ----- 51 | * `semigroupoids` 5 support. 52 | * `profunctors` 5 support. 53 | 54 | 4.2 55 | --- 56 | * `contravariant` 1.0 support. `Day` convolution moves to `kan-extensions`. 57 | 58 | 4.0.3 59 | ----- 60 | * Silenced `Control.Monad.Instances` deprecation warnings on GHC 7.8 61 | 62 | 4.0.2 63 | ----- 64 | * Added `mfixRep` to make it easier to define representable `MonadFix` instances. 65 | * Added `mzipRep` and `mzipWithRep` to make it easier to define representable `MonadZip` instances. 66 | * Added `duplicateRepBy`, `extendRepBy` and `extractRepBy` to make it easier to pick your own `Monoid`. 67 | * Minor documentation fixes. 68 | 69 | 4.0.1 70 | ----- 71 | * Increased lower bound on `contravariant` to match the actual requirement. 72 | 73 | 4.0 74 | --- 75 | * Merged the contents of `representable-functors`. 76 | * Removed the dependency on `keys`. 77 | * Moved `Data.Functor.Contravariant.Representable` to `Data.Functor.Contravariant.Rep` and made the API mimic `Data.Profunctor.Rep`. 78 | * Moved `Data.Functor.Representable` to `Data.Functor.Rep` and made the API mimic `Data.Profunctor.Rep`. 79 | * Added `Tagged` and `Proxy` instances for `Data.Functor.Rep.Representable` 80 | * Added a `Proxy` instance for `Data.Functor.Contravariant.Rep.Representable` 81 | 82 | 3.2.1.1 83 | ------- 84 | * Updated the `array` dependency 85 | 86 | 3.2.1 87 | ----- 88 | * Marked modules appropriately `Trustworthy`. 89 | 90 | 3.2 91 | --- 92 | * Updated to `representable-functors` 3.1, which changed the API for contravariant representable functors. 93 | -------------------------------------------------------------------------------- /src/Data/Functor/Contravariant/Rep.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# OPTIONS_GHC -fenable-rewrite-rules #-} 6 | ---------------------------------------------------------------------- 7 | -- | 8 | -- Copyright : (c) Edward Kmett 2011-2014 9 | -- License : BSD3 10 | -- 11 | -- Maintainer : ekmett@gmail.com 12 | -- Stability : experimental 13 | -- 14 | -- Representable contravariant endofunctors over the category of Haskell 15 | -- types are isomorphic to @(_ -> r)@ and resemble mappings to a 16 | -- fixed range. 17 | ---------------------------------------------------------------------- 18 | module Data.Functor.Contravariant.Rep 19 | ( 20 | -- * Representable Contravariant Functors 21 | Representable(..) 22 | , tabulated 23 | -- * Default definitions 24 | , contramapRep 25 | ) where 26 | 27 | import Data.Functor.Contravariant 28 | import Data.Functor.Product 29 | import Data.Profunctor 30 | import Data.Proxy 31 | import GHC.Generics hiding (Rep) 32 | import Prelude 33 | 34 | -- | A 'Contravariant' functor @f@ is 'Representable' if 'tabulate' and 'index' witness an isomorphism to @(_ -> Rep f)@. 35 | -- 36 | -- @ 37 | -- 'tabulate' . 'index' ≡ id 38 | -- 'index' . 'tabulate' ≡ id 39 | -- @ 40 | class Contravariant f => Representable f where 41 | type Rep f :: * 42 | -- | 43 | -- @ 44 | -- 'contramap' f ('tabulate' g) = 'tabulate' (g . f) 45 | -- @ 46 | tabulate :: (a -> Rep f) -> f a 47 | 48 | index :: f a -> a -> Rep f 49 | 50 | -- | 51 | -- @ 52 | -- 'contramapWithRep' f p ≡ 'tabulate' $ 'either' ('index' p) 'id' . f 53 | -- @ 54 | contramapWithRep :: (b -> Either a (Rep f)) -> f a -> f b 55 | contramapWithRep f p = tabulate $ either (index p) id . f 56 | 57 | {-# RULES 58 | "tabulate/index" forall t. tabulate (index t) = t #-} 59 | 60 | -- | 'tabulate' and 'index' form two halves of an isomorphism. 61 | -- 62 | -- This can be used with the combinators from the @lens@ package. 63 | -- 64 | -- @'tabulated' :: 'Representable' f => 'Iso'' (a -> 'Rep' f) (f a)@ 65 | tabulated :: (Representable f, Representable g, Profunctor p, Functor h) 66 | => p (f a) (h (g b)) -> p (a -> Rep f) (h (b -> Rep g)) 67 | tabulated = dimap tabulate (fmap index) 68 | {-# INLINE tabulated #-} 69 | 70 | contramapRep :: Representable f => (a -> b) -> f b -> f a 71 | contramapRep f = tabulate . (. f) . index 72 | 73 | instance Representable Proxy where 74 | type Rep Proxy = () 75 | tabulate _ = Proxy 76 | index Proxy _ = () 77 | contramapWithRep _ Proxy = Proxy 78 | 79 | instance Representable (Op r) where 80 | type Rep (Op r) = r 81 | tabulate = Op 82 | index = getOp 83 | 84 | instance Representable Predicate where 85 | type Rep Predicate = Bool 86 | tabulate = Predicate 87 | index = getPredicate 88 | 89 | instance (Representable f, Representable g) => Representable (Product f g) where 90 | type Rep (Product f g) = (Rep f, Rep g) 91 | tabulate f = Pair (tabulate (fst . f)) (tabulate (snd . f)) 92 | index (Pair f g) a = (index f a, index g a) 93 | contramapWithRep h (Pair f g) = Pair 94 | (contramapWithRep (fmap fst . h) f) 95 | (contramapWithRep (fmap snd . h) g) 96 | 97 | instance Representable U1 where 98 | type Rep U1 = () 99 | tabulate _ = U1 100 | index U1 _ = () 101 | contramapWithRep _ U1 = U1 102 | 103 | instance (Representable f, Representable g) => Representable (f :*: g) where 104 | type Rep (f :*: g) = (Rep f, Rep g) 105 | tabulate f = tabulate (fst . f) :*: tabulate (snd . f) 106 | index (f :*: g) a = (index f a, index g a) 107 | contramapWithRep h (f :*: g) = 108 | contramapWithRep (fmap fst . h) f :*: contramapWithRep (fmap snd . h) g 109 | -------------------------------------------------------------------------------- /src/Control/Comonad/Representable/Store.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | ---------------------------------------------------------------------- 9 | -- | 10 | -- Module : Control.Comonad.Representable.Store 11 | -- Copyright : (c) Edward Kmett & Sjoerd Visscher 2011 12 | -- License : BSD3 13 | -- 14 | -- Maintainer : ekmett@gmail.com 15 | -- Stability : experimental 16 | -- 17 | -- This is a generalized 'Store' 'Comonad', parameterized by a 'Representable' 'Functor'. 18 | -- The representation of that 'Functor' serves as the index of the store. 19 | -- 20 | -- This can be useful if the representable functor serves to memoize its 21 | -- contents and will be inspected often. 22 | ---------------------------------------------------------------------- 23 | module Control.Comonad.Representable.Store 24 | ( Store 25 | , store 26 | , runStore 27 | , StoreT(..) 28 | , storeT 29 | , runStoreT 30 | , ComonadStore(..) 31 | ) where 32 | 33 | import Control.Comonad 34 | import Control.Comonad.Cofree.Class 35 | import Control.Comonad.Env.Class 36 | import Control.Comonad.Hoist.Class 37 | import Control.Comonad.Store.Class 38 | import Control.Comonad.Traced.Class 39 | import Control.Comonad.Trans.Class 40 | import Control.Monad.Identity 41 | import Data.Functor.Apply 42 | import Data.Functor.Extend 43 | import Data.Functor.Rep 44 | #if !(MIN_VERSION_base(4,11,0)) 45 | import Data.Semigroup 46 | #endif 47 | 48 | -- | A memoized store comonad parameterized by a representable functor @g@, where 49 | -- the representatation of @g@, @Rep g@ is the index of the store. 50 | -- 51 | type Store g = StoreT g Identity 52 | 53 | -- | Construct a store comonad computation from a function and a current index. 54 | -- (The inverse of 'runStore'.) 55 | store :: Representable g 56 | => (Rep g -> a) -- ^ computation 57 | -> Rep g -- ^ index 58 | -> Store g a 59 | store = storeT . Identity 60 | 61 | -- | Unwrap a store comonad computation as a function and a current index. 62 | -- (The inverse of 'store'.) 63 | runStore :: Representable g 64 | => Store g a -- ^ a store to access 65 | -> (Rep g -> a, Rep g) -- ^ initial state 66 | runStore (StoreT (Identity ga) k) = (index ga, k) 67 | 68 | -- --------------------------------------------------------------------------- 69 | -- | A store transformer comonad parameterized by: 70 | -- 71 | -- * @g@ - A representable functor used to memoize results for an index @Rep g@ 72 | -- 73 | -- * @w@ - The inner comonad. 74 | data StoreT g w a = StoreT (w (g a)) (Rep g) 75 | 76 | storeT :: (Functor w, Representable g) => w (Rep g -> a) -> Rep g -> StoreT g w a 77 | storeT = StoreT . fmap tabulate 78 | 79 | runStoreT :: (Functor w, Representable g) => StoreT g w a -> (w (Rep g -> a), Rep g) 80 | runStoreT (StoreT w s) = (index <$> w, s) 81 | 82 | instance (Comonad w, Representable g, Rep g ~ s) => ComonadStore s (StoreT g w) where 83 | pos (StoreT _ s) = s 84 | peek s (StoreT w _) = extract w `index` s 85 | peeks f (StoreT w s) = extract w `index` f s 86 | seek s (StoreT w _) = StoreT w s 87 | seeks f (StoreT w s) = StoreT w (f s) 88 | 89 | instance (Functor w, Functor g) => Functor (StoreT g w) where 90 | fmap f (StoreT w s) = StoreT (fmap (fmap f) w) s 91 | 92 | instance (Apply w, Semigroup (Rep g), Representable g) => Apply (StoreT g w) where 93 | StoreT ff m <.> StoreT fa n = StoreT (apRep <$> ff <.> fa) (m <> n) 94 | 95 | instance (ComonadApply w, Semigroup (Rep g), Representable g) => ComonadApply (StoreT g w) where 96 | StoreT ff m <@> StoreT fa n = StoreT (apRep <$> ff <@> fa) (m <> n) 97 | 98 | instance (Applicative w, Monoid (Rep g), Representable g) => Applicative (StoreT g w) where 99 | pure a = StoreT (pure (pureRep a)) mempty 100 | StoreT ff m <*> StoreT fa n = StoreT (apRep <$> ff <*> fa) (m `mappend` n) 101 | 102 | instance (Extend w, Representable g) => Extend (StoreT g w) where 103 | duplicated (StoreT wf s) = StoreT (extended (tabulate . StoreT) wf) s 104 | 105 | instance (Comonad w, Representable g) => Comonad (StoreT g w) where 106 | duplicate (StoreT wf s) = StoreT (extend (tabulate . StoreT) wf) s 107 | extract (StoreT wf s) = index (extract wf) s 108 | 109 | instance Representable g => ComonadTrans (StoreT g) where 110 | lower (StoreT w s) = fmap (`index` s) w 111 | 112 | instance ComonadHoist (StoreT g) where 113 | cohoist f (StoreT w s) = StoreT (f w) s 114 | 115 | instance (ComonadTraced m w, Representable g) => ComonadTraced m (StoreT g w) where 116 | trace m = trace m . lower 117 | 118 | instance (ComonadEnv m w, Representable g) => ComonadEnv m (StoreT g w) where 119 | ask = ask . lower 120 | 121 | instance (Representable g, ComonadCofree f w) => ComonadCofree f (StoreT g w) where 122 | unwrap (StoreT w s) = fmap (`StoreT` s) (unwrap w) 123 | -------------------------------------------------------------------------------- /src/Control/Monad/Representable/Reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, TypeFamilies, TypeOperators, CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, TypeSynonymInstances #-} 2 | {-# OPTIONS_GHC -fenable-rewrite-rules -Wno-orphans #-} 3 | ---------------------------------------------------------------------- 4 | -- | 5 | -- Module : Control.Monad.Representable.Reader 6 | -- Copyright : (c) Edward Kmett 2011, 7 | -- (c) Conal Elliott 2008 8 | -- License : BSD3 9 | -- 10 | -- Maintainer : ekmett@gmail.com 11 | -- Stability : experimental 12 | -- 13 | -- Representable functors on Hask are all monads, because they are isomorphic to 14 | -- a 'Reader' monad. 15 | ---------------------------------------------------------------------- 16 | 17 | module Control.Monad.Representable.Reader 18 | ( 19 | -- * Representable functor monad 20 | Reader 21 | , runReader 22 | -- * Monad Transformer 23 | , ReaderT(..), readerT, runReaderT 24 | , MonadReader(..) 25 | , module Data.Functor.Rep 26 | ) where 27 | 28 | import Control.Comonad 29 | import Control.Monad.Reader.Class 30 | import Control.Monad.Writer.Class as Writer 31 | import Control.Monad.Trans.Class 32 | import Control.Monad.IO.Class 33 | import Data.Distributive 34 | import Data.Functor.Bind 35 | import Data.Functor.Extend 36 | import Data.Functor.Identity 37 | import Data.Functor.Rep 38 | #if !(MIN_VERSION_base(4,11,0)) 39 | import Data.Semigroup 40 | #endif 41 | import Data.Semigroup.Foldable 42 | import Data.Semigroup.Traversable 43 | import GHC.Generics hiding (Rep) 44 | 45 | type Reader f = ReaderT f Identity 46 | 47 | runReader :: Representable f => Reader f b -> Rep f -> b 48 | runReader = fmap runIdentity . runReaderT 49 | 50 | -- * This 'representable monad transformer' transforms any monad @m@ with a 'Representable' 'Monad'. 51 | -- This monad in turn is also representable if @m@ is 'Representable'. 52 | newtype ReaderT f m b = ReaderT { getReaderT :: f (m b) } 53 | 54 | readerT :: Representable f => (Rep f -> m b) -> ReaderT f m b 55 | readerT = ReaderT . tabulate 56 | 57 | runReaderT :: Representable f => ReaderT f m b -> Rep f -> m b 58 | runReaderT = index . getReaderT 59 | 60 | instance (Functor f, Functor m) => Functor (ReaderT f m) where 61 | fmap f = ReaderT . fmap (fmap f) . getReaderT 62 | 63 | instance (Representable f, Representable m) => Representable (ReaderT f m) where 64 | type Rep (ReaderT f m) = (Rep f, Rep m) 65 | tabulate = ReaderT . tabulate . fmap tabulate . curry 66 | index = uncurry . fmap index . index . getReaderT 67 | cotraverse1 = cotraverse1Iso (Comp1 . getReaderT) (ReaderT . unComp1) 68 | 69 | instance (Representable f, Apply m) => Apply (ReaderT f m) where 70 | ReaderT ff <.> ReaderT fa = ReaderT (unCo ((<.>) <$> Co ff <.> Co fa)) 71 | 72 | instance (Representable f, Applicative m) => Applicative (ReaderT f m) where 73 | pure = ReaderT . pureRep . pure 74 | ReaderT ff <*> ReaderT fa = ReaderT (unCo ((<*>) <$> Co ff <*> Co fa)) 75 | 76 | instance (Representable f, Bind m) => Bind (ReaderT f m) where 77 | ReaderT fm >>- f = ReaderT $ mzipWithRep (>>-) fm $ distribute (getReaderT . f) 78 | 79 | instance (Representable f, Monad m) => Monad (ReaderT f m) where 80 | ReaderT fm >>= f = ReaderT $ mzipWithRep (>>=) fm $ distribute (getReaderT . f) 81 | 82 | instance (Representable f, Monad m, Rep f ~ e) => MonadReader e (ReaderT f m) where 83 | ask = ReaderT (tabulate return) 84 | local f m = readerT $ \r -> runReaderT m (f r) 85 | reader = readerT . fmap return 86 | 87 | instance Representable f => MonadTrans (ReaderT f) where 88 | lift = ReaderT . pureRep 89 | 90 | instance (Representable f, Distributive m) => Distributive (ReaderT f m) where 91 | distribute = ReaderT . fmap distribute . unCo . collect (Co . getReaderT) 92 | 93 | instance (Representable f, Representable m, Semigroup (Rep f), Semigroup (Rep m)) => Extend (ReaderT f m) where 94 | extended = extendedRep 95 | duplicated = duplicatedRep 96 | 97 | instance (Representable f, Representable m, Monoid (Rep f), Monoid (Rep m)) => Comonad (ReaderT f m) where 98 | extend = extendRep 99 | duplicate = duplicateRep 100 | extract = extractRep 101 | 102 | instance (Representable f, MonadIO m) => MonadIO (ReaderT f m) where 103 | liftIO = lift . liftIO 104 | 105 | instance (Representable f, MonadWriter w m) => MonadWriter w (ReaderT f m) where 106 | tell = lift . tell 107 | listen = ReaderT . fmap listen . getReaderT 108 | pass = ReaderT . fmap pass . getReaderT 109 | 110 | -- misc. instances that can exist, but aren't particularly about representability 111 | 112 | instance (Foldable f, Foldable m) => Foldable (ReaderT f m) where 113 | foldMap f = foldMap (foldMap f) . getReaderT 114 | 115 | instance (Foldable1 f, Foldable1 m) => Foldable1 (ReaderT f m) where 116 | foldMap1 f = foldMap1 (foldMap1 f) . getReaderT 117 | 118 | instance (Traversable f, Traversable m) => Traversable (ReaderT f m) where 119 | traverse f = fmap ReaderT . traverse (traverse f) . getReaderT 120 | 121 | instance (Traversable1 f, Traversable1 m) => Traversable1 (ReaderT f m) where 122 | traverse1 f = fmap ReaderT . traverse1 (traverse1 f) . getReaderT 123 | -------------------------------------------------------------------------------- /src/Control/Monad/Representable/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | ---------------------------------------------------------------------- 9 | -- | 10 | -- Module : Control.Monad.Representable.State 11 | -- Copyright : (c) Edward Kmett & Sjoerd Visscher 2011 12 | -- License : BSD3 13 | -- 14 | -- Maintainer : ekmett@gmail.com 15 | -- Stability : experimental 16 | -- 17 | -- A generalized State monad, parameterized by a Representable functor. 18 | -- The representation of that functor serves as the state. 19 | ---------------------------------------------------------------------- 20 | module Control.Monad.Representable.State 21 | ( State 22 | , runState 23 | , evalState 24 | , execState 25 | , mapState 26 | , StateT(..) 27 | , stateT 28 | , runStateT 29 | , evalStateT 30 | , execStateT 31 | , mapStateT 32 | , liftCallCC 33 | , liftCallCC' 34 | , MonadState(..) 35 | ) where 36 | 37 | import Control.Monad 38 | import Data.Functor.Bind 39 | import Data.Functor.Bind.Trans 40 | import Control.Monad.State.Class 41 | import Control.Monad.Cont.Class (MonadCont(..)) 42 | import Control.Monad.Reader.Class 43 | import Control.Monad.Writer.Class 44 | import Control.Monad.Free.Class 45 | import Control.Monad.Trans.Class 46 | import Data.Functor.Identity 47 | import Data.Functor.Rep 48 | 49 | -- --------------------------------------------------------------------------- 50 | -- | A memoized state monad parameterized by a representable functor @g@, where 51 | -- the representatation of @g@, @Rep g@ is the state to carry. 52 | -- 53 | -- The 'return' function leaves the state unchanged, while @>>=@ uses 54 | -- the final state of the first computation as the initial state of 55 | -- the second. 56 | type State g = StateT g Identity 57 | 58 | 59 | -- | Unwrap a state monad computation as a function. 60 | -- (The inverse of 'state'.) 61 | runState :: Representable g 62 | => State g a -- ^ state-passing computation to execute 63 | -> Rep g -- ^ initial state 64 | -> (a, Rep g) -- ^ return value and final state 65 | runState m = runIdentity . runStateT m 66 | 67 | -- | Evaluate a state computation with the given initial state 68 | -- and return the final value, discarding the final state. 69 | -- 70 | -- * @'evalState' m s = 'fst' ('runState' m s)@ 71 | evalState :: Representable g 72 | => State g a -- ^state-passing computation to execute 73 | -> Rep g -- ^initial value 74 | -> a -- ^return value of the state computation 75 | evalState m s = fst (runState m s) 76 | 77 | -- | Evaluate a state computation with the given initial state 78 | -- and return the final state, discarding the final value. 79 | -- 80 | -- * @'execState' m s = 'snd' ('runState' m s)@ 81 | execState :: Representable g 82 | => State g a -- ^state-passing computation to execute 83 | -> Rep g -- ^initial value 84 | -> Rep g -- ^final state 85 | execState m s = snd (runState m s) 86 | 87 | -- | Map both the return value and final state of a computation using 88 | -- the given function. 89 | -- 90 | -- * @'runState' ('mapState' f m) = f . 'runState' m@ 91 | mapState :: Functor g => ((a, Rep g) -> (b, Rep g)) -> State g a -> State g b 92 | mapState f = mapStateT (Identity . f . runIdentity) 93 | 94 | -- --------------------------------------------------------------------------- 95 | -- | A state transformer monad parameterized by: 96 | -- 97 | -- * @g@ - A representable functor used to memoize results for a state @Rep g@ 98 | -- 99 | -- * @m@ - The inner monad. 100 | -- 101 | -- The 'return' function leaves the state unchanged, while @>>=@ uses 102 | -- the final state of the first computation as the initial state of 103 | -- the second. 104 | newtype StateT g m a = StateT { getStateT :: g (m (a, Rep g)) } 105 | 106 | stateT :: Representable g => (Rep g -> m (a, Rep g)) -> StateT g m a 107 | stateT = StateT . tabulate 108 | 109 | runStateT :: Representable g => StateT g m a -> Rep g -> m (a, Rep g) 110 | runStateT (StateT m) = index m 111 | 112 | mapStateT :: Functor g => (m (a, Rep g) -> n (b, Rep g)) -> StateT g m a -> StateT g n b 113 | mapStateT f (StateT m) = StateT (fmap f m) 114 | 115 | -- | Evaluate a state computation with the given initial state 116 | -- and return the final value, discarding the final state. 117 | -- 118 | -- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@ 119 | evalStateT :: (Representable g, Monad m) => StateT g m a -> Rep g -> m a 120 | evalStateT m s = do 121 | (a, _) <- runStateT m s 122 | return a 123 | 124 | -- | Evaluate a state computation with the given initial state 125 | -- and return the final state, discarding the final value. 126 | -- 127 | -- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@ 128 | execStateT :: (Representable g, Monad m) => StateT g m a -> Rep g -> m (Rep g) 129 | execStateT m s = do 130 | (_, s') <- runStateT m s 131 | return s' 132 | 133 | instance (Functor g, Functor m) => Functor (StateT g m) where 134 | fmap f = StateT . fmap (fmap (\ ~(a, s) -> (f a, s))) . getStateT 135 | 136 | instance (Representable g, Bind m) => Apply (StateT g m) where 137 | mf <.> ma = mf >>- \f -> fmap f ma 138 | 139 | instance (Representable g, Functor m, Monad m) => Applicative (StateT g m) where 140 | pure = StateT . leftAdjunctRep return 141 | mf <*> ma = mf >>= \f -> fmap f ma 142 | 143 | instance (Representable g, Bind m) => Bind (StateT g m) where 144 | StateT m >>- f = StateT $ fmap (>>- rightAdjunctRep (runStateT . f)) m 145 | 146 | instance (Representable g, Monad m) => Monad (StateT g m) where 147 | StateT m >>= f = StateT $ fmap (>>= rightAdjunctRep (runStateT . f)) m 148 | 149 | instance Representable f => BindTrans (StateT f) where 150 | liftB m = stateT $ \s -> fmap (\a -> (a, s)) m 151 | 152 | instance Representable f => MonadTrans (StateT f) where 153 | lift m = stateT $ \s -> liftM (\a -> (a, s)) m 154 | 155 | instance (Representable g, Monad m, Rep g ~ s) => MonadState s (StateT g m) where 156 | get = stateT $ \s -> return (s, s) 157 | put s = StateT $ pureRep $ return ((),s) 158 | state f = stateT (return . f) 159 | 160 | instance (Representable g, MonadReader e m) => MonadReader e (StateT g m) where 161 | ask = lift ask 162 | local = mapStateT . local 163 | 164 | instance (Representable g, MonadWriter w m) => MonadWriter w (StateT g m) where 165 | tell = lift . tell 166 | listen = mapStateT $ \ma -> do 167 | ((a,s'), w) <- listen ma 168 | return ((a,w), s') 169 | pass = mapStateT $ \ma -> pass $ do 170 | ((a, f), s') <- ma 171 | return ((a, s'), f) 172 | 173 | instance (Representable g, MonadCont m) => MonadCont (StateT g m) where 174 | callCC = liftCallCC' callCC 175 | 176 | instance (Functor f, Representable g, MonadFree f m) => MonadFree f (StateT g m) where 177 | wrap as = stateT $ \s -> wrap (fmap (`runStateT` s) as) 178 | 179 | leftAdjunctRep :: Representable u => ((a, Rep u) -> b) -> a -> u b 180 | leftAdjunctRep f a = tabulate (\s -> f (a,s)) 181 | 182 | rightAdjunctRep :: Representable u => (a -> u b) -> (a, Rep u) -> b 183 | rightAdjunctRep f ~(a, k) = f a `index` k 184 | 185 | -- | Uniform lifting of a @callCC@ operation to the new monad. 186 | -- This version rolls back to the original state on entering the 187 | -- continuation. 188 | liftCallCC :: Representable g => ((((a,Rep g) -> m (b,Rep g)) -> m (a,Rep g)) -> m (a,Rep g)) -> 189 | ((a -> StateT g m b) -> StateT g m a) -> StateT g m a 190 | liftCallCC callCC' f = stateT $ \s -> 191 | callCC' $ \c -> 192 | runStateT (f (\a -> StateT $ pureRep $ c (a, s))) s 193 | 194 | -- | In-situ lifting of a @callCC@ operation to the new monad. 195 | -- This version uses the current state on entering the continuation. 196 | -- It does not satisfy the laws of a monad transformer. 197 | liftCallCC' :: Representable g => ((((a,Rep g) -> m (b,Rep g)) -> m (a,Rep g)) -> m (a,Rep g)) -> 198 | ((a -> StateT g m b) -> StateT g m a) -> StateT g m a 199 | liftCallCC' callCC' f = stateT $ \s -> 200 | callCC' $ \c -> 201 | runStateT (f (\a -> stateT $ \s' -> c (a, s'))) s 202 | 203 | -------------------------------------------------------------------------------- /src/Data/Functor/Adjunction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types 2 | , MultiParamTypeClasses 3 | , FunctionalDependencies 4 | , TypeOperators 5 | , UndecidableInstances #-} 6 | 7 | {-# LANGUAGE Trustworthy #-} 8 | {-# LANGUAGE EmptyCase #-} 9 | {-# OPTIONS_GHC -Wno-trustworthy-safe #-} 10 | 11 | ------------------------------------------------------------------------------------------- 12 | -- | 13 | -- Copyright : 2008-2013 Edward Kmett 14 | -- License : BSD 15 | -- 16 | -- Maintainer : Edward Kmett 17 | -- Stability : experimental 18 | -- Portability : rank 2 types, MPTCs, fundeps 19 | -- 20 | ------------------------------------------------------------------------------------------- 21 | module Data.Functor.Adjunction 22 | ( Adjunction(..) 23 | , adjuncted 24 | , tabulateAdjunction 25 | , indexAdjunction 26 | , zapWithAdjunction 27 | , zipR, unzipR 28 | , unabsurdL, absurdL 29 | , cozipL, uncozipL 30 | , extractL, duplicateL 31 | , splitL, unsplitL 32 | ) where 33 | 34 | import Control.Arrow ((&&&), (|||)) 35 | import Control.Monad.Free 36 | import Control.Monad.Trans.Identity 37 | import Control.Monad.Trans.Reader 38 | import Control.Monad.Trans.Writer 39 | import Control.Comonad 40 | import Control.Comonad.Cofree 41 | import Control.Comonad.Trans.Env 42 | import Control.Comonad.Trans.Traced 43 | 44 | import Data.Functor.Identity 45 | import Data.Functor.Compose 46 | import Data.Functor.Product 47 | import Data.Functor.Rep 48 | import Data.Functor.Sum 49 | import Data.Profunctor 50 | import Data.Void 51 | import GHC.Generics 52 | 53 | -- | An adjunction between Hask and Hask. 54 | -- 55 | -- Minimal definitions require one of the following pairs of 56 | -- functions to be defined: 57 | -- 58 | -- * 'unit' and 'counit' 59 | -- 60 | -- * 'leftAdjunct' and 'rightAdjunct' 61 | -- 62 | -- * 'unit' and 'rightAdjunct' 63 | -- 64 | -- * 'leftAdjunct' and 'counit' 65 | -- 66 | -- For any implementation, the following laws should hold: 67 | -- 68 | -- > unit = leftAdjunct id 69 | -- > counit = rightAdjunct id 70 | -- > leftAdjunct f = fmap f . unit 71 | -- > rightAdjunct f = counit . fmap f 72 | -- 73 | -- All implementations are required to ensure that 'leftAdjunct' and 74 | -- 'rightAdjunct' witness an isomorphism from @Nat (f a, b)@ to 75 | -- @Nat (a, g b)@ 76 | -- 77 | -- > rightAdjunct unit = id 78 | -- > leftAdjunct counit = id 79 | class (Functor f, Representable u) => 80 | Adjunction f u | f -> u, u -> f where 81 | {-# MINIMAL (unit | leftAdjunct), (rightAdjunct | counit) #-} 82 | unit :: a -> u (f a) 83 | counit :: f (u a) -> a 84 | leftAdjunct :: (f a -> b) -> a -> u b 85 | rightAdjunct :: (a -> u b) -> f a -> b 86 | 87 | unit = leftAdjunct id 88 | counit = rightAdjunct id 89 | leftAdjunct f = fmap f . unit 90 | rightAdjunct f = counit . fmap f 91 | 92 | -- | 'leftAdjunct' and 'rightAdjunct' form two halves of an isomorphism. 93 | -- 94 | -- This can be used with the combinators from the @lens@ package. 95 | -- 96 | -- @'adjuncted' :: 'Adjunction' f u => 'Iso'' (f a -> b) (a -> u b)@ 97 | adjuncted :: (Adjunction f u, Profunctor p, Functor g) 98 | => p (a -> u b) (g (c -> u d)) -> p (f a -> b) (g (f c -> d)) 99 | adjuncted = dimap leftAdjunct (fmap rightAdjunct) 100 | {-# INLINE adjuncted #-} 101 | 102 | -- | Every right adjoint is representable by its left adjoint 103 | -- applied to a unit element 104 | -- 105 | -- Use this definition and the primitives in 106 | -- Data.Functor.Representable to meet the requirements of the 107 | -- superclasses of Representable. 108 | tabulateAdjunction :: Adjunction f u => (f () -> b) -> u b 109 | tabulateAdjunction f = leftAdjunct f () 110 | 111 | -- | This definition admits a default definition for the 112 | -- 'index' method of 'Index", one of the superclasses of 113 | -- Representable. 114 | indexAdjunction :: Adjunction f u => u b -> f a -> b 115 | indexAdjunction = rightAdjunct . const 116 | 117 | zapWithAdjunction :: Adjunction f u => (a -> b -> c) -> u a -> f b -> c 118 | zapWithAdjunction f ua = rightAdjunct (\b -> fmap (flip f b) ua) 119 | 120 | splitL :: Adjunction f u => f a -> (a, f ()) 121 | splitL = rightAdjunct (flip leftAdjunct () . (,)) 122 | 123 | unsplitL :: Functor f => a -> f () -> f a 124 | unsplitL = (<$) 125 | 126 | extractL :: Adjunction f u => f a -> a 127 | extractL = fst . splitL 128 | 129 | duplicateL :: Adjunction f u => f a -> f (f a) 130 | duplicateL as = as <$ as 131 | 132 | -- | A right adjoint functor admits an intrinsic 133 | -- notion of zipping 134 | zipR :: Adjunction f u => (u a, u b) -> u (a, b) 135 | zipR = leftAdjunct (rightAdjunct fst &&& rightAdjunct snd) 136 | 137 | -- | Every functor in Haskell permits unzipping 138 | unzipR :: Functor u => u (a, b) -> (u a, u b) 139 | unzipR = fmap fst &&& fmap snd 140 | 141 | absurdL :: Void -> f Void 142 | absurdL = absurd 143 | 144 | -- | A left adjoint must be inhabited, or we can derive bottom. 145 | unabsurdL :: Adjunction f u => f Void -> Void 146 | unabsurdL = rightAdjunct absurd 147 | 148 | -- | And a left adjoint must be inhabited by exactly one element 149 | cozipL :: Adjunction f u => f (Either a b) -> Either (f a) (f b) 150 | cozipL = rightAdjunct (leftAdjunct Left ||| leftAdjunct Right) 151 | 152 | -- | Every functor in Haskell permits 'uncozipping' 153 | uncozipL :: Functor f => Either (f a) (f b) -> f (Either a b) 154 | uncozipL = fmap Left ||| fmap Right 155 | 156 | -- Requires deprecated Impredicative types 157 | -- limitR :: Adjunction f u => (forall a. u a) -> u (forall a. a) 158 | -- limitR = leftAdjunct (rightAdjunct (\(x :: forall a. a) -> x)) 159 | 160 | instance Adjunction ((,) e) ((->) e) where 161 | leftAdjunct f a e = f (e, a) 162 | rightAdjunct f ~(e, a) = f a e 163 | 164 | instance Adjunction Identity Identity where 165 | leftAdjunct f = Identity . f . Identity 166 | rightAdjunct f = runIdentity . f . runIdentity 167 | 168 | instance Adjunction f g => 169 | Adjunction (IdentityT f) (IdentityT g) where 170 | unit = IdentityT . leftAdjunct IdentityT 171 | counit = rightAdjunct runIdentityT . runIdentityT 172 | 173 | instance Adjunction w m => 174 | Adjunction (EnvT e w) (ReaderT e m) where 175 | unit = ReaderT . flip fmap EnvT . flip leftAdjunct 176 | counit (EnvT e w) = rightAdjunct (flip runReaderT e) w 177 | 178 | instance Adjunction m w => 179 | Adjunction (WriterT s m) (TracedT s w) where 180 | unit = TracedT . leftAdjunct (\ma s -> WriterT (fmap (\a -> (a, s)) ma)) 181 | counit = rightAdjunct (\(t, s) -> ($ s) <$> runTracedT t) . runWriterT 182 | 183 | instance (Adjunction f g, Adjunction f' g') => 184 | Adjunction (Compose f' f) (Compose g g') where 185 | unit = Compose . leftAdjunct (leftAdjunct Compose) 186 | counit = rightAdjunct (rightAdjunct getCompose) . getCompose 187 | 188 | instance (Adjunction f g, Adjunction f' g') => 189 | Adjunction (Sum f f') (Product g g') where 190 | unit a = Pair (leftAdjunct InL a) (leftAdjunct InR a) 191 | counit (InL l) = rightAdjunct (\(Pair x _) -> x) l 192 | counit (InR r) = rightAdjunct (\(Pair _ x) -> x) r 193 | 194 | instance Adjunction f u => 195 | Adjunction (Free f) (Cofree u) where 196 | unit a = return a :< tabulateAdjunction (\k -> leftAdjunct (wrap . flip unsplitL k) a) 197 | counit (Pure a) = extract a 198 | counit (Free k) = rightAdjunct (flip indexAdjunction k . unwrap) (extractL k) 199 | 200 | instance Adjunction V1 U1 where 201 | unit _ = U1 202 | counit = absurdV1 203 | 204 | absurdV1 :: V1 a -> b 205 | absurdV1 x = case x of {} 206 | 207 | instance Adjunction Par1 Par1 where 208 | leftAdjunct f = Par1 . f . Par1 209 | rightAdjunct f = unPar1 . f . unPar1 210 | 211 | instance Adjunction f g => Adjunction (Rec1 f) (Rec1 g) where 212 | unit = Rec1 . leftAdjunct Rec1 213 | counit = rightAdjunct unRec1 . unRec1 214 | 215 | -- @i@ and @c@ indexes have to be the same due functional dependency. 216 | -- But we want them to be different, therefore we rather not define this instance 217 | {- 218 | instance Adjunction f g => Adjunction (M1 i c f) (M1 i c g) where 219 | unit = M1 . leftAdjunct M1 220 | counit = rightAdjunct unM1 . unM1 221 | -} 222 | 223 | instance (Adjunction f g, Adjunction f' g') => Adjunction (f' :.: f) (g :.: g') where 224 | unit = Comp1 . leftAdjunct (leftAdjunct Comp1) 225 | counit = rightAdjunct (rightAdjunct unComp1) . unComp1 226 | 227 | instance (Adjunction f g, Adjunction f' g') => Adjunction (f :+: f') (g :*: g') where 228 | unit a = leftAdjunct L1 a :*: leftAdjunct R1 a 229 | counit (L1 l) = rightAdjunct (\(x :*: _) -> x) l 230 | counit (R1 r) = rightAdjunct (\(_ :*: x) -> x) r 231 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' '--config=cabal.haskell-ci' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250917 12 | # 13 | # REGENDATA ("0.19.20250917",["github","--config=cabal.haskell-ci","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | - merge_group 20 | jobs: 21 | linux: 22 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 23 | runs-on: ubuntu-24.04 24 | timeout-minutes: 25 | 60 26 | container: 27 | image: buildpack-deps:jammy 28 | continue-on-error: ${{ matrix.allow-failure }} 29 | strategy: 30 | matrix: 31 | include: 32 | - compiler: ghc-9.12.2 33 | compilerKind: ghc 34 | compilerVersion: 9.12.2 35 | setup-method: ghcup 36 | allow-failure: false 37 | - compiler: ghc-9.10.3 38 | compilerKind: ghc 39 | compilerVersion: 9.10.3 40 | setup-method: ghcup 41 | allow-failure: false 42 | - compiler: ghc-9.8.4 43 | compilerKind: ghc 44 | compilerVersion: 9.8.4 45 | setup-method: ghcup 46 | allow-failure: false 47 | - compiler: ghc-9.6.7 48 | compilerKind: ghc 49 | compilerVersion: 9.6.7 50 | setup-method: ghcup 51 | allow-failure: false 52 | - compiler: ghc-9.4.8 53 | compilerKind: ghc 54 | compilerVersion: 9.4.8 55 | setup-method: ghcup 56 | allow-failure: false 57 | - compiler: ghc-9.2.8 58 | compilerKind: ghc 59 | compilerVersion: 9.2.8 60 | setup-method: ghcup 61 | allow-failure: false 62 | - compiler: ghc-9.0.2 63 | compilerKind: ghc 64 | compilerVersion: 9.0.2 65 | setup-method: ghcup 66 | allow-failure: false 67 | - compiler: ghc-8.10.7 68 | compilerKind: ghc 69 | compilerVersion: 8.10.7 70 | setup-method: ghcup 71 | allow-failure: false 72 | - compiler: ghc-8.8.4 73 | compilerKind: ghc 74 | compilerVersion: 8.8.4 75 | setup-method: ghcup 76 | allow-failure: false 77 | - compiler: ghc-8.6.5 78 | compilerKind: ghc 79 | compilerVersion: 8.6.5 80 | setup-method: ghcup 81 | allow-failure: false 82 | - compiler: ghc-8.4.4 83 | compilerKind: ghc 84 | compilerVersion: 8.4.4 85 | setup-method: ghcup 86 | allow-failure: false 87 | - compiler: ghc-8.2.2 88 | compilerKind: ghc 89 | compilerVersion: 8.2.2 90 | setup-method: ghcup 91 | allow-failure: false 92 | - compiler: ghc-8.0.2 93 | compilerKind: ghc 94 | compilerVersion: 8.0.2 95 | setup-method: ghcup 96 | allow-failure: false 97 | fail-fast: false 98 | steps: 99 | - name: apt-get install 100 | run: | 101 | apt-get update 102 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 103 | - name: Install GHCup 104 | run: | 105 | mkdir -p "$HOME/.ghcup/bin" 106 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 107 | chmod a+x "$HOME/.ghcup/bin/ghcup" 108 | - name: Install cabal-install 109 | run: | 110 | "$HOME/.ghcup/bin/ghcup" install cabal 3.16.0.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 111 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.16.0.0 -vnormal+nowrap" >> "$GITHUB_ENV" 112 | - name: Install GHC (GHCup) 113 | if: matrix.setup-method == 'ghcup' 114 | run: | 115 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 116 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 117 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 118 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 119 | echo "HC=$HC" >> "$GITHUB_ENV" 120 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 121 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 122 | env: 123 | HCKIND: ${{ matrix.compilerKind }} 124 | HCNAME: ${{ matrix.compiler }} 125 | HCVER: ${{ matrix.compilerVersion }} 126 | - name: Set PATH and environment variables 127 | run: | 128 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 129 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 130 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 131 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 132 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 133 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 134 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 135 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 136 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 137 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 138 | env: 139 | HCKIND: ${{ matrix.compilerKind }} 140 | HCNAME: ${{ matrix.compiler }} 141 | HCVER: ${{ matrix.compilerVersion }} 142 | - name: env 143 | run: | 144 | env 145 | - name: write cabal config 146 | run: | 147 | mkdir -p $CABAL_DIR 148 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 181 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 182 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 183 | rm -f cabal-plan.xz 184 | chmod a+x $HOME/.cabal/bin/cabal-plan 185 | cabal-plan --version 186 | - name: checkout 187 | uses: actions/checkout@v5 188 | with: 189 | path: source 190 | - name: initial cabal.project for sdist 191 | run: | 192 | touch cabal.project 193 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 194 | cat cabal.project 195 | - name: sdist 196 | run: | 197 | mkdir -p sdist 198 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 199 | - name: unpack 200 | run: | 201 | mkdir -p unpacked 202 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 203 | - name: generate cabal.project 204 | run: | 205 | PKGDIR_adjunctions="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/adjunctions-[0-9.]*')" 206 | echo "PKGDIR_adjunctions=${PKGDIR_adjunctions}" >> "$GITHUB_ENV" 207 | rm -f cabal.project cabal.project.local 208 | touch cabal.project 209 | touch cabal.project.local 210 | echo "packages: ${PKGDIR_adjunctions}" >> cabal.project 211 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package adjunctions" >> cabal.project ; fi 212 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods -Werror=missing-fields" >> cabal.project ; fi 213 | if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo "package adjunctions" >> cabal.project ; fi 214 | if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo " ghc-options: -Werror=unused-packages" >> cabal.project ; fi 215 | if [ $((HCNUMVER >= 90000)) -ne 0 ] ; then echo "package adjunctions" >> cabal.project ; fi 216 | if [ $((HCNUMVER >= 90000)) -ne 0 ] ; then echo " ghc-options: -Werror=incomplete-patterns -Werror=incomplete-uni-patterns" >> cabal.project ; fi 217 | cat >> cabal.project <> cabal.project.local 220 | cat cabal.project 221 | cat cabal.project.local 222 | - name: dump install plan 223 | run: | 224 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 225 | cabal-plan 226 | - name: restore cache 227 | uses: actions/cache/restore@v4 228 | with: 229 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 230 | path: ~/.cabal/store 231 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 232 | - name: install dependencies 233 | run: | 234 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 235 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 236 | - name: build 237 | run: | 238 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 239 | - name: tests 240 | run: | 241 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 242 | - name: cabal check 243 | run: | 244 | cd ${PKGDIR_adjunctions} || false 245 | ${CABAL} -vnormal check 246 | - name: haddock 247 | run: | 248 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 249 | - name: save cache 250 | if: always() 251 | uses: actions/cache/save@v4 252 | with: 253 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 254 | path: ~/.cabal/store 255 | -------------------------------------------------------------------------------- /src/Data/Functor/Rep.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE DeriveFunctor #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE DefaultSignatures #-} 11 | {-# LANGUAGE Trustworthy #-} 12 | {-# LANGUAGE PolyKinds #-} 13 | 14 | {-# OPTIONS_GHC -fenable-rewrite-rules #-} 15 | ---------------------------------------------------------------------- 16 | -- | 17 | -- Copyright : (c) Edward Kmett 2011-2014 18 | -- License : BSD3 19 | -- 20 | -- Maintainer : ekmett@gmail.com 21 | -- Stability : experimental 22 | -- 23 | -- Representable endofunctors over the category of Haskell types are 24 | -- isomorphic to the reader monad and so inherit a very large number 25 | -- of properties for free. 26 | ---------------------------------------------------------------------- 27 | 28 | module Data.Functor.Rep 29 | ( 30 | -- * Representable Functors 31 | Representable(..) 32 | , tabulateAlg 33 | , tabulated 34 | -- * Logarithms 35 | , Logarithm(..) 36 | , contramapLogarithm 37 | , logarithmRep 38 | -- * Wrapped representable functors 39 | , Co(..) 40 | -- * Default definitions 41 | -- ** Functor 42 | , fmapRep 43 | -- ** Distributive 44 | , distributeRep 45 | , collectRep 46 | , cotraverseRep 47 | -- ** Apply/Applicative 48 | , apRep 49 | , pureRep 50 | , liftR2 51 | , liftR3 52 | -- ** Bind/Monad 53 | , bindRep 54 | -- ** MonadFix 55 | , mfixRep 56 | -- ** MonadZip 57 | , mzipRep 58 | , mzipWithRep 59 | -- ** MonadReader 60 | , askRep 61 | , localRep 62 | -- ** Extend 63 | , duplicatedRep 64 | , extendedRep 65 | -- ** Comonad 66 | , duplicateRep 67 | , extendRep 68 | , extractRep 69 | -- ** Comonad, with user-specified monoid 70 | , duplicateRepBy 71 | , extendRepBy 72 | , extractRepBy 73 | -- ** WithIndex 74 | , imapRep 75 | , ifoldMapRep 76 | , itraverseRep 77 | -- ** Representable 78 | , tabulateCotraverse1 79 | , indexLogarithm 80 | , cotraverse1Iso 81 | -- ** Generics 82 | , gcotraverse1 83 | , GRep 84 | , gindex 85 | , gtabulate 86 | , WrappedRep(..) 87 | ) where 88 | 89 | import Control.Applicative 90 | import Control.Applicative.Backwards 91 | import Data.Coerce 92 | import Control.Comonad 93 | import Control.Comonad.Trans.Class 94 | import Control.Comonad.Trans.Traced 95 | import Control.Comonad.Cofree 96 | import Control.Monad.Trans.Identity 97 | import Control.Monad.Reader (MonadReader(..), ReaderT(..)) 98 | import Data.Complex 99 | import Data.Distributive 100 | import Data.Foldable (Foldable(fold)) 101 | import Data.Function 102 | import Data.Functor.Bind 103 | import Data.Functor.Identity 104 | import Data.Functor.Compose 105 | import Data.Functor.Extend 106 | import Data.Functor.Product 107 | import Data.Functor.Reverse 108 | import Data.Functor1 109 | import Data.Functor1.Applied 110 | import qualified Data.Monoid as Monoid 111 | import Data.Profunctor.Unsafe 112 | import Data.Proxy 113 | import Data.Sequence (Seq) 114 | import qualified Data.Sequence as Seq 115 | import Data.Semigroup hiding (Product) 116 | import Data.Tagged 117 | import Data.Void 118 | import GHC.Generics hiding (Rep) 119 | import Prelude 120 | 121 | -- | A 'Functor' @f@ is 'Representable' if 'tabulate' and 'index' witness an 122 | -- isomorphism to @(->) r@, for some @r@. 123 | -- 124 | -- Alternatively, an instance can be derived from 'cotraverse1', by defining: 125 | -- 126 | -- @ 127 | -- 'Rep' f = 'Logarithm' f 128 | -- 'tabulate' = 'tabulateCotraverse1' 129 | -- 'index' = 'indexLogarithm' 130 | -- @ 131 | -- 132 | -- Instances without random access should implement 'cotraverse1', as it can 133 | -- allow asymptotically faster zipping. 134 | -- 135 | -- Every 'Distributive' 'Functor' is actually 'Representable'. 136 | -- 137 | -- Every 'Representable' 'Functor' from Hask to Hask is a right adjoint. 138 | -- 139 | -- @ 140 | -- 'tabulate' . 'index' ≡ id 141 | -- 'index' . 'tabulate' ≡ id 142 | -- 'tabulate' . 'return' ≡ 'return' 143 | -- 144 | -- 'distribute1' . 'Applied' ≡ 'fmap' ('Applied' . 'Identity') 145 | -- 'distribute1' ('Const' x) ≡ 'Const' x '<$' xs 146 | -- 147 | -- 'cotraverse1' f ≡ 'fmap' f . 'distribute1' 148 | -- 'collect1' f ≡ 'distribute1' . 'map1' f 149 | -- 'cotraverseMap1' f g ≡ 'cotraverse1' f . 'map1' g 150 | -- @ 151 | 152 | class Distributive f => Representable f where 153 | -- | If no definition is provided, this will default to 'GRep'. 154 | type Rep f :: * 155 | type Rep f = GRep f 156 | 157 | -- | 158 | -- @ 159 | -- 'fmap' f . 'tabulate' ≡ 'tabulate' . 'fmap' f 160 | -- @ 161 | -- 162 | -- If no definition is provided, this will default to 'gtabulate'. 163 | tabulate :: (Rep f -> a) -> f a 164 | default tabulate :: (Generic1 f, GRep f ~ Rep f, GTabulate (Rep1 f)) 165 | => (Rep f -> a) -> f a 166 | tabulate = gtabulate 167 | 168 | -- | If no definition is provided, this will default to 'gindex'. 169 | index :: f a -> Rep f -> a 170 | default index :: (Generic1 f, GRep f ~ Rep f, GIndex (Rep1 f)) 171 | => f a -> Rep f -> a 172 | index = gindex 173 | 174 | -- | A more powerful version of 'cotraverse' 175 | -- 176 | -- @'cotraverse1' f = 'fmap' f . 'distribute1'@ 177 | cotraverse1 :: Functor1 w => (w Identity -> a) -> w f -> f a 178 | cotraverse1 f w = tabulateAlg (\g -> f $ map1Identity g w) 179 | 180 | -- | A more powerful version of 'distribute' 181 | -- 182 | -- @ 183 | -- 'distribute1' . 'Applied' ≡ 'fmap' ('Applied' . 'Identity') 184 | -- 'distribute1' ('Const' x) ≡ 'Const' x '<$' xs 185 | -- @ 186 | distribute1 :: Functor1 w => w f -> f (w Identity) 187 | distribute1 = cotraverse1 id 188 | 189 | -- | A more powerful version of 'collect' 190 | -- 191 | -- @'collect1' f ≡ 'distribute1' . 'map1' f@ 192 | collect1 :: Functor1 w => (forall x. g x -> f x) -> w g -> f (w Identity) 193 | collect1 f = distribute1 . map1 f 194 | 195 | -- | @'cotraverseMap1' f g ≡ 'cotraverse1' f . 'map1' g@ 196 | cotraverseMap1 :: 197 | Functor1 w => (w Identity -> a) -> (forall x. g x -> f x) -> w g -> f a 198 | cotraverseMap1 f g = cotraverse1 f . map1 g 199 | 200 | tabulateAlg :: Representable f => ((forall x. f x -> x) -> a) -> f a 201 | tabulateAlg f = tabulate $ \i -> f (`index` i) 202 | 203 | -- | A default implementation of 'Rep' for a datatype that is an instance of 204 | -- 'Generic1'. This is usually composed of 'Either', tuples, unit tuples, and 205 | -- underlying 'Rep' values. For instance, if you have: 206 | -- 207 | -- @ 208 | -- data Foo a = MkFoo a (Bar a) (Baz (Quux a)) deriving ('Functor', 'Generic1') 209 | -- instance 'Representable' Foo 210 | -- @ 211 | -- 212 | -- Then you'll get: 213 | -- 214 | -- @ 215 | -- 'GRep' Foo = Either () (Either ('WrappedRep' Bar) ('WrappedRep' Baz, 'WrappedRep' Quux)) 216 | -- @ 217 | -- 218 | -- (See the Haddocks for 'WrappedRep' for an explanation of its purpose.) 219 | type GRep f = GRep' (Rep1 f) 220 | 221 | -- | A default implementation of 'tabulate' in terms of 'GRep'. 222 | gtabulate :: (Generic1 f, GRep f ~ Rep f, GTabulate (Rep1 f)) 223 | => (Rep f -> a) -> f a 224 | gtabulate = to1 . gtabulate' 225 | 226 | -- | A default implementation of 'index' in terms of 'GRep'. 227 | gindex :: (Generic1 f, GRep f ~ Rep f, GIndex (Rep1 f)) 228 | => f a -> Rep f -> a 229 | gindex = gindex' . from1 230 | 231 | type family GRep' (f :: * -> *) :: * 232 | class GTabulate f where 233 | gtabulate' :: (GRep' f -> a) -> f a 234 | class GIndex f where 235 | gindex' :: f a -> GRep' f -> a 236 | 237 | type instance GRep' (f :*: g) = Either (GRep' f) (GRep' g) 238 | instance (GTabulate f, GTabulate g) => GTabulate (f :*: g) where 239 | gtabulate' f = gtabulate' (f . Left) :*: gtabulate' (f . Right) 240 | instance (GIndex f, GIndex g) => GIndex (f :*: g) where 241 | gindex' (a :*: _) (Left i) = gindex' a i 242 | gindex' (_ :*: b) (Right j) = gindex' b j 243 | 244 | type instance GRep' (f :.: g) = (WrappedRep f, GRep' g) 245 | instance (Representable f, GTabulate g) => GTabulate (f :.: g) where 246 | gtabulate' f = Comp1 $ tabulate $ gtabulate' <$> fmap (curry f) WrapRep 247 | instance (Representable f, GIndex g) => GIndex (f :.: g) where 248 | gindex' (Comp1 fg) (i, j) = gindex' (index fg (unwrapRep i)) j 249 | 250 | type instance GRep' Par1 = () 251 | instance GTabulate Par1 where 252 | gtabulate' f = Par1 (f ()) 253 | instance GIndex Par1 where 254 | gindex' (Par1 a) () = a 255 | 256 | type instance GRep' (Rec1 f) = WrappedRep f 257 | -- Using coerce explicitly here seems a bit more readable, and 258 | -- likely a drop easier on the simplifier. 259 | instance Representable f => GTabulate (Rec1 f) where 260 | gtabulate' = coerce (tabulate :: (Rep f -> a) -> f a) 261 | :: forall a . (WrappedRep f -> a) -> Rec1 f a 262 | instance Representable f => GIndex (Rec1 f) where 263 | gindex' = coerce (index :: f a -> Rep f -> a) 264 | :: forall a . Rec1 f a -> WrappedRep f -> a 265 | 266 | type instance GRep' (M1 i c f) = GRep' f 267 | instance GTabulate f => GTabulate (M1 i c f) where 268 | gtabulate' = M1 #. gtabulate' 269 | instance GIndex f => GIndex (M1 i c f) where 270 | gindex' = gindex' .# unM1 271 | 272 | -- | On the surface, 'WrappedRec' is a simple wrapper around 'Rep'. But it plays 273 | -- a very important role: it prevents generic 'Representable' instances for 274 | -- recursive types from sending the typechecker into an infinite loop. Consider 275 | -- the following datatype: 276 | -- 277 | -- @ 278 | -- data Stream a = a :< Stream a deriving ('Functor', 'Generic1') 279 | -- instance 'Representable' Stream 280 | -- @ 281 | -- 282 | -- With 'WrappedRep', we have its 'Rep' being: 283 | -- 284 | -- @ 285 | -- 'Rep' Stream = 'Either' () ('WrappedRep' Stream) 286 | -- @ 287 | -- 288 | -- If 'WrappedRep' didn't exist, it would be: 289 | -- 290 | -- @ 291 | -- 'Rep' Stream = Either () (Either () (Either () ...)) 292 | -- @ 293 | -- 294 | -- An infinite type! 'WrappedRep' breaks the potentially infinite loop. 295 | newtype WrappedRep f = WrapRep { unwrapRep :: Rep f } 296 | 297 | {-# RULES 298 | "tabulate/index" forall t. tabulate (index t) = t #-} 299 | 300 | -- | 'tabulate' and 'index' form two halves of an isomorphism. 301 | -- 302 | -- This can be used with the combinators from the @lens@ package. 303 | -- 304 | -- @'tabulated' :: 'Representable' f => 'Iso'' ('Rep' f -> a) (f a)@ 305 | tabulated :: (Representable f, Representable g, Profunctor p, Functor h) 306 | => p (f a) (h (g b)) -> p (Rep f -> a) (h (Rep g -> b)) 307 | tabulated = dimap tabulate (fmap index) 308 | {-# INLINE tabulated #-} 309 | 310 | -- * Logarithms 311 | 312 | -- | Can be used as a value for 'Rep' 313 | newtype Logarithm f = Logarithm { runLogarithm :: forall x. f x -> x } 314 | 315 | contramapLogarithm :: (forall x. f x -> g x) -> Logarithm g -> Logarithm f 316 | contramapLogarithm f (Logarithm g) = Logarithm (g . f) 317 | 318 | -- | An index is equivalent to a function which gets the element at that index. 319 | -- 320 | -- This can be used with the combinators from the @lens@ package. 321 | -- 322 | -- @'logarithmRep' :: 'Representable' f => 'Iso' ('Logarithm' f) ('Rep' f)@ 323 | logarithmRep :: 324 | (Representable f, Representable g, Profunctor p, Functor h) => 325 | p (Rep f) (h (Rep g)) -> p (Logarithm f) (h (Logarithm g)) 326 | logarithmRep = 327 | dimap (\(Logarithm f) -> f askRep) (fmap (\x -> Logarithm (`index` x))) 328 | 329 | -- * Default definitions 330 | 331 | fmapRep :: Representable f => (a -> b) -> f a -> f b 332 | fmapRep f = cotraverse1 (f . runIdentity . runApplied) . Applied 333 | 334 | pureRep :: Representable f => a -> f a 335 | pureRep = tabulate . const 336 | 337 | bindRep :: Representable f => f a -> (a -> f b) -> f b 338 | bindRep m f = distribute f `apRep` m 339 | 340 | mfixRep :: Representable f => (a -> f a) -> f a 341 | mfixRep = cotraverseRep fix 342 | 343 | data PairOf a b f = PairOf (f a) (f b) 344 | instance Functor1 (PairOf a b) where 345 | map1 f (PairOf x y) = PairOf (f x) (f y) 346 | 347 | mzipWithRep :: Representable f => (a -> b -> c) -> f a -> f b -> f c 348 | mzipWithRep f as bs = 349 | cotraverse1 (\(PairOf (Identity a) (Identity b)) -> f a b) (PairOf as bs) 350 | 351 | mzipRep :: Representable f => f a -> f b -> f (a, b) 352 | mzipRep = mzipWithRep (,) 353 | 354 | askRep :: Representable f => f (Rep f) 355 | askRep = tabulate id 356 | 357 | localRep :: Representable f => (Rep f -> Rep f) -> f a -> f a 358 | localRep f m = tabulate (index m . f) 359 | 360 | apRep :: Representable f => f (a -> b) -> f a -> f b 361 | apRep = mzipWithRep ($) 362 | 363 | distributeRep :: (Representable f, Functor w) => w (f a) -> f (w a) 364 | distributeRep = cotraverseRep id 365 | 366 | collectRep :: (Representable f, Functor w) => (a -> f b) -> w a -> f (w b) 367 | collectRep f = distributeRep . fmap f 368 | 369 | newtype Composed g a f = Composed { runComposed :: g (f a) } 370 | instance Functor g => Functor1 (Composed g a) where 371 | map1 f = Composed . fmap f . runComposed 372 | 373 | cotraverseRep :: (Representable f, Functor w) => (w a -> b) -> w (f a) -> f b 374 | cotraverseRep f = cotraverse1 (f . fmap runIdentity . runComposed) . Composed 375 | 376 | duplicateRepBy :: Representable f => (Rep f -> Rep f -> Rep f) -> f a -> f (f a) 377 | duplicateRepBy plus w = tabulate (\m -> tabulate (index w . plus m)) 378 | 379 | extendRepBy :: Representable f => (Rep f -> Rep f -> Rep f) -> (f a -> b) -> f a -> f b 380 | extendRepBy plus f w = tabulate (\m -> f (tabulate (index w . plus m))) 381 | 382 | extractRepBy :: Representable f => Rep f -> f a -> a 383 | extractRepBy = flip index 384 | 385 | duplicatedRep :: (Representable f, Semigroup (Rep f)) => f a -> f (f a) 386 | duplicatedRep = duplicateRepBy (<>) 387 | 388 | extendedRep :: (Representable f, Semigroup (Rep f)) => (f a -> b) -> f a -> f b 389 | extendedRep = extendRepBy (<>) 390 | 391 | duplicateRep :: (Representable f, Monoid (Rep f)) => f a -> f (f a) 392 | duplicateRep = duplicateRepBy mappend 393 | 394 | extendRep :: (Representable f, Monoid (Rep f)) => (f a -> b) -> f a -> f b 395 | extendRep = extendRepBy mappend 396 | 397 | extractRep :: (Representable f, Monoid (Rep f)) => f a -> a 398 | extractRep = extractRepBy mempty 399 | 400 | imapRep :: Representable r => (Rep r -> a -> b) -> r a -> r b 401 | imapRep f = mzipWithRep f askRep 402 | 403 | ifoldMapRep :: forall r m a. (Representable r, Foldable r, Monoid m) 404 | => (Rep r -> a -> m) -> (r a -> m) 405 | ifoldMapRep ix = fold . imapRep ix 406 | 407 | itraverseRep :: forall r f a a'. (Representable r, Traversable r, Applicative f) 408 | => (Rep r -> a -> f a') -> (r a -> f (r a')) 409 | itraverseRep ix = sequenceA . imapRep ix 410 | 411 | newtype TabulateArg a f = TabulateArg (Logarithm f -> a) 412 | instance Functor1 (TabulateArg a) where 413 | map1 f (TabulateArg g) = TabulateArg (g . contramapLogarithm f) 414 | 415 | -- | Derive 'tabulate' given @'Rep' f ~ 'Logarithm' f@ and an 416 | -- implementation of 'cotraverse1' 417 | tabulateCotraverse1 :: Representable f => (Logarithm f -> a) -> f a 418 | tabulateCotraverse1 = 419 | cotraverse1 (\(TabulateArg g) -> g (Logarithm runIdentity)) . TabulateArg 420 | 421 | -- | Derive 'index', given @'Rep' f ~ 'Logarithm' f@ 422 | indexLogarithm :: f a -> Logarithm f -> a 423 | indexLogarithm i (Logarithm f) = f i 424 | 425 | -- | Derive 'cotraverse1' via an isomorphism 426 | cotraverse1Iso :: 427 | (Representable g, Functor1 w) 428 | => (forall x. f x -> g x) 429 | -> (forall x. g x -> f x) 430 | -> (w Identity -> a) 431 | -> w f 432 | -> f a 433 | cotraverse1Iso t frm f = frm . cotraverseMap1 f t 434 | 435 | gcotraverse1 :: 436 | (Representable (Rep1 f), Functor1 w, Generic1 f) 437 | => (w Identity -> a) 438 | -> w f 439 | -> f a 440 | gcotraverse1 = cotraverse1Iso from1 to1 441 | 442 | -- * Instances 443 | 444 | instance Representable Proxy where 445 | type Rep Proxy = Void 446 | index Proxy = absurd 447 | tabulate _ = Proxy 448 | 449 | instance Representable Identity where 450 | type Rep Identity = () 451 | index (Identity a) () = a 452 | tabulate f = Identity (f ()) 453 | 454 | instance Representable (Tagged t) where 455 | type Rep (Tagged t) = () 456 | index (Tagged a) () = a 457 | tabulate f = Tagged (f ()) 458 | 459 | instance Representable m => Representable (IdentityT m) where 460 | type Rep (IdentityT m) = Rep m 461 | index = index .# runIdentityT 462 | tabulate = IdentityT #. tabulate 463 | cotraverse1 = cotraverse1Iso runIdentityT IdentityT 464 | 465 | instance Representable ((->) e) where 466 | type Rep ((->) e) = e 467 | index = id 468 | tabulate = id 469 | 470 | instance Representable m => Representable (ReaderT e m) where 471 | type Rep (ReaderT e m) = (e, Rep m) 472 | index (ReaderT f) (e,k) = index (f e) k 473 | tabulate = ReaderT . fmap tabulate . curry 474 | cotraverse1 = cotraverse1Iso (Comp1 . runReaderT) (ReaderT . unComp1) 475 | 476 | instance (Representable f, Representable g) => Representable (Compose f g) where 477 | type Rep (Compose f g) = (Rep f, Rep g) 478 | index (Compose fg) (i,j) = index (index fg i) j 479 | tabulate = Compose . tabulate . fmap tabulate . curry 480 | cotraverse1 = cotraverse1Iso (Comp1 . getCompose) (Compose . unComp1) 481 | 482 | instance Representable w => Representable (TracedT s w) where 483 | type Rep (TracedT s w) = (s, Rep w) 484 | index (TracedT w) (e,k) = index w k e 485 | tabulate = TracedT . unCo . collect (Co #. tabulate) . curry 486 | cotraverse1 = cotraverse1Iso (Comp1 . runTracedT) (TracedT . unComp1) 487 | 488 | instance (Representable f, Representable g) => Representable (Product f g) where 489 | type Rep (Product f g) = Either (Rep f) (Rep g) 490 | index (Pair a _) (Left i) = index a i 491 | index (Pair _ b) (Right j) = index b j 492 | tabulate f = Pair (tabulate (f . Left)) (tabulate (f . Right)) 493 | cotraverse1 = cotraverse1Iso (\(Pair x y) -> x :*: y) (\(x :*: y) -> Pair x y) 494 | 495 | instance Representable f => Representable (Cofree f) where 496 | type Rep (Cofree f) = Seq (Rep f) 497 | index (a :< as) key = case Seq.viewl key of 498 | Seq.EmptyL -> a 499 | k Seq.:< ks -> index (index as k) ks 500 | tabulate f = f Seq.empty :< tabulate (\k -> tabulate (f . (k Seq.<|))) 501 | 502 | -- this could be derived via isomorphism to 503 | -- Identity :*: (f :.: Cofree f), but then the instance would be 504 | -- recursive which would prevent specialization 505 | cotraverse1 f = go 506 | where 507 | go w = 508 | f (map1Identity extract w) :< 509 | cotraverse1 510 | (go . map1 (runIdentity . unComp1) . runAppCompose) 511 | (AppCompose $ map1 (Comp1 . unwrap) w) 512 | 513 | instance Representable f => Representable (Backwards f) where 514 | type Rep (Backwards f) = Rep f 515 | index = index .# forwards 516 | tabulate = Backwards #. tabulate 517 | cotraverse1 = cotraverse1Iso forwards Backwards 518 | 519 | instance Representable f => Representable (Reverse f) where 520 | type Rep (Reverse f) = Rep f 521 | index = index .# getReverse 522 | tabulate = Reverse #. tabulate 523 | cotraverse1 = cotraverse1Iso getReverse Reverse 524 | 525 | instance Representable Monoid.Dual where 526 | type Rep Monoid.Dual = () 527 | index (Monoid.Dual d) () = d 528 | tabulate f = Monoid.Dual (f ()) 529 | 530 | instance Representable Monoid.Product where 531 | type Rep Monoid.Product = () 532 | index (Monoid.Product p) () = p 533 | tabulate f = Monoid.Product (f ()) 534 | 535 | instance Representable Monoid.Sum where 536 | type Rep Monoid.Sum = () 537 | index (Monoid.Sum s) () = s 538 | tabulate f = Monoid.Sum (f ()) 539 | 540 | instance Representable Complex where 541 | type Rep Complex = Bool 542 | index (r :+ i) key = if key then i else r 543 | tabulate f = f False :+ f True 544 | 545 | instance Representable U1 where 546 | type Rep U1 = Void 547 | index U1 = absurd 548 | tabulate _ = U1 549 | 550 | instance (Representable f, Representable g) => Representable (f :*: g) where 551 | type Rep (f :*: g) = Either (Rep f) (Rep g) 552 | index (a :*: _) (Left i) = index a i 553 | index (_ :*: b) (Right j) = index b j 554 | tabulate f = tabulate (f . Left) :*: tabulate (f . Right) 555 | cotraverse1 f w = 556 | cotraverseMap1 f (\(a :*: _) -> a) w :*: cotraverseMap1 f (\(_ :*: b) -> b) w 557 | 558 | newtype AppCompose w g f = AppCompose { runAppCompose :: w (f :.: g) } 559 | instance Functor1 w => Functor1 (AppCompose w g) where 560 | map1 f = AppCompose . map1 (Comp1 . f . unComp1) . runAppCompose 561 | 562 | instance (Representable f, Representable g) => Representable (f :.: g) where 563 | type Rep (f :.: g) = (Rep f, Rep g) 564 | index (Comp1 fg) (i, j) = index (index fg i) j 565 | tabulate = Comp1 . tabulate . fmap tabulate . curry 566 | cotraverse1 f w = 567 | Comp1 $ 568 | cotraverse1 (cotraverseMap1 f (runIdentity . unComp1) . runAppCompose) $ 569 | AppCompose w 570 | 571 | instance Representable Par1 where 572 | type Rep Par1 = () 573 | index (Par1 a) () = a 574 | tabulate f = Par1 (f ()) 575 | 576 | instance Representable f => Representable (Rec1 f) where 577 | type Rep (Rec1 f) = Rep f 578 | index = index .# unRec1 579 | tabulate = Rec1 #. tabulate 580 | cotraverse1 = cotraverse1Iso unRec1 Rec1 581 | 582 | instance Representable f => Representable (M1 i c f) where 583 | type Rep (M1 i c f) = Rep f 584 | index = index .# unM1 585 | tabulate = M1 #. tabulate 586 | cotraverse1 = cotraverse1Iso unM1 M1 587 | 588 | newtype Co f a = Co { unCo :: f a } 589 | 590 | instance Representable f => Functor (Co f) where 591 | fmap = fmapRep 592 | 593 | instance Representable f => Representable (Co f) where 594 | type Rep (Co f) = Rep f 595 | tabulate = Co #. tabulate 596 | index = index .# unCo 597 | cotraverse1 = cotraverse1Iso unCo Co 598 | 599 | instance Representable f => Apply (Co f) where 600 | (<.>) = apRep 601 | 602 | instance Representable f => Applicative (Co f) where 603 | pure = pureRep 604 | (<*>) = apRep 605 | 606 | -- | This method is /O(1)/. 'Representable' functors are isomorphic 607 | -- to functions and '<*' for functions drops its second argument and 608 | -- returns its first. 609 | as <* _ = as 610 | -- | This method is /O(1)/. 'Representable' functors are isomorphic 611 | -- to functions and '*>' for functions drops its first argument and 612 | -- returns its second. 613 | _ *> bs = bs 614 | 615 | -- See issue #64: 616 | 617 | instance Representable f => Distributive (Co f) where 618 | distribute = distributeRep 619 | collect = collectRep 620 | 621 | instance Representable f => Bind (Co f) where 622 | (>>-) = bindRep 623 | 624 | instance Representable f => Monad (Co f) where 625 | return = pure 626 | (>>=) = bindRep 627 | 628 | instance (Representable f, Rep f ~ a) => MonadReader a (Co f) where 629 | ask = askRep 630 | local = localRep 631 | 632 | instance (Representable f, Semigroup (Rep f)) => Extend (Co f) where 633 | extended = extendedRep 634 | 635 | instance (Representable f, Monoid (Rep f)) => Comonad (Co f) where 636 | extend = extendRep 637 | extract = extractRep 638 | 639 | instance ComonadTrans Co where 640 | lower (Co f) = f 641 | 642 | liftR2 :: Representable f => (a -> b -> c) -> f a -> f b -> f c 643 | liftR2 = mzipWithRep 644 | 645 | data TripleOf a b c f = TripleOf (f a) (f b) (f c) 646 | instance Functor1 (TripleOf a b c) where 647 | map1 f (TripleOf a b c) = TripleOf (f a) (f b) (f c) 648 | 649 | liftR3 :: Representable f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d 650 | liftR3 f fa fb fc = 651 | cotraverse1 652 | (\(TripleOf (Identity a) (Identity b) (Identity c)) -> f a b c) 653 | (TripleOf fa fb fc) 654 | --------------------------------------------------------------------------------