distributive 0.5.1 → 0.5.2

raw patch · 10 files changed

+440/−101 lines, 10 filesdep +distributivedep +generic-derivingdep +hspecdep −directorydep −filepathdep ~doctestsetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: distributive, generic-deriving, hspec

Dependencies removed: directory, filepath

Dependency ranges changed: doctest

API changes (from Hackage documentation)

Files

• .travis.yml +8/−7
• CHANGELOG.markdown +12/−0
• Setup.lhs +163/−29
• distributive.cabal +27/−5
• src-compat/Data/Coerce.hs +8/−0
• src/Data/Distributive.hs +66/−16
• src/Data/Distributive/Generic.hs +45/−17
• tests/GenericsSpec.hs +91/−0
• tests/Spec.hs +1/−0
• tests/doctests.hs +19/−27

@@ -48,7 +48,7 @@       compiler: ": #GHC 8.0.2"       addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} -    - env: CABALVER=1.24 GHCVER=head BUILD=cabal+    - env: CABALVER=1.24 GHCVER=head BUILD=cabal CABALFLAGS=--allow-newer       compiler: ": #GHC head"       addons: {apt: {packages: [cabal-install-1.24,ghc-head,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} @@ -61,7 +61,7 @@   allow_failures:     - env: CABALVER=1.18 GHCVER=7.0.4 BUILD=cabal     - env: CABALVER=1.18 GHCVER=7.2.2 BUILD=cabal-    - env: CABALVER=1.24 GHCVER=head BUILD=cabal+    - env: CABALVER=1.24 GHCVER=head BUILD=cabal CABALFLAGS=--allow-newer  before_install:  - unset CC@@ -91,7 +91,7 @@               $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;        fi;        travis_retry cabal update;-       cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt;+       cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v $CABALFLAGS> installplan.txt;        sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt;        if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; then          echo "cabal build-cache HIT";@@ -102,7 +102,7 @@          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;+         cabal install --only-dependencies --enable-tests --enable-benchmarks $CABALFLAGS;          if [ "$GHCVER" = "7.10.3" ]; then cabal install Cabal-1.22.4.0; fi;        fi;        if [ ! -d $HOME/.cabsnap ]; then@@ -122,12 +122,13 @@      stack)        scripts/travis_long stack --no-terminal $STACK_OPTIONS build -j2;;      cabal)-       cabal configure --enable-tests -v2;+       cabal configure --enable-tests -v2 $CABALFLAGS;        cabal build;-       cabal test;+       cabal test --show-details=always;        cabal bench || true;        cabal sdist || true;-       SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ");;+       SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz;+       if [ -f $SRC_TGZ ]; then (cd dist && cabal install --force-reinstalls "$SRC_TGZ"); fi;    esac  notifications:

@@ -1,3 +1,15 @@+0.5.2+-----+* Revamp `Setup.hs` to use `cabal-doctest`. This makes `distributive` build+  with `Cabal-1.25`, and makes the `doctest`s work with `cabal new-build` and+  sandboxes.+* Fix bugs in `Data.Distributive.Generic` that cause generic `Distributive`+  instances not to work properly for datatypes with recursive types+* Add `genericCollect` to `Data.Distributive.Generic`, and switch the underlying+  machinery in that module to work on a `collect`-like method instead of a+  `distribute`-like one+* Add a test suite for regression-testing `Data.Distributive.Generic`+ 0.5.1 ----- * Add `Distributive` instances for datatypes from `Data.Semigroup` and `GHC.Generics`

