├── cabal.project ├── Setup.lhs ├── cabal.haskell-ci ├── .hlint.yaml ├── src ├── Control │ ├── Comonad │ │ ├── Trans │ │ │ ├── Identity.hs │ │ │ ├── Class.hs │ │ │ ├── Traced.hs │ │ │ ├── Env.hs │ │ │ └── Store.hs │ │ ├── Identity.hs │ │ ├── Store.hs │ │ ├── Traced.hs │ │ ├── Hoist │ │ │ └── Class.hs │ │ ├── Env.hs │ │ ├── Env │ │ │ └── Class.hs │ │ ├── Traced │ │ │ └── Class.hs │ │ └── Store │ │ │ └── Class.hs │ └── Comonad.hs └── Data │ └── Functor │ └── Composition.hs ├── .gitignore ├── .vim.custom ├── examples ├── comonad-examples.cabal ├── History.hs └── LICENSE.md ├── README.md ├── coq └── Store.v ├── comonad.cabal ├── CHANGELOG.md ├── .github └── workflows │ └── haskell-ci.yml └── LICENSE.md /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | ./examples 3 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | module Main (main) where 3 | import Distribution.Simple (defaultMain) 4 | main :: IO () 5 | main = defaultMain 6 | \end{code} 7 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | distribution: jammy 2 | no-tests-no-benchmarks: False 3 | unconstrained: False 4 | -- irc-channels: irc.freenode.org#haskell-lens 5 | irc-if-in-origin-repo: True 6 | docspec: True 7 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - arguments: [--cpp-define=HLINT, --cpp-ansi] 2 | 3 | - ignore: {name: Eta reduce} 4 | - ignore: {name: Use import/export shortcut} 5 | - ignore: {name: Redundant lambda} 6 | - ignore: {name: Avoid lambda} 7 | - ignore: {name: Use first} 8 | - ignore: {name: Use second} 9 | - ignore: {name: Avoid lambda using `infix`} 10 | -------------------------------------------------------------------------------- /src/Control/Comonad/Trans/Identity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | -- | 4 | -- Copyright : (C) 2008-2011 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : provisional 8 | -- Portability : portable 9 | 10 | module Control.Comonad.Trans.Identity 11 | ( IdentityT(..) 12 | ) where 13 | 14 | import Control.Monad.Trans.Identity 15 | -------------------------------------------------------------------------------- /.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 | -------------------------------------------------------------------------------- /src/Control/Comonad/Identity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | -- | 4 | -- Copyright : (C) 2008-2014 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : experimental 8 | -- Portability : non-portable (fundeps, MPTCs) 9 | 10 | module Control.Comonad.Identity 11 | ( module Data.Functor.Identity 12 | , module Control.Comonad.Trans.Identity 13 | ) where 14 | 15 | import Data.Functor.Identity 16 | import Control.Comonad.Trans.Identity 17 | -------------------------------------------------------------------------------- /src/Data/Functor/Composition.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Functor.Composition 4 | ( Composition(..) 5 | ) where 6 | 7 | import Data.Functor.Compose 8 | 9 | -- | We often need to distinguish between various forms of Functor-like composition in Haskell in order to please the type system. 10 | -- This lets us work with these representations uniformly. 11 | class Composition o where 12 | decompose :: o f g x -> f (g x) 13 | compose :: f (g x) -> o f g x 14 | 15 | instance Composition Compose where 16 | decompose = getCompose 17 | compose = Compose 18 | -------------------------------------------------------------------------------- /src/Control/Comonad/Trans/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | -- | 4 | -- Copyright : (C) 2008-2015 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : provisional 8 | -- Portability : portable 9 | 10 | module Control.Comonad.Trans.Class 11 | ( ComonadTrans(..) 12 | ) where 13 | 14 | import Control.Comonad 15 | import Control.Monad.Trans.Identity 16 | 17 | class ComonadTrans t where 18 | lower :: Comonad w => t w a -> w a 19 | 20 | -- avoiding orphans 21 | instance ComonadTrans IdentityT where 22 | lower = runIdentityT 23 | {-# inline lower #-} 24 | -------------------------------------------------------------------------------- /src/Control/Comonad/Store.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | 4 | -- | 5 | -- Copyright : (C) 2008-2021 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- Maintainer : Edward Kmett 8 | -- Stability : experimental 9 | -- Portability : non-portable (fundeps, MPTCs) 10 | 11 | module Control.Comonad.Store 12 | ( 13 | -- * ComonadStore class 14 | ComonadStore(..) 15 | -- * The Store comonad 16 | , Store 17 | , pattern Store 18 | , runStore 19 | -- * The StoreT comonad transformer 20 | , StoreT(..) 21 | , runStoreT 22 | ) where 23 | 24 | import Control.Comonad.Store.Class (ComonadStore(..)) 25 | import Control.Comonad.Trans.Store (Store, pattern Store, runStore, StoreT(..), runStoreT) 26 | -------------------------------------------------------------------------------- /src/Control/Comonad/Traced.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | 4 | -- | 5 | -- Copyright : (C) 2008-2014 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- Maintainer : Edward Kmett 8 | -- Stability : experimental 9 | -- Portability : non-portable (fundeps, MPTCs) 10 | 11 | module Control.Comonad.Traced 12 | ( 13 | -- * ComonadTraced class 14 | ComonadTraced(..) 15 | , traces 16 | -- * The Traced comonad 17 | , Traced 18 | , pattern Traced 19 | , runTraced 20 | -- * The TracedT comonad transformer 21 | , TracedT(..) 22 | ) where 23 | 24 | import Control.Comonad.Traced.Class (ComonadTraced(..), traces) 25 | import Control.Comonad.Trans.Traced (Traced, pattern Traced, runTraced, TracedT(..), runTracedT) 26 | -------------------------------------------------------------------------------- /src/Control/Comonad/Hoist/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE Safe #-} 3 | 4 | -- | 5 | -- Copyright : (C) 2008-2021 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- Maintainer : Edward Kmett 8 | -- Stability : provisional 9 | -- Portability : portable 10 | 11 | module Control.Comonad.Hoist.Class 12 | ( ComonadHoist(cohoist) 13 | ) where 14 | 15 | import Control.Comonad 16 | import Control.Monad.Trans.Identity 17 | 18 | class ComonadHoist t where 19 | -- | Given any comonad-homomorphism from @w@ to @v@ this yields a comonad 20 | -- homomorphism from @t w@ to @t v@. 21 | cohoist :: (Comonad w, Comonad v) => (forall x. w x -> v x) -> t w a -> t v a 22 | 23 | instance ComonadHoist IdentityT where 24 | cohoist l = IdentityT . l . runIdentityT 25 | {-# inline cohoist #-} 26 | -------------------------------------------------------------------------------- /.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 | -------------------------------------------------------------------------------- /src/Control/Comonad/Env.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Safe #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | 5 | 6 | -- | 7 | -- Copyright : (C) 2008-2021 Edward Kmett 8 | -- License : BSD-style (see the file LICENSE) 9 | -- Maintainer : Edward Kmett 10 | -- Stability : experimental 11 | -- Portability : non-portable (fundeps, MPTCs) 12 | -- 13 | -- The Env comonad (aka the Coreader, Environment, or Product comonad) 14 | -- 15 | -- A co-Kleisli arrow in the Env comonad is isomorphic to a Kleisli arrow 16 | -- in the reader monad. 17 | -- 18 | -- @ 19 | -- (a -> e -> m) ~ (a, e) -> m ~ 'Env' e a -> m 20 | -- @ 21 | module Control.Comonad.Env 22 | ( 23 | -- * ComonadEnv class 24 | ComonadEnv(..) 25 | , asks 26 | , local 27 | -- * The Env comonad 28 | , Env 29 | , pattern Env 30 | , runEnv 31 | -- * The EnvT comonad transformer 32 | , EnvT(..) 33 | , runEnvT 34 | ) where 35 | 36 | import Control.Comonad.Env.Class (ComonadEnv(..), asks) 37 | import Control.Comonad.Trans.Env (Env, pattern Env, runEnv, EnvT(..), runEnvT, local) 38 | -------------------------------------------------------------------------------- /examples/comonad-examples.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: comonad-examples 3 | category: Control, Comonads 4 | version: 0.2 5 | license: BSD-2-Clause OR Apache-2.0 6 | license-file: LICENSE.md 7 | author: Edward A. Kmett 8 | maintainer: Edward A. Kmett 9 | stability: provisional 10 | homepage: http://github.com/ekmett/comonad/ 11 | bug-reports: http://github.com/ekmett/comonad/issues 12 | copyright: Copyright (C) 2008-2014 Edward A. Kmett, 13 | Copyright (C) 2004-2008 Dave Menendez 14 | synopsis: Comonads 15 | description: Comonads. 16 | build-type: Simple 17 | tested-with: GHC == 8.6.5 18 | , GHC == 8.8.4 19 | , GHC == 8.10.7 20 | , GHC == 9.0.2 21 | , GHC == 9.2.8 22 | , GHC == 9.4.5 23 | , GHC == 9.6.2 24 | 25 | source-repository head 26 | type: git 27 | location: git://github.com/ekmett/comonad.git 28 | subdir: examples 29 | 30 | library 31 | hs-source-dirs: . 32 | default-language: Haskell2010 33 | ghc-options: -Wall 34 | 35 | exposed-modules: 36 | History 37 | 38 | build-depends: 39 | , base >= 4.12 && < 5 40 | , comonad ^>= 6 41 | -------------------------------------------------------------------------------- /src/Control/Comonad/Env/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE Safe #-} 5 | 6 | -- | 7 | -- Copyright : (C) 2008-2015 Edward Kmett 8 | -- License : BSD-style (see the file LICENSE) 9 | -- Maintainer : Edward Kmett 10 | -- Stability : experimental 11 | -- Portability : non-portable (fundeps, MPTCs) 12 | 13 | module Control.Comonad.Env.Class 14 | ( ComonadEnv(..) 15 | , asks 16 | ) where 17 | 18 | import Control.Comonad 19 | import Control.Comonad.Trans.Class 20 | import qualified Control.Comonad.Trans.Env as Env 21 | import Control.Comonad.Trans.Store 22 | import Control.Comonad.Trans.Traced 23 | import Control.Comonad.Trans.Identity 24 | import Data.Semigroup 25 | 26 | class Comonad w => ComonadEnv e w | w -> e where 27 | ask :: w a -> e 28 | 29 | asks :: ComonadEnv e w => (e -> e') -> w a -> e' 30 | asks f wa = f (ask wa) 31 | {-# inline asks #-} 32 | 33 | instance Comonad w => ComonadEnv e (Env.EnvT e w) where 34 | ask = Env.ask 35 | {-# inline ask #-} 36 | 37 | instance ComonadEnv e ((,)e) where 38 | ask = fst 39 | {-# inline ask #-} 40 | 41 | instance ComonadEnv e (Arg e) where 42 | ask (Arg e _) = e 43 | {-# inline ask #-} 44 | 45 | lowerAsk :: (ComonadEnv e w, ComonadTrans t) => t w a -> e 46 | lowerAsk = ask . lower 47 | {-# inline lowerAsk #-} 48 | 49 | instance ComonadEnv e w => ComonadEnv e (StoreT t w) where 50 | ask = lowerAsk 51 | {-# inline ask #-} 52 | 53 | instance ComonadEnv e w => ComonadEnv e (IdentityT w) where 54 | ask = lowerAsk 55 | {-# inline ask #-} 56 | 57 | instance (ComonadEnv e w, Monoid m) => ComonadEnv e (TracedT m w) where 58 | ask = lowerAsk 59 | {-# inline ask #-} 60 | -------------------------------------------------------------------------------- /src/Control/Comonad/Traced/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE Safe #-} 5 | 6 | -- | 7 | -- Copyright : (C) 2008-2021 Edward Kmett 8 | -- License : BSD-style (see the file LICENSE) 9 | -- Maintainer : Edward Kmett 10 | -- Stability : experimental 11 | -- Portability : non-portable (fundeps, MPTCs) 12 | 13 | module Control.Comonad.Traced.Class 14 | ( ComonadTraced(..) 15 | , traces 16 | ) where 17 | 18 | import Control.Comonad 19 | import Control.Comonad.Trans.Class 20 | import Control.Comonad.Trans.Env 21 | import Control.Comonad.Trans.Store 22 | import qualified Control.Comonad.Trans.Traced as Traced 23 | import Control.Comonad.Trans.Identity 24 | 25 | class Comonad w => ComonadTraced m w | w -> m where 26 | trace :: m -> w a -> a 27 | 28 | traces :: ComonadTraced m w => (a -> m) -> w a -> a 29 | traces f wa = trace (f (extract wa)) wa 30 | {-# inline traces #-} 31 | 32 | instance (Comonad w, Monoid m) => ComonadTraced m (Traced.TracedT m w) where 33 | trace = Traced.trace 34 | {-# inline trace #-} 35 | 36 | instance Monoid m => ComonadTraced m ((->) m) where 37 | trace m f = f m 38 | {-# inline trace #-} 39 | 40 | lowerTrace :: (ComonadTrans t, ComonadTraced m w) => m -> t w a -> a 41 | lowerTrace m = trace m . lower 42 | {-# inline lowerTrace #-} 43 | 44 | -- All of these require UndecidableInstances because they do not satisfy the coverage condition 45 | 46 | instance ComonadTraced m w => ComonadTraced m (IdentityT w) where 47 | trace = lowerTrace 48 | {-# inline trace #-} 49 | 50 | instance ComonadTraced m w => ComonadTraced m (EnvT e w) where 51 | trace = lowerTrace 52 | {-# inline trace #-} 53 | 54 | instance ComonadTraced m w => ComonadTraced m (StoreT s w) where 55 | trace = lowerTrace 56 | {-# inline trace #-} 57 | -------------------------------------------------------------------------------- /examples/History.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | 4 | -- http://www.mail-archive.com/haskell@haskell.org/msg17244.html 5 | module History where 6 | 7 | import Control.Category 8 | import Control.Comonad 9 | import Data.Foldable hiding (sum) 10 | import Data.Traversable 11 | import Prelude hiding (id,(.),sum) 12 | 13 | infixl 4 :> 14 | 15 | data History a = First a | History a :> a 16 | deriving (Functor, Foldable, Traversable, Show) 17 | 18 | runHistory :: (History a -> b) -> [a] -> [b] 19 | runHistory _ [] = [] 20 | runHistory f (a0:as0) = run (First a0) as0 21 | where 22 | run az [] = [f az] 23 | run az (a:as) = f az : run (az :> a) as 24 | 25 | instance Comonad History where 26 | extend f w@First{} = First (f w) 27 | extend f w@(as :> _) = extend f as :> f w 28 | extract (First a) = a 29 | extract (_ :> a) = a 30 | 31 | instance ComonadApply History where 32 | First f <@> First a = First (f a) 33 | (_ :> f) <@> First a = First (f a) 34 | First f <@> (_ :> a) = First (f a) 35 | (fs :> f) <@> (as :> a) = (fs <@> as) :> f a 36 | 37 | fby :: a -> History a -> a 38 | a `fby` First _ = a 39 | _ `fby` (First b :> _) = b 40 | _ `fby` ((_ :> b) :> _) = b 41 | 42 | pos :: History a -> Int 43 | pos dx = wfix $ dx $> fby 0 . fmap (+1) 44 | 45 | sum :: Num a => History a -> a 46 | sum dx = extract dx + (0 `fby` extend sum dx) 47 | 48 | diff :: Num a => History a -> a 49 | diff dx = extract dx - fby 0 dx 50 | 51 | ini :: History a -> a 52 | ini dx = extract dx `fby` extend ini dx 53 | 54 | fibo :: Num b => History a -> b 55 | fibo d = wfix $ d $> fby 0 . extend (\dfibo -> extract dfibo + fby 1 dfibo) 56 | 57 | fibo' :: Num b => History a -> b 58 | fibo' d = fst $ wfix $ d $> fby (0, 1) . fmap (\(x, x') -> (x',x+x')) 59 | 60 | plus :: Num a => History a -> History a -> History a 61 | plus = liftW2 (+) 62 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | comonad 2 | ======= 3 | 4 | [![Build Status](https://github.com/ekmett/comonad/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/comonad/actions?query=workflow%3AHaskell-CI) 5 | 6 | This package provides comonads, the categorical dual of monads. The typeclass 7 | provides three methods: `extract`, `duplicate`, and `extend`. 8 | 9 | class Functor w => Comonad w where 10 | extract :: w a -> a 11 | duplicate :: w a -> w (w a) 12 | extend :: (w a -> b) -> w a -> w b 13 | 14 | There are two ways to define a comonad: 15 | 16 | I. Provide definitions for `extract` and `extend` satisfying these laws: 17 | 18 | extend extract = id 19 | extract . extend f = f 20 | extend f . extend g = extend (f . extend g) 21 | 22 | In this case, you may simply set `fmap` = `liftW`. 23 | 24 | These laws are directly analogous to the [laws for 25 | monads](https://wiki.haskell.org/Monad_laws). The comonad laws can 26 | perhaps be made clearer by viewing them as stating that Cokleisli composition 27 | must be a) associative and b) have `extract` for a unit: 28 | 29 | f =>= extract = f 30 | extract =>= f = f 31 | (f =>= g) =>= h = f =>= (g =>= h) 32 | 33 | II. Alternately, you may choose to provide definitions for `fmap`, 34 | `extract`, and `duplicate` satisfying these laws: 35 | 36 | extract . duplicate = id 37 | fmap extract . duplicate = id 38 | duplicate . duplicate = fmap duplicate . duplicate 39 | 40 | In this case, you may not rely on the ability to define `fmap` in 41 | terms of `liftW`. 42 | 43 | You may, of course, choose to define both `duplicate` _and_ `extend`. 44 | In that case, you must also satisfy these laws: 45 | 46 | extend f = fmap f . duplicate 47 | duplicate = extend id 48 | fmap f = extend (f . extract) 49 | 50 | These implementations are the default definitions of `extend` and `duplicate` and 51 | the definition of `liftW` respectively. 52 | 53 | Contact Information 54 | ------------------- 55 | 56 | Contributions and bug reports are welcome! 57 | 58 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 59 | 60 | -Edward Kmett 61 | -------------------------------------------------------------------------------- /coq/Store.v: -------------------------------------------------------------------------------- 1 | (* Proof StoreT forms a comonad -- Russell O'Connor *) 2 | 3 | Set Implict Arguments. 4 | Unset Strict Implicit. 5 | 6 | Require Import FunctionalExtensionality. 7 | 8 | Record Comonad (w : Type -> Type) : Type := 9 | { extract : forall a, w a -> a 10 | ; extend : forall a b, (w a -> b) -> w a -> w b 11 | ; law1 : forall a x, extend _ _ (extract a) x = x 12 | ; law2 : forall a b f x, extract b (extend a _ f x) = f x 13 | ; law3 : forall a b c f g x, extend b c f (extend a b g x) = extend a c (fun y => f (extend a b g y)) x 14 | }. 15 | 16 | Section StoreT. 17 | 18 | Variables (s : Type) (w:Type -> Type). 19 | Hypothesis wH : Comonad w. 20 | 21 | Definition map a b f x := extend _ wH a b (fun y => f (extract _ wH _ y)) x. 22 | 23 | Lemma map_extend : forall a b c f g x, map b c f (extend _ wH a b g x) = extend _ wH _ _ (fun y => f (g y)) x. 24 | Proof. 25 | intros a b c f g x. 26 | unfold map. 27 | rewrite law3. 28 | apply equal_f. 29 | apply f_equal. 30 | extensionality y. 31 | rewrite law2. 32 | reflexivity. 33 | Qed. 34 | 35 | Record StoreT (a:Type): Type := mkStoreT 36 | {store : w (s -> a) 37 | ;loc : s}. 38 | 39 | Definition extractST a (x:StoreT a) : a := 40 | extract _ wH _ (store _ x) (loc _ x). 41 | 42 | Definition mapST a b (f:a -> b) (x:StoreT a) : StoreT b := 43 | mkStoreT _ (map _ _ (fun g x => f (g x)) (store _ x)) (loc _ x). 44 | 45 | Definition duplicateST a (x:StoreT a) : StoreT (StoreT a) := 46 | mkStoreT _ (extend _ wH _ _ (mkStoreT _) (store _ x)) (loc _ x). 47 | 48 | Let extendST := fun a b f x => mapST _ b f (duplicateST a x). 49 | 50 | Lemma law1ST : forall a x, extendST _ _ (extractST a) x = x. 51 | Proof. 52 | intros a [v b]. 53 | unfold extractST, extendST, duplicateST, mapST. 54 | simpl. 55 | rewrite map_extend. 56 | simpl. 57 | replace (fun (y : w (s -> a)) (x : s) => extract w wH (s -> a) y x) 58 | with (extract w wH (s -> a)). 59 | rewrite law1. 60 | reflexivity. 61 | extensionality y. 62 | extensionality x. 63 | reflexivity. 64 | Qed. 65 | 66 | Lemma law2ST : forall a b f x, extractST b (extendST a _ f x) = f x. 67 | Proof. 68 | intros a b f [v c]. 69 | unfold extendST, mapST, extractST. 70 | simpl. 71 | rewrite map_extend. 72 | rewrite law2. 73 | reflexivity. 74 | Qed. 75 | 76 | Lemma law3ST : forall a b c f g x, extendST b c f (extendST a b g x) = extendST a c (fun y => f (extendST a b g y)) x. 77 | Proof. 78 | intros a b c f g [v d]. 79 | unfold extendST, mapST, extractST. 80 | simpl. 81 | repeat rewrite map_extend. 82 | rewrite law3. 83 | repeat (apply equal_f||apply f_equal). 84 | extensionality y. 85 | extensionality x. 86 | rewrite map_extend. 87 | reflexivity. 88 | Qed. 89 | 90 | Definition StoreTComonad : Comonad StoreT := 91 | Build_Comonad _ _ _ law1ST law2ST law3ST. 92 | 93 | End StoreT. 94 | 95 | Check StoreTComonad. 96 | 97 | -------------------------------------------------------------------------------- /src/Control/Comonad/Store/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE Safe #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | -- | 7 | -- Copyright : (C) 2008-2021 Edward Kmett 8 | -- License : BSD-style (see the file LICENSE) 9 | -- Maintainer : Edward Kmett 10 | -- Stability : experimental 11 | -- Portability : non-portable (fundeps, MPTCs) 12 | 13 | module Control.Comonad.Store.Class 14 | ( ComonadStore(..) 15 | , lowerPos 16 | , lowerPeek 17 | ) where 18 | 19 | import Control.Comonad 20 | import Control.Comonad.Trans.Class 21 | import Control.Comonad.Trans.Env 22 | import qualified Control.Comonad.Trans.Store as Store 23 | import Control.Comonad.Trans.Traced 24 | import Control.Comonad.Trans.Identity 25 | 26 | class Comonad w => ComonadStore s w | w -> s where 27 | pos :: w a -> s 28 | peek :: s -> w a -> a 29 | 30 | peeks :: (s -> s) -> w a -> a 31 | peeks f w = peek (f (pos w)) w 32 | {-# inline peeks #-} 33 | 34 | seek :: s -> w a -> w a 35 | seek s = peek s . duplicate 36 | {-# inline seek #-} 37 | 38 | seeks :: (s -> s) -> w a -> w a 39 | seeks f = peeks f . duplicate 40 | {-# inline seeks #-} 41 | 42 | experiment :: Functor f => (s -> f s) -> w a -> f a 43 | experiment f w = fmap (`peek` w) (f (pos w)) 44 | {-# inline experiment #-} 45 | 46 | instance Comonad w => ComonadStore s (Store.StoreT s w) where 47 | pos = Store.pos 48 | peek = Store.peek 49 | peeks = Store.peeks 50 | seek = Store.seek 51 | seeks = Store.seeks 52 | experiment = Store.experiment 53 | {-# inline pos #-} 54 | {-# inline peek #-} 55 | {-# inline peeks #-} 56 | {-# inline seek #-} 57 | {-# inline seeks #-} 58 | {-# inline experiment #-} 59 | 60 | lowerPos :: (ComonadTrans t, ComonadStore s w) => t w a -> s 61 | lowerPos = pos . lower 62 | {-# inline lowerPos #-} 63 | 64 | lowerPeek :: (ComonadTrans t, ComonadStore s w) => s -> t w a -> a 65 | lowerPeek s = peek s . lower 66 | {-# inline lowerPeek #-} 67 | 68 | lowerExperiment :: (ComonadTrans t, ComonadStore s w, Functor f) => (s -> f s) -> t w a -> f a 69 | lowerExperiment f = experiment f . lower 70 | {-# inline lowerExperiment #-} 71 | 72 | instance ComonadStore s w => ComonadStore s (IdentityT w) where 73 | pos = lowerPos 74 | peek = lowerPeek 75 | experiment = lowerExperiment 76 | {-# inline pos #-} 77 | {-# inline peek #-} 78 | {-# inline experiment #-} 79 | 80 | instance ComonadStore s w => ComonadStore s (EnvT e w) where 81 | pos = lowerPos 82 | peek = lowerPeek 83 | experiment = lowerExperiment 84 | {-# inline pos #-} 85 | {-# inline peek #-} 86 | {-# inline experiment #-} 87 | 88 | instance (ComonadStore s w, Monoid m) => ComonadStore s (TracedT m w) where 89 | pos = lowerPos 90 | peek = lowerPeek 91 | experiment = lowerExperiment 92 | {-# inline pos #-} 93 | {-# inline peek #-} 94 | {-# inline experiment #-} 95 | -------------------------------------------------------------------------------- /comonad.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: comonad 3 | category: Control, Comonads 4 | version: 6 5 | license: BSD-2-Clause OR Apache-2.0 6 | license-file: LICENSE.md 7 | author: Edward A. Kmett 8 | maintainer: Edward A. Kmett 9 | stability: provisional 10 | homepage: http://github.com/ekmett/comonad/ 11 | bug-reports: http://github.com/ekmett/comonad/issues 12 | copyright: Copyright (C) 2008-2014 Edward A. Kmett, 13 | Copyright (C) 2004-2008 Dave Menendez 14 | synopsis: Comonads 15 | description: Comonads. 16 | build-type: Simple 17 | tested-with: GHC == 8.6.5 18 | , GHC == 8.8.4 19 | , GHC == 8.10.7 20 | , GHC == 9.0.2 21 | , GHC == 9.2.8 22 | , GHC == 9.4.5 23 | , GHC == 9.6.2 24 | extra-source-files: 25 | .gitignore 26 | .hlint.yaml 27 | .vim.custom 28 | coq/Store.v 29 | README.md 30 | CHANGELOG.md 31 | examples/History.hs 32 | 33 | flag containers 34 | description: 35 | You can disable the use of the `containers` package using `-f-containers`. 36 | . 37 | Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. 38 | default: True 39 | manual: True 40 | 41 | flag indexed-traversable 42 | description: 43 | You can disable the use of the `indexed-traversable` package using `-f-indexed-traversable`. 44 | . 45 | Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. 46 | . 47 | If disabled we will not supply instances of `FunctorWithIndex` 48 | . 49 | default: True 50 | manual: True 51 | 52 | source-repository head 53 | type: git 54 | location: git://github.com/ekmett/comonad.git 55 | 56 | library 57 | hs-source-dirs: src 58 | default-language: Haskell2010 59 | ghc-options: -Wall 60 | 61 | build-depends: 62 | , base >= 4.12 && < 5 63 | , tagged >= 0.8.6.1 && < 1 64 | , transformers >= 0.5 && < 0.7 65 | 66 | if flag(containers) 67 | build-depends: containers >= 0.3 && < 0.9 68 | 69 | if flag(indexed-traversable) 70 | build-depends: indexed-traversable >= 0.1.1 && < 0.2 71 | 72 | if impl(ghc >= 9.0) 73 | -- these flags may abort compilation with GHC-8.10 74 | -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 75 | ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode 76 | 77 | exposed-modules: 78 | Control.Comonad 79 | Control.Comonad.Env 80 | Control.Comonad.Env.Class 81 | Control.Comonad.Hoist.Class 82 | Control.Comonad.Identity 83 | Control.Comonad.Store 84 | Control.Comonad.Store.Class 85 | Control.Comonad.Traced 86 | Control.Comonad.Traced.Class 87 | Control.Comonad.Trans.Class 88 | Control.Comonad.Trans.Env 89 | Control.Comonad.Trans.Identity 90 | Control.Comonad.Trans.Store 91 | Control.Comonad.Trans.Traced 92 | Data.Functor.Composition 93 | 94 | other-extensions: 95 | CPP 96 | DefaultSignatures 97 | DeriveDataTypeable 98 | DeriveGeneric 99 | FlexibleContexts 100 | FlexibleInstances 101 | FunctionalDependencies 102 | MultiParamTypeClasses 103 | PolyKinds 104 | RankNTypes 105 | Safe 106 | StandaloneDeriving 107 | Trustworthy 108 | UndecidableInstances 109 | -------------------------------------------------------------------------------- /src/Control/Comonad/Trans/Traced.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE Safe #-} 5 | #ifdef MIN_VERSION_indexed_traversable 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | #endif 9 | 10 | -- | 11 | -- Copyright : (C) 2008-2021 Edward Kmett 12 | -- License : BSD-style (see the file LICENSE) 13 | -- Maintainer : Edward Kmett 14 | -- Stability : provisional 15 | -- Portability : portable 16 | -- 17 | -- The trace comonad builds up a result by prepending monoidal values to each 18 | -- other. 19 | -- 20 | -- This module specifies the traced comonad transformer (aka the cowriter or 21 | -- exponential comonad transformer). 22 | 23 | module Control.Comonad.Trans.Traced 24 | ( 25 | -- * Traced comonad 26 | Traced 27 | , pattern Traced 28 | , runTraced 29 | -- * Traced comonad transformer 30 | , TracedT(..) 31 | -- * Operations 32 | , trace 33 | , listen 34 | , listens 35 | , censor 36 | ) where 37 | 38 | import Control.Monad (ap) 39 | import Control.Comonad 40 | import Control.Comonad.Hoist.Class 41 | import Control.Comonad.Trans.Class 42 | import Data.Functor.Identity 43 | 44 | #ifdef MIN_VERSION_indexed_traversable 45 | import Data.Functor.WithIndex 46 | #endif 47 | 48 | import GHC.Generics 49 | 50 | type Traced m = TracedT m Identity 51 | 52 | pattern Traced :: (m -> a) -> Traced m a 53 | pattern Traced { runTraced } = TracedT (Identity runTraced) 54 | 55 | newtype TracedT m w a = TracedT { runTracedT :: w (m -> a) } 56 | deriving (Generic, Generic1) 57 | 58 | instance Functor w => Functor (TracedT m w) where 59 | fmap g = TracedT . fmap (g .) . runTracedT 60 | {-# inline fmap #-} 61 | 62 | instance (ComonadApply w, Monoid m) => ComonadApply (TracedT m w) where 63 | TracedT wf <@> TracedT wa = TracedT (ap <$> wf <@> wa) 64 | {-# inline (<@>) #-} 65 | 66 | instance Applicative w => Applicative (TracedT m w) where 67 | pure = TracedT . pure . const 68 | {-# inline pure #-} 69 | TracedT wf <*> TracedT wa = TracedT (ap <$> wf <*> wa) 70 | {-# inline (<*>) #-} 71 | 72 | instance (Comonad w, Monoid m) => Comonad (TracedT m w) where 73 | extend f = TracedT . extend (\wf m -> f (TracedT (fmap (. mappend m) wf))) . runTracedT 74 | {-# inline extend #-} 75 | extract (TracedT wf) = extract wf mempty 76 | {-# inline extract #-} 77 | 78 | instance Monoid m => ComonadTrans (TracedT m) where 79 | lower = fmap ($ mempty) . runTracedT 80 | {-# inline lower #-} 81 | 82 | instance ComonadHoist (TracedT m) where 83 | cohoist l = TracedT . l . runTracedT 84 | {-# inline cohoist #-} 85 | 86 | #ifdef MIN_VERSION_indexed_traversable 87 | instance FunctorWithIndex i w => FunctorWithIndex (s, i) (TracedT s w) where 88 | imap f (TracedT w) = TracedT $ imap (\k' g k -> f (k, k') (g k)) w 89 | {-# INLINE imap #-} 90 | #endif 91 | 92 | trace :: Comonad w => m -> TracedT m w a -> a 93 | trace m (TracedT wf) = extract wf m 94 | {-# inline trace #-} 95 | 96 | listen :: Functor w => TracedT m w a -> TracedT m w (a, m) 97 | listen = TracedT . fmap (\f m -> (f m, m)) . runTracedT 98 | {-# inline listen #-} 99 | 100 | listens :: Functor w => (m -> b) -> TracedT m w a -> TracedT m w (a, b) 101 | listens g = TracedT . fmap (\f m -> (f m, g m)) . runTracedT 102 | {-# inline listens #-} 103 | 104 | censor :: Functor w => (m -> m) -> TracedT m w a -> TracedT m w a 105 | censor g = TracedT . fmap (. g) . runTracedT 106 | {-# inline censor #-} 107 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 6 [2021.mm.dd] 2 | -------------- 3 | * Invert dependency between `comonad` and `distributive` 4 | * Drop support for GHC < 8.6 5 | * Add `Generic`, `Generic1` instances where possible 6 | * Stop exporting `Control.Comonad` from all the `Control.Comonad.Foo` modules 7 | to match style with the upcoming `mtl` release. 8 | * Add `Eq(1)`, `Ord(1)`, `Read(1)`, and `Show(1)` instances for `EnvT`. 9 | 10 | 5.0.9 [2024.12.04] 11 | ------------------ 12 | * Drop support for pre-8.0 versions of GHC. 13 | 14 | 5.0.8 [2020.12.30] 15 | ----------------- 16 | * Explicitly mark modules as Safe or Trustworthy 17 | * The build-type has been changed from `Custom` to `Simple`. 18 | To achieve this, the `doctests` test suite has been removed in favor of using [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) to run the doctests. 19 | 20 | 5.0.7 [2020.12.15] 21 | ------------------ 22 | * Move `FunctorWithIndex (TracedT m w)` instance from `lens`. 23 | This instance depends on the `indexed-traversable` package. This can be disabled using the flag of the same name. 24 | 25 | 5.0.6 [2019.11.26] 26 | ------------------ 27 | * Achieve forward compatibility with 28 | [GHC proposal 229](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst). 29 | 30 | 5.0.5 [2019.05.02] 31 | ------------------ 32 | * Raised the minimum `semigroups` version to 0.16.2. In addition, the 33 | package will only be required at all for GHCs before 8.0. 34 | * Drop the `contravariant` flag from `comonad.cabal`, as `comonad` no longer 35 | depends on the `contravariant` library. 36 | 37 | 5.0.4 [2018.07.01] 38 | ------------------ 39 | * Add `Comonad` instances for `Tagged s` with `s` of any kind. Before the 40 | change, `s` had to be of kind `*`. 41 | * Allow `containers-0.6`. 42 | 43 | 5.0.3 [2018.02.06] 44 | ------------------ 45 | * Don't enable `Safe` on GHC 7.2. 46 | 47 | 5.0.2 48 | ----- 49 | * Support `doctest-0.12` 50 | 51 | 5.0.1 52 | ----- 53 | * Revamp `Setup.hs` to use `cabal-doctest`. This makes it build 54 | with `Cabal-1.25`, and makes the `doctest`s work with `cabal new-build` and 55 | sandboxes. 56 | 57 | 5 58 | - 59 | * Removed module `Data.Functor.Coproduct` in favor of the `transformers` 60 | package's `Data.Functor.Sum`. n.b. Compatibility with older versions of 61 | `transformers` is possible using `transformers-compat`. 62 | * Add `Comonad` instance for `Data.Functor.Sum.Sum` 63 | * GHC 8 compatibility 64 | 65 | 4.2.7.2 66 | ------- 67 | * Compiles warning-free on GHC 7.10 68 | 69 | 4.2.7.1 70 | ------- 71 | * Use CPP 72 | 73 | 4.2.7 74 | ----- 75 | * `Trustworthy` fixes for GHC 7.2 76 | 77 | 4.2.6 78 | ----- 79 | * Re-export `(Data.Functor.$>)` rather than supply our own on GHC 7.8+ 80 | * Better SafeHaskell support. 81 | * `instance Monoid m => ComonadTraced m ((->) m)` 82 | 83 | 4.2.5 84 | ------- 85 | * Added a `MINIMAL` pragma to `Comonad`. 86 | * Added `DefaultSignatures` support for `ComonadApply` on GHC 7.2+ 87 | 88 | 4.2.4 89 | ----- 90 | * Added Kenneth Foner's fixed point as `kfix`. 91 | 92 | 4.2.3 93 | ----- 94 | * Add `Comonad` and `ComonadEnv` instances for `Arg e` from `semigroups 0.16.3` which can be used to extract the argmin or argmax. 95 | 96 | 4.2.2 97 | ----- 98 | * `contravariant` 1.0 support 99 | 100 | 4.2.1 101 | ----- 102 | * Added flags that supply unsupported build modes that can be convenient for sandbox users. 103 | 104 | 4.2 105 | --- 106 | * `transformers 0.4` compatibility 107 | 108 | 4.1 109 | --- 110 | * Fixed the 'Typeable' instance for 'Cokleisli on GHC 7.8.1 111 | 112 | 4.0.1 113 | ----- 114 | * Fixes to avoid warnings on GHC 7.8.1 115 | 116 | 4.0 117 | --- 118 | * Merged the contents of `comonad-transformers` and `comonads-fd` into this package. 119 | 120 | 3.1 121 | --- 122 | * Added `instance Comonad (Tagged s)`. 123 | 124 | 3.0.3 125 | ----- 126 | * Trustworthy or Safe depending on GHC version 127 | 128 | 3.0.2 129 | ------- 130 | * GHC 7.7 HEAD compatibility 131 | * Updated build system 132 | -------------------------------------------------------------------------------- /src/Control/Comonad/Trans/Env.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | {-# LANGUAGE Safe #-} 6 | 7 | -- | 8 | -- Copyright : (C) 2008-2021 Edward Kmett 9 | -- License : BSD-style (see the file LICENSE) 10 | -- Maintainer : Edward Kmett 11 | -- Stability : provisional 12 | -- Portability : portable 13 | -- 14 | -- The environment comonad holds a value along with some retrievable context. 15 | -- 16 | -- This module specifies the environment comonad transformer (aka coreader), 17 | -- which is left adjoint to the reader comonad. 18 | -- 19 | -- The following sets up an experiment that retains its initial value in the 20 | -- background: 21 | -- 22 | -- >>> let initial = Env 0 0 23 | -- 24 | -- Extract simply retrieves the value: 25 | -- 26 | -- >>> extract initial 27 | -- 0 28 | -- 29 | -- Play around with the value, in our case producing a negative value: 30 | -- 31 | -- >>> let experiment = fmap (+ 10) initial 32 | -- >>> extract experiment 33 | -- 10 34 | -- 35 | -- Oh noes, something went wrong, 10 isn't very negative! Better restore the 36 | -- initial value using the default: 37 | -- 38 | -- >>> let initialRestored = experiment =>> ask 39 | -- >>> extract initialRestored 40 | -- 0 41 | 42 | module Control.Comonad.Trans.Env 43 | ( 44 | -- * The strict environment comonad 45 | Env 46 | , pattern Env 47 | , runEnv 48 | -- * The strict environment comonad transformer 49 | , EnvT(..) 50 | , runEnvT 51 | , lowerEnvT 52 | -- * Combinators 53 | , ask 54 | , asks 55 | , local 56 | ) where 57 | 58 | import Control.Comonad 59 | import Control.Comonad.Hoist.Class 60 | import Control.Comonad.Trans.Class 61 | import Data.Data 62 | import Data.Functor.Classes 63 | import Data.Functor.Identity 64 | import GHC.Generics 65 | import GHC.Read (expectP) 66 | import Text.Read (Read (..), parens) 67 | import Text.Read.Lex (Lexeme(..)) 68 | 69 | -- $setup 70 | -- >>> import Control.Comonad 71 | 72 | type Env e = EnvT e Identity 73 | data EnvT e w a = EnvT e (w a) 74 | deriving (Eq, Ord, Read, Show, Generic, Generic1, Data) 75 | 76 | -- | Create an Env using an environment and a value 77 | pattern Env :: e -> a -> Env e a 78 | pattern Env e a = EnvT e (Identity a) 79 | 80 | runEnv :: Env e a -> (e, a) 81 | runEnv = \(EnvT e (Identity a)) -> (e, a) 82 | {-# inline runEnv #-} 83 | 84 | runEnvT :: EnvT e w a -> (e, w a) 85 | runEnvT = \(EnvT e wa) -> (e, wa) 86 | {-# inline runEnvT #-} 87 | 88 | instance (Eq e, Eq1 w) => Eq1 (EnvT e w) where 89 | liftEq eq (EnvT e1 wa1) (EnvT e2 wa2) = e1 == e2 && liftEq eq wa1 wa2 90 | 91 | instance (Ord e, Ord1 w) => Ord1 (EnvT e w) where 92 | liftCompare comp (EnvT e1 wa1) (EnvT e2 wa2) = 93 | compare e1 e2 <> liftCompare comp wa1 wa2 94 | 95 | instance (Read e, Read1 w) => Read1 (EnvT e w) where 96 | liftReadPrec rp rl = 97 | parens $ 98 | expectP (Ident "EnvT") *> (EnvT <$> readPrec <*> liftReadPrec rp rl) 99 | 100 | instance (Show e, Show1 w) => Show1 (EnvT e w) where 101 | liftShowsPrec sp sl p (EnvT e wa) = 102 | showParen (p > 10) 103 | $ showString "EnvT" 104 | . foldMap (showString " " .) [showsPrec 11 e, liftShowsPrec sp sl 11 wa] 105 | 106 | instance Functor w => Functor (EnvT e w) where 107 | fmap = \g (EnvT e wa) -> EnvT e (fmap g wa) 108 | {-# inline fmap #-} 109 | 110 | instance Comonad w => Comonad (EnvT e w) where 111 | duplicate = \(EnvT e wa) -> EnvT e (extend (EnvT e) wa) 112 | extract = \(EnvT _ wa) -> extract wa 113 | {-# inline duplicate #-} 114 | {-# inline extract #-} 115 | 116 | instance ComonadTrans (EnvT e) where 117 | lower = \(EnvT _ wa) -> wa 118 | {-# inline lower #-} 119 | 120 | instance (Monoid e, Applicative m) => Applicative (EnvT e m) where 121 | pure = EnvT mempty . pure 122 | {-# inline pure #-} 123 | (<*>) = \(EnvT ef wf) (EnvT ea wa) -> EnvT (ef `mappend` ea) (wf <*> wa) 124 | {-# inline (<*>) #-} 125 | 126 | -- | Gets rid of the environment. This differs from 'extract' in that it will 127 | -- not continue extracting the value from the contained comonad. 128 | lowerEnvT :: EnvT e w a -> w a 129 | lowerEnvT = \(EnvT _ wa) -> wa 130 | {-# inline lowerEnvT #-} 131 | 132 | instance ComonadHoist (EnvT e) where 133 | cohoist = \l (EnvT e wa) -> EnvT e (l wa) 134 | {-# inline cohoist #-} 135 | 136 | instance (Semigroup e, ComonadApply w) => ComonadApply (EnvT e w) where 137 | (<@>) = \(EnvT ef wf) (EnvT ea wa) -> EnvT (ef <> ea) (wf <@> wa) 138 | {-# inline (<@>) #-} 139 | 140 | instance Foldable w => Foldable (EnvT e w) where 141 | foldMap = \f (EnvT _ w) -> foldMap f w 142 | {-# inline foldMap #-} 143 | 144 | instance Traversable w => Traversable (EnvT e w) where 145 | traverse = \f (EnvT e w) -> EnvT e <$> traverse f w 146 | {-# inline traverse #-} 147 | 148 | -- | Retrieves the environment. 149 | ask :: EnvT e w a -> e 150 | ask = \(EnvT e _) -> e 151 | {-# inline ask #-} 152 | 153 | -- | Like 'ask', but modifies the resulting value with a function. 154 | -- 155 | -- > asks = f . ask 156 | asks :: (e -> f) -> EnvT e w a -> f 157 | asks = \f (EnvT e _) -> f e 158 | {-# inline asks #-} 159 | 160 | -- | Modifies the environment using the specified function. 161 | local :: (e -> e') -> EnvT e w a -> EnvT e' w a 162 | local = \f (EnvT e wa) -> EnvT (f e) wa 163 | {-# inline local #-} 164 | -------------------------------------------------------------------------------- /src/Control/Comonad/Trans/Store.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | -- | 6 | -- Copyright : (C) 2008-2021 Edward Kmett 7 | -- License : BSD-style (see the file LICENSE) 8 | -- Maintainer : Edward Kmett 9 | -- Stability : provisional 10 | -- Portability : portable 11 | -- 12 | -- The store comonad holds a constant value along with a modifiable /accessor/ 13 | -- function, which maps the /stored value/ to the /focus/. 14 | -- 15 | -- This module defines the strict store (aka state-in-context/costate) comonad 16 | -- transformer. 17 | -- 18 | -- @stored value = (1, 5)@, @accessor = fst@, @resulting focus = 1@: 19 | -- 20 | -- >>> :{ 21 | -- let 22 | -- storeTuple :: Store (Int, Int) Int 23 | -- storeTuple = Store fst (1, 5) 24 | -- :} 25 | -- 26 | -- Add something to the focus: 27 | -- 28 | -- >>> :{ 29 | -- let 30 | -- addToFocus :: Int -> Store (Int, Int) Int -> Int 31 | -- addToFocus x wa = x + extract wa 32 | -- :} 33 | -- 34 | -- >>> :{ 35 | -- let 36 | -- added3 :: Store (Int, Int) Int 37 | -- added3 = extend (addToFocus 3) storeTuple 38 | -- :} 39 | -- 40 | -- The focus of added3 is now @1 + 3 = 4@. However, this action changed only 41 | -- the accessor function and therefore the focus but not the stored value: 42 | -- 43 | -- >>> pos added3 44 | -- (1,5) 45 | -- 46 | -- >>> extract added3 47 | -- 4 48 | -- 49 | -- The strict store (state-in-context/costate) comonad transformer is subject 50 | -- to the laws: 51 | -- 52 | -- > x = seek (pos x) x 53 | -- > y = pos (seek y x) 54 | -- > seek y x = seek y (seek z x) 55 | -- 56 | -- Thanks go to Russell O'Connor and Daniel Peebles for their help formulating 57 | -- and proving the laws for this comonad transformer. 58 | 59 | module Control.Comonad.Trans.Store 60 | ( 61 | -- * The Store comonad 62 | Store, pattern Store, runStore 63 | -- * The Store comonad transformer 64 | , StoreT(..), runStoreT 65 | -- * Operations 66 | , pos 67 | , seek, seeks 68 | , peek, peeks 69 | , experiment 70 | ) where 71 | 72 | import Control.Comonad 73 | import Control.Comonad.Hoist.Class 74 | import Control.Comonad.Trans.Class 75 | import Data.Functor.Identity 76 | import GHC.Generics 77 | 78 | -- $setup 79 | -- >>> import Control.Comonad 80 | -- >>> import Data.Tuple (swap) 81 | 82 | type Store s = StoreT s Identity 83 | 84 | -- | Create a Store using an accessor function and a stored value 85 | pattern Store :: (s -> a) -> s -> Store s a 86 | pattern Store f s = StoreT (Identity f) s 87 | 88 | runStore :: Store s a -> (s -> a, s) 89 | runStore = \(StoreT (Identity f) s) -> (f, s) 90 | {-# inline runStore #-} 91 | 92 | data StoreT s w a = StoreT (w (s -> a)) s 93 | deriving (Generic, Generic1) 94 | 95 | runStoreT :: StoreT s w a -> (w (s -> a), s) 96 | runStoreT = \(StoreT wf s) -> (wf, s) 97 | {-# inline runStoreT #-} 98 | 99 | instance Functor w => Functor (StoreT s w) where 100 | fmap = \f (StoreT wf s) -> StoreT (fmap (f .) wf) s 101 | {-# inline fmap #-} 102 | 103 | instance (ComonadApply w, Semigroup s) => ComonadApply (StoreT s w) where 104 | (<@>) = \(StoreT ff m) (StoreT fa n) -> StoreT ((<*>) <$> ff <@> fa) (m <> n) 105 | {-# inline (<@>) #-} 106 | 107 | instance (Applicative w, Monoid s) => Applicative (StoreT s w) where 108 | pure = \a -> StoreT (pure (const a)) mempty 109 | {-# inline pure #-} 110 | (<*>) = \(StoreT ff m) (StoreT fa n) -> StoreT ((<*>) <$> ff <*> fa) (mappend m n) 111 | {-# inline (<*>) #-} 112 | 113 | instance Comonad w => Comonad (StoreT s w) where 114 | duplicate = \(StoreT wf s) -> StoreT (extend StoreT wf) s 115 | extend = \f (StoreT wf s) -> StoreT (extend (\wf' s' -> f (StoreT wf' s')) wf) s 116 | extract = \(StoreT wf s) -> extract wf s 117 | {-# inline duplicate #-} 118 | {-# inline extend #-} 119 | {-# inline extract #-} 120 | 121 | instance ComonadTrans (StoreT s) where 122 | lower = \(StoreT f s) -> fmap ($ s) f 123 | {-# inline lower #-} 124 | 125 | instance ComonadHoist (StoreT s) where 126 | cohoist = \l (StoreT f s) -> StoreT (l f) s 127 | {-# inline cohoist #-} 128 | 129 | -- | Read the stored value 130 | -- 131 | -- >>> pos $ Store fst (1,5) 132 | -- (1,5) 133 | -- 134 | pos :: StoreT s w a -> s 135 | pos = \(StoreT _ s) -> s 136 | {-# inline pos #-} 137 | 138 | -- | Set the stored value 139 | -- 140 | -- >>> pos . seek (3,7) $ Store fst (1,5) 141 | -- (3,7) 142 | -- 143 | -- Seek satisfies the law 144 | -- 145 | -- > seek s = peek s . duplicate 146 | seek :: s -> StoreT s w a -> StoreT s w a 147 | seek = \s ~(StoreT f _) -> StoreT f s 148 | {-# inline seek #-} 149 | 150 | -- | Modify the stored value 151 | -- 152 | -- >>> pos . seeks swap $ Store fst (1,5) 153 | -- (5,1) 154 | -- 155 | -- Seeks satisfies the law 156 | -- 157 | -- > seeks f = peeks f . duplicate 158 | seeks :: (s -> s) -> StoreT s w a -> StoreT s w a 159 | seeks = \f ~(StoreT g s) -> StoreT g (f s) 160 | {-# inline seeks #-} 161 | 162 | -- | Peek at what the current focus would be for a different stored value 163 | -- 164 | -- Peek satisfies the law 165 | -- 166 | -- > peek x . extend (peek y) = peek y 167 | peek :: Comonad w => s -> StoreT s w a -> a 168 | peek = \s (StoreT g _) -> extract g s 169 | {-# inline peek #-} 170 | 171 | 172 | -- | Peek at what the current focus would be if the stored value was 173 | -- modified by some function 174 | peeks :: Comonad w => (s -> s) -> StoreT s w a -> a 175 | peeks = \f ~(StoreT g s) -> extract g (f s) 176 | {-# inline peeks #-} 177 | 178 | -- | Applies a functor-valued function to the stored value, and then uses the 179 | -- new accessor to read the resulting focus. 180 | -- 181 | -- >>> let f x = if x > 0 then Just (x^2) else Nothing 182 | -- >>> experiment f $ Store (+1) 2 183 | -- Just 5 184 | -- >>> experiment f $ Store (+1) (-2) 185 | -- Nothing 186 | experiment :: (Comonad w, Functor f) => (s -> f s) -> StoreT s w a -> f a 187 | experiment = \f (StoreT wf s) -> extract wf <$> f s 188 | {-# inline experiment #-} 189 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' '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.20250216 12 | # 13 | # REGENDATA ("0.19.20250216",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-24.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.6.2 32 | compilerKind: ghc 33 | compilerVersion: 9.6.2 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.4.5 37 | compilerKind: ghc 38 | compilerVersion: 9.4.5 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.2.8 42 | compilerKind: ghc 43 | compilerVersion: 9.2.8 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.0.2 47 | compilerKind: ghc 48 | compilerVersion: 9.0.2 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-8.10.7 52 | compilerKind: ghc 53 | compilerVersion: 8.10.7 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-8.8.4 57 | compilerKind: ghc 58 | compilerVersion: 8.8.4 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-8.6.5 62 | compilerKind: ghc 63 | compilerVersion: 8.6.5 64 | setup-method: ghcup 65 | allow-failure: false 66 | fail-fast: false 67 | steps: 68 | - name: apt-get install 69 | run: | 70 | apt-get update 71 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 72 | - name: Install GHCup 73 | run: | 74 | mkdir -p "$HOME/.ghcup/bin" 75 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 76 | chmod a+x "$HOME/.ghcup/bin/ghcup" 77 | - name: Install cabal-install 78 | run: | 79 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 80 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 81 | - name: Install GHC (GHCup) 82 | if: matrix.setup-method == 'ghcup' 83 | run: | 84 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 85 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 86 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 87 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 88 | echo "HC=$HC" >> "$GITHUB_ENV" 89 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 90 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 91 | env: 92 | HCKIND: ${{ matrix.compilerKind }} 93 | HCNAME: ${{ matrix.compiler }} 94 | HCVER: ${{ matrix.compilerVersion }} 95 | - name: Set PATH and environment variables 96 | run: | 97 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 98 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 99 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 100 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 101 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 102 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 103 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 104 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 105 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 106 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 107 | env: 108 | HCKIND: ${{ matrix.compilerKind }} 109 | HCNAME: ${{ matrix.compiler }} 110 | HCVER: ${{ matrix.compilerVersion }} 111 | - name: env 112 | run: | 113 | env 114 | - name: write cabal config 115 | run: | 116 | mkdir -p $CABAL_DIR 117 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 150 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 151 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 152 | rm -f cabal-plan.xz 153 | chmod a+x $HOME/.cabal/bin/cabal-plan 154 | cabal-plan --version 155 | - name: install cabal-docspec 156 | run: | 157 | mkdir -p $HOME/.cabal/bin 158 | curl -sL https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20240703/cabal-docspec-0.0.0.20240703-x86_64-linux.xz > cabal-docspec.xz 159 | echo '48bf3b7fd2f7f0caa6162afee57a755be8523e7f467b694900eb420f5f9a7b76 cabal-docspec.xz' | sha256sum -c - 160 | xz -d < cabal-docspec.xz > $HOME/.cabal/bin/cabal-docspec 161 | rm -f cabal-docspec.xz 162 | chmod a+x $HOME/.cabal/bin/cabal-docspec 163 | cabal-docspec --version 164 | - name: checkout 165 | uses: actions/checkout@v4 166 | with: 167 | path: source 168 | - name: initial cabal.project for sdist 169 | run: | 170 | touch cabal.project 171 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 172 | echo "packages: $GITHUB_WORKSPACE/source/./examples" >> cabal.project 173 | cat cabal.project 174 | - name: sdist 175 | run: | 176 | mkdir -p sdist 177 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 178 | - name: unpack 179 | run: | 180 | mkdir -p unpacked 181 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 182 | - name: generate cabal.project 183 | run: | 184 | PKGDIR_comonad="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/comonad-[0-9.]*')" 185 | echo "PKGDIR_comonad=${PKGDIR_comonad}" >> "$GITHUB_ENV" 186 | PKGDIR_comonad_examples="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/comonad-examples-[0-9.]*')" 187 | echo "PKGDIR_comonad_examples=${PKGDIR_comonad_examples}" >> "$GITHUB_ENV" 188 | rm -f cabal.project cabal.project.local 189 | touch cabal.project 190 | touch cabal.project.local 191 | echo "packages: ${PKGDIR_comonad}" >> cabal.project 192 | echo "packages: ${PKGDIR_comonad_examples}" >> cabal.project 193 | echo "package comonad" >> cabal.project 194 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 195 | echo "package comonad-examples" >> cabal.project 196 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 197 | cat >> cabal.project <> cabal.project.local 200 | cat cabal.project 201 | cat cabal.project.local 202 | - name: dump install plan 203 | run: | 204 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 205 | cabal-plan 206 | - name: restore cache 207 | uses: actions/cache/restore@v4 208 | with: 209 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 210 | path: ~/.cabal/store 211 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 212 | - name: install dependencies 213 | run: | 214 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 215 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 216 | - name: build 217 | run: | 218 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 219 | - name: docspec 220 | run: | 221 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all 222 | cabal-docspec $ARG_COMPILER 223 | - name: cabal check 224 | run: | 225 | cd ${PKGDIR_comonad} || false 226 | ${CABAL} -vnormal check 227 | cd ${PKGDIR_comonad_examples} || false 228 | ${CABAL} -vnormal check 229 | - name: haddock 230 | run: | 231 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 232 | - name: save cache 233 | if: always() 234 | uses: actions/cache/save@v4 235 | with: 236 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 237 | path: ~/.cabal/store 238 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # License 2 | 3 | Licensed under either of 4 | * Apache License, Version 2.0 (http://www.apache.org/licenses/LICENSE-2.0) 5 | * BSD 2-Clause license (https://opensource.org/licenses/BSD-2-Clause) 6 | at your option. 7 | 8 | ## BSD 2-Clause License 9 | 10 | - Copyright 2008-2021 Edward Kmett 11 | - Copyright 2004-2008 Dave Menendez 12 | 13 | All rights reserved. 14 | 15 | Redistribution and use in source and binary forms, with or without 16 | modification, are permitted provided that the following conditions 17 | are met: 18 | 19 | 1. Redistributions of source code must retain the above copyright 20 | notice, this list of conditions and the following disclaimer. 21 | 22 | 2. Redistributions in binary form must reproduce the above copyright 23 | notice, this list of conditions and the following disclaimer in the 24 | documentation and/or other materials provided with the distribution. 25 | 26 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 27 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 28 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 29 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 30 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 31 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 32 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 33 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 34 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 35 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 36 | POSSIBILITY OF SUCH DAMAGE. 37 | 38 | ## Apache License 39 | 40 | _Version 2.0, January 2004_ 41 | _<>_ 42 | 43 | ### Terms and Conditions for use, reproduction, and distribution 44 | 45 | #### 1. Definitions 46 | 47 | “License” shall mean the terms and conditions for use, reproduction, and 48 | distribution as defined by Sections 1 through 9 of this document. 49 | 50 | “Licensor” shall mean the copyright owner or entity authorized by the copyright 51 | owner that is granting the License. 52 | 53 | “Legal Entity” shall mean the union of the acting entity and all other entities 54 | that control, are controlled by, or are under common control with that entity. 55 | For the purposes of this definition, “control” means **(i)** the power, direct or 56 | indirect, to cause the direction or management of such entity, whether by 57 | contract or otherwise, or **(ii)** ownership of fifty percent (50%) or more of the 58 | outstanding shares, or **(iii)** beneficial ownership of such entity. 59 | 60 | “You” (or “Your”) shall mean an individual or Legal Entity exercising 61 | permissions granted by this License. 62 | 63 | “Source” form shall mean the preferred form for making modifications, including 64 | but not limited to software source code, documentation source, and configuration 65 | files. 66 | 67 | “Object” form shall mean any form resulting from mechanical transformation or 68 | translation of a Source form, including but not limited to compiled object code, 69 | generated documentation, and conversions to other media types. 70 | 71 | “Work” shall mean the work of authorship, whether in Source or Object form, made 72 | available under the License, as indicated by a copyright notice that is included 73 | in or attached to the work (an example is provided in the Appendix below). 74 | 75 | “Derivative Works” shall mean any work, whether in Source or Object form, that 76 | is based on (or derived from) the Work and for which the editorial revisions, 77 | annotations, elaborations, or other modifications represent, as a whole, an 78 | original work of authorship. For the purposes of this License, Derivative Works 79 | shall not include works that remain separable from, or merely link (or bind by 80 | name) to the interfaces of, the Work and Derivative Works thereof. 81 | 82 | “Contribution” shall mean any work of authorship, including the original version 83 | of the Work and any modifications or additions to that Work or Derivative Works 84 | thereof, that is intentionally submitted to Licensor for inclusion in the Work 85 | by the copyright owner or by an individual or Legal Entity authorized to submit 86 | on behalf of the copyright owner. For the purposes of this definition, 87 | “submitted” means any form of electronic, verbal, or written communication sent 88 | to the Licensor or its representatives, including but not limited to 89 | communication on electronic mailing lists, source code control systems, and 90 | issue tracking systems that are managed by, or on behalf of, the Licensor for 91 | the purpose of discussing and improving the Work, but excluding communication 92 | that is conspicuously marked or otherwise designated in writing by the copyright 93 | owner as “Not a Contribution.” 94 | 95 | “Contributor” shall mean Licensor and any individual or Legal Entity on behalf 96 | of whom a Contribution has been received by Licensor and subsequently 97 | incorporated within the Work. 98 | 99 | #### 2. Grant of Copyright License 100 | 101 | Subject to the terms and conditions of this License, each Contributor hereby 102 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, 103 | irrevocable copyright license to reproduce, prepare Derivative Works of, 104 | publicly display, publicly perform, sublicense, and distribute the Work and such 105 | Derivative Works in Source or Object form. 106 | 107 | #### 3. Grant of Patent License 108 | 109 | Subject to the terms and conditions of this License, each Contributor hereby 110 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, 111 | irrevocable (except as stated in this section) patent license to make, have 112 | made, use, offer to sell, sell, import, and otherwise transfer the Work, where 113 | such license applies only to those patent claims licensable by such Contributor 114 | that are necessarily infringed by their Contribution(s) alone or by combination 115 | of their Contribution(s) with the Work to which such Contribution(s) was 116 | submitted. If You institute patent litigation against any entity (including a 117 | cross-claim or counterclaim in a lawsuit) alleging that the Work or a 118 | Contribution incorporated within the Work constitutes direct or contributory 119 | patent infringement, then any patent licenses granted to You under this License 120 | for that Work shall terminate as of the date such litigation is filed. 121 | 122 | #### 4. Redistribution 123 | 124 | You may reproduce and distribute copies of the Work or Derivative Works thereof 125 | in any medium, with or without modifications, and in Source or Object form, 126 | provided that You meet the following conditions: 127 | 128 | * **(a)** You must give any other recipients of the Work or Derivative Works a copy of 129 | this License; and 130 | * **(b)** You must cause any modified files to carry prominent notices stating that You 131 | changed the files; and 132 | * **(c)** You must retain, in the Source form of any Derivative Works that You distribute, 133 | all copyright, patent, trademark, and attribution notices from the Source form 134 | of the Work, excluding those notices that do not pertain to any part of the 135 | Derivative Works; and 136 | * **(d)** If the Work includes a “NOTICE” text file as part of its distribution, then any 137 | Derivative Works that You distribute must include a readable copy of the 138 | attribution notices contained within such NOTICE file, excluding those notices 139 | that do not pertain to any part of the Derivative Works, in at least one of the 140 | following places: within a NOTICE text file distributed as part of the 141 | Derivative Works; within the Source form or documentation, if provided along 142 | with the Derivative Works; or, within a display generated by the Derivative 143 | Works, if and wherever such third-party notices normally appear. The contents of 144 | the NOTICE file are for informational purposes only and do not modify the 145 | License. You may add Your own attribution notices within Derivative Works that 146 | You distribute, alongside or as an addendum to the NOTICE text from the Work, 147 | provided that such additional attribution notices cannot be construed as 148 | modifying the License. 149 | 150 | You may add Your own copyright statement to Your modifications and may provide 151 | additional or different license terms and conditions for use, reproduction, or 152 | distribution of Your modifications, or for any such Derivative Works as a whole, 153 | provided Your use, reproduction, and distribution of the Work otherwise complies 154 | with the conditions stated in this License. 155 | 156 | #### 5. Submission of Contributions 157 | 158 | Unless You explicitly state otherwise, any Contribution intentionally submitted 159 | for inclusion in the Work by You to the Licensor shall be under the terms and 160 | conditions of this License, without any additional terms or conditions. 161 | Notwithstanding the above, nothing herein shall supersede or modify the terms of 162 | any separate license agreement you may have executed with Licensor regarding 163 | such Contributions. 164 | 165 | #### 6. Trademarks 166 | 167 | This License does not grant permission to use the trade names, trademarks, 168 | service marks, or product names of the Licensor, except as required for 169 | reasonable and customary use in describing the origin of the Work and 170 | reproducing the content of the NOTICE file. 171 | 172 | #### 7. Disclaimer of Warranty 173 | 174 | Unless required by applicable law or agreed to in writing, Licensor provides the 175 | Work (and each Contributor provides its Contributions) on an “AS IS” BASIS, 176 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, 177 | including, without limitation, any warranties or conditions of TITLE, 178 | NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are 179 | solely responsible for determining the appropriateness of using or 180 | redistributing the Work and assume any risks associated with Your exercise of 181 | permissions under this License. 182 | 183 | #### 8. Limitation of Liability 184 | 185 | In no event and under no legal theory, whether in tort (including negligence), 186 | contract, or otherwise, unless required by applicable law (such as deliberate 187 | and grossly negligent acts) or agreed to in writing, shall any Contributor be 188 | liable to You for damages, including any direct, indirect, special, incidental, 189 | or consequential damages of any character arising as a result of this License or 190 | out of the use or inability to use the Work (including but not limited to 191 | damages for loss of goodwill, work stoppage, computer failure or malfunction, or 192 | any and all other commercial damages or losses), even if such Contributor has 193 | been advised of the possibility of such damages. 194 | 195 | #### 9. Accepting Warranty or Additional Liability 196 | 197 | While redistributing the Work or Derivative Works thereof, You may choose to 198 | offer, and charge a fee for, acceptance of support, warranty, indemnity, or 199 | other liability obligations and/or rights consistent with this License. However, 200 | in accepting such obligations, You may act only on Your own behalf and on Your 201 | sole responsibility, not on behalf of any other Contributor, and only if You 202 | agree to indemnify, defend, and hold each Contributor harmless for any liability 203 | incurred by, or claims asserted against, such Contributor by reason of your 204 | accepting any such warranty or additional liability. 205 | 206 | _END OF TERMS AND CONDITIONS_ 207 | 208 | ### APPENDIX: How to apply the Apache License to your work 209 | 210 | To apply the Apache License to your work, attach the following boilerplate 211 | notice, with the fields enclosed by brackets `[]` replaced with your own 212 | identifying information. (Don't include the brackets!) The text should be 213 | enclosed in the appropriate comment syntax for the file format. We also 214 | recommend that a file or class name and description of purpose be included on 215 | the same “printed page” as the copyright notice for easier identification within 216 | third-party archives. 217 | 218 | Copyright [yyyy] [name of copyright owner] 219 | 220 | Licensed under the Apache License, Version 2.0 (the "License"); 221 | you may not use this file except in compliance with the License. 222 | You may obtain a copy of the License at 223 | 224 | http://www.apache.org/licenses/LICENSE-2.0 225 | 226 | Unless required by applicable law or agreed to in writing, software 227 | distributed under the License is distributed on an "AS IS" BASIS, 228 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 229 | See the License for the specific language governing permissions and 230 | limitations under the License. 231 | 232 | -------------------------------------------------------------------------------- /examples/LICENSE.md: -------------------------------------------------------------------------------- 1 | # License 2 | 3 | Licensed under either of 4 | * Apache License, Version 2.0 (http://www.apache.org/licenses/LICENSE-2.0) 5 | * BSD 2-Clause license (https://opensource.org/licenses/BSD-2-Clause) 6 | at your option. 7 | 8 | ## BSD 2-Clause License 9 | 10 | - Copyright 2008-2021 Edward Kmett 11 | - Copyright 2004-2008 Dave Menendez 12 | 13 | All rights reserved. 14 | 15 | Redistribution and use in source and binary forms, with or without 16 | modification, are permitted provided that the following conditions 17 | are met: 18 | 19 | 1. Redistributions of source code must retain the above copyright 20 | notice, this list of conditions and the following disclaimer. 21 | 22 | 2. Redistributions in binary form must reproduce the above copyright 23 | notice, this list of conditions and the following disclaimer in the 24 | documentation and/or other materials provided with the distribution. 25 | 26 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 27 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 28 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 29 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 30 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 31 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 32 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 33 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 34 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 35 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 36 | POSSIBILITY OF SUCH DAMAGE. 37 | 38 | ## Apache License 39 | 40 | _Version 2.0, January 2004_ 41 | _<>_ 42 | 43 | ### Terms and Conditions for use, reproduction, and distribution 44 | 45 | #### 1. Definitions 46 | 47 | “License” shall mean the terms and conditions for use, reproduction, and 48 | distribution as defined by Sections 1 through 9 of this document. 49 | 50 | “Licensor” shall mean the copyright owner or entity authorized by the copyright 51 | owner that is granting the License. 52 | 53 | “Legal Entity” shall mean the union of the acting entity and all other entities 54 | that control, are controlled by, or are under common control with that entity. 55 | For the purposes of this definition, “control” means **(i)** the power, direct or 56 | indirect, to cause the direction or management of such entity, whether by 57 | contract or otherwise, or **(ii)** ownership of fifty percent (50%) or more of the 58 | outstanding shares, or **(iii)** beneficial ownership of such entity. 59 | 60 | “You” (or “Your”) shall mean an individual or Legal Entity exercising 61 | permissions granted by this License. 62 | 63 | “Source” form shall mean the preferred form for making modifications, including 64 | but not limited to software source code, documentation source, and configuration 65 | files. 66 | 67 | “Object” form shall mean any form resulting from mechanical transformation or 68 | translation of a Source form, including but not limited to compiled object code, 69 | generated documentation, and conversions to other media types. 70 | 71 | “Work” shall mean the work of authorship, whether in Source or Object form, made 72 | available under the License, as indicated by a copyright notice that is included 73 | in or attached to the work (an example is provided in the Appendix below). 74 | 75 | “Derivative Works” shall mean any work, whether in Source or Object form, that 76 | is based on (or derived from) the Work and for which the editorial revisions, 77 | annotations, elaborations, or other modifications represent, as a whole, an 78 | original work of authorship. For the purposes of this License, Derivative Works 79 | shall not include works that remain separable from, or merely link (or bind by 80 | name) to the interfaces of, the Work and Derivative Works thereof. 81 | 82 | “Contribution” shall mean any work of authorship, including the original version 83 | of the Work and any modifications or additions to that Work or Derivative Works 84 | thereof, that is intentionally submitted to Licensor for inclusion in the Work 85 | by the copyright owner or by an individual or Legal Entity authorized to submit 86 | on behalf of the copyright owner. For the purposes of this definition, 87 | “submitted” means any form of electronic, verbal, or written communication sent 88 | to the Licensor or its representatives, including but not limited to 89 | communication on electronic mailing lists, source code control systems, and 90 | issue tracking systems that are managed by, or on behalf of, the Licensor for 91 | the purpose of discussing and improving the Work, but excluding communication 92 | that is conspicuously marked or otherwise designated in writing by the copyright 93 | owner as “Not a Contribution.” 94 | 95 | “Contributor” shall mean Licensor and any individual or Legal Entity on behalf 96 | of whom a Contribution has been received by Licensor and subsequently 97 | incorporated within the Work. 98 | 99 | #### 2. Grant of Copyright License 100 | 101 | Subject to the terms and conditions of this License, each Contributor hereby 102 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, 103 | irrevocable copyright license to reproduce, prepare Derivative Works of, 104 | publicly display, publicly perform, sublicense, and distribute the Work and such 105 | Derivative Works in Source or Object form. 106 | 107 | #### 3. Grant of Patent License 108 | 109 | Subject to the terms and conditions of this License, each Contributor hereby 110 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, 111 | irrevocable (except as stated in this section) patent license to make, have 112 | made, use, offer to sell, sell, import, and otherwise transfer the Work, where 113 | such license applies only to those patent claims licensable by such Contributor 114 | that are necessarily infringed by their Contribution(s) alone or by combination 115 | of their Contribution(s) with the Work to which such Contribution(s) was 116 | submitted. If You institute patent litigation against any entity (including a 117 | cross-claim or counterclaim in a lawsuit) alleging that the Work or a 118 | Contribution incorporated within the Work constitutes direct or contributory 119 | patent infringement, then any patent licenses granted to You under this License 120 | for that Work shall terminate as of the date such litigation is filed. 121 | 122 | #### 4. Redistribution 123 | 124 | You may reproduce and distribute copies of the Work or Derivative Works thereof 125 | in any medium, with or without modifications, and in Source or Object form, 126 | provided that You meet the following conditions: 127 | 128 | * **(a)** You must give any other recipients of the Work or Derivative Works a copy of 129 | this License; and 130 | * **(b)** You must cause any modified files to carry prominent notices stating that You 131 | changed the files; and 132 | * **(c)** You must retain, in the Source form of any Derivative Works that You distribute, 133 | all copyright, patent, trademark, and attribution notices from the Source form 134 | of the Work, excluding those notices that do not pertain to any part of the 135 | Derivative Works; and 136 | * **(d)** If the Work includes a “NOTICE” text file as part of its distribution, then any 137 | Derivative Works that You distribute must include a readable copy of the 138 | attribution notices contained within such NOTICE file, excluding those notices 139 | that do not pertain to any part of the Derivative Works, in at least one of the 140 | following places: within a NOTICE text file distributed as part of the 141 | Derivative Works; within the Source form or documentation, if provided along 142 | with the Derivative Works; or, within a display generated by the Derivative 143 | Works, if and wherever such third-party notices normally appear. The contents of 144 | the NOTICE file are for informational purposes only and do not modify the 145 | License. You may add Your own attribution notices within Derivative Works that 146 | You distribute, alongside or as an addendum to the NOTICE text from the Work, 147 | provided that such additional attribution notices cannot be construed as 148 | modifying the License. 149 | 150 | You may add Your own copyright statement to Your modifications and may provide 151 | additional or different license terms and conditions for use, reproduction, or 152 | distribution of Your modifications, or for any such Derivative Works as a whole, 153 | provided Your use, reproduction, and distribution of the Work otherwise complies 154 | with the conditions stated in this License. 155 | 156 | #### 5. Submission of Contributions 157 | 158 | Unless You explicitly state otherwise, any Contribution intentionally submitted 159 | for inclusion in the Work by You to the Licensor shall be under the terms and 160 | conditions of this License, without any additional terms or conditions. 161 | Notwithstanding the above, nothing herein shall supersede or modify the terms of 162 | any separate license agreement you may have executed with Licensor regarding 163 | such Contributions. 164 | 165 | #### 6. Trademarks 166 | 167 | This License does not grant permission to use the trade names, trademarks, 168 | service marks, or product names of the Licensor, except as required for 169 | reasonable and customary use in describing the origin of the Work and 170 | reproducing the content of the NOTICE file. 171 | 172 | #### 7. Disclaimer of Warranty 173 | 174 | Unless required by applicable law or agreed to in writing, Licensor provides the 175 | Work (and each Contributor provides its Contributions) on an “AS IS” BASIS, 176 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, 177 | including, without limitation, any warranties or conditions of TITLE, 178 | NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are 179 | solely responsible for determining the appropriateness of using or 180 | redistributing the Work and assume any risks associated with Your exercise of 181 | permissions under this License. 182 | 183 | #### 8. Limitation of Liability 184 | 185 | In no event and under no legal theory, whether in tort (including negligence), 186 | contract, or otherwise, unless required by applicable law (such as deliberate 187 | and grossly negligent acts) or agreed to in writing, shall any Contributor be 188 | liable to You for damages, including any direct, indirect, special, incidental, 189 | or consequential damages of any character arising as a result of this License or 190 | out of the use or inability to use the Work (including but not limited to 191 | damages for loss of goodwill, work stoppage, computer failure or malfunction, or 192 | any and all other commercial damages or losses), even if such Contributor has 193 | been advised of the possibility of such damages. 194 | 195 | #### 9. Accepting Warranty or Additional Liability 196 | 197 | While redistributing the Work or Derivative Works thereof, You may choose to 198 | offer, and charge a fee for, acceptance of support, warranty, indemnity, or 199 | other liability obligations and/or rights consistent with this License. However, 200 | in accepting such obligations, You may act only on Your own behalf and on Your 201 | sole responsibility, not on behalf of any other Contributor, and only if You 202 | agree to indemnify, defend, and hold each Contributor harmless for any liability 203 | incurred by, or claims asserted against, such Contributor by reason of your 204 | accepting any such warranty or additional liability. 205 | 206 | _END OF TERMS AND CONDITIONS_ 207 | 208 | ### APPENDIX: How to apply the Apache License to your work 209 | 210 | To apply the Apache License to your work, attach the following boilerplate 211 | notice, with the fields enclosed by brackets `[]` replaced with your own 212 | identifying information. (Don't include the brackets!) The text should be 213 | enclosed in the appropriate comment syntax for the file format. We also 214 | recommend that a file or class name and description of purpose be included on 215 | the same “printed page” as the copyright notice for easier identification within 216 | third-party archives. 217 | 218 | Copyright [yyyy] [name of copyright owner] 219 | 220 | Licensed under the Apache License, Version 2.0 (the "License"); 221 | you may not use this file except in compliance with the License. 222 | You may obtain a copy of the License at 223 | 224 | http://www.apache.org/licenses/LICENSE-2.0 225 | 226 | Unless required by applicable law or agreed to in writing, software 227 | distributed under the License is distributed on an "AS IS" BASIS, 228 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 229 | See the License for the specific language governing permissions and 230 | limitations under the License. 231 | 232 | -------------------------------------------------------------------------------- /src/Control/Comonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Safe #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | 8 | -- | 9 | -- Copyright : (C) 2008-2021 Edward Kmett, 10 | -- (C) 2004 Dave Menendez 11 | -- License : BSD-style (see the file LICENSE) 12 | -- Maintainer : Edward Kmett 13 | -- Stability : provisional 14 | -- Portability : portable 15 | module Control.Comonad 16 | ( 17 | -- * Comonads 18 | Comonad(..) 19 | , liftW -- :: Comonad w => (a -> b) -> w a -> w b 20 | , wfix -- :: Comonad w => w (w a -> a) -> a 21 | , cfix -- :: Comonad w => (w a -> a) -> w a 22 | , kfix -- :: ComonadApply w => w (w a -> a) -> w a 23 | , (=>=) 24 | , (=<=) 25 | , (<<=) 26 | , (=>>) 27 | -- * Combining Comonads 28 | , ComonadApply(..) 29 | , (<@@>) -- :: ComonadApply w => w a -> w (a -> b) -> w b 30 | , liftW2 -- :: ComonadApply w => (a -> b -> c) -> w a -> w b -> w c 31 | , liftW3 -- :: ComonadApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d 32 | -- * Cokleisli Arrows 33 | , Cokleisli(..) 34 | -- * Functors 35 | , Functor(..) 36 | , (<$>) -- :: Functor f => (a -> b) -> f a -> f b 37 | , ($>) -- :: Functor f => f a -> b -> f b 38 | ) where 39 | 40 | import Data.Functor 41 | import Control.Applicative 42 | import Control.Arrow 43 | import Control.Category 44 | import Control.Monad.Fix 45 | import Control.Monad.Trans.Identity 46 | import Data.Functor.Identity 47 | import qualified Data.Functor.Sum as FSum 48 | import Data.List.NonEmpty hiding (map) 49 | import Data.Semigroup hiding (Product) 50 | import Data.Tagged 51 | import GHC.Generics 52 | import Prelude hiding (id, (.)) 53 | 54 | #ifdef MIN_VERSION_containers 55 | import Data.Tree 56 | #endif 57 | 58 | infixl 4 <@, @>, <@@>, <@> 59 | infixl 1 =>> 60 | infixr 1 <<=, =<=, =>= 61 | 62 | {- | 63 | 64 | There are two ways to define a comonad: 65 | 66 | I. Provide definitions for 'extract' and 'extend' 67 | satisfying these laws: 68 | 69 | @ 70 | 'extend' 'extract' = 'id' 71 | 'extract' . 'extend' f = f 72 | 'extend' f . 'extend' g = 'extend' (f . 'extend' g) 73 | @ 74 | 75 | In this case, you may simply set 'fmap' = 'liftW'. 76 | 77 | These laws are directly analogous to the laws for monads 78 | and perhaps can be made clearer by viewing them as laws stating 79 | that Cokleisli composition must be associative, and has extract for 80 | a unit: 81 | 82 | @ 83 | f '=>=' 'extract' = f 84 | 'extract' '=>=' f = f 85 | (f '=>=' g) '=>=' h = f '=>=' (g '=>=' h) 86 | @ 87 | 88 | II. Alternately, you may choose to provide definitions for 'fmap', 89 | 'extract', and 'duplicate' satisfying these laws: 90 | 91 | @ 92 | 'extract' . 'duplicate' = 'id' 93 | 'fmap' 'extract' . 'duplicate' = 'id' 94 | 'duplicate' . 'duplicate' = 'fmap' 'duplicate' . 'duplicate' 95 | @ 96 | 97 | In this case you may not rely on the ability to define 'fmap' in 98 | terms of 'liftW'. 99 | 100 | You may of course, choose to define both 'duplicate' /and/ 'extend'. 101 | In that case you must also satisfy these laws: 102 | 103 | @ 104 | 'extend' f = 'fmap' f . 'duplicate' 105 | 'duplicate' = 'extend' id 106 | 'fmap' f = 'extend' (f . 'extract') 107 | @ 108 | 109 | These are the default definitions of 'extend' and 'duplicate' and 110 | the definition of 'liftW' respectively. 111 | 112 | -} 113 | 114 | class Functor w => Comonad w where 115 | -- | 116 | -- @ 117 | -- 'extract' . 'fmap' f = f . 'extract' 118 | -- @ 119 | extract :: w a -> a 120 | 121 | -- | 122 | -- @ 123 | -- 'duplicate' = 'extend' 'id' 124 | -- 'fmap' ('fmap' f) . 'duplicate' = 'duplicate' . 'fmap' f 125 | -- @ 126 | duplicate :: w a -> w (w a) 127 | duplicate = extend id 128 | {-# inline duplicate #-} 129 | 130 | -- | 131 | -- @ 132 | -- 'extend' f = 'fmap' f . 'duplicate' 133 | -- @ 134 | extend :: (w a -> b) -> w a -> w b 135 | extend = \f -> fmap f . duplicate 136 | {-# inline extend #-} 137 | 138 | {-# MINIMAL extract, (duplicate | extend) #-} 139 | 140 | instance Comonad ((,) e) where 141 | duplicate = \p -> (fst p, p) 142 | {-# inline duplicate #-} 143 | extract = snd 144 | {-# inline extract #-} 145 | 146 | instance Comonad (Arg e) where 147 | duplicate = \w@(Arg a _) -> Arg a w 148 | {-# inline duplicate #-} 149 | extend = \f w@(Arg a _) -> Arg a (f w) 150 | {-# inline extend #-} 151 | extract = \(Arg _ b) -> b 152 | {-# inline extract #-} 153 | 154 | instance Monoid m => Comonad ((->)m) where 155 | duplicate = \f m -> f . mappend m 156 | {-# inline duplicate #-} 157 | extract = \f -> f mempty 158 | {-# inline extract #-} 159 | 160 | instance Comonad Identity where 161 | duplicate = Identity 162 | {-# inline duplicate #-} 163 | extract = runIdentity 164 | {-# inline extract #-} 165 | 166 | -- $ 167 | -- The variable `s` can have any kind. 168 | -- For example, here it has kind `Bool`: 169 | -- >>> :set -XDataKinds 170 | -- >>> import Data.Tagged 171 | -- >>> extract (Tagged 42 :: Tagged 'True Integer) 172 | -- 42 173 | instance Comonad (Tagged s) where 174 | duplicate = Tagged 175 | {-# inline duplicate #-} 176 | extract = unTagged 177 | {-# inline extract #-} 178 | 179 | instance Comonad w => Comonad (IdentityT w) where 180 | extend = \f (IdentityT m) -> IdentityT (extend (f . IdentityT) m) 181 | {-# inline extend #-} 182 | extract = extract . runIdentityT 183 | {-# inline extract #-} 184 | 185 | #ifdef MIN_VERSION_containers 186 | instance Comonad Tree where 187 | duplicate = \w@(Node _ as) -> Node w (map duplicate as) 188 | {-# inline duplicate #-} 189 | extract (Node a _) = a 190 | {-# inline extract #-} 191 | #endif 192 | 193 | instance Comonad NonEmpty where 194 | extend = \f w@(~(_ :| aas)) -> 195 | f w :| case aas of 196 | [] -> [] 197 | (a:as) -> toList (extend f (a :| as)) 198 | {-# inline extend #-} 199 | extract = \ ~(a :| _) -> a 200 | {-# inline extract #-} 201 | 202 | coproduct :: (f a -> b) -> (g a -> b) -> FSum.Sum f g a -> b 203 | coproduct = \f g -> \case 204 | FSum.InL x -> f x 205 | FSum.InR y -> g y 206 | {-# inline coproduct #-} 207 | 208 | instance (Comonad f, Comonad g) => Comonad (FSum.Sum f g) where 209 | extend = \f -> coproduct 210 | (FSum.InL . extend (f . FSum.InL)) 211 | (FSum.InR . extend (f . FSum.InR)) 212 | {-# inline extend #-} 213 | extract = coproduct extract extract 214 | {-# inline extract #-} 215 | 216 | 217 | -- | @ComonadApply@ is to @Comonad@ like @Applicative@ is to @Monad@. 218 | -- 219 | -- Mathematically, it is a strong lax symmetric semi-monoidal comonad on the 220 | -- category @Hask@ of Haskell types. That it to say that @w@ is a strong lax 221 | -- symmetric semi-monoidal functor on Hask, where both 'extract' and 'duplicate' are 222 | -- symmetric monoidal natural transformations. 223 | -- 224 | -- Laws: 225 | -- 226 | -- @ 227 | -- ('.') '<$>' u '<@>' v '<@>' w = u '<@>' (v '<@>' w) 228 | -- 'extract' (p '<@>' q) = 'extract' p ('extract' q) 229 | -- 'duplicate' (p '<@>' q) = ('<@>') '<$>' 'duplicate' p '<@>' 'duplicate' q 230 | -- @ 231 | -- 232 | -- If our type is both a 'ComonadApply' and 'Applicative' we further require 233 | -- 234 | -- @ 235 | -- ('<*>') = ('<@>') 236 | -- @ 237 | -- 238 | -- Finally, if you choose to define ('<@') and ('@>'), the results of your 239 | -- definitions should match the following laws: 240 | -- 241 | -- @ 242 | -- a '@>' b = 'const' 'id' '<$>' a '<@>' b 243 | -- a '<@' b = 'const' '<$>' a '<@>' b 244 | -- @ 245 | 246 | class Comonad w => ComonadApply w where 247 | (<@>) :: w (a -> b) -> w a -> w b 248 | default (<@>) :: Applicative w => w (a -> b) -> w a -> w b 249 | (<@>) = (<*>) 250 | 251 | (@>) :: w a -> w b -> w b 252 | (@>) = \a b -> id <$ a <@> b 253 | 254 | (<@) :: w a -> w b -> w a 255 | (<@) = \a b -> const <$> a <@> b 256 | {-# inline (<@>) #-} 257 | {-# inline (@>) #-} 258 | {-# inline (<@) #-} 259 | 260 | instance Semigroup m => ComonadApply ((,)m) where 261 | (<@>) = \(m, f) (n, a) -> (m <> n, f a) 262 | (<@) = \(m, a) (n, _) -> (m <> n, a) 263 | (@>) = \(m, _) (n, b) -> (m <> n, b) 264 | {-# inline (<@>) #-} 265 | {-# inline (@>) #-} 266 | {-# inline (<@) #-} 267 | 268 | instance ComonadApply NonEmpty where 269 | (<@>) = (<*>) 270 | (<@ ) = (<* ) 271 | ( @>) = ( *>) 272 | {-# inline (<@>) #-} 273 | {-# inline (@>) #-} 274 | {-# inline (<@) #-} 275 | 276 | instance Monoid m => ComonadApply ((->)m) where 277 | (<@>) = (<*>) 278 | (<@ ) = (<* ) 279 | ( @>) = ( *>) 280 | {-# inline (<@>) #-} 281 | {-# inline (@>) #-} 282 | {-# inline (<@) #-} 283 | 284 | instance ComonadApply Identity where 285 | (<@>) = (<*>) 286 | (<@ ) = (<* ) 287 | ( @>) = ( *>) 288 | {-# inline (<@>) #-} 289 | {-# inline (@>) #-} 290 | {-# inline (<@) #-} 291 | 292 | instance ComonadApply w => ComonadApply (IdentityT w) where 293 | (<@>) = \(IdentityT wa) (IdentityT wb) -> IdentityT (wa <@> wb) 294 | {-# inline (<@>) #-} 295 | 296 | #ifdef MIN_VERSION_containers 297 | instance ComonadApply Tree where 298 | (<@>) = (<*>) 299 | (<@ ) = (<* ) 300 | ( @>) = ( *>) 301 | {-# inline (<@>) #-} 302 | {-# inline (@>) #-} 303 | {-# inline (<@) #-} 304 | #endif 305 | 306 | -- | A suitable default definition for 'fmap' for a 'Comonad'. 307 | -- Promotes a function to a comonad. 308 | -- 309 | -- You can only safely use 'liftW' to define 'fmap' if your 'Comonad' 310 | -- defines 'extend', not just 'duplicate', since defining 311 | -- 'extend' in terms of duplicate uses 'fmap'! 312 | -- 313 | -- @ 314 | -- 'fmap' f = 'liftW' f = 'extend' (f . 'extract') 315 | -- @ 316 | liftW :: Comonad w => (a -> b) -> w a -> w b 317 | liftW = \f -> extend (f . extract) 318 | {-# inline liftW #-} 319 | 320 | -- | Comonadic fixed point à la David Menendez 321 | wfix :: Comonad w => w (w a -> a) -> a 322 | wfix = \w -> extract w (extend wfix w) 323 | 324 | -- | Comonadic fixed point à la Dominic Orchard 325 | cfix :: Comonad w => (w a -> a) -> w a 326 | cfix = \f -> fix (extend f) 327 | {-# inline cfix #-} 328 | 329 | -- | Comonadic fixed point à la Kenneth Foner: 330 | -- 331 | -- This is the @evaluate@ function from his talk. 332 | kfix :: ComonadApply w => w (w a -> a) -> w a 333 | kfix = \w -> fix $ \u -> w <@> duplicate u 334 | {-# inline kfix #-} 335 | 336 | -- | 'extend' with the arguments swapped. Dual to '>>=' for a 'Monad'. 337 | (=>>) :: Comonad w => w a -> (w a -> b) -> w b 338 | (=>>) = flip extend 339 | {-# inline (=>>) #-} 340 | 341 | -- | 'extend' in operator form 342 | (<<=) :: Comonad w => (w a -> b) -> w a -> w b 343 | (<<=) = extend 344 | {-# inline (<<=) #-} 345 | 346 | -- | Right-to-left 'Cokleisli' composition 347 | (=<=) :: Comonad w => (w b -> c) -> (w a -> b) -> w a -> c 348 | (=<=) = \f g -> f . extend g 349 | {-# inline (=<=) #-} 350 | 351 | -- | Left-to-right 'Cokleisli' composition 352 | (=>=) :: Comonad w => (w a -> b) -> (w b -> c) -> w a -> c 353 | (=>=) = \f g -> g . extend f 354 | {-# inline (=>=) #-} 355 | 356 | -- | A variant of '<@>' with the arguments reversed. 357 | (<@@>) :: ComonadApply w => w a -> w (a -> b) -> w b 358 | (<@@>) = liftW2 (flip id) 359 | {-# inline (<@@>) #-} 360 | 361 | -- | Lift a binary function into a 'Comonad' with zipping 362 | liftW2 :: ComonadApply w => (a -> b -> c) -> w a -> w b -> w c 363 | liftW2 = \f a b -> f <$> a <@> b 364 | {-# inline liftW2 #-} 365 | 366 | -- | Lift a ternary function into a 'Comonad' with zipping 367 | liftW3 :: ComonadApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d 368 | liftW3 = \f a b c -> f <$> a <@> b <@> c 369 | {-# inline liftW3 #-} 370 | 371 | -- | The 'Cokleisli' 'Arrow's of a given 'Comonad' 372 | newtype Cokleisli w a b = Cokleisli { runCokleisli :: w a -> b } 373 | deriving (Generic, Generic1) 374 | 375 | instance Comonad w => Category (Cokleisli w) where 376 | id = Cokleisli extract 377 | {-# inline id #-} 378 | (.) = \(Cokleisli f) (Cokleisli g) -> Cokleisli (f =<= g) 379 | {-# inline (.) #-} 380 | 381 | instance Comonad w => Arrow (Cokleisli w) where 382 | arr = \f -> Cokleisli (f . extract) 383 | {-# inline arr #-} 384 | first = \f -> f *** id 385 | {-# inline first #-} 386 | second = \f -> id *** f 387 | {-# inline second #-} 388 | (***) = \(Cokleisli f) (Cokleisli g) -> Cokleisli (f . fmap fst &&& g . fmap snd) 389 | {-# inline (***) #-} 390 | (&&&) = \(Cokleisli f) (Cokleisli g) -> Cokleisli (f &&& g) 391 | {-# inline (&&&) #-} 392 | 393 | instance Comonad w => ArrowApply (Cokleisli w) where 394 | app = Cokleisli $ \w -> runCokleisli (fst (extract w)) (snd <$> w) 395 | {-# inline app #-} 396 | 397 | instance Comonad w => ArrowChoice (Cokleisli w) where 398 | left = leftApp 399 | {-# inline left #-} 400 | 401 | instance ComonadApply w => ArrowLoop (Cokleisli w) where 402 | loop = \(Cokleisli f) -> 403 | let f' wa wb = f ((,) <$> wa <@> (snd <$> wb)) in 404 | Cokleisli (fst . wfix . extend f') 405 | {-# inline loop #-} 406 | 407 | instance Functor (Cokleisli w a) where 408 | fmap = \f (Cokleisli g) -> Cokleisli (f . g) 409 | {-# inline fmap #-} 410 | 411 | instance Applicative (Cokleisli w a) where 412 | pure = Cokleisli . const 413 | {-# inline pure #-} 414 | (<*>) = \(Cokleisli f) (Cokleisli a) -> Cokleisli (\w -> f w (a w)) 415 | {-# inline (<*>) #-} 416 | 417 | instance Monad (Cokleisli w a) where 418 | (>>=) = \(Cokleisli k) f -> Cokleisli $ \w -> runCokleisli (f (k w)) w 419 | {-# inline (>>=) #-} 420 | --------------------------------------------------------------------------------