bifunctors-5.1/0000755000000000000000000000000012617716006011731 5ustar0000000000000000bifunctors-5.1/.travis.yml0000644000000000000000000000260012617716006014040 0ustar0000000000000000env: - GHCVER=7.0.1 CABALVER=1.16 - GHCVER=7.0.4 CABALVER=1.16 - GHCVER=7.2.2 CABALVER=1.16 - GHCVER=7.4.2 CABALVER=1.16 - GHCVER=7.6.3 CABALVER=1.16 - GHCVER=7.8.4 CABALVER=1.18 - GHCVER=7.10.1 CABALVER=1.22 - GHCVER=head CABALVER=1.22 matrix: allow_failures: - env: GHCVER=head CABALVER=1.20 - env: GHCVER=7.0.1 CABALVER=1.16 - env: GHCVER=7.0.4 CABALVER=1.16 - env: GHCVER=7.2.2 CABALVER=1.16 before_install: - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - travis_retry sudo apt-get update - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH - cabal --version 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/; if [ -f "$SRC_TGZ" ]; then cabal install "$SRC_TGZ"; else echo "expected '$SRC_TGZ' not found"; exit 1; fi notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313bifunctors\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f" bifunctors-5.1/bifunctors.cabal0000644000000000000000000000466612617716006015107 0ustar0000000000000000name: bifunctors category: Data, Functors version: 5.1 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/bifunctors/ bug-reports: http://github.com/ekmett/bifunctors/issues copyright: Copyright (C) 2008-2015 Edward A. Kmett synopsis: Bifunctors description: Bifunctors build-type: Simple tested-with: GHC == 7.0.1, GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1 extra-source-files: .travis.yml CHANGELOG.markdown README.markdown source-repository head type: git location: git://github.com/ekmett/bifunctors.git flag semigroups default: True manual: True description: You can disable the use of the `semigroups` package using `-f-semigroups`. . Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. flag tagged default: True manual: True description: You can disable the use of the `tagged` package using `-f-tagged`. . Disabing this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. library hs-source-dirs: src build-depends: base >= 4 && < 5, containers >= 0.1 && < 0.6, template-haskell >= 2.4 && < 2.11 if flag(tagged) build-depends: tagged >= 0.7.3 && < 1 if flag(semigroups) build-depends: semigroups >= 0.8.3.1 && < 1 if impl(ghc<7.9) hs-source-dirs: old-src exposed-modules: Data.Bifunctor exposed-modules: Data.Biapplicative 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 bifunctors-5.1/CHANGELOG.markdown0000644000000000000000000000245712617716006014774 0ustar00000000000000005.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. * Added flags 4.2.1 ----- * Support `Arg` from `semigroups` 0.16.2 * Fixed a typo. 4.2 --- * Bumped dependency on `tagged`, which is required to build cleanly on GHC 7.9+ * Only export `Data.Bifunctor` when building on GHC < 7.9, otherwise it comes from `base`. 4.1.1.1 ------- * Added documentation for 'Bifoldable' and 'Bitraversable' 4.1.1 ----- * Added `Data.Bifunctor.Join` * Fixed improper lower bounds on `base` 4.1.0.1 ------- * Updated to BSD 2-clause license 4.1 --- * Added product bifunctors 4.0 --- * Compatibility with `semigroupoids` 4.0 3.2 --- * Added missing product instances for `Biapplicative` and `Biapply`. 3.1 ----- * Added `Data.Biapplicative`. * Added the `Clown` and `Joker` bifunctors from Conor McBride's "Clowns to the left of me, Jokers to the right." * Added instances for `Const`, higher tuples * Added `Tagged` instances. 3.0.4 ----- * Added `Data.Bifunctor.Flip` and `Data.Bifunctor.Wrapped`. 3.0.3 --- * Removed upper bounds from my other package dependencies bifunctors-5.1/LICENSE0000644000000000000000000000236412617716006012743 0ustar0000000000000000Copyright 2008-2015 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. bifunctors-5.1/README.markdown0000644000000000000000000000071012617716006014430 0ustar0000000000000000bifunctors ========== [![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 ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett bifunctors-5.1/Setup.lhs0000644000000000000000000000016512617716006013543 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain bifunctors-5.1/old-src/0000755000000000000000000000000012617716006013274 5ustar0000000000000000bifunctors-5.1/old-src/Data/0000755000000000000000000000000012617716006014145 5ustar0000000000000000bifunctors-5.1/old-src/Data/Bifunctor.hs0000644000000000000000000001060012617716006016431 0ustar0000000000000000{-# 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) 2008-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Bifunctor ( -- * Overview -- -- Bifunctors extend the standard 'Functor' to two arguments -- * Examples -- $examples Bifunctor(..) ) where import Control.Applicative #if MIN_VERSION_semigroups(0,16,2) import Data.Semigroup #endif #ifdef MIN_VERSION_tagged 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 -- from @Hask@ -> @Hask@. -- -- Intuitively it is a bifunctor where both the first and second arguments are covariant. -- -- You can define a 'Bifunctor' by either defining 'bimap' or by defining both -- 'first' and 'second'. -- -- If you supply 'bimap', you should ensure that: -- -- @'bimap' 'id' 'id' ≡ 'id'@ -- -- If you supply 'first' and 'second', ensure: -- -- @ -- 'first' 'id' ≡ 'id' -- 'second' 'id' ≡ 'id' -- @ -- -- If you supply both, you should also ensure: -- -- @'bimap' f g ≡ 'first' f '.' 'second' g@ -- -- These ensure by parametricity: -- -- @ -- 'bimap' (f '.' g) (h '.' i) ≡ 'bimap' f h '.' 'bimap' g i -- 'first' (f '.' g) ≡ 'first' f '.' 'first' g -- 'second' (f '.' g) ≡ 'second' f '.' 'second' g -- @ class Bifunctor p where -- | Map over both arguments at the same time. -- -- @'bimap' f g ≡ 'first' f '.' 'second' g@ bimap :: (a -> b) -> (c -> d) -> p a c -> p b d bimap f g = first f . second g {-# INLINE bimap #-} -- | Map covariantly over the first argument. -- -- @'first' f ≡ 'bimap' f 'id'@ first :: (a -> b) -> p a c -> p b c first f = bimap f id {-# INLINE first #-} -- | Map covariantly over the second argument. -- -- @'second' ≡ 'bimap' 'id'@ second :: (b -> c) -> p a b -> p a c second = bimap id {-# INLINE second #-} #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL bimap | first, second #-} deriving instance Typeable Bifunctor #endif instance Bifunctor (,) where bimap f g ~(a, b) = (f a, g b) {-# INLINE bimap #-} #if MIN_VERSION_semigroups(0,16,2) instance Bifunctor Arg where bimap f g (Arg a b) = Arg (f a) (g b) #endif instance Bifunctor ((,,) x) where bimap f g ~(x, a, b) = (x, f a, g b) {-# INLINE bimap #-} instance Bifunctor ((,,,) x y) where bimap f g ~(x, y, a, b) = (x, y, f a, g b) {-# INLINE bimap #-} instance Bifunctor ((,,,,) x y z) where bimap f g ~(x, y, z, a, b) = (x, y, z, f a, g b) {-# INLINE bimap #-} instance Bifunctor ((,,,,,) x y z w) where bimap f g ~(x, y, z, w, a, b) = (x, y, z, w, f a, g b) {-# INLINE bimap #-} instance Bifunctor ((,,,,,,) x y z w v) where bimap f g ~(x, y, z, w, v, a, b) = (x, y, z, w, v, f a, g b) {-# INLINE bimap #-} instance Bifunctor Either where bimap f _ (Left a) = Left (f a) bimap _ g (Right b) = Right (g b) {-# INLINE bimap #-} instance Bifunctor Const where bimap f _ (Const a) = Const (f a) {-# INLINE bimap #-} #ifdef MIN_VERSION_tagged instance Bifunctor Tagged where 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) bifunctors-5.1/src/0000755000000000000000000000000012617716006012520 5ustar0000000000000000bifunctors-5.1/src/Data/0000755000000000000000000000000012617716006013371 5ustar0000000000000000bifunctors-5.1/src/Data/Biapplicative.hs0000644000000000000000000000760112617716006016505 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef MIN_VERSION_semigroups #define MIN_VERSION_semigroups(x,y,z) 0 #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Biapplicative ( -- * Biapplicative bifunctors Biapplicative(..) , (<<$>>) , (<<**>>) , biliftA2 , biliftA3 , module Data.Bifunctor ) where import Control.Applicative import Data.Bifunctor #if MIN_VERSION_semigroups(0,16,2) import Data.Semigroup #else import Data.Monoid #endif #ifdef MIN_VERSION_tagged import Data.Tagged #endif infixl 4 <<$>>, <<*>>, <<*, *>>, <<**>> (<<$>>) :: (a -> b) -> a -> b (<<$>>) = id {-# INLINE (<<$>>) #-} class Bifunctor p => Biapplicative p where bipure :: a -> b -> p a b (<<*>>) :: p (a -> b) (c -> d) -> p a c -> p b d -- | -- @ -- 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 {-# INLINE (*>>) #-} -- | -- @ -- a '<<*' b ≡ 'bimap' 'const' 'const' '<<$>>' a '<<*>>' b -- @ (<<*) :: p a b -> p c d -> p a b a <<* b = bimap const const <<$>> a <<*>> b {-# INLINE (<<*) #-} (<<**>>) :: Biapplicative p => p a c -> p (a -> b) (c -> d) -> p b d (<<**>>) = biliftA2 (flip id) (flip id) {-# INLINE (<<**>>) #-} -- | Lift binary functions biliftA2 :: Biapplicative w => (a -> b -> c) -> (d -> e -> f) -> w a d -> w b e -> w c f biliftA2 f g a b = bimap f g <<$>> a <<*>> b {-# INLINE biliftA2 #-} -- | Lift ternary functions biliftA3 :: Biapplicative w => (a -> b -> c -> d) -> (e -> f -> g -> h) -> w a e -> w b f -> w c g -> w d h biliftA3 f g a b c = bimap f g <<$>> a <<*>> b <<*>> c {-# INLINE biliftA3 #-} instance Biapplicative (,) where bipure = (,) {-# INLINE bipure #-} (f, g) <<*>> (a, b) = (f a, g b) {-# INLINE (<<*>>) #-} #if MIN_VERSION_semigroups(0,16,2) instance Biapplicative Arg where bipure = Arg {-# INLINE bipure #-} Arg f g <<*>> Arg a b = Arg (f a) (g b) {-# INLINE (<<*>>) #-} #endif instance Monoid x => Biapplicative ((,,) x) where bipure = (,,) mempty {-# INLINE bipure #-} (x, f, g) <<*>> (x', a, b) = (mappend x x', f a, g b) {-# INLINE (<<*>>) #-} instance (Monoid x, Monoid y) => Biapplicative ((,,,) x y) where bipure = (,,,) mempty mempty {-# INLINE bipure #-} (x, y, f, g) <<*>> (x', y', a, b) = (mappend x x', mappend y y', f a, g b) {-# INLINE (<<*>>) #-} instance (Monoid x, Monoid y, Monoid z) => Biapplicative ((,,,,) x y z) where bipure = (,,,,) mempty mempty mempty {-# INLINE bipure #-} (x, y, z, f, g) <<*>> (x', y', z', a, b) = (mappend x x', mappend y y', mappend z z', f a, g b) {-# INLINE (<<*>>) #-} instance (Monoid x, Monoid y, Monoid z, Monoid w) => Biapplicative ((,,,,,) x y z w) where bipure = (,,,,,) mempty mempty mempty mempty {-# INLINE bipure #-} (x, y, z, w, f, g) <<*>> (x', y', z', w', a, b) = (mappend x x', mappend y y', mappend z z', mappend w w', f a, g b) {-# INLINE (<<*>>) #-} instance (Monoid x, Monoid y, Monoid z, Monoid w, Monoid v) => Biapplicative ((,,,,,,) x y z w v) where bipure = (,,,,,,) mempty mempty mempty mempty mempty {-# INLINE bipure #-} (x, y, z, w, v, f, g) <<*>> (x', y', z', w', v', a, b) = (mappend x x', mappend y y', mappend z z', mappend w w', mappend v v', f a, g b) {-# INLINE (<<*>>) #-} #ifdef MIN_VERSION_tagged instance Biapplicative Tagged where bipure _ b = Tagged b {-# INLINE bipure #-} Tagged f <<*>> Tagged x = Tagged (f x) {-# INLINE (<<*>>) #-} #endif instance Biapplicative Const where bipure a _ = Const a {-# INLINE bipure #-} Const f <<*>> Const x = Const (f x) {-# INLINE (<<*>>) #-} bifunctors-5.1/src/Data/Bifoldable.hs0000644000000000000000000001774012617716006015761 0ustar0000000000000000{-# 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-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Bifoldable ( Bifoldable(..) , bifoldr' , bifoldrM , bifoldl' , bifoldlM , bitraverse_ , bifor_ , bimapM_ , biforM_ , bisequenceA_ , bisequence_ , biList , biconcat , biconcatMap , biany , biall ) where import Control.Applicative #if MIN_VERSION_semigroups(0,16,2) import Data.Semigroup #else import Data.Monoid #endif #ifdef MIN_VERSION_tagged 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 -- elements. Common examples are 'Either' and '(,)': -- -- > instance Bifoldable Either where -- > bifoldMap f _ (Left a) = f a -- > bifoldMap _ g (Right b) = g b -- > -- > instance Bifoldable (,) where -- > bifoldr f g z (a, b) = f a (g b z) -- -- When defining more than the minimal set of definitions, one should ensure -- that the following identities hold: -- -- @ -- 'bifold' ≡ 'bifoldMap' 'id' 'id' -- 'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty' -- 'bifoldr' f g z t ≡ 'appEndo' ('bifoldMap' (Endo . f) (Endo . g) t) z -- @ class Bifoldable p where -- | Combines the elements of a structure using a monoid. -- -- @'bifold' ≡ 'bifoldMap' 'id' 'id'@ bifold :: Monoid m => p m m -> m bifold = bifoldMap id id {-# INLINE bifold #-} -- | Combines the elements of a structure, given ways of mapping them to a -- common monoid. -- -- @'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty'@ bifoldMap :: Monoid m => (a -> m) -> (b -> m) -> p a b -> m bifoldMap f g = bifoldr (mappend . f) (mappend . g) mempty {-# INLINE bifoldMap #-} -- | Combines the elements of a structure in a right associative manner. Given -- a hypothetical function @toEitherList :: p a b -> [Either a b]@ yielding a -- list of all elements of a structure in order, the following would hold: -- -- @'bifoldr' f g z ≡ 'foldr' ('either' f g) z . toEitherList@ bifoldr :: (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c bifoldr f g z t = appEndo (bifoldMap (Endo . f) (Endo . g) t) z {-# INLINE bifoldr #-} -- | Combines the elments of a structure in a left associative manner. Given a -- hypothetical function @toEitherList :: p a b -> [Either a b]@ yielding a -- list of all elements of a structure in order, the following would hold: -- -- @'bifoldl' f g z ≡ 'foldl' (\acc -> 'either' (f acc) (g acc)) z . toEitherList@ bifoldl :: (c -> a -> c) -> (c -> b -> c) -> c -> p a b -> c bifoldl f g z t = appEndo (getDual (bifoldMap (Dual . Endo . flip f) (Dual . Endo . flip g) t)) z {-# INLINE bifoldl #-} #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL bifoldr | bifoldMap #-} deriving instance Typeable Bifoldable #endif #if MIN_VERSION_semigroups(0,16,2) instance Bifoldable Arg where bifoldMap f g (Arg a b) = f a `mappend` g b #endif instance Bifoldable (,) where bifoldMap f g ~(a, b) = f a `mappend` g b {-# INLINE bifoldMap #-} instance Bifoldable Const where bifoldMap f _ (Const a) = f a {-# INLINE bifoldMap #-} instance Bifoldable ((,,) x) where bifoldMap f g ~(_,a,b) = f a `mappend` g b {-# INLINE bifoldMap #-} instance Bifoldable ((,,,) x y) where bifoldMap f g ~(_,_,a,b) = f a `mappend` g b {-# INLINE bifoldMap #-} instance Bifoldable ((,,,,) x y z) where bifoldMap f g ~(_,_,_,a,b) = f a `mappend` g b {-# INLINE bifoldMap #-} instance Bifoldable ((,,,,,) x y z w) where bifoldMap f g ~(_,_,_,_,a,b) = f a `mappend` g b {-# INLINE bifoldMap #-} instance Bifoldable ((,,,,,,) x y z w v) where bifoldMap f g ~(_,_,_,_,_,a,b) = f a `mappend` g b {-# INLINE bifoldMap #-} #ifdef MIN_VERSION_tagged instance Bifoldable Tagged where bifoldMap _ g (Tagged b) = g b {-# INLINE bifoldMap #-} #endif instance Bifoldable Either where bifoldMap f _ (Left a) = f a bifoldMap _ g (Right b) = g b {-# INLINE bifoldMap #-} -- | As 'bifoldr', but strict in the result of the reduction functions at each -- step. bifoldr' :: Bifoldable t => (a -> c -> c) -> (b -> c -> c) -> c -> t a b -> c bifoldr' f g z0 xs = bifoldl f' g' id xs z0 where f' k x z = k $! f x z g' k x z = k $! g x z {-# INLINE bifoldr' #-} -- | Right associative monadic bifold over a structure. bifoldrM :: (Bifoldable t, Monad m) => (a -> c -> m c) -> (b -> c -> m c) -> c -> t a b -> m c bifoldrM f g z0 xs = bifoldl f' g' return xs z0 where f' k x z = f x z >>= k g' k x z = g x z >>= k {-# INLINE bifoldrM #-} -- | As 'bifoldl', but strict in the result of the reductionf unctions at each -- step. bifoldl':: Bifoldable t => (a -> b -> a) -> (a -> c -> a) -> a -> t b c -> a bifoldl' f g z0 xs = bifoldr f' g' id xs z0 where f' x k z = k $! f z x g' x k z = k $! g z x {-# INLINE bifoldl' #-} -- | Left associative monadic bifold over a structure. bifoldlM :: (Bifoldable t, Monad m) => (a -> b -> m a) -> (a -> c -> m a) -> a -> t b c -> m a bifoldlM f g z0 xs = bifoldr f' g' return xs z0 where f' x k z = f z x >>= k g' x k z = g z x >>= k {-# INLINE bifoldlM #-} -- | As 'Data.Bitraversable.bitraverse', but ignores the results of the -- functions, merely performing the "actions". bitraverse_ :: (Bifoldable t, Applicative f) => (a -> f c) -> (b -> f d) -> t a b -> f () bitraverse_ f g = bifoldr ((*>) . f) ((*>) . g) (pure ()) {-# INLINE bitraverse_ #-} -- | As 'bitraverse_', but with the structure as the primary argument. bifor_ :: (Bifoldable t, Applicative f) => t a b -> (a -> f c) -> (b -> f d) -> f () bifor_ t f g = bitraverse_ f g t {-# INLINE bifor_ #-} -- | As 'Data.Bitraversable.bimapM', but ignores the results of the functions, -- merely performing -- the "actions". bimapM_:: (Bifoldable t, Monad m) => (a -> m c) -> (b -> m d) -> t a b -> m () bimapM_ f g = bifoldr ((>>) . f) ((>>) . g) (return ()) {-# INLINE bimapM_ #-} -- | As 'bimapM_', but with the structure as the primary argument. biforM_ :: (Bifoldable t, Monad m) => t a b -> (a -> m c) -> (b -> m d) -> m () biforM_ t f g = bimapM_ f g t {-# INLINE biforM_ #-} -- | As 'Data.Bitraversable.bisequenceA', but ignores the results of the actions. bisequenceA_ :: (Bifoldable t, Applicative f) => t (f a) (f b) -> f () bisequenceA_ = bifoldr (*>) (*>) (pure ()) {-# INLINE bisequenceA_ #-} -- | As 'Data.Bitraversable.bisequence', but ignores the results of the actions. bisequence_ :: (Bifoldable t, Monad m) => t (m a) (m b) -> m () bisequence_ = bifoldr (>>) (>>) (return ()) {-# INLINE bisequence_ #-} -- | Collects the list of elements of a structure in order. biList :: Bifoldable t => t a a -> [a] biList = bifoldr (:) (:) [] {-# INLINE biList #-} -- | Reduces a structure of lists to the concatenation of those lists. biconcat :: Bifoldable t => t [a] [a] -> [a] biconcat = bifold {-# INLINE biconcat #-} -- | Given a means of mapping the elements of a structure to lists, computes the -- concatenation of all such lists in order. biconcatMap :: Bifoldable t => (a -> [c]) -> (b -> [c]) -> t a b -> [c] biconcatMap = bifoldMap {-# INLINE biconcatMap #-} -- | Determines whether any element of the structure satisfies the appropriate -- predicate. biany :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool biany p q = getAny . bifoldMap (Any . p) (Any . q) {-# INLINE biany #-} -- | Determines whether all elements of the structure satisfy the appropriate -- predicate. biall :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool biall p q = getAll . bifoldMap (All . p) (All . q) {-# INLINE biall #-} bifunctors-5.1/src/Data/Bitraversable.hs0000644000000000000000000002163112617716006016515 0ustar0000000000000000{-# 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-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Bitraversable ( Bitraversable(..) , bisequenceA , bisequence , bimapM , bifor , biforM , bimapAccumL , bimapAccumR , bimapDefault , bifoldMapDefault ) where import Control.Applicative import Data.Bifunctor import Data.Bifoldable #if MIN_VERSION_semigroups(0,16,2) import Data.Semigroup #else import Data.Monoid #endif #ifdef MIN_VERSION_tagged import Data.Tagged #endif #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 -- element, and collecting a result structure with the same shape. -- -- A definition of 'traverse' must satisfy the following laws: -- -- [/naturality/] -- @'bitraverse' (t . f) (t . g) ≡ t . 'bitraverse' f g@ -- for every applicative transformation @t@ -- -- [/identity/] -- @'bitraverse' 'Identity' 'Identity' ≡ 'Identity'@ -- -- [/composition/] -- @'Compose' . 'fmap' ('bitraverse' g1 g2) . 'bitraverse' f1 f2 -- ≡ 'traverse' ('Compose' . 'fmap' g1 . f1) ('Compose' . 'fmap' g2 . f2)@ -- -- where an /applicative transformation/ is a function -- -- @t :: ('Applicative' f, 'Applicative' g) => f a -> g a@ -- -- preserving the 'Applicative' operations: -- -- @ -- t ('pure' x) = 'pure' x -- t (f '<*>' x) = t f '<*>' t x -- @ -- -- and the identity functor 'Identity' and composition functors 'Compose' are -- defined as -- -- > newtype Identity a = Identity { runIdentity :: a } -- > -- > instance Functor Identity where -- > fmap f (Identity x) = Identity (f x) -- > -- > instance Applicative Identity where -- > pure = Identity -- > Identity f <*> Identity x = Identity (f x) -- > -- > newtype Compose f g a = Compose (f (g a)) -- > -- > instance (Functor f, Functor g) => Functor (Compose f g) where -- > fmap f (Compose x) = Compose (fmap (fmap f) x) -- > -- > instance (Applicative f, Applicative g) => Applicative (Compose f g) where -- > pure = Compose . pure . pure -- > Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) -- -- Some simple examples are 'Either' and '(,)': -- -- > instance Bitraversable Either where -- > bitraverse f _ (Left x) = Left <$> f x -- > bitraverse _ g (Right y) = Right <$> g y -- > -- > instance Bitraversable (,) where -- > bitraverse f g (x, y) = (,) <$> f x <*> g y -- -- 'Bitraversable' relates to its superclasses in the following ways: -- -- @ -- 'bimap' f g ≡ 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g) -- 'bifoldMap' f g = 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g) -- @ -- -- These are available as 'bimapDefault' and 'bifoldMapDefault' respectively. class (Bifunctor t, Bifoldable t) => Bitraversable t where -- | Evaluates the relevant functions at each element in the structure, running -- the action, and builds a new structure with the same shape, using the -- elements produced from sequencing the actions. -- -- @'bitraverse' f g ≡ 'bisequenceA' . 'bimap' f g@ bitraverse :: Applicative f => (a -> f c) -> (b -> f d) -> t a b -> f (t c d) 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 :: (Bitraversable t, 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 :: (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 #-} -- | 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) instance Bitraversable Arg where bitraverse f g (Arg a b) = Arg <$> f a <*> g b #endif instance Bitraversable (,) where bitraverse f g ~(a, b) = (,) <$> f a <*> g b {-# INLINE bitraverse #-} instance Bitraversable ((,,) x) where bitraverse f g ~(x, a, b) = (,,) x <$> f a <*> g b {-# INLINE bitraverse #-} instance Bitraversable ((,,,) x y) where bitraverse f g ~(x, y, a, b) = (,,,) x y <$> f a <*> g b {-# INLINE bitraverse #-} instance Bitraversable ((,,,,) x y z) where bitraverse f g ~(x, y, z, a, b) = (,,,,) x y z <$> f a <*> g b {-# INLINE bitraverse #-} instance Bitraversable ((,,,,,) x y z w) where bitraverse f g ~(x, y, z, w, a, b) = (,,,,,) x y z w <$> f a <*> g b {-# INLINE bitraverse #-} instance Bitraversable ((,,,,,,) x y z w v) where bitraverse f g ~(x, y, z, w, v, a, b) = (,,,,,,) x y z w v <$> f a <*> g b {-# INLINE bitraverse #-} instance Bitraversable Either where bitraverse f _ (Left a) = Left <$> f a bitraverse _ g (Right b) = Right <$> g b {-# INLINE bitraverse #-} instance Bitraversable Const where bitraverse f _ (Const a) = Const <$> f a {-# INLINE bitraverse #-} #ifdef MIN_VERSION_tagged instance Bitraversable Tagged where bitraverse _ g (Tagged b) = Tagged <$> g b {-# INLINE bitraverse #-} #endif -- | 'bifor' is 'bitraverse' with the structure as the first argument. bifor :: (Bitraversable t, Applicative f) => t a b -> (a -> f c) -> (b -> f d) -> f (t c d) bifor t f g = bitraverse f g t {-# INLINE bifor #-} -- | 'biforM' is 'bimapM' with the structure as the first argument. biforM :: (Bitraversable t, Monad m) => t a b -> (a -> m c) -> (b -> m d) -> m (t c d) biforM t f g = bimapM f g t {-# INLINE biforM #-} -- | left-to-right state transformer newtype StateL s a = StateL { runStateL :: s -> (s, a) } instance Functor (StateL s) where fmap f (StateL k) = StateL $ \ s -> let (s', v) = k s in (s', f v) {-# INLINE fmap #-} instance Applicative (StateL s) where pure x = StateL (\ s -> (s, x)) {-# INLINE pure #-} StateL kf <*> StateL kv = StateL $ \ s -> let (s', f) = kf s (s'', v) = kv s' in (s'', f v) {-# INLINE (<*>) #-} -- | Traverses a structure from left to right, threading a state of type @a@ -- and using the given actions to compute new elements for the structure. bimapAccumL :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e)) -> a -> t b d -> (a, t c e) bimapAccumL f g s t = runStateL (bitraverse (StateL . flip f) (StateL . flip g) t) s {-# INLINE bimapAccumL #-} -- | right-to-left state transformer newtype StateR s a = StateR { runStateR :: s -> (s, a) } instance Functor (StateR s) where fmap f (StateR k) = StateR $ \ s -> let (s', v) = k s in (s', f v) {-# INLINE fmap #-} instance Applicative (StateR s) where pure x = StateR (\ s -> (s, x)) {-# INLINE pure #-} StateR kf <*> StateR kv = StateR $ \ s -> let (s', v) = kv s (s'', f) = kf s' in (s'', f v) {-# INLINE (<*>) #-} -- | Traverses a structure from right to left, threading a state of type @a@ -- and using the given actions to compute new elements for the structure. bimapAccumR :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e)) -> a -> t b d -> (a, t c e) bimapAccumR f g s t = runStateR (bitraverse (StateR . flip f) (StateR . flip g) t) s {-# INLINE bimapAccumR #-} newtype Id a = Id { getId :: a } instance Functor Id where fmap f (Id x) = Id (f x) {-# INLINE fmap #-} instance Applicative Id where pure = Id {-# INLINE pure #-} Id f <*> Id x = Id (f x) {-# INLINE (<*>) #-} -- | A default definition of 'bimap' in terms of the 'Bitraversable' operations. bimapDefault :: Bitraversable t => (a -> b) -> (c -> d) -> t a c -> t b d bimapDefault f g = getId . bitraverse (Id . f) (Id . g) {-# INLINE bimapDefault #-} -- | A default definition of 'bifoldMap' in terms of the 'Bitraversable' operations. bifoldMapDefault :: (Bitraversable t, Monoid m) => (a -> m) -> (b -> m) -> t a b -> m bifoldMapDefault f g = getConst . bitraverse (Const . f) (Const . g) {-# INLINE bifoldMapDefault #-} bifunctors-5.1/src/Data/Bifunctor/0000755000000000000000000000000012617716006015324 5ustar0000000000000000bifunctors-5.1/src/Data/Bifunctor/Biff.hs0000644000000000000000000000456712617716006016542 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Bifunctor.Biff ( 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 #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 {-# INLINE first #-} second f = Biff . second (fmap f) . runBiff {-# INLINE second #-} bimap f g = Biff . bimap (fmap f) (fmap g) . runBiff {-# INLINE bimap #-} instance (Bifunctor p, Functor g) => Functor (Biff p f g a) where fmap f = Biff . second (fmap f) . runBiff {-# INLINE fmap #-} instance (Biapplicative p, Applicative f, Applicative g) => Biapplicative (Biff p f g) where bipure a b = Biff (bipure (pure a) (pure b)) {-# INLINE bipure #-} Biff fg <<*>> Biff xy = Biff (bimap (<*>) (<*>) fg <<*>> xy) {-# INLINE (<<*>>) #-} instance (Bifoldable p, Foldable g) => Foldable (Biff p f g a) where foldMap f = bifoldMap (const mempty) (foldMap f) . runBiff {-# INLINE foldMap #-} instance (Bifoldable p, Foldable f, Foldable g) => Bifoldable (Biff p f g) where bifoldMap f g = bifoldMap (foldMap f) (foldMap g) . runBiff {-# INLINE bifoldMap #-} instance (Bitraversable p, Traversable g) => Traversable (Biff p f g a) where traverse f = fmap Biff . bitraverse pure (traverse f) . runBiff {-# INLINE traverse #-} instance (Bitraversable p, Traversable f, Traversable g) => Bitraversable (Biff p f g) where bitraverse f g = fmap Biff . bitraverse (traverse f) (traverse g) . runBiff {-# INLINE bitraverse #-} bifunctors-5.1/src/Data/Bifunctor/Clown.hs0000644000000000000000000000425712617716006016752 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- From the Functional Pearl \"Clowns to the Left of me, Jokers to the Right: Dissecting Data Structures\" -- by Conor McBride. ---------------------------------------------------------------------------- module Data.Bifunctor.Clown ( 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 #if __GLASGOW_HASKELL__ >= 708 , Typeable #endif ) instance Functor f => Bifunctor (Clown f) where first f = Clown . fmap f . runClown {-# INLINE first #-} second _ = Clown . runClown {-# INLINE second #-} bimap f _ = Clown . fmap f . runClown {-# INLINE bimap #-} instance Functor (Clown f a) where fmap _ = Clown . runClown {-# INLINE fmap #-} instance Applicative f => Biapplicative (Clown f) where bipure a _ = Clown (pure a) {-# INLINE bipure #-} Clown mf <<*>> Clown mx = Clown (mf <*> mx) {-# INLINE (<<*>>) #-} instance Foldable f => Bifoldable (Clown f) where bifoldMap f _ = foldMap f . runClown {-# INLINE bifoldMap #-} instance Foldable (Clown f a) where foldMap _ = mempty {-# INLINE foldMap #-} instance Traversable f => Bitraversable (Clown f) where bitraverse f _ = fmap Clown . traverse f . runClown {-# INLINE bitraverse #-} instance Traversable (Clown f a) where traverse _ = pure . Clown . runClown {-# INLINE traverse #-} bifunctors-5.1/src/Data/Bifunctor/Fix.hs0000644000000000000000000000330212617716006016404 0ustar0000000000000000{-# 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 #-} bifunctors-5.1/src/Data/Bifunctor/Flip.hs0000644000000000000000000000413112617716006016551 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Bifunctor.Flip -- Copyright : (C) 2008-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Bifunctor.Flip ( 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 #if __GLASGOW_HASKELL__ >= 708 , Typeable #endif ) instance Bifunctor p => Bifunctor (Flip p) where first f = Flip . second f . runFlip {-# INLINE first #-} second f = Flip . first f . runFlip {-# INLINE second #-} bimap f g = Flip . bimap g f . runFlip {-# INLINE bimap #-} instance Bifunctor p => Functor (Flip p a) where fmap f = Flip . first f . runFlip {-# INLINE fmap #-} instance Biapplicative p => Biapplicative (Flip p) where bipure a b = Flip (bipure b a) {-# INLINE bipure #-} Flip fg <<*>> Flip xy = Flip (fg <<*>> xy) {-# INLINE (<<*>>) #-} instance Bifoldable p => Bifoldable (Flip p) where bifoldMap f g = bifoldMap g f . runFlip {-# INLINE bifoldMap #-} instance Bifoldable p => Foldable (Flip p a) where foldMap f = bifoldMap f (const mempty) . runFlip {-# INLINE foldMap #-} instance Bitraversable p => Bitraversable (Flip p) where bitraverse f g = fmap Flip . bitraverse g f . runFlip {-# INLINE bitraverse #-} instance Bitraversable p => Traversable (Flip p a) where traverse f = fmap Flip . bitraverse f pure . runFlip {-# INLINE traverse #-} bifunctors-5.1/src/Data/Bifunctor/Join.hs0000644000000000000000000000371412617716006016564 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Bifunctor.Join ( 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) deriving instance Show (p a a) => Show (Join p a) deriving instance Read (p a a) => Read (Join p a) instance Bifunctor p => Functor (Join p) where fmap f (Join a) = Join (bimap f f a) {-# INLINE fmap #-} instance Biapplicative p => Applicative (Join p) where pure a = Join (bipure a a) {-# INLINE pure #-} Join f <*> Join a = Join (f <<*>> a) {-# INLINE (<*>) #-} Join a *> Join b = Join (a *>> b) {-# INLINE (*>) #-} Join a <* Join b = Join (a <<* b) {-# INLINE (<*) #-} instance Bifoldable p => Foldable (Join p) where foldMap f (Join a) = bifoldMap f f a {-# INLINE foldMap #-} instance Bitraversable p => Traversable (Join p) where traverse f (Join a) = fmap Join (bitraverse f f a) {-# INLINE traverse #-} sequenceA (Join a) = fmap Join (bisequenceA a) {-# INLINE sequenceA #-} bifunctors-5.1/src/Data/Bifunctor/Joker.hs0000644000000000000000000000435212617716006016736 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- From the Functional Pearl \"Clowns to the Left of me, Jokers to the Right: Dissecting Data Structures\" -- by Conor McBride. ---------------------------------------------------------------------------- module Data.Bifunctor.Joker ( 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 #if __GLASGOW_HASKELL__ >= 708 , Typeable #endif ) instance Functor g => Bifunctor (Joker g) where first _ = Joker . runJoker {-# INLINE first #-} second g = Joker . fmap g . runJoker {-# INLINE second #-} bimap _ g = Joker . fmap g . runJoker {-# INLINE bimap #-} instance Functor g => Functor (Joker g a) where fmap g = Joker . fmap g . runJoker {-# INLINE fmap #-} instance Applicative g => Biapplicative (Joker g) where bipure _ b = Joker (pure b) {-# INLINE bipure #-} Joker mf <<*>> Joker mx = Joker (mf <*> mx) {-# INLINE (<<*>>) #-} instance Foldable g => Bifoldable (Joker g) where bifoldMap _ g = foldMap g . runJoker {-# INLINE bifoldMap #-} instance Foldable g => Foldable (Joker g a) where foldMap g = foldMap g . runJoker {-# INLINE foldMap #-} instance Traversable g => Bitraversable (Joker g) where bitraverse _ g = fmap Joker . traverse g . runJoker {-# INLINE bitraverse #-} instance Traversable g => Traversable (Joker g a) where traverse g = fmap Joker . traverse g . runJoker {-# INLINE traverse #-} bifunctors-5.1/src/Data/Bifunctor/Product.hs0000644000000000000000000000361512617716006017305 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2015 Jesse Selover, Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- The product of two bifunctors. ---------------------------------------------------------------------------- module Data.Bifunctor.Product ( 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 #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) {-# INLINE first #-} second g (Pair x y) = Pair (second g x) (second g y) {-# INLINE second #-} bimap f g (Pair x y) = Pair (bimap f g x) (bimap f g y) {-# INLINE bimap #-} instance (Biapplicative f, Biapplicative g) => Biapplicative (Product f g) where bipure a b = Pair (bipure a b) (bipure a b) {-# INLINE bipure #-} Pair w x <<*>> Pair y z = Pair (w <<*>> y) (x <<*>> z) {-# INLINE (<<*>>) #-} instance (Bifoldable f, Bifoldable g) => Bifoldable (Product f g) where bifoldMap f g (Pair x y) = bifoldMap f g x `mappend` bifoldMap f g y {-# INLINE bifoldMap #-} instance (Bitraversable f, Bitraversable g) => Bitraversable (Product f g) where bitraverse f g (Pair x y) = Pair <$> bitraverse f g x <*> bitraverse f g y {-# INLINE bitraverse #-} bifunctors-5.1/src/Data/Bifunctor/Tannen.hs0000644000000000000000000000447512617716006017115 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Bifunctor.Tannen ( 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 #if __GLASGOW_HASKELL__ >= 708 , Typeable #endif ) instance (Functor f, Bifunctor p) => Bifunctor (Tannen f p) where first f = Tannen . fmap (first f) . runTannen {-# INLINE first #-} second f = Tannen . fmap (second f) . runTannen {-# INLINE second #-} bimap f g = Tannen . fmap (bimap f g) . runTannen {-# INLINE bimap #-} instance (Functor f, Bifunctor p) => Functor (Tannen f p a) where fmap f = Tannen . fmap (second f) . runTannen {-# INLINE fmap #-} instance (Applicative f, Biapplicative p) => Biapplicative (Tannen f p) where bipure a b = Tannen (pure (bipure a b)) {-# INLINE bipure #-} Tannen fg <<*>> Tannen xy = Tannen ((<<*>>) <$> fg <*> xy) {-# INLINE (<<*>>) #-} instance (Foldable f, Bifoldable p) => Foldable (Tannen f p a) where foldMap f = foldMap (bifoldMap (const mempty) f) . runTannen {-# INLINE foldMap #-} instance (Foldable f, Bifoldable p) => Bifoldable (Tannen f p) where bifoldMap f g = foldMap (bifoldMap f g) . runTannen {-# INLINE bifoldMap #-} instance (Traversable f, Bitraversable p) => Traversable (Tannen f p a) where traverse f = fmap Tannen . traverse (bitraverse pure f) . runTannen {-# INLINE traverse #-} instance (Traversable f, Bitraversable p) => Bitraversable (Tannen f p) where bitraverse f g = fmap Tannen . traverse (bitraverse f g) . runTannen {-# INLINE bitraverse #-} bifunctors-5.1/src/Data/Bifunctor/TH.hs0000644000000000000000000010671012617716006016200 0ustar0000000000000000{-# 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 bifunctors-5.1/src/Data/Bifunctor/Wrapped.hs0000644000000000000000000000451512617716006017267 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Bifunctor.Wrapped ( 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 #if __GLASGOW_HASKELL__ >= 708 , Typeable #endif ) instance Bifunctor p => Bifunctor (WrappedBifunctor p) where first f = WrapBifunctor . first f . unwrapBifunctor {-# INLINE first #-} second f = WrapBifunctor . second f . unwrapBifunctor {-# INLINE second #-} bimap f g = WrapBifunctor . bimap f g . unwrapBifunctor {-# INLINE bimap #-} instance Bifunctor p => Functor (WrappedBifunctor p a) where fmap f = WrapBifunctor . second f . unwrapBifunctor {-# INLINE fmap #-} instance Biapplicative p => Biapplicative (WrappedBifunctor p) where bipure a b = WrapBifunctor (bipure a b) {-# INLINE bipure #-} WrapBifunctor fg <<*>> WrapBifunctor xy = WrapBifunctor (fg <<*>> xy) {-# INLINE (<<*>>) #-} instance Bifoldable p => Foldable (WrappedBifunctor p a) where foldMap f = bifoldMap (const mempty) f . unwrapBifunctor {-# INLINE foldMap #-} instance Bifoldable p => Bifoldable (WrappedBifunctor p) where bifoldMap f g = bifoldMap f g . unwrapBifunctor {-# INLINE bifoldMap #-} instance Bitraversable p => Traversable (WrappedBifunctor p a) where traverse f = fmap WrapBifunctor . bitraverse pure f . unwrapBifunctor {-# INLINE traverse #-} instance Bitraversable p => Bitraversable (WrappedBifunctor p) where bitraverse f g = fmap WrapBifunctor . bitraverse f g . unwrapBifunctor {-# INLINE bitraverse #-} bifunctors-5.1/src/Data/Bifunctor/TH/0000755000000000000000000000000012617716006015637 5ustar0000000000000000bifunctors-5.1/src/Data/Bifunctor/TH/Internal.hs0000644000000000000000000003720212617716006017753 0ustar0000000000000000{-# 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 bifunctors-5.1/tests/0000755000000000000000000000000012617716006013073 5ustar0000000000000000bifunctors-5.1/tests/BifunctorSpec.hs0000644000000000000000000001423212617716006016177 0ustar0000000000000000{-# 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) bifunctors-5.1/tests/Spec.hs0000644000000000000000000000005412617716006014320 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-}