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/.hlint.yaml b/.hlint.yaml new file mode 100644 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,3 @@ +- arguments: [--cpp-define=HLINT, --cpp-ansi] + +- ignore: {name: Use section} diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,25 +0,0 @@ -language: haskell -before_install: - # Uncomment whenever hackage is down. - # - mkdir -p ~/.cabal && cp config ~/.cabal/config && cabal update - - # Try installing some of the build-deps with apt-get for speed. - - ./travis-cabal-apt-install --only-dependencies --force-reinstall $mode - -install: - - cabal configure -flib-Werror $mode - - cabal build - -script: - - $script - -notifications: - irc: - channels: - - "irc.freenode.org#haskell-lens" - skip_join: true - template: - - "\x0313distributive\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" - -env: - - mode="--enable-tests" script="cabal test" diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,65 @@ +0.6.3 [2026.01.10] +------------------ +* Drop support for pre-8.0 versions of GHC. +* Drop unnecessary `base-orphans` dependency. + +0.6.2.1 [2020.12.30] +-------------------- +* The build-type has been changed from `Custom` to `Simple`. + To achieve this, the `doctests` test suite has been removed in favor of using + [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) + to run the doctests. + +0.6.2 [2020.04.10] +------------------ +* Make the `Distributive` instance for `Tagged` poly-kinded. + +0.6.1 [2019.09.06] +------------------ +* Add a `Distributive` instance for `WrappedMonad m`. + +0.6 [2018.07.02] +---------------- +* Remove `fmapCollect`. (See + [here](https://github.com/ekmett/distributive/commit/1020655f15714514048d0dc842ffe4adcec89a7b) + for an explanation of why it was removed.) +* Avoid incurring some dependencies when using recent GHCs. + +0.5.3 +----- +* Support `doctest-0.12` + +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` +* Add `MINIMAL` pragma for `Distributive` + +0.5.0.2 +------- +* A more elegant fix for builds on GHC 7.2 + +0.5.0.1 +------- +* Fix builds on GHC 7.2 + +0.5 +--- +* Added flags for removing some dependencies. +* Support `doctests` when building to non-standard locations (such as when using `stack`.) +* Support `base-orphans` + 0.4.4 ----- * `transformers 0.4` compatibility diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2011-2014 Edward Kmett +Copyright 2011-2016 Edward Kmett All rights reserved. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,8 @@ distributive ============ -[![Build Status](https://secure.travis-ci.org/ekmett/distributive.png?branch=master)](http://travis-ci.org/ekmett/distributive) + +[![Hackage](https://img.shields.io/hackage/v/distributive.svg)](https://hackage.haskell.org/package/distributive) [![Build Status](https://github.com/ekmett/distributive/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/distributive/actions?query=workflow%3AHaskell-CI) This package provides the notion that is categorically dual to `Traversable`. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,44 +1,5 @@ -#!/usr/bin/runhaskell \begin{code} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -import Data.List ( nub ) -import Data.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) -import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) -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 System.FilePath ( () ) - +import Distribution.Simple (defaultMain) main :: IO () -main = defaultMainWithHooks simpleUserHooks - { buildHook = \pkg lbi hooks flags -> do - generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi - buildHook simpleUserHooks pkg lbi hooks flags - } - -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () -generateBuildModule verbosity pkg lbi = do - let dir = autogenModulesDir lbi - createDirectoryIfMissingVerbose verbosity True dir - withLibLBI pkg lbi $ \_ libcfg -> do - withTestLBI pkg lbi $ \suite suitecfg -> do - rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines - [ "module Build_" ++ testName suite ++ " where" - , "deps :: [String]" - , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) - ] - where - formatdeps = map (formatone . snd) - formatone p = case packageName p of - PackageName n -> n ++ "-" ++ showVersion (packageVersion p) - -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] -testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys - +main = defaultMain \end{code} diff --git a/distributive.cabal b/distributive.cabal --- a/distributive.cabal +++ b/distributive.cabal @@ -1,65 +1,87 @@ name: distributive category: Data Structures -version: 0.4.4 +version: 0.6.3 license: BSD3 -cabal-version: >= 1.8 +cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/distributive/ bug-reports: http://github.com/ekmett/distributive/issues -copyright: Copyright (C) 2011-2014 Edward A. Kmett +copyright: Copyright (C) 2011-2016 Edward A. Kmett synopsis: Distributive functors -- Dual to Traversable -description: Distributive functors -- Dual to Traversable -build-type: Custom +description: Distributive functors -- Dual to @Traversable@ +build-type: Simple +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.4 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.3 + , GHC == 9.12.2 + , GHC == 9.14.1 extra-source-files: - .ghci - .travis.yml + .hlint.yaml .vim.custom config - travis-cabal-apt-install CHANGELOG.markdown README.markdown source-repository head type: git - location: git://github.com/ekmett/distributive.git + location: https://github.com/ekmett/distributive.git -flag lib-Werror +flag tagged manual: True - default: False + default: True + description: + You can disable the use of the `tagged` package using `-f-tagged`. + . + Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. library build-depends: - base >= 4 && < 5, - tagged >= 0.7 && < 1, - transformers >= 0.2 && < 0.5, - transformers-compat >= 0.3 && < 1 + base >= 4.9 && < 5, + transformers >= 0.3 && < 0.7 hs-source-dirs: src exposed-modules: Data.Distributive + Data.Distributive.Generic - if impl(ghc>=7.2) - exposed-modules: Data.Distributive.Generic - build-depends: ghc-prim + if flag(tagged) + build-depends: tagged >= 0.7 && < 1 - if flag(lib-Werror) - ghc-options: -Werror - else - ghc-options: -Wall + ghc-options: -Wall --- Verify the results of the examples -test-suite doctests - type: exitcode-stdio-1.0 - main-is: doctests.hs - build-depends: - base >= 4, - directory >= 1.0, - doctest >= 0.9.1, - filepath >= 1.2 - ghc-options: -Wall -threaded - if impl(ghc<7.6.1) - ghc-options: -Werror + if impl(ghc >= 9.0) + -- these flags may abort compilation with GHC-8.10 + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 + ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode + + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 hs-source-dirs: tests + build-tool-depends: + hspec-discover:hspec-discover + + 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 + default-language: Haskell2010 diff --git a/src/Data/Distributive.hs b/src/Data/Distributive.hs --- a/src/Data/Distributive.hs +++ b/src/Data/Distributive.hs @@ -1,9 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE PolyKinds #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Distributive --- Copyright : (C) 2011-2014 Edward Kmett +-- Copyright : (C) 2011-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -20,17 +25,22 @@ import Control.Applicative import Control.Applicative.Backwards import Control.Monad (liftM) -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707 -import Control.Monad.Instances () -#endif import Control.Monad.Trans.Identity import Control.Monad.Trans.Reader +import Data.Coerce +import Data.Complex import Data.Functor.Compose import Data.Functor.Identity import Data.Functor.Product import Data.Functor.Reverse +import qualified Data.Monoid as Monoid import Data.Proxy +import qualified Data.Semigroup as Semigroup +import GHC.Generics (U1(..), (:*:)(..), (:.:)(..), Par1(..), Rec1(..), M1(..)) + +#ifdef MIN_VERSION_tagged import Data.Tagged +#endif #ifdef HLINT {-# ANN module "hlint: ignore Use section" #-} @@ -43,9 +53,7 @@ -- some Coapplicative class. Categorically every 'Distributive' -- functor is actually a right adjoint, and so it must be 'Representable' -- endofunctor and preserve all limits. This is a fancy way of saying it --- isomorphic to `(->) x` for some x. --- --- Minimal complete definition: 'distribute' or 'collect' +-- is isomorphic to @(->) x@ for some x. -- -- To be distributable a container will need to have a way to consistently -- zip a potentially infinite number of copies of itself. This effectively @@ -54,74 +62,195 @@ -- and no extra information to try to merge together. -- class Functor g => Distributive g where + {-# MINIMAL distribute | collect #-} -- | The dual of 'Data.Traversable.sequenceA' -- -- >>> distribute [(+1),(+2)] 1 -- [2,3] -- - -- @'distribute' = 'collect' 'id'@ + -- @ + -- 'distribute' = 'collect' 'id' + -- 'distribute' . 'distribute' = 'id' + -- @ distribute :: Functor f => f (g a) -> g (f a) distribute = collect id -- | - -- @'collect' f = 'distribute' . 'fmap' f@ + -- @ + -- 'collect' f = 'distribute' . 'fmap' f + -- 'fmap' f = 'runIdentity' . 'collect' ('Identity' . f) + -- 'fmap' 'distribute' . 'collect' f = 'getCompose' . 'collect' ('Compose' . f) + -- @ + collect :: Functor f => (a -> g b) -> f a -> g (f b) collect f = distribute . fmap f -- | The dual of 'Data.Traversable.sequence' -- - -- @'distributeM' = 'fmap' 'unwrapMonad' . 'distribute' . 'WrapMonad'@ + -- @ + -- 'distributeM' = 'fmap' 'unwrapMonad' . 'distribute' . 'WrapMonad' + -- @ distributeM :: Monad m => m (g a) -> g (m a) distributeM = fmap unwrapMonad . distribute . WrapMonad -- | - -- @'collectM' = 'distributeM' . 'liftM' f@ + -- @ + -- 'collectM' = 'distributeM' . 'liftM' f + -- @ collectM :: Monad m => (a -> g b) -> m a -> g (m b) collectM f = distributeM . liftM f -- | The dual of 'Data.Traversable.traverse' -- --- @'cotraverse' f = 'fmap' f . 'distribute'@ -cotraverse :: (Functor f, Distributive g) => (f a -> b) -> f (g a) -> g b +-- @ +-- 'cotraverse' f = 'fmap' f . 'distribute' +-- @ +cotraverse :: (Distributive g, Functor f) => (f a -> b) -> f (g a) -> g b cotraverse f = fmap f . distribute -- | The dual of 'Data.Traversable.mapM' -- --- @'comapM' f = 'fmap' f . 'distributeM'@ -comapM :: (Monad m, Distributive g) => (m a -> b) -> m (g a) -> g b +-- @ +-- 'comapM' f = 'fmap' f . 'distributeM' +-- @ +comapM :: (Distributive g, Monad m) => (m a -> b) -> m (g a) -> g b 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 instance Distributive Proxy where collect _ _ = Proxy distribute _ = Proxy +#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 + 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 = 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 = 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 = 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 + +instance Distributive Semigroup.Min where + 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 = 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 = 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 = 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 + +instance Distributive Complex where + distribute wc = fmap realP wc :+ fmap imagP wc where + -- Redefine realPart and imagPart to avoid incurring redundant RealFloat + -- constraints on older versions of base + realP (r :+ _) = r + imagP (_ :+ i) = i + +instance (Distributive m, Monad m) => Distributive (WrappedMonad m) where + collect f = WrapMonad . collect (coerce f) + +instance Distributive U1 where + distribute _ = U1 + +instance (Distributive a, Distributive b) => Distributive (a :*: b) 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 . 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 . 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 . 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) diff --git a/src/Data/Distributive/Generic.hs b/src/Data/Distributive/Generic.hs --- a/src/Data/Distributive/Generic.hs +++ b/src/Data/Distributive/Generic.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Distributive --- Copyright : (C) 2011-2014 Edward Kmett +-- Copyright : (C) 2011-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -14,49 +15,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, Functor b, 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 #-} diff --git a/tests/GenericsSpec.hs b/tests/GenericsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/GenericsSpec.hs @@ -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 +-- 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 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 #-} diff --git a/tests/doctests.hs b/tests/doctests.hs deleted file mode 100644 --- a/tests/doctests.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Main where - -import Build_doctests (deps) -import Control.Applicative -import Control.Monad -import Data.List -import System.Directory -import System.FilePath -import Test.DocTest - -main :: IO () -main = getSources >>= \sources -> doctest $ - "-isrc" - : "-idist/build/autogen" - : "-optP-include" - : "-optPdist/build/autogen/cabal_macros.h" - : "-hide-all-packages" - : map ("-package="++) deps ++ sources - -getSources :: IO [FilePath] -getSources = filter (isSuffixOf ".hs") <$> go "src" - where - go dir = do - (dirs, files) <- getFilesAndDirectories dir - (files ++) . concat <$> mapM go dirs - -getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) -getFilesAndDirectories dir = do - c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir - (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c diff --git a/travis-cabal-apt-install b/travis-cabal-apt-install deleted file mode 100644 --- a/travis-cabal-apt-install +++ /dev/null @@ -1,16 +0,0 @@ -#!/bin/sh -set -eu - -sudo apt-get -q update -sudo apt-get -q -y install dctrl-tools - -# Try installing some of the build-deps with apt-get for speed. -eval "$( - printf '%s' "grep-aptavail -n -sPackage '(' -FFALSE -X FALSE ')'" - 2>/dev/null cabal install "$@" --dry-run -v | \ - sed -nre "s/^([^ ]+)-[0-9.]+ \(.*$/ -o '(' -FPackage -X libghc-\1-dev ')'/p" | \ - xargs -d'\n' -)" | sort -u | xargs -d'\n' sudo apt-get -q -y install -- libghc-quickcheck2-dev - -# Install whatever is still needed with cabal. -cabal install "$@"