bifunctors 5.5.2 → 5.5.3

raw patch · 4 files changed

+264/−46 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• .travis.yml +41/−29
• CHANGELOG.markdown +7/−0
• bifunctors.cabal +17/−6
• src/Data/Biapplicative.hs +199/−11

@@ -1,6 +1,6 @@ # 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'+#   runghc make_travis_yml_2.hs '-o' '.travis.yml' '--ghc-head' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-unconstrained' 'cabal.project' # # For more information, see https://github.com/hvr/multi-ghc-travis #@@ -36,42 +36,45 @@  matrix:   include:-    - compiler: "ghc-7.0.4"+    - compiler: "ghc-8.6.1"+      env: GHCHEAD=true+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.6.1], sources: [hvr-ghc]}}+    - compiler: "ghc-8.4.3"     # env: TEST=--disable-tests BENCH=--disable-benchmarks-      addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.0.4], sources: [hvr-ghc]}}-    - compiler: "ghc-7.2.2"+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.4.3], 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-7.2.2], sources: [hvr-ghc]}}-    - compiler: "ghc-7.4.2"+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.2.2], 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-7.4.2], sources: [hvr-ghc]}}-    - compiler: "ghc-7.6.3"+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.0.2], 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.6.3], sources: [hvr-ghc]}}+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.10.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"+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.8.4], 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.10.3], sources: [hvr-ghc]}}-    - compiler: "ghc-8.0.2"+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.6.3], 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-8.0.2], sources: [hvr-ghc]}}-    - compiler: "ghc-8.2.2"+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.4.2], sources: [hvr-ghc]}}+    - compiler: "ghc-7.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]}}+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.2.2], sources: [hvr-ghc]}}+    - compiler: "ghc-7.0.4"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.0.4], sources: [hvr-ghc]}}     - compiler: "ghc-head"       env: GHCHEAD=true-      addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-head], sources: [hvr-ghc]}}+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}}    allow_failures:+    - compiler: "ghc-head"     - compiler: "ghc-7.0.4"     - compiler: "ghc-7.2.2"-    - compiler: "ghc-8.4.1"-    - compiler: "ghc-head"+    - compiler: "ghc-8.6.1"  before_install:   - HC=${CC}@@ -89,7 +92,8 @@   - BENCH=${BENCH---enable-benchmarks}   - TEST=${TEST---enable-tests}   - HADDOCK=${HADDOCK-true}-  - INSTALLED=${INSTALLED-true}+  - UNCONSTRAINED=${UNCONSTRAINED-true}+  - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}   - GHCHEAD=${GHCHEAD-false}   - travis_retry cabal update -v   - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"@@ -97,7 +101,8 @@   # 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+      sed -i 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config+      for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done        echo 'repository head.hackage'                                                        >> ${HOME}/.cabal/config       echo '   url: http://head.hackage.haskell.org/'                                       >> ${HOME}/.cabal/config@@ -107,17 +112,22 @@       echo '              8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config       echo '   key-threshold: 3'                                                            >> ${HOME}/.cabal.config +      grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'+       cabal new-update head.hackage -v     fi   - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'   - "printf 'packages: \".\"\\n' > cabal.project"-  - cat cabal.project+  - touch cabal.project.local+  - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"+  - cat cabal.project || true+  - cat cabal.project.local || true   - 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+  - 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;@@ -129,8 +139,10 @@   - cd ${DISTDIR} || false   - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;   - "printf 'packages: bifunctors-*/*.cabal\\n' > cabal.project"-  - cat cabal.project-+  - touch cabal.project.local+  - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"+  - cat cabal.project || true+  - cat cabal.project.local || true    # build & run tests, build benchmarks   - cabal new-build -w ${HC} ${TEST} ${BENCH} all@@ -143,5 +155,5 @@   - 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"]+# REGENDATA ["-o",".travis.yml","--ghc-head","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-unconstrained","cabal.project"] # EOF

@@ -1,3 +1,10 @@+5.5.3 [2018.07.04]+------------------+* Make `biliftA2` a class method of `Biapplicative`.+* Add the `traverseBia`, `sequenceBia`, and `traverseBiaWith` functions for+  traversing a `Traversable` container in a `Biapplicative`.+* Avoid incurring some dependencies when using recent GHCs.+ 5.5.2 [2018.02.06] ------------------ * Don't enable `Safe` on GHC 7.2.