@@ -1,48 +1,182 @@-#!/usr/bin/runhaskell \begin{code}-{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module Main (main) where +#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0+#endif+++#if MIN_VERSION_cabal_doctest(1,0,0)+import Distribution.Extra.Doctest ( defaultMainWithDoctests )+#else++-- Otherwise we provide a shim++#ifndef MIN_VERSION_Cabal+#define MIN_VERSION_Cabal(x,y,z) 0+#endif+#ifndef MIN_VERSION_directory+#define MIN_VERSION_directory(x,y,z) 0+#endif+#if MIN_VERSION_Cabal(1,24,0)+#define InstalledPackageId UnitId+#endif++import Control.Monad ( when ) import Data.List ( nub )-import Data.Version ( showVersion )-import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )-import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Data.String ( fromString )+import Distribution.Package ( InstalledPackageId )+import Distribution.Package ( PackageId, Package (..), packageVersion )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) , Library (..), BuildInfo (..)) import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) import Distribution.Simple.BuildPaths ( autogenModulesDir )-import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag )-import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )-import Distribution.Verbosity ( Verbosity )+import Distribution.Simple.Setup ( BuildFlags(buildDistPref, buildVerbosity), fromFlag)+import Distribution.Simple.LocalBuildInfo ( withPackageDB, withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps), compiler )+import Distribution.Simple.Compiler ( showCompilerId , PackageDB (..))+import Distribution.Text ( display , simpleParse ) import System.FilePath ( (</>) ) -main :: IO ()-main = defaultMainWithHooks simpleUserHooks-  { buildHook = \pkg lbi hooks flags -> do-     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi-     buildHook simpleUserHooks pkg lbi hooks flags-  }+#if MIN_VERSION_Cabal(1,25,0)+import Distribution.Simple.BuildPaths ( autogenComponentModulesDir )+#endif -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()-generateBuildModule verbosity pkg lbi = do-  let dir = autogenModulesDir lbi-  createDirectoryIfMissingVerbose verbosity True dir-  withLibLBI pkg lbi $ \_ libcfg -> do-    withTestLBI pkg lbi $ \suite suitecfg -> do-      rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines-        [ "module Build_" ++ testName suite ++ " where"+#if MIN_VERSION_directory(1,2,2)+import System.Directory (makeAbsolute)+#else+import System.Directory (getCurrentDirectory)+import System.FilePath (isAbsolute)++makeAbsolute :: FilePath -> IO FilePath+makeAbsolute p | isAbsolute p = return p+               | otherwise    = do+    cwd <- getCurrentDirectory+    return $ cwd </> p+#endif++generateBuildModule :: String -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule testsuiteName flags pkg lbi = do+  let verbosity = fromFlag (buildVerbosity flags)+  let distPref = fromFlag (buildDistPref flags)++  -- Package DBs+  let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </> "package.conf.inplace" ]+  let dbFlags = "-hide-all-packages" : packageDbArgs dbStack++  withLibLBI pkg lbi $ \lib libcfg -> do+    let libBI = libBuildInfo lib++    -- modules+    let modules = exposedModules lib ++ otherModules libBI+    -- it seems that doctest is happy to take in module names, not actual files!+    let module_sources = modules++    -- We need the directory with library's cabal_macros.h!+#if MIN_VERSION_Cabal(1,25,0)+    let libAutogenDir = autogenComponentModulesDir lbi libcfg+#else+    let libAutogenDir = autogenModulesDir lbi+#endif++    -- Lib sources and includes+    iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ libAutogenDir : hsSourceDirs libBI+    includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs libBI++    -- CPP includes, i.e. include cabal_macros.h+    let cppFlags = map ("-optP"++) $+            [ "-include", libAutogenDir ++ "/cabal_macros.h" ]+            ++ cppOptions libBI++    withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testsuiteName) $ do++      -- get and create autogen dir+#if MIN_VERSION_Cabal(1,25,0)+      let testAutogenDir = autogenComponentModulesDir lbi suitecfg+#else+      let testAutogenDir = autogenModulesDir lbi+#endif+      createDirectoryIfMissingVerbose verbosity True testAutogenDir++      -- write autogen'd file+      rewriteFile (testAutogenDir </> "Build_doctests.hs") $ unlines+        [ "module Build_doctests where"         , ""-        , "autogen_dir :: String"-        , "autogen_dir = " ++ show dir+        -- -package-id etc. flags+        , "pkgs :: [String]"+        , "pkgs = " ++ (show $ formatDeps $ testDeps libcfg suitecfg)         , ""-        , "deps :: [String]"-        , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+        , "flags :: [String]"+        , "flags = " ++ show (iArgs ++ includeArgs ++ dbFlags ++ cppFlags)+        , ""+        , "module_sources :: [String]"+        , "module_sources = " ++ show (map display module_sources)         ]   where-    formatdeps = map (formatone . snd)-    formatone p = case packageName p of-      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)+    -- we do this check in Setup, as then doctests don't need to depend on Cabal+    isOldCompiler = maybe False id $ do+      a <- simpleParse $ showCompilerId $ compiler lbi+      b <- simpleParse "7.5"+      return $ packageVersion (a :: PackageId) < b +    formatDeps = map formatOne+    formatOne (installedPkgId, pkgId)+      -- The problem is how different cabal executables handle package databases+      -- when doctests depend on the library+      | packageId pkg == pkgId = "-package=" ++ display pkgId+      | otherwise              = "-package-id=" ++ display installedPkgId++    -- From Distribution.Simple.Program.GHC+    packageDbArgs :: [PackageDB] -> [String]+    packageDbArgs | isOldCompiler = packageDbArgsConf+                  | otherwise     = packageDbArgsDb++    -- GHC <7.6 uses '-package-conf' instead of '-package-db'.+    packageDbArgsConf :: [PackageDB] -> [String]+    packageDbArgsConf dbstack = case dbstack of+      (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs+      (GlobalPackageDB:dbs)               -> ("-no-user-package-conf")+                                           : concatMap specific dbs+      _ -> ierror+      where+        specific (SpecificPackageDB db) = [ "-package-conf=" ++ db ]+        specific _                      = ierror+        ierror = error $ "internal error: unexpected package db stack: "+                      ++ show dbstack++    -- GHC >= 7.6 uses the '-package-db' flag. See+    -- https://ghc.haskell.org/trac/ghc/ticket/5977.+    packageDbArgsDb :: [PackageDB] -> [String]+    -- special cases to make arguments prettier in common scenarios+    packageDbArgsDb dbstack = case dbstack of+      (GlobalPackageDB:UserPackageDB:dbs)+        | all isSpecific dbs              -> concatMap single dbs+      (GlobalPackageDB:dbs)+        | all isSpecific dbs              -> "-no-user-package-db"+                                           : concatMap single dbs+      dbs                                 -> "-clear-package-db"+                                           : concatMap single dbs+     where+       single (SpecificPackageDB db) = [ "-package-db=" ++ db ]+       single GlobalPackageDB        = [ "-global-package-db" ]+       single UserPackageDB          = [ "-user-package-db" ]+       isSpecific (SpecificPackageDB _) = True+       isSpecific _                     = False+ testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++defaultMainWithDoctests :: String -> IO ()+defaultMainWithDoctests testSuiteName = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule testSuiteName flags pkg lbi+     buildHook simpleUserHooks pkg lbi hooks flags+  }++#endif++main :: IO ()+main = defaultMainWithDoctests "doctests"  \end{code}

