comonad 3.0.1.1 → 3.0.2
raw patch · 11 files changed
+655/−325 lines, 11 filesdep +directorydep +doctestdep +filepathdep ~basedep ~semigroupsbuild-type:Customsetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: directory, doctest, filepath
Dependency ranges changed: base, semigroups
API changes (from Hackage documentation)
Files
- .gitignore +13/−0
- .travis.yml +25/−0
- CHANGELOG.markdown +4/−0
- Control/Comonad.hs +0/−314
- LICENSE +1/−1
- README.markdown +59/−0
- Setup.lhs +52/−4
- comonad.cabal +38/−6
- examples/History.hs +60/−0
- src/Control/Comonad.hs +329/−0
- tests/doctests.hsc +74/−0
+ .gitignore view
@@ -0,0 +1,13 @@+dist+docs+wiki+TAGS+tags+wip+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#
.travis.yml view
@@ -1,1 +1,26 @@ language: haskell+before_install:+ # Uncomment whenever hackage is down.+ # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update+ - cabal update++ # Try installing some of the build-deps with apt-get for speed.+ - travis/cabal-apt-install $mode++install:+ - cabal configure -flib-Werror $mode+ - cabal build++script:+ - $script && hlint src --cpp-define HLINT++notifications:+ irc:+ channels:+ - "irc.freenode.org#haskell-lens"+ skip_join: true+ template:+ - "\x0313comonad\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"++env:+ - mode="--enable-tests" script="cabal test --show-details=always"
+ CHANGELOG.markdown view
@@ -0,0 +1,4 @@+3.0.2+-------+* GHC 7.7 HEAD compatibility+* Updated build system
− Control/Comonad.hs
@@ -1,314 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module : Control.Comonad--- Copyright : (C) 2008-2012 Edward Kmett,--- (C) 2004 Dave Menendez--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable---------------------------------------------------------------------------------module Control.Comonad (- -- * Comonads- Comonad(..)- , liftW -- :: Comonad w => (a -> b) -> w a -> w b- , wfix -- :: Comonad w => w (w a -> a) -> a- , cfix -- :: Comonad w => (w a -> a) -> w a- , (=>=)- , (=<=)- , (<<=)- , (=>>)- -- * Combining Comonads- , ComonadApply(..)- , (<@@>) -- :: ComonadApply w => w a -> w (a -> b) -> w b- , liftW2 -- :: ComonadApply w => (a -> b -> c) -> w a -> w b -> w c- , liftW3 -- :: ComonadApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d- -- * Cokleisli Arrows- , Cokleisli(..)- -- * Functors- , Functor(..)- , (<$>) -- :: Functor f => (a -> b) -> f a -> f b- , ($>) -- :: Functor f => f a -> b -> f b- ) where---- import _everything_-import Control.Applicative-import Control.Arrow-import Control.Category-import Control.Monad (ap)-import Control.Monad.Instances-import Control.Monad.Trans.Identity-import Data.Functor.Identity-import Data.List.NonEmpty hiding (map)-import Data.Semigroup hiding (Product)-import Data.Tree-import Prelude hiding (id, (.))-import Control.Monad.Fix-import Data.Typeable--infixl 4 <@, @>, <@@>, <@>, $>-infixl 1 =>>-infixr 1 <<=, =<=, =>=--{- |--There are two ways to define a comonad:--I. Provide definitions for 'extract' and 'extend'-satisfying these laws:--> extend extract = id-> extract . extend f = f-> extend f . extend g = extend (f . extend g)--In this case, you may simply set 'fmap' = 'liftW'.--These laws are directly analogous to the laws for monads-and perhaps can be made clearer by viewing them as laws stating-that Cokleisli composition must be associative, and has extract for-a unit:--> f =>= extract = f-> extract =>= f = f-> (f =>= g) =>= h = f =>= (g =>= h)--II. Alternately, you may choose to provide definitions for 'fmap',-'extract', and 'duplicate' satisfying these laws:--> extract . duplicate = id-> fmap extract . duplicate = id-> duplicate . duplicate = fmap duplicate . duplicate--In this case you may not rely on the ability to define 'fmap' in-terms of 'liftW'.--You may of course, choose to define both 'duplicate' /and/ 'extend'.-In that case you must also satisfy these laws:--> extend f = fmap f . duplicate-> duplicate = extend id-> fmap f = extend (f . extract)--These are the default definitions of 'extend' and 'duplicate' and-the definition of 'liftW' respectively.---}--class Functor w => Comonad w where- -- |- -- > extract . fmap f = f . extract- extract :: w a -> a-- -- |- -- > duplicate = extend id- -- > fmap (fmap f) . duplicate = duplicate . fmap f- duplicate :: w a -> w (w a)- duplicate = extend id-- -- |- -- > extend f = fmap f . duplicate- extend :: (w a -> b) -> w a -> w b- extend f = fmap f . duplicate---instance Comonad ((,)e) where- duplicate p = (fst p, p)- {-# INLINE duplicate #-}- extract = snd- {-# INLINE extract #-}--instance Monoid m => Comonad ((->)m) where- duplicate f m = f . mappend m- {-# INLINE duplicate #-}- extract f = f mempty- {-# INLINE extract #-}--instance Comonad Identity where- duplicate = Identity- {-# INLINE duplicate #-}- extract = runIdentity- {-# INLINE extract #-}--instance Comonad w => Comonad (IdentityT w) where- extend f (IdentityT m) = IdentityT (extend (f . IdentityT) m)- extract = extract . runIdentityT- {-# INLINE extract #-}--instance Comonad Tree where- duplicate w@(Node _ as) = Node w (map duplicate as)- extract (Node a _) = a- {-# INLINE extract #-}--instance Comonad NonEmpty where- extend f w@ ~(_ :| aas) = f w :| case aas of- [] -> []- (a:as) -> toList (extend f (a :| as))- extract ~(a :| _) = a- {-# INLINE extract #-}---- | A @ComonadApply w@ is a strong lax symmetric semi-monoidal comonad on the--- category @Hask@ of Haskell types.------ That it to say that @w@ is a strong lax symmetric semi-monoidal functor on--- Hask, where both extract and duplicate are symmetric monoidal natural--- transformations.------ Laws:------ > (.) <$> u <@> v <@> w = u <@> (v <@> w)--- > extract p (extract q) = extract (p <@> q)--- > duplicate (p <*> q) = (\r s -> fmap (r <@> s)) <@> duplicate q <*> duplicate q------ If our type is both a ComonadApply and Applicative we further require------ > (<*>) = (<@>)------ Finally, if you choose to define ('<@') and ('@>'), the results of your--- definitions should match the following laws:------ > a @> b = const id <$> a <@> b--- > a <@ b = const <$> a <@> b--class Comonad w => ComonadApply w where- (<@>) :: w (a -> b) -> w a -> w b-- (@>) :: w a -> w b -> w b- a @> b = const id <$> a <@> b-- (<@) :: w a -> w b -> w a- a <@ b = const <$> a <@> b--instance Semigroup m => ComonadApply ((,)m) where- (m, f) <@> (n, a) = (m <> n, f a)- (m, a) <@ (n, _) = (m <> n, a)- (m, _) @> (n, b) = (m <> n, b)--instance ComonadApply NonEmpty where- (<@>) = ap--instance Monoid m => ComonadApply ((->)m) where- (<@>) = (<*>)- (<@ ) = (<* )- ( @>) = ( *>)--instance ComonadApply Identity where- (<@>) = (<*>)- (<@ ) = (<* )- ( @>) = ( *>)--instance ComonadApply w => ComonadApply (IdentityT w) where- IdentityT wa <@> IdentityT wb = IdentityT (wa <@> wb)--instance ComonadApply Tree where- (<@>) = (<*>)- (<@ ) = (<* )- ( @>) = ( *>)---- | A suitable default definition for 'fmap' for a 'Comonad'.--- Promotes a function to a comonad.------ > fmap f = liftW f = extend (f . extract)-liftW :: Comonad w => (a -> b) -> w a -> w b-liftW f = extend (f . extract)-{-# INLINE liftW #-}---- | Comonadic fixed point à la Menendez-wfix :: Comonad w => w (w a -> a) -> a-wfix w = extract w (extend wfix w)---- | Comonadic fixed point à la Orchard-cfix :: Comonad w => (w a -> a) -> w a-cfix f = fix (extend f)-{-# INLINE cfix #-}---- | 'extend' with the arguments swapped. Dual to '>>=' for a 'Monad'.-(=>>) :: Comonad w => w a -> (w a -> b) -> w b-(=>>) = flip extend-{-# INLINE (=>>) #-}---- | 'extend' in operator form-(<<=) :: Comonad w => (w a -> b) -> w a -> w b-(<<=) = extend-{-# INLINE (<<=) #-}---- | Right-to-left Cokleisli composition-(=<=) :: Comonad w => (w b -> c) -> (w a -> b) -> w a -> c-f =<= g = f . extend g-{-# INLINE (=<=) #-}---- | Left-to-right Cokleisli composition-(=>=) :: Comonad w => (w a -> b) -> (w b -> c) -> w a -> c-f =>= g = g . extend f-{-# INLINE (=>=) #-}---- | A variant of '<@>' with the arguments reversed.-(<@@>) :: ComonadApply w => w a -> w (a -> b) -> w b-(<@@>) = liftW2 (flip id)-{-# INLINE (<@@>) #-}---- | Lift a binary function into a comonad with zipping-liftW2 :: ComonadApply w => (a -> b -> c) -> w a -> w b -> w c-liftW2 f a b = f <$> a <@> b-{-# INLINE liftW2 #-}---- | Lift a ternary function into a comonad with zipping-liftW3 :: ComonadApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d-liftW3 f a b c = f <$> a <@> b <@> c-{-# INLINE liftW3 #-}---- | The 'Cokleisli' 'Arrow's of a given 'Comonad'-newtype Cokleisli w a b = Cokleisli { runCokleisli :: w a -> b }--#ifdef __GLASGOW_HASKELL__-instance Typeable1 w => Typeable2 (Cokleisli w) where- typeOf2 twab = mkTyConApp cokleisliTyCon [typeOf1 (wa twab)]- where wa :: Cokleisli w a b -> w a- wa = undefined-#endif--cokleisliTyCon :: TyCon-#if MIN_VERSION_base(4,4,0)-cokleisliTyCon = mkTyCon3 "comonad" "Control.Comonad" "Cokleisli"-#else-cokleisliTyCon = mkTyCon "Control.Comonad.Cokleisli"-#endif-{-# NOINLINE cokleisliTyCon #-}--instance Comonad w => Category (Cokleisli w) where- id = Cokleisli extract- Cokleisli f . Cokleisli g = Cokleisli (f =<= g)--instance Comonad w => Arrow (Cokleisli w) where- arr f = Cokleisli (f . extract)- first f = f *** id- second f = id *** f- Cokleisli f *** Cokleisli g = Cokleisli (f . fmap fst &&& g . fmap snd)- Cokleisli f &&& Cokleisli g = Cokleisli (f &&& g)--instance Comonad w => ArrowApply (Cokleisli w) where- app = Cokleisli $ \w -> runCokleisli (fst (extract w)) (snd <$> w)--instance Comonad w => ArrowChoice (Cokleisli w) where- left = leftApp--instance ComonadApply w => ArrowLoop (Cokleisli w) where- loop (Cokleisli f) = Cokleisli (fst . wfix . extend f') where- f' wa wb = f ((,) <$> wa <@> (snd <$> wb))--instance Functor (Cokleisli w a) where- fmap f (Cokleisli g) = Cokleisli (f . g)--instance Applicative (Cokleisli w a) where- pure = Cokleisli . const- Cokleisli f <*> Cokleisli a = Cokleisli (\w -> (f w) (a w))--instance Monad (Cokleisli w a) where- return = Cokleisli . const- Cokleisli k >>= f = Cokleisli $ \w -> runCokleisli (f (k w)) w---- | Replace the contents of a functor uniformly with a constant value.-($>) :: Functor f => f a -> b -> f b-($>) = flip (<$)
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2008-2011 Edward Kmett+Copyright 2008-2013 Edward Kmett Copyright 2004-2008 Dave Menendez All rights reserved.
+ README.markdown view
@@ -0,0 +1,59 @@+comonad+=======++[](http://travis-ci.org/ekmett/comonad)++This package provides comonads, the categorical dual of monads.++ class Functor w => Comonad w where+ extract :: w a -> a+ duplicate :: w a -> w (w a)+ extend :: (w a -> b) -> w a -> w b++There are two ways to define a comonad:++I. Provide definitions for 'extract' and 'extend' satisfying these laws:++ extend extract = id+ extract . extend f = f+ extend f . extend g = extend (f . extend g)++In this case, you may simply set 'fmap' = 'liftW'.++These laws are directly analogous to the laws for monads+and perhaps can be made clearer by viewing them as laws stating+that Cokleisli composition must be associative, and has extract for+a unit:++ f =>= extract = f+ extract =>= f = f+ (f =>= g) =>= h = f =>= (g =>= h)++II. Alternately, you may choose to provide definitions for 'fmap',+'extract', and 'duplicate' satisfying these laws:++ extract . duplicate = id+ fmap extract . duplicate = id+ duplicate . duplicate = fmap duplicate . duplicate++In this case you may not rely on the ability to define 'fmap' in+terms of 'liftW'.++You may of course, choose to define both 'duplicate' /and/ 'extend'.+In that case you must also satisfy these laws:++ extend f = fmap f . duplicate+ duplicate = extend id+ fmap f = extend (f . extract)++These are the default definitions of 'extend' and'duplicate' and+the definition of 'liftW' respectively.++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett
Setup.lhs view
@@ -1,7 +1,55 @@ #!/usr/bin/runhaskell-> module Main (main) where+\begin{code}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where -> import Distribution.Simple+import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Text ( display )+import Distribution.Verbosity ( Verbosity, normal )+import System.FilePath ( (</>) ) -> main :: IO ()-> main = defaultMain+main :: IO ()+main = defaultMainWithHooks simpleUserHooks+ { buildHook = \pkg lbi hooks flags -> do+ generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+ buildHook simpleUserHooks pkg lbi hooks flags+ , postHaddock = \args flags pkg lbi -> do+ copyFiles normal (haddockOutputDir flags pkg) []+ postHaddock simpleUserHooks args flags pkg lbi+ }++haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath+haddockOutputDir flags pkg = destDir where+ baseDir = case haddockDistPref flags of+ NoFlag -> "."+ Flag x -> x+ destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+ let dir = autogenModulesDir lbi+ createDirectoryIfMissingVerbose verbosity True dir+ withLibLBI pkg lbi $ \_ libcfg -> do+ withTestLBI pkg lbi $ \suite suitecfg -> do+ rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+ [ "module Build_" ++ testName suite ++ " where"+ , "deps :: [String]"+ , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+ ]+ where+ formatdeps = map (formatone . snd)+ formatone p = case packageName p of+ PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++\end{code}
comonad.cabal view
@@ -1,35 +1,67 @@ name: comonad category: Control, Comonads-version: 3.0.1.1+version: 3.0.2 license: BSD3-cabal-version: >= 1.6+cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com> stability: provisional homepage: http://github.com/ekmett/comonad/ bug-reports: http://github.com/ekmett/comonad/issues-copyright: Copyright (C) 2008-2012 Edward A. Kmett,+copyright: Copyright (C) 2008-2013 Edward A. Kmett, Copyright (C) 2004-2008 Dave Menendez synopsis: Haskell 98 compatible comonads description: Haskell 98 compatible comonads-build-type: Simple-extra-source-files: .travis.yml+build-type: Custom+extra-source-files:+ .gitignore+ .travis.yml+ README.markdown+ CHANGELOG.markdown+ examples/History.hs +-- You can disable the doctests test suite with -f-test-doctests+flag test-doctests+ default: True+ manual: True+ source-repository head type: git location: git://github.com/ekmett/comonad.git library+ hs-source-dirs: src+ default-language: Haskell2010 other-extensions: CPP build-depends: base >= 4 && < 5, transformers >= 0.2 && < 0.4, containers >= 0.3 && < 0.6,- semigroups >= 0.8.3+ semigroups >= 0.8.3 && < 1 exposed-modules: Control.Comonad ghc-options: -Wall++test-suite doctests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ main-is: doctests.hs+ ghc-options: -Wall -threaded+ hs-source-dirs: tests++ if !flag(test-doctests)+ buildable: False+ else+ build-depends:+ base,+ directory >= 1.0,+ doctest >= 0.9.1,+ filepath++ if impl(ghc<7.6.1)+ ghc-options: -Werror+
+ examples/History.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# OPTIONS_GHC -Wall #-}++-- http://www.mail-archive.com/haskell@haskell.org/msg17244.html++import Prelude hiding (id,(.),sum)+import Control.Category+import Control.Comonad+import Data.Foldable hiding (sum)+import Data.Traversable++infixl 4 :>++data History a = First a | History a :> a+ deriving (Functor, Foldable, Traversable, Show)++runHistory :: (History a -> b) -> [a] -> [b]+runHistory _ [] = []+runHistory f (a0:as0) = run (First a0) as0+ where+ run az [] = [f az]+ run az (a:as) = f az : run (az :> a) as++instance Comonad History where+ extend f w@First{} = First (f w)+ extend f w@(as :> _) = extend f as :> f w+ extract (First a) = a+ extract (_ :> a) = a++instance ComonadApply History where+ First f <@> First a = First (f a)+ (_ :> f) <@> First a = First (f a)+ First f <@> (_ :> a) = First (f a)+ (fs :> f) <@> (as :> a) = (fs <@> as) :> f a++fby :: a -> History a -> a+a `fby` First _ = a+_ `fby` (First b :> _) = b+_ `fby` ((_ :> b) :> _) = b++pos :: History a -> Int+pos dx = wfix $ dx $> fby 0 . fmap (+1)++sum :: Num a => History a -> a+sum dx = extract dx + (0 `fby` extend sum dx)++diff :: Num a => History a -> a+diff dx = extract dx - fby 0 dx++ini :: History a -> a+ini dx = extract dx `fby` extend ini dx++fibo :: Num b => History a -> b+fibo d = wfix $ d $> fby 0 . extend (\dfibo -> extract dfibo + fby 1 dfibo) ++fibo' :: Num b => History a -> b+fibo' d = fst $ wfix $ d $> fby (0, 1) . fmap (\(x, x') -> (x',x+x'))++plus :: Num a => History a -> History a -> History a+plus = liftW2 (+)
+ src/Control/Comonad.hs view
@@ -0,0 +1,329 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 707+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}+#endif+ -----------------------------------------------------------------------------+-- |+-- Module : Control.Comonad+-- Copyright : (C) 2008-2012 Edward Kmett,+-- (C) 2004 Dave Menendez+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+----------------------------------------------------------------------------+module Control.Comonad (+ -- * Comonads+ Comonad(..)+ , liftW -- :: Comonad w => (a -> b) -> w a -> w b+ , wfix -- :: Comonad w => w (w a -> a) -> a+ , cfix -- :: Comonad w => (w a -> a) -> w a+ , (=>=)+ , (=<=)+ , (<<=)+ , (=>>)+ -- * Combining Comonads+ , ComonadApply(..)+ , (<@@>) -- :: ComonadApply w => w a -> w (a -> b) -> w b+ , liftW2 -- :: ComonadApply w => (a -> b -> c) -> w a -> w b -> w c+ , liftW3 -- :: ComonadApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d+ -- * Cokleisli Arrows+ , Cokleisli(..)+ -- * Functors+ , Functor(..)+ , (<$>) -- :: Functor f => (a -> b) -> f a -> f b+ , ($>) -- :: Functor f => f a -> b -> f b+ ) where++-- import _everything_+import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Monad (ap)+#if MIN_VERSION_base(4,7,0)+-- Control.Monad.Instances is empty+#else+import Control.Monad.Instances+#endif+import Control.Monad.Trans.Identity+import Data.Functor.Identity+import Data.List.NonEmpty hiding (map)+import Data.Semigroup hiding (Product)+import Data.Tree+import Prelude hiding (id, (.))+import Control.Monad.Fix+#if __GLASGOW_HASKELL__ >= 707+-- Data.Typeable is redundant+#else+import Data.Typeable+#endif++infixl 4 <@, @>, <@@>, <@>, $>+infixl 1 =>>+infixr 1 <<=, =<=, =>=++{- |++There are two ways to define a comonad:++I. Provide definitions for 'extract' and 'extend'+satisfying these laws:++> extend extract = id+> extract . extend f = f+> extend f . extend g = extend (f . extend g)++In this case, you may simply set 'fmap' = 'liftW'.++These laws are directly analogous to the laws for monads+and perhaps can be made clearer by viewing them as laws stating+that Cokleisli composition must be associative, and has extract for+a unit:++> f =>= extract = f+> extract =>= f = f+> (f =>= g) =>= h = f =>= (g =>= h)++II. Alternately, you may choose to provide definitions for 'fmap',+'extract', and 'duplicate' satisfying these laws:++> extract . duplicate = id+> fmap extract . duplicate = id+> duplicate . duplicate = fmap duplicate . duplicate++In this case you may not rely on the ability to define 'fmap' in+terms of 'liftW'.++You may of course, choose to define both 'duplicate' /and/ 'extend'.+In that case you must also satisfy these laws:++> extend f = fmap f . duplicate+> duplicate = extend id+> fmap f = extend (f . extract)++These are the default definitions of 'extend' and 'duplicate' and+the definition of 'liftW' respectively.++-}++class Functor w => Comonad w where+ -- |+ -- > extract . fmap f = f . extract+ extract :: w a -> a++ -- |+ -- > duplicate = extend id+ -- > fmap (fmap f) . duplicate = duplicate . fmap f+ duplicate :: w a -> w (w a)+ duplicate = extend id++ -- |+ -- > extend f = fmap f . duplicate+ extend :: (w a -> b) -> w a -> w b+ extend f = fmap f . duplicate+++instance Comonad ((,)e) where+ duplicate p = (fst p, p)+ {-# INLINE duplicate #-}+ extract = snd+ {-# INLINE extract #-}++instance Monoid m => Comonad ((->)m) where+ duplicate f m = f . mappend m+ {-# INLINE duplicate #-}+ extract f = f mempty+ {-# INLINE extract #-}++instance Comonad Identity where+ duplicate = Identity+ {-# INLINE duplicate #-}+ extract = runIdentity+ {-# INLINE extract #-}++instance Comonad w => Comonad (IdentityT w) where+ extend f (IdentityT m) = IdentityT (extend (f . IdentityT) m)+ extract = extract . runIdentityT+ {-# INLINE extract #-}++instance Comonad Tree where+ duplicate w@(Node _ as) = Node w (map duplicate as)+ extract (Node a _) = a+ {-# INLINE extract #-}++instance Comonad NonEmpty where+ extend f w@ ~(_ :| aas) = f w :| case aas of+ [] -> []+ (a:as) -> toList (extend f (a :| as))+ extract ~(a :| _) = a+ {-# INLINE extract #-}++-- | @ComonadApply@ is to @Comonad@ like @Applicative@ is to @Monad@.+--+-- Mathematically, it is a strong lax symmetric semi-monoidal comonad on the+-- category @Hask@ of Haskell types. That it to say that @w@ is a strong lax+-- symmetric semi-monoidal functor on Hask, where both extract and duplicate are+-- symmetric monoidal natural transformations.+--+-- Laws:+--+-- > (.) <$> u <@> v <@> w = u <@> (v <@> w)+-- > extract (p <@> q) = extract p (extract q)+-- > duplicate (p <@> q) = (<@>) <$> duplicate p <@> duplicate q+--+-- If our type is both a ComonadApply and Applicative we further require+--+-- > (<*>) = (<@>)+--+-- Finally, if you choose to define ('<@') and ('@>'), the results of your+-- definitions should match the following laws:+--+-- > a @> b = const id <$> a <@> b+-- > a <@ b = const <$> a <@> b++class Comonad w => ComonadApply w where+ (<@>) :: w (a -> b) -> w a -> w b++ (@>) :: w a -> w b -> w b+ a @> b = const id <$> a <@> b++ (<@) :: w a -> w b -> w a+ a <@ b = const <$> a <@> b++instance Semigroup m => ComonadApply ((,)m) where+ (m, f) <@> (n, a) = (m <> n, f a)+ (m, a) <@ (n, _) = (m <> n, a)+ (m, _) @> (n, b) = (m <> n, b)++instance ComonadApply NonEmpty where+ (<@>) = ap++instance Monoid m => ComonadApply ((->)m) where+ (<@>) = (<*>)+ (<@ ) = (<* )+ ( @>) = ( *>)++instance ComonadApply Identity where+ (<@>) = (<*>)+ (<@ ) = (<* )+ ( @>) = ( *>)++instance ComonadApply w => ComonadApply (IdentityT w) where+ IdentityT wa <@> IdentityT wb = IdentityT (wa <@> wb)++instance ComonadApply Tree where+ (<@>) = (<*>)+ (<@ ) = (<* )+ ( @>) = ( *>)++-- | A suitable default definition for 'fmap' for a 'Comonad'.+-- Promotes a function to a comonad.+--+-- > fmap f = liftW f = extend (f . extract)+liftW :: Comonad w => (a -> b) -> w a -> w b+liftW f = extend (f . extract)+{-# INLINE liftW #-}++-- | Comonadic fixed point à la Menendez+wfix :: Comonad w => w (w a -> a) -> a+wfix w = extract w (extend wfix w)++-- | Comonadic fixed point à la Orchard+cfix :: Comonad w => (w a -> a) -> w a+cfix f = fix (extend f)+{-# INLINE cfix #-}++-- | 'extend' with the arguments swapped. Dual to '>>=' for a 'Monad'.+(=>>) :: Comonad w => w a -> (w a -> b) -> w b+(=>>) = flip extend+{-# INLINE (=>>) #-}++-- | 'extend' in operator form+(<<=) :: Comonad w => (w a -> b) -> w a -> w b+(<<=) = extend+{-# INLINE (<<=) #-}++-- | Right-to-left Cokleisli composition+(=<=) :: Comonad w => (w b -> c) -> (w a -> b) -> w a -> c+f =<= g = f . extend g+{-# INLINE (=<=) #-}++-- | Left-to-right Cokleisli composition+(=>=) :: Comonad w => (w a -> b) -> (w b -> c) -> w a -> c+f =>= g = g . extend f+{-# INLINE (=>=) #-}++-- | A variant of '<@>' with the arguments reversed.+(<@@>) :: ComonadApply w => w a -> w (a -> b) -> w b+(<@@>) = liftW2 (flip id)+{-# INLINE (<@@>) #-}++-- | Lift a binary function into a comonad with zipping+liftW2 :: ComonadApply w => (a -> b -> c) -> w a -> w b -> w c+liftW2 f a b = f <$> a <@> b+{-# INLINE liftW2 #-}++-- | Lift a ternary function into a comonad with zipping+liftW3 :: ComonadApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d+liftW3 f a b c = f <$> a <@> b <@> c+{-# INLINE liftW3 #-}++-- | The 'Cokleisli' 'Arrow's of a given 'Comonad'+newtype Cokleisli w a b = Cokleisli { runCokleisli :: w a -> b }++#if __GLASGOW_HASKELL__ >= 707+-- instance Typeable (Cokleisli w) derived automatically+#else+#ifdef __GLASGOW_HASKELL__+instance Typeable1 w => Typeable2 (Cokleisli w) where+ typeOf2 twab = mkTyConApp cokleisliTyCon [typeOf1 (wa twab)]+ where wa :: Cokleisli w a b -> w a+ wa = undefined+#endif++cokleisliTyCon :: TyCon+#if MIN_VERSION_base(4,4,0)+cokleisliTyCon = mkTyCon3 "comonad" "Control.Comonad" "Cokleisli"+#else+cokleisliTyCon = mkTyCon "Control.Comonad.Cokleisli"+#endif+{-# NOINLINE cokleisliTyCon #-}+#endif++instance Comonad w => Category (Cokleisli w) where+ id = Cokleisli extract+ Cokleisli f . Cokleisli g = Cokleisli (f =<= g)++instance Comonad w => Arrow (Cokleisli w) where+ arr f = Cokleisli (f . extract)+ first f = f *** id+ second f = id *** f+ Cokleisli f *** Cokleisli g = Cokleisli (f . fmap fst &&& g . fmap snd)+ Cokleisli f &&& Cokleisli g = Cokleisli (f &&& g)++instance Comonad w => ArrowApply (Cokleisli w) where+ app = Cokleisli $ \w -> runCokleisli (fst (extract w)) (snd <$> w)++instance Comonad w => ArrowChoice (Cokleisli w) where+ left = leftApp++instance ComonadApply w => ArrowLoop (Cokleisli w) where+ loop (Cokleisli f) = Cokleisli (fst . wfix . extend f') where+ f' wa wb = f ((,) <$> wa <@> (snd <$> wb))++instance Functor (Cokleisli w a) where+ fmap f (Cokleisli g) = Cokleisli (f . g)++instance Applicative (Cokleisli w a) where+ pure = Cokleisli . const+ Cokleisli f <*> Cokleisli a = Cokleisli (\w -> (f w) (a w))++instance Monad (Cokleisli w a) where+ return = Cokleisli . const+ Cokleisli k >>= f = Cokleisli $ \w -> runCokleisli (f (k w)) w++-- | Replace the contents of a functor uniformly with a constant value.+($>) :: Functor f => f a -> b -> f b+($>) = flip (<$)
+ tests/doctests.hsc view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module : Main (doctests)+-- Copyright : (C) 2012-13 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- This module provides doctests for a project based on the actual versions+-- of the packages it was built with. It requires a corresponding Setup.lhs+-- to be added to the project+-----------------------------------------------------------------------------+module Main where++import Build_doctests (deps)+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++##if defined(mingw32_HOST_OS)+##if defined(i386_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##elif defined(x86_64_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##endif+##endif++-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+##ifdef USE_CP+withUnicode m = do+ cp <- c_GetConsoleCP+ (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp+##else+withUnicode m = m+##endif++main :: IO ()+main = withUnicode $ getSources >>= \sources -> doctest $+ "-isrc"+ : "-idist/build/autogen"+ : "-optP-include"+ : "-optPdist/build/autogen/cabal_macros.h"+ : "-hide-all-packages"+ : "-Iincludes"+ : map ("-package="++) deps ++ sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+ where+ go dir = do+ (dirs, files) <- getFilesAndDirectories dir+ (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+ c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c