@@ -1,6 +1,6 @@ name:          bifunctors category:      Data, Functors-version:       5.5.2+version:       5.5.3 license:       BSD3 cabal-version: >= 1.8 license-file:  LICENSE@@ -13,7 +13,16 @@ synopsis:      Bifunctors description:   Bifunctors. build-type:    Simple-tested-with:   GHC == 7.0.4, GHC == 7.2.2, 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+tested-with:   GHC == 7.0.4+             , GHC == 7.2.2+             , 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.3+             , GHC == 8.6.1 extra-source-files: .travis.yml CHANGELOG.markdown README.markdown  source-repository head@@ -42,11 +51,13 @@     base                >= 4     && < 5,     base-orphans        >= 0.5.2 && < 1,     comonad             >= 4     && < 6,-    containers          >= 0.1   && < 0.6,-    template-haskell    >= 2.4   && < 2.13,+    containers          >= 0.1   && < 0.7,+    template-haskell    >= 2.4   && < 2.15,     th-abstraction      >= 0.2.2 && < 0.3,-    transformers        >= 0.2   && < 0.6,-    transformers-compat >= 0.5   && < 0.6+    transformers        >= 0.2   && < 0.6++  if !impl(ghc > 8.2)+    build-depends: transformers-compat >= 0.5 && < 0.7    if flag(tagged)     build-depends: tagged >= 0.7.3 && < 1