@@ -1,6 +1,6 @@ name:          distributive category:      Data Structures-version:       0.5.1+version:       0.5.2 license:       BSD3 cabal-version: >= 1.8 license-file:  LICENSE@@ -25,11 +25,16 @@   type: git   location: git://github.com/ekmett/distributive.git +custom-setup+  setup-depends:+    base >= 4 && <5,+    cabal-doctest >= 1 && <1.1+ flag semigroups   manual: True   default: True   description:-    You can disable the use of the `tagged` package using `-f-tagged`.+    You can disable the use of the `semigroups` package using `-f-semigroups`.     .     Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. @@ -65,6 +70,10 @@     if flag(semigroups)       build-depends: semigroups >= 0.11 && < 1 +  if impl(ghc < 7.8)+    hs-source-dirs: src-compat+    other-modules: Data.Coerce+   ghc-options: -Wall  -- Verify the results of the examples@@ -73,8 +82,21 @@   main-is: doctests.hs   build-depends:     base      >= 4,-    directory >= 1.0,-    doctest   >= 0.9.1,-    filepath  >= 1.2+    doctest   >= 0.11.1 && <0.12   ghc-options: -Wall -threaded   hs-source-dirs: tests++test-suite spec+  type:           exitcode-stdio-1.0+  hs-source-dirs: tests++  build-depends:+    base             >= 4    && < 5,+    distributive,+    generic-deriving >= 1.11 && < 2,+    hspec            >= 2    && < 3++  main-is: Spec.hs+  other-modules: GenericsSpec++  ghc-options: -Wall -threaded -rtsopts

