adjunctions 4.3 → 4.4

raw patch · 12 files changed

+568/−88 lines, 12 filesdep +adjunctionsdep +generic-derivingdep +ghc-primdep ~containersdep ~distributivedep ~freenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: adjunctions, generic-deriving, ghc-prim, hspec

Dependency ranges changed: containers, distributive, free

API changes (from Hackage documentation)

Files

• .ghci +0/−1
• .gitignore +19/−0
• .travis.yml +121/−72
• CHANGELOG.markdown +11/−0
• adjunctions.cabal +36/−6
• src/Control/Monad/Representable/State.hs +1/−1
• src/Data/Functor/Adjunction.hs +44/−0
• src/Data/Functor/Contravariant/Adjunction.hs +3/−0
• src/Data/Functor/Contravariant/Rep.hs +19/−2
• src/Data/Functor/Rep.hs +201/−6
• tests/GenericsSpec.hs +112/−0
• tests/Spec.hs +1/−0

@@ -1,1 +0,0 @@-:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h

@@ -1,4 +1,5 @@ dist+dist-newstyle docs wiki TAGS@@ -11,3 +12,21 @@ *.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.*

@@ -1,97 +1,146 @@-# This file has been generated -- see https://github.com/hvr/multi-ghc-travis+# This Travis job script has been generated by a script via+#+#   runghc make_travis_yml_2.hs '-o' '.travis.yml' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-installed' 'cabal.project'+#+# For more information, see https://github.com/hvr/multi-ghc-travis+# language: c sudo: false +git:+  submodules: false  # whether to recursively clone submodules++notifications:+  irc:+    channels:+      - "irc.freenode.org#haskell-lens"+    skip_join: true+    template:+      - "\x0313adjunctions\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"+ cache:   directories:-    - $HOME/.cabsnap     - $HOME/.cabal/packages+    - $HOME/.cabal/store  before_cache:   - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log-  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar+  # remove files that are regenerated by 'cabal update'+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx +  - rm -rfv $HOME/.cabal/packages/head.hackage++addons:+  apt:+    packages: &apt_packages+      - ghc-ppa-tools+      - alex-3.1.7+      - happy-1.19.5+ matrix:   include:-    - env: CABALVER=1.24 GHCVER=7.4.2-      compiler: ": #GHC 7.4.2"-      addons: {apt: {packages: [cabal-install-1.24,ghc-7.4.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}-    - env: CABALVER=1.24 GHCVER=7.6.3-      compiler: ": #GHC 7.6.3"-      addons: {apt: {packages: [cabal-install-1.24,ghc-7.6.3,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}-    - env: CABALVER=1.18 GHCVER=7.8.4-      compiler: ": #GHC 7.8.4"-      addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}-    - env: CABALVER=1.22 GHCVER=7.10.1-      compiler: ": #GHC 7.10.1"-      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}-    - env: CABALVER=1.22 GHCVER=7.10.2-      compiler: ": #GHC 7.10.2"-      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}+    - compiler: "ghc-7.4.2"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}}+    - compiler: "ghc-7.6.3"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}}+    - compiler: "ghc-7.8.4"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}}+    - compiler: "ghc-7.10.3"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.10.3], sources: [hvr-ghc]}}+    - compiler: "ghc-8.0.2"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}+    - compiler: "ghc-8.2.2"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}+    - compiler: "ghc-8.4.1"+      env: GHCHEAD=true+      addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}}+    - compiler: "ghc-head"+      env: GHCHEAD=true+      addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-head], sources: [hvr-ghc]}} +  allow_failures:+    - compiler: "ghc-8.4.1"+    - compiler: "ghc-head"+ before_install:- - unset CC- - export HAPPYVER=1.19.5- - export ALEXVER=3.1.4- - export PATH=~/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH+  - HC=${CC}+  - HCPKG=${HC/ghc/ghc-pkg}+  - unset CC+  - ROOTDIR=$(pwd)+  - mkdir -p $HOME/.local/bin+  - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"+  - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))+  - echo $HCNUMVER  install:- - cabal --version- - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"- - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];-   then-     zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >-          $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;-   fi- - travis_retry cabal update- - "sed -i  's/^jobs:.*$/jobs: 2/' $HOME/.cabal/config"- - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt- - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt+  - cabal --version+  - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"+  - BENCH=${BENCH---enable-benchmarks}+  - TEST=${TEST---enable-tests}+  - HADDOCK=${HADDOCK-true}+  - INSTALLED=${INSTALLED-true}+  - GHCHEAD=${GHCHEAD-false}+  - travis_retry cabal update -v+  - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"+  - rm -fv cabal.project cabal.project.local+  # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage+  - |+    if $GHCHEAD; then+      sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config -# check whether current requested install-plan matches cached package-db snapshot- - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;-   then-     echo "cabal build-cache HIT";-     rm -rfv .ghc;-     cp -a $HOME/.cabsnap/ghc $HOME/.ghc;-     cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;-   else-     echo "cabal build-cache MISS";-     rm -rf $HOME/.cabsnap;-     mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;-     cabal install --only-dependencies --enable-tests --enable-benchmarks;-     if [ "$GHCVER" = "7.10.1" ]; then cabal install Cabal-1.22.4.0; fi;-   fi+      echo 'repository head.hackage'                                                        >> ${HOME}/.cabal/config+      echo '   url: http://head.hackage.haskell.org/'                                       >> ${HOME}/.cabal/config+      echo '   secure: True'                                                                >> ${HOME}/.cabal/config+      echo '   root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config+      echo '              2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config+      echo '              8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config+      echo '   key-threshold: 3'                                                            >> ${HOME}/.cabal.config -# snapshot package-db on cache miss- - if [ ! -d $HOME/.cabsnap ];-   then-      echo "snapshotting package-db to build-cache";-      mkdir $HOME/.cabsnap;-      cp -a $HOME/.ghc $HOME/.cabsnap/ghc;-      cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;-   fi+      cabal new-update head.hackage -v+    fi+  - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'+  - "printf 'packages: \".\"\\n' > cabal.project"+  - cat cabal.project+  - if [ -f "./configure.ac" ]; then+      (cd "." && autoreconf -i);+    fi+  - rm -f cabal.project.freeze+  - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all+  - rm -rf "."/.ghc.environment.* "."/dist+  - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)  # Here starts the actual work to be performed for the package under test; # any command which exits with a non-zero exit code causes the build to fail. script:- - cabal configure --enable-tests -v2  # -v2 provides useful information for debugging- - cabal build   # this builds all libraries and executables (including tests)- - cabal test- - cabal bench || true  # expected result: these will crash- - cabal sdist || true  # tests that a source-distribution can be generated+  # test that source-distributions can be generated+  - (cd "." && cabal sdist)+  - mv "."/dist/adjunctions-*.tar.gz ${DISTDIR}/+  - cd ${DISTDIR} || false+  - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;+  - "printf 'packages: adjunctions-*/*.cabal\\n' > cabal.project"+  - cat cabal.project -# Check that the resulting source distribution can be built & installed.-# If there are no other `.tar.gz` files in `dist`, this can be even simpler:-# `cabal install --force-reinstalls dist/*-*.tar.gz`- - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&-   (cd dist && cabal install --force-reinstalls "$SRC_TGZ") -notifications:-  irc:-    channels:-      - "irc.freenode.org#haskell-lens"-    skip_join: true-    template:-      - "\x0313adjunctions\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f"+  # build & run tests, build benchmarks+  - cabal new-build -w ${HC} ${TEST} ${BENCH} all+  - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi++  # cabal check+  - (cd adjunctions-* && cabal check)++  # haddock+  - rm -rf ./dist-newstyle+  - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi++# REGENDATA ["-o",".travis.yml","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-installed","cabal.project"] # EOF

