adjunctions-4.4.2/0000755000000000000000000000000007346545000012233 5ustar0000000000000000adjunctions-4.4.2/.gitignore0000644000000000000000000000043007346545000014220 0ustar0000000000000000dist dist-newstyle docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# .stack-work/ cabal-dev *.chi *.chs.h *.dyn_o *.dyn_hi .hpc .hsenv .cabal-sandbox/ cabal.sandbox.config *.prof *.aux *.hp *.eventlog cabal.project.local cabal.project.local~ .HTF/ .ghc.environment.* adjunctions-4.4.2/.vim.custom0000644000000000000000000000137707346545000014350 0ustar0000000000000000" Add the following to your .vimrc to automatically load this on startup " if filereadable(".vim.custom") " so .vim.custom " endif function StripTrailingWhitespace() let myline=line(".") let mycolumn = col(".") silent %s/ *$// call cursor(myline, mycolumn) endfunction " enable syntax highlighting syntax on " search for the tags file anywhere between here and / set tags=TAGS;/ " highlight tabs and trailing spaces set listchars=tab:‗‗,trail:‗ set list " f2 runs hasktags map :exec ":!hasktags -x -c --ignore src" " strip trailing whitespace before saving " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() " rebuild hasktags after saving au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" adjunctions-4.4.2/CHANGELOG.markdown0000644000000000000000000000464107346545000015273 0ustar00000000000000004.4.2 [2022.08.15] ------------------ * Fix the build with `mtl-2.3.1`. 4.4.1 [2022.05.07] ------------------ * Allow building with `transformers-0.6.*` and `mtl-2.3.*`. 4.4 [2018.01.28] ---------------- * Added `imapRep`, `ifoldMapRep`, `itraverseRep` to make it easier to define representable `FunctorWithIndex`, `FoldableWithIndex`, `TraversableWithIndex` instances from the `lens` package. * Add `GHC.Generics`-based default implementation for `Data.Functor.Rep.Representable` instances * Add `Data.Functor.Rep.Representable` instances for `Backwards`, `Reverse`, and the datatypes in `GHC.Generics`. * Add `Data.Functor.Adjunction.Adjunction` instances for some datatypes in `GHC.Generics` * Add `Data.Functor.Contravariant.Rep.Representable` instances for `U1` and `(:*:)` from `GHC.Generics` * Add `collectRep` and `imapRep` functions to `Data.Functor.Rep`. * Add `MINIMAL` pragmas to the `Adjunction` classes. * Allow `free-5`. 4.3 --- * Removed a spurious superclass constraint for `Applicative (StoreT g w)` * GHC 8 support * `comonad` 5 support 4.2.2 ----- * Builds clean on GHC 7.10 4.2.1 ----- * `semigroupoids` 5 support. * `profunctors` 5 support. 4.2 --- * `contravariant` 1.0 support. `Day` convolution moves to `kan-extensions`. 4.0.3 ----- * Silenced `Control.Monad.Instances` deprecation warnings on GHC 7.8 4.0.2 ----- * Added `mfixRep` to make it easier to define representable `MonadFix` instances. * Added `mzipRep` and `mzipWithRep` to make it easier to define representable `MonadZip` instances. * Added `duplicateRepBy`, `extendRepBy` and `extractRepBy` to make it easier to pick your own `Monoid`. * Minor documentation fixes. 4.0.1 ----- * Increased lower bound on `contravariant` to match the actual requirement. 4.0 --- * Merged the contents of `representable-functors`. * Removed the dependency on `keys`. * Moved `Data.Functor.Contravariant.Representable` to `Data.Functor.Contravariant.Rep` and made the API mimic `Data.Profunctor.Rep`. * Moved `Data.Functor.Representable` to `Data.Functor.Rep` and made the API mimic `Data.Profunctor.Rep`. * Added `Tagged` and `Proxy` instances for `Data.Functor.Rep.Representable` * Added a `Proxy` instance for `Data.Functor.Contravariant.Rep.Representable` 3.2.1.1 ------- * Updated the `array` dependency 3.2.1 ----- * Marked modules appropriately `Trustworthy`. 3.2 --- * Updated to `representable-functors` 3.1, which changed the API for contravariant representable functors. adjunctions-4.4.2/HLint.hs0000644000000000000000000000012707346545000013605 0ustar0000000000000000import "hint" HLint.Default ignore "Warning: Avoid lambda" ignore "Warning: Use &&&" adjunctions-4.4.2/LICENSE0000644000000000000000000000236407346545000013245 0ustar0000000000000000Copyright 2011-2014 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. adjunctions-4.4.2/README.markdown0000644000000000000000000000104207346545000014731 0ustar0000000000000000adjunctions ========== [![Hackage](https://img.shields.io/hackage/v/adjunctions.svg)](https://hackage.haskell.org/package/adjunctions) [![Build Status](https://github.com/ekmett/adjunctions/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/adjunctions/actions?query=workflow%3AHaskell-CI) This package provides adjunctions for Haskell. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett adjunctions-4.4.2/Setup.lhs0000644000000000000000000000016507346545000014045 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain adjunctions-4.4.2/adjunctions.cabal0000644000000000000000000000626207346545000015546 0ustar0000000000000000name: adjunctions category: Data Structures, Adjunctions version: 4.4.2 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/adjunctions/ bug-reports: http://github.com/ekmett/adjunctions/issues copyright: Copyright (C) 2011-2014 Edward A. Kmett synopsis: Adjunctions and representable functors description: Adjunctions and representable functors. build-type: Simple extra-source-files: .gitignore .vim.custom HLint.hs CHANGELOG.markdown README.markdown tested-with: GHC == 7.4.2 , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.2 source-repository head type: git location: git://github.com/ekmett/adjunctions.git library hs-source-dirs: src other-extensions: CPP FunctionalDependencies FlexibleContexts MultiParamTypeClasses Rank2Types UndecidableInstances build-depends: array >= 0.3.0.2 && < 0.7, base >= 4 && < 5, comonad >= 4 && < 6, containers >= 0.3 && < 0.7, contravariant >= 1 && < 2, distributive >= 0.5.1 && < 1, free >= 4 && < 6, mtl >= 2.0.1 && < 2.4, profunctors >= 4 && < 6, tagged >= 0.7 && < 1, semigroupoids >= 4 && < 6, semigroups >= 0.11 && < 1, transformers >= 0.2 && < 0.7, transformers-compat >= 0.3 && < 1, void >= 0.5.5.1 && < 1 if impl(ghc < 7.6) build-depends: ghc-prim exposed-modules: Control.Comonad.Representable.Store Control.Comonad.Trans.Adjoint Control.Monad.Representable.Reader Control.Monad.Representable.State Control.Monad.Trans.Adjoint Control.Monad.Trans.Contravariant.Adjoint Control.Monad.Trans.Conts Data.Functor.Adjunction Data.Functor.Contravariant.Adjunction Data.Functor.Contravariant.Rep Data.Functor.Rep ghc-options: -Wall default-language: Haskell2010 if impl(ghc >= 8.0) -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0 ghc-options: -Wcompat -Wnoncanonical-monad-instances ghc-options: -Wno-trustworthy-safe -Wno-inline-rule-shadowing if !impl(ghc >= 8.8) ghc-options: -Wnoncanonical-monadfail-instances if impl(ghc >= 8.6) ghc-options: -Wno-star-is-type test-suite spec type: exitcode-stdio-1.0 hs-source-dirs: tests build-tool-depends: hspec-discover:hspec-discover >=2 && <3 build-depends: adjunctions, base >= 4 && < 5, distributive >= 0.5.1 && < 1, generic-deriving >= 1.11 && < 2, hspec >= 2 && < 3 main-is: Spec.hs other-modules: GenericsSpec ghc-options: -Wall -threaded -rtsopts default-language: Haskell2010 adjunctions-4.4.2/src/Control/Comonad/Representable/0000755000000000000000000000000007346545000020615 5ustar0000000000000000adjunctions-4.4.2/src/Control/Comonad/Representable/Store.hs0000644000000000000000000001067207346545000022253 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} ---------------------------------------------------------------------- -- | -- Module : Control.Comonad.Representable.Store -- Copyright : (c) Edward Kmett & Sjoerd Visscher 2011 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- -- This is a generalized 'Store' 'Comonad', parameterized by a 'Representable' 'Functor'. -- The representation of that 'Functor' serves as the index of the store. -- -- This can be useful if the representable functor serves to memoize its -- contents and will be inspected often. ---------------------------------------------------------------------- module Control.Comonad.Representable.Store ( Store , store , runStore , StoreT(..) , storeT , runStoreT , ComonadStore(..) ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Comonad import Control.Comonad.Cofree.Class import Control.Comonad.Env.Class import Control.Comonad.Hoist.Class import Control.Comonad.Store.Class import Control.Comonad.Traced.Class import Control.Comonad.Trans.Class import Control.Monad.Identity import Data.Functor.Apply import Data.Functor.Extend import Data.Functor.Rep #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif -- | A memoized store comonad parameterized by a representable functor @g@, where -- the representatation of @g@, @Rep g@ is the index of the store. -- type Store g = StoreT g Identity -- | Construct a store comonad computation from a function and a current index. -- (The inverse of 'runStore'.) store :: Representable g => (Rep g -> a) -- ^ computation -> Rep g -- ^ index -> Store g a store = storeT . Identity -- | Unwrap a store comonad computation as a function and a current index. -- (The inverse of 'store'.) runStore :: Representable g => Store g a -- ^ a store to access -> (Rep g -> a, Rep g) -- ^ initial state runStore (StoreT (Identity ga) k) = (index ga, k) -- --------------------------------------------------------------------------- -- | A store transformer comonad parameterized by: -- -- * @g@ - A representable functor used to memoize results for an index @Rep g@ -- -- * @w@ - The inner comonad. data StoreT g w a = StoreT (w (g a)) (Rep g) storeT :: (Functor w, Representable g) => w (Rep g -> a) -> Rep g -> StoreT g w a storeT = StoreT . fmap tabulate runStoreT :: (Functor w, Representable g) => StoreT g w a -> (w (Rep g -> a), Rep g) runStoreT (StoreT w s) = (index <$> w, s) instance (Comonad w, Representable g, Rep g ~ s) => ComonadStore s (StoreT g w) where pos (StoreT _ s) = s peek s (StoreT w _) = extract w `index` s peeks f (StoreT w s) = extract w `index` f s seek s (StoreT w _) = StoreT w s seeks f (StoreT w s) = StoreT w (f s) instance (Functor w, Functor g) => Functor (StoreT g w) where fmap f (StoreT w s) = StoreT (fmap (fmap f) w) s instance (Apply w, Semigroup (Rep g), Representable g) => Apply (StoreT g w) where StoreT ff m <.> StoreT fa n = StoreT (apRep <$> ff <.> fa) (m <> n) instance (ComonadApply w, Semigroup (Rep g), Representable g) => ComonadApply (StoreT g w) where StoreT ff m <@> StoreT fa n = StoreT (apRep <$> ff <@> fa) (m <> n) instance (Applicative w, Monoid (Rep g), Representable g) => Applicative (StoreT g w) where pure a = StoreT (pure (pureRep a)) mempty StoreT ff m <*> StoreT fa n = StoreT (apRep <$> ff <*> fa) (m `mappend` n) instance (Extend w, Representable g) => Extend (StoreT g w) where duplicated (StoreT wf s) = StoreT (extended (tabulate . StoreT) wf) s instance (Comonad w, Representable g) => Comonad (StoreT g w) where duplicate (StoreT wf s) = StoreT (extend (tabulate . StoreT) wf) s extract (StoreT wf s) = index (extract wf) s instance Representable g => ComonadTrans (StoreT g) where lower (StoreT w s) = fmap (`index` s) w instance ComonadHoist (StoreT g) where cohoist f (StoreT w s) = StoreT (f w) s instance (ComonadTraced m w, Representable g) => ComonadTraced m (StoreT g w) where trace m = trace m . lower instance (ComonadEnv m w, Representable g) => ComonadEnv m (StoreT g w) where ask = ask . lower instance (Representable g, ComonadCofree f w) => ComonadCofree f (StoreT g w) where unwrap (StoreT w s) = fmap (`StoreT` s) (unwrap w) adjunctions-4.4.2/src/Control/Comonad/Trans/0000755000000000000000000000000007346545000017111 5ustar0000000000000000adjunctions-4.4.2/src/Control/Comonad/Trans/Adjoint.hs0000644000000000000000000000371507346545000021043 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MPTCs, fundeps -- ---------------------------------------------------------------------------- module Control.Comonad.Trans.Adjoint ( Adjoint , runAdjoint , adjoint , AdjointT(..) ) where import Prelude hiding (sequence) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Comonad import Control.Comonad.Trans.Class import Data.Functor.Adjunction import Data.Functor.Extend import Data.Functor.Identity import Data.Distributive type Adjoint f g = AdjointT f g Identity newtype AdjointT f g w a = AdjointT { runAdjointT :: f (w (g a)) } adjoint :: Functor f => f (g a) -> Adjoint f g a adjoint = AdjointT . fmap Identity runAdjoint :: Functor f => Adjoint f g a -> f (g a) runAdjoint = fmap runIdentity . runAdjointT instance (Adjunction f g, Functor w) => Functor (AdjointT f g w) where fmap f (AdjointT g) = AdjointT $ fmap (fmap (fmap f)) g b <$ (AdjointT g) = AdjointT $ fmap (fmap (b <$)) g instance (Adjunction f g, Extend w) => Extend (AdjointT f g w) where extended f (AdjointT m) = AdjointT $ fmap (extended $ leftAdjunct (f . AdjointT)) m instance (Adjunction f g, Comonad w) => Comonad (AdjointT f g w) where extend f (AdjointT m) = AdjointT $ fmap (extend $ leftAdjunct (f . AdjointT)) m extract = rightAdjunct extract . runAdjointT {- instance (Adjunction f g, Monad m) => Applicative (AdjointT f g m) where pure = AdjointT . leftAdjunct return (<*>) = ap -} instance (Adjunction f g, Distributive g) => ComonadTrans (AdjointT f g) where lower = counit . fmap distribute . runAdjointT adjunctions-4.4.2/src/Control/Monad/Representable/0000755000000000000000000000000007346545000020273 5ustar0000000000000000adjunctions-4.4.2/src/Control/Monad/Representable/Reader.hs0000644000000000000000000001135407346545000022035 0ustar0000000000000000{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, TypeSynonymInstances #-} {-# OPTIONS_GHC -fenable-rewrite-rules -fno-warn-orphans #-} ---------------------------------------------------------------------- -- | -- Module : Control.Monad.Representable.Reader -- Copyright : (c) Edward Kmett 2011, -- (c) Conal Elliott 2008 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- -- Representable functors on Hask are all monads, because they are isomorphic to -- a 'Reader' monad. ---------------------------------------------------------------------- module Control.Monad.Representable.Reader ( -- * Representable functor monad Reader , runReader -- * Monad Transformer , ReaderT(..), readerT, runReaderT , MonadReader(..) , module Data.Functor.Rep ) where import Control.Applicative import Control.Comonad import Control.Monad.Reader.Class import Control.Monad.Writer.Class as Writer import Control.Monad.Trans.Class import Control.Monad.IO.Class import Data.Distributive import Data.Functor.Bind import Data.Functor.Extend import Data.Functor.Identity import Data.Functor.Rep import Data.Foldable import Data.Traversable import Data.Semigroup import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Prelude hiding (lookup,zipWith) type Reader f = ReaderT f Identity runReader :: Representable f => Reader f b -> Rep f -> b runReader = fmap runIdentity . runReaderT -- * This 'representable monad transformer' transforms any monad @m@ with a 'Representable' 'Monad'. -- This monad in turn is also representable if @m@ is 'Representable'. newtype ReaderT f m b = ReaderT { getReaderT :: f (m b) } readerT :: Representable f => (Rep f -> m b) -> ReaderT f m b readerT = ReaderT . tabulate runReaderT :: Representable f => ReaderT f m b -> Rep f -> m b runReaderT = index . getReaderT instance (Functor f, Functor m) => Functor (ReaderT f m) where fmap f = ReaderT . fmap (fmap f) . getReaderT instance (Representable f, Representable m) => Representable (ReaderT f m) where type Rep (ReaderT f m) = (Rep f, Rep m) tabulate = ReaderT . tabulate . fmap tabulate . curry index = uncurry . fmap index . index . getReaderT instance (Representable f, Apply m) => Apply (ReaderT f m) where ReaderT ff <.> ReaderT fa = ReaderT (unCo ((<.>) <$> Co ff <.> Co fa)) instance (Representable f, Applicative m) => Applicative (ReaderT f m) where pure = ReaderT . pureRep . pure ReaderT ff <*> ReaderT fa = ReaderT (unCo ((<*>) <$> Co ff <*> Co fa)) instance (Representable f, Bind m) => Bind (ReaderT f m) where ReaderT fm >>- f = ReaderT $ tabulate (\a -> index fm a >>- flip index a . getReaderT . f) instance (Representable f, Monad m) => Monad (ReaderT f m) where #if __GLASGOW_HASKELL__ < 710 return = ReaderT . pureRep . return #endif ReaderT fm >>= f = ReaderT $ tabulate (\a -> index fm a >>= flip index a . getReaderT . f) #if __GLASGOW_HASKELL >= 704 instance (Representable f, Monad m, Rep f ~ e) => MonadReader e (ReaderT f m) where ask = ReaderT (tabulate return) local f m = readerT $ \r -> runReaderT m (f r) #if MIN_VERSION_transformers(0,3,0) reader = readerT . fmap return #endif #endif instance Representable f => MonadTrans (ReaderT f) where lift = ReaderT . pureRep instance (Representable f, Distributive m) => Distributive (ReaderT f m) where distribute = ReaderT . fmapRep distribute . unCo . collect (Co . getReaderT) instance (Representable f, Representable m, Semigroup (Rep f), Semigroup (Rep m)) => Extend (ReaderT f m) where extended = extendedRep duplicated = duplicatedRep instance (Representable f, Representable m, Monoid (Rep f), Monoid (Rep m)) => Comonad (ReaderT f m) where extend = extendRep duplicate = duplicateRep extract = extractRep instance (Representable f, MonadIO m) => MonadIO (ReaderT f m) where liftIO = lift . liftIO instance (Representable f, MonadWriter w m) => MonadWriter w (ReaderT f m) where tell = lift . tell listen (ReaderT m) = ReaderT $ tabulate $ Writer.listen . index m pass (ReaderT m) = ReaderT $ tabulate $ Writer.pass . index m -- misc. instances that can exist, but aren't particularly about representability instance (Foldable f, Foldable m) => Foldable (ReaderT f m) where foldMap f = foldMap (foldMap f) . getReaderT instance (Foldable1 f, Foldable1 m) => Foldable1 (ReaderT f m) where foldMap1 f = foldMap1 (foldMap1 f) . getReaderT instance (Traversable f, Traversable m) => Traversable (ReaderT f m) where traverse f = fmap ReaderT . traverse (traverse f) . getReaderT instance (Traversable1 f, Traversable1 m) => Traversable1 (ReaderT f m) where traverse1 f = fmap ReaderT . traverse1 (traverse1 f) . getReaderT adjunctions-4.4.2/src/Control/Monad/Representable/State.hs0000644000000000000000000001670007346545000021713 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} ---------------------------------------------------------------------- -- | -- Module : Control.Monad.Representable.State -- Copyright : (c) Edward Kmett & Sjoerd Visscher 2011 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- -- A generalized State monad, parameterized by a Representable functor. -- The representation of that functor serves as the state. ---------------------------------------------------------------------- module Control.Monad.Representable.State ( State , runState , evalState , execState , mapState , StateT(..) , stateT , runStateT , evalStateT , execStateT , mapStateT , liftCallCC , liftCallCC' , MonadState(..) ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Monad import Data.Functor.Bind import Data.Functor.Bind.Trans import Control.Monad.State.Class import Control.Monad.Cont.Class (MonadCont(..)) import Control.Monad.Reader.Class import Control.Monad.Writer.Class import Control.Monad.Free.Class import Control.Monad.Trans.Class import Data.Functor.Identity import Data.Functor.Rep -- --------------------------------------------------------------------------- -- | A memoized state monad parameterized by a representable functor @g@, where -- the representatation of @g@, @Rep g@ is the state to carry. -- -- The 'return' function leaves the state unchanged, while @>>=@ uses -- the final state of the first computation as the initial state of -- the second. type State g = StateT g Identity -- | Unwrap a state monad computation as a function. -- (The inverse of 'state'.) runState :: Representable g => State g a -- ^ state-passing computation to execute -> Rep g -- ^ initial state -> (a, Rep g) -- ^ return value and final state runState m = runIdentity . runStateT m -- | Evaluate a state computation with the given initial state -- and return the final value, discarding the final state. -- -- * @'evalState' m s = 'fst' ('runState' m s)@ evalState :: Representable g => State g a -- ^state-passing computation to execute -> Rep g -- ^initial value -> a -- ^return value of the state computation evalState m s = fst (runState m s) -- | Evaluate a state computation with the given initial state -- and return the final state, discarding the final value. -- -- * @'execState' m s = 'snd' ('runState' m s)@ execState :: Representable g => State g a -- ^state-passing computation to execute -> Rep g -- ^initial value -> Rep g -- ^final state execState m s = snd (runState m s) -- | Map both the return value and final state of a computation using -- the given function. -- -- * @'runState' ('mapState' f m) = f . 'runState' m@ mapState :: Functor g => ((a, Rep g) -> (b, Rep g)) -> State g a -> State g b mapState f = mapStateT (Identity . f . runIdentity) -- --------------------------------------------------------------------------- -- | A state transformer monad parameterized by: -- -- * @g@ - A representable functor used to memoize results for a state @Rep g@ -- -- * @m@ - The inner monad. -- -- The 'return' function leaves the state unchanged, while @>>=@ uses -- the final state of the first computation as the initial state of -- the second. newtype StateT g m a = StateT { getStateT :: g (m (a, Rep g)) } stateT :: Representable g => (Rep g -> m (a, Rep g)) -> StateT g m a stateT = StateT . tabulate runStateT :: Representable g => StateT g m a -> Rep g -> m (a, Rep g) runStateT (StateT m) = index m mapStateT :: Functor g => (m (a, Rep g) -> n (b, Rep g)) -> StateT g m a -> StateT g n b mapStateT f (StateT m) = StateT (fmap f m) -- | Evaluate a state computation with the given initial state -- and return the final value, discarding the final state. -- -- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@ evalStateT :: (Representable g, Monad m) => StateT g m a -> Rep g -> m a evalStateT m s = do (a, _) <- runStateT m s return a -- | Evaluate a state computation with the given initial state -- and return the final state, discarding the final value. -- -- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@ execStateT :: (Representable g, Monad m) => StateT g m a -> Rep g -> m (Rep g) execStateT m s = do (_, s') <- runStateT m s return s' instance (Functor g, Functor m) => Functor (StateT g m) where fmap f = StateT . fmap (fmap (\ ~(a, s) -> (f a, s))) . getStateT instance (Representable g, Bind m) => Apply (StateT g m) where mf <.> ma = mf >>- \f -> fmap f ma instance (Representable g, Functor m, Monad m) => Applicative (StateT g m) where pure = StateT . leftAdjunctRep return mf <*> ma = mf >>= \f -> fmap f ma instance (Representable g, Bind m) => Bind (StateT g m) where StateT m >>- f = StateT $ fmap (>>- rightAdjunctRep (runStateT . f)) m instance (Representable g, Monad m) => Monad (StateT g m) where #if __GLASGOW_HASKELL__ < 710 return = StateT . leftAdjunctRep return #endif StateT m >>= f = StateT $ fmap (>>= rightAdjunctRep (runStateT . f)) m instance Representable f => BindTrans (StateT f) where liftB m = stateT $ \s -> fmap (\a -> (a, s)) m instance Representable f => MonadTrans (StateT f) where lift m = stateT $ \s -> liftM (\a -> (a, s)) m instance (Representable g, Monad m, Rep g ~ s) => MonadState s (StateT g m) where get = stateT $ \s -> return (s, s) put s = StateT $ pureRep $ return ((),s) #if MIN_VERSION_transformers(0,3,0) state f = stateT (return . f) #endif instance (Representable g, MonadReader e m) => MonadReader e (StateT g m) where ask = lift ask local = mapStateT . local instance (Representable g, MonadWriter w m) => MonadWriter w (StateT g m) where tell = lift . tell listen = mapStateT $ \ma -> do ((a,s'), w) <- listen ma return ((a,w), s') pass = mapStateT $ \ma -> pass $ do ((a, f), s') <- ma return ((a, s'), f) instance (Representable g, MonadCont m) => MonadCont (StateT g m) where callCC = liftCallCC' callCC instance (Functor f, Representable g, MonadFree f m) => MonadFree f (StateT g m) where wrap as = stateT $ \s -> wrap (fmap (`runStateT` s) as) leftAdjunctRep :: Representable u => ((a, Rep u) -> b) -> a -> u b leftAdjunctRep f a = tabulate (\s -> f (a,s)) rightAdjunctRep :: Representable u => (a -> u b) -> (a, Rep u) -> b rightAdjunctRep f ~(a, k) = f a `index` k -- | Uniform lifting of a @callCC@ operation to the new monad. -- This version rolls back to the original state on entering the -- continuation. liftCallCC :: Representable g => ((((a,Rep g) -> m (b,Rep g)) -> m (a,Rep g)) -> m (a,Rep g)) -> ((a -> StateT g m b) -> StateT g m a) -> StateT g m a liftCallCC callCC' f = stateT $ \s -> callCC' $ \c -> runStateT (f (\a -> StateT $ pureRep $ c (a, s))) s -- | In-situ lifting of a @callCC@ operation to the new monad. -- This version uses the current state on entering the continuation. -- It does not satisfy the laws of a monad transformer. liftCallCC' :: Representable g => ((((a,Rep g) -> m (b,Rep g)) -> m (a,Rep g)) -> m (a,Rep g)) -> ((a -> StateT g m b) -> StateT g m a) -> StateT g m a liftCallCC' callCC' f = stateT $ \s -> callCC' $ \c -> runStateT (f (\a -> stateT $ \s' -> c (a, s'))) s adjunctions-4.4.2/src/Control/Monad/Trans/0000755000000000000000000000000007346545000016567 5ustar0000000000000000adjunctions-4.4.2/src/Control/Monad/Trans/Adjoint.hs0000644000000000000000000000351507346545000020517 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MPTCs, fundeps -- ---------------------------------------------------------------------------- module Control.Monad.Trans.Adjoint ( Adjoint , runAdjoint , adjoint , AdjointT(..) ) where import Prelude hiding (sequence) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Monad (ap, liftM) import Control.Monad.Trans.Class import Data.Traversable import Data.Functor.Adjunction import Data.Functor.Identity type Adjoint f g = AdjointT f g Identity newtype AdjointT f g m a = AdjointT { runAdjointT :: g (m (f a)) } adjoint :: Functor g => g (f a) -> Adjoint f g a adjoint = AdjointT . fmap Identity runAdjoint :: Functor g => Adjoint f g a -> g (f a) runAdjoint = fmap runIdentity . runAdjointT instance (Adjunction f g, Monad m) => Functor (AdjointT f g m) where fmap f (AdjointT g) = AdjointT $ fmap (liftM (fmap f)) g b <$ AdjointT g = AdjointT $ fmap (liftM (b <$)) g instance (Adjunction f g, Monad m) => Applicative (AdjointT f g m) where pure = AdjointT . leftAdjunct return (<*>) = ap instance (Adjunction f g, Monad m) => Monad (AdjointT f g m) where return = pure AdjointT m >>= f = AdjointT $ fmap (>>= rightAdjunct (runAdjointT . f)) m -- | Exploiting this instance requires that we have the missing Traversables for Identity, (,)e and IdentityT instance (Adjunction f g, Traversable f) => MonadTrans (AdjointT f g) where lift = AdjointT . fmap sequence . unit adjunctions-4.4.2/src/Control/Monad/Trans/Contravariant/0000755000000000000000000000000007346545000021402 5ustar0000000000000000adjunctions-4.4.2/src/Control/Monad/Trans/Contravariant/Adjoint.hs0000644000000000000000000000377307346545000023340 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.Contravariant.Adjoint -- Copyright : (C) 2011 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MPTCs, fundeps -- -- Uses a contravariant adjunction: -- -- f -| g : Hask^op -> Hask -- -- to build a 'Comonad' to 'Monad' transformer. Sadly, the dual construction, -- which builds a 'Comonad' out of a 'Monad', is uninhabited, because any -- 'Adjunction' of the form -- -- > f -| g : Hask -> Hask^op -- -- would trivially admit unsafePerformIO. -- ---------------------------------------------------------------------------- module Control.Monad.Trans.Contravariant.Adjoint ( Adjoint , runAdjoint , adjoint , AdjointT(..) ) where import Prelude hiding (sequence) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Comonad import Control.Monad (ap) import Data.Functor.Identity import Data.Functor.Contravariant import Data.Functor.Contravariant.Adjunction type Adjoint f g = AdjointT f g Identity newtype AdjointT f g w a = AdjointT { runAdjointT :: g (w (f a)) } adjoint :: Contravariant g => g (f a) -> Adjoint f g a adjoint = AdjointT . contramap runIdentity runAdjoint :: Contravariant g => Adjoint f g a -> g (f a) runAdjoint = contramap Identity . runAdjointT instance (Adjunction f g, Functor w) => Functor (AdjointT f g w) where fmap f (AdjointT g) = AdjointT $ contramap (fmap (contramap f)) g instance (Adjunction f g, Comonad w) => Applicative (AdjointT f g w) where pure = AdjointT . leftAdjunct extract (<*>) = ap instance (Adjunction f g, Comonad w) => Monad (AdjointT f g w) where return = pure AdjointT m >>= f = AdjointT $ contramap (extend (rightAdjunct (runAdjointT . f))) m adjunctions-4.4.2/src/Control/Monad/Trans/Conts.hs0000644000000000000000000000500107346545000020205 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MPTCs, fundeps -- -- > Cont r ~ Contravariant.Adjoint (Op r) (Op r) -- > Conts r ~ Contravariant.AdjointT (Op r) (Op r) -- > ContsT r w m ~ Contravariant.AdjointT (Op (m r)) (Op (m r)) w ---------------------------------------------------------------------------- module Control.Monad.Trans.Conts ( -- * Continuation passing style Cont , cont , runCont -- * Multiple-continuation passing style , Conts , runConts , conts -- * Multiple-continuation passing style transformer , ContsT(..) , callCC ) where import Prelude hiding (sequence) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Comonad import Control.Monad.Trans.Class import Control.Monad (ap) import Data.Functor.Apply import Data.Functor.Identity type Cont r = ContsT r Identity Identity cont :: ((a -> r) -> r) -> Cont r a cont f = ContsT $ \ (Identity k) -> Identity $ f $ runIdentity . k runCont :: Cont r a -> (a -> r) -> r runCont (ContsT k) f = runIdentity $ k $ Identity (Identity . f) type Conts r w = ContsT r w Identity conts :: Functor w => (w (a -> r) -> r) -> Conts r w a conts k = ContsT $ Identity . k . fmap (runIdentity .) runConts :: Functor w => Conts r w a -> w (a -> r) -> r runConts (ContsT k) = runIdentity . k . fmap (Identity .) newtype ContsT r w m a = ContsT { runContsT :: w (a -> m r) -> m r } instance Functor w => Functor (ContsT r w m) where fmap f (ContsT k) = ContsT $ k . fmap (. f) instance Comonad w => Apply (ContsT r w m) where (<.>) = ap instance Comonad w => Applicative (ContsT r w m) where pure x = ContsT $ \f -> extract f x (<*>) = ap instance Comonad w => Monad (ContsT r w m) where return = pure ContsT k >>= f = ContsT $ k . extend (\wa a -> runContsT (f a) wa) callCC :: Comonad w => ((a -> ContsT r w m b) -> ContsT r w m a) -> ContsT r w m a callCC f = ContsT $ \wamr -> runContsT (f (\a -> ContsT $ \_ -> extract wamr a)) wamr {- callCCs :: Comonad w => (w (a -> ContsT r w m b) -> ContsT r w m a) -> ContsT r w m a callCCs f = -} instance Comonad w => MonadTrans (ContsT r w) where lift m = ContsT $ extract . fmap (m >>=) adjunctions-4.4.2/src/Data/Functor/0000755000000000000000000000000007346545000015313 5ustar0000000000000000adjunctions-4.4.2/src/Data/Functor/Adjunction.hs0000644000000000000000000001717707346545000017762 0ustar0000000000000000{-# LANGUAGE Rank2Types , MultiParamTypeClasses , FunctionalDependencies , TypeOperators , UndecidableInstances #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE EmptyCase #-} #endif ------------------------------------------------------------------------------------------- -- | -- Copyright : 2008-2013 Edward Kmett -- License : BSD -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : rank 2 types, MPTCs, fundeps -- ------------------------------------------------------------------------------------------- module Data.Functor.Adjunction ( Adjunction(..) , adjuncted , tabulateAdjunction , indexAdjunction , zapWithAdjunction , zipR, unzipR , unabsurdL, absurdL , cozipL, uncozipL , extractL, duplicateL , splitL, unsplitL ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Arrow ((&&&), (|||)) import Control.Monad.Free #if __GLASGOW_HASKELL__ < 707 import Control.Monad.Instances () #endif import Control.Monad.Trans.Identity import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer import Control.Comonad import Control.Comonad.Cofree import Control.Comonad.Trans.Env import Control.Comonad.Trans.Traced import Data.Functor.Identity import Data.Functor.Compose import Data.Functor.Product import Data.Functor.Rep import Data.Functor.Sum import Data.Profunctor import Data.Void import GHC.Generics -- | An adjunction between Hask and Hask. -- -- Minimal definition: both 'unit' and 'counit' or both 'leftAdjunct' -- and 'rightAdjunct', subject to the constraints imposed by the -- default definitions that the following laws should hold. -- -- > unit = leftAdjunct id -- > counit = rightAdjunct id -- > leftAdjunct f = fmap f . unit -- > rightAdjunct f = counit . fmap f -- -- Any implementation is required to ensure that 'leftAdjunct' and -- 'rightAdjunct' witness an isomorphism from @Nat (f a, b)@ to -- @Nat (a, g b)@ -- -- > rightAdjunct unit = id -- > leftAdjunct counit = id class (Functor f, Representable u) => Adjunction f u | f -> u, u -> f where #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL (unit, counit) | (leftAdjunct, rightAdjunct) #-} #endif unit :: a -> u (f a) counit :: f (u a) -> a leftAdjunct :: (f a -> b) -> a -> u b rightAdjunct :: (a -> u b) -> f a -> b unit = leftAdjunct id counit = rightAdjunct id leftAdjunct f = fmap f . unit rightAdjunct f = counit . fmap f -- | 'leftAdjunct' and 'rightAdjunct' form two halves of an isomorphism. -- -- This can be used with the combinators from the @lens@ package. -- -- @'adjuncted' :: 'Adjunction' f u => 'Iso'' (f a -> b) (a -> u b)@ adjuncted :: (Adjunction f u, Profunctor p, Functor g) => p (a -> u b) (g (c -> u d)) -> p (f a -> b) (g (f c -> d)) adjuncted = dimap leftAdjunct (fmap rightAdjunct) {-# INLINE adjuncted #-} -- | Every right adjoint is representable by its left adjoint -- applied to a unit element -- -- Use this definition and the primitives in -- Data.Functor.Representable to meet the requirements of the -- superclasses of Representable. tabulateAdjunction :: Adjunction f u => (f () -> b) -> u b tabulateAdjunction f = leftAdjunct f () -- | This definition admits a default definition for the -- 'index' method of 'Index", one of the superclasses of -- Representable. indexAdjunction :: Adjunction f u => u b -> f a -> b indexAdjunction = rightAdjunct . const zapWithAdjunction :: Adjunction f u => (a -> b -> c) -> u a -> f b -> c zapWithAdjunction f ua = rightAdjunct (\b -> fmap (flip f b) ua) splitL :: Adjunction f u => f a -> (a, f ()) splitL = rightAdjunct (flip leftAdjunct () . (,)) unsplitL :: Functor f => a -> f () -> f a unsplitL = (<$) extractL :: Adjunction f u => f a -> a extractL = fst . splitL duplicateL :: Adjunction f u => f a -> f (f a) duplicateL as = as <$ as -- | A right adjoint functor admits an intrinsic -- notion of zipping zipR :: Adjunction f u => (u a, u b) -> u (a, b) zipR = leftAdjunct (rightAdjunct fst &&& rightAdjunct snd) -- | Every functor in Haskell permits unzipping unzipR :: Functor u => u (a, b) -> (u a, u b) unzipR = fmap fst &&& fmap snd absurdL :: Void -> f Void absurdL = absurd -- | A left adjoint must be inhabited, or we can derive bottom. unabsurdL :: Adjunction f u => f Void -> Void unabsurdL = rightAdjunct absurd -- | And a left adjoint must be inhabited by exactly one element cozipL :: Adjunction f u => f (Either a b) -> Either (f a) (f b) cozipL = rightAdjunct (leftAdjunct Left ||| leftAdjunct Right) -- | Every functor in Haskell permits 'uncozipping' uncozipL :: Functor f => Either (f a) (f b) -> f (Either a b) uncozipL = fmap Left ||| fmap Right -- Requires deprecated Impredicative types -- limitR :: Adjunction f u => (forall a. u a) -> u (forall a. a) -- limitR = leftAdjunct (rightAdjunct (\(x :: forall a. a) -> x)) instance Adjunction ((,) e) ((->) e) where leftAdjunct f a e = f (e, a) rightAdjunct f ~(e, a) = f a e instance Adjunction Identity Identity where leftAdjunct f = Identity . f . Identity rightAdjunct f = runIdentity . f . runIdentity instance Adjunction f g => Adjunction (IdentityT f) (IdentityT g) where unit = IdentityT . leftAdjunct IdentityT counit = rightAdjunct runIdentityT . runIdentityT instance Adjunction w m => Adjunction (EnvT e w) (ReaderT e m) where unit = ReaderT . flip fmap EnvT . flip leftAdjunct counit (EnvT e w) = rightAdjunct (flip runReaderT e) w instance Adjunction m w => Adjunction (WriterT s m) (TracedT s w) where unit = TracedT . leftAdjunct (\ma s -> WriterT (fmap (\a -> (a, s)) ma)) counit = rightAdjunct (\(t, s) -> ($ s) <$> runTracedT t) . runWriterT instance (Adjunction f g, Adjunction f' g') => Adjunction (Compose f' f) (Compose g g') where unit = Compose . leftAdjunct (leftAdjunct Compose) counit = rightAdjunct (rightAdjunct getCompose) . getCompose instance (Adjunction f g, Adjunction f' g') => Adjunction (Sum f f') (Product g g') where unit a = Pair (leftAdjunct InL a) (leftAdjunct InR a) counit (InL l) = rightAdjunct (\(Pair x _) -> x) l counit (InR r) = rightAdjunct (\(Pair _ x) -> x) r instance Adjunction f u => Adjunction (Free f) (Cofree u) where unit a = return a :< tabulateAdjunction (\k -> leftAdjunct (wrap . flip unsplitL k) a) counit (Pure a) = extract a counit (Free k) = rightAdjunct (flip indexAdjunction k . unwrap) (extractL k) instance Adjunction V1 U1 where unit _ = U1 counit = absurdV1 absurdV1 :: V1 a -> b #if __GLASGOW_HASKELL__ >= 708 absurdV1 x = case x of {} #else absurdV1 x = x `seq` undefined #endif instance Adjunction Par1 Par1 where leftAdjunct f = Par1 . f . Par1 rightAdjunct f = unPar1 . f . unPar1 instance Adjunction f g => Adjunction (Rec1 f) (Rec1 g) where unit = Rec1 . leftAdjunct Rec1 counit = rightAdjunct unRec1 . unRec1 -- @i@ and @c@ indexes have to be the same due functional dependency. -- But we want them to be different, therefore we rather not define this instance {- instance Adjunction f g => Adjunction (M1 i c f) (M1 i c g) where unit = M1 . leftAdjunct M1 counit = rightAdjunct unM1 . unM1 -} instance (Adjunction f g, Adjunction f' g') => Adjunction (f' :.: f) (g :.: g') where unit = Comp1 . leftAdjunct (leftAdjunct Comp1) counit = rightAdjunct (rightAdjunct unComp1) . unComp1 instance (Adjunction f g, Adjunction f' g') => Adjunction (f :+: f') (g :*: g') where unit a = leftAdjunct L1 a :*: leftAdjunct R1 a counit (L1 l) = rightAdjunct (\(x :*: _) -> x) l counit (R1 r) = rightAdjunct (\(_ :*: x) -> x) r adjunctions-4.4.2/src/Data/Functor/Contravariant/0000755000000000000000000000000007346545000020126 5ustar0000000000000000adjunctions-4.4.2/src/Data/Functor/Contravariant/Adjunction.hs0000644000000000000000000000515407346545000022565 0ustar0000000000000000{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-} {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MPTCs -- ---------------------------------------------------------------------------- module Data.Functor.Contravariant.Adjunction ( Adjunction(..) , adjuncted , contrarepAdjunction , coindexAdjunction ) where #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707 import Control.Monad.Instances () #endif import Data.Functor.Contravariant import Data.Functor.Contravariant.Rep import Data.Profunctor -- | An adjunction from @Hask^op@ to @Hask@ -- -- @'Op' (f a) b ~ 'Hask' a (g b)@ -- -- @ -- 'rightAdjunct' 'unit' = 'id' -- 'leftAdjunct' 'counit' = 'id' -- @ -- -- Any adjunction from @Hask@ to @Hask^op@ would indirectly -- permit @unsafePerformIO@, and therefore does not exist. class (Contravariant f, Representable g) => Adjunction f g | f -> g, g -> f where #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL (unit, counit) | (leftAdjunct, rightAdjunct) #-} #endif unit :: a -> g (f a) -- monad in Hask counit :: a -> f (g a) -- comonad in Hask^op leftAdjunct :: (b -> f a) -> a -> g b rightAdjunct :: (a -> g b) -> b -> f a unit = leftAdjunct id counit = rightAdjunct id leftAdjunct f = contramap f . unit rightAdjunct f = contramap f . counit -- | 'leftAdjunct' and 'rightAdjunct' form two halves of an isomorphism. -- -- This can be used with the combinators from the @lens@ package. -- -- @'adjuncted' :: 'Adjunction' f g => 'Iso'' (b -> f a) (a -> g b)@ adjuncted :: (Adjunction f g, Profunctor p, Functor h) => p (a -> g b) (h (c -> g d)) -> p (b -> f a) (h (d -> f c)) adjuncted = dimap leftAdjunct (fmap rightAdjunct) {-# INLINE adjuncted #-} -- | This 'Adjunction' gives rise to the @Cont@ 'Monad' instance Adjunction (Op r) (Op r) where unit a = Op (\k -> getOp k a) counit = unit -- | This gives rise to the @Cont Bool@ 'Monad' instance Adjunction Predicate Predicate where unit a = Predicate (\k -> getPredicate k a) counit = unit -- | Represent a 'Contravariant' functor that has a left adjoint contrarepAdjunction :: Adjunction f g => (a -> f ()) -> g a contrarepAdjunction = flip leftAdjunct () coindexAdjunction :: Adjunction f g => g a -> a -> f () coindexAdjunction = rightAdjunct . const adjunctions-4.4.2/src/Data/Functor/Contravariant/Rep.hs0000644000000000000000000000633707346545000021221 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fenable-rewrite-rules #-} ---------------------------------------------------------------------- -- | -- Copyright : (c) Edward Kmett 2011-2014 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- -- Representable contravariant endofunctors over the category of Haskell -- types are isomorphic to @(_ -> r)@ and resemble mappings to a -- fixed range. ---------------------------------------------------------------------- module Data.Functor.Contravariant.Rep ( -- * Representable Contravariant Functors Representable(..) , tabulated -- * Default definitions , contramapRep ) where import Data.Functor.Contravariant import Data.Functor.Product import Data.Profunctor import Data.Proxy import GHC.Generics hiding (Rep) import Prelude hiding (lookup) -- | A 'Contravariant' functor @f@ is 'Representable' if 'tabulate' and 'index' witness an isomorphism to @(_ -> Rep f)@. -- -- @ -- 'tabulate' . 'index' ≡ id -- 'index' . 'tabulate' ≡ id -- @ class Contravariant f => Representable f where type Rep f :: * -- | -- @ -- 'contramap' f ('tabulate' g) = 'tabulate' (g . f) -- @ tabulate :: (a -> Rep f) -> f a index :: f a -> a -> Rep f -- | -- @ -- 'contramapWithRep' f p ≡ 'tabulate' $ 'either' ('index' p) 'id' . f -- @ contramapWithRep :: (b -> Either a (Rep f)) -> f a -> f b contramapWithRep f p = tabulate $ either (index p) id . f {-# RULES "tabulate/index" forall t. tabulate (index t) = t #-} -- | 'tabulate' and 'index' form two halves of an isomorphism. -- -- This can be used with the combinators from the @lens@ package. -- -- @'tabulated' :: 'Representable' f => 'Iso'' (a -> 'Rep' f) (f a)@ tabulated :: (Representable f, Representable g, Profunctor p, Functor h) => p (f a) (h (g b)) -> p (a -> Rep f) (h (b -> Rep g)) tabulated = dimap tabulate (fmap index) {-# INLINE tabulated #-} contramapRep :: Representable f => (a -> b) -> f b -> f a contramapRep f = tabulate . (. f) . index instance Representable Proxy where type Rep Proxy = () tabulate _ = Proxy index Proxy _ = () contramapWithRep _ Proxy = Proxy instance Representable (Op r) where type Rep (Op r) = r tabulate = Op index = getOp instance Representable Predicate where type Rep Predicate = Bool tabulate = Predicate index = getPredicate instance (Representable f, Representable g) => Representable (Product f g) where type Rep (Product f g) = (Rep f, Rep g) tabulate f = Pair (tabulate (fst . f)) (tabulate (snd . f)) index (Pair f g) a = (index f a, index g a) contramapWithRep h (Pair f g) = Pair (contramapWithRep (fmap fst . h) f) (contramapWithRep (fmap snd . h) g) instance Representable U1 where type Rep U1 = () tabulate _ = U1 index U1 _ = () contramapWithRep _ U1 = U1 instance (Representable f, Representable g) => Representable (f :*: g) where type Rep (f :*: g) = (Rep f, Rep g) tabulate f = tabulate (fst . f) :*: tabulate (snd . f) index (f :*: g) a = (index f a, index g a) contramapWithRep h (f :*: g) = contramapWithRep (fmap fst . h) f :*: contramapWithRep (fmap snd . h) g adjunctions-4.4.2/src/Data/Functor/Rep.hs0000644000000000000000000003614707346545000016410 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fenable-rewrite-rules #-} ---------------------------------------------------------------------- -- | -- Copyright : (c) Edward Kmett 2011-2014 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- -- Representable endofunctors over the category of Haskell types are -- isomorphic to the reader monad and so inherit a very large number -- of properties for free. ---------------------------------------------------------------------- module Data.Functor.Rep ( -- * Representable Functors Representable(..) , tabulated -- * Wrapped representable functors , Co(..) -- * Default definitions -- ** Functor , fmapRep -- ** Distributive , distributeRep , collectRep -- ** Apply/Applicative , apRep , pureRep , liftR2 , liftR3 -- ** Bind/Monad , bindRep -- ** MonadFix , mfixRep -- ** MonadZip , mzipRep , mzipWithRep -- ** MonadReader , askRep , localRep -- ** Extend , duplicatedRep , extendedRep -- ** Comonad , duplicateRep , extendRep , extractRep -- ** Comonad, with user-specified monoid , duplicateRepBy , extendRepBy , extractRepBy -- ** WithIndex , imapRep , ifoldMapRep , itraverseRep -- ** Generics , GRep , gindex , gtabulate , WrappedRep(..) ) where import Control.Applicative import Control.Applicative.Backwards import Control.Arrow ((&&&)) #if __GLASGOW_HASKELL__ >= 708 import Data.Coerce #endif import Control.Comonad import Control.Comonad.Trans.Class import Control.Comonad.Trans.Traced import Control.Comonad.Cofree import Control.Monad.Fix (MonadFix(..)) import Control.Monad.Trans.Identity import Control.Monad.Reader (MonadReader(..), ReaderT(..)) #if MIN_VERSION_base(4,4,0) import Data.Complex #endif import Data.Distributive import Data.Foldable (Foldable(fold)) import Data.Function import Data.Functor.Bind import Data.Functor.Identity import Data.Functor.Compose import Data.Functor.Extend import Data.Functor.Product import Data.Functor.Reverse import qualified Data.Monoid as Monoid import Data.Profunctor.Unsafe import Data.Proxy import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Semigroup hiding (Product) import Data.Tagged #if !(MIN_VERSION_base(4,8,0)) import Data.Traversable (Traversable(sequenceA)) #endif import Data.Void import GHC.Generics hiding (Rep) import Prelude hiding (lookup) -- | A 'Functor' @f@ is 'Representable' if 'tabulate' and 'index' witness an isomorphism to @(->) x@. -- -- Every 'Distributive' 'Functor' is actually 'Representable'. -- -- Every 'Representable' 'Functor' from Hask to Hask is a right adjoint. -- -- @ -- 'tabulate' . 'index' ≡ id -- 'index' . 'tabulate' ≡ id -- 'tabulate' . 'return' ≡ 'return' -- @ class Distributive f => Representable f where -- | If no definition is provided, this will default to 'GRep'. type Rep f :: * type Rep f = GRep f -- | -- @ -- 'fmap' f . 'tabulate' ≡ 'tabulate' . 'fmap' f -- @ -- -- If no definition is provided, this will default to 'gtabulate'. tabulate :: (Rep f -> a) -> f a default tabulate :: (Generic1 f, GRep f ~ Rep f, GTabulate (Rep1 f)) => (Rep f -> a) -> f a tabulate = gtabulate -- | If no definition is provided, this will default to 'gindex'. index :: f a -> Rep f -> a default index :: (Generic1 f, GRep f ~ Rep f, GIndex (Rep1 f)) => f a -> Rep f -> a index = gindex -- | A default implementation of 'Rep' for a datatype that is an instance of -- 'Generic1'. This is usually composed of 'Either', tuples, unit tuples, and -- underlying 'Rep' values. For instance, if you have: -- -- @ -- data Foo a = MkFoo a (Bar a) (Baz (Quux a)) deriving ('Functor', 'Generic1') -- instance 'Representable' Foo -- @ -- -- Then you'll get: -- -- @ -- 'GRep' Foo = Either () (Either ('WrappedRep' Bar) ('WrappedRep' Baz, 'WrappedRep' Quux)) -- @ -- -- (See the Haddocks for 'WrappedRep' for an explanation of its purpose.) type GRep f = GRep' (Rep1 f) -- | A default implementation of 'tabulate' in terms of 'GRep'. gtabulate :: (Generic1 f, GRep f ~ Rep f, GTabulate (Rep1 f)) => (Rep f -> a) -> f a gtabulate = to1 . gtabulate' -- | A default implementation of 'index' in terms of 'GRep'. gindex :: (Generic1 f, GRep f ~ Rep f, GIndex (Rep1 f)) => f a -> Rep f -> a gindex = gindex' . from1 type family GRep' (f :: * -> *) :: * class GTabulate f where gtabulate' :: (GRep' f -> a) -> f a class GIndex f where gindex' :: f a -> GRep' f -> a type instance GRep' (f :*: g) = Either (GRep' f) (GRep' g) instance (GTabulate f, GTabulate g) => GTabulate (f :*: g) where gtabulate' f = gtabulate' (f . Left) :*: gtabulate' (f . Right) instance (GIndex f, GIndex g) => GIndex (f :*: g) where gindex' (a :*: _) (Left i) = gindex' a i gindex' (_ :*: b) (Right j) = gindex' b j type instance GRep' (f :.: g) = (WrappedRep f, GRep' g) instance (Representable f, GTabulate g) => GTabulate (f :.: g) where gtabulate' f = Comp1 $ tabulate $ fmap gtabulate' $ fmap (curry f) WrapRep instance (Representable f, GIndex g) => GIndex (f :.: g) where gindex' (Comp1 fg) (i, j) = gindex' (index fg (unwrapRep i)) j type instance GRep' Par1 = () instance GTabulate Par1 where gtabulate' f = Par1 (f ()) instance GIndex Par1 where gindex' (Par1 a) () = a type instance GRep' (Rec1 f) = WrappedRep f #if __GLASGOW_HASKELL__ >= 708 -- Using coerce explicitly here seems a bit more readable, and -- likely a drop easier on the simplifier. instance Representable f => GTabulate (Rec1 f) where gtabulate' = coerce (tabulate :: (Rep f -> a) -> f a) :: forall a . (WrappedRep f -> a) -> Rec1 f a instance Representable f => GIndex (Rec1 f) where gindex' = coerce (index :: f a -> Rep f -> a) :: forall a . Rec1 f a -> WrappedRep f -> a #else instance Representable f => GTabulate (Rec1 f) where gtabulate' = Rec1 #. tabulate .# (. WrapRep) instance Representable f => GIndex (Rec1 f) where gindex' = (. unwrapRep) #. index .# unRec1 #endif type instance GRep' (M1 i c f) = GRep' f instance GTabulate f => GTabulate (M1 i c f) where gtabulate' = M1 #. gtabulate' instance GIndex f => GIndex (M1 i c f) where gindex' = gindex' .# unM1 -- | On the surface, 'WrappedRec' is a simple wrapper around 'Rep'. But it plays -- a very important role: it prevents generic 'Representable' instances for -- recursive types from sending the typechecker into an infinite loop. Consider -- the following datatype: -- -- @ -- data Stream a = a :< Stream a deriving ('Functor', 'Generic1') -- instance 'Representable' Stream -- @ -- -- With 'WrappedRep', we have its 'Rep' being: -- -- @ -- 'Rep' Stream = 'Either' () ('WrappedRep' Stream) -- @ -- -- If 'WrappedRep' didn't exist, it would be: -- -- @ -- 'Rep' Stream = Either () (Either () (Either () ...)) -- @ -- -- An infinite type! 'WrappedRep' breaks the potentially infinite loop. newtype WrappedRep f = WrapRep { unwrapRep :: Rep f } {-# RULES "tabulate/index" forall t. tabulate (index t) = t #-} -- | 'tabulate' and 'index' form two halves of an isomorphism. -- -- This can be used with the combinators from the @lens@ package. -- -- @'tabulated' :: 'Representable' f => 'Iso'' ('Rep' f -> a) (f a)@ tabulated :: (Representable f, Representable g, Profunctor p, Functor h) => p (f a) (h (g b)) -> p (Rep f -> a) (h (Rep g -> b)) tabulated = dimap tabulate (fmap index) {-# INLINE tabulated #-} -- * Default definitions fmapRep :: Representable f => (a -> b) -> f a -> f b fmapRep f = tabulate . fmap f . index pureRep :: Representable f => a -> f a pureRep = tabulate . const bindRep :: Representable f => f a -> (a -> f b) -> f b bindRep m f = tabulate $ \a -> index (f (index m a)) a mfixRep :: Representable f => (a -> f a) -> f a mfixRep = tabulate . mfix . fmap index mzipWithRep :: Representable f => (a -> b -> c) -> f a -> f b -> f c mzipWithRep f as bs = tabulate $ \k -> f (index as k) (index bs k) mzipRep :: Representable f => f a -> f b -> f (a, b) mzipRep as bs = tabulate (index as &&& index bs) askRep :: Representable f => f (Rep f) askRep = tabulate id localRep :: Representable f => (Rep f -> Rep f) -> f a -> f a localRep f m = tabulate (index m . f) apRep :: Representable f => f (a -> b) -> f a -> f b apRep f g = tabulate (index f <*> index g) distributeRep :: (Representable f, Functor w) => w (f a) -> f (w a) distributeRep wf = tabulate (\k -> fmap (`index` k) wf) collectRep :: (Representable f, Functor w) => (a -> f b) -> w a -> f (w b) collectRep f w = tabulate (\k -> (`index` k) . f <$> w) duplicateRepBy :: Representable f => (Rep f -> Rep f -> Rep f) -> f a -> f (f a) duplicateRepBy plus w = tabulate (\m -> tabulate (index w . plus m)) extendRepBy :: Representable f => (Rep f -> Rep f -> Rep f) -> (f a -> b) -> f a -> f b extendRepBy plus f w = tabulate (\m -> f (tabulate (index w . plus m))) extractRepBy :: Representable f => (Rep f) -> f a -> a extractRepBy = flip index duplicatedRep :: (Representable f, Semigroup (Rep f)) => f a -> f (f a) duplicatedRep = duplicateRepBy (<>) extendedRep :: (Representable f, Semigroup (Rep f)) => (f a -> b) -> f a -> f b extendedRep = extendRepBy (<>) duplicateRep :: (Representable f, Monoid (Rep f)) => f a -> f (f a) duplicateRep = duplicateRepBy mappend extendRep :: (Representable f, Monoid (Rep f)) => (f a -> b) -> f a -> f b extendRep = extendRepBy mappend extractRep :: (Representable f, Monoid (Rep f)) => f a -> a extractRep = extractRepBy mempty imapRep :: Representable r => (Rep r -> a -> a') -> (r a -> r a') imapRep f xs = tabulate (f <*> index xs) ifoldMapRep :: forall r m a. (Representable r, Foldable r, Monoid m) => (Rep r -> a -> m) -> (r a -> m) ifoldMapRep ix xs = fold (tabulate (\(i :: Rep r) -> ix i $ index xs i) :: r m) itraverseRep :: forall r f a a'. (Representable r, Traversable r, Applicative f) => (Rep r -> a -> f a') -> (r a -> f (r a')) itraverseRep ix xs = sequenceA $ tabulate (ix <*> index xs) -- * Instances instance Representable Proxy where type Rep Proxy = Void index Proxy = absurd tabulate _ = Proxy instance Representable Identity where type Rep Identity = () index (Identity a) () = a tabulate f = Identity (f ()) instance Representable (Tagged t) where type Rep (Tagged t) = () index (Tagged a) () = a tabulate f = Tagged (f ()) instance Representable m => Representable (IdentityT m) where type Rep (IdentityT m) = Rep m index = index .# runIdentityT tabulate = IdentityT #. tabulate instance Representable ((->) e) where type Rep ((->) e) = e index = id tabulate = id instance Representable m => Representable (ReaderT e m) where type Rep (ReaderT e m) = (e, Rep m) index (ReaderT f) (e,k) = index (f e) k tabulate = ReaderT . fmap tabulate . curry instance (Representable f, Representable g) => Representable (Compose f g) where type Rep (Compose f g) = (Rep f, Rep g) index (Compose fg) (i,j) = index (index fg i) j tabulate = Compose . tabulate . fmap tabulate . curry instance Representable w => Representable (TracedT s w) where type Rep (TracedT s w) = (s, Rep w) index (TracedT w) (e,k) = index w k e tabulate = TracedT . unCo . collect (Co #. tabulate) . curry instance (Representable f, Representable g) => Representable (Product f g) where type Rep (Product f g) = Either (Rep f) (Rep g) index (Pair a _) (Left i) = index a i index (Pair _ b) (Right j) = index b j tabulate f = Pair (tabulate (f . Left)) (tabulate (f . Right)) instance Representable f => Representable (Cofree f) where type Rep (Cofree f) = Seq (Rep f) index (a :< as) key = case Seq.viewl key of Seq.EmptyL -> a k Seq.:< ks -> index (index as k) ks tabulate f = f Seq.empty :< tabulate (\k -> tabulate (f . (k Seq.<|))) instance Representable f => Representable (Backwards f) where type Rep (Backwards f) = Rep f index = index .# forwards tabulate = Backwards #. tabulate instance Representable f => Representable (Reverse f) where type Rep (Reverse f) = Rep f index = index .# getReverse tabulate = Reverse #. tabulate instance Representable Monoid.Dual where type Rep Monoid.Dual = () index (Monoid.Dual d) () = d tabulate f = Monoid.Dual (f ()) instance Representable Monoid.Product where type Rep Monoid.Product = () index (Monoid.Product p) () = p tabulate f = Monoid.Product (f ()) instance Representable Monoid.Sum where type Rep Monoid.Sum = () index (Monoid.Sum s) () = s tabulate f = Monoid.Sum (f ()) #if MIN_VERSION_base(4,4,0) instance Representable Complex where type Rep Complex = Bool index (r :+ i) key = if key then i else r tabulate f = f False :+ f True #endif instance Representable U1 where type Rep U1 = Void index U1 = absurd tabulate _ = U1 instance (Representable f, Representable g) => Representable (f :*: g) where type Rep (f :*: g) = Either (Rep f) (Rep g) index (a :*: _) (Left i) = index a i index (_ :*: b) (Right j) = index b j tabulate f = tabulate (f . Left) :*: tabulate (f . Right) instance (Representable f, Representable g) => Representable (f :.: g) where type Rep (f :.: g) = (Rep f, Rep g) index (Comp1 fg) (i, j) = index (index fg i) j tabulate = Comp1 . tabulate . fmap tabulate . curry instance Representable Par1 where type Rep Par1 = () index (Par1 a) () = a tabulate f = Par1 (f ()) instance Representable f => Representable (Rec1 f) where type Rep (Rec1 f) = Rep f index = index .# unRec1 tabulate = Rec1 #. tabulate instance Representable f => Representable (M1 i c f) where type Rep (M1 i c f) = Rep f index = index .# unM1 tabulate = M1 #. tabulate newtype Co f a = Co { unCo :: f a } deriving Functor instance Representable f => Representable (Co f) where type Rep (Co f) = Rep f tabulate = Co #. tabulate index = index .# unCo instance Representable f => Apply (Co f) where (<.>) = apRep instance Representable f => Applicative (Co f) where pure = pureRep (<*>) = apRep instance Representable f => Distributive (Co f) where distribute = distributeRep collect = collectRep instance Representable f => Bind (Co f) where (>>-) = bindRep instance Representable f => Monad (Co f) where return = pure (>>=) = bindRep #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 instance (Representable f, Rep f ~ a) => MonadReader a (Co f) where ask = askRep local = localRep #endif instance (Representable f, Semigroup (Rep f)) => Extend (Co f) where extended = extendedRep instance (Representable f, Monoid (Rep f)) => Comonad (Co f) where extend = extendRep extract = extractRep instance ComonadTrans Co where lower (Co f) = f liftR2 :: Representable f => (a -> b -> c) -> f a -> f b -> f c liftR2 f fa fb = tabulate $ \i -> f (index fa i) (index fb i) liftR3 :: Representable f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d liftR3 f fa fb fc = tabulate $ \i -> f (index fa i) (index fb i) (index fc i) adjunctions-4.4.2/tests/0000755000000000000000000000000007346545000013375 5ustar0000000000000000adjunctions-4.4.2/tests/GenericsSpec.hs0000644000000000000000000000701407346545000016305 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} ---------------------------------------------------------------------- -- | -- Copyright : (c) Edward Kmett 2011-2014 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- -- Tests for generically derived 'Representable' instances. ---------------------------------------------------------------------- module GenericsSpec (main, spec) where import Data.Distributive (Distributive(..)) import Data.Functor.Rep (Representable(..), WrappedRep(..)) #if __GLASGOW_HASKELL__ >= 706 import Generics.Deriving.Base hiding (Rep) #else import qualified Generics.Deriving.TH as Generics (deriveAll1) #endif import Test.Hspec main :: IO () main = hspec spec spec :: Spec spec = do describe "Id" $ itIndexes "idExample" "idRep" idExample idRep 42 describe "Stream" $ do let streamIndexes :: String -> Rep Stream -> Int -> Spec streamIndexes repNum = itIndexes "streamExample" ("streamRep" ++ repNum) streamExample streamIndexes "1" streamRep1 0 streamIndexes "2" streamRep2 1 streamIndexes "3" streamRep3 2 describe "PolyRec" $ do let polyRecIndexes :: String -> Rep PolyRec -> Int -> Spec polyRecIndexes repNum = itIndexes "polyRecExample" ("polyRecRep" ++ repNum) polyRecExample polyRecIndexes "1" polyRecRep1 1 polyRecIndexes "2" polyRecRep2 2 polyRecIndexes "3" polyRecRep3 0 itIndexes :: (Eq a, Representable f, Show a) => String -> String -> f a -> Rep f -> a -> Spec itIndexes exampleStr repStr exampleVal rep res = it ("index " ++ exampleStr ++ " " ++ repStr ++ " = " ++ show res) $ index exampleVal rep `shouldBe` res ------------------------------------------------------------------------------- newtype Id a = Id { runId :: a } deriving Functor instance Distributive Id where collect f = Id . fmap (runId . f) distribute = Id . fmap runId instance Representable Id -- type Rep Id = () idExample :: Id Int idExample = Id 42 idRep :: Rep Id idRep = () data Stream a = (:>) { shead :: a, stail :: Stream a } deriving Functor instance Distributive Stream where distribute w = fmap shead w :> distribute (fmap stail w) instance Representable Stream -- type Rep Stream = Either () (WrappedRep Stream) streamExample :: Stream Int streamExample = let s = 0 :> fmap (+1) s in s streamRep1, streamRep2, streamRep3 :: Rep Stream streamRep1 = Left () streamRep2 = Right $ WrapRep $ Left () streamRep3 = Right $ WrapRep $ Right $ WrapRep $ Left () data PolyRec a = PolyRec (Id (PolyRec a)) a deriving Functor instance Distributive PolyRec where distribute fpa = PolyRec (Id $ distribute fpa) (fmap (\(PolyRec _ a) -> a) fpa) instance Representable PolyRec -- type Rep PolyRec = Either (WrappedRep Id, WrappedRep PolyRec) () polyRecExample :: PolyRec Int polyRecExample = let p = PolyRec (Id (fmap (+1) p)) 0 in p polyRecRep1, polyRecRep2, polyRecRep3 :: Rep PolyRec polyRecRep1 = Left (WrapRep (), WrapRep $ Right ()) polyRecRep2 = Left (WrapRep (), WrapRep $ Left (WrapRep (), WrapRep $ Right ())) polyRecRep3 = Right () #if __GLASGOW_HASKELL__ >= 706 deriving instance Generic1 Id deriving instance Generic1 Stream deriving instance Generic1 PolyRec #else $(Generics.deriveAll1 ''Id) $(Generics.deriveAll1 ''Stream) $(Generics.deriveAll1 ''PolyRec) #endif adjunctions-4.4.2/tests/Spec.hs0000644000000000000000000000005407346545000014622 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-}