diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -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/; diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -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 ------------------- diff --git a/bifunctors.cabal b/bifunctors.cabal --- a/bifunctors.cabal +++ b/bifunctors.cabal @@ -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 @@ -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 diff --git a/old-src/Data/Bifunctor.hs b/old-src/Data/Bifunctor.hs --- a/old-src/Data/Bifunctor.hs +++ b/old-src/Data/Bifunctor.hs @@ -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) diff --git a/src/Data/Biapplicative.hs b/src/Data/Biapplicative.hs --- a/src/Data/Biapplicative.hs +++ b/src/Data/Biapplicative.hs @@ -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 diff --git a/src/Data/Bifoldable.hs b/src/Data/Bifoldable.hs --- a/src/Data/Bifoldable.hs +++ b/src/Data/Bifoldable.hs @@ -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) diff --git a/src/Data/Bifunctor/Biff.hs b/src/Data/Bifunctor/Biff.hs --- a/src/Data/Bifunctor/Biff.hs +++ b/src/Data/Bifunctor/Biff.hs @@ -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 diff --git a/src/Data/Bifunctor/Clown.hs b/src/Data/Bifunctor/Clown.hs --- a/src/Data/Bifunctor/Clown.hs +++ b/src/Data/Bifunctor/Clown.hs @@ -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 diff --git a/src/Data/Bifunctor/Fix.hs b/src/Data/Bifunctor/Fix.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bifunctor/Fix.hs @@ -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 +-- 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 #-} diff --git a/src/Data/Bifunctor/Flip.hs b/src/Data/Bifunctor/Flip.hs --- a/src/Data/Bifunctor/Flip.hs +++ b/src/Data/Bifunctor/Flip.hs @@ -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 diff --git a/src/Data/Bifunctor/Join.hs b/src/Data/Bifunctor/Join.hs --- a/src/Data/Bifunctor/Join.hs +++ b/src/Data/Bifunctor/Join.hs @@ -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) diff --git a/src/Data/Bifunctor/Joker.hs b/src/Data/Bifunctor/Joker.hs --- a/src/Data/Bifunctor/Joker.hs +++ b/src/Data/Bifunctor/Joker.hs @@ -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 diff --git a/src/Data/Bifunctor/Product.hs b/src/Data/Bifunctor/Product.hs --- a/src/Data/Bifunctor/Product.hs +++ b/src/Data/Bifunctor/Product.hs @@ -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) diff --git a/src/Data/Bifunctor/TH.hs b/src/Data/Bifunctor/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bifunctor/TH.hs @@ -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 +-- 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: + +@ +{-# LANGUAGE TemplateHaskell #-} +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: + +@ +{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-} +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': + +@ +{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} +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 diff --git a/src/Data/Bifunctor/TH/Internal.hs b/src/Data/Bifunctor/TH/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bifunctor/TH/Internal.hs @@ -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 diff --git a/src/Data/Bifunctor/Tannen.hs b/src/Data/Bifunctor/Tannen.hs --- a/src/Data/Bifunctor/Tannen.hs +++ b/src/Data/Bifunctor/Tannen.hs @@ -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 diff --git a/src/Data/Bifunctor/Wrapped.hs b/src/Data/Bifunctor/Wrapped.hs --- a/src/Data/Bifunctor/Wrapped.hs +++ b/src/Data/Bifunctor/Wrapped.hs @@ -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 diff --git a/src/Data/Bitraversable.hs b/src/Data/Bitraversable.hs --- a/src/Data/Bitraversable.hs +++ b/src/Data/Bitraversable.hs @@ -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 @@ -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) diff --git a/tests/BifunctorSpec.hs b/tests/BifunctorSpec.hs new file mode 100644 --- /dev/null +++ b/tests/BifunctorSpec.hs @@ -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) diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}