@@ -0,0 +1,8 @@+-- This is a shim for GHC before 7.8. Cabal ignores it+-- for GHC 7.8 and later.+module Data.Coerce (coerce) where++import Unsafe.Coerce (unsafeCoerce)++coerce :: a -> b+coerce = unsafeCoerce

@@ -1,6 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Distributive@@ -27,6 +32,7 @@ #endif import Control.Monad.Trans.Identity import Control.Monad.Trans.Reader+import Data.Coerce import Data.Functor.Compose import Data.Functor.Identity import Data.Functor.Product@@ -127,7 +133,8 @@ comapM f = fmap f . distributeM  instance Distributive Identity where-  collect f = Identity . fmap (runIdentity . f)+  collect = coerce (fmap :: (a -> b) -> f a -> f b)+    :: forall a b f . Functor f => (a -> Identity b) -> f a -> Identity (f b)   distribute = Identity . fmap runIdentity  #if __GLASGOW_HASKELL__ >= 707 || defined(MIN_VERSION_tagged)@@ -138,60 +145,90 @@  #if defined(MIN_VERSION_tagged) instance Distributive (Tagged t) where-  collect f = Tagged . fmap (unTagged . f)+  collect = coerce (fmap :: (a -> b) -> f a -> f b)+    :: forall a b f . Functor f => (a -> Tagged t b) -> f a -> Tagged t (f b)   distribute = Tagged . fmap unTagged #endif  instance Distributive ((->)e) where   distribute a e = fmap ($e) a+  collect f q e = fmap (flip f e) q  instance Distributive g => Distributive (ReaderT e g) where   distribute a = ReaderT $ \e -> collect (flip runReaderT e) a+  collect f x = ReaderT $ \e -> collect (\a -> runReaderT (f a) e) x  instance Distributive g => Distributive (IdentityT g) where-  collect f = IdentityT . collect (runIdentityT . f)+  collect = coerce (collect :: (a -> g b) -> f a -> g (f b))+            :: forall a b f . Functor f => (a -> IdentityT g b) -> f a -> IdentityT g (f b)  instance (Distributive f, Distributive g) => Distributive (Compose f g) where   distribute = Compose . fmap distribute . collect getCompose+  collect f = Compose . fmap distribute . collect (coerce f)  instance (Distributive f, Distributive g) => Distributive (Product f g) where+  -- It might be tempting to write a 'collect' implementation that+  -- composes the passed function with fstP and sndP. This could be bad,+  -- because it would lead to the passed function being evaluated twice+  -- for each element of the underlying functor.   distribute wp = Pair (collect fstP wp) (collect sndP wp) where     fstP (Pair a _) = a     sndP (Pair _ b) = b + instance Distributive f => Distributive (Backwards f) where   distribute = Backwards . collect forwards+  collect = coerce (collect :: (a -> f b) -> g a -> f (g b))+    :: forall g a b . Functor g+    => (a -> Backwards f b) -> g a -> Backwards f (g b)  instance Distributive f => Distributive (Reverse f) where   distribute = Reverse . collect getReverse+  collect = coerce (collect :: (a -> f b) -> g a -> f (g b))+    :: forall g a b . Functor g+    => (a -> Reverse f b) -> g a -> Reverse f (g b)  instance Distributive Monoid.Dual where-  collect f  = Monoid.Dual . fmap (Monoid.getDual . f)+  collect = coerce (fmap :: (a -> b) -> f a -> f b)+    :: forall f a b . Functor f+    => (a -> Monoid.Dual b) -> f a -> Monoid.Dual (f b)   distribute = Monoid.Dual . fmap Monoid.getDual  instance Distributive Monoid.Product where-  collect f  = Monoid.Product . fmap (Monoid.getProduct . f)+  collect = coerce (fmap :: (a -> b) -> f a -> f b)+    :: forall f a b . Functor f+    => (a -> Monoid.Product b) -> f a -> Monoid.Product (f b)   distribute = Monoid.Product . fmap Monoid.getProduct  instance Distributive Monoid.Sum where-  collect f  = Monoid.Sum . fmap (Monoid.getSum . f)+  collect = coerce (fmap :: (a -> b) -> f a -> f b)+    :: forall f a b . Functor f+    => (a -> Monoid.Sum b) -> f a -> Monoid.Sum (f b)   distribute = Monoid.Sum . fmap Monoid.getSum  #if __GLASGOW_HASKELL__ >= 800 || defined(MIN_VERSION_semigroups) instance Distributive Semigroup.Min where-  collect f  = Semigroup.Min . fmap (Semigroup.getMin . f)+  collect = coerce (fmap :: (a -> b) -> f a -> f b)+    :: forall f a b . Functor f+    => (a -> Semigroup.Min b) -> f a -> Semigroup.Min (f b)   distribute = Semigroup.Min . fmap Semigroup.getMin  instance Distributive Semigroup.Max where-  collect f  = Semigroup.Max . fmap (Semigroup.getMax . f)+  collect = coerce (fmap :: (a -> b) -> f a -> f b)+    :: forall f a b . Functor f+    => (a -> Semigroup.Max b) -> f a -> Semigroup.Max (f b)   distribute = Semigroup.Max . fmap Semigroup.getMax  instance Distributive Semigroup.First where-  collect f  = Semigroup.First . fmap (Semigroup.getFirst . f)+  collect = coerce (fmap :: (a -> b) -> f a -> f b)+    :: forall f a b . Functor f+    => (a -> Semigroup.First b) -> f a -> Semigroup.First (f b)   distribute = Semigroup.First . fmap Semigroup.getFirst  instance Distributive Semigroup.Last where-  collect f  = Semigroup.Last . fmap (Semigroup.getLast . f)+  collect = coerce (fmap :: (a -> b) -> f a -> f b)+    :: forall f a b . Functor f+    => (a -> Semigroup.Last b) -> f a -> Semigroup.Last (f b)   distribute = Semigroup.Last . fmap Semigroup.getLast #endif @@ -206,27 +243,40 @@  -- | 'fmapCollect' is a viable default definition for 'fmap' given -- a 'Distributive' instance defined in terms of 'collect'.-fmapCollect :: Distributive f => (a -> b) -> f a -> f b-fmapCollect f = runIdentity . collect (Identity . f)+fmapCollect :: forall f a b . Distributive f => (a -> b) -> f a -> f b+fmapCollect = coerce (collect :: (a -> Identity b) -> f a -> Identity (f b))  #if __GLASGOW_HASKELL__ >= 702 instance Distributive U1 where   distribute _ = U1  instance (Distributive a, Distributive b) => Distributive (a :*: b) where-  distribute f = distribute (fmap fstP f) :*: distribute (fmap sndP f) where+  -- It might be tempting to write a 'collect' implementation that+  -- composes the passed function with fstP and sndP. This could be bad,+  -- because it would lead to the passed function being evaluated twice+  -- for each element of the underlying functor.+  distribute f = collect fstP f :*: collect sndP f where     fstP (l :*: _) = l     sndP (_ :*: r) = r  instance (Distributive a, Distributive b) => Distributive (a :.: b) where-  distribute = Comp1 . fmap distribute . distribute . fmap unComp1+  distribute = Comp1 . fmap distribute . collect unComp1+  collect f = Comp1 . fmap distribute . collect (coerce f)  instance Distributive Par1 where   distribute = Par1 . fmap unPar1+  collect = coerce (fmap :: (a -> b) -> f a -> f b)+    :: forall f a b . Functor f => (a -> Par1 b) -> f a -> Par1 (f b)  instance Distributive f => Distributive (Rec1 f) where-  distribute = Rec1 . distribute . fmap unRec1+  distribute = Rec1 . collect unRec1+  collect = coerce (collect :: (a -> f b) -> g a -> f (g b))+    :: forall g a b . Functor g+    => (a -> Rec1 f b) -> g a -> Rec1 f (g b)  instance Distributive f => Distributive (M1 i c f) where-  distribute = M1 . distribute . fmap unM1+  distribute = M1 . collect unM1+  collect = coerce (collect :: (a -> f b) -> g a -> f (g b))+    :: forall g a b . Functor g+    => (a -> M1 i c f b) -> g a -> M1 i c f (g b) #endif