@@ -1,3 +1,14 @@+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)`

@@ -1,8 +1,8 @@ name:          adjunctions category:      Data Structures, Adjunctions-version:       4.3+version:       4.4 license:       BSD3-cabal-version: >= 1.6+cabal-version: >= 1.8 license-file:  LICENSE author:        Edward A. Kmett maintainer:    Edward A. Kmett <ekmett@gmail.com>@@ -11,10 +11,9 @@ 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+description:   Adjunctions and representable functors. build-type:    Simple extra-source-files:-  .ghci   .gitignore   .travis.yml   .vim.custom@@ -23,6 +22,13 @@   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.1  source-repository head   type: git@@ -45,8 +51,8 @@     comonad             >= 4       && < 6,     containers          >= 0.3     && < 0.6,     contravariant       >= 1       && < 2,-    distributive        >= 0.4     && < 1,-    free                >= 4       && < 5,+    distributive        >= 0.5.1   && < 1,+    free                >= 4       && < 6,     mtl                 >= 2.0.1   && < 2.3,     profunctors         >= 4       && < 6,     tagged              >= 0.7     && < 1,@@ -56,6 +62,9 @@     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@@ -70,3 +79,24 @@     Data.Functor.Rep    ghc-options: -Wall++  -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0+  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances++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

@@ -147,7 +147,7 @@   StateT m >>- f = StateT $ fmap (>>- rightAdjunctRep (runStateT . f)) m  instance (Representable g, Monad m) => Monad (StateT g m) where-#if __GLASGOW_VERSION__ < 710+#if __GLASGOW_HASKELL__ < 710   return = StateT . leftAdjunctRep return #endif   StateT m >>= f = StateT $ fmap (>>= rightAdjunctRep (runStateT . f)) m

@@ -1,12 +1,16 @@ {-# LANGUAGE Rank2Types            , MultiParamTypeClasses            , FunctionalDependencies+           , TypeOperators            , UndecidableInstances #-}  {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE EmptyCase #-}+#endif  ------------------------------------------------------------------------------------------- -- |@@ -54,6 +58,7 @@ import Data.Functor.Sum import Data.Profunctor import Data.Void+import GHC.Generics  -- | An adjunction between Hask and Hask. --@@ -74,6 +79,9 @@ -- > 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@@ -191,3 +199,39 @@   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

@@ -41,6 +41,9 @@ -- 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

@@ -1,4 +1,7 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fenable-rewrite-rules #-} ---------------------------------------------------------------------- -- |@@ -26,6 +29,7 @@ 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)@.@@ -59,7 +63,7 @@ -- 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) +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 #-}@@ -90,3 +94,16 @@   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

@@ -1,10 +1,16 @@ {-# 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 #-} ---------------------------------------------------------------------- -- |@@ -31,6 +37,7 @@   , fmapRep   -- ** Distributive   , distributeRep+  , collectRep   -- ** Apply/Applicative   , apRep   , pureRep@@ -57,10 +64,24 @@   , 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@@ -71,19 +92,23 @@ import Data.Complex #endif import Data.Distributive+import Data.Foldable (Foldable(fold)) 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+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+import Data.Traversable (Traversable(sequenceA)) 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@.@@ -99,14 +124,128 @@ -- @  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 #-} @@ -152,6 +291,9 @@ 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)) @@ -176,6 +318,17 @@ 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@@ -195,8 +348,8 @@  instance Representable m => Representable (IdentityT m) where   type Rep (IdentityT m) = Rep m-  index (IdentityT m) i = index m i-  tabulate = IdentityT . tabulate+  index = index .# runIdentityT+  tabulate = IdentityT #. tabulate  instance Representable ((->) e) where   type Rep ((->) e) = e@@ -216,7 +369,7 @@ 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+  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)@@ -231,6 +384,16 @@       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@@ -253,12 +416,43 @@   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 (Co f) i = index f i+  tabulate = Co #. tabulate+  index = index .# unCo  instance Representable f => Apply (Co f) where   (<.>) = apRep@@ -269,6 +463,7 @@  instance Representable f => Distributive (Co f) where   distribute = distributeRep+  collect = collectRep  instance Representable f => Bind (Co f) where   (>>-) = bindRep

@@ -0,0 +1,112 @@+{-# 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

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}