bifunctors 5 → 5.1

raw patch · 21 files changed

+1976/−61 lines, 21 filesdep +QuickCheckdep +bifunctorsdep +containersdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, bifunctors, containers, hspec, template-haskell, transformers, transformers-compat

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• .travis.yml +5/−0
• CHANGELOG.markdown +6/−0
• README.markdown +1/−1
• bifunctors.cabal +32/−3
• old-src/Data/Bifunctor.hs +44/−2
• src/Data/Biapplicative.hs +2/−2
• src/Data/Bifoldable.hs +11/−1
• src/Data/Bifunctor/Biff.hs +21/−1
• src/Data/Bifunctor/Clown.hs +24/−1
• src/Data/Bifunctor/Fix.hs +57/−0
• src/Data/Bifunctor/Flip.hs +21/−1
• src/Data/Bifunctor/Join.hs +22/−1
• src/Data/Bifunctor/Joker.hs +23/−1
• src/Data/Bifunctor/Product.hs +21/−1
• src/Data/Bifunctor/TH.hs +933/−0
• src/Data/Bifunctor/TH/Internal.hs +486/−0
• src/Data/Bifunctor/Tannen.hs +21/−1
• src/Data/Bifunctor/Wrapped.hs +21/−1
• src/Data/Bitraversable.hs +41/−44
• tests/BifunctorSpec.hs +183/−0
• tests/Spec.hs +1/−0

@@ -11,6 +11,9 @@ 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  before_install:  - travis_retry sudo add-apt-repository -y ppa:hvr/ghc@@ -22,10 +25,12 @@ install:  - travis_retry cabal update  - cabal install --enable-tests --only-dependencies+ - export PATH=$HOME/.cabal/bin:$PATH # Needed to be able to find hspec-discover  script:  - cabal configure -v2 --enable-tests  - cabal build+ - cabal test --show-details=always  - cabal sdist  - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;    cd dist/;

@@ -1,3 +1,9 @@+5.1+---+* Added `Data.Bifunctor.Fix`+* Added `Data.Bifunctor.TH`, which permits `TemplateHaskell`-based deriving of `Bifunctor`, `Bifoldable` and `Bitraversable` instances.+* Simplified `Bitraversable`.+ 5 - * Inverted the dependency on `semigroupoids`. We can support a much wider array of `base` versions than it can.

