bifunctors 5.1 → 5.2

raw patch · 21 files changed

+812/−230 lines, 21 filesdep +comonaddep +ghc-primdep ~basedep ~template-haskelldep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: comonad, ghc-prim

Dependency ranges changed: base, template-haskell, transformers

API changes (from Hackage documentation)

Files

• .travis.yml +8/−10
• CHANGELOG.markdown +6/−0
• LICENSE +1/−1
• bifunctors.cabal +11/−4
• old-src/Data/Bifunctor.hs +7/−2
• src/Data/Bifoldable.hs +3/−3
• src/Data/Bifunctor/Biff.hs +46/−3
• src/Data/Bifunctor/Clown.hs +41/−3
• src/Data/Bifunctor/Fix.hs +30/−2
• src/Data/Bifunctor/Flip.hs +19/−3
• src/Data/Bifunctor/Functor.hs +51/−0
• src/Data/Bifunctor/Join.hs +20/−5
• src/Data/Bifunctor/Joker.hs +42/−3
• src/Data/Bifunctor/Product.hs +47/−3
• src/Data/Bifunctor/Sum.hs +91/−0
• src/Data/Bifunctor/TH.hs +123/−153
• src/Data/Bifunctor/TH/Internal.hs +9/−5
• src/Data/Bifunctor/Tannen.hs +95/−8
• src/Data/Bifunctor/Wrapped.hs +42/−3
• src/Data/Bitraversable.hs +0/−2
• tests/BifunctorSpec.hs +120/−17

@@ -1,19 +1,17 @@ env:- - GHCVER=7.0.1 CABALVER=1.16- - GHCVER=7.0.4 CABALVER=1.16- - GHCVER=7.2.2 CABALVER=1.16- - GHCVER=7.4.2 CABALVER=1.16- - GHCVER=7.6.3 CABALVER=1.16+ - GHCVER=7.0.4 CABALVER=1.18+ - GHCVER=7.2.2 CABALVER=1.18+ - GHCVER=7.4.2 CABALVER=1.18+ - GHCVER=7.6.3 CABALVER=1.18  - GHCVER=7.8.4 CABALVER=1.18- - GHCVER=7.10.1 CABALVER=1.22+ - GHCVER=7.10.3 CABALVER=1.22  - GHCVER=head CABALVER=1.22  matrix:   allow_failures:-   - env: GHCVER=head CABALVER=1.20-   - env: GHCVER=7.0.1 CABALVER=1.16-   - env: GHCVER=7.0.4 CABALVER=1.16-   - env: GHCVER=7.2.2 CABALVER=1.16+   - env: GHCVER=head CABALVER=1.22+   - env: GHCVER=7.0.4 CABALVER=1.18+   - env: GHCVER=7.2.2 CABALVER=1.18  before_install:  - travis_retry sudo add-apt-repository -y ppa:hvr/ghc

@@ -1,3 +1,9 @@+5.2+-----+* Added several `Arrow`-like instances for `Tannen` so we can use it as the Cayley construction if needed.+* Added `Data.Bifunctor.Sum`+* Added `BifunctorFunctor`, `BifunctorMonad` and `BifunctorComonad`.+ 5.1 --- * Added `Data.Bifunctor.Fix`

@@ -1,4 +1,4 @@-Copyright 2008-2015 Edward Kmett+Copyright 2008-2016 Edward Kmett  All rights reserved. 

@@ -1,6 +1,6 @@ name:          bifunctors category:      Data, Functors-version:       5.1+version:       5.2 license:       BSD3 cabal-version: >= 1.8 license-file:  LICENSE@@ -9,11 +9,11 @@ stability:     provisional homepage:      http://github.com/ekmett/bifunctors/ bug-reports:   http://github.com/ekmett/bifunctors/issues-copyright:     Copyright (C) 2008-2015 Edward A. Kmett+copyright:     Copyright (C) 2008-2016 Edward A. Kmett synopsis:      Bifunctors description:   Bifunctors build-type:    Simple-tested-with:   GHC == 7.0.1, GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.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 extra-source-files: .travis.yml CHANGELOG.markdown README.markdown  source-repository head@@ -40,8 +40,10 @@   hs-source-dirs: src   build-depends:     base             >= 4   && < 5,+    comonad          >= 4   && < 6,     containers       >= 0.1 && < 0.6,-    template-haskell >= 2.4 && < 2.11+    template-haskell >= 2.4 && < 2.12,+    transformers     >= 0.2 && < 0.6    if flag(tagged)     build-depends: tagged >= 0.7.3 && < 1@@ -53,6 +55,9 @@     hs-source-dirs: old-src     exposed-modules: Data.Bifunctor +  if impl(ghc>=7.2) && impl(ghc<7.5)+    build-depends: ghc-prim == 0.2.0.0+   exposed-modules:     Data.Biapplicative     Data.Bifoldable@@ -60,9 +65,11 @@     Data.Bifunctor.Clown     Data.Bifunctor.Fix     Data.Bifunctor.Flip+    Data.Bifunctor.Functor     Data.Bifunctor.Join     Data.Bifunctor.Joker     Data.Bifunctor.Product+    Data.Bifunctor.Sum     Data.Bifunctor.Tannen     Data.Bifunctor.TH     Data.Bifunctor.Wrapped

@@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-}-#endif  #ifndef MIN_VERSION_semigroups #define MIN_VERSION_semigroups(x,y,z) 0@@ -28,6 +26,7 @@   ) where  import Control.Applicative+import Data.Functor.Constant  #if MIN_VERSION_semigroups(0,16,2) import Data.Semigroup@@ -97,7 +96,9 @@  #if __GLASGOW_HASKELL__ >= 708   {-# MINIMAL bimap | first, second #-}+#endif +#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 deriving instance Typeable Bifunctor #endif @@ -137,6 +138,10 @@  instance Bifunctor Const where   bimap f _ (Const a) = Const (f a)+  {-# INLINE bimap #-}++instance Bifunctor Constant where+  bimap f _ (Constant a) = Constant (f a)   {-# INLINE bimap #-}  #ifdef MIN_VERSION_tagged

@@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-}-#endif  #ifndef MIN_VERSION_semigroups #define MIN_VERSION_semigroups(x,y,z) 0@@ -48,7 +46,7 @@ import Data.Tagged #endif -#if __GLASGOW_HASKELL__ >= 708+#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 import Data.Typeable #endif @@ -108,7 +106,9 @@  #if __GLASGOW_HASKELL__ >= 708   {-# MINIMAL bifoldr | bifoldMap #-}+#endif +#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 deriving instance Typeable Bifoldable #endif 

