diff --git a/.ghci b/.ghci deleted file mode 100644 --- a/.ghci +++ /dev/null @@ -1,1 +0,0 @@ -:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -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.* diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -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 diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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)` diff --git a/adjunctions.cabal b/adjunctions.cabal --- a/adjunctions.cabal +++ b/adjunctions.cabal @@ -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 @@ -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 diff --git a/src/Control/Monad/Representable/State.hs b/src/Control/Monad/Representable/State.hs --- a/src/Control/Monad/Representable/State.hs +++ b/src/Control/Monad/Representable/State.hs @@ -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 diff --git a/src/Data/Functor/Adjunction.hs b/src/Data/Functor/Adjunction.hs --- a/src/Data/Functor/Adjunction.hs +++ b/src/Data/Functor/Adjunction.hs @@ -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 diff --git a/src/Data/Functor/Contravariant/Adjunction.hs b/src/Data/Functor/Contravariant/Adjunction.hs --- a/src/Data/Functor/Contravariant/Adjunction.hs +++ b/src/Data/Functor/Contravariant/Adjunction.hs @@ -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 diff --git a/src/Data/Functor/Contravariant/Rep.hs b/src/Data/Functor/Contravariant/Rep.hs --- a/src/Data/Functor/Contravariant/Rep.hs +++ b/src/Data/Functor/Contravariant/Rep.hs @@ -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 diff --git a/src/Data/Functor/Rep.hs b/src/Data/Functor/Rep.hs --- a/src/Data/Functor/Rep.hs +++ b/src/Data/Functor/Rep.hs @@ -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 diff --git a/tests/GenericsSpec.hs b/tests/GenericsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/GenericsSpec.hs @@ -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 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}