bifunctors-5.5.15/0000755000000000000000000000000007346545000012156 5ustar0000000000000000bifunctors-5.5.15/CHANGELOG.markdown0000644000000000000000000001431307346545000015213 0ustar00000000000000005.5.15 [2023.02.27] ------------------- * Support `th-abstraction-0.5.*`. 5.5.14 [2022.12.07] ------------------- * Define `Functor`, `Foldable`, and `Traversable` instances for `Sum` and `Product`. 5.5.13 [2022.09.12] ------------------- * Make the `Biapplicative` instances for tuples lazy, to match their `Bifunctor` instances. 5.5.12 [2022.05.07] ------------------- * Backport an upstream GHC change which removes the default implementation of `bitraverse`. Per the discussion in https://github.com/haskell/core-libraries-committee/issues/47, this default implementation was completely broken, as attempting to use it would always result in an infinite loop. 5.5.11 [2021.04.30] ------------------- * Allow building with `template-haskell-2.18` (GHC 9.2). 5.5.10 [2021.01.21] ------------------- * Fix a bug in which `deriveBifoldable` could generate code that triggers `-Wunused-matches` warnings. 5.5.9 [2020.12.30] ------------------ * Explicitly mark modules as Safe or Trustworthy. 5.5.8 [2020.10.01] ------------------ * Fix a bug in which `deriveBifunctor` would fail on sufficiently complex uses of rank-n types in constructor fields. * Fix a bug in which `deriveBiunctor` and related functions would needlessly reject data types whose two last type parameters appear as oversaturated arguments to a type family. 5.5.7 [2020.01.29] ------------------ * Add `Data.Bifunctor.Biap`. 5.5.6 [2019.11.26] ------------------ * Add `Category`, `Arrow`, `ArrowChoice`, `ArrowLoop`, `ArrowZero`, and `ArrowPlus` instances for `Data.Bifunctor.Product`. 5.5.5 [2019.08.27] ------------------ * Add `Eq{1,2}`, `Ord{1,2}`, `Read{1,2}`, and `Show{1,2}` instances for data types in the `Data.Bifunctor.*` module namespace where possible. The operative phrase is "where possible" since many of these instances require the use of `Eq2`/`Ord2`/`Read2`/`Show2`, which are not avaiable when built against `transformers-0.4.*`. 5.5.4 [2019.04.26] ------------------ * Support `th-abstraction-0.3` or later. * Don't incur a `semigroup` dependency on recent GHCs. 5.5.3 [2018.07.04] ------------------ * Make `biliftA2` a class method of `Biapplicative`. * Add the `traverseBia`, `sequenceBia`, and `traverseBiaWith` functions for traversing a `Traversable` container in a `Biapplicative`. * Avoid incurring some dependencies when using recent GHCs. 5.5.2 [2018.02.06] ------------------ * Don't enable `Safe` on GHC 7.2. 5.5.1 [2018.02.04] ------------------ * Test suite fixes for GHC 8.4. 5.5 [2017.12.07] ---------------- * `Data.Bifunctor.TH` now derives `bimap`/`bitraverse` implementations for empty data types that are strict in the argument. * `Data.Bifunctor.TH` no longer derives `bifoldr`/`bifoldMap` implementations that error on empty data types. Instead, they simply return the folded state (for `bifoldr`) or `mempty` (for `bifoldMap`). * When using `Data.Bifunctor.TH` to derive `Bifunctor` or `Bitraversable` instances for data types where the last two type variables are at phantom roles, generated `bimap`/`bitraverse` implementations now use `coerce` for efficiency. * Add `Options` to `Data.Bifunctor.TH`, along with variants of existing functions that take `Options` as an argument. For now, the only configurable option is whether derived instances for empty data types should use the `EmptyCase` extension (this is disabled by default). 5.4.2 ----- * Make `deriveBitraversable` use `liftA2` in derived implementations of `bitraverse` when possible, now that `liftA2` is a class method of `Applicative` (as of GHC 8.2) * Backport slightly more efficient implementations of `bimapDefault` and `bifoldMapDefault` 5.4.1 ----- * Add explicit `Safe`, `Trustworthy`, and `Unsafe` annotations. In particular, annotate the `Data.Bifoldable` module as `Trustworthy` (previously, it was inferred to be `Unsafe`). 5.4 --- * Only export `Data.Bifoldable` and `Data.Bitraversable` when building on GHC < 8.1, otherwise they come from `base` * Allow TH derivation of `Bifunctor` and `Bifoldable` instances for datatypes containing unboxed tuple types 5.3 --- * Added `bifoldr1`, `bifoldl1`, `bimsum`, `biasum`, `binull`, `bilength`, `bielem`, `bimaximum`, `biminimum`, `bisum`, `biproduct`, `biand`, `bior`, `bimaximumBy`, `biminimumBy`, `binotElem`, and `bifind` to `Data.Bifoldable` * Added `Bifunctor`, `Bifoldable`, and `Bitraversable` instances for `GHC.Generics.K1` * TH code no longer generates superfluous `mempty` or `pure` subexpressions in derived `Bifoldable` or `Bitraversable` instances, respectively 5.2.1 ---- * Added `Bifoldable` and `Bitraversable` instances for `Constant` from `transformers` * `Data.Bifunctor.TH` now compiles warning-free on GHC 8.0 5.2 ----- * Added several `Arrow`-like instances for `Tannen` so we can use it as the Cayley construction if needed. * Added `Data.Bifunctor.Sum` * Added `BifunctorFunctor`, `BifunctorMonad` and `BifunctorComonad`. * Backported `Bifunctor Constant` instance from `transformers` 5.1 --- * Added `Data.Bifunctor.Fix` * Added `Data.Bifunctor.TH`, which permits `TemplateHaskell`-based deriving of `Bifunctor`, `Bifoldable` and `Bitraversable` instances. * Simplified `Bitraversable`. 5 - * Inverted the dependency on `semigroupoids`. We can support a much wider array of `base` versions than it can. * 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.5.15/LICENSE0000644000000000000000000000236407346545000013170 0ustar0000000000000000Copyright 2008-2016 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.5.15/README.markdown0000644000000000000000000000075507346545000014666 0ustar0000000000000000bifunctors ========== [![Hackage](https://img.shields.io/hackage/v/bifunctors.svg)](https://hackage.haskell.org/package/bifunctors) [![Build Status](https://github.com/ekmett/bifunctors/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/bifunctors/actions?query=workflow%3AHaskell-CI) 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.5.15/Setup.lhs0000644000000000000000000000016507346545000013770 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain bifunctors-5.5.15/bifunctors.cabal0000644000000000000000000000741207346545000015324 0ustar0000000000000000name: bifunctors category: Data, Functors version: 5.5.15 license: BSD3 cabal-version: >= 1.10 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-2016 Edward A. Kmett synopsis: Bifunctors description: Bifunctors. build-type: Simple tested-with: GHC == 7.0.4 , GHC == 7.2.2 , GHC == 7.4.2 , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.6 , GHC == 9.4.4 , GHC == 9.6.1 extra-source-files: CHANGELOG.markdown README.markdown include/bifunctors-common.h source-repository head type: git location: https://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 include-dirs: include includes: bifunctors-common.h build-depends: base >= 4.3 && < 5, base-orphans >= 0.8.4 && < 1, comonad >= 5.0.7 && < 6, containers >= 0.2 && < 0.7, template-haskell >= 2.4 && < 2.21, th-abstraction >= 0.4.2.0 && < 0.6, transformers >= 0.3 && < 0.7 if !impl(ghc > 8.2) build-depends: transformers-compat >= 0.5 && < 0.8 if !impl(ghc >= 8.0) build-depends: fail == 4.9.* if flag(tagged) build-depends: tagged >= 0.8.6 && < 1 if flag(semigroups) && !impl(ghc >= 8.0) build-depends: semigroups >= 0.18.5 && < 1 if impl(ghc<7.9) hs-source-dirs: old-src/ghc709 exposed-modules: Data.Bifunctor if impl(ghc<8.1) hs-source-dirs: old-src/ghc801 exposed-modules: Data.Bifoldable Data.Bitraversable if impl(ghc>=7.2) && impl(ghc<7.5) build-depends: ghc-prim == 0.2.0.0 exposed-modules: Data.Biapplicative Data.Bifunctor.Biap Data.Bifunctor.Biff Data.Bifunctor.Clown Data.Bifunctor.Fix Data.Bifunctor.Flip Data.Bifunctor.Functor Data.Bifunctor.Join Data.Bifunctor.Joker Data.Bifunctor.Product Data.Bifunctor.Sum Data.Bifunctor.Tannen Data.Bifunctor.TH Data.Bifunctor.Wrapped other-modules: Data.Bifunctor.TH.Internal Paths_bifunctors ghc-options: -Wall default-language: Haskell2010 if impl(ghc >= 9.0) -- these flags may abort compilation with GHC-8.10 -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode test-suite bifunctors-spec type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Spec.hs other-modules: BifunctorSpec T89Spec ghc-options: -Wall if impl(ghc >= 8.6) ghc-options: -Wno-star-is-type default-language: Haskell2010 build-tool-depends: hspec-discover:hspec-discover >= 1.8 build-depends: base >= 4 && < 5, bifunctors, hspec >= 1.8, QuickCheck >= 2 && < 3, template-haskell, transformers, transformers-compat bifunctors-5.5.15/include/0000755000000000000000000000000007346545000013601 5ustar0000000000000000bifunctors-5.5.15/include/bifunctors-common.h0000644000000000000000000000066707346545000017427 0ustar0000000000000000#ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif #ifndef MIN_VERSION_transformers_compat #define MIN_VERSION_transformers_compat(x,y,z) 0 #endif #if MIN_VERSION_base(4,9,0) #define LIFTED_FUNCTOR_CLASSES 1 #else #if MIN_VERSION_transformers(0,5,0) #define LIFTED_FUNCTOR_CLASSES 1 #else #if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0) #define LIFTED_FUNCTOR_CLASSES 1 #endif #endif #endif bifunctors-5.5.15/old-src/ghc709/Data/0000755000000000000000000000000007346545000015373 5ustar0000000000000000bifunctors-5.5.15/old-src/ghc709/Data/Bifunctor.hs0000644000000000000000000001126607346545000017670 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #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 import Data.Functor.Constant import Data.Semigroup #ifdef MIN_VERSION_tagged import Data.Tagged #endif #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics (K1(..)) #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 #-} #endif #if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 deriving instance Typeable Bifunctor #endif instance Bifunctor (,) where bimap f g ~(a, b) = (f a, g b) {-# INLINE bimap #-} instance Bifunctor Arg where bimap f g (Arg a b) = Arg (f a) (g b) 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 #-} instance Bifunctor Constant where bimap f _ (Constant a) = Constant (f a) {-# INLINE bimap #-} #if __GLASGOW_HASKELL__ >= 702 instance Bifunctor (K1 i) where bimap f _ (K1 c) = K1 (f c) {-# INLINE bimap #-} #endif #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.5.15/old-src/ghc801/Data/0000755000000000000000000000000007346545000015364 5ustar0000000000000000bifunctors-5.5.15/old-src/ghc801/Data/Bifoldable.hs0000644000000000000000000003757107346545000017760 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #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' , bifoldr1 , bifoldrM , bifoldl' , bifoldl1 , bifoldlM , bitraverse_ , bifor_ , bimapM_ , biforM_ , bimsum , bisequenceA_ , bisequence_ , biasum , biList , binull , bilength , bielem , bimaximum , biminimum , bisum , biproduct , biconcat , biconcatMap , biand , bior , biany , biall , bimaximumBy , biminimumBy , binotElem , bifind ) where import Control.Applicative import Control.Monad import Data.Functor.Constant import Data.Maybe (fromMaybe) import Data.Monoid #if MIN_VERSION_base(4,7,0) import Data.Coerce #else import Unsafe.Coerce #endif import Data.Semigroup (Arg(..)) #ifdef MIN_VERSION_tagged import Data.Tagged #endif #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics (K1(..)) #endif #if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 import Data.Typeable #endif -- | 'Bifoldable' identifies foldable structures with two different varieties -- of elements (as opposed to 'Foldable', which has one variety of element). -- 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) -- -- A minimal 'Bifoldable' definition consists of either 'bifoldMap' or -- 'bifoldr'. When defining more than this minimal set, 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 -- @ -- -- If the type is also a 'Bifunctor' instance, it should satisfy: -- -- > 'bifoldMap' f g ≡ 'bifold' . 'bimap' f g -- -- which implies that -- -- > 'bifoldMap' f g . 'bimap' h i ≡ 'bifoldMap' (f . h) (g . i) 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@ -- -- Note that if you want an efficient left-fold, you probably want to use -- 'bifoldl'' instead of 'bifoldl'. The reason is that the latter does not -- force the "inner" results, resulting in a thunk chain which then must be -- evaluated from the outside-in. 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 #-} #endif #if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 deriving instance Typeable Bifoldable #endif instance Bifoldable Arg where bifoldMap f g (Arg a b) = f a `mappend` g b 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 Constant where bifoldMap f _ (Constant a) = f a {-# INLINE bifoldMap #-} #if __GLASGOW_HASKELL__ >= 702 instance Bifoldable (K1 i) where bifoldMap f _ (K1 c) = f c {-# INLINE bifoldMap #-} #endif 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' #-} -- | A variant of 'bifoldr' that has no base case, -- and thus may only be applied to non-empty structures. bifoldr1 :: Bifoldable t => (a -> a -> a) -> t a a -> a bifoldr1 f xs = fromMaybe (error "bifoldr1: empty structure") (bifoldr mbf mbf Nothing xs) where mbf x m = Just (case m of Nothing -> x Just y -> f x y) {-# INLINE bifoldr1 #-} -- | 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 reduction functions at each -- step. -- -- This ensures that each step of the bifold is forced to weak head normal form -- before being applied, avoiding the collection of thunks that would otherwise -- occur. This is often what you want to strictly reduce a finite structure to -- a single, monolithic result (e.g., 'bilength'). 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' #-} -- | A variant of 'bifoldl' that has no base case, -- and thus may only be applied to non-empty structures. bifoldl1 :: Bifoldable t => (a -> a -> a) -> t a a -> a bifoldl1 f xs = fromMaybe (error "bifoldl1: empty structure") (bifoldl mbf mbf Nothing xs) where mbf m y = Just (case m of Nothing -> y Just x -> f x y) {-# INLINe bifoldl1 #-} -- | 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 #-} -- | Map each element of a structure using one of two actions, evaluate these -- actions from left to right, and ignore the results. For a version that -- doesn't ignore the results, see 'Data.Bitraversable.bitraverse'. 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. For a -- version that doesn't ignore the results, see 'Data.Bitraversable.bifor'. -- -- >>> > bifor_ ('a', "bc") print (print . reverse) -- 'a' -- "cb" 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_ #-} -- | Evaluate each action in the structure from left to right, and ignore the -- results. For a version that doesn't ignore the results, see -- 'Data.Bitraversable.bisequence'. bisequence_ :: (Bifoldable t, Monad m) => t (m a) (m b) -> m () bisequence_ = bifoldr (>>) (>>) (return ()) {-# INLINE bisequence_ #-} -- | The sum of a collection of actions, generalizing 'biconcat'. biasum :: (Bifoldable t, Alternative f) => t (f a) (f a) -> f a biasum = bifoldr (<|>) (<|>) empty {-# INLINE biasum #-} -- | The sum of a collection of actions, generalizing 'biconcat'. bimsum :: (Bifoldable t, MonadPlus m) => t (m a) (m a) -> m a bimsum = bifoldr mplus mplus mzero {-# INLINE bimsum #-} -- | Collects the list of elements of a structure, from left to right. biList :: Bifoldable t => t a a -> [a] biList = bifoldr (:) (:) [] {-# INLINE biList #-} -- | Test whether the structure is empty. binull :: Bifoldable t => t a b -> Bool binull = bifoldr (\_ _ -> False) (\_ _ -> False) True {-# INLINE binull #-} -- | Returns the size/length of a finite structure as an 'Int'. bilength :: Bifoldable t => t a b -> Int bilength = bifoldl' (\c _ -> c+1) (\c _ -> c+1) 0 {-# INLINE bilength #-} -- | Does the element occur in the structure? bielem :: (Bifoldable t, Eq a) => a -> t a a -> Bool bielem x = biany (== x) (== x) {-# INLINE bielem #-} -- | Reduces a structure of lists to the concatenation of those lists. biconcat :: Bifoldable t => t [a] [a] -> [a] biconcat = bifold {-# INLINE biconcat #-} newtype Max a = Max {getMax :: Maybe a} newtype Min a = Min {getMin :: Maybe a} instance Ord a => Monoid (Max a) where mempty = Max Nothing {-# INLINE mappend #-} m `mappend` Max Nothing = m Max Nothing `mappend` n = n (Max m@(Just x)) `mappend` (Max n@(Just y)) | x >= y = Max m | otherwise = Max n instance Ord a => Monoid (Min a) where mempty = Min Nothing {-# INLINE mappend #-} m `mappend` Min Nothing = m Min Nothing `mappend` n = n (Min m@(Just x)) `mappend` (Min n@(Just y)) | x <= y = Min m | otherwise = Min n -- | The largest element of a non-empty structure. bimaximum :: forall t a. (Bifoldable t, Ord a) => t a a -> a bimaximum = fromMaybe (error "bimaximum: empty structure") . getMax . bifoldMap mj mj where mj = Max #. (Just :: a -> Maybe a) {-# INLINE bimaximum #-} -- | The least element of a non-empty structure. biminimum :: forall t a. (Bifoldable t, Ord a) => t a a -> a biminimum = fromMaybe (error "biminimum: empty structure") . getMin . bifoldMap mj mj where mj = Min #. (Just :: a -> Maybe a) {-# INLINE biminimum #-} -- | The 'bisum' function computes the sum of the numbers of a structure. bisum :: (Bifoldable t, Num a) => t a a -> a bisum = getSum #. bifoldMap Sum Sum {-# INLINE bisum #-} -- | The 'biproduct' function computes the product of the numbers of a -- structure. biproduct :: (Bifoldable t, Num a) => t a a -> a biproduct = getProduct #. bifoldMap Product Product {-# INLINE biproduct #-} -- | 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 #-} -- | 'biand' returns the conjunction of a container of Bools. For the -- result to be 'True', the container must be finite; 'False', however, -- results from a 'False' value finitely far from the left end. biand :: Bifoldable t => t Bool Bool -> Bool biand = getAll #. bifoldMap All All {-# INLINE biand #-} -- | 'bior' returns the disjunction of a container of Bools. For the -- result to be 'False', the container must be finite; 'True', however, -- results from a 'True' value finitely far from the left end. bior :: Bifoldable t => t Bool Bool -> Bool bior = getAny #. bifoldMap Any Any {-# INLINE bior #-} -- | 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 #-} -- | The largest element of a non-empty structure with respect to the -- given comparison function. bimaximumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a bimaximumBy cmp = bifoldr1 max' where max' x y = case cmp x y of GT -> x _ -> y {-# INLINE bimaximumBy #-} -- | The least element of a non-empty structure with respect to the -- given comparison function. biminimumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a biminimumBy cmp = bifoldr1 min' where min' x y = case cmp x y of GT -> y _ -> x {-# INLINE biminimumBy #-} -- | 'binotElem' is the negation of 'bielem'. binotElem :: (Bifoldable t, Eq a) => a -> t a a-> Bool binotElem x = not . bielem x {-# INLINE binotElem #-} -- | The 'bifind' function takes a predicate and a structure and returns -- the leftmost element of the structure matching the predicate, or -- 'Nothing' if there is no such element. bifind :: Bifoldable t => (a -> Bool) -> t a a -> Maybe a bifind p = getFirst . bifoldMap finder finder where finder x = First (if p x then Just x else Nothing) {-# INLINE bifind #-} -- See Note [Function coercion] #if MIN_VERSION_base(4,7,0) (#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) (#.) _f = coerce #else (#.) :: (b -> c) -> (a -> b) -> (a -> c) (#.) _f = unsafeCoerce #endif {-# INLINE (#.) #-} {- Note [Function coercion] ~~~~~~~~~~~~~~~~~~~~~~~~ Several functions here use (#.) instead of (.) to avoid potential efficiency problems relating to #7542. The problem, in a nutshell: If N is a newtype constructor, then N x will always have the same representation as x (something similar applies for a newtype deconstructor). However, if f is a function, N . f = \x -> N (f x) This looks almost the same as f, but the eta expansion lifts it--the lhs could be _|_, but the rhs never is. This can lead to very inefficient code. Thus we steal a technique from Shachaf and Edward Kmett and adapt it to the current (rather clean) setting. Instead of using N . f, we use N .## f, which is just coerce f `asTypeOf` (N . f) That is, we just *pretend* that f has the right type, and thanks to the safety of coerce, the type checker guarantees that nothing really goes wrong. We still have to be a bit careful, though: remember that #. completely ignores the *value* of its left operand. -} bifunctors-5.5.15/old-src/ghc801/Data/Bitraversable.hs0000644000000000000000000002443007346545000020510 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-} #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 Control.Monad.Trans.Instances () import Data.Bifunctor import Data.Bifoldable import Data.Functor.Constant import Data.Functor.Identity import Data.Orphans () #if MIN_VERSION_base(4,7,0) import Data.Coerce (coerce) #else import Unsafe.Coerce (unsafeCoerce) #endif #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid #endif import Data.Semigroup (Arg(..)) #ifdef MIN_VERSION_tagged import Data.Tagged #endif #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics (K1(..)) #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. -- -- As opposed to 'Traversable' data structures, which have one variety of -- element on which an action can be performed, 'Bitraversable' data structures -- have two such varieties of elements. -- -- A definition of 'bitraverse' 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 -- ≡ 'bitraverse' ('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@ -- -- For a version that ignores the results, see 'bitraverse_'. bitraverse :: Applicative f => (a -> f c) -> (b -> f d) -> t a b -> f (t c d) -- | Sequences all the actions in a structure, building a new structure with the -- same shape using the results of the actions. For a version that ignores the -- results, see 'bisequenceA_'. -- -- @'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'. For a version that ignores the results, see 'bimapM_'. -- -- @ -- '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'. For a version that ignores the results, see 'bisequence_'. -- -- @ -- '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 instance Bitraversable Arg where bitraverse f g (Arg a b) = Arg <$> f a <*> g b 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 #-} instance Bitraversable Constant where bitraverse f _ (Constant a) = Constant <$> f a {-# INLINE bitraverse #-} #if __GLASGOW_HASKELL__ >= 702 instance Bitraversable (K1 i) where bitraverse f _ (K1 c) = K1 <$> f c {-# INLINE bitraverse #-} #endif #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. For a -- version that ignores the results, see 'bifor_'. 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. For a -- version that ignores the results, see 'biforM_'. 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 (<*>) #-} -- | The 'bimapAccumL' function behaves like a combination of 'bimap' and -- 'bifoldl'; it 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 (<*>) #-} -- | The 'bimapAccumR' function behaves like a combination of 'bimap' and -- 'bifoldl'; it 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 #-} -- | A default definition of 'bimap' in terms of the 'Bitraversable' operations. -- -- @'bimapDefault' f g ≡ -- 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)@ bimapDefault :: forall t a b c d . Bitraversable t => (a -> b) -> (c -> d) -> t a c -> t b d bimapDefault = coerce (bitraverse :: (a -> Identity b) -> (c -> Identity d) -> t a c -> Identity (t b d)) {-# INLINE bimapDefault #-} -- | A default definition of 'bifoldMap' in terms of the 'Bitraversable' operations. -- -- @'bifoldMapDefault' f g ≡ -- 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)@ bifoldMapDefault :: forall t m a b . (Bitraversable t, Monoid m) => (a -> m) -> (b -> m) -> t a b -> m bifoldMapDefault = coerce (bitraverse :: (a -> Const m ()) -> (b -> Const m ()) -> t a b -> Const m (t () ())) {-# INLINE bifoldMapDefault #-} #if !(MIN_VERSION_base(4,7,0)) coerce :: a -> b coerce = unsafeCoerce #endif bifunctors-5.5.15/src/Data/0000755000000000000000000000000007346545000013616 5ustar0000000000000000bifunctors-5.5.15/src/Data/Biapplicative.hs0000644000000000000000000002507207346545000016734 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #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(..) , (<<$>>) , (<<**>>) , biliftA3 , traverseBia , sequenceBia , traverseBiaWith , module Data.Bifunctor ) where import Control.Applicative import Data.Bifunctor import Data.Functor.Identity import GHC.Exts (inline) #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid import Data.Traversable (Traversable (traverse)) #endif import Data.Semigroup (Arg(..)) #ifdef MIN_VERSION_tagged import Data.Tagged #endif infixl 4 <<$>>, <<*>>, <<*, *>>, <<**>> (<<$>>) :: (a -> b) -> a -> b (<<$>>) = id {-# INLINE (<<$>>) #-} class Bifunctor p => Biapplicative p where #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL bipure, ((<<*>>) | biliftA2 ) #-} #endif bipure :: a -> b -> p a b (<<*>>) :: p (a -> b) (c -> d) -> p a c -> p b d (<<*>>) = biliftA2 id id {-# INLINE (<<*>>) #-} -- | Lift binary functions biliftA2 :: (a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f biliftA2 f g a b = bimap f g <<$>> a <<*>> b {-# INLINE biliftA2 #-} -- | -- @ -- a '*>>' b ≡ 'bimap' ('const' 'id') ('const' 'id') '<<$>>' a '<<*>>' b -- @ (*>>) :: p a b -> p c d -> p c d a *>> b = biliftA2 (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 = biliftA2 const const a b {-# INLINE (<<*) #-} (<<**>>) :: Biapplicative p => p a c -> p (a -> b) (c -> d) -> p b d (<<**>>) = biliftA2 (flip id) (flip id) {-# INLINE (<<**>>) #-} -- | Lift 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 = biliftA2 f g a b <<*>> c {-# INLINE biliftA3 #-} -- | Traverse a 'Traversable' container in a 'Biapplicative'. -- -- 'traverseBia' satisfies the following properties: -- -- [/Pairing/] -- -- @'traverseBia' (,) t = (t, t)@ -- -- [/Composition/] -- -- @'traverseBia' ('Data.Bifunctor.Biff.Biff' . 'bimap' g h . f) = 'Data.Bifunctor.Biff.Biff' . 'bimap' ('traverse' g) ('traverse' h) . 'traverseBia' f@ -- -- @'traverseBia' ('Data.Bifunctor.Tannen.Tannen' . 'fmap' f . g) = 'Data.Bifunctor.Tannen.Tannen' . 'fmap' ('traverseBia' f) . 'traverse' g@ -- -- [/Naturality/] -- -- @ t . 'traverseBia' f = 'traverseBia' (t . f) @ -- -- for every biapplicative transformation @t@. -- -- A /biapplicative transformation/ from a 'Biapplicative' @P@ to a 'Biapplicative' @Q@ -- is a function -- -- @t :: P a b -> Q a b@ -- -- preserving the 'Biapplicative' operations. That is, -- -- * @t ('bipure' x y) = 'bipure' x y@ -- -- * @t (x '<<*>>' y) = t x '<<*>>' t y@ -- -- === Performance note -- -- 'traverseBia' is fairly efficient, and uses compiler rewrite rules -- to be even more efficient for a few important types like @[]@. However, -- if performance is critical, you might consider writing a container-specific -- implementation. traverseBia :: (Traversable t, Biapplicative p) => (a -> p b c) -> t a -> p (t b) (t c) traverseBia = inline (traverseBiaWith traverse) -- We explicitly inline traverseBiaWith because it seems likely to help -- specialization. I'm not much of an expert at the inlining business, -- so I won't mind if someone else decides to do this differently. -- We use a staged INLINABLE so we can rewrite traverseBia to specialized -- versions for a few important types. {-# INLINABLE [1] traverseBia #-} -- | Perform all the 'Biappicative' actions in a 'Traversable' container -- and produce a container with all the results. -- -- @ -- sequenceBia = 'traverseBia' id -- @ sequenceBia :: (Traversable t, Biapplicative p) => t (p b c) -> p (t b) (t c) sequenceBia = inline (traverseBia id) {-# INLINABLE sequenceBia #-} -- | A version of 'traverseBia' that doesn't care how the traversal is -- done. -- -- @ -- 'traverseBia' = traverseBiaWith traverse -- @ traverseBiaWith :: forall p a b c s t. Biapplicative p => (forall f x. Applicative f => (a -> f x) -> s -> f (t x)) -> (a -> p b c) -> s -> p (t b) (t c) traverseBiaWith trav p s = smash p (trav One s) {-# INLINABLE traverseBiaWith #-} smash :: forall p t a b c. Biapplicative p => (a -> p b c) -> (forall x. Mag a x (t x)) -> p (t b) (t c) smash p m = go m m where go :: forall x y. Mag a b x -> Mag a c y -> p x y go (Pure t) (Pure u) = bipure t u go (Map f x) (Map g y) = bimap f g (go x y) go (Ap fs xs) (Ap gs ys) = go fs gs <<*>> go xs ys #if MIN_VERSION_base(4,10,0) go (LiftA2 f xs ys) (LiftA2 g zs ws) = biliftA2 f g (go xs zs) (go ys ws) #endif go (One x) (One _) = p x go _ _ = impossibleError {-# INLINABLE smash #-} -- Let's not end up with a bunch of CallStack junk in the smash -- unfolding. impossibleError :: a impossibleError = error "Impossible: the arguments are always the same." -- This is used to reify a traversal for 'traverseBia'. It's a somewhat -- bogus 'Functor' and 'Applicative' closely related to 'Magma' from the -- @lens@ package. Valid traversals don't use (<$), (<*), or (*>), so -- we leave them out. We offer all the rest of the Functor and Applicative -- operations to improve performance: we generally want to keep the structure -- as small as possible. We might even consider using RULES to widen lifts -- when we can: -- -- liftA2 f x y <*> z ==> liftA3 f x y z, -- -- etc., up to the pointer tagging limit. But we do need to be careful. I don't -- *think* GHC will ever inline the traversal into the go function (because that -- would duplicate work), but if it did, and if different RULES fired for the -- two copies, everything would break horribly. -- -- Note: if it's necessary for some reason, we *could* relax GADTs to -- ExistentialQuantification by changing the type of One to -- -- One :: (b -> c) -> a -> Mag a b c -- -- where the function will always end up being id. But we allocate a *lot* -- of One constructors, so this would definitely be bad for performance. data Mag a b t where Pure :: t -> Mag a b t Map :: (x -> t) -> Mag a b x -> Mag a b t Ap :: Mag a b (t -> u) -> Mag a b t -> Mag a b u #if MIN_VERSION_base(4,10,0) LiftA2 :: (t -> u -> v) -> Mag a b t -> Mag a b u -> Mag a b v #endif One :: a -> Mag a b b instance Functor (Mag a b) where fmap = Map instance Applicative (Mag a b) where pure = Pure (<*>) = Ap #if MIN_VERSION_base(4,10,0) liftA2 = LiftA2 #endif -- Rewrite rules for traversing a few important types. These avoid the overhead -- of allocating and matching on a Mag. {-# RULES "traverseBia/list" forall f t. traverseBia f t = traverseBiaList f t "traverseBia/Maybe" forall f t. traverseBia f t = traverseBiaMaybe f t "traverseBia/Either" forall f t. traverseBia f t = traverseBiaEither f t "traverseBia/Identity" forall f t. traverseBia f t = traverseBiaIdentity f t "traverseBia/Const" forall f t. traverseBia f t = traverseBiaConst f t "traverseBia/Pair" forall f t. traverseBia f t = traverseBiaPair f t #-} traverseBiaList :: Biapplicative p => (a -> p b c) -> [a] -> p [b] [c] traverseBiaList f = foldr go (bipure [] []) where go x r = biliftA2 (:) (:) (f x) r traverseBiaMaybe :: Biapplicative p => (a -> p b c) -> Maybe a -> p (Maybe b) (Maybe c) traverseBiaMaybe _f Nothing = bipure Nothing Nothing traverseBiaMaybe f (Just x) = bimap Just Just (f x) traverseBiaEither :: Biapplicative p => (a -> p b c) -> Either e a -> p (Either e b) (Either e c) traverseBiaEither f (Right x) = bimap Right Right (f x) traverseBiaEither _f (Left (e :: e)) = bipure m m where m :: Either e x m = Left e traverseBiaIdentity :: Biapplicative p => (a -> p b c) -> Identity a -> p (Identity b) (Identity c) traverseBiaIdentity f (Identity x) = bimap Identity Identity (f x) traverseBiaConst :: Biapplicative p => (a -> p b c) -> Const x a -> p (Const x b) (Const x c) traverseBiaConst _f (Const x) = bipure (Const x) (Const x) traverseBiaPair :: Biapplicative p => (a -> p b c) -> (e, a) -> p (e, b) (e, c) traverseBiaPair f (x,y) = bimap ((,) x) ((,) x) (f y) ---------------------------------------------- -- -- Instances instance Biapplicative (,) where bipure = (,) {-# INLINE bipure #-} ~(f, g) <<*>> ~(a, b) = (f a, g b) {-# INLINE (<<*>>) #-} biliftA2 f g ~(x, y) ~(a, b) = (f x a, g y b) {-# INLINE biliftA2 #-} instance Biapplicative Arg where bipure = Arg {-# INLINE bipure #-} Arg f g <<*>> Arg a b = Arg (f a) (g b) {-# INLINE (<<*>>) #-} biliftA2 f g (Arg x y) (Arg a b) = Arg (f x a) (g y b) {-# INLINE biliftA2 #-} 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.5.15/src/Data/Bifunctor/0000755000000000000000000000000007346545000015551 5ustar0000000000000000bifunctors-5.5.15/src/Data/Bifunctor/Biap.hs0000644000000000000000000001056707346545000016771 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} #endif -- This module uses GND #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #include "bifunctors-common.h" ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Bifunctor.Biap ( Biap(..) ) where import Control.Applicative import Control.Monad import qualified Control.Monad.Fail as Fail (MonadFail) import Data.Biapplicative import Data.Bifoldable import Data.Bitraversable import Data.Functor.Classes #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics #endif #if !(MIN_VERSION_base(4,8,0)) import Data.Foldable import Data.Monoid import Data.Traversable #endif import qualified Data.Semigroup as S -- | Pointwise lifting of a class over two arguments, using -- 'Biapplicative'. -- -- Classes that can be lifted include 'Monoid', 'Num' and -- 'Bounded'. Each method of those classes can be defined as lifting -- themselves over each argument of 'Biapplicative'. -- -- @ -- mempty = bipure mempty mempty -- minBound = bipure minBound minBound -- maxBound = bipure maxBound maxBound -- fromInteger n = bipure (fromInteger n) (fromInteger n) -- -- negate = bimap negate negate -- -- (+) = biliftA2 (+) (+) -- (<>) = biliftA2 (<>) (<>) -- @ -- -- 'Biap' is to 'Biapplicative' as 'Data.Monoid.Ap' is to -- 'Applicative'. -- -- 'Biap' can be used with @DerivingVia@ to derive a numeric instance -- for pairs: -- -- @ -- newtype Numpair a = Np (a, a) -- deriving (S.Semigroup, Monoid, Num, Bounded) -- via Biap (,) a a -- @ -- newtype Biap bi a b = Biap { getBiap :: bi a b } deriving ( Eq , Ord , Show , Read , Enum , Functor , Foldable , Traversable , Alternative , Applicative #if __GLASGOW_HASKELL__ >= 702 , Generic #endif #if __GLASGOW_HASKELL__ >= 706 , Generic1 #endif , Monad , Fail.MonadFail , MonadPlus , Eq1 , Ord1 , Bifunctor , Biapplicative , Bifoldable #if LIFTED_FUNCTOR_CLASSES , Eq2 , Ord2 #endif ) instance Bitraversable bi => Bitraversable (Biap bi) where bitraverse f g (Biap as) = Biap <$> bitraverse f g as instance (Biapplicative bi, S.Semigroup a, S.Semigroup b) => S.Semigroup (Biap bi a b) where (<>) = biliftA2 (S.<>) (S.<>) instance (Biapplicative bi, Monoid a, Monoid b) => Monoid (Biap bi a b) where mempty = bipure mempty mempty #if !(MIN_VERSION_base(4,11,0)) mappend = biliftA2 mappend mappend #endif instance (Biapplicative bi, Bounded a, Bounded b) => Bounded (Biap bi a b) where minBound = bipure minBound minBound maxBound = bipure maxBound maxBound instance ( Biapplicative bi, Num a, Num b #if !(MIN_VERSION_base(4,5,0)) -- Old versions of Num have Eq and Show as superclasses. Sigh. , Eq (bi a b), Show (bi a b) #endif ) => Num (Biap bi a b) where (+) = biliftA2 (+) (+) (*) = biliftA2 (*) (*) negate = bimap negate negate abs = bimap abs abs signum = bimap signum signum fromInteger n = bipure (fromInteger n) (fromInteger n) #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 706 data BiapMetaData data BiapMetaCons data BiapMetaSel instance Datatype BiapMetaData where datatypeName = const "Biap" moduleName = const "Data.Bifunctor.Wrapped" instance Constructor BiapMetaCons where conName = const "Biap" conIsRecord = const True instance Selector BiapMetaSel where selName = const "getBiap" instance Generic1 (Biap p a) where type Rep1 (Biap p a) = D1 BiapMetaData (C1 BiapMetaCons (S1 BiapMetaSel (Rec1 (p a)))) from1 = M1 . M1 . M1 . Rec1 . getBiap to1 = Biap . unRec1 . unM1 . unM1 . unM1 #endif bifunctors-5.5.15/src/Data/Bifunctor/Biff.hs0000644000000000000000000001231607346545000016756 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} #endif #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #include "bifunctors-common.h" ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 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 #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics #endif #if LIFTED_FUNCTOR_CLASSES import Data.Functor.Classes #endif -- | Compose two 'Functor's on the inside of a 'Bifunctor'. newtype Biff p f g a b = Biff { runBiff :: p (f a) (g b) } deriving ( Eq, Ord, Show, Read #if __GLASGOW_HASKELL__ >= 702 , Generic #endif #if __GLASGOW_HASKELL__ >= 708 , Typeable #endif ) #if __GLASGOW_HASKELL__ >= 702 # if __GLASGOW_HASKELL__ >= 708 deriving instance Functor (p (f a)) => Generic1 (Biff p f g a) # else data BiffMetaData data BiffMetaCons data BiffMetaSel instance Datatype BiffMetaData where datatypeName = const "Biff" moduleName = const "Data.Bifunctor.Biff" instance Constructor BiffMetaCons where conName = const "Biff" conIsRecord = const True instance Selector BiffMetaSel where selName = const "runBiff" instance Functor (p (f a)) => Generic1 (Biff p f g a) where type Rep1 (Biff p f g a) = D1 BiffMetaData (C1 BiffMetaCons (S1 BiffMetaSel (p (f a) :.: Rec1 g))) from1 = M1 . M1 . M1 . Comp1 . fmap Rec1 . runBiff to1 = Biff . fmap unRec1 . unComp1 . unM1 . unM1 . unM1 # endif #endif #if LIFTED_FUNCTOR_CLASSES instance (Eq2 p, Eq1 f, Eq1 g, Eq a) => Eq1 (Biff p f g a) where liftEq = liftEq2 (==) instance (Eq2 p, Eq1 f, Eq1 g) => Eq2 (Biff p f g) where liftEq2 f g (Biff x) (Biff y) = liftEq2 (liftEq f) (liftEq g) x y instance (Ord2 p, Ord1 f, Ord1 g, Ord a) => Ord1 (Biff p f g a) where liftCompare = liftCompare2 compare instance (Ord2 p, Ord1 f, Ord1 g) => Ord2 (Biff p f g) where liftCompare2 f g (Biff x) (Biff y) = liftCompare2 (liftCompare f) (liftCompare g) x y instance (Read2 p, Read1 f, Read1 g, Read a) => Read1 (Biff p f g a) where liftReadsPrec = liftReadsPrec2 readsPrec readList instance (Read2 p, Read1 f, Read1 g) => Read2 (Biff p f g) where liftReadsPrec2 rp1 rl1 rp2 rl2 p = readParen (p > 10) $ \s0 -> do ("Biff", s1) <- lex s0 ("{", s2) <- lex s1 ("runBiff", s3) <- lex s2 (x, s4) <- liftReadsPrec2 (liftReadsPrec rp1 rl1) (liftReadList rp1 rl1) (liftReadsPrec rp2 rl2) (liftReadList rp2 rl2) 0 s3 ("}", s5) <- lex s4 return (Biff x, s5) instance (Show2 p, Show1 f, Show1 g, Show a) => Show1 (Biff p f g a) where liftShowsPrec = liftShowsPrec2 showsPrec showList instance (Show2 p, Show1 f, Show1 g) => Show2 (Biff p f g) where liftShowsPrec2 sp1 sl1 sp2 sl2 p (Biff x) = showParen (p > 10) $ showString "Biff {runBiff = " . liftShowsPrec2 (liftShowsPrec sp1 sl1) (liftShowList sp1 sl1) (liftShowsPrec sp2 sl2) (liftShowList sp2 sl2) 0 x . showChar '}' #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.5.15/src/Data/Bifunctor/Clown.hs0000644000000000000000000001225507346545000017174 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} #endif #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #include "bifunctors-common.h" ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 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 import Data.Functor.Classes #if __GLASGOW_HASKELL__ < 710 import Data.Foldable import Data.Monoid import Data.Traversable #endif #if __GLASGOW_HASKELL__ >= 708 import Data.Typeable #endif #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics #endif -- | Make a 'Functor' over the first argument of a 'Bifunctor'. -- -- Mnemonic: C__l__owns to the __l__eft (parameter of the Bifunctor), -- joke__r__s to the __r__ight. newtype Clown f a b = Clown { runClown :: f a } deriving ( Eq, Ord, Show, Read #if __GLASGOW_HASKELL__ >= 702 , Generic #endif #if __GLASGOW_HASKELL__ >= 708 , Generic1 , Typeable #endif ) #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 data ClownMetaData data ClownMetaCons data ClownMetaSel instance Datatype ClownMetaData where datatypeName _ = "Clown" moduleName _ = "Data.Bifunctor.Clown" instance Constructor ClownMetaCons where conName _ = "Clown" conIsRecord _ = True instance Selector ClownMetaSel where selName _ = "runClown" instance Generic1 (Clown f a) where type Rep1 (Clown f a) = D1 ClownMetaData (C1 ClownMetaCons (S1 ClownMetaSel (Rec0 (f a)))) from1 = M1 . M1 . M1 . K1 . runClown to1 = Clown . unK1 . unM1 . unM1 . unM1 #endif #if LIFTED_FUNCTOR_CLASSES instance (Eq1 f, Eq a) => Eq1 (Clown f a) where liftEq = liftEq2 (==) instance Eq1 f => Eq2 (Clown f) where liftEq2 f _ = eqClown (liftEq f) instance (Ord1 f, Ord a) => Ord1 (Clown f a) where liftCompare = liftCompare2 compare instance Ord1 f => Ord2 (Clown f) where liftCompare2 f _ = compareClown (liftCompare f) instance (Read1 f, Read a) => Read1 (Clown f a) where liftReadsPrec = liftReadsPrec2 readsPrec readList instance Read1 f => Read2 (Clown f) where liftReadsPrec2 rp1 rl1 _ _ = readsPrecClown (liftReadsPrec rp1 rl1) instance (Show1 f, Show a) => Show1 (Clown f a) where liftShowsPrec = liftShowsPrec2 showsPrec showList instance Show1 f => Show2 (Clown f) where liftShowsPrec2 sp1 sl1 _ _ = showsPrecClown (liftShowsPrec sp1 sl1) #else instance (Eq1 f, Eq a) => Eq1 (Clown f a) where eq1 = eqClown eq1 instance (Ord1 f, Ord a) => Ord1 (Clown f a) where compare1 = compareClown compare1 instance (Read1 f, Read a) => Read1 (Clown f a) where readsPrec1 = readsPrecClown readsPrec1 instance (Show1 f, Show a) => Show1 (Clown f a) where showsPrec1 = showsPrecClown showsPrec1 #endif eqClown :: (f a1 -> f a2 -> Bool) -> Clown f a1 b1 -> Clown f a2 b2 -> Bool eqClown eqA (Clown x) (Clown y) = eqA x y compareClown :: (f a1 -> f a2 -> Ordering) -> Clown f a1 b1 -> Clown f a2 b2 -> Ordering compareClown compareA (Clown x) (Clown y) = compareA x y readsPrecClown :: (Int -> ReadS (f a)) -> Int -> ReadS (Clown f a b) readsPrecClown rpA p = readParen (p > 10) $ \s0 -> do ("Clown", s1) <- lex s0 ("{", s2) <- lex s1 ("runClown", s3) <- lex s2 (x, s4) <- rpA 0 s3 ("}", s5) <- lex s4 return (Clown x, s5) showsPrecClown :: (Int -> f a -> ShowS) -> Int -> Clown f a b -> ShowS showsPrecClown spA p (Clown x) = showParen (p > 10) $ showString "Clown {runClown = " . spA 0 x . showChar '}' 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.5.15/src/Data/Bifunctor/Fix.hs0000644000000000000000000000617507346545000016644 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} #endif #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #include "bifunctors-common.h" ----------------------------------------------------------------------------- -- | -- Module : Data.Bifunctor.Fix -- Copyright : (C) 2008-2016 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 #if __GLASGOW_HASKELL__ >= 708 import Data.Typeable #endif #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics #endif #if LIFTED_FUNCTOR_CLASSES import Data.Functor.Classes #endif -- | Greatest fixpoint of a 'Bifunctor' (a 'Functor' over the first argument with zipping). newtype Fix p a = In { out :: p (Fix p a) a } deriving ( #if __GLASGOW_HASKELL__ >= 702 Generic #endif #if __GLASGOW_HASKELL__ >= 708 , Typeable #endif ) deriving instance Eq (p (Fix p a) a) => Eq (Fix p a) deriving instance Ord (p (Fix p a) a) => Ord (Fix p a) deriving instance Show (p (Fix p a) a) => Show (Fix p a) deriving instance Read (p (Fix p a) a) => Read (Fix p a) #if LIFTED_FUNCTOR_CLASSES instance Eq2 p => Eq1 (Fix p) where liftEq f (In x) (In y) = liftEq2 (liftEq f) f x y instance Ord2 p => Ord1 (Fix p) where liftCompare f (In x) (In y) = liftCompare2 (liftCompare f) f x y instance Read2 p => Read1 (Fix p) where liftReadsPrec rp1 rl1 p = readParen (p > 10) $ \s0 -> do ("In", s1) <- lex s0 ("{", s2) <- lex s1 ("out", s3) <- lex s2 (x, s4) <- liftReadsPrec2 (liftReadsPrec rp1 rl1) (liftReadList rp1 rl1) rp1 rl1 0 s3 ("}", s5) <- lex s4 return (In x, s5) instance Show2 p => Show1 (Fix p) where liftShowsPrec sp1 sl1 p (In x) = showParen (p > 10) $ showString "In {out = " . liftShowsPrec2 (liftShowsPrec sp1 sl1) (liftShowList sp1 sl1) sp1 sl1 0 x . showChar '}' #endif 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.5.15/src/Data/Bifunctor/Flip.hs0000644000000000000000000000730207346545000017001 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} #endif #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #include "bifunctors-common.h" ----------------------------------------------------------------------------- -- | -- Module : Data.Bifunctor.Flip -- Copyright : (C) 2008-2016 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.Bifunctor.Functor 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 #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics #endif #if LIFTED_FUNCTOR_CLASSES import Data.Functor.Classes #endif -- | Make a 'Bifunctor' flipping the arguments of a 'Bifunctor'. newtype Flip p a b = Flip { runFlip :: p b a } deriving ( Eq, Ord, Show, Read #if __GLASGOW_HASKELL__ >= 702 , Generic #endif #if __GLASGOW_HASKELL__ >= 708 , Typeable #endif ) #if LIFTED_FUNCTOR_CLASSES instance (Eq2 p, Eq a) => Eq1 (Flip p a) where liftEq = liftEq2 (==) instance Eq2 p => Eq2 (Flip p) where liftEq2 f g (Flip x) (Flip y) = liftEq2 g f x y instance (Ord2 p, Ord a) => Ord1 (Flip p a) where liftCompare = liftCompare2 compare instance Ord2 p => Ord2 (Flip p) where liftCompare2 f g (Flip x) (Flip y) = liftCompare2 g f x y instance (Read2 p, Read a) => Read1 (Flip p a) where liftReadsPrec = liftReadsPrec2 readsPrec readList instance Read2 p => Read2 (Flip p) where liftReadsPrec2 rp1 rl1 rp2 rl2 p = readParen (p > 10) $ \s0 -> do ("Flip", s1) <- lex s0 ("{", s2) <- lex s1 ("runFlip", s3) <- lex s2 (x, s4) <- liftReadsPrec2 rp2 rl2 rp1 rl1 0 s3 ("}", s5) <- lex s4 return (Flip x, s5) instance (Show2 p, Show a) => Show1 (Flip p a) where liftShowsPrec = liftShowsPrec2 showsPrec showList instance Show2 p => Show2 (Flip p) where liftShowsPrec2 sp1 sl1 sp2 sl2 p (Flip x) = showParen (p > 10) $ showString "Flip {runFlip = " . liftShowsPrec2 sp2 sl2 sp1 sl1 0 x . showChar '}' #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 #-} instance BifunctorFunctor Flip where bifmap f (Flip p) = Flip (f p) bifunctors-5.5.15/src/Data/Bifunctor/Functor.hs0000644000000000000000000000266707346545000017540 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif module Data.Bifunctor.Functor ( (:->) , BifunctorFunctor(..) , BifunctorMonad(..) , biliftM , BifunctorComonad(..) , biliftW ) where -- | Using parametricity as an approximation of a natural transformation in two arguments. type (:->) p q = forall a b. p a b -> q a b infixr 0 :-> class BifunctorFunctor t where bifmap :: (p :-> q) -> t p :-> t q class BifunctorFunctor t => BifunctorMonad t where bireturn :: p :-> t p bibind :: (p :-> t q) -> t p :-> t q bibind f = bijoin . bifmap f bijoin :: t (t p) :-> t p bijoin = bibind id #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL bireturn, (bibind | bijoin) #-} #endif biliftM :: BifunctorMonad t => (p :-> q) -> t p :-> t q biliftM f = bibind (bireturn . f) {-# INLINE biliftM #-} class BifunctorFunctor t => BifunctorComonad t where biextract :: t p :-> p biextend :: (t p :-> q) -> t p :-> t q biextend f = bifmap f . biduplicate biduplicate :: t p :-> t (t p) biduplicate = biextend id #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL biextract, (biextend | biduplicate) #-} #endif biliftW :: BifunctorComonad t => (p :-> q) -> t p :-> t q biliftW f = biextend (f . biextract) {-# INLINE biliftW #-} bifunctors-5.5.15/src/Data/Bifunctor/Join.hs0000644000000000000000000000612307346545000017006 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} #endif #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #include "bifunctors-common.h" ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 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 #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics #endif #if LIFTED_FUNCTOR_CLASSES import Data.Functor.Classes #endif -- | Make a 'Functor' over both arguments of a 'Bifunctor'. newtype Join p a = Join { runJoin :: p a a } deriving ( #if __GLASGOW_HASKELL__ >= 702 Generic #endif #if __GLASGOW_HASKELL__ >= 708 , 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) #if LIFTED_FUNCTOR_CLASSES instance Eq2 p => Eq1 (Join p) where liftEq f (Join x) (Join y) = liftEq2 f f x y instance Ord2 p => Ord1 (Join p) where liftCompare f (Join x) (Join y) = liftCompare2 f f x y instance Read2 p => Read1 (Join p) where liftReadsPrec rp1 rl1 p = readParen (p > 10) $ \s0 -> do ("Join", s1) <- lex s0 ("{", s2) <- lex s1 ("runJoin", s3) <- lex s2 (x, s4) <- liftReadsPrec2 rp1 rl1 rp1 rl1 0 s3 ("}", s5) <- lex s4 return (Join x, s5) instance Show2 p => Show1 (Join p) where liftShowsPrec sp1 sl1 p (Join x) = showParen (p > 10) $ showString "Join {runJoin = " . liftShowsPrec2 sp1 sl1 sp1 sl1 0 x . showChar '}' #endif 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.5.15/src/Data/Bifunctor/Joker.hs0000644000000000000000000001230307346545000017156 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} #endif #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #include "bifunctors-common.h" ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 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 import Data.Functor.Classes #if __GLASGOW_HASKELL__ < 710 import Data.Foldable import Data.Traversable #endif #if __GLASGOW_HASKELL__ >= 708 import Data.Typeable #endif #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics #endif -- | Make a 'Functor' over the second argument of a 'Bifunctor'. -- -- Mnemonic: C__l__owns to the __l__eft (parameter of the Bifunctor), -- joke__r__s to the __r__ight. newtype Joker g a b = Joker { runJoker :: g b } deriving ( Eq, Ord, Show, Read #if __GLASGOW_HASKELL__ >= 702 , Generic #endif #if __GLASGOW_HASKELL__ >= 708 , Generic1 , Typeable #endif ) #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 data JokerMetaData data JokerMetaCons data JokerMetaSel instance Datatype JokerMetaData where datatypeName _ = "Joker" moduleName _ = "Data.Bifunctor.Joker" instance Constructor JokerMetaCons where conName _ = "Joker" conIsRecord _ = True instance Selector JokerMetaSel where selName _ = "runJoker" instance Generic1 (Joker g a) where type Rep1 (Joker g a) = D1 JokerMetaData (C1 JokerMetaCons (S1 JokerMetaSel (Rec1 g))) from1 = M1 . M1 . M1 . Rec1 . runJoker to1 = Joker . unRec1 . unM1 . unM1 . unM1 #endif #if LIFTED_FUNCTOR_CLASSES instance Eq1 g => Eq1 (Joker g a) where liftEq g = eqJoker (liftEq g) instance Eq1 g => Eq2 (Joker g) where liftEq2 _ g = eqJoker (liftEq g) instance Ord1 g => Ord1 (Joker g a) where liftCompare g = compareJoker (liftCompare g) instance Ord1 g => Ord2 (Joker g) where liftCompare2 _ g = compareJoker (liftCompare g) instance Read1 g => Read1 (Joker g a) where liftReadsPrec rp rl = readsPrecJoker (liftReadsPrec rp rl) instance Read1 g => Read2 (Joker g) where liftReadsPrec2 _ _ rp2 rl2 = readsPrecJoker (liftReadsPrec rp2 rl2) instance Show1 g => Show1 (Joker g a) where liftShowsPrec sp sl = showsPrecJoker (liftShowsPrec sp sl) instance Show1 g => Show2 (Joker g) where liftShowsPrec2 _ _ sp2 sl2 = showsPrecJoker (liftShowsPrec sp2 sl2) #else instance Eq1 g => Eq1 (Joker g a) where eq1 = eqJoker eq1 instance Ord1 g => Ord1 (Joker g a) where compare1 = compareJoker compare1 instance Read1 g => Read1 (Joker g a) where readsPrec1 = readsPrecJoker readsPrec1 instance Show1 g => Show1 (Joker g a) where showsPrec1 = showsPrecJoker showsPrec1 #endif eqJoker :: (g b1 -> g b2 -> Bool) -> Joker g a1 b1 -> Joker g a2 b2 -> Bool eqJoker eqB (Joker x) (Joker y) = eqB x y compareJoker :: (g b1 -> g b2 -> Ordering) -> Joker g a1 b1 -> Joker g a2 b2 -> Ordering compareJoker compareB (Joker x) (Joker y) = compareB x y readsPrecJoker :: (Int -> ReadS (g b)) -> Int -> ReadS (Joker g a b) readsPrecJoker rpB p = readParen (p > 10) $ \s0 -> do ("Joker", s1) <- lex s0 ("{", s2) <- lex s1 ("runJoker", s3) <- lex s2 (x, s4) <- rpB 0 s3 ("}", s5) <- lex s4 return (Joker x, s5) showsPrecJoker :: (Int -> g b -> ShowS) -> Int -> Joker g a b -> ShowS showsPrecJoker spB p (Joker x) = showParen (p > 10) $ showString "Joker {runJoker = " . spB 0 x . showChar '}' 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.5.15/src/Data/Bifunctor/Product.hs0000644000000000000000000001410107346545000017522 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} #endif #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #include "bifunctors-common.h" ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 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 import qualified Control.Arrow as A import Control.Category import Data.Biapplicative import Data.Bifoldable import Data.Bifunctor.Functor import Data.Bitraversable #if __GLASGOW_HASKELL__ < 710 import Control.Applicative import Data.Foldable import Data.Monoid hiding (Product) import Data.Traversable #endif #if __GLASGOW_HASKELL__ >= 708 import Data.Typeable #endif #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics #endif #if LIFTED_FUNCTOR_CLASSES import Data.Functor.Classes #endif import Prelude hiding ((.),id) -- | Form the product of two bifunctors data Product f g a b = Pair (f a b) (g a b) deriving ( Eq, Ord, Show, Read #if __GLASGOW_HASKELL__ >= 702 , Generic #endif #if __GLASGOW_HASKELL__ >= 708 , Generic1 , Typeable #endif ) deriving instance (Functor (f a), Functor (g a)) => Functor (Product f g a) deriving instance (Foldable (f a), Foldable (g a)) => Foldable (Product f g a) deriving instance (Traversable (f a), Traversable (g a)) => Traversable (Product f g a) #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 data ProductMetaData data ProductMetaCons instance Datatype ProductMetaData where datatypeName _ = "Product" moduleName _ = "Data.Bifunctor.Product" instance Constructor ProductMetaCons where conName _ = "Pair" instance Generic1 (Product f g a) where type Rep1 (Product f g a) = D1 ProductMetaData (C1 ProductMetaCons ((:*:) (S1 NoSelector (Rec1 (f a))) (S1 NoSelector (Rec1 (g a))))) from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g))) to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g) #endif #if LIFTED_FUNCTOR_CLASSES instance (Eq2 f, Eq2 g, Eq a) => Eq1 (Product f g a) where liftEq = liftEq2 (==) instance (Eq2 f, Eq2 g) => Eq2 (Product f g) where liftEq2 f g (Pair x1 y1) (Pair x2 y2) = liftEq2 f g x1 x2 && liftEq2 f g y1 y2 instance (Ord2 f, Ord2 g, Ord a) => Ord1 (Product f g a) where liftCompare = liftCompare2 compare instance (Ord2 f, Ord2 g) => Ord2 (Product f g) where liftCompare2 f g (Pair x1 y1) (Pair x2 y2) = liftCompare2 f g x1 x2 `mappend` liftCompare2 f g y1 y2 instance (Read2 f, Read2 g, Read a) => Read1 (Product f g a) where liftReadsPrec = liftReadsPrec2 readsPrec readList instance (Read2 f, Read2 g) => Read2 (Product f g) where liftReadsPrec2 rp1 rl1 rp2 rl2 = readsData $ readsBinaryWith (liftReadsPrec2 rp1 rl1 rp2 rl2) (liftReadsPrec2 rp1 rl1 rp2 rl2) "Pair" Pair instance (Show2 f, Show2 g, Show a) => Show1 (Product f g a) where liftShowsPrec = liftShowsPrec2 showsPrec showList instance (Show2 f, Show2 g) => Show2 (Product f g) where liftShowsPrec2 sp1 sl1 sp2 sl2 p (Pair x y) = showsBinaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) (liftShowsPrec2 sp1 sl1 sp2 sl2) "Pair" p x y #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 #-} instance BifunctorFunctor (Product p) where bifmap f (Pair p q) = Pair p (f q) instance BifunctorComonad (Product p) where biextract (Pair _ q) = q biduplicate pq@(Pair p _) = Pair p pq biextend f pq@(Pair p _) = Pair p (f pq) instance (Category p, Category q) => Category (Product p q) where id = Pair id id Pair x y . Pair x' y' = Pair (x . x') (y . y') instance (A.Arrow p, A.Arrow q) => A.Arrow (Product p q) where arr f = Pair (A.arr f) (A.arr f) first (Pair x y) = Pair (A.first x) (A.first y) second (Pair x y) = Pair (A.second x) (A.second y) Pair x y *** Pair x' y' = Pair (x A.*** x') (y A.*** y') Pair x y &&& Pair x' y' = Pair (x A.&&& x') (y A.&&& y') instance (A.ArrowChoice p, A.ArrowChoice q) => A.ArrowChoice (Product p q) where left (Pair x y) = Pair (A.left x) (A.left y) right (Pair x y) = Pair (A.right x) (A.right y) Pair x y +++ Pair x' y' = Pair (x A.+++ x') (y A.+++ y') Pair x y ||| Pair x' y' = Pair (x A.||| x') (y A.||| y') instance (A.ArrowLoop p, A.ArrowLoop q) => A.ArrowLoop (Product p q) where loop (Pair x y) = Pair (A.loop x) (A.loop y) instance (A.ArrowZero p, A.ArrowZero q) => A.ArrowZero (Product p q) where zeroArrow = Pair A.zeroArrow A.zeroArrow instance (A.ArrowPlus p, A.ArrowPlus q) => A.ArrowPlus (Product p q) where Pair x y <+> Pair x' y' = Pair (x A.<+> x') (y A.<+> y') bifunctors-5.5.15/src/Data/Bifunctor/Sum.hs0000644000000000000000000001060707346545000016655 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} #endif #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #include "bifunctors-common.h" module Data.Bifunctor.Sum where import Data.Bifunctor import Data.Bifunctor.Functor import Data.Bifoldable import Data.Bitraversable #if __GLASGOW_HASKELL__ < 710 import Data.Foldable import Data.Functor import Data.Monoid hiding (Sum) import Data.Traversable #endif #if __GLASGOW_HASKELL__ >= 708 import Data.Typeable #endif #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics #endif #if LIFTED_FUNCTOR_CLASSES import Data.Functor.Classes #endif data Sum p q a b = L2 (p a b) | R2 (q a b) deriving ( Eq, Ord, Show, Read #if __GLASGOW_HASKELL__ >= 702 , Generic #endif #if __GLASGOW_HASKELL__ >= 708 , Generic1 , Typeable #endif ) deriving instance (Functor (f a), Functor (g a)) => Functor (Sum f g a) deriving instance (Foldable (f a), Foldable (g a)) => Foldable (Sum f g a) deriving instance (Traversable (f a), Traversable (g a)) => Traversable (Sum f g a) #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 data SumMetaData data SumMetaConsL2 data SumMetaConsR2 instance Datatype SumMetaData where datatypeName _ = "Sum" moduleName _ = "Data.Bifunctor.Sum" instance Constructor SumMetaConsL2 where conName _ = "L2" instance Constructor SumMetaConsR2 where conName _ = "R2" instance Generic1 (Sum p q a) where type Rep1 (Sum p q a) = D1 SumMetaData ((:+:) (C1 SumMetaConsL2 (S1 NoSelector (Rec1 (p a)))) (C1 SumMetaConsR2 (S1 NoSelector (Rec1 (q a))))) from1 (L2 p) = M1 (L1 (M1 (M1 (Rec1 p)))) from1 (R2 q) = M1 (R1 (M1 (M1 (Rec1 q)))) to1 (M1 (L1 (M1 (M1 p)))) = L2 (unRec1 p) to1 (M1 (R1 (M1 (M1 q)))) = R2 (unRec1 q) #endif #if LIFTED_FUNCTOR_CLASSES instance (Eq2 f, Eq2 g, Eq a) => Eq1 (Sum f g a) where liftEq = liftEq2 (==) instance (Eq2 f, Eq2 g) => Eq2 (Sum f g) where liftEq2 f g (L2 x1) (L2 x2) = liftEq2 f g x1 x2 liftEq2 _ _ (L2 _) (R2 _) = False liftEq2 _ _ (R2 _) (L2 _) = False liftEq2 f g (R2 y1) (R2 y2) = liftEq2 f g y1 y2 instance (Ord2 f, Ord2 g, Ord a) => Ord1 (Sum f g a) where liftCompare = liftCompare2 compare instance (Ord2 f, Ord2 g) => Ord2 (Sum f g) where liftCompare2 f g (L2 x1) (L2 x2) = liftCompare2 f g x1 x2 liftCompare2 _ _ (L2 _) (R2 _) = LT liftCompare2 _ _ (R2 _) (L2 _) = GT liftCompare2 f g (R2 y1) (R2 y2) = liftCompare2 f g y1 y2 instance (Read2 f, Read2 g, Read a) => Read1 (Sum f g a) where liftReadsPrec = liftReadsPrec2 readsPrec readList instance (Read2 f, Read2 g) => Read2 (Sum f g) where liftReadsPrec2 rp1 rl1 rp2 rl2 = readsData $ readsUnaryWith (liftReadsPrec2 rp1 rl1 rp2 rl2) "L2" L2 `mappend` readsUnaryWith (liftReadsPrec2 rp1 rl1 rp2 rl2) "R2" R2 instance (Show2 f, Show2 g, Show a) => Show1 (Sum f g a) where liftShowsPrec = liftShowsPrec2 showsPrec showList instance (Show2 f, Show2 g) => Show2 (Sum f g) where liftShowsPrec2 sp1 sl1 sp2 sl2 p (L2 x) = showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "L2" p x liftShowsPrec2 sp1 sl1 sp2 sl2 p (R2 y) = showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "R2" p y #endif instance (Bifunctor p, Bifunctor q) => Bifunctor (Sum p q) where bimap f g (L2 p) = L2 (bimap f g p) bimap f g (R2 q) = R2 (bimap f g q) first f (L2 p) = L2 (first f p) first f (R2 q) = R2 (first f q) second f (L2 p) = L2 (second f p) second f (R2 q) = R2 (second f q) instance (Bifoldable p, Bifoldable q) => Bifoldable (Sum p q) where bifoldMap f g (L2 p) = bifoldMap f g p bifoldMap f g (R2 q) = bifoldMap f g q instance (Bitraversable p, Bitraversable q) => Bitraversable (Sum p q) where bitraverse f g (L2 p) = L2 <$> bitraverse f g p bitraverse f g (R2 q) = R2 <$> bitraverse f g q instance BifunctorFunctor (Sum p) where bifmap _ (L2 p) = L2 p bifmap f (R2 q) = R2 (f q) instance BifunctorMonad (Sum p) where bireturn = R2 bijoin (L2 p) = L2 p bijoin (R2 q) = q bibind _ (L2 p) = L2 p bibind f (R2 q) = f q bifunctors-5.5.15/src/Data/Bifunctor/TH.hs0000644000000000000000000015132507346545000016427 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Unsafe #-} #endif #ifndef MIN_VERSION_template_haskell #define MIN_VERSION_template_haskell(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 Edward Kmett, (C) 2015-2016 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 , deriveBifunctorOptions , makeBimap , makeBimapOptions -- * 'Bifoldable' , deriveBifoldable , deriveBifoldableOptions , makeBifold , makeBifoldOptions , makeBifoldMap , makeBifoldMapOptions , makeBifoldr , makeBifoldrOptions , makeBifoldl , makeBifoldlOptions -- * 'Bitraversable' , deriveBitraversable , deriveBitraversableOptions , makeBitraverse , makeBitraverseOptions , makeBisequenceA , makeBisequenceAOptions , makeBimapM , makeBimapMOptions , makeBisequence , makeBisequenceOptions -- * 'Options' , Options(..) , defaultOptions ) where import Control.Monad (guard, unless, when) import Data.Bifunctor.TH.Internal import qualified Data.List as List import qualified Data.Map as Map ((!), fromList, keys, lookup, member, size) import Data.Maybe import Language.Haskell.TH.Datatype as Datatype import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr import Language.Haskell.TH.Syntax ------------------------------------------------------------------------------- -- User-facing API ------------------------------------------------------------------------------- -- | Options that further configure how the functions in "Data.Bifunctor.TH" -- should behave. newtype Options = Options { emptyCaseBehavior :: Bool -- ^ If 'True', derived instances for empty data types (i.e., ones with -- no data constructors) will use the @EmptyCase@ language extension. -- If 'False', derived instances will simply use 'seq' instead. -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only -- available in 7.8 or later.) } deriving (Eq, Ord, Read, Show) -- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to -- prevent users from having to enable that extension at use sites.) defaultOptions :: Options defaultOptions = Options { emptyCaseBehavior = False } {- $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@. -} {- $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 = deriveBifunctorOptions defaultOptions -- | Like 'deriveBifunctor', but takes an 'Options' argument. deriveBifunctorOptions :: Options -> Name -> Q [Dec] deriveBifunctorOptions = deriveBiClass Bifunctor -- | Generates a lambda expression which behaves like 'bimap' (without requiring a -- 'Bifunctor' instance). makeBimap :: Name -> Q Exp makeBimap = makeBimapOptions defaultOptions -- | Like 'makeBimap', but takes an 'Options' argument. makeBimapOptions :: Options -> Name -> Q Exp makeBimapOptions = makeBiFun Bimap -- | Generates a 'Bifoldable' instance declaration for the given data type or data -- family instance. deriveBifoldable :: Name -> Q [Dec] deriveBifoldable = deriveBifoldableOptions defaultOptions -- | Like 'deriveBifoldable', but takes an 'Options' argument. deriveBifoldableOptions :: Options -> Name -> Q [Dec] deriveBifoldableOptions = deriveBiClass Bifoldable --- | Generates a lambda expression which behaves like 'bifold' (without requiring a -- 'Bifoldable' instance). makeBifold :: Name -> Q Exp makeBifold = makeBifoldOptions defaultOptions -- | Like 'makeBifold', but takes an 'Options' argument. makeBifoldOptions :: Options -> Name -> Q Exp makeBifoldOptions opts name = appsE [ makeBifoldMapOptions opts name , varE idValName , varE idValName ] -- | Generates a lambda expression which behaves like 'bifoldMap' (without requiring -- a 'Bifoldable' instance). makeBifoldMap :: Name -> Q Exp makeBifoldMap = makeBifoldMapOptions defaultOptions -- | Like 'makeBifoldMap', but takes an 'Options' argument. makeBifoldMapOptions :: Options -> Name -> Q Exp makeBifoldMapOptions = makeBiFun BifoldMap -- | Generates a lambda expression which behaves like 'bifoldr' (without requiring a -- 'Bifoldable' instance). makeBifoldr :: Name -> Q Exp makeBifoldr = makeBifoldrOptions defaultOptions -- | Like 'makeBifoldr', but takes an 'Options' argument. makeBifoldrOptions :: Options -> Name -> Q Exp makeBifoldrOptions = makeBiFun Bifoldr -- | Generates a lambda expression which behaves like 'bifoldl' (without requiring a -- 'Bifoldable' instance). makeBifoldl :: Name -> Q Exp makeBifoldl = makeBifoldlOptions defaultOptions -- | Like 'makeBifoldl', but takes an 'Options' argument. makeBifoldlOptions :: Options -> Name -> Q Exp makeBifoldlOptions opts 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 [ makeBifoldMapOptions opts 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 = deriveBitraversableOptions defaultOptions -- | Like 'deriveBitraversable', but takes an 'Options' argument. deriveBitraversableOptions :: Options -> Name -> Q [Dec] deriveBitraversableOptions = deriveBiClass Bitraversable -- | Generates a lambda expression which behaves like 'bitraverse' (without -- requiring a 'Bitraversable' instance). makeBitraverse :: Name -> Q Exp makeBitraverse = makeBitraverseOptions defaultOptions -- | Like 'makeBitraverse', but takes an 'Options' argument. makeBitraverseOptions :: Options -> Name -> Q Exp makeBitraverseOptions = makeBiFun Bitraverse -- | Generates a lambda expression which behaves like 'bisequenceA' (without -- requiring a 'Bitraversable' instance). makeBisequenceA :: Name -> Q Exp makeBisequenceA = makeBisequenceAOptions defaultOptions -- | Like 'makeBitraverseA', but takes an 'Options' argument. makeBisequenceAOptions :: Options -> Name -> Q Exp makeBisequenceAOptions opts name = appsE [ makeBitraverseOptions opts name , varE idValName , varE idValName ] -- | Generates a lambda expression which behaves like 'bimapM' (without -- requiring a 'Bitraversable' instance). makeBimapM :: Name -> Q Exp makeBimapM = makeBimapMOptions defaultOptions -- | Like 'makeBimapM', but takes an 'Options' argument. makeBimapMOptions :: Options -> Name -> Q Exp makeBimapMOptions opts name = do f <- newName "f" g <- newName "g" lamE [varP f, varP g] . infixApp (varE unwrapMonadValName) (varE composeValName) $ appsE [ makeBitraverseOptions opts 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 = makeBisequenceOptions defaultOptions -- | Like 'makeBisequence', but takes an 'Options' argument. makeBisequenceOptions :: Options -> Name -> Q Exp makeBisequenceOptions opts name = appsE [ makeBimapMOptions opts name , varE idValName , varE idValName ] ------------------------------------------------------------------------------- -- Code generation ------------------------------------------------------------------------------- -- | Derive a class instance declaration (depending on the BiClass argument's value). deriveBiClass :: BiClass -> Options -> Name -> Q [Dec] deriveBiClass biClass opts name = do info <- reifyDatatype name case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName , datatypeInstTypes = instTys , datatypeVariant = variant , datatypeCons = cons } -> do (instanceCxt, instanceType) <- buildTypeInstance biClass parentName ctxt instTys variant (:[]) `fmap` instanceD (return instanceCxt) (return instanceType) (biFunDecs biClass opts parentName instTys cons) -- | 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 -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec] biFunDecs biClass opts parentName instTys cons = map makeFunD $ biClassToFuns biClass where makeFunD :: BiFun -> Q Dec makeFunD biFun = funD (biFunName biFun) [ clause [] (normalB $ makeBiFunForCons biFun opts parentName instTys cons) [] ] -- | Generates a lambda expression which behaves like the BiFun argument. makeBiFun :: BiFun -> Options -> Name -> Q Exp makeBiFun biFun opts name = do info <- reifyDatatype name case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName , datatypeInstTypes = instTys , datatypeVariant = variant , datatypeCons = cons } -> -- We force buildTypeInstance here since it performs some checks for whether -- or not the provided datatype can actually have bimap/bifoldr/bitraverse/etc. -- implemented for it, and produces errors if it can't. buildTypeInstance (biFunToClass biFun) parentName ctxt instTys variant >> makeBiFunForCons biFun opts parentName instTys cons -- | Generates a lambda expression for the given constructors. -- All constructors must be from the same type. makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp makeBiFunForCons biFun opts _parentName instTys cons = do map1 <- newName "f" map2 <- newName "g" z <- newName "z" -- Only used for deriving bifoldr value <- newName "value" let argNames = catMaybes [ Just map1 , Just map2 , guard (biFun == Bifoldr) >> Just z , Just value ] lastTyVars = map varTToName $ drop (length instTys - 2) instTys tvMap = Map.fromList $ zip lastTyVars [map1, map2] lamE (map varP argNames) . appsE $ [ varE $ biFunConstName biFun , makeFun z value tvMap ] ++ map varE argNames where makeFun :: Name -> Name -> TyVarMap -> Q Exp makeFun z value tvMap = do #if MIN_VERSION_template_haskell(2,9,0) roles <- reifyRoles _parentName #endif case () of _ #if MIN_VERSION_template_haskell(2,9,0) | Just (rs, PhantomR) <- unsnoc roles , Just (_, PhantomR) <- unsnoc rs -> biFunPhantom z value #endif | null cons && emptyCaseBehavior opts && ghc7'8OrLater -> biFunEmptyCase biFun z value | null cons -> biFunNoCons biFun z value | otherwise -> caseE (varE value) (map (makeBiFunForCon biFun z tvMap) cons) ghc7'8OrLater :: Bool #if __GLASGOW_HASKELL__ >= 708 ghc7'8OrLater = True #else ghc7'8OrLater = False #endif #if MIN_VERSION_template_haskell(2,9,0) biFunPhantom :: Name -> Name -> Q Exp biFunPhantom z value = biFunTrivial coerce (varE pureValName `appE` coerce) biFun z where coerce :: Q Exp coerce = varE coerceValName `appE` varE value #endif -- | Generates a match for a single constructor. makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match makeBiFunForCon biFun z tvMap con@(ConstructorInfo { constructorName = conName , constructorContext = ctxt }) = do when ((any (`predMentionsName` Map.keys tvMap) ctxt || Map.size tvMap < 2) && not (allowExQuant (biFunToClass biFun))) $ existentialContextError conName case biFun of Bimap -> makeBimapMatch tvMap con Bifoldr -> makeBifoldrMatch z tvMap con BifoldMap -> makeBifoldMapMatch tvMap con Bitraverse -> makeBitraverseMatch tvMap con -- | Generates a match whose right-hand side implements @bimap@. makeBimapMatch :: TyVarMap -> ConstructorInfo -> Q Match makeBimapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do parts <- foldDataConArgs tvMap ft_bimap con match_for_con conName parts where ft_bimap :: FFoldType (Exp -> Q Exp) ft_bimap = FT { ft_triv = return , ft_var = \v x -> return $ VarE (tvMap Map.! v) `AppE` x , ft_fun = \g h x -> mkSimpleLam $ \b -> do gg <- g b h $ x `AppE` gg , ft_tup = mkSimpleTupleCase match_for_con , ft_ty_app = \argGs x -> do let inspect :: (Type, Exp -> Q Exp) -> Q Exp inspect (argTy, g) -- If the argument type is a bare occurrence of one -- of the data type's last type variables, then we -- can generate more efficient code. -- This was inspired by GHC#17880. | Just argVar <- varTToName_maybe argTy , Just f <- Map.lookup argVar tvMap = return $ VarE f | otherwise = mkSimpleLam g appsE $ varE (fmapArity (length argGs)) : map inspect argGs ++ [return x] , ft_forall = \_ g x -> g x , ft_bad_app = \_ -> outOfPlaceTyVarError conName , ft_co_var = \_ _ -> contravarianceError conName } -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... match_for_con :: Name -> [Exp -> Q Exp] -> Q Match match_for_con = mkSimpleConMatch $ \conName' xs -> appsE (conE conName':xs) -- Con x1 x2 .. -- | Generates a match whose right-hand side implements @bifoldr@. makeBifoldrMatch :: Name -> TyVarMap -> ConstructorInfo -> Q Match makeBifoldrMatch z tvMap con@(ConstructorInfo{constructorName = conName}) = do parts <- foldDataConArgs tvMap ft_bifoldr con parts' <- sequence parts match_for_con (VarE z) conName parts' where -- The Bool is True if the type mentions of the last two type parameters, -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter -- out expressions that do not mention the last parameters by checking for -- False. ft_bifoldr :: FFoldType (Q (Bool, Exp)) ft_bifoldr = FT { -- See Note [ft_triv for Bifoldable and Bitraversable] ft_triv = do lam <- mkSimpleLam2 $ \_ z' -> return z' return (False, lam) , ft_var = \v -> return (True, VarE $ tvMap Map.! v) , ft_tup = \t gs -> do gg <- sequence gs lam <- mkSimpleLam2 $ \x z' -> mkSimpleTupleCase (match_for_con z') t gg x return (True, lam) , ft_ty_app = \gs -> do lam <- mkSimpleLam2 $ \x z' -> appsE $ varE (foldrArity (length gs)) : map (\(_, hs) -> fmap snd hs) gs ++ map return [z', x] return (True, lam) , ft_forall = \_ g -> g , ft_co_var = \_ -> contravarianceError conName , ft_fun = \_ _ -> noFunctionsError conName , ft_bad_app = outOfPlaceTyVarError conName } match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match match_for_con zExp = mkSimpleConMatch2 $ \_ xs -> return $ mkBifoldr xs where -- g1 v1 (g2 v2 (.. z)) mkBifoldr :: [Exp] -> Exp mkBifoldr = foldr AppE zExp -- | Generates a match whose right-hand side implements @bifoldMap@. makeBifoldMapMatch :: TyVarMap -> ConstructorInfo -> Q Match makeBifoldMapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do parts <- foldDataConArgs tvMap ft_bifoldMap con parts' <- sequence parts match_for_con conName parts' where -- The Bool is True if the type mentions of the last two type parameters, -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter -- out expressions that do not mention the last parameters by checking for -- False. ft_bifoldMap :: FFoldType (Q (Bool, Exp)) ft_bifoldMap = FT { -- See Note [ft_triv for Bifoldable and Bitraversable] ft_triv = do lam <- mkSimpleLam $ \_ -> return $ VarE memptyValName return (False, lam) , ft_var = \v -> return (True, VarE $ tvMap Map.! v) , ft_tup = \t gs -> do gg <- sequence gs lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg return (True, lam) , ft_ty_app = \gs -> do e <- appsE $ varE (foldMapArity (length gs)) : map (\(_, hs) -> fmap snd hs) gs return (True, e) , ft_forall = \_ g -> g , ft_co_var = \_ -> contravarianceError conName , ft_fun = \_ _ -> noFunctionsError conName , ft_bad_app = outOfPlaceTyVarError conName } match_for_con :: Name -> [(Bool, Exp)] -> Q Match match_for_con = mkSimpleConMatch2 $ \_ xs -> return $ mkBifoldMap xs where -- mappend v1 (mappend v2 ..) mkBifoldMap :: [Exp] -> Exp mkBifoldMap [] = VarE memptyValName mkBifoldMap es = foldr1 (AppE . AppE (VarE mappendValName)) es -- | Generates a match whose right-hand side implements @bitraverse@. makeBitraverseMatch :: TyVarMap -> ConstructorInfo -> Q Match makeBitraverseMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do parts <- foldDataConArgs tvMap ft_bitrav con parts' <- sequence parts match_for_con conName parts' where -- The Bool is True if the type mentions of the last two type parameters, -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter -- out expressions that do not mention the last parameters by checking for -- False. ft_bitrav :: FFoldType (Q (Bool, Exp)) ft_bitrav = FT { -- See Note [ft_triv for Bifoldable and Bitraversable] ft_triv = return (False, VarE pureValName) , ft_var = \v -> return (True, VarE $ tvMap Map.! v) , ft_tup = \t gs -> do gg <- sequence gs lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg return (True, lam) , ft_ty_app = \gs -> do e <- appsE $ varE (traverseArity (length gs)) : map (\(_, hs) -> fmap snd hs) gs return (True, e) , ft_forall = \_ g -> g , ft_co_var = \_ -> contravarianceError conName , ft_fun = \_ _ -> noFunctionsError conName , ft_bad_app = outOfPlaceTyVarError conName } -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) -- (g2 a2) <*> ... match_for_con :: Name -> [(Bool, Exp)] -> Q Match match_for_con = mkSimpleConMatch2 $ \conExp xs -> return $ mkApCon conExp xs where -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. mkApCon :: Exp -> [Exp] -> Exp mkApCon conExp [] = VarE pureValName `AppE` conExp mkApCon conExp [e] = VarE fmapValName `AppE` conExp `AppE` e mkApCon conExp (e1:e2:es) = List.foldl' appAp (VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es where appAp se1 se2 = InfixE (Just se1) (VarE apValName) (Just se2) ------------------------------------------------------------------------------- -- Template Haskell reifying and AST manipulation ------------------------------------------------------------------------------- -- For the given Types, generate an instance context and head. Coming up with -- the instance type isn't as simple as dropping the last types, as you need to -- be wary of kinds being instantiated with *. -- See Note [Type inference in derived instances] buildTypeInstance :: BiClass -- ^ Bifunctor, Bifoldable, or Bitraversable -> Name -- ^ The type constructor or data family name -> Cxt -- ^ The datatype context -> [Type] -- ^ The types to instantiate the instance with -> DatatypeVariant -- ^ Are we dealing with a data family instance or not -> Q (Cxt, Type) buildTypeInstance biClass tyConName dataCxt instTysOrig variant = do -- Make sure to expand through type/kind synonyms! Otherwise, the -- eta-reduction check might get tripped up over type variables in a -- synonym that are actually dropped. -- (See GHC Trac #11416 for a scenario where this actually happened.) varTysExp <- mapM resolveTypeSynonyms instTysOrig let remainingLength :: Int remainingLength = length instTysOrig - 2 droppedTysExp :: [Type] droppedTysExp = drop remainingLength varTysExp droppedStarKindStati :: [StarKindStatus] droppedStarKindStati = map canRealizeKindStar droppedTysExp -- Check there are enough types to drop and that all of them are either of -- kind * or kind k (for some kind variable k). If not, throw an error. when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ derivingKindError biClass tyConName let droppedKindVarNames :: [Name] droppedKindVarNames = catKindVarNames droppedStarKindStati -- Substitute kind * for any dropped kind variables varTysExpSubst :: [Type] varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp remainingTysExpSubst, droppedTysExpSubst :: [Type] (remainingTysExpSubst, droppedTysExpSubst) = splitAt remainingLength varTysExpSubst -- All of the type variables mentioned in the dropped types -- (post-synonym expansion) droppedTyVarNames :: [Name] droppedTyVarNames = freeVariables droppedTysExpSubst -- If any of the dropped types were polykinded, ensure that they are of kind * -- after substituting * for the dropped kind variables. If not, throw an error. unless (all hasKindStar droppedTysExpSubst) $ derivingKindError biClass tyConName let preds :: [Maybe Pred] kvNames :: [[Name]] kvNames' :: [Name] -- Derive instance constraints (and any kind variables which are specialized -- to * in those constraints) (preds, kvNames) = unzip $ map (deriveConstraint biClass) remainingTysExpSubst kvNames' = concat kvNames -- Substitute the kind variables specialized in the constraints with * remainingTysExpSubst' :: [Type] remainingTysExpSubst' = map (substNamesWithKindStar kvNames') remainingTysExpSubst -- We now substitute all of the specialized-to-* kind variable names with -- *, but in the original types, not the synonym-expanded types. The reason -- we do this is a superficial one: we want the derived instance to resemble -- the datatype written in source code as closely as possible. For example, -- for the following data family instance: -- -- data family Fam a -- newtype instance Fam String = Fam String -- -- We'd want to generate the instance: -- -- instance C (Fam String) -- -- Not: -- -- instance C (Fam [Char]) remainingTysOrigSubst :: [Type] remainingTysOrigSubst = map (substNamesWithKindStar (List.union droppedKindVarNames kvNames')) $ take remainingLength instTysOrig isDataFamily <- case variant of Datatype -> return False Newtype -> return False DataInstance -> return True NewtypeInstance -> return True #if MIN_VERSION_th_abstraction(0,5,0) Datatype.TypeData -> typeDataError tyConName #endif let remainingTysOrigSubst' :: [Type] -- See Note [Kind signatures in derived instances] for an explanation -- of the isDataFamily check. remainingTysOrigSubst' = if isDataFamily then remainingTysOrigSubst else map unSigT remainingTysOrigSubst instanceCxt :: Cxt instanceCxt = catMaybes preds instanceType :: Type instanceType = AppT (ConT $ biClassName biClass) $ applyTyCon tyConName remainingTysOrigSubst' -- If the datatype context mentions any of the dropped type variables, -- we can't derive an instance, so throw an error. when (any (`predMentionsName` droppedTyVarNames) dataCxt) $ datatypeContextError tyConName instanceType -- Also ensure the dropped types can be safely eta-reduced. Otherwise, -- throw an error. unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $ etaReductionError instanceType return (instanceCxt, instanceType) -- | Attempt to derive a constraint on a Type. If successful, return -- Just the constraint and any kind variable names constrained to *. -- Otherwise, return Nothing and the empty list. -- -- See Note [Type inference in derived instances] for the heuristics used to -- come up with constraints. deriveConstraint :: BiClass -> Type -> (Maybe Pred, [Name]) deriveConstraint biClass t | not (isTyVar t) = (Nothing, []) | otherwise = case hasKindVarChain 1 t of Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 1, ns) _ -> case hasKindVarChain 2 t of Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 2, ns) _ -> (Nothing, []) where tName :: Name tName = varTToName t {- Note [Kind signatures in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is possible to put explicit kind signatures into the derived instances, e.g., instance C a => C (Data (f :: * -> *)) where ... But it is preferable to avoid this if possible. If we come up with an incorrect kind signature (which is entirely possible, since our type inferencer is pretty unsophisticated - see Note [Type inference in derived instances]), then GHC will flat-out reject the instance, which is quite unfortunate. Plain old datatypes have the advantage that you can avoid using any kind signatures at all in their instances. This is because a datatype declaration uses all type variables, so the types that we use in a derived instance uniquely determine their kinds. As long as we plug in the right types, the kind inferencer can do the rest of the work. For this reason, we use unSigT to remove all kind signatures before splicing in the instance context and head. Data family instances are trickier, since a data family can have two instances that are distinguished by kind alone, e.g., data family Fam (a :: k) data instance Fam (a :: * -> *) data instance Fam (a :: *) If we dropped the kind signatures for C (Fam a), then GHC will have no way of knowing which instance we are talking about. To avoid this scenario, we always include explicit kind signatures in data family instances. There is a chance that the inferred kind signatures will be incorrect, but if so, we can always fall back on the make- functions. Note [Type inference in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Type inference is can be tricky to get right, and we want to avoid recreating the entirety of GHC's type inferencer in Template Haskell. For this reason, we will probably never come up with derived instance contexts that are as accurate as GHC's. But that doesn't mean we can't do anything! There are a couple of simple things we can do to make instance contexts that work for 80% of use cases: 1. If one of the last type parameters is polykinded, then its kind will be specialized to * in the derived instance. We note what kind variable the type parameter had and substitute it with * in the other types as well. For example, imagine you had data Data (a :: k) (b :: k) (c :: k) Then you'd want to derived instance to be: instance C (Data (a :: *)) Not: instance C (Data (a :: k)) 2. We naïvely come up with instance constraints using the following criteria: (i) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind variables), then generate a Functor n constraint, and if k1/k2 are kind variables, then substitute k1/k2 with * elsewhere in the types. We must consider the case where they are kind variables because you might have a scenario like this: newtype Compose (f :: k3 -> *) (g :: k1 -> k2 -> k3) (a :: k1) (b :: k2) = Compose (f (g a b)) Which would have a derived Bifunctor instance of: instance (Functor f, Bifunctor g) => Bifunctor (Compose f g) where ... (ii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are * or kind variables), then generate a Bifunctor n constraint and perform kind substitution as in the other case. -} {- Note [Matching functions with GADT type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When deriving Bifoldable, there is a tricky corner case to consider: data Both a b where BothCon :: x -> x -> Both x x Which fold functions should be applied to which arguments of BothCon? We have a choice, since both the function of type (a -> m) and of type (b -> m) can be applied to either argument. In such a scenario, the second fold function takes precedence over the first fold function, so the derived Bifoldable instance would be: instance Bifoldable Both where bifoldMap _ g (BothCon x1 x2) = g x1 <> g x2 This is not an arbitrary choice, as this definition ensures that bifoldMap id = Foldable.foldMap for a derived Bifoldable instance for Both. -} ------------------------------------------------------------------------------- -- 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 -> Q a derivingKindError biClass tyConName = fail . 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 -> Q a contravarianceError conName = fail . 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 -> Q a noFunctionsError conName = fail . 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 -> Q a datatypeContextError dataName instanceType = fail . 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 -> Q a existentialContextError conName = fail . 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 -> Q a outOfPlaceTyVarError conName = fail . showString "Constructor ‘" . showString (nameBase conName) . showString "‘ must only use its last two type variable(s) within" . showString " the last two argument(s) of a data type" $ "" -- | One of the last type variables cannot be eta-reduced (see the canEtaReduce -- function for the criteria it would have to meet). etaReductionError :: Type -> Q a etaReductionError instanceType = fail $ "Cannot eta-reduce to an instance of form \n\tinstance (...) => " ++ pprint instanceType typeDataError :: Name -> Q a typeDataError dataName = fail . showString "Cannot derive instance for ‘" . showString (nameBase dataName) . showString "‘, which is a ‘type data‘ declaration" $ "" ------------------------------------------------------------------------------- -- 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 fmapArity :: Int -> Name fmapArity 1 = fmapValName fmapArity 2 = bimapValName fmapArity n = arityErr n foldrArity :: Int -> Name foldrArity 1 = foldrValName foldrArity 2 = bifoldrValName foldrArity n = arityErr n foldMapArity :: Int -> Name foldMapArity 1 = foldMapValName foldMapArity 2 = bifoldMapValName foldMapArity n = arityErr n traverseArity :: Int -> Name traverseArity 1 = traverseValName traverseArity 2 = bitraverseValName traverseArity n = arityErr n arityErr :: Int -> a arityErr n = error $ "Unsupported arity: " ++ show n allowExQuant :: BiClass -> Bool allowExQuant Bifoldable = True allowExQuant _ = False biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp biFunEmptyCase biFun z value = biFunTrivial emptyCase (varE pureValName `appE` emptyCase) biFun z where emptyCase :: Q Exp emptyCase = caseE (varE value) [] biFunNoCons :: BiFun -> Name -> Name -> Q Exp biFunNoCons biFun z value = biFunTrivial seqAndError (varE pureValName `appE` seqAndError) biFun z where seqAndError :: Q Exp seqAndError = appE (varE seqValName) (varE value) `appE` appE (varE errorValName) (stringE $ "Void " ++ nameBase (biFunName biFun)) biFunTrivial :: Q Exp -> Q Exp -> BiFun -> Name -> Q Exp biFunTrivial bimapE bitraverseE biFun z = go biFun where go :: BiFun -> Q Exp go Bimap = bimapE go Bifoldr = varE z go BifoldMap = varE memptyValName go Bitraverse = bitraverseE {- Note [ft_triv for Bifoldable and Bitraversable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When deriving Bifoldable and Bitraversable, we filter out any subexpressions whose type does not mention one of the last two type parameters. From this, you might think that we don't need to implement ft_triv for bifoldr, bifoldMap, or bitraverse at all, but in fact we do need to. Imagine the following data type: data T a b = MkT a (T Int b) In a derived Bifoldable T instance, you would generate the following bifoldMap definition: bifoldMap f g (MkT a1 a2) = f a1 <> bifoldMap (\_ -> mempty) g arg2 You need to fill in bi_triv (\_ -> mempty) as the first argument to the recursive call to bifoldMap, since that is how the algorithm handles polymorphic recursion. -} ------------------------------------------------------------------------------- -- Generic traversal for functor-like deriving ------------------------------------------------------------------------------- -- Much of the code below is cargo-culted from the TcGenFunctor module in GHC. data FFoldType a -- Describes how to fold over a Type in a functor like way = FT { ft_triv :: a -- ^ Does not contain variables , ft_var :: Name -> a -- ^ A bare variable , ft_co_var :: Name -> a -- ^ A bare variable, contravariantly , ft_fun :: a -> a -> a -- ^ Function type , ft_tup :: TupleSort -> [a] -> a -- ^ Tuple type. The [a] is the result of folding over the -- arguments of the tuple. , ft_ty_app :: [(Type, a)] -> a -- ^ Type app, variables only in last argument. The [(Type, a)] -- represents the last argument types. That is, they form the -- argument parts of @fun_ty arg_ty_1 ... arg_ty_n@. , ft_bad_app :: a -- ^ Type app, variable other than in last arguments , ft_forall :: [TyVarBndrSpec] -> a -> a -- ^ Forall type } -- Note that in GHC, this function is pure. It must be monadic here since we: -- -- (1) Expand type synonyms -- (2) Detect type family applications -- -- Which require reification in Template Haskell, but are pure in Core. functorLikeTraverse :: forall a. TyVarMap -- ^ Variables to look for -> FFoldType a -- ^ How to fold -> Type -- ^ Type to process -> Q a functorLikeTraverse tvMap (FT { ft_triv = caseTrivial, ft_var = caseVar , ft_co_var = caseCoVar, ft_fun = caseFun , ft_tup = caseTuple, ft_ty_app = caseTyApp , ft_bad_app = caseWrongArg, ft_forall = caseForAll }) ty = do ty' <- resolveTypeSynonyms ty (res, _) <- go False ty' return res where go :: Bool -- Covariant or contravariant context -> Type -> Q (a, Bool) -- (result of type a, does type contain var) go co t@AppT{} | (ArrowT, [funArg, funRes]) <- unapplyTy t = do (funArgR, funArgC) <- go (not co) funArg (funResR, funResC) <- go co funRes if funArgC || funResC then return (caseFun funArgR funResR, True) else trivial go co t@AppT{} = do let (f, args) = unapplyTy t (_, fc) <- go co f (xrs, xcs) <- fmap unzip $ mapM (go co) args let numLastArgs, numFirstArgs :: Int numLastArgs = min 2 $ length args numFirstArgs = length args - numLastArgs tuple :: TupleSort -> Q (a, Bool) tuple tupSort = return (caseTuple tupSort xrs, True) wrongArg :: Q (a, Bool) wrongArg = return (caseWrongArg, True) case () of _ | not (or xcs) -> trivial -- Variable does not occur -- At this point we know that xrs, xcs is not empty, -- and at least one xr is True | TupleT len <- f -> tuple $ Boxed len #if MIN_VERSION_template_haskell(2,6,0) | UnboxedTupleT len <- f -> tuple $ Unboxed len #endif | fc || or (take numFirstArgs xcs) -> wrongArg -- T (..var..) ty_1 ... ty_n | otherwise -- T (..no var..) ty_1 ... ty_n -> do itf <- isInTypeFamilyApp tyVarNames f args if itf -- We can't decompose type families, so -- error if we encounter one here. then wrongArg else return ( caseTyApp $ drop numFirstArgs $ zip args xrs , True ) go co (SigT t k) = do (_, kc) <- go_kind co k if kc then return (caseWrongArg, True) else go co t go co (VarT v) | Map.member v tvMap = return (if co then caseCoVar v else caseVar v, True) | otherwise = trivial go co (ForallT tvbs _ t) = do (tr, tc) <- go co t let tvbNames = map tvName tvbs if not tc || any (`elem` tvbNames) tyVarNames then trivial else return (caseForAll tvbs tr, True) go _ _ = trivial go_kind :: Bool -> Kind -> Q (a, Bool) #if MIN_VERSION_template_haskell(2,9,0) go_kind = go #else go_kind _ _ = trivial #endif trivial :: Q (a, Bool) trivial = return (caseTrivial, False) tyVarNames :: [Name] tyVarNames = Map.keys tvMap -- Fold over the arguments of a data constructor in a Functor-like way. foldDataConArgs :: forall a. TyVarMap -> FFoldType a -> ConstructorInfo -> Q [a] foldDataConArgs tvMap ft con = do fieldTys <- mapM resolveTypeSynonyms $ constructorFields con mapM foldArg fieldTys where foldArg :: Type -> Q a foldArg = functorLikeTraverse tvMap ft -- Make a 'LamE' using a fresh variable. mkSimpleLam :: (Exp -> Q Exp) -> Q Exp mkSimpleLam lam = do -- Use an underscore in front of the variable name, as it's possible for -- certain Bifoldable instances to generate code like this (see #89): -- -- @ -- bifoldMap (\\_n -> mempty) ... -- @ -- -- Without the underscore, that code would trigger -Wunused-matches warnings. n <- newName "_n" body <- lam (VarE n) return $ LamE [VarP n] body -- Make a 'LamE' using two fresh variables. mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp mkSimpleLam2 lam = do -- Use an underscore in front of the variable name, as it's possible for -- certain Bifoldable instances to generate code like this (see #89): -- -- @ -- bifoldr (\\_n1 n2 -> n2) ... -- @ -- -- Without the underscore, that code would trigger -Wunused-matches warnings. n1 <- newName "_n1" n2 <- newName "n2" body <- lam (VarE n1) (VarE n2) return $ LamE [VarP n1, VarP n2] body -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" -- -- @mkSimpleConMatch fold conName insides@ produces a match clause in -- which the LHS pattern-matches on @extraPats@, followed by a match on the -- constructor @conName@ and its arguments. The RHS folds (with @fold@) over -- @conName@ and its arguments, applying an expression (from @insides@) to each -- of the respective arguments of @conName@. mkSimpleConMatch :: (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> Q Match mkSimpleConMatch fold conName insides = do varsNeeded <- newNameList "_arg" $ length insides let pat = conPCompat conName (map VarP varsNeeded) rhs <- fold conName (zipWith (\i v -> i $ VarE v) insides varsNeeded) return $ Match pat (NormalB rhs) [] -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" -- -- @mkSimpleConMatch2 fold conName insides@ behaves very similarly to -- 'mkSimpleConMatch', with two key differences: -- -- 1. @insides@ is a @[(Bool, Exp)]@ instead of a @[Exp]@. This is because it -- filters out the expressions corresponding to arguments whose types do not -- mention the last type variable in a derived 'Foldable' or 'Traversable' -- instance (i.e., those elements of @insides@ containing @False@). -- -- 2. @fold@ takes an expression as its first argument instead of a -- constructor name. This is because it uses a specialized -- constructor function expression that only takes as many parameters as -- there are argument types that mention the last type variable. mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match mkSimpleConMatch2 fold conName insides = do varsNeeded <- newNameList "_arg" lengthInsides let pat = conPCompat conName (map VarP varsNeeded) -- Make sure to zip BEFORE invoking catMaybes. We want the variable -- indicies in each expression to match up with the argument indices -- in conExpr (defined below). exps = catMaybes $ zipWith (\(m, i) v -> if m then Just (i `AppE` VarE v) else Nothing) insides varsNeeded -- An element of argTysTyVarInfo is True if the constructor argument -- with the same index has a type which mentions the last type -- variable. argTysTyVarInfo = map (\(m, _) -> m) insides (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo varsNeeded conExpQ | null asWithTyVar = appsE (conE conName:map varE asWithoutTyVar) | otherwise = do bs <- newNameList "b" lengthInsides let bs' = filterByList argTysTyVarInfo bs vars = filterByLists argTysTyVarInfo (map varE bs) (map varE varsNeeded) lamE (map varP bs') (appsE (conE conName:vars)) conExp <- conExpQ rhs <- fold conExp exps return $ Match pat (NormalB rhs) [] where lengthInsides = length insides -- Indicates whether a tuple is boxed or unboxed, as well as its number of -- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #) -- corresponds to @Unboxed 3@. data TupleSort = Boxed Int #if MIN_VERSION_template_haskell(2,6,0) | Unboxed Int #endif -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" mkSimpleTupleCase :: (Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp mkSimpleTupleCase matchForCon tupSort insides x = do let tupDataName = case tupSort of Boxed len -> tupleDataName len #if MIN_VERSION_template_haskell(2,6,0) Unboxed len -> unboxedTupleDataName len #endif m <- matchForCon tupDataName insides return $ CaseE x [m] -- Adapt to the type of ConP changing in template-haskell-2.18.0.0. conPCompat :: Name -> [Pat] -> Pat conPCompat n pats = ConP n #if MIN_VERSION_template_haskell(2,18,0) [] #endif pats bifunctors-5.5.15/src/Data/Bifunctor/TH/0000755000000000000000000000000007346545000016064 5ustar0000000000000000bifunctors-5.5.15/src/Data/Bifunctor/TH/Internal.hs0000644000000000000000000004520007346545000020175 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Unsafe #-} #endif {-| Module: Data.Bifunctor.TH.Internal Copyright: (C) 2008-2016 Edward Kmett, (C) 2015-2016 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.Foldable (foldr') import qualified Data.List as List import qualified Data.Map as Map (singleton) import Data.Map (Map) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import Data.Set (Set) import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax -- Ensure, beyond a shadow of a doubt, that the instances are in-scope import Data.Bifunctor () import Data.Bifoldable () import Data.Bitraversable () #ifndef CURRENT_PACKAGE_KEY import Data.Version (showVersion) import Paths_bifunctors (version) #endif ------------------------------------------------------------------------------- -- Expanding type synonyms ------------------------------------------------------------------------------- applySubstitutionKind :: Map Name Kind -> Type -> Type #if MIN_VERSION_template_haskell(2,8,0) applySubstitutionKind = applySubstitution #else applySubstitutionKind _ t = t #endif substNameWithKind :: Name -> Kind -> Type -> Type substNameWithKind n k = applySubstitutionKind (Map.singleton n k) substNamesWithKindStar :: [Name] -> Type -> Type substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns ------------------------------------------------------------------------------- -- 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 #-} ------------------------------------------------------------------------------- -- StarKindStatus ------------------------------------------------------------------------------- -- | Whether a type is not of kind *, is of kind *, or is a kind variable. data StarKindStatus = NotKindStar | KindStar | IsKindVar Name deriving Eq -- | Does a Type have kind * or k (for some kind variable k)? canRealizeKindStar :: Type -> StarKindStatus canRealizeKindStar t | hasKindStar t = KindStar | otherwise = case t of #if MIN_VERSION_template_haskell(2,8,0) SigT _ (VarT k) -> IsKindVar k #endif _ -> NotKindStar -- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists. -- Otherwise, returns 'Nothing'. starKindStatusToName :: StarKindStatus -> Maybe Name starKindStatusToName (IsKindVar n) = Just n starKindStatusToName _ = Nothing -- | Concat together all of the StarKindStatuses that are IsKindVar and extract -- the kind variables' Names out. catKindVarNames :: [StarKindStatus] -> [Name] catKindVarNames = mapMaybe starKindStatusToName ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- -- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed) -- | 'filterByList' takes a list of Bools and a list of some elements and -- filters out these elements for which the corresponding value in the list of -- Bools is False. This function does not check whether the lists have equal -- length. filterByList :: [Bool] -> [a] -> [a] filterByList (True:bs) (x:xs) = x : filterByList bs xs filterByList (False:bs) (_:xs) = filterByList bs xs filterByList _ _ = [] -- | 'filterByLists' takes a list of Bools and two lists as input, and -- outputs a new list consisting of elements from the last two input lists. For -- each Bool in the list, if it is 'True', then it takes an element from the -- former list. If it is 'False', it takes an element from the latter list. -- The elements taken correspond to the index of the Bool in its list. -- For example: -- -- @ -- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" -- @ -- -- This function does not check whether the lists have equal length. filterByLists :: [Bool] -> [a] -> [a] -> [a] filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys filterByLists _ _ _ = [] -- | 'partitionByList' takes a list of Bools and a list of some elements and -- partitions the list according to the list of Bools. Elements corresponding -- to 'True' go to the left; elements corresponding to 'False' go to the right. -- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ -- This function does not check whether the lists have equal -- length. partitionByList :: [Bool] -> [a] -> ([a], [a]) partitionByList = go [] [] where go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs go trues falses _ _ = (reverse trues, reverse falses) -- | Returns True if a Type has kind *. hasKindStar :: Type -> Bool hasKindStar VarT{} = True #if MIN_VERSION_template_haskell(2,8,0) hasKindStar (SigT _ StarT) = True #else hasKindStar (SigT _ StarK) = True #endif hasKindStar _ = False -- Returns True is a kind is equal to *, or if it is a kind variable. isStarOrVar :: Kind -> Bool #if MIN_VERSION_template_haskell(2,8,0) isStarOrVar StarT = True isStarOrVar VarT{} = True #else isStarOrVar StarK = True #endif isStarOrVar _ = False -- | @hasKindVarChain n kind@ Checks if @kind@ is of the form -- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or -- kind variables. hasKindVarChain :: Int -> Type -> Maybe [Name] hasKindVarChain kindArrows t = let uk = uncurryKind (tyKind t) in if (length uk - 1 == kindArrows) && all isStarOrVar uk then Just (freeVariables uk) else Nothing -- | If a Type is a SigT, returns its kind signature. Otherwise, return *. tyKind :: Type -> Kind tyKind (SigT _ k) = k tyKind _ = starK -- | A mapping of type variable Names to their map function Names. For example, in a -- Bifunctor declaration, a TyVarMap might look like (a ~> f, b ~> g), where -- a and b are the last two type variables of the datatype, and f and g are the two -- functions which map their respective type variables. type TyVarMap = Map Name Name thd3 :: (a, b, c) -> c thd3 (_, _, c) = c unsnoc :: [a] -> Maybe ([a], a) unsnoc [] = Nothing unsnoc (x:xs) = case unsnoc xs of Nothing -> Just ([], x) Just (a,b) -> Just (x:a, b) -- | 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] -- | 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 droppedNames -- 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 (`mentionsName` droppedNames) remaining) where droppedNames :: [Name] droppedNames = map varTToName dropped -- | Extract Just the Name from a type variable. If the argument Type is not a -- type variable, return Nothing. varTToName_maybe :: Type -> Maybe Name varTToName_maybe (VarT n) = Just n varTToName_maybe (SigT t _) = varTToName_maybe t varTToName_maybe _ = Nothing -- | Extract the Name from a type variable. If the argument Type is not a -- type variable, throw an error. varTToName :: Type -> Name varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe -- | 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 -- | Detect if a Name in a list of provided Names occurs as an argument to some -- type family. This makes an effort to exclude /oversaturated/ arguments to -- type families. For instance, if one declared the following type family: -- -- @ -- type family F a :: Type -> Type -- @ -- -- Then in the type @F a b@, we would consider @a@ to be an argument to @F@, -- but not @b@. isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool isInTypeFamilyApp names tyFun tyArgs = case tyFun of ConT tcName -> go tcName _ -> return False where go :: Name -> Q Bool go tcName = do info <- reify tcName case info of #if MIN_VERSION_template_haskell(2,11,0) FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ -> withinFirstArgs bndrs #elif MIN_VERSION_template_haskell(2,7,0) FamilyI (FamilyD TypeFam _ bndrs _) _ -> withinFirstArgs bndrs #else TyConI (FamilyD TypeFam _ bndrs _) -> withinFirstArgs bndrs #endif #if MIN_VERSION_template_haskell(2,11,0) FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ -> withinFirstArgs bndrs #elif MIN_VERSION_template_haskell(2,9,0) FamilyI (ClosedTypeFamilyD _ bndrs _ _) _ -> withinFirstArgs bndrs #endif _ -> return False where withinFirstArgs :: [a] -> Q Bool withinFirstArgs bndrs = let firstArgs = take (length bndrs) tyArgs argFVs = freeVariables firstArgs in return $ any (`elem` argFVs) names -- | 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 Names in the list? mentionsName :: Type -> [Name] -> Bool mentionsName = go where go :: Type -> [Name] -> Bool go (AppT t1 t2) names = go t1 names || go t2 names go (SigT t _k) names = go t names #if MIN_VERSION_template_haskell(2,8,0) || go _k names #endif go (VarT n) names = n `elem` names go _ _ = False -- | Does an instance predicate mention any of the Names in the list? predMentionsName :: Pred -> [Name] -> Bool #if MIN_VERSION_template_haskell(2,10,0) predMentionsName = mentionsName #else predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names #endif -- | Construct a type via curried application. applyTy :: Type -> [Type] -> Type applyTy = List.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, [Type]) unapplyTy ty = go ty ty [] where go :: Type -> Type -> [Type] -> (Type, [Type]) go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args) go origTy (SigT ty' _) args = go origTy ty' args #if MIN_VERSION_template_haskell(2,11,0) go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args go origTy (ParensT ty') args = go origTy ty' args #endif go origTy _ args = (origTy, args) -- | Split a type signature by the arrows on its spine. For example, this: -- -- @ -- forall a b. (a ~ b) => (a -> b) -> Char -> () -- @ -- -- would split to this: -- -- @ -- (a ~ b, [a -> b, Char, ()]) -- @ uncurryTy :: Type -> (Cxt, [Type]) uncurryTy (AppT (AppT ArrowT t1) t2) = let (ctxt, tys) = uncurryTy t2 in (ctxt, t1:tys) uncurryTy (SigT t _) = uncurryTy t uncurryTy (ForallT _ ctxt t) = let (ctxt', tys) = uncurryTy t in (ctxt ++ ctxt', tys) uncurryTy t = ([], [t]) -- | Like uncurryType, except on a kind level. uncurryKind :: Kind -> [Kind] #if MIN_VERSION_template_haskell(2,8,0) uncurryKind = snd . uncurryTy #else uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2 uncurryKind k = [k] #endif ------------------------------------------------------------------------------- -- 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 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" coerceValName :: Name coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce" bitraverseConstValName :: Name bitraverseConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bitraverseConst" 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" 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" seqValName :: Name seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq" 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" "<*>" liftA2ValName :: Name liftA2ValName = mkNameG_v "base" "GHC.Base" "liftA2" 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" "<*>" liftA2ValName :: Name liftA2ValName = mkNameG_v "base" "Control.Applicative" "liftA2" mappendValName :: Name mappendValName = mkNameG_v "base" "Data.Monoid" "mappend" memptyValName :: Name memptyValName = mkNameG_v "base" "Data.Monoid" "mempty" #endif #if MIN_VERSION_base(4,10,0) bifoldableTypeName :: Name bifoldableTypeName = mkNameG_tc "base" "Data.Bifoldable" "Bifoldable" bitraversableTypeName :: Name bitraversableTypeName = mkNameG_tc "base" "Data.Bitraversable" "Bitraversable" bifoldrValName :: Name bifoldrValName = mkNameG_v "base" "Data.Bifoldable" "bifoldr" bifoldMapValName :: Name bifoldMapValName = mkNameG_v "base" "Data.Bifoldable" "bifoldMap" bitraverseValName :: Name bitraverseValName = mkNameG_v "base" "Data.Bitraversable" "bitraverse" #else 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" #endif #if MIN_VERSION_base(4,11,0) appEndoValName :: Name appEndoValName = mkNameG_v "base" "Data.Semigroup.Internal" "appEndo" dualDataName :: Name dualDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Dual" endoDataName :: Name endoDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Endo" getDualValName :: Name getDualValName = mkNameG_v "base" "Data.Semigroup.Internal" "getDual" #else appEndoValName :: Name appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo" dualDataName :: Name dualDataName = mkNameG_d "base" "Data.Monoid" "Dual" endoDataName :: Name endoDataName = mkNameG_d "base" "Data.Monoid" "Endo" getDualValName :: Name getDualValName = mkNameG_v "base" "Data.Monoid" "getDual" #endif bifunctors-5.5.15/src/Data/Bifunctor/Tannen.hs0000644000000000000000000001512007346545000017327 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} #endif #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #include "bifunctors-common.h" ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Bifunctor.Tannen ( Tannen(..) ) where import Control.Applicative import Control.Arrow as A import Control.Category import Control.Comonad import Data.Bifunctor as B import Data.Bifunctor.Functor import Data.Biapplicative import Data.Bifoldable import Data.Bitraversable #if __GLASGOW_HASKELL__ < 710 import Data.Foldable import Data.Monoid import Data.Traversable #endif #if __GLASGOW_HASKELL__ >= 708 import Data.Typeable #endif #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics #endif #if LIFTED_FUNCTOR_CLASSES import Data.Functor.Classes #endif import Prelude hiding ((.),id) -- | Compose a 'Functor' on the outside of a 'Bifunctor'. newtype Tannen f p a b = Tannen { runTannen :: f (p a b) } deriving ( Eq, Ord, Show, Read #if __GLASGOW_HASKELL__ >= 702 , Generic #endif #if __GLASGOW_HASKELL__ >= 708 , Typeable #endif ) #if __GLASGOW_HASKELL__ >= 702 # if __GLASGOW_HASKELL__ >= 708 deriving instance Functor f => Generic1 (Tannen f p a) # else data TannenMetaData data TannenMetaCons data TannenMetaSel instance Datatype TannenMetaData where datatypeName _ = "Tannen" moduleName _ = "Data.Bifunctor.Tannen" instance Constructor TannenMetaCons where conName _ = "Tannen" conIsRecord _ = True instance Selector TannenMetaSel where selName _ = "runTannen" instance Functor f => Generic1 (Tannen f p a) where type Rep1 (Tannen f p a) = D1 TannenMetaData (C1 TannenMetaCons (S1 TannenMetaSel (f :.: Rec1 (p a)))) from1 = M1 . M1 . M1 . Comp1 . fmap Rec1 . runTannen to1 = Tannen . fmap unRec1 . unComp1 . unM1 . unM1 . unM1 # endif #endif #if LIFTED_FUNCTOR_CLASSES instance (Eq1 f, Eq2 p, Eq a) => Eq1 (Tannen f p a) where liftEq = liftEq2 (==) instance (Eq1 f, Eq2 p) => Eq2 (Tannen f p) where liftEq2 f g (Tannen x) (Tannen y) = liftEq (liftEq2 f g) x y instance (Ord1 f, Ord2 p, Ord a) => Ord1 (Tannen f p a) where liftCompare = liftCompare2 compare instance (Ord1 f, Ord2 p) => Ord2 (Tannen f p) where liftCompare2 f g (Tannen x) (Tannen y) = liftCompare (liftCompare2 f g) x y instance (Read1 f, Read2 p, Read a) => Read1 (Tannen f p a) where liftReadsPrec = liftReadsPrec2 readsPrec readList instance (Read1 f, Read2 p) => Read2 (Tannen f p) where liftReadsPrec2 rp1 rl1 rp2 rl2 p = readParen (p > 10) $ \s0 -> do ("Tannen", s1) <- lex s0 ("{", s2) <- lex s1 ("runTannen", s3) <- lex s2 (x, s4) <- liftReadsPrec (liftReadsPrec2 rp1 rl1 rp2 rl2) (liftReadList2 rp1 rl1 rp2 rl2) 0 s3 ("}", s5) <- lex s4 return (Tannen x, s5) instance (Show1 f, Show2 p, Show a) => Show1 (Tannen f p a) where liftShowsPrec = liftShowsPrec2 showsPrec showList instance (Show1 f, Show2 p) => Show2 (Tannen f p) where liftShowsPrec2 sp1 sl1 sp2 sl2 p (Tannen x) = showParen (p > 10) $ showString "Tannen {runTannen = " . liftShowsPrec (liftShowsPrec2 sp1 sl1 sp2 sl2) (liftShowList2 sp1 sl1 sp2 sl2) 0 x . showChar '}' #endif instance Functor f => BifunctorFunctor (Tannen f) where bifmap f (Tannen fp) = Tannen (fmap f fp) instance (Functor f, Monad f) => BifunctorMonad (Tannen f) where bireturn = Tannen . return bibind f (Tannen fp) = Tannen $ fp >>= runTannen . f instance Comonad f => BifunctorComonad (Tannen f) where biextract = extract . runTannen biextend f (Tannen fp) = Tannen (extend (f . Tannen) fp) instance (Functor f, Bifunctor p) => Bifunctor (Tannen f p) where first f = Tannen . fmap (B.first f) . runTannen {-# INLINE first #-} second f = Tannen . fmap (B.second f) . runTannen {-# INLINE second #-} bimap f g = Tannen . fmap (bimap f g) . runTannen {-# INLINE bimap #-} instance (Functor f, Bifunctor p) => Functor (Tannen f p a) where fmap f = Tannen . fmap (B.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 #-} instance (Applicative f, Category p) => Category (Tannen f p) where id = Tannen $ pure id Tannen fpbc . Tannen fpab = Tannen $ liftA2 (.) fpbc fpab instance (Applicative f, Arrow p) => Arrow (Tannen f p) where arr f = Tannen $ pure $ arr f first = Tannen . fmap A.first . runTannen second = Tannen . fmap A.second . runTannen Tannen ab *** Tannen cd = Tannen $ liftA2 (***) ab cd Tannen ab &&& Tannen ac = Tannen $ liftA2 (&&&) ab ac instance (Applicative f, ArrowChoice p) => ArrowChoice (Tannen f p) where left = Tannen . fmap left . runTannen right = Tannen . fmap right . runTannen Tannen ab +++ Tannen cd = Tannen $ liftA2 (+++) ab cd Tannen ac ||| Tannen bc = Tannen $ liftA2 (|||) ac bc instance (Applicative f, ArrowLoop p) => ArrowLoop (Tannen f p) where loop = Tannen . fmap loop . runTannen instance (Applicative f, ArrowZero p) => ArrowZero (Tannen f p) where zeroArrow = Tannen $ pure zeroArrow instance (Applicative f, ArrowPlus p) => ArrowPlus (Tannen f p) where Tannen f <+> Tannen g = Tannen (liftA2 (<+>) f g) bifunctors-5.5.15/src/Data/Bifunctor/Wrapped.hs0000644000000000000000000001164307346545000017514 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} #endif #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #include "bifunctors-common.h" ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2008-2016 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 #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics #endif #if LIFTED_FUNCTOR_CLASSES import Data.Functor.Classes #endif -- | Make a 'Functor' over the second argument of a 'Bifunctor'. newtype WrappedBifunctor p a b = WrapBifunctor { unwrapBifunctor :: p a b } deriving ( Eq, Ord, Show, Read #if __GLASGOW_HASKELL__ >= 702 , Generic #endif #if __GLASGOW_HASKELL__ >= 708 , Generic1 , Typeable #endif ) #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 data WrappedBifunctorMetaData data WrappedBifunctorMetaCons data WrappedBifunctorMetaSel instance Datatype WrappedBifunctorMetaData where datatypeName = const "WrappedBifunctor" moduleName = const "Data.Bifunctor.Wrapped" instance Constructor WrappedBifunctorMetaCons where conName = const "WrapBifunctor" conIsRecord = const True instance Selector WrappedBifunctorMetaSel where selName = const "unwrapBifunctor" instance Generic1 (WrappedBifunctor p a) where type Rep1 (WrappedBifunctor p a) = D1 WrappedBifunctorMetaData (C1 WrappedBifunctorMetaCons (S1 WrappedBifunctorMetaSel (Rec1 (p a)))) from1 = M1 . M1 . M1 . Rec1 . unwrapBifunctor to1 = WrapBifunctor . unRec1 . unM1 . unM1 . unM1 #endif #if LIFTED_FUNCTOR_CLASSES instance (Eq2 p, Eq a) => Eq1 (WrappedBifunctor p a) where liftEq = liftEq2 (==) instance Eq2 p => Eq2 (WrappedBifunctor p) where liftEq2 f g (WrapBifunctor x) (WrapBifunctor y) = liftEq2 f g x y instance (Ord2 p, Ord a) => Ord1 (WrappedBifunctor p a) where liftCompare = liftCompare2 compare instance Ord2 p => Ord2 (WrappedBifunctor p) where liftCompare2 f g (WrapBifunctor x) (WrapBifunctor y) = liftCompare2 f g x y instance (Read2 p, Read a) => Read1 (WrappedBifunctor p a) where liftReadsPrec = liftReadsPrec2 readsPrec readList instance Read2 p => Read2 (WrappedBifunctor p) where liftReadsPrec2 rp1 rl1 rp2 rl2 p = readParen (p > 10) $ \s0 -> do ("WrapBifunctor", s1) <- lex s0 ("{", s2) <- lex s1 ("unwrapBifunctor", s3) <- lex s2 (x, s4) <- liftReadsPrec2 rp1 rl1 rp2 rl2 0 s3 ("}", s5) <- lex s4 return (WrapBifunctor x, s5) instance (Show2 p, Show a) => Show1 (WrappedBifunctor p a) where liftShowsPrec = liftShowsPrec2 showsPrec showList instance Show2 p => Show2 (WrappedBifunctor p) where liftShowsPrec2 sp1 sl1 sp2 sl2 p (WrapBifunctor x) = showParen (p > 10) $ showString "WrapBifunctor {unwrapBifunctor = " . liftShowsPrec2 sp1 sl1 sp2 sl2 0 x . showChar '}' #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.5.15/tests/0000755000000000000000000000000007346545000013320 5ustar0000000000000000bifunctors-5.5.15/tests/BifunctorSpec.hs0000644000000000000000000004676507346545000016444 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE EmptyCase #-} {-# LANGUAGE RoleAnnotations #-} #endif {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -fno-warn-unused-foralls #-} #endif {-| 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, Show1) import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..)) import Data.Monoid import GHC.Exts (Int#) 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 -- Plain data types 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 deriving (Functor, Foldable, Traversable) 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 deriving Functor data StrangeGADT a b where T10 :: Ord d => d -> StrangeGADT c d T11 :: Int -> StrangeGADT e Int T12 :: c ~ Int => c -> StrangeGADT f Int T13 :: i ~ Int => Int -> StrangeGADT h i T14 :: k ~ Int => k -> StrangeGADT j k T15 :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADT m n instance Foldable (StrangeGADT a) where foldMap f (T10 x) = f x foldMap f (T11 _) = mempty foldMap f (T12 _) = mempty foldMap f (T13 _) = mempty foldMap f (T14 x) = f x foldMap f (T15 _ _) = mempty data NotPrimitivelyRecursive a b = S1 (NotPrimitivelyRecursive (a,a) (b, a)) | S2 a | S3 b deriving (Functor, Foldable, Traversable) newtype OneTwoCompose f g a b = OneTwoCompose (f (g a b)) deriving (Arbitrary, Eq, Foldable, Functor, Show, Traversable) newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g a,a,b)) instance (Bifunctor (f Int), Functor g) => Functor (ComplexConstraint f g a) where fmap f (ComplexConstraint x) = ComplexConstraint (bimap id (\(ga,a,b) -> (ga,a,f b)) x) instance (Bifoldable (f Int), Foldable g) => Foldable (ComplexConstraint f g a) where foldMap f (ComplexConstraint x) = bifoldMap (const mempty) (\(_,_,b) -> f b) x instance (Bitraversable (f Int), Traversable g) => Traversable (ComplexConstraint f g a) where traverse f (ComplexConstraint x) = ComplexConstraint `fmap` bitraverse pure (\(ga,a,b) -> (ga,a,) `fmap` f b) x 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) instance Functor (Universal a) where fmap f (Universal x) = Universal x fmap f (Universal2 x) = Universal2 (bimap id f x) fmap f (Universal3 x) = Universal3 x fmap f (NotReallyUniversal x) = NotReallyUniversal x data Existential a b = forall a. ExistentialList [a] | forall f. Bitraversable f => ExistentialFunctor (f a b) | forall b. SneakyUseSameName (Maybe b) instance Functor (Existential a) where fmap f (ExistentialList x) = ExistentialList x fmap f (ExistentialFunctor x) = ExistentialFunctor (bimap id f x) fmap f (SneakyUseSameName x) = SneakyUseSameName x instance Foldable (Existential a) where foldMap f (ExistentialList _) = mempty foldMap f (ExistentialFunctor x) = bifoldMap (const mempty) f x foldMap f (SneakyUseSameName _) = mempty instance Traversable (Existential a) where traverse f (ExistentialList x) = pure $ ExistentialList x traverse f (ExistentialFunctor x) = ExistentialFunctor `fmap` bitraverse pure f x traverse f (SneakyUseSameName x) = pure $ SneakyUseSameName x data IntHash a b = IntHash Int# Int# | IntHashTuple Int# a b (a, b, Int, IntHash Int (a, b, Int)) deriving (Functor, Foldable) instance Traversable (IntHash a) where traverse f (IntHash x y) = pure (IntHash x y) traverse f (IntHashTuple x y z (a,b,c,d)) = (\z' b' d' -> IntHashTuple x y z' (a,b',c,d')) `fmap` f z <*> f b <*> traverse (\(m,n,o) -> fmap (\n' -> (m,n',o)) (f n)) d data IntHashFun a b = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a) deriving Functor data Empty1 a b deriving (Functor, Foldable, Traversable) data Empty2 a b deriving (Functor, Foldable, Traversable) #if __GLASGOW_HASKELL__ >= 708 type role Empty2 nominal nominal #endif data TyCon81 a b = TyCon81a (forall c. c -> (forall d. a -> d) -> a) | TyCon81b (Int -> forall c. c -> b) instance Functor (TyCon81 a) where fmap f (TyCon81a g) = TyCon81a g fmap f (TyCon81b g) = TyCon81b (\x y -> f (g x y)) type family F :: * -> * -> * type instance F = Either data TyCon82 a b = TyCon82 (F a b) deriving (Functor, Foldable, Traversable) -- Data families data family StrangeFam x y z data instance StrangeFam a b c = T1Fam a b c | T2Fam [a] [b] [c] -- lists | T3Fam [[a]] [[b]] [[c]] -- nested lists | T4Fam (c,(b,b),(c,c)) -- tuples | T5Fam ([c],Strange a b c) -- tycons #if __GLASGOW_HASKELL__ >= 708 -- Unfortunately, pre-7.8 versions of GHC suffer from a bug that prevents -- deriving Functor for data family instances. We could write all of the -- derived instances by hand, but that amount of boilerplate makes me -- nauseous. Instead, I elect to guard the derived instances with CPP. deriving (Functor, Foldable, Traversable) #endif data family StrangeFunctionsFam x y z data instance StrangeFunctionsFam a b c = T6Fam (a -> c) -- function types | T7Fam (a -> (c,a)) -- functions and tuples | T8Fam ((b -> a) -> c) -- continuation | T9Fam (IntFun b c) -- type synonyms #if __GLASGOW_HASKELL__ >= 708 deriving Functor #endif data family StrangeGADTFam x y data instance StrangeGADTFam a b where T10Fam :: Ord d => d -> StrangeGADTFam c d T11Fam :: Int -> StrangeGADTFam e Int T12Fam :: c ~ Int => c -> StrangeGADTFam f Int T13Fam :: i ~ Int => Int -> StrangeGADTFam h i T14Fam :: k ~ Int => k -> StrangeGADTFam j k T15Fam :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADTFam m n instance Foldable (StrangeGADTFam a) where foldMap f (T10Fam x) = f x foldMap f (T11Fam _) = mempty foldMap f (T12Fam _) = mempty foldMap f (T13Fam _) = mempty foldMap f (T14Fam x) = f x foldMap f (T15Fam _ _) = mempty data family NotPrimitivelyRecursiveFam x y data instance NotPrimitivelyRecursiveFam a b = S1Fam (NotPrimitivelyRecursive (a,a) (b, a)) | S2Fam a | S3Fam b #if __GLASGOW_HASKELL__ >= 708 deriving (Functor, Foldable, Traversable) #endif data family OneTwoComposeFam (j :: * -> *) (k :: * -> * -> *) x y newtype instance OneTwoComposeFam f g a b = OneTwoComposeFam (f (g a b)) deriving ( Arbitrary, Eq, Show #if __GLASGOW_HASKELL__ >= 708 , Functor, Foldable, Traversable #endif ) data family ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b)) instance (Bifunctor (f Int), Functor g) => Functor (ComplexConstraintFam f g a) where fmap f (ComplexConstraintFam x) = ComplexConstraintFam (bimap id (\(ga,a,b) -> (ga,a,f b)) x) instance (Bifoldable (f Int), Foldable g) => Foldable (ComplexConstraintFam f g a) where foldMap f (ComplexConstraintFam x) = bifoldMap (const mempty) (\(_,_,b) -> f b) x instance (Bitraversable (f Int), Traversable g) => Traversable (ComplexConstraintFam f g a) where traverse f (ComplexConstraintFam x) = ComplexConstraintFam `fmap` bitraverse pure (\(ga,a,b) -> (ga,a,) `fmap` f b) x data family UniversalFam x y data instance UniversalFam a b = UniversalFam (forall b. (b,[a])) | Universal2Fam (forall f. Bifunctor f => f a b) | Universal3Fam (forall a. Maybe a) -- reuse a | NotReallyUniversalFam (forall b. a) instance Functor (UniversalFam a) where fmap f (UniversalFam x) = UniversalFam x fmap f (Universal2Fam x) = Universal2Fam (bimap id f x) fmap f (Universal3Fam x) = Universal3Fam x fmap f (NotReallyUniversalFam x) = NotReallyUniversalFam x data family ExistentialFam x y data instance ExistentialFam a b = forall a. ExistentialListFam [a] | forall f. Bitraversable f => ExistentialFunctorFam (f a b) | forall b. SneakyUseSameNameFam (Maybe b) instance Functor (ExistentialFam a) where fmap f (ExistentialListFam x) = ExistentialListFam x fmap f (ExistentialFunctorFam x) = ExistentialFunctorFam (bimap id f x) fmap f (SneakyUseSameNameFam x) = SneakyUseSameNameFam x instance Foldable (ExistentialFam a) where foldMap f (ExistentialListFam _) = mempty foldMap f (ExistentialFunctorFam x) = bifoldMap (const mempty) f x foldMap f (SneakyUseSameNameFam _) = mempty instance Traversable (ExistentialFam a) where traverse f (ExistentialListFam x) = pure $ ExistentialListFam x traverse f (ExistentialFunctorFam x) = ExistentialFunctorFam `fmap` bitraverse pure f x traverse f (SneakyUseSameNameFam x) = pure $ SneakyUseSameNameFam x data family IntHashFam x y data instance IntHashFam a b = IntHashFam Int# Int# | IntHashTupleFam Int# a b (a, b, Int, IntHashFam Int (a, b, Int)) #if __GLASGOW_HASKELL__ >= 708 deriving (Functor, Foldable) -- Old versions of GHC are unable to derive Traversable instances for data types -- with fields of unlifted types, so write this one by hand. instance Traversable (IntHashFam a) where traverse f (IntHashFam x y) = pure (IntHashFam x y) traverse f (IntHashTupleFam x y z (a,b,c,d)) = (\z' b' d' -> IntHashTupleFam x y z' (a,b',c,d')) `fmap` f z <*> f b <*> traverse (\(m,n,o) -> fmap (\n' -> (m,n',o)) (f n)) d #endif data family IntHashFunFam x y data instance IntHashFunFam a b = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a) #if __GLASGOW_HASKELL__ >= 708 deriving Functor #endif data family TyFamily81 x y data instance TyFamily81 a b = TyFamily81a (forall c. c -> (forall d. a -> d) -> a) | TyFamily81b (Int -> forall c. c -> b) instance Functor (TyFamily81 a) where fmap f (TyFamily81a g) = TyFamily81a g fmap f (TyFamily81b g) = TyFamily81b (\x y -> f (g x y)) data family TyFamily82 x y data instance TyFamily82 a b = TyFamily82 (F a b) #if __GLASGOW_HASKELL__ >= 708 deriving (Functor, Foldable, Traversable) #endif ------------------------------------------------------------------------------- -- Plain data types $(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) bifoldlComplexConstraint :: (Bifoldable (f Int), Foldable g) => (c -> a -> c) -> (c -> b -> c) -> c -> ComplexConstraint f g a b -> c bifoldlComplexConstraint = $(makeBifoldl ''ComplexConstraint) bifoldComplexConstraint :: (Bifoldable (f Int), Foldable g, Monoid m) => ComplexConstraint f g m m -> m bifoldComplexConstraint = $(makeBifold ''ComplexConstraint) instance (Bitraversable (f Int), Traversable g) => Bitraversable (ComplexConstraint f g) where bitraverse = $(makeBitraverse ''ComplexConstraint) bisequenceAComplexConstraint :: (Bitraversable (f Int), Traversable g, Applicative t) => ComplexConstraint f g (t a) (t b) -> t (ComplexConstraint f g a b) bisequenceAComplexConstraint = $(makeBisequenceA ''ComplexConstraint) $(deriveBifunctor ''Universal) $(deriveBifunctor ''Existential) $(deriveBifoldable ''Existential) $(deriveBitraversable ''Existential) $(deriveBifunctor ''IntHash) $(deriveBifoldable ''IntHash) $(deriveBitraversable ''IntHash) $(deriveBifunctor ''IntHashFun) $(deriveBifunctor ''Empty1) $(deriveBifoldable ''Empty1) $(deriveBitraversable ''Empty1) -- Use EmptyCase here $(deriveBifunctorOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) $(deriveBifoldableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) $(deriveBitraversableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) $(deriveBifunctor ''TyCon81) $(deriveBifunctor ''TyCon82) $(deriveBifoldable ''TyCon82) $(deriveBitraversable ''TyCon82) #if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveBifunctor 'T1Fam) $(deriveBifoldable 'T2Fam) $(deriveBitraversable 'T3Fam) $(deriveBifunctor 'T6Fam) $(deriveBifoldable 'T10Fam) $(deriveBifunctor 'S1Fam) $(deriveBifoldable 'S2Fam) $(deriveBitraversable 'S3Fam) $(deriveBifunctor 'OneTwoComposeFam) $(deriveBifoldable 'OneTwoComposeFam) $(deriveBitraversable 'OneTwoComposeFam) instance (Bifunctor (f Int), Functor g) => Bifunctor (ComplexConstraintFam f g) where bimap = $(makeBimap 'ComplexConstraintFam) instance (Bifoldable (f Int), Foldable g) => Bifoldable (ComplexConstraintFam f g) where bifoldr = $(makeBifoldr 'ComplexConstraintFam) bifoldMap = $(makeBifoldMap 'ComplexConstraintFam) bifoldlComplexConstraintFam :: (Bifoldable (f Int), Foldable g) => (c -> a -> c) -> (c -> b -> c) -> c -> ComplexConstraintFam f g a b -> c bifoldlComplexConstraintFam = $(makeBifoldl 'ComplexConstraintFam) bifoldComplexConstraintFam :: (Bifoldable (f Int), Foldable g, Monoid m) => ComplexConstraintFam f g m m -> m bifoldComplexConstraintFam = $(makeBifold 'ComplexConstraintFam) instance (Bitraversable (f Int), Traversable g) => Bitraversable (ComplexConstraintFam f g) where bitraverse = $(makeBitraverse 'ComplexConstraintFam) bisequenceAComplexConstraintFam :: (Bitraversable (f Int), Traversable g, Applicative t) => ComplexConstraintFam f g (t a) (t b) -> t (ComplexConstraintFam f g a b) bisequenceAComplexConstraintFam = $(makeBisequenceA 'ComplexConstraintFam) $(deriveBifunctor 'UniversalFam) $(deriveBifunctor 'ExistentialListFam) $(deriveBifoldable 'ExistentialFunctorFam) $(deriveBitraversable 'SneakyUseSameNameFam) $(deriveBifunctor 'IntHashFam) $(deriveBifoldable 'IntHashTupleFam) $(deriveBitraversable 'IntHashFam) $(deriveBifunctor 'IntHashFunFam) $(deriveBifunctor 'TyFamily81a) $(deriveBifunctor 'TyFamily82) $(deriveBifoldable 'TyFamily82) $(deriveBitraversable 'TyFamily82) #endif ------------------------------------------------------------------------------- prop_BifunctorLaws :: (Bifunctor p, Eq (p a b), Eq (p c d), Show (p a b), Show (p c d)) => (a -> c) -> (b -> d) -> p a b -> Expectation prop_BifunctorLaws f g x = do bimap id id x `shouldBe` x first id x `shouldBe` x second id x `shouldBe` x bimap f g x `shouldBe` (first f . second g) x prop_BifunctorEx :: (Bifunctor p, Eq (p [Int] [Int]), Show (p [Int] [Int])) => p [Int] [Int] -> Expectation prop_BifunctorEx = prop_BifunctorLaws reverse (++ [42]) prop_BifoldableLaws :: (Eq a, Eq b, Eq z, Show a, Show b, Show z, Monoid a, Monoid b, Bifoldable p) => (a -> b) -> (a -> b) -> (a -> z -> z) -> (a -> z -> z) -> z -> p a a -> Expectation prop_BifoldableLaws f g h i z x = do bifold x `shouldBe` bifoldMap id id x bifoldMap f g x `shouldBe` bifoldr (mappend . f) (mappend . g) mempty x bifoldr h i z x `shouldBe` appEndo (bifoldMap (Endo . h) (Endo . i) x) z prop_BifoldableEx :: Bifoldable p => p [Int] [Int] -> Expectation prop_BifoldableEx = prop_BifoldableLaws reverse (++ [42]) ((+) . length) ((*) . length) 0 prop_BitraversableLaws :: (Applicative f, Applicative g, Bitraversable p, Eq (g (p c c)), Eq (p a b), Eq (p d e), Eq1 f, Show (g (p c c)), Show (p a b), Show (p d e), Show1 f) => (a -> f c) -> (b -> f c) -> (c -> f d) -> (c -> f e) -> (forall x. f x -> g x) -> p a b -> Expectation prop_BitraversableLaws f g h i t x = do bitraverse (t . f) (t . g) x `shouldBe` (t . bitraverse f g) x bitraverse Identity Identity x `shouldBe` Identity x (Compose . fmap (bitraverse h i) . bitraverse f g) x `shouldBe` bitraverse (Compose . fmap h . f) (Compose . fmap i . g) x prop_BitraversableEx :: (Bitraversable p, Eq (p Char Char), Eq (p [Char] [Char]), Eq (p [Int] [Int]), Show (p Char Char), Show (p [Char] [Char]), Show (p [Int] [Int])) => p [Int] [Int] -> Expectation prop_BitraversableEx = prop_BitraversableLaws (replicate 2 . map (chr . abs)) (replicate 4 . map (chr . abs)) (++ "hello") (++ "world") reverse ------------------------------------------------------------------------------- main :: IO () main = hspec spec spec :: Spec spec = do describe "OneTwoCompose Maybe Either [Int] [Int]" $ do prop "satisfies the Bifunctor laws" (prop_BifunctorEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) prop "satisfies the Bifoldable laws" (prop_BifoldableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) prop "satisfies the Bitraversable laws" (prop_BitraversableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) #if MIN_VERSION_template_haskell(2,7,0) describe "OneTwoComposeFam Maybe Either [Int] [Int]" $ do prop "satisfies the Bifunctor laws" (prop_BifunctorEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation) prop "satisfies the Bifoldable laws" (prop_BifoldableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation) prop "satisfies the Bitraversable laws" (prop_BitraversableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation) #endif bifunctors-5.5.15/tests/Spec.hs0000644000000000000000000000005407346545000014545 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} bifunctors-5.5.15/tests/T89Spec.hs0000644000000000000000000000070307346545000015053 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- | A regression test for #89 which ensures that a TH-generated Bifoldable -- instance of a certain shape does not trigger -Wunused-matches warnings. module T89Spec where import Data.Bifunctor.TH import Test.Hspec data X = MkX data Y a b = MkY a b newtype XY a b = XY { getResp :: Either X (Y a b) } $(deriveBifoldable ''Y) $(deriveBifoldable ''XY) main :: IO () main = hspec spec spec :: Spec spec = return ()