@@ -1,8 +1,9 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} -#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 702+#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif @@ -24,16 +25,21 @@     Biapplicative(..)   , (<<$>>)   , (<<**>>)-  , biliftA2   , biliftA3+  , traverseBia+  , sequenceBia+  , traverseBiaWith   , module Data.Bifunctor   ) where  import Control.Applicative import Data.Bifunctor+import Data.Functor.Identity+import GHC.Exts (inline)  #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid+import Data.Traversable (Traversable (traverse)) #endif  #if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2)@@ -50,16 +56,24 @@ {-# INLINE (<<$>>) #-}  class Bifunctor p => Biapplicative p where+  {-# MINIMAL bipure, ((<<*>>) | biliftA2 ) #-}   bipure :: a -> b -> p a b    (<<*>>) :: p (a -> b) (c -> d) -> p a c -> p b d+  (<<*>>) = biliftA2 id id+  {-# INLINE (<<*>>) #-} +  -- | Lift binary functions+  biliftA2 :: (a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f+  biliftA2 f g a b = bimap f g <<$>> a <<*>> b+  {-# INLINE biliftA2 #-}+   -- |   -- @   -- a '*>>' b ≡ 'bimap' ('const' 'id') ('const' 'id') '<<$>>' a '<<*>>' b   -- @   (*>>) :: p a b -> p c d -> p c d-  a *>> b = bimap (const id) (const id) <<$>> a <<*>> b+  a *>> b = biliftA2 (const id) (const id) a b   {-# INLINE (*>>) #-}    -- |@@ -67,28 +81,200 @@   -- a '<<*' b ≡ 'bimap' 'const' 'const' '<<$>>' a '<<*>>' b   -- @   (<<*) :: p a b -> p c d -> p a b-  a <<* b = bimap const const <<$>> a <<*>> b+  a <<* b = biliftA2 const const a b   {-# INLINE (<<*) #-}  (<<**>>) :: Biapplicative p => p a c -> p (a -> b) (c -> d) -> p b d (<<**>>) = biliftA2 (flip id) (flip id) {-# INLINE (<<**>>) #-} --- | Lift binary functions-biliftA2 :: Biapplicative w => (a -> b -> c) -> (d -> e -> f) -> w a d -> w b e -> w c f-biliftA2 f g a b = bimap f g <<$>> a <<*>> b-{-# INLINE biliftA2 #-}  -- | Lift ternary functions biliftA3 :: Biapplicative w => (a -> b -> c -> d) -> (e -> f -> g -> h) -> w a e -> w b f -> w c g -> w d h-biliftA3 f g a b c = bimap f g <<$>> a <<*>> b <<*>> c+biliftA3 f g a b c = biliftA2 f g a b <<*>> c {-# INLINE biliftA3 #-} +-- | Traverse a 'Traversable' container in a 'Biapplicative'.+--+-- 'traverseBia' satisfies the following properties:+--+-- [/Pairing/]+--+--     @'traverseBia' (,) t = (t, t)@+--+-- [/Composition/]+--+--     @'traverseBia' ('Data.Bifunctor.Biff.Biff' . 'bimap' g h . f) = 'Data.Bifunctor.Biff.Biff' . 'bimap' ('traverse' g) ('traverse' h) . 'traverseBia' f@+--+--     @'traverseBia' ('Data.Bifunctor.Tannen.Tannen' . 'fmap' f . g) = 'Data.Bifunctor.Tannen.Tannen' . 'fmap' ('traverseBia' f) . 'traverse' g@+--+-- [/Naturality/]+--+--     @ t . 'traverseBia' f = 'traverseBia' (t . f) @+--+--     for every biapplicative transformation @t@.+--+--     A /biapplicative transformation/ from a 'Biapplicative' @P@ to a 'Biapplicative' @Q@+--     is a function+--+--     @t :: P a b -> Q a b@+--+--     preserving the 'Biapplicative' operations. That is,+--+--     * @t ('bipure' x y) = 'bipure' x y@+--+--     * @t (x '<<*>>' y) = t x '<<*>>' t y@+--+-- === Performance note+--+-- 'traverseBia' is fairly efficient, and uses compiler rewrite rules+-- to be even more efficient for a few important types like @[]@. However,+-- if performance is critical, you might consider writing a container-specific+-- implementation.+traverseBia :: (Traversable t, Biapplicative p)+            => (a -> p b c) -> t a -> p (t b) (t c)+traverseBia = inline (traverseBiaWith traverse)+-- We explicitly inline traverseBiaWith because it seems likely to help+-- specialization. I'm not much of an expert at the inlining business,+-- so I won't mind if someone else decides to do this differently.++-- We use a staged INLINABLE so we can rewrite traverseBia to specialized+-- versions for a few important types.+{-# INLINABLE [1] traverseBia #-}++-- | Perform all the 'Biappicative' actions in a 'Traversable' container+-- and produce a container with all the results.+--+-- @+-- sequenceBia = 'traverseBia' id+-- @+sequenceBia :: (Traversable t, Biapplicative p)+            => t (p b c) -> p (t b) (t c)+sequenceBia = inline (traverseBia id)+{-# INLINABLE sequenceBia #-}++-- | A version of 'traverseBia' that doesn't care how the traversal is+-- done.+--+-- @+-- 'traverseBia' = traverseBiaWith traverse+-- @+traverseBiaWith :: forall p a b c s t. Biapplicative p+  => (forall f x. Applicative f => (a -> f x) -> s -> f (t x))+  -> (a -> p b c) -> s -> p (t b) (t c)+traverseBiaWith trav p s = smash p (trav One s)+{-# INLINABLE traverseBiaWith #-}++smash :: forall p t a b c. Biapplicative p+      => (a -> p b c)+      -> (forall x. Mag a x (t x))+      -> p (t b) (t c)+smash p m = go m m+  where+    go :: forall x y. Mag a b x -> Mag a c y -> p x y+    go (Pure t) (Pure u) = bipure t u+    go (Map f x) (Map g y) = bimap f g (go x y)+    go (Ap fs xs) (Ap gs ys) = go fs gs <<*>> go xs ys+#if MIN_VERSION_base(4,10,0)+    go (LiftA2 f xs ys) (LiftA2 g zs ws) = bimap f g (go xs zs) <<*>> go ys ws+#endif+    go (One x) (One _) = p x+    go _ _ = impossibleError+{-# INLINABLE smash #-}++-- Let's not end up with a bunch of CallStack junk in the smash+-- unfolding.+impossibleError :: a+impossibleError = error "Impossible: the arguments are always the same."++-- This is used to reify a traversal for 'traverseBia'. It's a somewhat+-- bogus 'Functor' and 'Applicative' closely related to 'Magma' from the+-- @lens@ package. Valid traversals don't use (<$), (<*), or (*>), so+-- we leave them out. We offer all the rest of the Functor and Applicative+-- operations to improve performance: we generally want to keep the structure+-- as small as possible. We might even consider using RULES to widen lifts+-- when we can:+--+--   liftA2 f x y <*> z ==> liftA3 f x y z,+--+-- etc., up to the pointer tagging limit. But we do need to be careful. I don't+-- *think* GHC will ever inline the traversal into the go function (because that+-- would duplicate work), but if it did, and if different RULES fired for the+-- two copies, everything would break horribly.+--+-- Note: if it's necessary for some reason, we *could* relax GADTs to+-- ExistentialQuantification by changing the type of One to+--+--   One :: (b -> c) -> a -> Mag a b c+--+-- where the function will always end up being id. But we allocate a *lot*+-- of One constructors, so this would definitely be bad for performance.+data Mag a b t where+  Pure :: t -> Mag a b t+  Map :: (x -> t) -> Mag a b x -> Mag a b t+  Ap :: Mag a b (t -> u) -> Mag a b t -> Mag a b u+#if MIN_VERSION_base(4,10,0)+  LiftA2 :: (t -> u -> v) -> Mag a b t -> Mag a b u -> Mag a b v+#endif+  One :: a -> Mag a b b++instance Functor (Mag a b) where+  fmap = Map++instance Applicative (Mag a b) where+  pure = Pure+  (<*>) = Ap+#if MIN_VERSION_base(4,10,0)+  liftA2 = LiftA2+#endif++-- Rewrite rules for traversing a few important types. These avoid the overhead+-- of allocating and matching on a Mag.+{-# RULES+"traverseBia/list" forall f t. traverseBia f t = traverseBiaList f t+"traverseBia/Maybe" forall f t. traverseBia f t = traverseBiaMaybe f t+"traverseBia/Either" forall f t. traverseBia f t = traverseBiaEither f t+"traverseBia/Identity" forall f t. traverseBia f t = traverseBiaIdentity f t+"traverseBia/Const" forall f t. traverseBia f t = traverseBiaConst f t+"traverseBia/Pair" forall f t. traverseBia f t = traverseBiaPair f t+ #-}++traverseBiaList :: Biapplicative p => (a -> p b c) -> [a] -> p [b] [c]+traverseBiaList f = foldr go (bipure [] [])+  where+    go x r = biliftA2 (:) (:) (f x) r++traverseBiaMaybe :: Biapplicative p => (a -> p b c) -> Maybe a -> p (Maybe b) (Maybe c)+traverseBiaMaybe _f Nothing = bipure Nothing Nothing+traverseBiaMaybe f (Just x) = bimap Just Just (f x)++traverseBiaEither :: Biapplicative p => (a -> p b c) -> Either e a -> p (Either e b) (Either e c)+traverseBiaEither f (Right x) = bimap Right Right (f x)+traverseBiaEither _f (Left (e :: e)) = bipure m m+  where+    m :: Either e x+    m = Left e++traverseBiaIdentity :: Biapplicative p => (a -> p b c) -> Identity a -> p (Identity b) (Identity c)+traverseBiaIdentity f (Identity x) = bimap Identity Identity (f x)++traverseBiaConst :: Biapplicative p => (a -> p b c) -> Const x a -> p (Const x b) (Const x c)+traverseBiaConst _f (Const x) = bipure (Const x) (Const x)++traverseBiaPair :: Biapplicative p => (a -> p b c) -> (e, a) -> p (e, b) (e, c)+traverseBiaPair f (x,y) = bimap ((,) x) ((,) x) (f y)++----------------------------------------------+--+-- Instances+ instance Biapplicative (,) where   bipure = (,)   {-# INLINE bipure #-}   (f, g) <<*>> (a, b) = (f a, g b)   {-# INLINE (<<*>>) #-}+  biliftA2 f g (x, y) (a, b) = (f x a, g y b)+  {-# INLINE biliftA2 #-}  #if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) instance Biapplicative Arg where@@ -96,6 +282,8 @@   {-# INLINE bipure #-}   Arg f g <<*>> Arg a b = Arg (f a) (g b)   {-# INLINE (<<*>>) #-}+  biliftA2 f g (Arg x y) (Arg a b) = Arg (f x a) (g y b)+  {-# INLINE biliftA2 #-} #endif  instance Monoid x => Biapplicative ((,,) x) where