@@ -1,7 +1,7 @@ bifunctors ========== -[![Build Status](https://secure.travis-ci.org/ekmett/bifunctors.png?branch=master)](http://travis-ci.org/ekmett/bifunctors)+[![Hackage](https://img.shields.io/hackage/v/bifunctors.svg)](https://hackage.haskell.org/package/bifunctors) [![Build Status](https://secure.travis-ci.org/ekmett/bifunctors.png?branch=master)](http://travis-ci.org/ekmett/bifunctors)  Contact Information -------------------

@@ -1,8 +1,8 @@ name:          bifunctors category:      Data, Functors-version:       5+version:       5.1 license:       BSD3-cabal-version: >= 1.6+cabal-version: >= 1.8 license-file:  LICENSE author:        Edward A. Kmett maintainer:    Edward A. Kmett <ekmett@gmail.com>@@ -39,7 +39,9 @@ library   hs-source-dirs: src   build-depends:-    base >= 4 && < 5+    base             >= 4   && < 5,+    containers       >= 0.1 && < 0.6,+    template-haskell >= 2.4 && < 2.11    if flag(tagged)     build-depends: tagged >= 0.7.3 && < 1@@ -56,12 +58,39 @@     Data.Bifoldable     Data.Bifunctor.Biff     Data.Bifunctor.Clown+    Data.Bifunctor.Fix     Data.Bifunctor.Flip     Data.Bifunctor.Join     Data.Bifunctor.Joker     Data.Bifunctor.Product     Data.Bifunctor.Tannen+    Data.Bifunctor.TH     Data.Bifunctor.Wrapped     Data.Bitraversable++  other-modules:+    Data.Bifunctor.TH.Internal+    Paths_bifunctors++  ghc-options: -Wall++test-suite bifunctors-spec+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    tests++  main-is:+    Spec.hs+  other-modules:+    BifunctorSpec++  build-depends:+    base                >= 4   && < 5,+    bifunctors,+    hspec               >= 1.8,+    QuickCheck          >= 2   && < 3,+    transformers        >= 0.2 && < 0.5,+    transformers-compat >= 0.3 && < 0.5    ghc-options: -Wall

@@ -1,4 +1,8 @@ {-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif  #ifndef MIN_VERSION_semigroups #define MIN_VERSION_semigroups(x,y,z) 0@@ -14,7 +18,13 @@ -- ---------------------------------------------------------------------------- module Data.Bifunctor-  ( Bifunctor(..)+  ( -- * Overview+    --+    -- Bifunctors extend the standard 'Functor' to two arguments++    -- * Examples+    -- $examples+    Bifunctor(..)   ) where  import Control.Applicative@@ -27,6 +37,10 @@ import Data.Tagged #endif +#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif+ -- | Minimal definition either 'bimap' or 'first' and 'second'  -- | Formally, the class 'Bifunctor' represents a bifunctor@@ -81,8 +95,10 @@   second = bimap id   {-# INLINE second #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+#if __GLASGOW_HASKELL__ >= 708   {-# MINIMAL bimap | first, second #-}++deriving instance Typeable Bifunctor #endif  instance Bifunctor (,) where@@ -128,3 +144,29 @@   bimap _ g (Tagged b) = Tagged (g b)   {-# INLINE bimap #-} #endif++-- $examples+--+-- ==== __Examples__+--+-- While the standard 'Functor' instance for 'Either' is limited to mapping over 'Right' arguments,+-- the 'Bifunctor' instance allows mapping over the 'Left', 'Right', or both arguments:+--+-- > let x = Left "foo" :: Either String Integer+--+-- In the case of 'first' and 'second', the function may or may not be applied:+--+-- > first (++ "bar") x == Left "foobar"+-- > second (+2) x      == Left "foo"+--+-- In the case of 'bimap', only one of the functions will be applied:+--+-- > bimap (++ "bar") (+2) x == Left "foobar"+--+-- The 'Bifunctor' instance for 2 element tuples allows mapping over one or both of the elements:+--+-- > let x = ("foo",1)+-- >+-- > first  (++ "bar") x      == ("foobar", 1)+-- > second (+2) x            == ("foo", 3)+-- > bimap  (++ "bar") (+2) x == ("foobar", 3)

@@ -48,7 +48,7 @@    -- |   -- @-  -- a '*>' b ≡ 'const' 'id' '<$>' a '<*>' b+  -- 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@@ -56,7 +56,7 @@    -- |   -- @-  -- a '<*' b ≡ 'const' '<$>' a '<.>' b+  -- a '<<*' b ≡ 'bimap' 'const' 'const' '<<$>>' a '<<*>>' b   -- @   (<<*) :: p a b -> p c d -> p a b   a <<* b = bimap const const <<$>> a <<*>> b

@@ -1,4 +1,8 @@ {-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif  #ifndef MIN_VERSION_semigroups #define MIN_VERSION_semigroups(x,y,z) 0@@ -44,6 +48,10 @@ import Data.Tagged #endif +#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif+ -- | Minimal definition either 'bifoldr' or 'bifoldMap'  -- | 'Bifoldable' identifies foldable structures with two different varieties of@@ -98,8 +106,10 @@   bifoldl f g z t = appEndo (getDual (bifoldMap (Dual . Endo . flip f) (Dual . Endo . flip g) t)) z   {-# INLINE bifoldl #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+#if __GLASGOW_HASKELL__ >= 708   {-# MINIMAL bifoldr | bifoldMap #-}++deriving instance Typeable Bifoldable #endif  #if MIN_VERSION_semigroups(0,16,2)

@@ -1,3 +1,9 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Copyright   :  (C) 2008-2015 Edward Kmett@@ -12,17 +18,31 @@   ( Biff(..)   ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif+ import Data.Biapplicative import Data.Bifoldable import Data.Bitraversable++#if __GLASGOW_HASKELL__ < 710 import Data.Foldable import Data.Monoid import Data.Traversable+#endif +#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#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)+  deriving ( Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 708+           , Typeable+#endif+           )  instance (Bifunctor p, Functor f, Functor g) => Bifunctor (Biff p f g) where   first f = Biff . first (fmap f) . runBiff

@@ -1,3 +1,9 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Copyright   :  (C) 2008-2015 Edward Kmett@@ -14,17 +20,34 @@   ( Clown(..)   ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif+ import Data.Biapplicative import Data.Bifoldable import Data.Bitraversable++#if __GLASGOW_HASKELL__ < 710 import Data.Foldable import Data.Monoid import Data.Traversable+#endif +#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#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)+  deriving ( Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 708+           , Typeable+#endif+           )  instance Functor f => Bifunctor (Clown f) where   first f = Clown . fmap f . runClown

@@ -0,0 +1,57 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Bifunctor.Fix+-- Copyright   :  (C) 2008-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  non-portable+--+-----------------------------------------------------------------------------+module Data.Bifunctor.Fix+  ( Fix(..)+  ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif++import Data.Biapplicative+import Data.Bifoldable+import Data.Bitraversable++#if __GLASGOW_HASKELL__ < 710+import Data.Foldable+import Data.Traversable+#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 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)+  {-# INLINE fmap #-}++instance Biapplicative p => Applicative (Fix p) where+  pure a = In (bipure (pure a) a)+  {-# INLINE pure #-}+  In p <*> In q = In (biliftA2 (<*>) ($) p q)+  {-# INLINE (<*>) #-}++instance Bifoldable p => Foldable (Fix p) where+  foldMap f (In p) = bifoldMap (foldMap f) f p+  {-# INLINE foldMap #-}++instance Bitraversable p => Traversable (Fix p) where+  traverse f (In p) = In <$> bitraverse (traverse f) f p+  {-# INLINE traverse #-}

@@ -1,3 +1,9 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Bifunctor.Flip@@ -13,17 +19,31 @@   ( Flip(..)   ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif+ import Data.Biapplicative import Data.Bifoldable import Data.Bitraversable++#if __GLASGOW_HASKELL__ < 710 import Data.Foldable import Data.Monoid import Data.Traversable+#endif +#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#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)+  deriving ( Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 708+           , Typeable+#endif+           )  instance Bifunctor p => Bifunctor (Flip p) where   first f = Flip . second f . runFlip

@@ -1,4 +1,12 @@-{-# LANGUAGE StandaloneDeriving, FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Copyright   :  (C) 2008-2015 Edward Kmett@@ -13,15 +21,28 @@   ( Join(..)   ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif+ import Data.Biapplicative import Data.Bifoldable import Data.Bitraversable++#if __GLASGOW_HASKELL__ < 710 import Data.Foldable import Data.Traversable+#endif +#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif+ -- | Make a 'Functor' over both arguments of a 'Bifunctor'. newtype Join p a = Join { runJoin :: p a a }+#if __GLASGOW_HASKELL__ >= 708+  deriving Typeable+#endif  deriving instance Eq   (p a a) => Eq   (Join p a) deriving instance Ord  (p a a) => Ord  (Join p a)

@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+#endif ----------------------------------------------------------------------------- -- | -- Copyright   :  (C) 2008-2015 Edward Kmett@@ -14,16 +19,33 @@   ( Joker(..)   ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif+ import Data.Biapplicative import Data.Bifoldable import Data.Bitraversable++#if __GLASGOW_HASKELL__ < 710 import Data.Foldable import Data.Traversable+#endif +#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#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)+  deriving ( Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 708+           , Typeable+#endif+           )  instance Functor g => Bifunctor (Joker g) where   first _ = Joker . runJoker

@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+#endif ----------------------------------------------------------------------------- -- | -- Copyright   :  (C) 2008-2015 Jesse Selover, Edward Kmett@@ -13,14 +18,29 @@   ( Product(..)   ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif+ import Data.Biapplicative import Data.Bifoldable import Data.Bitraversable++#if __GLASGOW_HASKELL__ < 710 import Data.Monoid hiding (Product)+#endif +#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#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)+data Product f g a b = Pair (f a b) (g a b)+  deriving ( Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 708+           , Typeable+#endif+           )  instance (Bifunctor f, Bifunctor g) => Bifunctor (Product f g) where   first f (Pair x y) = Pair (first f x) (first f y)

@@ -0,0 +1,933 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE BangPatterns #-}++#ifndef MIN_VERSION_template_haskell+#define MIN_VERSION_template_haskell(x,y,z) 1+#endif+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2008-2015 Edward Kmett, (C) 2015 Ryan Scott+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- Functions to mechanically derive 'Bifunctor', 'Bifoldable',+-- or 'Bitraversable' instances, or to splice their functions directly into+-- source code. You need to enable the @TemplateHaskell@ language extension+-- in order to use this module.+----------------------------------------------------------------------------++module Data.Bifunctor.TH (+    -- * @derive@- functions+    -- $derive+    -- * @make@- functions+    -- $make+    -- * 'Bifunctor'+    deriveBifunctor+  , makeBimap+    -- * 'Bifoldable'+  , deriveBifoldable+  , makeBifold+  , makeBifoldMap+  , makeBifoldr+  , makeBifoldl+    -- * 'Bitraversable'+  , deriveBitraversable+  , makeBitraverse+  , makeBisequenceA+  , makeBimapM+  , makeBisequence+  ) where++import Control.Monad (guard)++import Data.Bifunctor.TH.Internal+import Data.List+import Data.Maybe+#if __GLASGOW_HASKELL__ < 710 && MIN_VERSION_template_haskell(2,8,0)+import qualified Data.Set as Set+#endif++import Language.Haskell.TH.Lib+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Syntax++-------------------------------------------------------------------------------+-- User-facing API+-------------------------------------------------------------------------------++{- $derive++'deriveBifunctor', 'deriveBifoldable', and 'deriveBitraversable' automatically+generate their respective class instances for a given data type, newtype, or data+family instance that has at least two type variable. Examples:++@+&#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;+import Data.Bifunctor.TH++data Pair a b = Pair a b+$('deriveBifunctor' ''Pair) -- instance Bifunctor Pair where ...++data WrapLeftPair f g a b = WrapLeftPair (f a) (g a b)+$('deriveBifoldable' ''WrapLeftPair)+-- instance (Foldable f, Bifoldable g) => Bifoldable (WrapLeftPair f g) where ...+@++If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later),+the @derive@ functions can be used data family instances (which requires the+@-XTypeFamilies@ extension). To do so, pass the name of a data or newtype instance+constructor (NOT a data family name!) to a @derive@ function.  Note that the+generated code may require the @-XFlexibleInstances@ extension. Example:++@+&#123;-&#35; LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies &#35;-&#125;+import Data.Bifunctor.TH++class AssocClass a b c where+    data AssocData a b c+instance AssocClass Int b c where+    data AssocData Int b c = AssocDataInt1 Int | AssocDataInt2 b c+$('deriveBitraversable' 'AssocDataInt1) -- instance Bitraversable (AssocData Int) where ...+-- Alternatively, one could use $(deriveBitraversable 'AssocDataInt2)+@++Note that there are some limitations:++* The 'Name' argument to a @derive@ function must not be a type synonym.++* With a @derive@ function, the last two type variables must both be of kind @*@.+  Other type variables of kind @* -> *@ are assumed to require a 'Functor',+  'Foldable', or 'Traversable' constraint (depending on which @derive@ function is+  used), and other type variables of kind @* -> * -> *@ are assumed to require an+  'Bifunctor', 'Bifoldable', or 'Bitraversable' constraint. If your data type+  doesn't meet these assumptions, use a @make@ function.++* If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@+  extensions, a constraint cannot mention either of the last two type variables. For+  example, @data Illegal2 a b where I2 :: Ord a => a -> b -> Illegal2 a b@ cannot+  have a derived 'Bifunctor' instance.++* If either of the last two type variables is used within a constructor argument's+  type, it must only be used in the last two type arguments. For example,+  @data Legal a b = Legal (Int, Int, a, b)@ can have a derived 'Bifunctor' instance,+  but @data Illegal a b = Illegal (a, b, a, b)@ cannot.++* Data family instances must be able to eta-reduce the last two type variables. In other+  words, if you have a instance of the form:++  @+  data family Family a1 ... an t1 t2+  data instance Family e1 ... e2 v1 v2 = ...+  @++  Then the following conditions must hold:++  1. @v1@ and @v2@ must be distinct type variables.+  2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@.++* In GHC 7.8, a bug exists that can cause problems when a data family declaration and+  one of its data instances use different type variables, e.g.,++  @+  data family Foo a b c+  data instance Foo Int y z = Foo Int y z+  $(deriveBifunctor 'Foo)+  @++  To avoid this issue, it is recommened that you use the same type variables in the+  same positions in which they appeared in the data family declaration:++  @+  data family Foo a b c+  data instance Foo Int b c = Foo Int b c+  $(deriveBifunctor 'Foo)+  @++-}++{- $make++There may be scenarios in which you want to, say, 'bimap' over an arbitrary data type+or data family instance without having to make the type an instance of 'Bifunctor'. For+these cases, this module provides several functions (all prefixed with @make@-) that+splice the appropriate lambda expression into your source code.++This is particularly useful for creating instances for sophisticated data types. For+example, 'deriveBifunctor' cannot infer the correct type context for+@newtype HigherKinded f a b c = HigherKinded (f a b c)@, since @f@ is of kind+@* -> * -> * -> *@. However, it is still possible to create a 'Bifunctor' instance for+@HigherKinded@ without too much trouble using 'makeBimap':++@+&#123;-&#35; LANGUAGE FlexibleContexts, TemplateHaskell &#35;-&#125;+import Data.Bifunctor+import Data.Bifunctor.TH++newtype HigherKinded f a b c = HigherKinded (f a b c)++instance Bifunctor (f a) => Bifunctor (HigherKinded f a) where+    bimap = $(makeBimap ''HigherKinded)+@++-}++-- | Generates a 'Bifunctor' instance declaration for the given data type or data+-- family instance.+deriveBifunctor :: Name -> Q [Dec]+deriveBifunctor = deriveBiClass Bifunctor++-- | Generates a lambda expression which behaves like 'bimap' (without requiring a+-- 'Bifunctor' instance).+makeBimap :: Name -> Q Exp+makeBimap = makeBiFun Bimap++-- | Generates a 'Bifoldable' instance declaration for the given data type or data+-- family instance.+deriveBifoldable :: Name -> Q [Dec]+deriveBifoldable = deriveBiClass Bifoldable++-- | Generates a lambda expression which behaves like 'bifold' (without requiring a+-- 'Bifoldable' instance).+makeBifold :: Name -> Q Exp+makeBifold name = appsE [ makeBifoldMap name+                        , varE idValName+                        , varE idValName+                        ]++-- | Generates a lambda expression which behaves like 'bifoldMap' (without requiring a+-- 'Bifoldable' instance).+makeBifoldMap :: Name -> Q Exp+makeBifoldMap = makeBiFun BifoldMap++-- | Generates a lambda expression which behaves like 'bifoldr' (without requiring a+-- 'Bifoldable' instance).+makeBifoldr :: Name -> Q Exp+makeBifoldr = makeBiFun Bifoldr++-- | Generates a lambda expression which behaves like 'bifoldl' (without requiring a+-- 'Bifoldable' instance).+makeBifoldl :: Name -> Q Exp+makeBifoldl name = do+  f <- newName "f"+  g <- newName "g"+  z <- newName "z"+  t <- newName "t"+  lamE [varP f, varP g, varP z, varP t] $+    appsE [ varE appEndoValName+          , appsE [ varE getDualValName+                  , appsE [ makeBifoldMap name, foldFun f, foldFun g, varE t]+                  ]+          , varE z+          ]+  where+    foldFun :: Name -> Q Exp+    foldFun n = infixApp (conE dualDataName)+                         (varE composeValName)+                         (infixApp (conE endoDataName)+                                   (varE composeValName)+                                   (varE flipValName `appE` varE n)+                         )++-- | Generates a 'Bitraversable' instance declaration for the given data type or data+-- family instance.+deriveBitraversable :: Name -> Q [Dec]+deriveBitraversable = deriveBiClass Bitraversable++-- | Generates a lambda expression which behaves like 'bitraverse' (without requiring a+-- 'Bitraversable' instance).+makeBitraverse :: Name -> Q Exp+makeBitraverse = makeBiFun Bitraverse++-- | Generates a lambda expression which behaves like 'bisequenceA' (without requiring a+-- 'Bitraversable' instance).+makeBisequenceA :: Name -> Q Exp+makeBisequenceA name = appsE [ makeBitraverse name+                             , varE idValName+                             , varE idValName+                             ]++-- | Generates a lambda expression which behaves like 'bimapM' (without requiring a+-- 'Bitraversable' instance).+makeBimapM :: Name -> Q Exp+makeBimapM name = do+  f <- newName "f"+  g <- newName "g"+  lamE [varP f, varP g] . infixApp (varE unwrapMonadValName) (varE composeValName) $+                          appsE [makeBitraverse name, wrapMonadExp f, wrapMonadExp g]+  where+    wrapMonadExp :: Name -> Q Exp+    wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n)++-- | Generates a lambda expression which behaves like 'bisequence' (without requiring a+-- 'Bitraversable' instance).+makeBisequence :: Name -> Q Exp+makeBisequence name = appsE [ makeBimapM name+                            , varE idValName+                            , varE idValName+                            ]++-------------------------------------------------------------------------------+-- Code generation+-------------------------------------------------------------------------------++-- | 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`+    instanceD (return instanceCxt)+              (return $ AppT (ConT className) instanceType)+              (biFunDecs biClass droppedNbs cons)+    where+      (instanceCxt, instanceType, droppedNbs) =+          cxtAndTypeDataFamInstCon biClass parentName ctxt famTvbs instTys+#endif++-- | Generates a declaration defining the primary function(s) corresponding to a+-- particular class (bimap for Bifunctor, bifoldr and bifoldMap for Bifoldable, and+-- bitraverse for Bitraversable).+--+-- For why both bifoldr and bifoldMap are derived for Bifoldable, see Trac #7436.+biFunDecs :: BiClass -> [NameBase] -> [Con] -> [Q Dec]+biFunDecs biClass nbs cons = map makeFunD $ biClassToFuns biClass where+  makeFunD :: BiFun -> Q Dec+  makeFunD biFun =+    funD (biFunName biFun)+         [ clause []+                  (normalB $ makeBiFunForCons biFun nbs cons)+                  []+         ]++-- | 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: "++-- | Generates a lambda expression for the given constructors.+-- All constructors must be from the same type.+makeBiFunForCons :: BiFun -> [NameBase] -> [Con] -> Q Exp+makeBiFunForCons biFun nbs cons = do+  argNames <- mapM newName $ catMaybes [ Just "f"+                                       , Just "g"+                                       , guard (biFun == Bifoldr) >> Just "z"+                                       , Just "value"+                                       ]+  let (maps,others) = splitAt 2 argNames+      z             = head others -- If we're deriving bifoldr, this will be well defined+                                  -- and useful. Otherwise, it'll be ignored.+      value         = last others+      tvis          = zip nbs maps+  lamE (map varP argNames)+      . appsE+      $ [ varE $ biFunConstName biFun+        , if null cons+             then appE (varE errorValName)+                       (stringE $ "Void " ++ nameBase (biFunName biFun))+             else caseE (varE value)+                        (map (makeBiFunForCon biFun z tvis) cons)+        ] ++ map varE argNames++-- | Generates a lambda expression for a single constructor.+makeBiFunForCon :: BiFun -> Name -> [TyVarInfo] -> Con -> Q Match+makeBiFunForCon biFun z tvis (NormalC conName tys) = do+  args <- newNameList "arg" $ length tys+  let argTys = map snd tys+  makeBiFunForArgs biFun z tvis conName argTys args+makeBiFunForCon biFun z tvis (RecC conName tys) = do+  args <- newNameList "arg" $ length tys+  let argTys = map thd3 tys+  makeBiFunForArgs biFun z tvis conName argTys args+makeBiFunForCon biFun z tvis (InfixC (_, argTyL) conName (_, argTyR)) = do+  argL <- newName "argL"+  argR <- newName "argR"+  makeBiFunForArgs biFun z tvis conName [argTyL, argTyR] [argL, argR]+makeBiFunForCon biFun z tvis (ForallC tvbs faCxt con)+  | any (`predMentionsNameBase` map fst tvis) faCxt && not (allowExQuant (biFunToClass biFun))+  = existentialContextError (constructorName con)+  | otherwise = makeBiFunForCon biFun z (removeForalled tvbs tvis) con++-- | Generates a lambda expression for a single constructor's arguments.+makeBiFunForArgs :: BiFun+                 -> Name+                 -> [TyVarInfo]+                 -> Name+                 -> [Type]+                 -> [Name]+                 ->  Q Match+makeBiFunForArgs biFun z tvis conName tys args =+  match (conP conName $ map varP args)+        (normalB $ biFunCombine biFun conName z mappedArgs)+        []+  where+    mappedArgs :: [Q Exp]+    mappedArgs = zipWith (makeBiFunForArg biFun tvis conName) tys args++-- | Generates a lambda expression for a single argument of a constructor.+makeBiFunForArg :: BiFun+                -> [TyVarInfo]+                -> Name+                -> Type+                -> Name+                -> Q Exp+makeBiFunForArg biFun tvis conName ty tyExpName = do+  ty' <- expandSyn ty+  makeBiFunForArg' biFun tvis conName ty' tyExpName++-- | Generates a lambda expression for a single argument of a constructor, after+-- expanding all type synonyms.+makeBiFunForArg' :: BiFun+                 -> [TyVarInfo]+                 -> Name+                 -> Type+                 -> Name+                 -> Q Exp+makeBiFunForArg' biFun tvis conName ty tyExpName =+  makeBiFunForType biFun tvis conName True ty `appE` varE tyExpName++-- | Generates a lambda expression for a specific type.+makeBiFunForType :: BiFun+                 -> [TyVarInfo]+                 -> Name+                 -> Bool+                 -> Type+                 -> Q Exp+makeBiFunForType biFun tvis conName covariant (VarT tyName) =+  case lookup (NameBase tyName) tvis of+    Just mapName -> varE $ if covariant+                           then mapName+                           else contravarianceError conName+    Nothing -> biFunTriv biFun+makeBiFunForType biFun tvis conName covariant (SigT ty _) =+  makeBiFunForType biFun tvis conName covariant ty+makeBiFunForType biFun tvis conName covariant (ForallT tvbs _ ty) =+  makeBiFunForType biFun (removeForalled tvbs tvis) conName covariant ty+makeBiFunForType biFun tvis conName covariant ty =+  let tyCon  :: Type+      tyArgs :: [Type]+      tyCon:tyArgs = unapplyTy ty++      numLastArgs :: Int+      numLastArgs = min 2 $ length tyArgs++      lhsArgs, rhsArgs :: [Type]+      (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs++      tyVarNameBases :: [NameBase]+      tyVarNameBases = map fst tvis++      mentionsTyArgs :: Bool+      mentionsTyArgs = any (`mentionsNameBase` tyVarNameBases) tyArgs++      makeBiFunTuple :: Type -> Name -> Q Exp+      makeBiFunTuple fieldTy fieldName =+        makeBiFunForType biFun tvis conName covariant fieldTy `appE` varE fieldName++   in case tyCon of+     ArrowT+       | not (allowFunTys (biFunToClass biFun)) -> noFunctionsError conName+       | mentionsTyArgs, [argTy, resTy] <- tyArgs ->+         do x <- newName "x"+            b <- newName "b"+            lamE [varP x, varP b] $+              covBiFun covariant resTy `appE` (varE x `appE`+                (covBiFun (not covariant) argTy `appE` varE b))+         where+           covBiFun :: Bool -> Type -> Q Exp+           covBiFun = makeBiFunForType biFun tvis conName+     TupleT n+       | n > 0 && mentionsTyArgs -> do+         args <- mapM newName $ catMaybes [ Just "x"+                                          , guard (biFun == Bifoldr) >> Just "z"+                                          ]+         xs <- newNameList "tup" n++         let x = head args+             z = last args+         lamE (map varP args) $ caseE (varE x)+              [ match (tupP $ map varP xs)+                      (normalB $ biFunCombine biFun+                                              (tupleDataName n)+                                              z+                                              (zipWith makeBiFunTuple tyArgs xs)+                      )+                      []+              ]+     _ -> do+         itf <- isTyFamily tyCon+         if any (`mentionsNameBase` tyVarNameBases) lhsArgs || (itf && mentionsTyArgs)+           then outOfPlaceTyVarError conName tyVarNameBases+           else if any (`mentionsNameBase` tyVarNameBases) rhsArgs+                  then biFunApp biFun . appsE $+                         ( varE (fromJust $ biFunArity biFun numLastArgs)+                         : map (makeBiFunForType biFun tvis conName covariant) rhsArgs+                         )+                  else biFunTriv biFun++-------------------------------------------------------------------------------+-- 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+  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: "++#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+    DataConI _ _ parentName _ -> do+      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."+  where+    ns :: String+    ns = "Data.Bifunctor.TH.withDataFamInstCon: "+#endif++-- | 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+                  -> (Cxt, Type, [NameBase])+cxtAndTypePlainTy biClass tyConName dataCxt tvbs+  | 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+  = datatypeContextError tyConName instanceType+  | otherwise = (instanceCxt, instanceType, droppedNbs)+  where+    instanceCxt :: Cxt+    instanceCxt = mapMaybe (applyConstraint biClass) remaining++    instanceType :: Type+    instanceType = applyTyCon tyConName $ map (VarT . tvbName) remaining++    remainingLength :: Int+    remainingLength = length tvbs - 2++    remaining, dropped :: [TyVarBndr]+    (remaining, dropped) = splitAt remainingLength tvbs++    droppedKinds :: [Kind]+    droppedKinds = map tvbKind dropped++    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+  | 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+  = datatypeContextError parentName instanceType+  | canEtaReduce remaining dropped -- If it is safe to drop the type variables+  = (instanceCxt, instanceType, droppedNbs)+  | otherwise = etaReductionError instanceType+  where+    instanceCxt :: Cxt+    instanceCxt = mapMaybe (applyConstraint biClass) lhsTvbs++    -- We need to make sure that type variables in the instance head which have+    -- constraints aren't poly-kinded, e.g.,+    --+    -- @+    -- instance Bifunctor f => Bifunctor (Foo (f :: k)) where+    -- @+    --+    -- To do this, we remove every kind ascription (i.e., strip off every 'SigT').+    instanceType :: Type+    instanceType = applyTyCon parentName+                 $ map unSigT remaining++    remainingLength :: Int+    remainingLength = length famTvbs - 2++    remaining, dropped :: [Type]+    (remaining, dropped) = splitAt remainingLength rhsTypes++    droppedKinds :: [Kind]+    droppedKinds = map tvbKind . snd $ splitAt remainingLength famTvbs++    droppedNbs :: [NameBase]+    droppedNbs = map varTToNameBase dropped++    -- We need to be mindful of an old GHC bug which causes kind variables to appear in+    -- @instTysAndKinds@ (as the name suggests) if+    --+    --   (1) @PolyKinds@ is enabled+    --   (2) either GHC 7.6 or 7.8 is being used (for more info, see Trac #9692).+    --+    -- Since Template Haskell doesn't seem to have a mechanism for detecting which+    -- language extensions are enabled, we do the next-best thing by counting+    -- the number of distinct kind variables in the data family declaration, and+    -- then dropping that number of entries from @instTysAndKinds@.+    instTypes :: [Type]+    instTypes =+# if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))+      instTysAndKinds+# else+      drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) famTvbs)+        instTysAndKinds+# endif++    lhsTvbs :: [TyVarBndr]+    lhsTvbs = map (uncurry replaceTyVarName)+            . filter (isTyVar . snd)+            . take remainingLength+            $ zip famTvbs 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+    -- is pretty inconvenient, as it makes it impossible to come up with the correct+    -- instance types in some cases. For example, consider the following code:+    --+    -- @+    -- data family Foo a b c+    -- data instance Foo Int y z = Foo Int y z+    -- $(deriveBifunctor 'Foo)+    -- @+    --+    -- Due to the aformentioned bug, Template Haskell doesn't tell us the names of+    -- either of type variables in the data instance (@y@ and @z@). As a result, we+    -- won't know to which fields of the 'Foo' constructor to apply the map functions,+    -- which will result in an incorrect instance. Urgh.+    --+    -- A workaround is to ensure that you use the exact same type variables, in the+    -- exact same order, in the data family declaration and any data or newtype+    -- instances:+    --+    -- @+    -- data family Foo a b c+    -- data instance Foo Int b c = Foo Int b c+    -- $(deriveBifunctor 'Foo)+    -- @+    --+    -- 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+      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 biClass (KindedTV name kind) = do+  constraint <- biClassConstraint biClass $ numKindArrows kind+  if canRealizeKindStarChain kind+    then Just $ applyClass constraint name+    else Nothing++-------------------------------------------------------------------------------+-- Error messages+-------------------------------------------------------------------------------++-- | Either the given data type doesn't have enough type variables, or one of+-- the type variables to be eta-reduced cannot realize kind *.+derivingKindError :: BiClass -> Name -> a+derivingKindError biClass tyConName = error+  . showString "Cannot derive well-kinded instance of form ‘"+  . showString className+  . showChar ' '+  . showParen True+    ( showString (nameBase tyConName)+    . showString " ..."+    )+  . showString "‘\n\tClass "+  . showString className+  . showString " expects an argument of kind * -> * -> *"+  $ ""+  where+    className :: String+    className = nameBase $ biClassName biClass++-- | One of the last two type variables appeard in a contravariant position+-- when deriving Bifoldable or Bitraversable.+contravarianceError :: Name -> a+contravarianceError conName = error+  . showString "Constructor ‘"+  . showString (nameBase conName)+  . showString "‘ must not use the last type variable(s) in a function argument"+  $ ""++-- | A constructor has a function argument in a derived Bifoldable or Bitraversable+-- instance.+noFunctionsError :: Name -> a+noFunctionsError conName = error+  . showString "Constructor ‘"+  . showString (nameBase conName)+  . showString "‘ must not contain function types"+  $ ""++-- | The data type has a DatatypeContext which mentions one of the eta-reduced+-- type variables.+datatypeContextError :: Name -> Type -> a+datatypeContextError dataName instanceType = error+  . showString "Can't make a derived instance of ‘"+  . showString (pprint instanceType)+  . showString "‘:\n\tData type ‘"+  . showString (nameBase dataName)+  . showString "‘ must not have a class context involving the last type argument(s)"+  $ ""++-- | The data type has an existential constraint which mentions one of the+-- eta-reduced type variables.+existentialContextError :: Name -> a+existentialContextError conName = error+  . showString "Constructor ‘"+  . showString (nameBase conName)+  . showString "‘ must be truly polymorphic in the last argument(s) of the data type"+  $ ""++-- | The data type mentions one of the n eta-reduced type variables in a place other+-- than the last nth positions of a data type in a constructor's field.+outOfPlaceTyVarError :: Name -> [NameBase] -> a+outOfPlaceTyVarError conName tyVarNames = error+  . showString "Constructor ‘"+  . showString (nameBase conName)+  . showString "‘ must use the type variable(s) "+  . shows tyVarNames+  . 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+-- | 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+dataConIError = error+  . showString "Cannot use a data constructor."+  . showString "\n\t(Note: if you are trying to derive for a data family instance,"+  . showString "\n\tuse GHC >= 7.4 instead.)"+  $ ""+#endif++-------------------------------------------------------------------------------+-- Class-specific constants+-------------------------------------------------------------------------------++-- | A representation of which class is being derived.+data BiClass = Bifunctor | Bifoldable | Bitraversable++-- | A representation of which function is being generated.+data BiFun = Bimap | Bifoldr | BifoldMap | Bitraverse+  deriving Eq++biFunConstName :: BiFun -> Name+biFunConstName Bimap      = bimapConstValName+biFunConstName Bifoldr    = bifoldrConstValName+biFunConstName BifoldMap  = bifoldMapConstValName+biFunConstName Bitraverse = bitraverseConstValName++biClassName :: BiClass -> Name+biClassName Bifunctor     = bifunctorTypeName+biClassName Bifoldable    = bifoldableTypeName+biClassName Bitraversable = bitraversableTypeName++biFunName :: BiFun -> Name+biFunName Bimap      = bimapValName+biFunName Bifoldr    = bifoldrValName+biFunName BifoldMap  = bifoldMapValName+biFunName Bitraverse = bitraverseValName++biClassToFuns :: BiClass -> [BiFun]+biClassToFuns Bifunctor     = [Bimap]+biClassToFuns Bifoldable    = [Bifoldr, BifoldMap]+biClassToFuns Bitraversable = [Bitraverse]++biFunToClass :: BiFun -> BiClass+biFunToClass Bimap      = Bifunctor+biFunToClass Bifoldr    = Bifoldable+biFunToClass BifoldMap  = Bifoldable+biFunToClass Bitraverse = Bitraversable++biClassConstraint :: BiClass -> Int -> Maybe Name+biClassConstraint Bifunctor     1 = Just functorTypeName+biClassConstraint Bifoldable    1 = Just foldableTypeName+biClassConstraint Bitraversable 1 = Just traversableTypeName+biClassConstraint biClass       2 = Just $ biClassName biClass+biClassConstraint _             _ = Nothing++biFunArity :: BiFun -> Int -> Maybe Name+biFunArity Bimap      1 = Just fmapValName+biFunArity Bifoldr    1 = Just foldrValName+biFunArity BifoldMap  1 = Just foldMapValName+biFunArity Bitraverse 1 = Just traverseValName+biFunArity biFun      2 = Just $ biFunName biFun+biFunArity _          _ = Nothing++allowFunTys :: BiClass -> Bool+allowFunTys Bifunctor = True+allowFunTys _         = False++allowExQuant :: BiClass -> Bool+allowExQuant Bifoldable = True+allowExQuant _          = False++-- See Trac #7436 for why explicit lambdas are used+biFunTriv :: BiFun -> Q Exp+biFunTriv Bimap = do+  x <- newName "x"+  lamE [varP x] $ varE x+biFunTriv Bifoldr = do+  z <- newName "z"+  lamE [wildP, varP z] $ varE z+biFunTriv BifoldMap = lamE [wildP] $ varE memptyValName+biFunTriv Bitraverse = varE pureValName++biFunApp :: BiFun -> Q Exp -> Q Exp+biFunApp Bifoldr e = do+  x <- newName "x"+  z <- newName "z"+  lamE [varP x, varP z] $ appsE [e, varE z, varE x]+biFunApp _ e = e++biFunCombine :: BiFun -> Name -> Name -> [Q Exp] -> Q Exp+biFunCombine Bimap      = bimapCombine+biFunCombine Bifoldr    = bifoldrCombine+biFunCombine BifoldMap  = bifoldMapCombine+biFunCombine Bitraverse = bitraverseCombine++bimapCombine :: Name -> Name -> [Q Exp] -> Q Exp+bimapCombine conName _ = foldl' appE (conE conName)++bifoldrCombine :: Name -> Name -> [Q Exp] -> Q Exp+bifoldrCombine _ zName = foldr appE (varE zName)++bifoldMapCombine :: Name -> Name -> [Q Exp] -> Q Exp+bifoldMapCombine _ _ [] = varE memptyValName+bifoldMapCombine _ _ es = foldr1 (appE . appE (varE mappendValName)) es++bitraverseCombine :: Name -> Name -> [Q Exp] -> Q Exp+bitraverseCombine conName _ [] = varE pureValName `appE` conE conName+bitraverseCombine conName _ (e:es) =+  foldl' (flip infixApp $ varE apValName)+    (appsE [varE fmapValName, conE conName, e]) es

@@ -0,0 +1,486 @@+{-# LANGUAGE CPP #-}++{-|+Module:      Data.Bifunctor.TH.Internal+Copyright:   (C) 2008-2015 Edward Kmett, (C) 2015 Ryan Scott+License:     BSD-style (see the file LICENSE)+Maintainer:  Edward Kmett+Portability: Template Haskell++Template Haskell-related utilities.+-}+module Data.Bifunctor.TH.Internal where++import           Data.Function (on)+import           Data.List+import qualified Data.Map as Map (fromList, lookup)+import           Data.Map (Map)+import           Data.Maybe+import qualified Data.Set as Set+import           Data.Set (Set)++import           Language.Haskell.TH.Lib+import           Language.Haskell.TH.Syntax++#ifndef CURRENT_PACKAGE_KEY+import           Data.Version (showVersion)+import           Paths_bifunctors (version)+#endif++-------------------------------------------------------------------------------+-- Expanding type synonyms+-------------------------------------------------------------------------------++-- | Expands all type synonyms in a type. Written by Dan Rosén in the+-- @genifunctors@ package (licensed under BSD3).+expandSyn :: Type -> Q Type+expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t+expandSyn t@AppT{}            = expandSynApp t []+expandSyn t@ConT{}            = expandSynApp t []+expandSyn (SigT t _)          = expandSyn t   -- Ignore kind synonyms+expandSyn t                   = return t++expandSynApp :: Type -> [Type] -> Q Type+expandSynApp (AppT t1 t2) ts = do+    t2' <- expandSyn t2+    expandSynApp t1 (t2':ts)+expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts+expandSynApp t@(ConT n) ts = do+    info <- reify n+    case info of+        TyConI (TySynD _ tvs rhs) ->+            let (ts', ts'') = splitAt (length tvs) ts+                subs = mkSubst tvs ts'+                rhs' = subst subs rhs+             in expandSynApp rhs' ts''+        _ -> return $ foldl' AppT t ts+expandSynApp t ts = do+    t' <- expandSyn t+    return $ foldl' AppT t' ts++type Subst = Map Name Type++mkSubst :: [TyVarBndr] -> [Type] -> Subst+mkSubst vs ts =+   let vs' = map un vs+       un (PlainTV v)    = v+       un (KindedTV v _) = v+   in Map.fromList $ zip vs' ts++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 (AppT t1 t2)    = AppT (subst subs t1) (subst subs t2)+subst subs (SigT t k)      = SigT (subst subs t) k+subst _ t                  = t++-------------------------------------------------------------------------------+-- Type-specialized const functions+-------------------------------------------------------------------------------++bimapConst :: p b d -> (a -> b) -> (c -> d) -> p a c -> p b d+bimapConst = const . const . const+{-# INLINE bimapConst #-}++bifoldrConst :: c -> (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c+bifoldrConst = const . const . const . const+{-# INLINE bifoldrConst #-}++bifoldMapConst :: m -> (a -> m) -> (b -> m) -> p a b -> m+bifoldMapConst = const . const . const+{-# INLINE bifoldMapConst #-}++bitraverseConst :: f (t c d) -> (a -> f c) -> (b -> f d) -> t a b -> f (t c d)+bitraverseConst = const . const . const+{-# INLINE bitraverseConst #-}++-------------------------------------------------------------------------------+-- NameBase+-------------------------------------------------------------------------------++-- | A wrapper around Name which only uses the 'nameBase' (not the entire Name)+-- to compare for equality. For example, if you had two Names a_123 and a_456,+-- they are not equal as Names, but they are equal as NameBases.+--+-- This is useful when inspecting type variables, since a type variable in an+-- instance context may have a distinct Name from a type variable within an+-- actual constructor declaration, but we'd want to treat them as the same+-- if they have the same 'nameBase' (since that's what the programmer uses to+-- begin with).+newtype NameBase = NameBase { getName :: Name }++getNameBase :: NameBase -> String+getNameBase = nameBase . getName++instance Eq NameBase where+    (==) = (==) `on` getNameBase++instance Ord NameBase where+    compare = compare `on` getNameBase++instance Show NameBase where+    showsPrec p = showsPrec p . getNameBase++-- | A NameBase paired with the name of its map function. For example, when deriving+-- Bifunctor, its list of TyVarInfos might look like [(a, 'f), (b, 'g)].+type TyVarInfo = (NameBase, Name)++-------------------------------------------------------------------------------+-- Assorted utilities+-------------------------------------------------------------------------------++thd3 :: (a, b, c) -> c+thd3 (_, _, c) = c++-- | Extracts the name of a constructor.+constructorName :: Con -> Name+constructorName (NormalC name      _  ) = name+constructorName (RecC    name      _  ) = name+constructorName (InfixC  _    name _  ) = name+constructorName (ForallC _    _    con) = constructorName con++-- | Generate a list of fresh names with a common prefix, and numbered suffixes.+newNameList :: String -> Int -> Q [Name]+newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]++-- | Remove any occurrences of a forall-ed type variable from a list of @TyVarInfo@s.+removeForalled :: [TyVarBndr] -> [TyVarInfo] -> [TyVarInfo]+removeForalled tvbs = filter (not . foralled tvbs)+  where+    foralled :: [TyVarBndr] -> TyVarInfo -> Bool+    foralled tvbs' tvi = fst tvi `elem` map (NameBase . tvbName) tvbs'++-- | Extracts the name from a TyVarBndr.+tvbName :: TyVarBndr -> Name+tvbName (PlainTV  name)   = name+tvbName (KindedTV name _) = name++-- | Extracts the kind from a TyVarBndr.+tvbKind :: TyVarBndr -> Kind+tvbKind (PlainTV  _)   = starK+tvbKind (KindedTV _ k) = k++-- | Replace the Name of a TyVarBndr with one from a Type (if the Type has a Name).+replaceTyVarName :: TyVarBndr -> Type -> TyVarBndr+replaceTyVarName tvb            (SigT t _) = replaceTyVarName tvb t+replaceTyVarName (PlainTV  _)   (VarT n)   = PlainTV  n+replaceTyVarName (KindedTV _ k) (VarT n)   = KindedTV n k+replaceTyVarName tvb            _          = tvb++-- | Applies a typeclass constraint to a type.+applyClass :: Name -> Name -> Pred+#if MIN_VERSION_template_haskell(2,10,0)+applyClass con t = AppT (ConT con) (VarT t)+#else+applyClass con t = ClassP con [VarT t]+#endif++-- | Checks to see if the last types in a data family instance can be safely eta-+-- reduced (i.e., dropped), given the other types. This checks for three conditions:+--+-- (1) All of the dropped types are type variables+-- (2) All of the dropped types are distinct+-- (3) None of the remaining types mention any of the dropped types+canEtaReduce :: [Type] -> [Type] -> Bool+canEtaReduce remaining dropped =+       all isTyVar dropped+    && allDistinct nbs -- Make sure not to pass something of type [Type], since Type+                       -- didn't have an Ord instance until template-haskell-2.10.0.0+    && not (any (`mentionsNameBase` nbs) remaining)+  where+    nbs :: [NameBase]+    nbs = map varTToNameBase dropped++-- | Extract the Name from a type variable.+varTToName :: Type -> Name+varTToName (VarT n)   = n+varTToName (SigT t _) = varTToName t+varTToName _          = error "Not a type variable!"++-- | Extract the NameBase from a type variable.+varTToNameBase :: Type -> NameBase+varTToNameBase = NameBase . varTToName++-- | Peel off a kind signature from a Type (if it has one).+unSigT :: Type -> Type+unSigT (SigT t _) = t+unSigT t          = t++-- | Is the given type a variable?+isTyVar :: Type -> Bool+isTyVar (VarT _)   = True+isTyVar (SigT t _) = isTyVar t+isTyVar _          = False++-- | Is the given type a type family constructor (and not a data family constructor)?+isTyFamily :: Type -> Q Bool+isTyFamily (ConT n) = do+    info <- reify n+    return $ case info of+#if MIN_VERSION_template_haskell(2,7,0)+         FamilyI (FamilyD TypeFam _ _ _) _ -> True+#else+         TyConI  (FamilyD TypeFam _ _ _)   -> True+#endif+         _ -> False+isTyFamily _ = return False++-- | Are all of the items in a list (which have an ordering) distinct?+--+-- This uses Set (as opposed to nub) for better asymptotic time complexity.+allDistinct :: Ord a => [a] -> Bool+allDistinct = allDistinct' Set.empty+  where+    allDistinct' :: Ord a => Set a -> [a] -> Bool+    allDistinct' uniqs (x:xs)+        | x `Set.member` uniqs = False+        | otherwise            = allDistinct' (Set.insert x uniqs) xs+    allDistinct' _ _           = True++-- | Does the given type mention any of the NameBases in the list?+mentionsNameBase :: Type -> [NameBase] -> Bool+mentionsNameBase = go Set.empty+  where+    go :: Set NameBase -> Type -> [NameBase] -> Bool+    go foralls (ForallT tvbs _ t) nbs =+        go (foralls `Set.union` Set.fromList (map (NameBase . tvbName) tvbs)) t nbs+    go foralls (AppT t1 t2) nbs = go foralls t1 nbs || go foralls t2 nbs+    go foralls (SigT t _)   nbs = go foralls t nbs+    go foralls (VarT n)     nbs = varNb `elem` nbs && not (varNb `Set.member` foralls)+      where+        varNb = NameBase n+    go _       _            _   = False++-- | Does an instance predicate mention any of the NameBases in the list?+predMentionsNameBase :: Pred -> [NameBase] -> Bool+#if MIN_VERSION_template_haskell(2,10,0)+predMentionsNameBase = mentionsNameBase+#else+predMentionsNameBase (ClassP _ tys) nbs = any (`mentionsNameBase` nbs) tys+predMentionsNameBase (EqualP t1 t2) nbs = mentionsNameBase t1 nbs || mentionsNameBase t2 nbs+#endif++-- | The number of arrows that compose the spine of a kind signature+-- (e.g., (* -> *) -> k -> * has two arrows on its spine).+numKindArrows :: Kind -> Int+numKindArrows k = length (uncurryKind k) - 1++-- | Construct a type via curried application.+applyTy :: Type -> [Type] -> Type+applyTy = foldl' AppT++-- | Fully applies a type constructor to its type variables.+applyTyCon :: Name -> [Type] -> Type+applyTyCon = applyTy . ConT++-- | Split an applied type into its individual components. For example, this:+--+-- @+-- Either Int Char+-- @+--+-- would split to this:+--+-- @+-- [Either, Int, Char]+-- @+unapplyTy :: Type -> [Type]+unapplyTy = reverse . go+  where+    go :: Type -> [Type]+    go (AppT t1 t2) = t2:go t1+    go (SigT t _)   = go t+    go t            = [t]++-- | Split a type signature by the arrows on its spine. For example, this:+--+-- @+-- (Int -> String) -> Char -> ()+-- @+--+-- would split to this:+--+-- @+-- [Int -> String, Char, ()]+-- @+uncurryTy :: Type -> [Type]+uncurryTy (AppT (AppT ArrowT t1) t2) = t1:uncurryTy t2+uncurryTy (SigT t _)                 = uncurryTy t+uncurryTy t                          = [t]++-- | Like uncurryType, except on a kind level.+uncurryKind :: Kind -> [Kind]+#if MIN_VERSION_template_haskell(2,8,0)+uncurryKind = uncurryTy+#else+uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2+uncurryKind k              = [k]+#endif++wellKinded :: [Kind] -> Bool+wellKinded = all canRealizeKindStar++-- | Of form k1 -> k2 -> ... -> kn, where k is either a single kind variable or *.+canRealizeKindStarChain :: Kind -> Bool+canRealizeKindStarChain = all canRealizeKindStar . uncurryKind++canRealizeKindStar :: Kind -> Bool+canRealizeKindStar k = case uncurryKind k of+    [k'] -> case k' of+#if MIN_VERSION_template_haskell(2,8,0)+                 StarT    -> True+                 (VarT _) -> True -- Kind k can be instantiated with *+#else+                 StarK    -> True+#endif+                 _ -> False+    _ -> False++distinctKindVars :: Kind -> Set Name+#if MIN_VERSION_template_haskell(2,8,0)+distinctKindVars (AppT k1 k2) = distinctKindVars k1 `Set.union` distinctKindVars k2+distinctKindVars (SigT k _)   = distinctKindVars k+distinctKindVars (VarT k)     = Set.singleton k+#endif+distinctKindVars _            = Set.empty++tvbToType :: TyVarBndr -> Type+tvbToType (PlainTV n)    = VarT n+tvbToType (KindedTV n k) = SigT (VarT n) k++-------------------------------------------------------------------------------+-- Manually quoted names+-------------------------------------------------------------------------------++-- By manually generating these names we avoid needing to use the+-- TemplateHaskell language extension when compiling the bifunctors library.+-- This allows the library to be used in stage1 cross-compilers.++bifunctorsPackageKey :: String+#ifdef CURRENT_PACKAGE_KEY+bifunctorsPackageKey = CURRENT_PACKAGE_KEY+#else+bifunctorsPackageKey = "bifunctors-" ++ showVersion version+#endif++mkBifunctorsName_tc :: String -> String -> Name+mkBifunctorsName_tc = mkNameG_tc bifunctorsPackageKey++mkBifunctorsName_v :: String -> String -> Name+mkBifunctorsName_v = mkNameG_v bifunctorsPackageKey++bifoldableTypeName :: Name+bifoldableTypeName = mkBifunctorsName_tc "Data.Bifoldable" "Bifoldable"++bitraversableTypeName :: Name+bitraversableTypeName = mkBifunctorsName_tc "Data.Bitraversable" "Bitraversable"++bifoldrValName :: Name+bifoldrValName = mkBifunctorsName_v "Data.Bifoldable" "bifoldr"++bifoldMapValName :: Name+bifoldMapValName = mkBifunctorsName_v "Data.Bifoldable" "bifoldMap"++bitraverseValName :: Name+bitraverseValName = mkBifunctorsName_v "Data.Bitraversable" "bitraverse"++bimapConstValName :: Name+bimapConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bimapConst"++bifoldrConstValName :: Name+bifoldrConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldrConst"++bifoldMapConstValName :: Name+bifoldMapConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldMapConst"++bitraverseConstValName :: Name+bitraverseConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bitraverseConst"++dualDataName :: Name+dualDataName = mkNameG_d "base" "Data.Monoid" "Dual"++endoDataName :: Name+endoDataName = mkNameG_d "base" "Data.Monoid" "Endo"++wrapMonadDataName :: Name+wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad"++functorTypeName :: Name+functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor"++foldableTypeName :: Name+foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable"++traversableTypeName :: Name+traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable"++appEndoValName :: Name+appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo"++composeValName :: Name+composeValName = mkNameG_v "base" "GHC.Base" "."++idValName :: Name+idValName = mkNameG_v "base" "GHC.Base" "id"++errorValName :: Name+errorValName = mkNameG_v "base" "GHC.Err" "error"++flipValName :: Name+flipValName = mkNameG_v "base" "GHC.Base" "flip"++fmapValName :: Name+fmapValName = mkNameG_v "base" "GHC.Base" "fmap"++foldrValName :: Name+foldrValName = mkNameG_v "base" "Data.Foldable" "foldr"++foldMapValName :: Name+foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap"++getDualValName :: Name+getDualValName = mkNameG_v "base" "Data.Monoid" "getDual"++traverseValName :: Name+traverseValName = mkNameG_v "base" "Data.Traversable" "traverse"++unwrapMonadValName :: Name+unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad"++#if MIN_VERSION_base(4,8,0)+bifunctorTypeName :: Name+bifunctorTypeName = mkNameG_tc "base" "Data.Bifunctor" "Bifunctor"++bimapValName :: Name+bimapValName = mkNameG_v "base" "Data.Bifunctor" "bimap"++pureValName :: Name+pureValName = mkNameG_v "base" "GHC.Base" "pure"++apValName :: Name+apValName = mkNameG_v "base" "GHC.Base" "<*>"++mappendValName :: Name+mappendValName = mkNameG_v "base" "GHC.Base" "mappend"++memptyValName :: Name+memptyValName = mkNameG_v "base" "GHC.Base" "mempty"+#else+bifunctorTypeName :: Name+bifunctorTypeName = mkBifunctorsName_tc "Data.Bifunctor" "Bifunctor"++bimapValName :: Name+bimapValName = mkBifunctorsName_v "Data.Bifunctor" "bimap"++pureValName :: Name+pureValName = mkNameG_v "base" "Control.Applicative" "pure"++apValName :: Name+apValName = mkNameG_v "base" "Control.Applicative" "<*>"++mappendValName :: Name+mappendValName = mkNameG_v "base" "Data.Monoid" "mappend"++memptyValName :: Name+memptyValName = mkNameG_v "base" "Data.Monoid" "mempty"+#endif

@@ -1,3 +1,9 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Copyright   :  (C) 2008-2015 Edward Kmett@@ -12,17 +18,31 @@   ( Tannen(..)   ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif+ import Data.Biapplicative import Data.Bifoldable import Data.Bitraversable++#if __GLASGOW_HASKELL__ < 710 import Data.Foldable import Data.Monoid import Data.Traversable+#endif +#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#endif+ -- | 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)+  deriving ( Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 708+           , Typeable+#endif+           )  instance (Functor f, Bifunctor p) => Bifunctor (Tannen f p) where   first f = Tannen . fmap (first f) . runTannen

@@ -1,3 +1,9 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Copyright   :  (C) 2008-2015 Edward Kmett@@ -12,17 +18,31 @@   ( WrappedBifunctor(..)   ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif+ import Data.Biapplicative import Data.Bifoldable import Data.Bitraversable++#if __GLASGOW_HASKELL__ < 710 import Data.Foldable import Data.Monoid import Data.Traversable+#endif +#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable+#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)+  deriving ( Eq, Ord, Show, Read+#if __GLASGOW_HASKELL__ >= 708+           , Typeable+#endif+           )  instance Bifunctor p => Bifunctor (WrappedBifunctor p) where   first f = WrapBifunctor . first f . unwrapBifunctor

@@ -1,11 +1,15 @@ {-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif  #ifndef MIN_VERSION_semigroups #define MIN_VERSION_semigroups(x,y,z) 0 #endif ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2011 Edward Kmett+-- Copyright   :  (C) 2011-2015 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -15,6 +19,9 @@ ---------------------------------------------------------------------------- module Data.Bitraversable   ( Bitraversable(..)+  , bisequenceA+  , bisequence+  , bimapM   , bifor   , biforM   , bimapAccumL@@ -37,7 +44,9 @@ import Data.Tagged #endif --- | Minimal complete definition either 'bitraverse' or 'bisequenceA'.+#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710+import Data.Typeable+#endif  -- | 'Bitraversable' identifies bifunctorial data structures whose elements can -- be traversed in order, performing 'Applicative' or 'Monad' actions at each@@ -56,19 +65,6 @@ --   @'Compose' . 'fmap' ('bitraverse' g1 g2) . 'bitraverse' f1 f2 --     ≡ 'traverse' ('Compose' . 'fmap' g1 . f1) ('Compose' . 'fmap' g2 . f2)@ ----- A definition of 'bisequenceA' must satisfy the following laws:------ [/naturality/]---   @'bisequenceA' . 'bimap' t t ≡ t . 'bisequenceA'@---   for every applicative transformation @t@------ [/identity/]---   @'bisequenceA' . 'bimap' 'Identity' 'Identity' ≡ 'Identity'@------ [/composition/]---   @'bisequenceA' . 'bimap' 'Compose' 'Compose'---     ≡ 'Compose' . 'fmap' 'bisequenceA' . 'bisequenceA'@--- -- where an /applicative transformation/ is a function -- -- @t :: ('Applicative' f, 'Applicative' g) => f a -> g a@@@ -128,38 +124,39 @@   bitraverse f g = bisequenceA . bimap f g   {-# INLINE bitraverse #-} -  -- | Sequences all the actions in a structure, building a new structure with the-  -- same shape using the results of the actions.-  ---  -- @'bisequenceA' ≡ 'bitraverse' 'id' 'id'@-  bisequenceA :: Applicative f => t (f a) (f b) -> f (t a b)-  bisequenceA = bitraverse id id-  {-# INLINE bisequenceA #-} -  -- | As 'bitraverse', but uses evidence that @m@ is a 'Monad' rather than an-  -- 'Applicative'.-  ---  -- @-  -- 'bimapM' f g ≡ 'bisequence' . 'bimap' f g-  -- 'bimapM' f g ≡ 'unwrapMonad' . 'bitraverse' ('WrapMonad' . f) ('WrapMonad' . g)-  -- @-  bimapM :: Monad m => (a -> m c) -> (b -> m d) -> t a b -> m (t c d)-  bimapM f g = unwrapMonad . bitraverse (WrapMonad . f) (WrapMonad . g)-  {-# INLINE bimapM #-}+-- | Sequences all the actions in a structure, building a new structure with the+-- same shape using the results of the actions.+--+-- @'bisequenceA' ≡ 'bitraverse' 'id' 'id'@+bisequenceA :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b)+bisequenceA = bitraverse id id+{-# INLINE bisequenceA #-} -  -- | As 'bisequenceA', but uses evidence that @m@ is a 'Monad' rather than an-  -- 'Applicative'.-  ---  -- @-  -- 'bisequence' ≡ 'bimapM' 'id' 'id'-  -- 'bisequence' ≡ 'unwrapMonad' . 'bisequenceA' . 'bimap' 'WrapMonad' 'WrapMonad'-  -- @-  bisequence :: Monad m => t (m a) (m b) -> m (t a b)-  bisequence = bimapM id id-  {-# INLINE bisequence #-}+-- | As 'bitraverse', but uses evidence that @m@ is a 'Monad' rather than an+-- 'Applicative'.+--+-- @+-- 'bimapM' f g ≡ 'bisequence' . 'bimap' f g+-- 'bimapM' f g ≡ 'unwrapMonad' . 'bitraverse' ('WrapMonad' . f) ('WrapMonad' . g)+-- @+bimapM :: (Bitraversable t, Monad m) => (a -> m c) -> (b -> m d) -> t a b -> m (t c d)+bimapM f g = unwrapMonad . bitraverse (WrapMonad . f) (WrapMonad . g)+{-# INLINE bimapM #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708-  {-# MINIMAL bitraverse | bisequenceA #-}+-- | As 'bisequenceA', but uses evidence that @m@ is a 'Monad' rather than an+-- 'Applicative'.+--+-- @+-- 'bisequence' ≡ 'bimapM' 'id' 'id'+-- 'bisequence' ≡ 'unwrapMonad' . 'bisequenceA' . 'bimap' 'WrapMonad' 'WrapMonad'+-- @+bisequence :: (Bitraversable t, Monad m) => t (m a) (m b) -> m (t a b)+bisequence = bimapM id id+{-# INLINE bisequence #-}++#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710+deriving instance Typeable Bitraversable #endif  #if MIN_VERSION_semigroups(0,16,2)

@@ -0,0 +1,183 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}++{-|+Module:      BifunctorSpec+Copyright:   (C) 2008-2015 Edward Kmett, (C) 2015 Ryan Scott+License:     BSD-style (see the file LICENSE)+Maintainer:  Edward Kmett+Portability: Template Haskell++@hspec@ tests for the "Data.Bifunctor.TH" module.+-}+module BifunctorSpec where++import Data.Bifunctor+import Data.Bifunctor.TH+import Data.Bifoldable+import Data.Bitraversable++import Data.Char (chr)+import Data.Functor.Classes (Eq1)+import Data.Functor.Compose (Compose(..))+import Data.Functor.Identity (Identity(..))+import Data.Monoid++import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary)++#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative (Applicative(..))+import Data.Foldable (Foldable)+import Data.Traversable (Traversable)+#endif++-------------------------------------------------------------------------------++-- Adapted from the test cases from+-- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch++data Strange a b c+    = T1 a b c+    | T2 [a] [b] [c]         -- lists+    | T3 [[a]] [[b]] [[c]]   -- nested lists+    | T4 (c,(b,b),(c,c))     -- tuples+    | T5 ([c],Strange a b c) -- tycons++type IntFun a b = (b -> Int) -> a+data StrangeFunctions a b c+    = T6 (a -> c)            -- function types+    | T7 (a -> (c,a))        -- functions and tuples+    | T8 ((b -> a) -> c)     -- continuation+    | T9 (IntFun b c)        -- type synonyms++data StrangeGADT a b where+    T10 :: Ord b            => b        -> StrangeGADT a b+    T11 ::                     Int      -> StrangeGADT a Int+    T12 :: c ~ Int          => c        -> StrangeGADT a Int+    T13 :: b ~ Int          => Int      -> StrangeGADT a b+    T14 :: b ~ Int          => b        -> StrangeGADT a b+    T15 :: (b ~ c, c ~ Int) => Int -> c -> StrangeGADT a b++data NotPrimitivelyRecursive a b+    = S1 (NotPrimitivelyRecursive (a,a) (b, a))+    | S2 a+    | S3 b++newtype OneTwoCompose f g a b = OneTwoCompose (f (g a b))+  deriving (Arbitrary, Eq, Show)++newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g a,a,b))++data Universal a b+    = Universal  (forall b. (b,[a]))+    | Universal2 (forall f. Bifunctor f => f a b)+    | Universal3 (forall a. Maybe a) -- reuse a+    | NotReallyUniversal (forall b. a)++data Existential a b+    = forall a. ExistentialList [a]+    | forall f. Bitraversable f => ExistentialFunctor (f a b)+    | forall b. SneakyUseSameName (Maybe b)++-------------------------------------------------------------------------------++$(deriveBifunctor     ''Strange)+$(deriveBifoldable    ''Strange)+$(deriveBitraversable ''Strange)++$(deriveBifunctor     ''StrangeFunctions)+$(deriveBifoldable    ''StrangeGADT)++$(deriveBifunctor     ''NotPrimitivelyRecursive)+$(deriveBifoldable    ''NotPrimitivelyRecursive)+$(deriveBitraversable ''NotPrimitivelyRecursive)++$(deriveBifunctor     ''OneTwoCompose)+$(deriveBifoldable    ''OneTwoCompose)+$(deriveBitraversable ''OneTwoCompose)++instance (Bifunctor (f Int), Functor g) =>+  Bifunctor (ComplexConstraint f g) where+    bimap = $(makeBimap ''ComplexConstraint)+instance (Bifoldable (f Int), Foldable g) =>+  Bifoldable (ComplexConstraint f g) where+    bifoldr   = $(makeBifoldr ''ComplexConstraint)+    bifoldMap = $(makeBifoldMap ''ComplexConstraint)+instance (Bitraversable (f Int), Traversable g) =>+  Bitraversable (ComplexConstraint f g) where+    bitraverse = $(makeBitraverse ''ComplexConstraint)++$(deriveBifunctor     ''Universal)++$(deriveBifunctor     ''Existential)+$(deriveBifoldable    ''Existential)+$(deriveBitraversable ''Existential)++-------------------------------------------------------------------------------++prop_BifunctorLaws :: (Bifunctor p, Eq (p a b), Eq (p c d))+                   => (a -> c) -> (b -> d) -> p a b -> Bool+prop_BifunctorLaws f g x =+       bimap  id id x == x+    && first  id    x == x+    && second id    x == x+    && bimap  f  g  x == (first f . second g) x++prop_BifoldableLaws :: (Eq a, Eq b, Eq z, Monoid a, Monoid b, Bifoldable p)+                => (a -> b) -> (a -> b)+                -> (a -> z -> z) -> (a -> z -> z)+                -> z -> p a a -> Bool+prop_BifoldableLaws f g h i z x =+       bifold        x == bifoldMap id id x+    && 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_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)+                       -> (f c -> f c) -> p a b -> Bool+prop_BitraversableLaws f g h i t x =+       bitraverse (t . f) (t . g)   x == bitraverse f g x+    && bitraverse Identity Identity x == Identity x+    && (Compose . fmap (bitraverse h i) . bitraverse f g) x+       == bitraverse (Compose . fmap h . f) (Compose . fmap i . g) x++-------------------------------------------------------------------------------++main :: IO ()+main = hspec spec++spec :: Spec+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 "satisfies the Bifoldable laws"+            (prop_BifoldableLaws+                reverse (++ [42])+                ((+) . length)+                ((*) . length)+                0+                :: 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)

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