@@ -1,12 +1,22 @@ {-# LANGUAGE CPP #-}--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-} #endif +#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+ ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2008-2015 Edward Kmett+-- Copyright   :  (C) 2008-2016 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -36,13 +46,46 @@ import Data.Typeable #endif +#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif+ -- | Compose two 'Functor's on the inside of a 'Bifunctor'. newtype Biff p f g a b = Biff { runBiff :: p (f a) (g b) }   deriving ( Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 702+           , Generic+#endif #if __GLASGOW_HASKELL__ >= 708            , Typeable #endif            )+#if __GLASGOW_HASKELL__ >= 702+# if __GLASGOW_HASKELL__ >= 708+deriving instance Functor (p (f a)) => Generic1 (Biff p f g a)+# else+data BiffMetaData+data BiffMetaCons+data BiffMetaSel++instance Datatype BiffMetaData where+    datatypeName = const "Biff"+    moduleName = const "Data.Bifunctor.Biff"++instance Constructor BiffMetaCons where+    conName = const "Biff"+    conIsRecord = const True++instance Selector BiffMetaSel where+    selName = const "runBiff"++instance Functor (p (f a)) => Generic1 (Biff p f g a) where+    type Rep1 (Biff p f g a) = D1 BiffMetaData (C1 BiffMetaCons+        (S1 BiffMetaSel (p (f a) :.: Rec1 g)))+    from1 = M1 . M1 . M1 . Comp1 . fmap Rec1 . runBiff+    to1 = Biff . fmap unRec1 . unComp1 . unM1 . unM1 . unM1+# endif+#endif  instance (Bifunctor p, Functor f, Functor g) => Bifunctor (Biff p f g) where   first f = Biff . first (fmap f) . runBiff

@@ -1,12 +1,19 @@ {-# LANGUAGE CPP #-}--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-} #endif +#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+ ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2008-2015 Edward Kmett+-- Copyright   :  (C) 2008-2016 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -38,16 +45,47 @@ import Data.Typeable #endif +#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif+ -- | Make a 'Functor' over the first argument of a 'Bifunctor'. -- -- Mnemonic: C__l__owns to the __l__eft (parameter of the Bifunctor), --           joke__r__s to the __r__ight. newtype Clown f a b = Clown { runClown :: f a }   deriving ( Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 702+           , Generic+#endif #if __GLASGOW_HASKELL__ >= 708+           , Generic1            , Typeable #endif            )++#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708+data ClownMetaData+data ClownMetaCons+data ClownMetaSel++instance Datatype ClownMetaData where+    datatypeName _ = "Clown"+    moduleName _ = "Data.Bifunctor.Clown"++instance Constructor ClownMetaCons where+    conName _ = "Clown"+    conIsRecord _ = True++instance Selector ClownMetaSel where+    selName _ = "runClown"++instance Generic1 (Clown f a) where+    type Rep1 (Clown f a) = D1 ClownMetaData (C1 ClownMetaCons+        (S1 ClownMetaSel (Rec0 (f a))))+    from1 = M1 . M1 . M1 . K1 . runClown+    to1 = Clown . unK1 . unM1 . unM1 . unM1+#endif  instance Functor f => Bifunctor (Clown f) where   first f = Clown . fmap f . runClown

@@ -1,11 +1,21 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+#endif++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Bifunctor.Fix--- Copyright   :  (C) 2008-2015 Edward Kmett+-- Copyright   :  (C) 2008-2016 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -30,13 +40,31 @@ import Data.Traversable #endif +#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif++#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif+ -- | Greatest fixpoint of a 'Bifunctor' (a 'Functor' over the first argument with zipping). newtype Fix p a = In { out :: p (Fix p a) a }+  deriving+    (+#if __GLASGOW_HASKELL__ >= 702+      Generic+#endif+#if __GLASGOW_HASKELL__ >= 708+    , Typeable+#endif+    )  deriving instance Eq   (p (Fix p a) a) => Eq   (Fix p a) deriving instance Ord  (p (Fix p a) a) => Ord  (Fix p a) deriving instance Show (p (Fix p a) a) => Show (Fix p a) deriving instance Read (p (Fix p a) a) => Read (Fix p a)+  instance Bifunctor p => Functor (Fix p) where   fmap f (In p) = In (bimap (fmap f) f p)

@@ -1,13 +1,18 @@ {-# LANGUAGE CPP #-}--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-} #endif +#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Bifunctor.Flip--- Copyright   :  (C) 2008-2015 Edward Kmett+-- Copyright   :  (C) 2008-2016 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -25,6 +30,7 @@  import Data.Biapplicative import Data.Bifoldable+import Data.Bifunctor.Functor import Data.Bitraversable  #if __GLASGOW_HASKELL__ < 710@@ -37,9 +43,16 @@ import Data.Typeable #endif +#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif+ -- | Make a 'Bifunctor' flipping the arguments of a 'Bifunctor'. newtype Flip p a b = Flip { runFlip :: p b a }   deriving ( Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 702+           , Generic+#endif #if __GLASGOW_HASKELL__ >= 708            , Typeable #endif@@ -79,3 +92,6 @@ instance Bitraversable p => Traversable (Flip p a) where   traverse f = fmap Flip . bitraverse f pure . runFlip   {-# INLINE traverse #-}++instance BifunctorFunctor Flip where+  bifmap f (Flip p) = Flip (f p)

@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif++module Data.Bifunctor.Functor+  ( (:->)+  , BifunctorFunctor(..)+  , BifunctorMonad(..)+  , biliftM+  , BifunctorComonad(..)+  , biliftW+  ) where++-- | Using parametricity as an approximation of a natural transformation in two arguments.+type (:->) p q = forall a b. p a b -> q a b+infixr 0 :->++class BifunctorFunctor t where+  bifmap :: (p :-> q) -> t p :-> t q++class BifunctorFunctor t => BifunctorMonad t where+  bireturn :: p :-> t p+  bibind   :: (p :-> t q) -> t p :-> t q+  bibind f = bijoin . bifmap f+  bijoin   :: t (t p) :-> t p+  bijoin = bibind id+#if __GLASGOW_HASKELL__ >= 708+  {-# MINIMAL bireturn, (bibind | bijoin) #-}+#endif++biliftM :: BifunctorMonad t => (p :-> q) -> t p :-> t q+biliftM f = bibind (bireturn . f)+{-# INLINE biliftM #-}++class BifunctorFunctor t => BifunctorComonad t where+  biextract :: t p :-> p+  biextend :: (t p :-> q) -> t p :-> t q+  biextend f = bifmap f . biduplicate+  biduplicate :: t p :-> t (t p)+  biduplicate =  biextend id+#if __GLASGOW_HASKELL__ >= 708+  {-# MINIMAL biextract, (biextend | biduplicate) #-}+#endif++biliftW :: BifunctorComonad t => (p :-> q) -> t p :-> t q+biliftW f = biextend (f . biextract)+{-# INLINE biliftW #-}

@@ -1,15 +1,20 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE DeriveDataTypeable #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-} #endif +#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+ ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2008-2015 Edward Kmett+-- Copyright   :  (C) 2008-2016 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -38,11 +43,21 @@ import Data.Typeable #endif +#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif+ -- | Make a 'Functor' over both arguments of a 'Bifunctor'. newtype Join p a = Join { runJoin :: p a a }+  deriving+    (+#if __GLASGOW_HASKELL__ >= 702+      Generic+#endif #if __GLASGOW_HASKELL__ >= 708-  deriving Typeable+    , Typeable #endif+    )  deriving instance Eq   (p a a) => Eq   (Join p a) deriving instance Ord  (p a a) => Ord  (Join p a)

@@ -1,11 +1,19 @@ {-# LANGUAGE CPP #-}--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-} #endif++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+ ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2008-2015 Edward Kmett+-- Copyright   :  (C) 2008-2016 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -36,16 +44,47 @@ import Data.Typeable #endif +#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif+ -- | Make a 'Functor' over the second argument of a 'Bifunctor'. -- -- Mnemonic: C__l__owns to the __l__eft (parameter of the Bifunctor), --           joke__r__s to the __r__ight. newtype Joker g a b = Joker { runJoker :: g b }   deriving ( Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 702+           , Generic+#endif #if __GLASGOW_HASKELL__ >= 708+           , Generic1            , Typeable #endif            )++#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708+data JokerMetaData+data JokerMetaCons+data JokerMetaSel++instance Datatype JokerMetaData where+    datatypeName _ = "Joker"+    moduleName _ = "Data.Bifunctor.Joker"++instance Constructor JokerMetaCons where+    conName _ = "Joker"+    conIsRecord _ = True++instance Selector JokerMetaSel where+    selName _ = "runJoker"++instance Generic1 (Joker g a) where+    type Rep1 (Joker g a) = D1 JokerMetaData (C1 JokerMetaCons+        (S1 JokerMetaSel (Rec1 g)))+    from1 = M1 . M1 . M1 . Rec1 . runJoker+    to1 = Joker . unRec1 . unM1 . unM1 . unM1+#endif  instance Functor g => Bifunctor (Joker g) where   first _ = Joker . runJoker

@@ -1,11 +1,19 @@ {-# LANGUAGE CPP #-}--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-} #endif++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+ ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2008-2015 Jesse Selover, Edward Kmett+-- Copyright   :  (C) 2008-2016 Jesse Selover, Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -24,6 +32,7 @@  import Data.Biapplicative import Data.Bifoldable+import Data.Bifunctor.Functor import Data.Bitraversable  #if __GLASGOW_HASKELL__ < 710@@ -34,14 +43,41 @@ import Data.Typeable #endif +#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif+ -- | Form the product of two bifunctors data Product f g a b = Pair (f a b) (g a b)   deriving ( Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 702+           , Generic+#endif #if __GLASGOW_HASKELL__ >= 708+           , Generic1            , Typeable #endif            ) +#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708+data ProductMetaData+data ProductMetaCons++instance Datatype ProductMetaData where+    datatypeName _ = "Product"+    moduleName _ = "Data.Bifunctor.Product"++instance Constructor ProductMetaCons where+    conName _ = "Pair"++instance Generic1 (Product f g a) where+    type Rep1 (Product f g a) = D1 ProductMetaData (C1 ProductMetaCons ((:*:)+        (S1 NoSelector (Rec1 (f a)))+        (S1 NoSelector (Rec1 (g a)))))+    from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g)))+    to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g)+#endif+ instance (Bifunctor f, Bifunctor g) => Bifunctor (Product f g) where   first f (Pair x y) = Pair (first f x) (first f y)   {-# INLINE first #-}@@ -63,3 +99,11 @@ instance (Bitraversable f, Bitraversable g) => Bitraversable (Product f g) where   bitraverse f g (Pair x y) = Pair <$> bitraverse f g x <*> bitraverse f g y   {-# INLINE bitraverse #-}++instance BifunctorFunctor (Product p) where+  bifmap f (Pair p q) = Pair p (f q)++instance BifunctorComonad (Product p) where+  biextract (Pair _ q) = q+  biduplicate pq@(Pair p _) = Pair p pq+  biextend f pq@(Pair p _) = Pair p (f pq)

@@ -0,0 +1,91 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+#endif++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif++module Data.Bifunctor.Sum where++import Data.Bifunctor+import Data.Bifunctor.Functor+import Data.Bifoldable+import Data.Bitraversable+#if __GLASGOW_HASKELL__ < 710+import Data.Functor+#endif+#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif+#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif++data Sum p q a b = L2 (p a b) | R2 (q a b)+  deriving ( Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 702+           , Generic+#endif+#if __GLASGOW_HASKELL__ >= 708+           , Generic1+           , Typeable+#endif+           )++#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708+data SumMetaData+data SumMetaConsL2+data SumMetaConsR2++instance Datatype SumMetaData where+    datatypeName _ = "Sum"+    moduleName _ = "Data.Bifunctor.Sum"++instance Constructor SumMetaConsL2 where+    conName _ = "L2"++instance Constructor SumMetaConsR2 where+    conName _ = "R2"++instance Generic1 (Sum p q a) where+    type Rep1 (Sum p q a) = D1 SumMetaData ((:+:)+        (C1 SumMetaConsL2 (S1 NoSelector (Rec1 (p a))))+        (C1 SumMetaConsR2 (S1 NoSelector (Rec1 (q a)))))+    from1 (L2 p) = M1 (L1 (M1 (M1 (Rec1 p))))+    from1 (R2 q) = M1 (R1 (M1 (M1 (Rec1 q))))+    to1 (M1 (L1 (M1 (M1 p)))) = L2 (unRec1 p)+    to1 (M1 (R1 (M1 (M1 q)))) = R2 (unRec1 q)+#endif++instance (Bifunctor p, Bifunctor q) => Bifunctor (Sum p q) where+  bimap f g (L2 p) = L2 (bimap f g p)+  bimap f g (R2 q) = R2 (bimap f g q)+  first f (L2 p) = L2 (first f p)+  first f (R2 q) = R2 (first f q)+  second f (L2 p) = L2 (second f p)+  second f (R2 q) = R2 (second f q)++instance (Bifoldable p, Bifoldable q) => Bifoldable (Sum p q) where+  bifoldMap f g (L2 p) = bifoldMap f g p+  bifoldMap f g (R2 q) = bifoldMap f g q++instance (Bitraversable p, Bitraversable q) => Bitraversable (Sum p q) where+  bitraverse f g (L2 p) = L2 <$> bitraverse f g p+  bitraverse f g (R2 q) = R2 <$> bitraverse f g q++instance BifunctorFunctor (Sum p) where+  bifmap _ (L2 p) = L2 p+  bifmap f (R2 q) = R2 (f q)++instance BifunctorMonad (Sum p) where+  bireturn = R2+  bijoin (L2 p) = L2 p+  bijoin (R2 q) = q+  bibind _ (L2 p) = L2 p+  bibind f (R2 q) = f q

@@ -7,7 +7,7 @@ #endif ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2008-2015 Edward Kmett, (C) 2015 Ryan Scott+-- Copyright   :  (C) 2008-2016 Edward Kmett, (C) 2015 Ryan Scott -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -276,56 +276,18 @@  -- | Derive a class instance declaration (depending on the BiClass argument's value). deriveBiClass :: BiClass -> Name -> Q [Dec]-deriveBiClass biClass tyConName = do-  info <- reify tyConName-  case info of-    TyConI{} -> deriveBiClassPlainTy biClass tyConName-#if MIN_VERSION_template_haskell(2,7,0)-    DataConI{} -> deriveBiClassDataFamInst biClass tyConName-    FamilyI (FamilyD DataFam _ _ _) _ ->-      error $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead."-    FamilyI (FamilyD TypeFam _ _ _) _ ->-      error $ ns ++ "Cannot use a type family name."-    _ -> error $ ns ++ "The name must be of a plain type constructor or data family instance constructor."-#else-      DataConI{} -> dataConIError-      _          -> error $ ns ++ "The name must be of a plain type constructor."-#endif-  where-    ns :: String-    ns = "Data.Bifunctor.TH.deriveBiClass: "---- | Generates a class instance declaration for a plain type constructor.-deriveBiClassPlainTy :: BiClass -> Name -> Q [Dec]-deriveBiClassPlainTy biClass tyConName = withTyCon tyConName fromCons where-  className :: Name-  className = biClassName biClass--  fromCons :: Cxt -> [TyVarBndr] -> [Con] -> Q [Dec]-  fromCons ctxt tvbs cons = (:[]) `fmap`-    instanceD (return instanceCxt)-              (return $ AppT (ConT className) instanceType)-              (biFunDecs biClass droppedNbs cons)-    where-      (instanceCxt, instanceType, droppedNbs) =-        cxtAndTypePlainTy biClass tyConName ctxt tvbs--#if MIN_VERSION_template_haskell(2,7,0)--- | Generates a class instance declaration for a data family instance constructor.-deriveBiClassDataFamInst :: BiClass -> Name -> Q [Dec]-deriveBiClassDataFamInst biClass dataFamInstName = withDataFamInstCon dataFamInstName fromDec where-  className :: Name-  className = biClassName biClass--  fromDec :: [TyVarBndr] -> Cxt -> Name -> [Type] -> [Con] -> Q [Dec]-  fromDec famTvbs ctxt parentName instTys cons = (:[]) `fmap`+deriveBiClass biClass name = withType name fromCons where+  fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec]+  fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap`     instanceD (return instanceCxt)-              (return $ AppT (ConT className) instanceType)+              (return instanceType)               (biFunDecs biClass droppedNbs cons)     where+      instanceCxt  :: Cxt+      instanceType :: Type+      droppedNbs   :: [NameBase]       (instanceCxt, instanceType, droppedNbs) =-          cxtAndTypeDataFamInstCon biClass parentName ctxt famTvbs instTys-#endif+        buildTypeInstance biClass name' ctxt tvbs mbTys  -- | Generates a declaration defining the primary function(s) corresponding to a -- particular class (bimap for Bifunctor, bifoldr and bifoldMap for Bifoldable, and@@ -344,28 +306,11 @@  -- | Generates a lambda expression which behaves like the BiFun argument. makeBiFun :: BiFun -> Name -> Q Exp-makeBiFun biFun tyConName = do-  info <- reify tyConName-  case info of-    TyConI{} -> withTyCon tyConName $ \ctxt tvbs decs ->-      let !nbs = thd3 $ cxtAndTypePlainTy (biFunToClass biFun) tyConName ctxt tvbs-      in makeBiFunForCons biFun nbs decs-#if MIN_VERSION_template_haskell(2,7,0)-    DataConI{} -> withDataFamInstCon tyConName $ \famTvbs ctxt parentName instTys cons ->-      let !nbs = thd3 $ cxtAndTypeDataFamInstCon (biFunToClass biFun) parentName ctxt famTvbs instTys-      in makeBiFunForCons biFun nbs cons-    FamilyI (FamilyD DataFam _ _ _) _ ->-      error $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead."-    FamilyI (FamilyD TypeFam _ _ _) _ ->-      error $ ns ++ "Cannot use a type family name."-    _ -> error $ ns ++ "The name must be of a plain type constructor or data family instance constructor."-#else-    DataConI{} -> dataConIError-    _          -> error $ ns ++ "The name must be of a plain type constructor."-#endif-  where-    ns :: String-    ns = "Data.Bifunctor.TH.makeBiFun: "+makeBiFun biFun name = withType name fromCons where+  fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp+  fromCons name' ctxt tvbs cons mbTys =+    let !nbs = thd3 $ buildTypeInstance (biFunToClass biFun) name' ctxt tvbs mbTys+    in makeBiFunForCons biFun nbs cons  -- | Generates a lambda expression for the given constructors. -- All constructors must be from the same type.@@ -531,76 +476,108 @@ -- Template Haskell reifying and AST manipulation ------------------------------------------------------------------------------- --- | Extracts a plain type constructor's information.-withTyCon :: Name-          -> (Cxt -> [TyVarBndr] -> [Con] -> Q a)-          -> Q a-withTyCon name f = do+-- | Boilerplate for top level splices.+--+-- The given Name must meet one of two criteria:+--+-- 1. It must be the name of a type constructor of a plain data type or newtype.+-- 2. It must be the name of a data family instance or newtype instance constructor.+--+-- Any other value will result in an exception.+withType :: Name+         -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)+         -> Q a+withType name f = do   info <- reify name   case info of     TyConI dec ->       case dec of-        DataD    ctxt _ tvbs cons _ -> f ctxt tvbs cons-        NewtypeD ctxt _ tvbs con  _ -> f ctxt tvbs [con]-        _ -> error $ ns ++ "Unsupported type " ++ show dec ++ ". Must be a data type or newtype."-    _ -> error $ ns ++ "The name must be of a plain type constructor."-  where-    ns :: String-    ns = "Data.Bifunctor.TH.withTyCon: "-+        DataD ctxt _ tvbs+#if MIN_VERSION_template_haskell(2,11,0)+              _+#endif+              cons _ -> f name ctxt tvbs cons Nothing+        NewtypeD ctxt _ tvbs+#if MIN_VERSION_template_haskell(2,11,0)+                 _+#endif+                 con _ -> f name ctxt tvbs [con] Nothing+        _ -> error $ ns ++ "Unsupported type: " ++ show dec #if MIN_VERSION_template_haskell(2,7,0)--- | Extracts a data family name's information.-withDataFam :: Name-            -> ([TyVarBndr] -> [Dec] -> Q a)-            -> Q a-withDataFam name f = do-  info <- reify name-  case info of-    FamilyI (FamilyD DataFam _ tvbs _) decs -> f tvbs decs-    FamilyI (FamilyD TypeFam _ _    _) _    -> error $ ns ++ "Cannot use a type family name."-    _ -> error $ ns ++ "Unsupported type " ++ show info ++ ". Must be a data family name."-  where-    ns :: String-    ns = "Data.Bifunctor.TH.withDataFam: "---- | Extracts a data family instance constructor's information.-withDataFamInstCon :: Name-                   -> ([TyVarBndr] -> Cxt -> Name -> [Type] -> [Con] -> Q a)-                   -> Q a-withDataFamInstCon dficName f = do-  dficInfo <- reify dficName-  case dficInfo of+# if MIN_VERSION_template_haskell(2,11,0)+    DataConI _ _ parentName   -> do+# else     DataConI _ _ parentName _ -> do+# endif       parentInfo <- reify parentName       case parentInfo of-        FamilyI (FamilyD DataFam _ _ _) _ -> withDataFam parentName $ \famTvbs decs ->-          let sameDefDec = flip find decs $ \dec ->-                case dec of-                  DataInstD    _ _ _ cons' _ -> any ((dficName ==) . constructorName) cons'-                  NewtypeInstD _ _ _ con   _ -> dficName == constructorName con-                  _ -> error $ ns ++ "Must be a data or newtype instance."--              (ctxt, instTys, cons) = case sameDefDec of-                Just (DataInstD    ctxt' _ instTys' cons' _) -> (ctxt', instTys', cons')-                Just (NewtypeInstD ctxt' _ instTys' con   _) -> (ctxt', instTys', [con])-                _ -> error $ ns ++ "Could not find data or newtype instance constructor."--          in f famTvbs ctxt parentName instTys cons-        _ -> error $ ns ++ "Data constructor " ++ show dficName ++ " is not from a data family instance."-    _ -> error $ ns ++ "Unsupported type " ++ show dficInfo ++ ". Must be a data family instance constructor."+# if MIN_VERSION_template_haskell(2,11,0)+        FamilyI (DataFamilyD _ tvbs _) decs ->+# else+        FamilyI (FamilyD DataFam _ tvbs _) decs ->+# endif+          let instDec = flip find decs $ \dec -> case dec of+                DataInstD _ _ _+# if MIN_VERSION_template_haskell(2,11,0)+                          _+# endif+                          cons _ -> any ((name ==) . constructorName) cons+                NewtypeInstD _ _ _+# if MIN_VERSION_template_haskell(2,11,0)+                             _+# endif+                             con _ -> name == constructorName con+                _ -> error $ ns ++ "Must be a data or newtype instance."+           in case instDec of+                Just (DataInstD ctxt _ instTys+# if MIN_VERSION_template_haskell(2,11,0)+                                _+# endif+                                cons _)+                  -> f parentName ctxt tvbs cons $ Just instTys+                Just (NewtypeInstD ctxt _ instTys+# if MIN_VERSION_template_haskell(2,11,0)+                                   _+# endif+                                   con _)+                  -> f parentName ctxt tvbs [con] $ Just instTys+                _ -> error $ ns +++                  "Could not find data or newtype instance constructor."+        _ -> error $ ns ++ "Data constructor " ++ show name +++          " is not from a data family instance constructor."+# if MIN_VERSION_template_haskell(2,11,0)+    FamilyI DataFamilyD{} _ ->+# else+    FamilyI (FamilyD DataFam _ _ _) _ ->+# endif+      error $ ns +++        "Cannot use a data family name. Use a data family instance constructor instead."+    _ -> error $ ns ++ "The name must be of a plain data type constructor, "+                    ++ "or a data family instance constructor."+#else+    DataConI{} -> dataConIError+    _          -> error $ ns ++ "The name must be of a plain type constructor."+#endif   where     ns :: String-    ns = "Data.Bifunctor.TH.withDataFamInstCon: "-#endif+    ns = "Data.Bifunctor.TH.withType: "  -- | Deduces the instance context, instance head, and eta-reduced type variables--- for a plain data type constructor.-cxtAndTypePlainTy :: BiClass     -- Bifunctor, Bifoldable, or Bitraversable-                  -> Name        -- The datatype's name-                  -> Cxt         -- The datatype context-                  -> [TyVarBndr] -- The type variables+-- for an instance.+buildTypeInstance :: BiClass+                  -- ^ Bifunctor, Bifoldable, or Bitraversable+                  -> Name+                  -- ^ The type constructor or data family name+                  -> Cxt+                  -- ^ The datatype context+                  -> [TyVarBndr]+                  -- ^ The type variables from the data type/data family declaration+                  -> Maybe [Type]+                  -- ^ 'Just' the types used to instantiate a data family instance,+                  -- or 'Nothing' if it's a plain data type                   -> (Cxt, Type, [NameBase])-cxtAndTypePlainTy biClass tyConName dataCxt tvbs+-- Plain data type/newtype case+buildTypeInstance biClass tyConName dataCxt tvbs Nothing   | remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables   = derivingKindError biClass tyConName   | any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable(s) are mentioned in a datatype context@@ -611,7 +588,9 @@     instanceCxt = mapMaybe (applyConstraint biClass) remaining      instanceType :: Type-    instanceType = applyTyCon tyConName $ map (VarT . tvbName) remaining+    instanceType = AppT (ConT $ biClassName biClass)+                 . applyTyCon tyConName+                 $ map (VarT . tvbName) remaining      remainingLength :: Int     remainingLength = length tvbs - 2@@ -624,17 +603,8 @@      droppedNbs :: [NameBase]     droppedNbs = map (NameBase . tvbName) dropped--#if MIN_VERSION_template_haskell(2,7,0)--- | Deduces the instance context, instance head, and eta-reduced type variables--- for a data family instance constructor.-cxtAndTypeDataFamInstCon :: BiClass     -- Bifunctor, Bifoldable, or Bitraversable-                         -> Name        -- The data family name-                         -> Cxt         -- The datatype context-                         -> [TyVarBndr] -- The data family declaration's type variables-                         -> [Type]      -- The data family instance types-                         -> (Cxt, Type, [NameBase])-cxtAndTypeDataFamInstCon biClass parentName dataCxt famTvbs instTysAndKinds+-- Data family instance case+buildTypeInstance biClass parentName dataCxt tvbs (Just instTysAndKinds)   | remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables   = derivingKindError biClass parentName   | any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable(s) are mentioned in a datatype context@@ -655,17 +625,18 @@     --     -- To do this, we remove every kind ascription (i.e., strip off every 'SigT').     instanceType :: Type-    instanceType = applyTyCon parentName+    instanceType = AppT (ConT $ biClassName biClass)+                 . applyTyCon parentName                  $ map unSigT remaining      remainingLength :: Int-    remainingLength = length famTvbs - 2+    remainingLength = length tvbs - 2      remaining, dropped :: [Type]     (remaining, dropped) = splitAt remainingLength rhsTypes      droppedKinds :: [Kind]-    droppedKinds = map tvbKind . snd $ splitAt remainingLength famTvbs+    droppedKinds = map tvbKind . snd $ splitAt remainingLength tvbs      droppedNbs :: [NameBase]     droppedNbs = map varTToNameBase dropped@@ -682,18 +653,18 @@     -- then dropping that number of entries from @instTysAndKinds@.     instTypes :: [Type]     instTypes =-# if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))+#if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))       instTysAndKinds-# else-      drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) famTvbs)+#else+      drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) tvbs)         instTysAndKinds-# endif+#endif      lhsTvbs :: [TyVarBndr]     lhsTvbs = map (uncurry replaceTyVarName)             . filter (isTyVar . snd)             . take remainingLength-            $ zip famTvbs rhsTypes+            $ zip tvbs rhsTypes      -- In GHC 7.8, only the @Type@s up to the rightmost non-eta-reduced type variable     -- in @instTypes@ are provided (as a result of a bug reported in Trac #9692). This@@ -724,16 +695,15 @@     -- Thankfully, other versions of GHC don't seem to have this bug.     rhsTypes :: [Type]     rhsTypes =-# if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710-      instTypes ++ map tvbToType (drop (length instTypes) famTvbs)-# else+#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710+      instTypes ++ map tvbToType (drop (length instTypes) tvbs)+#else       instTypes-# endif #endif  -- | Given a TyVarBndr, apply a certain constraint to it, depending on its kind. applyConstraint :: BiClass -> TyVarBndr -> Maybe Pred-applyConstraint _       (PlainTV  _)         = Nothing+applyConstraint _       PlainTV{}            = Nothing applyConstraint biClass (KindedTV name kind) = do   constraint <- biClassConstraint biClass $ numKindArrows kind   if canRealizeKindStarChain kind@@ -812,14 +782,14 @@   . showString " only in the last argument(s) of a data type"   $ "" -#if MIN_VERSION_template_haskell(2,7,0) -- | One of the last type variables cannot be eta-reduced (see the canEtaReduce -- function for the criteria it would have to meet). etaReductionError :: Type -> a etaReductionError instanceType = error $   "Cannot eta-reduce to an instance of form \n\tinstance (...) => "   ++ pprint instanceType-#else++#if !(MIN_VERSION_template_haskell(2,7,0)) -- | Template Haskell didn't list all of a data family's instances upon reification -- until template-haskell-2.7.0.0, which is necessary for a derived instance to work. dataConIError :: a

@@ -2,7 +2,7 @@  {-| Module:      Data.Bifunctor.TH.Internal-Copyright:   (C) 2008-2015 Edward Kmett, (C) 2015 Ryan Scott+Copyright:   (C) 2008-2016 Edward Kmett, (C) 2015 Ryan Scott License:     BSD-style (see the file LICENSE) Maintainer:  Edward Kmett Portability: Template Haskell@@ -13,9 +13,8 @@  import           Data.Function (on) import           Data.List-import qualified Data.Map as Map (fromList, lookup)+import qualified Data.Map as Map (fromList, findWithDefault) import           Data.Map (Map)-import           Data.Maybe import qualified Data.Set as Set import           Data.Set (Set) @@ -69,7 +68,7 @@  subst :: Subst -> Type -> Type subst subs (ForallT v c t) = ForallT v c $ subst subs t-subst subs t@(VarT n)      = fromMaybe t $ Map.lookup n subs+subst subs t@(VarT n)      = Map.findWithDefault t n subs subst subs (AppT t1 t2)    = AppT (subst subs t1) (subst subs t2) subst subs (SigT t k)      = SigT (subst subs t) k subst _ t                  = t@@ -217,10 +216,15 @@ isTyFamily (ConT n) = do     info <- reify n     return $ case info of-#if MIN_VERSION_template_haskell(2,7,0)+#if MIN_VERSION_template_haskell(2,11,0)+         FamilyI OpenTypeFamilyD{} _       -> True+#elif MIN_VERSION_template_haskell(2,7,0)          FamilyI (FamilyD TypeFam _ _ _) _ -> True #else          TyConI  (FamilyD TypeFam _ _ _)   -> True+#endif+#if MIN_VERSION_template_haskell(2,9,0)+         FamilyI ClosedTypeFamilyD{} _     -> True #endif          _ -> False isTyFamily _ = return False

@@ -1,12 +1,22 @@ {-# LANGUAGE CPP #-}--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-} #endif +#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+ ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2008-2015 Edward Kmett+-- Copyright   :  (C) 2008-2016 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -18,10 +28,14 @@   ( Tannen(..)   ) where -#if __GLASGOW_HASKELL__ < 710 import Control.Applicative-#endif +import Control.Arrow as A+import Control.Category+import Control.Comonad++import Data.Bifunctor as B+import Data.Bifunctor.Functor import Data.Biapplicative import Data.Bifoldable import Data.Bitraversable@@ -36,24 +50,70 @@ import Data.Typeable #endif +#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif++import Prelude hiding ((.),id)+ -- | Compose a 'Functor' on the outside of a 'Bifunctor'. newtype Tannen f p a b = Tannen { runTannen :: f (p a b) }   deriving ( Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 702+           , Generic+#endif #if __GLASGOW_HASKELL__ >= 708            , Typeable #endif            )+#if __GLASGOW_HASKELL__ >= 702+# if __GLASGOW_HASKELL__ >= 708+deriving instance Functor f => Generic1 (Tannen f p a)+# else+data TannenMetaData+data TannenMetaCons+data TannenMetaSel +instance Datatype TannenMetaData where+    datatypeName _ = "Tannen"+    moduleName _ = "Data.Bifunctor.Tannen"++instance Constructor TannenMetaCons where+    conName _ = "Tannen"+    conIsRecord _ = True++instance Selector TannenMetaSel where+    selName _ = "runTannen"++instance Functor f => Generic1 (Tannen f p a) where+    type Rep1 (Tannen f p a) = D1 TannenMetaData (C1 TannenMetaCons+        (S1 TannenMetaSel (f :.: Rec1 (p a))))+    from1 = M1 . M1 . M1 . Comp1 . fmap Rec1 . runTannen+    to1 = Tannen . fmap unRec1 . unComp1 . unM1 . unM1 . unM1+# endif+#endif++instance Functor f => BifunctorFunctor (Tannen f) where+  bifmap f (Tannen fp) = Tannen (fmap f fp)++instance (Functor f, Monad f) => BifunctorMonad (Tannen f) where+  bireturn = Tannen . return+  bibind f (Tannen fp) = Tannen $ fp >>= runTannen . f++instance Comonad f => BifunctorComonad (Tannen f) where+  biextract = extract . runTannen+  biextend f (Tannen fp) = Tannen (extend (f . Tannen) fp)+ instance (Functor f, Bifunctor p) => Bifunctor (Tannen f p) where-  first f = Tannen . fmap (first f) . runTannen+  first f = Tannen . fmap (B.first f) . runTannen   {-# INLINE first #-}-  second f = Tannen . fmap (second f) . runTannen+  second f = Tannen . fmap (B.second f) . runTannen   {-# INLINE second #-}   bimap f g = Tannen . fmap (bimap f g) . runTannen   {-# INLINE bimap #-}  instance (Functor f, Bifunctor p) => Functor (Tannen f p a) where-  fmap f = Tannen . fmap (second f) . runTannen+  fmap f = Tannen . fmap (B.second f) . runTannen   {-# INLINE fmap #-}  instance (Applicative f, Biapplicative p) => Biapplicative (Tannen f p) where@@ -78,3 +138,30 @@ instance (Traversable f, Bitraversable p) => Bitraversable (Tannen f p) where   bitraverse f g = fmap Tannen . traverse (bitraverse f g) . runTannen   {-# INLINE bitraverse #-}++instance (Applicative f, Category p) => Category (Tannen f p) where+  id = Tannen $ pure id+  Tannen fpbc . Tannen fpab = Tannen $ liftA2 (.) fpbc fpab++instance (Applicative f, Arrow p) => Arrow (Tannen f p) where+  arr f = Tannen $ pure $ arr f+  first = Tannen . fmap A.first . runTannen+  second = Tannen . fmap A.second . runTannen+  Tannen ab *** Tannen cd = Tannen $ liftA2 (***) ab cd+  Tannen ab &&& Tannen ac = Tannen $ liftA2 (&&&) ab ac++instance (Applicative f, ArrowChoice p) => ArrowChoice (Tannen f p) where+  left  = Tannen . fmap left . runTannen+  right = Tannen . fmap right . runTannen+  Tannen ab +++ Tannen cd = Tannen $ liftA2 (+++) ab cd+  Tannen ac ||| Tannen bc = Tannen $ liftA2 (|||) ac bc++instance (Applicative f, ArrowLoop p) => ArrowLoop (Tannen f p) where+  loop = Tannen . fmap loop . runTannen++instance (Applicative f, ArrowZero p) => ArrowZero (Tannen f p) where+  zeroArrow = Tannen $ pure zeroArrow++instance (Applicative f, ArrowPlus p) => ArrowPlus (Tannen f p) where+  Tannen f <+> Tannen g = Tannen (liftA2 (<+>) f g)+

@@ -1,12 +1,19 @@ {-# LANGUAGE CPP #-}--#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-} #endif +#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif+ ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2008-2015 Edward Kmett+-- Copyright   :  (C) 2008-2016 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -36,13 +43,45 @@ import Data.Typeable #endif +#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics+#endif+ -- | Make a 'Functor' over the second argument of a 'Bifunctor'. newtype WrappedBifunctor p a b = WrapBifunctor { unwrapBifunctor :: p a b }   deriving ( Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 702+           , Generic+#endif #if __GLASGOW_HASKELL__ >= 708+           , Generic1            , Typeable #endif            )++#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708+data WrappedBifunctorMetaData+data WrappedBifunctorMetaCons+data WrappedBifunctorMetaSel++instance Datatype WrappedBifunctorMetaData where+    datatypeName = const "WrappedBifunctor"+    moduleName = const "Data.Bifunctor.Wrapped"++instance Constructor WrappedBifunctorMetaCons where+    conName = const "WrapBifunctor"+    conIsRecord = const True++instance Selector WrappedBifunctorMetaSel where+    selName = const "unwrapBifunctor"++instance Generic1 (WrappedBifunctor p a) where+    type Rep1 (WrappedBifunctor p a) = D1 WrappedBifunctorMetaData+        (C1 WrappedBifunctorMetaCons+            (S1 WrappedBifunctorMetaSel (Rec1 (p a))))+    from1 = M1 . M1 . M1 . Rec1 . unwrapBifunctor+    to1 = WrapBifunctor . unRec1 . unM1 . unM1 . unM1+#endif  instance Bifunctor p => Bifunctor (WrappedBifunctor p) where   first f = WrapBifunctor . first f . unwrapBifunctor

@@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-}-#endif  #ifndef MIN_VERSION_semigroups #define MIN_VERSION_semigroups(x,y,z) 0

@@ -47,6 +47,8 @@ -- Adapted from the test cases from -- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch +-- Plain data types+ data Strange a b c     = T1 a b c     | T2 [a] [b] [c]         -- lists@@ -90,8 +92,62 @@     | forall f. Bitraversable f => ExistentialFunctor (f a b)     | forall b. SneakyUseSameName (Maybe b) +-- Data families++data family   StrangeFam a  b c+data instance StrangeFam a  b c+    = T1Fam a b c+    | T2Fam [a] [b] [c]         -- lists+    | T3Fam [[a]] [[b]] [[c]]   -- nested lists+    | T4Fam (c,(b,b),(c,c))     -- tuples+    | T5Fam ([c],Strange a b c) -- tycons++data family   StrangeFunctionsFam a b c+data instance StrangeFunctionsFam a b c+    = T6Fam (a -> c)            -- function types+    | T7Fam (a -> (c,a))        -- functions and tuples+    | T8Fam ((b -> a) -> c)     -- continuation+    | T9Fam (IntFun b c)        -- type synonyms++data family   StrangeGADTFam a b+data instance StrangeGADTFam a b where+    T10Fam :: Ord b            => b        -> StrangeGADTFam a b+    T11Fam ::                     Int      -> StrangeGADTFam a Int+    T12Fam :: c ~ Int          => c        -> StrangeGADTFam a Int+    T13Fam :: b ~ Int          => Int      -> StrangeGADTFam a b+    T14Fam :: b ~ Int          => b        -> StrangeGADTFam a b+    T15Fam :: (b ~ c, c ~ Int) => Int -> c -> StrangeGADTFam a b++data family   NotPrimitivelyRecursiveFam a b+data instance NotPrimitivelyRecursiveFam a b+    = S1Fam (NotPrimitivelyRecursive (a,a) (b, a))+    | S2Fam a+    | S3Fam b++data family      OneTwoComposeFam (f :: * -> *) (g :: * -> * -> *) a b+newtype instance OneTwoComposeFam f g a b = OneTwoComposeFam (f (g a b))+  deriving (Arbitrary, Eq, Show)++data family      ComplexConstraintFam (f :: * -> * -> * -> *) (g :: * -> *) a b+newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b))++data family   UniversalFam a b+data instance UniversalFam a b+    = UniversalFam  (forall b. (b,[a]))+    | Universal2Fam (forall f. Bifunctor f => f a b)+    | Universal3Fam (forall a. Maybe a) -- reuse a+    | NotReallyUniversalFam (forall b. a)++data family   ExistentialFam a b+data instance ExistentialFam a b+    = forall a. ExistentialListFam [a]+    | forall f. Bitraversable f => ExistentialFunctorFam (f a b)+    | forall b. SneakyUseSameNameFam (Maybe b)+ ------------------------------------------------------------------------------- +-- Plain data types+ $(deriveBifunctor     ''Strange) $(deriveBifoldable    ''Strange) $(deriveBitraversable ''Strange)@@ -124,6 +180,42 @@ $(deriveBifoldable    ''Existential) $(deriveBitraversable ''Existential) +#if MIN_VERSION_template_haskell(2,7,0)+-- Data families++$(deriveBifunctor     'T1Fam)+$(deriveBifoldable    'T2Fam)+$(deriveBitraversable 'T3Fam)++$(deriveBifunctor     'T6Fam)+$(deriveBifoldable    'T10Fam)++$(deriveBifunctor     'S1Fam)+$(deriveBifoldable    'S2Fam)+$(deriveBitraversable 'S3Fam)++$(deriveBifunctor     'OneTwoComposeFam)+$(deriveBifoldable    'OneTwoComposeFam)+$(deriveBitraversable 'OneTwoComposeFam)++instance (Bifunctor (f Int), Functor g) =>+  Bifunctor (ComplexConstraintFam f g) where+    bimap = $(makeBimap 'ComplexConstraintFam)+instance (Bifoldable (f Int), Foldable g) =>+  Bifoldable (ComplexConstraintFam f g) where+    bifoldr   = $(makeBifoldr 'ComplexConstraintFam)+    bifoldMap = $(makeBifoldMap 'ComplexConstraintFam)+instance (Bitraversable (f Int), Traversable g) =>+  Bitraversable (ComplexConstraintFam f g) where+    bitraverse = $(makeBitraverse 'ComplexConstraintFam)++$(deriveBifunctor     'UniversalFam)++$(deriveBifunctor     'ExistentialListFam)+$(deriveBifoldable    'ExistentialFunctorFam)+$(deriveBitraversable 'SneakyUseSameNameFam)+#endif+ -------------------------------------------------------------------------------  prop_BifunctorLaws :: (Bifunctor p, Eq (p a b), Eq (p c d))@@ -134,6 +226,9 @@     && second id    x == x     && bimap  f  g  x == (first f . second g) x +prop_BifunctorEx :: (Bifunctor p, Eq (p [Int] [Int])) => p [Int] [Int] -> Bool+prop_BifunctorEx = prop_BifunctorLaws reverse (++ [42])+ prop_BifoldableLaws :: (Eq a, Eq b, Eq z, Monoid a, Monoid b, Bifoldable p)                 => (a -> b) -> (a -> b)                 -> (a -> z -> z) -> (a -> z -> z)@@ -143,6 +238,9 @@     && bifoldMap f g x == bifoldr (mappend . f) (mappend . g) mempty x     && bifoldr h i z x == appEndo (bifoldMap (Endo . h) (Endo . i) x) z +prop_BifoldableEx :: Bifoldable p => p [Int] [Int] -> Bool+prop_BifoldableEx = prop_BifoldableLaws reverse (++ [42]) ((+) . length) ((*) . length) 0+ prop_BitraversableLaws :: (Applicative f, Bitraversable p, Eq (f (p c c)),                            Eq (p a b), Eq (p d e), Eq1 f)                        => (a -> f c) -> (b -> f c) -> (c -> f d) -> (c -> f e)@@ -153,6 +251,16 @@     && (Compose . fmap (bitraverse h i) . bitraverse f g) x        == bitraverse (Compose . fmap h . f) (Compose . fmap i . g) x +prop_BitraversableEx :: (Bitraversable p, Eq (p Char Char),+                        Eq (p [Char] [Char]), Eq (p [Int] [Int]))+                        => p [Int] [Int] -> Bool+prop_BitraversableEx = prop_BitraversableLaws+    (replicate 2 . map (chr . abs))+    (replicate 4 . map (chr . abs))+    (++ "hello")+    (++ "world")+    reverse+ -------------------------------------------------------------------------------  main :: IO ()@@ -162,22 +270,17 @@ spec = do     describe "OneTwoCompose Maybe Either [Int] [Int]" $ do         prop "satisfies the Bifunctor laws"-            (prop_BifunctorLaws-                reverse-                (++ [42])-                :: OneTwoCompose Maybe Either [Int] [Int] -> Bool)+            (prop_BifunctorEx     :: OneTwoCompose Maybe Either [Int] [Int] -> Bool)         prop "satisfies the Bifoldable laws"-            (prop_BifoldableLaws-                reverse (++ [42])-                ((+) . length)-                ((*) . length)-                0-                :: OneTwoCompose Maybe Either [Int] [Int] -> Bool)+            (prop_BifoldableEx    :: OneTwoCompose Maybe Either [Int] [Int] -> Bool)         prop "satisfies the Bitraversable laws"-            (prop_BitraversableLaws-                (replicate 2 . map (chr . abs))-                (replicate 4 . map (chr . abs))-                ((++ "hello"))-                ((++ "world"))-                reverse-                :: OneTwoCompose Maybe Either [Int] [Int] -> Bool)+            (prop_BitraversableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Bool)+#if MIN_VERSION_template_haskell(2,7,0)+    describe "OneTwoComposeFam Maybe Either [Int] [Int]" $ do+        prop "satisfies the Bifunctor laws"+            (prop_BifunctorEx     :: OneTwoComposeFam Maybe Either [Int] [Int] -> Bool)+        prop "satisfies the Bifoldable laws"+            (prop_BifoldableEx    :: OneTwoComposeFam Maybe Either [Int] [Int] -> Bool)+        prop "satisfies the Bitraversable laws"+            (prop_BitraversableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Bool)+#endif