@@ -1,6 +1,10 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Data.Distributive@@ -14,49 +18,73 @@ ---------------------------------------------------------------------------- module Data.Distributive.Generic   ( GDistributive(..)+  , genericCollect   , genericDistribute   ) where +import Data.Distributive import GHC.Generics+import Data.Coerce --- | 'distribute' derived from a 'Generic1' type+-- | 'collect' derived from a 'Generic1' type -- -- This can be used to easily produce a 'Distributive' instance for a -- type with a 'Generic1' instance, -- -- > data V2 a = V2 a a deriving (Show, Functor, Generic1)--- > instance Distributive V2' where distribute = genericDistribute+-- > instance Distributive V2' where collect = genericCollect+genericCollect :: (Functor f, Generic1 g, GDistributive (Rep1 g))+               => (a -> g b) -> f a -> g (f b)+genericCollect f = to1 . gcollect (from1 . f)++-- | 'distribute' derived from a 'Generic1' type+--+-- It's often more efficient to use 'genericCollect' instead. genericDistribute  :: (Functor f, Generic1 g, GDistributive (Rep1 g)) => f (g a) -> g (f a) genericDistribute = to1 . gdistribute . fmap from1 + -- Can't distribute over, --   * sums (:+:) --   * K1+--   * V1 class GDistributive g where-  gdistribute :: Functor f => f (g a) -> g (f a)+  gcollect :: Functor f => (a -> g b) -> f a -> g (f b) +gdistribute :: (GDistributive g, Functor f) => f (g b) -> g (f b)+gdistribute = gcollect id+{-# INLINE gdistribute #-}+ instance GDistributive U1 where-  gdistribute _ = U1-  {-# INLINE gdistribute #-}+  gcollect _ _ = U1+  {-# INLINE gcollect #-}  instance (GDistributive a, GDistributive b) => GDistributive (a :*: b) where-  gdistribute f = gdistribute (fmap fstP f) :*: gdistribute (fmap sndP f) where+  -- It might be tempting to fuse `gcollect fstP (fmap f x)` into+  -- `gcollect (fstP . f) x`, but this would lead to a loss of sharing.+  gcollect f x = gcollect fstP x' :*: gcollect sndP x' where+    x' = fmap f x     fstP (l :*: _) = l     sndP (_ :*: r) = r-  {-# INLINE gdistribute #-}+  {-# INLINE gcollect #-} -instance (Functor a, GDistributive a, GDistributive b) => GDistributive (a :.: b) where-  gdistribute = Comp1 . fmap gdistribute . gdistribute . fmap unComp1-  {-# INLINE gdistribute #-}+instance (Distributive a, GDistributive b) => GDistributive (a :.: b) where+  gcollect f = Comp1 . fmap gdistribute . collect (coerce f)+  {-# INLINE gcollect #-}  instance GDistributive Par1 where-  gdistribute = Par1 . fmap unPar1-  {-# INLINE gdistribute #-}+  gcollect = coerce (fmap :: (a -> b) -> f a -> f b)+    :: forall f a b . Functor f => (a -> Par1 b) -> f a -> Par1 (f b)+  {-# INLINE gcollect #-} -instance GDistributive f => GDistributive (Rec1 f) where-  gdistribute = Rec1 . gdistribute . fmap unRec1-  {-# INLINE gdistribute #-}+instance Distributive f => GDistributive (Rec1 f) where+  gcollect = coerce (collect :: (a -> f b) -> g a -> f (g b))+    :: forall g a b . Functor g+    => (a -> Rec1 f b) -> g a -> Rec1 f (g b)+  {-# INLINE gcollect #-}  instance GDistributive f => GDistributive (M1 i c f) where-  gdistribute = M1 . gdistribute . fmap unM1-  {-# INLINE gdistribute #-}+  gcollect = coerce (gcollect :: (a -> f b) -> g a -> f (g b))+    :: forall g a b . Functor g+    => (a -> M1 i c f b) -> g a -> M1 i c f (g b)+  {-# INLINE gcollect #-}

@@ -0,0 +1,91 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  GenericSpec+-- Copyright   :  (C) 2011-2016 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+--+-- Tests for generically derived 'Distributive' instances.+----------------------------------------------------------------------------+module GenericsSpec (main, spec) where++import Test.Hspec++#if __GLASGOW_HASKELL__ >= 702+import           Data.Distributive (Distributive(..))+import           Data.Distributive.Generic (genericCollect, genericDistribute)++# if __GLASGOW_HASKELL__ >= 706+import           Generics.Deriving.Base hiding (Rep)+# else+import qualified Generics.Deriving.TH as Generics (deriveAll1)+# endif+#endif++main :: IO ()+main = hspec spec++spec :: Spec+#if __GLASGOW_HASKELL__ < 702+spec = return ()+#else+spec = do+  describe "Id" $+    it "distribute idExample = idExample" $+      distribute idExample `shouldBe` idExample+  describe "Stream" $+    it "runId (shead (stail (distribute streamExample))) = 1" $+      runId (shead (stail (distribute streamExample))) `shouldBe` 1+  describe "PolyRec" $+    it "runId (plast (runId (pinit (distribute polyRecExample)))) = 1" $+      runId (plast (runId (pinit (distribute polyRecExample)))) `shouldBe` 1++newtype Id a = Id { runId :: a }+  deriving (Eq, Functor, Show)+instance Distributive Id where+  collect    = genericCollect+  distribute = genericDistribute++idExample :: Id (Id Int)+idExample = Id (Id 42)++data Stream a = (:>) { shead :: a, stail :: Stream a }+  deriving Functor+instance Distributive Stream where+  collect    = genericCollect+  distribute = genericDistribute++streamExample :: Id (Stream Int)+streamExample = Id $ let s = 0 :> fmap (+1) s in s++data PolyRec a = PolyRec { pinit :: Id (PolyRec a), plast :: a }+  deriving Functor+instance Distributive PolyRec where+  collect    = genericCollect+  distribute = genericDistribute++polyRecExample :: Id (PolyRec Int)+polyRecExample = Id $ let p = PolyRec (Id $ fmap (+1) p) 0 in p++# 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+#endif

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

@@ -1,33 +1,25 @@-{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (doctests)+-- Copyright   :  (C) 2012-14 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- This module provides doctests for a project based on the actual versions+-- of the packages it was built with. It requires a corresponding Setup.lhs+-- to be added to the project+----------------------------------------------------------------------------- module Main where -import Build_doctests (autogen_dir, deps)-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import Control.Monad-import Data.List-import System.Directory-import System.FilePath+import Build_doctests (flags, pkgs, module_sources)+import Data.Foldable (traverse_) import Test.DocTest  main :: IO ()-main = getSources >>= \sources -> doctest $-    "-isrc"-  : ("-i" ++ autogen_dir)-  : "-optP-include"-  : ("-optP" ++ autogen_dir ++ "/cabal_macros.h")-  : "-hide-all-packages"-  : map ("-package="++) deps ++ sources--getSources :: IO [FilePath]-getSources = filter (isSuffixOf ".hs") <$> go "src"+main = do+    traverse_ putStrLn args+    doctest args   where-    go dir = do-      (dirs, files) <- getFilesAndDirectories dir-      (files ++) . concat <$> mapM go dirs--getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])-getFilesAndDirectories dir = do-  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir-  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c+    args = flags ++ pkgs ++ module_sources