├── cabal.project ├── Setup.lhs ├── cabal.haskell-ci ├── tests ├── Spec.hs ├── T89Spec.hs └── BifunctorSpec.hs ├── .reuse └── dep5 ├── .hlint.yaml ├── .gitignore ├── README.markdown ├── src └── Data │ ├── Bifunctor │ ├── Unsafe.hs │ ├── Monoid.hs │ ├── Classes.hs │ ├── Functor.hs │ ├── Fix.hs │ ├── Functor │ │ └── Fix.hs │ ├── Day.hs │ ├── Join.hs │ ├── Reverse.hs │ ├── Flip.hs │ ├── Clown.hs │ ├── Sum.hs │ ├── Joker.hs │ ├── Biff.hs │ ├── Wrapped.hs │ ├── ShowRead.hs │ ├── Biap.hs │ ├── Product.hs │ ├── Tannen.hs │ ├── Yoneda.hs │ └── TH │ │ └── Internal.hs │ ├── Biapplicative │ └── Backwards.hs │ └── Biapplicative.hs ├── .vim.custom ├── LICENSE ├── LICENSES ├── BSD-2-Clause.txt └── Apache-2.0.txt ├── bifunctors.cabal ├── .github └── workflows │ └── haskell-ci.yml └── CHANGELOG.markdown /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | source-repository-package 4 | type: git 5 | location: https://github.com/ekmett/comonad.git 6 | branch: main 7 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | > module Main (main) where 3 | 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | distribution: jammy 2 | no-tests-no-benchmarks: False 3 | unconstrained: False 4 | -- irc-channels: irc.freenode.org#haskell-lens 5 | irc-if-in-origin-repo: True 6 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | 3 | -- | 4 | -- Module: Spec 5 | -- Copyright: (C) 2008-2023 Edward Kmett, (C) 2015 Ryan Scott 6 | -- License: BSD-2-Clause OR Apache-2.0 7 | -- Maintainer: Edward Kmett 8 | -- Portability: Template Haskell 9 | -------------------------------------------------------------------------------- /.reuse/dep5: -------------------------------------------------------------------------------- 1 | Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ 2 | Upstream-Name: bifunctors 3 | Upstream-Contact: Edward Kmett 4 | Source: http://github.com/ekmett/bifunctors 5 | 6 | Files: * 7 | Copyright: 2021-2023 Edward Kmett 8 | License: BSD-2-Clause OR Apache-2.0 9 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: {name: Eta reduce} 2 | - ignore: {name: Move brackets to avoid $} 3 | - ignore: {name: Reduce duplication} 4 | - ignore: {name: Redundant lambda} 5 | - ignore: {name: Use camelCase} 6 | - ignore: {name: Use infix} 7 | - ignore: {name: Use mapAndUnzipM} 8 | - ignore: {name: Use section} 9 | - ignore: {name: Use tuple-section} 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | docs 4 | wiki 5 | TAGS 6 | tags 7 | wip 8 | .DS_Store 9 | .*.swp 10 | .*.swo 11 | *.o 12 | *.hi 13 | *~ 14 | *# 15 | .cabal-sandbox/ 16 | cabal.sandbox.config 17 | .stack-work/ 18 | cabal-dev 19 | *.chi 20 | *.chs.h 21 | *.dyn_o 22 | *.dyn_hi 23 | .hpc 24 | .hsenv 25 | *.prof 26 | *.aux 27 | *.hp 28 | *.eventlog 29 | cabal.project.local 30 | cabal.project.local~ 31 | .HTF/ 32 | .ghc.environment.* 33 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | bifunctors 2 | ========== 3 | 4 | [![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) 5 | 6 | Contact Information 7 | ------------------- 8 | 9 | Contributions and bug reports are welcome! 10 | 11 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 12 | 13 | -Edward Kmett 14 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Unsafe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Unsafe #-} 2 | 3 | -- | 4 | -- Copyright : (C) 2021-2023 Edward Kmett 5 | -- License : BSD-2-Clause OR Apache-2.0 6 | -- Maintainer : Edward Kmett 7 | -- Stability : provisional 8 | -- Portability : portable 9 | 10 | module Data.Bifunctor.Unsafe where 11 | 12 | import Data.Coerce 13 | 14 | (#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c 15 | (#.) _ = coerce 16 | infixr 9 #. 17 | 18 | (.#) :: Coercible a b => (b -> c) -> (a -> b) -> a -> c 19 | (.#) f _ = coerce f 20 | infixl 8 .# 21 | -------------------------------------------------------------------------------- /tests/T89Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | 4 | -- Module: Spec 5 | -- Copyright: (C) 2008-2023 Edward Kmett, (C) 2015 Ryan Scott 6 | -- License: BSD-2-Clause OR Apache-2.0 7 | -- Maintainer: Edward Kmett 8 | -- Portability: Template Haskell 9 | -- 10 | -- A regression test for #89 which ensures that a TH-generated Bifoldable 11 | -- instance of a certain shape does not trigger -Wunused-matches warnings. 12 | 13 | module T89Spec where 14 | 15 | import Data.Bifunctor.TH 16 | import Test.Hspec 17 | 18 | data X = MkX 19 | data Y a b = MkY a b 20 | newtype XY a b = XY { getResp :: Either X (Y a b) } 21 | 22 | $(deriveBifoldable ''Y) 23 | $(deriveBifoldable ''XY) 24 | 25 | main :: IO () 26 | main = hspec spec 27 | 28 | spec :: Spec 29 | spec = return () 30 | -------------------------------------------------------------------------------- /.vim.custom: -------------------------------------------------------------------------------- 1 | " Add the following to your .vimrc to automatically load this on startup 2 | 3 | " if filereadable(".vim.custom") 4 | " so .vim.custom 5 | " endif 6 | 7 | function StripTrailingWhitespace() 8 | let myline=line(".") 9 | let mycolumn = col(".") 10 | silent %s/ *$// 11 | call cursor(myline, mycolumn) 12 | endfunction 13 | 14 | " enable syntax highlighting 15 | syntax on 16 | 17 | " search for the tags file anywhere between here and / 18 | set tags=TAGS;/ 19 | 20 | " highlight tabs and trailing spaces 21 | set listchars=tab:‗‗,trail:‗ 22 | set list 23 | 24 | " f2 runs hasktags 25 | map :exec ":!hasktags -x -c --ignore src" 26 | 27 | " strip trailing whitespace before saving 28 | " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() 29 | 30 | " rebuild hasktags after saving 31 | au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" 32 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Monoid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | {-# LANGUAGE MonoLocalBinds #-} 4 | {-# LANGUAGE QuantifiedConstraints #-} 5 | {-# LANGUAGE Safe #-} 6 | 7 | -- | 8 | -- Copyright : (C) 2008-2023 Edward Kmett 9 | -- License : BSD-2-Clause OR Apache-2.0 10 | -- Maintainer : Edward Kmett 11 | -- Stability : provisional 12 | -- Portability : portable 13 | -- 14 | module Data.Bifunctor.Monoid 15 | ( BifunctorSemigroup 16 | , BifunctorMonoid 17 | ) where 18 | 19 | import Data.Bifunctor.Classes 20 | 21 | class (forall a b. Semigroup (p a b), Bifunctor' p) => BifunctorSemigroup p 22 | instance (forall a b. Semigroup (p a b), Bifunctor' p) => BifunctorSemigroup p 23 | 24 | class (forall a b. Monoid (p a b), Bifunctor' p) => BifunctorMonoid p 25 | instance (forall a b. Monoid (p a b), Bifunctor' p) => BifunctorMonoid p 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2008-2023 Edward Kmett 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 20 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 22 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 23 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 24 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 25 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 26 | POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /LICENSES/BSD-2-Clause.txt: -------------------------------------------------------------------------------- 1 | Copyright 2008-2023 Edward Kmett 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 20 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 22 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 23 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 24 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 25 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 26 | POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Classes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE QuantifiedConstraints #-} 4 | {-# LANGUAGE Safe #-} 5 | 6 | -- | 7 | -- Copyright : (C) 2008-2023 Edward Kmett 8 | -- License : BSD-2-Clause OR Apache-2.0 9 | -- Maintainer : Edward Kmett 10 | -- Stability : provisional 11 | -- Portability : portable 12 | -- 13 | -- @base@ has yet to adopt @QuantifiedConstraints@ for 'Bifunctor', 'Bifoldable' and 'Bitraversable' 14 | -- 15 | -- This change is coming. (Sure it is) 16 | -- 17 | -- These definitions are portable even across versions of base that do not yet have this change applied. 18 | -- 19 | -- When base 4.18 has faded sufficiently far into the past, these will eventually just re-export @base@ 20 | 21 | module Data.Bifunctor.Classes 22 | ( Bifunctor', module Data.Bifunctor 23 | , Bifoldable', module Data.Bifoldable 24 | , Bitraversable', module Data.Bitraversable 25 | ) where 26 | 27 | import Data.Bifunctor hiding (Bifunctor) 28 | import qualified Data.Bifunctor as Base 29 | import Data.Bifoldable hiding (Bifoldable) 30 | import qualified Data.Bifoldable as Base 31 | import Data.Bitraversable hiding (Bitraversable) 32 | import qualified Data.Bitraversable as Base 33 | 34 | class (Base.Bifunctor p, forall a. Functor (p a)) => Bifunctor' p 35 | instance (Base.Bifunctor p, forall a. Functor (p a)) => Bifunctor' p 36 | 37 | class (Base.Bifoldable p, forall a. Foldable (p a)) => Bifoldable' p 38 | instance (Base.Bifoldable p, forall a. Foldable (p a)) => Bifoldable' p 39 | 40 | class (Base.Bitraversable p, forall a. Traversable (p a)) => Bitraversable' p 41 | instance (Base.Bitraversable p, forall a. Traversable (p a)) => Bitraversable' p 42 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE Safe #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE QuantifiedConstraints #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE MonoLocalBinds #-} 10 | 11 | -- | 12 | -- Copyright : (C) 2020-2023 Edward Kmett 13 | -- License : BSD-2-Clause OR Apache-2.0 14 | -- Maintainer : Edward Kmett 15 | -- Stability : provisional 16 | -- Portability : portable 17 | 18 | module Data.Bifunctor.Functor 19 | ( (:->) 20 | , BifunctorFunctor(..) 21 | , BifunctorMonad(..) 22 | , biliftM 23 | , BifunctorComonad(..) 24 | , biliftW 25 | ) where 26 | 27 | #if __GLASGOW_HASKELL__ < 900 28 | import Data.Bifunctor 29 | #endif 30 | import Data.Bifunctor.Classes 31 | 32 | -- | Using parametricity as an approximation of a natural transformation in two arguments. 33 | type (:->) p q = forall a b. p a b -> q a b 34 | infixr 0 :-> 35 | 36 | class (forall a. Functor (f a)) => QFunctor f 37 | instance (forall a. Functor (f a)) => QFunctor f 38 | 39 | class 40 | #if __GLASGOW_HASKELL__ < 900 41 | ( forall p. Bifunctor p => Bifunctor (t p) 42 | , forall p. (Bifunctor p, QFunctor p) => QFunctor (t p) 43 | #else 44 | ( forall p. Bifunctor' p => Bifunctor' (t p) 45 | #endif 46 | ) => BifunctorFunctor t where 47 | -- class (forall p. Bifunctor' p => Bifunctor' (t p)) => BifunctorFunctor t where 48 | bifmap :: (p :-> q) -> t p :-> t q 49 | 50 | class BifunctorFunctor t => BifunctorMonad t where 51 | bireturn :: Bifunctor' p => p :-> t p 52 | bibind :: Bifunctor' q => (p :-> t q) -> t p :-> t q 53 | bibind f = bijoin . bifmap f 54 | bijoin :: Bifunctor' p => t (t p) :-> t p 55 | bijoin = bibind id 56 | {-# MINIMAL bireturn, (bibind | bijoin) #-} 57 | 58 | biliftM :: (BifunctorMonad t, Bifunctor' q) => (p :-> q) -> t p :-> t q 59 | biliftM f = bibind (bireturn . f) 60 | {-# INLINE biliftM #-} 61 | 62 | class BifunctorFunctor t => BifunctorComonad t where 63 | biextract :: Bifunctor' p => t p :-> p 64 | biextend :: Bifunctor' p => (t p :-> q) -> t p :-> t q 65 | biextend f = bifmap f . biduplicate 66 | biduplicate :: Bifunctor' p => t p :-> t (t p) 67 | biduplicate = biextend id 68 | {-# MINIMAL biextract, (biextend | biduplicate) #-} 69 | 70 | biliftW :: (BifunctorComonad t, Bifunctor' p) => (p :-> q) -> t p :-> t q 71 | biliftW f = biextend (f . biextract) 72 | {-# INLINE biliftW #-} 73 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Fix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveLift #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE Trustworthy #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | -- | 12 | -- Copyright : (C) 2008-2023 Edward Kmett 13 | -- License : BSD-2-Clause OR Apache-2.0 14 | -- Maintainer : Edward Kmett 15 | -- Stability : provisional 16 | -- Portability : non-portable 17 | 18 | module Data.Bifunctor.Fix 19 | ( Fix(..) 20 | ) where 21 | 22 | import Data.Biapplicative 23 | import Data.Bifoldable 24 | import Data.Bifunctor 25 | import Data.Bifunctor.ShowRead 26 | import Data.Bitraversable 27 | import Data.Data 28 | import Data.Functor.Classes 29 | import GHC.Generics 30 | import Language.Haskell.TH.Syntax (Lift) 31 | 32 | -- | Greatest fixpoint of a 'Bifunctor' (a 'Functor' over the first argument with zipping). 33 | newtype Fix p a = In { out :: p (Fix p a) a } 34 | deriving (Generic) 35 | 36 | deriving instance Eq (p (Fix p a) a) => Eq (Fix p a) 37 | deriving instance Ord (p (Fix p a) a) => Ord (Fix p a) 38 | deriving instance Lift (p (Fix p a) a) => Lift (Fix p a) 39 | deriving via ShowRead (Fix p a) instance Show (p (Fix p a) a) => Show (Fix p a) 40 | deriving via ShowRead (Fix p a) instance Read (p (Fix p a) a) => Read (Fix p a) 41 | 42 | deriving instance 43 | ( Typeable k, Typeable p, Typeable a 44 | , Data (p (Fix p a) a) 45 | ) => Data (Fix p (a :: k)) 46 | 47 | instance Eq2 p => Eq1 (Fix p) where 48 | liftEq f (In x) (In y) = liftEq2 (liftEq f) f x y 49 | 50 | instance Ord2 p => Ord1 (Fix p) where 51 | liftCompare f (In x) (In y) = liftCompare2 (liftCompare f) f x y 52 | 53 | instance Read2 p => Read1 (Fix p) where 54 | liftReadPrec rp rl = go 55 | where 56 | go = liftReadPrecWhatever $ liftReadPrec2 go (liftReadListPrec rp rl) rp rl 57 | liftReadListPrec = liftReadListPrecDefault 58 | 59 | instance Show2 p => Show1 (Fix p) where 60 | liftShowsPrec sp1 sl1 = go 61 | where 62 | go = liftShowsPrecWhatever (liftShowsPrec2 go (liftShowList sp1 sl1) sp1 sl1) 63 | 64 | instance Bifunctor p => Functor (Fix p) where 65 | fmap f (In p) = In (bimap (fmap f) f p) 66 | {-# INLINE fmap #-} 67 | 68 | instance Biapplicative p => Applicative (Fix p) where 69 | pure a = In (bipure (pure a) a) 70 | {-# INLINE pure #-} 71 | In p <*> In q = In (biliftA2 (<*>) ($) p q) 72 | {-# INLINE (<*>) #-} 73 | 74 | instance Bifoldable p => Foldable (Fix p) where 75 | foldMap f (In p) = bifoldMap (foldMap f) f p 76 | {-# INLINE foldMap #-} 77 | 78 | instance Bitraversable p => Traversable (Fix p) where 79 | traverse f (In p) = In <$> bitraverse (traverse f) f p 80 | {-# INLINE traverse #-} 81 | -------------------------------------------------------------------------------- /bifunctors.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: bifunctors 3 | category: Data, Functors 4 | version: 6 5 | license: BSD-2-Clause OR Apache-2.0 6 | license-file: LICENSE 7 | author: Edward A. Kmett 8 | maintainer: Edward A. Kmett 9 | stability: provisional 10 | homepage: http://github.com/ekmett/bifunctors/ 11 | bug-reports: http://github.com/ekmett/bifunctors/issues 12 | copyright: Copyright (C) 2008-2023 Edward A. Kmett 13 | synopsis: Bifunctors 14 | description: Bifunctors. 15 | build-type: Simple 16 | tested-with: GHC == 8.6.5 17 | , GHC == 8.8.4 18 | , GHC == 8.10.7 19 | , GHC == 9.0.2 20 | , GHC == 9.2.8 21 | , GHC == 9.4.8 22 | , GHC == 9.6.6 23 | , GHC == 9.8.4 24 | , GHC == 9.10.1 25 | , GHC == 9.12.1 26 | extra-source-files: 27 | CHANGELOG.markdown 28 | README.markdown 29 | .reuse/dep5 30 | LICENSES/*.txt 31 | 32 | source-repository head 33 | type: git 34 | location: https://github.com/ekmett/bifunctors.git 35 | 36 | library 37 | hs-source-dirs: src 38 | build-depends: 39 | , base >= 4.12 && < 5 40 | , assoc >= 1.1 && < 1.2 41 | , base-orphans >= 0.8.4 && < 1 42 | , comonad ^>= 6 43 | , containers >= 0.6.0.1 && < 0.9 44 | , tagged >= 0.8.6 && < 1 45 | , template-haskell 46 | , th-abstraction >= 0.4.2.0 && < 0.8 47 | , transformers >= 0.5 && < 0.7 48 | 49 | if !impl(ghc >= 9.6) 50 | build-depends: foldable1-classes-compat >= 0.1 && < 0.2 51 | 52 | exposed-modules: 53 | Data.Biapplicative 54 | Data.Biapplicative.Backwards 55 | Data.Bifunctor.Biap 56 | Data.Bifunctor.Biff 57 | Data.Bifunctor.Classes 58 | Data.Bifunctor.Clown 59 | Data.Bifunctor.Day 60 | Data.Bifunctor.Fix 61 | Data.Bifunctor.Flip 62 | Data.Bifunctor.Functor 63 | Data.Bifunctor.Functor.Fix 64 | Data.Bifunctor.Join 65 | Data.Bifunctor.Joker 66 | Data.Bifunctor.Monoid 67 | Data.Bifunctor.Product 68 | Data.Bifunctor.Reverse 69 | Data.Bifunctor.Sum 70 | Data.Bifunctor.Tannen 71 | Data.Bifunctor.TH 72 | Data.Bifunctor.Wrapped 73 | Data.Bifunctor.Yoneda 74 | 75 | other-modules: 76 | Data.Bifunctor.TH.Internal 77 | Data.Bifunctor.Unsafe 78 | Data.Bifunctor.ShowRead 79 | 80 | ghc-options: -Wall 81 | default-language: Haskell2010 82 | 83 | if impl(ghc >= 9.0) 84 | -- these flags may abort compilation with GHC-8.10 85 | -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295 86 | ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode 87 | 88 | test-suite bifunctors-spec 89 | type: exitcode-stdio-1.0 90 | hs-source-dirs: tests 91 | main-is: Spec.hs 92 | other-modules: BifunctorSpec T89Spec 93 | ghc-options: -Wall -Wno-star-is-type 94 | default-language: Haskell2010 95 | build-tool-depends: hspec-discover:hspec-discover >= 1.8 96 | build-depends: 97 | , base 98 | , bifunctors 99 | , hspec >= 1.8 100 | , QuickCheck >= 2 && < 3 101 | , template-haskell 102 | , transformers 103 | -------------------------------------------------------------------------------- /src/Data/Biapplicative/Backwards.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DeriveTraversable #-} 5 | {-# LANGUAGE DerivingVia #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE InstanceSigs #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE Trustworthy #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | 14 | -- | 15 | -- Copyright : (C) 2021-2023 Edward Kmett and David Feuer 16 | -- License : BSD-2-Clause OR Apache-2.0 17 | -- Maintainer : Edward Kmett 18 | -- Stability : provisional 19 | -- Portability : 20 | -- 21 | -- 'Biapplicative's, backwards. 22 | 23 | module Data.Biapplicative.Backwards 24 | ( Backwards (..) 25 | ) where 26 | 27 | import Control.Applicative (Alternative) 28 | import Data.Biapplicative 29 | import Data.Bifunctor.ShowRead 30 | import Data.Coerce 31 | import qualified Data.Bifunctor as Base 32 | import Data.Bifoldable (Bifoldable (..)) 33 | import Data.Bitraversable (Bitraversable (..)) 34 | import GHC.Generics (Generic, Generic1) 35 | import Data.Functor.Classes 36 | import Control.Monad (MonadPlus) 37 | import qualified Control.Monad.Fail as Fail 38 | import Control.Monad.Fix (MonadFix) 39 | import Data.Functor.Contravariant (Contravariant) 40 | import Data.Type.Equality (TestEquality) 41 | import Data.Type.Coercion (TestCoercion) 42 | import Data.Data (Data) 43 | import Language.Haskell.TH.Syntax (Lift) 44 | 45 | -- | An analogue of @"Control.Applicative.Backwards".'Control.Applicative.Backwards.Backwards'@ 46 | -- for bifunctors. The 'Biapplicative' instance performs actions 47 | -- in the reverse order. All other instances are essentially derived ones. 48 | -- 49 | -- @ 50 | -- 'bipure' a b = Backwards ('bipure' a b) 51 | -- 'biliftA2' f g (Backwards m) (Backwards n) = Backwards $ 'biliftA2' ('flip' f) ('flip' g) n m 52 | -- @ 53 | newtype Backwards p a b = Backwards { forwards :: p a b } 54 | deriving stock (Traversable, Generic, Generic1, Data, Lift) 55 | deriving newtype ( Eq, Ord, Functor, Foldable, Base.Bifunctor, Bifoldable 56 | , Semigroup, Monoid, Applicative, Alternative, Monad, MonadFix 57 | , MonadPlus, Fail.MonadFail, Contravariant, TestEquality, TestCoercion 58 | , Eq1, Eq2, Ord1, Ord2 ) 59 | 60 | deriving via ShowRead (Backwards p a b) instance Show (p a b) => Show (Backwards p a b) 61 | 62 | deriving via ShowRead1 (Backwards p a) instance Show1 (p a) => Show1 (Backwards p a) 63 | 64 | deriving via ShowRead2 (Backwards p) instance Show2 p => Show2 (Backwards p) 65 | 66 | -- | Accepts either plain or record syntax. 67 | deriving via ShowRead (Backwards p a b) instance Read (p a b) => Read (Backwards p a b) 68 | 69 | -- | Accepts either plain or record syntax. 70 | deriving via ShowRead1 (Backwards p a) instance Read1 (p a) => Read1 (Backwards p a) 71 | 72 | -- | Accepts either plain or record syntax. 73 | deriving via ShowRead2 (Backwards p) instance Read2 p => Read2 (Backwards p) 74 | 75 | instance Biapplicative p => Biapplicative (Backwards p) where 76 | bipure :: forall a b. a -> b -> Backwards p a b 77 | bipure = coerce (bipure @p @a @b) 78 | 79 | biliftA2 f g (Backwards m) (Backwards n) = Backwards $ biliftA2 (flip f) (flip g) n m 80 | 81 | instance Bitraversable p => Bitraversable (Backwards p) where 82 | bitraverse f g (Backwards m) = Backwards <$> bitraverse f g m 83 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Functor/Fix.hs: -------------------------------------------------------------------------------- 1 | {-# Language CPP #-} 2 | {-# Language PolyKinds #-} 3 | {-# Language DeriveDataTypeable #-} 4 | {-# Language DeriveGeneric #-} 5 | {-# Language DeriveLift #-} 6 | {-# Language DeriveTraversable #-} 7 | {-# Language DerivingVia #-} 8 | {-# Language ScopedTypeVariables #-} 9 | {-# Language StandaloneDeriving #-} 10 | {-# Language InstanceSigs #-} 11 | {-# Language GeneralizedNewtypeDeriving #-} 12 | {-# Language Trustworthy #-} 13 | {-# Language QuantifiedConstraints #-} 14 | {-# Language UndecidableInstances #-} 15 | -- {-# Language UndecidableSuperClasses #-} 16 | 17 | -- | 18 | -- Copyright : (C) 2020-2023 Edward Kmett 19 | -- License : BSD-2-Clause OR Apache-2.0 20 | -- Maintainer : Edward Kmett 21 | -- Stability : provisional 22 | -- Portability : portable 23 | -- 24 | -- Fix points of functors over profunctors 25 | 26 | module Data.Bifunctor.Functor.Fix 27 | ( Fix(..) 28 | ) where 29 | 30 | import Data.Coerce 31 | import Data.Data 32 | import Data.Bifunctor 33 | import Data.Bifunctor.ShowRead 34 | import Data.Bifunctor.Functor 35 | import Data.Functor.Classes 36 | import GHC.Generics 37 | import Data.Type.Equality (TestEquality) 38 | import Data.Type.Coercion (TestCoercion) 39 | import Language.Haskell.TH.Syntax (Lift) 40 | 41 | -- Fix :: ((k1 -> k2 -> *) -> k1 -> k2 -> *) -> k1 -> k2 -> * 42 | newtype Fix f a b = In 43 | { out :: f (Fix f) a b 44 | } 45 | deriving stock (Generic, Generic1) 46 | 47 | deriving newtype instance Functor (f (Fix f) a) => Functor (Fix f a) 48 | deriving newtype instance Foldable (f (Fix f) a) => Foldable (Fix f a) 49 | deriving stock instance Traversable (f (Fix f) a) => Traversable (Fix f a) 50 | deriving stock instance 51 | ( Data (f (Fix f) a b) 52 | , Typeable i 53 | , Typeable j 54 | , Typeable f 55 | , Typeable a 56 | , Typeable b 57 | ) => Data (Fix f (a :: i) (b :: j)) 58 | deriving via ShowRead (Fix f a b) instance Show (f (Fix f) a b) => Show (Fix f a b) 59 | deriving via ShowRead (Fix f a b) instance Read (f (Fix f) a b) => Read (Fix f a b) 60 | deriving via ShowRead1 (Fix f a) instance Show1 (f (Fix f) a) => Show1 (Fix f a) 61 | deriving via ShowRead1 (Fix f a) instance Read1 (f (Fix f) a) => Read1 (Fix f a) 62 | deriving via ShowRead2 (Fix f) instance Show2 (f (Fix f)) => Show2 (Fix f) 63 | deriving via ShowRead2 (Fix f) instance Read2 (f (Fix f)) => Read2 (Fix f) 64 | deriving newtype instance Eq (f (Fix f) a b) => Eq (Fix f a b) 65 | deriving newtype instance Ord (f (Fix f) a b) => Ord (Fix f a b) 66 | deriving newtype instance Eq1 (f (Fix f) a) => Eq1 (Fix f a) 67 | deriving newtype instance Ord1 (f (Fix f) a) => Ord1 (Fix f a) 68 | deriving newtype instance Eq2 (f (Fix f)) => Eq2 (Fix f) 69 | deriving newtype instance Ord2 (f (Fix f)) => Ord2 (Fix f) 70 | deriving newtype instance TestEquality (f (Fix f) a) => TestEquality (Fix f a) 71 | deriving newtype instance TestCoercion (f (Fix f) a) => TestCoercion (Fix f a) 72 | deriving stock instance Lift (f (Fix f) a b) => Lift (Fix f a b) 73 | 74 | -- #if __GLASGOW_HASKELL__ >= 900 75 | instance BifunctorFunctor f => Bifunctor (Fix f) where 76 | -- #else 77 | --instance (BifunctorFunctor f, forall a. Functor (Fix f a)) => Bifunctor (Fix f) where 78 | -- #endif 79 | bimap :: forall a b c d. (a -> b) -> (c -> d) -> Fix f a c -> Fix f b d 80 | bimap = coerce (bimap :: (a -> b) -> (c -> d) -> f (Fix f) a c -> f (Fix f) b d) 81 | first :: forall a b c. (a -> b) -> Fix f a c -> Fix f b c 82 | first = coerce (first :: (a -> b) -> f (Fix f) a c -> f (Fix f) b c) 83 | second :: forall a c d. (c -> d) -> Fix f a c -> Fix f a d 84 | second = coerce (second :: (c -> d) -> f (Fix f) a c -> f (Fix f) a d) 85 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Day.hs: -------------------------------------------------------------------------------- 1 | {-# Language DerivingStrategies #-} 2 | {-# Language GADTs #-} 3 | {-# Language RankNTypes #-} 4 | {-# Language RoleAnnotations #-} 5 | {-# Language Safe #-} 6 | {-# Language TypeOperators #-} 7 | 8 | -- | 9 | -- Copyright : (C) 2020-2023 Edward Kmett 10 | -- License : BSD-2-Clause OR Apache-2.0 11 | -- Maintainer : Edward Kmett 12 | -- Stability : provisional 13 | -- Portability : portable 14 | 15 | module Data.Bifunctor.Day 16 | ( Day(..) 17 | , assoc, unassoc 18 | , lambda, unlambda 19 | , rho, unrho 20 | , trans1, trans2 21 | , swapped 22 | , monday 23 | , oneday 24 | ) where 25 | 26 | import Data.Biapplicative 27 | import Data.Bifunctor 28 | import Data.Bifunctor.Functor 29 | 30 | -- | (,) is the unit of 'Bifunctor' Day convolution 31 | type role Day 32 | representational 33 | representational 34 | representational 35 | representational 36 | data Day p q a b where 37 | Day 38 | :: (a -> c -> x) 39 | -> (b -> d -> y) 40 | -> p a b 41 | -> q c d 42 | -> Day p q x y 43 | 44 | instance Functor (Day p q a) where 45 | fmap = \g (Day f g' p q) -> Day f (\b d -> g (g' b d)) p q 46 | {-# inline fmap #-} 47 | 48 | instance Bifunctor (Day p q) where 49 | bimap = \f g (Day f' g' p q) -> Day 50 | (\a c -> f (f' a c)) 51 | (\b d -> g (g' b d)) 52 | p q 53 | {-# inline bimap #-} 54 | first = \f (Day f' g p q) -> Day 55 | (\a c -> f (f' a c)) g p q 56 | {-# inline first #-} 57 | second = \g (Day f g' p q) -> Day 58 | f (\b d -> g (g' b d)) p q 59 | {-# inline second #-} 60 | 61 | instance Bifunctor p => BifunctorFunctor (Day p) where 62 | bifmap = \h (Day f g p q) -> Day f g p (h q) 63 | {-# inline bifmap #-} 64 | 65 | instance Biapplicative p => BifunctorMonad (Day p) where 66 | bireturn = Day (\_ x -> x) (\_ x -> x) biempty 67 | {-# inline bireturn #-} 68 | bijoin = \(Day f g p (Day h i p' q)) -> 69 | Day 70 | (\(a1,a2) c1 -> f a1 (h a2 c1)) 71 | (\(b1,b2) d1 -> g b1 (i b2 d1)) 72 | (biappend p p') 73 | q 74 | {-# inline bijoin #-} 75 | 76 | assoc :: Day (Day p q) r :-> Day p (Day q r) 77 | assoc = \(Day f g (Day h i p q) r) -> 78 | Day 79 | (\a2 (c1,c) -> f (h a2 c1) c) 80 | (\a2 (c1,c) -> g (i a2 c1) c) 81 | p 82 | (Day (,) (,) q r) 83 | {-# inline assoc #-} 84 | 85 | unassoc :: Day p (Day q r) :-> Day (Day p q) r 86 | unassoc = \(Day f g p (Day h i q r)) -> 87 | Day 88 | (\(a1,a2) c1 -> f a1 (h a2 c1)) 89 | (\(a1,a2) c1 -> g a1 (i a2 c1)) 90 | (Day (,) (,) p q) 91 | r 92 | {-# inline unassoc #-} 93 | 94 | unit :: ((),()) 95 | unit = ((),()) 96 | {-# noinline[1] unit #-} 97 | 98 | lambda :: p :-> Day (,) p 99 | lambda = Day (\_ a -> a) (\_ a -> a) unit 100 | {-# inline lambda #-} 101 | 102 | unlambda :: Bifunctor p => Day (,) p :-> p 103 | unlambda = \(Day f g (a,b) q) -> bimap (f a) (g b) q 104 | {-# inline unlambda #-} 105 | 106 | rho :: p :-> Day p (,) 107 | rho = \p -> Day const const p unit 108 | {-# inline rho #-} 109 | 110 | unrho :: Bifunctor p => Day p (,) :-> p 111 | unrho = \(Day f g p (a,b)) -> bimap (`f` a) (`g` b) p 112 | {-# inline unrho #-} 113 | 114 | swapped :: Day p q :-> Day q p 115 | swapped = \(Day f g p q) -> Day (flip f) (flip g) q p 116 | {-# inline swapped #-} 117 | 118 | trans1 :: (p :-> q) -> Day p r :-> Day q r 119 | trans1 = \phi (Day f g p q) -> Day f g (phi p) q 120 | {-# inline trans1 #-} 121 | 122 | trans2 :: (p :-> q) -> Day r p :-> Day r q 123 | trans2 = \phi (Day f g p q) -> Day f g p (phi q) 124 | {-# inline trans2 #-} 125 | 126 | monday :: Biapplicative p => Day p p :-> p 127 | monday = \(Day f g p q) -> biliftA2 f g p q 128 | {-# inline monday #-} 129 | 130 | oneday :: Biapplicative p => (,) :-> p 131 | oneday = uncurry bipure 132 | {-# inline oneday #-} 133 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Join.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveLift #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE DeriveGeneric #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE InstanceSigs #-} 11 | {-# LANGUAGE Trustworthy #-} 12 | {-# LANGUAGE PolyKinds #-} 13 | 14 | -- | 15 | -- Copyright : (C) 2008-2023 Edward Kmett 16 | -- License : BSD-2-Clause OR Apache-2.0 17 | -- Maintainer : Edward Kmett 18 | -- Stability : provisional 19 | -- Portability : non-portable 20 | 21 | module Data.Bifunctor.Join 22 | ( Join(..) 23 | ) where 24 | 25 | #if !MIN_VERSION_base(4,18,0) 26 | import Control.Applicative (Applicative (liftA2)) 27 | #endif 28 | import Data.Biapplicative 29 | import Data.Bifoldable 30 | import Data.Bifoldable1 (Bifoldable1(..)) 31 | import Data.Bifunctor 32 | import Data.Bifunctor.ShowRead 33 | import Data.Bifunctor.Unsafe 34 | import Data.Bitraversable 35 | import Data.Coerce 36 | import Data.Data 37 | import Data.Foldable1 (Foldable1(..)) 38 | import Data.Functor.Classes 39 | import GHC.Generics 40 | import Language.Haskell.TH.Syntax (Lift) 41 | import Text.Read (Read (..), readListPrecDefault) 42 | 43 | -- | Make a 'Functor' over both arguments of a 'Bifunctor'. 44 | newtype Join p a = Join { runJoin :: p a a } 45 | deriving Generic 46 | 47 | deriving instance Eq (p a a) => Eq (Join p a) 48 | deriving instance Ord (p a a) => Ord (Join p a) 49 | deriving instance 50 | ( Typeable k, Typeable p, Typeable a, Data (p a a) 51 | ) => Data (Join p (a :: k)) 52 | deriving stock instance Lift (p a a) => Lift (Join p a) 53 | 54 | instance Eq2 p => Eq1 (Join p) where 55 | liftEq :: forall a b. (a -> b -> Bool) -> Join p a -> Join p b -> Bool 56 | liftEq f = coerce (liftEq2 f f :: p a a -> p b b -> Bool) 57 | 58 | instance Ord2 p => Ord1 (Join p) where 59 | liftCompare :: forall a b. (a -> b -> Ordering) -> Join p a -> Join p b -> Ordering 60 | liftCompare f = coerce (liftCompare2 f f :: p a a -> p b b -> Ordering) 61 | 62 | instance Read (p a a) => Read (Join p a) where 63 | readPrec = liftReadPrecWhatever readPrec 64 | readListPrec = readListPrecDefault 65 | 66 | instance Read2 p => Read1 (Join p) where 67 | liftReadPrec rp rl = liftReadPrecWhatever $ liftReadPrec2 rp rl rp rl 68 | liftReadListPrec = liftReadListPrecDefault 69 | 70 | instance Show (p a a) => Show (Join p a) where 71 | showsPrec = liftShowsPrecWhatever showsPrec 72 | 73 | instance Show2 p => Show1 (Join p) where 74 | liftShowsPrec sp1 sl1 = liftShowsPrecWhatever $ liftShowsPrec2 sp1 sl1 sp1 sl1 75 | 76 | mapJoin :: (p a a -> p b b) -> Join p a -> Join p b 77 | mapJoin = coerce 78 | 79 | mapJoin2 :: (p a a -> p b b -> p c c) -> Join p a -> Join p b -> Join p c 80 | mapJoin2 = coerce 81 | 82 | instance Bifunctor p => Functor (Join p) where 83 | fmap :: forall a b. (a -> b) -> Join p a -> Join p b 84 | fmap f = mapJoin (bimap f f) 85 | {-# inline fmap #-} 86 | 87 | instance Biapplicative p => Applicative (Join p) where 88 | pure a = Join $ bipure a a 89 | {-# inline pure #-} 90 | liftA2 = \f -> mapJoin2 (biliftA2 f f) 91 | {-# inline liftA2 #-} 92 | (<*>) = mapJoin2 (<<*>>) 93 | {-# inline (<*>) #-} 94 | (*>) = mapJoin2 (*>>) 95 | {-# inline (*>) #-} 96 | (<*) = mapJoin2 (<<*) 97 | {-# inline (<*) #-} 98 | 99 | instance Bifoldable p => Foldable (Join p) where 100 | foldMap f = bifoldMap f f .# runJoin 101 | {-# inline foldMap #-} 102 | 103 | instance Bifoldable1 p => Foldable1 (Join p) where 104 | foldMap1 f (Join a) = bifoldMap1 f f a 105 | {-# INLINE foldMap1 #-} 106 | 107 | instance Bitraversable p => Traversable (Join p) where 108 | traverse f = fmap Join . bitraverse f f .# runJoin 109 | {-# inline traverse #-} 110 | sequenceA = fmap Join . bisequenceA .# runJoin 111 | {-# inline sequenceA #-} 112 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Reverse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveLift #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE Trustworthy #-} 9 | 10 | -- | 11 | -- Copyright : (C) 2021-2023 Edward Kmett and David Feuer 12 | -- License : BSD-2-Clause OR Apache-2.0 13 | -- Maintainer : Edward Kmett 14 | -- Stability : provisional 15 | -- Portability : portable 16 | -- 17 | -- Making bifunctors whose elements are notionally in the 18 | -- reverse order from the original bifunctor. 19 | 20 | module Data.Bifunctor.Reverse 21 | ( Reverse (..) 22 | ) where 23 | 24 | import Control.Applicative (Alternative) 25 | import Data.Biapplicative 26 | import Data.Bifunctor.ShowRead 27 | import qualified Data.Bifunctor as Base 28 | import GHC.Generics (Generic, Generic1) 29 | import qualified Data.Functor.Reverse as FunReverse 30 | import Control.Applicative.Backwards 31 | import Data.Coerce 32 | import Data.Bifoldable (Bifoldable (..)) 33 | import Data.Bitraversable (Bitraversable (..)) 34 | import Data.Semigroup (Dual (..)) 35 | import Data.Functor.Classes 36 | import Control.Monad (MonadPlus) 37 | import qualified Control.Monad.Fail as Fail 38 | import Control.Monad.Fix (MonadFix) 39 | import Data.Functor.Contravariant (Contravariant) 40 | import Data.Type.Equality (TestEquality) 41 | import Data.Type.Coercion (TestCoercion) 42 | import Data.Data (Data) 43 | import Language.Haskell.TH.Syntax (Lift) 44 | 45 | -- | The same bifunctor, but with `Bifoldable`, `Bitraversable`, 46 | -- `Foldable` and `Traversable` instances that process the elements 47 | -- in the reverse order. All other instances are essentially derived 48 | -- ones. 49 | -- 50 | -- @ 51 | -- 'bitraverse' 52 | -- (\c -> do print c; (,) c <$> (readLn :: IO Int)) 53 | -- (\b -> do print b; pure b) 54 | -- (Reverse $ "Data.Bifunctor.Tannen".'Data.Bifunctor.Tannen.Tannen' [Left 'a', Right False, Left 'q']) 55 | -- 56 | -- 'q' -- output 57 | -- 12 -- input 58 | -- False -- output 59 | -- 'a' -- output 60 | -- 13 -- input 61 | -- Reverse ('Data.Bifunctor.Tannen.Tannen' {runTannen = [Left ('a',13),Right False,Left ('q',12)]}) -- output 62 | -- @ 63 | newtype Reverse t a b = Reverse { getReverse :: t a b } 64 | deriving stock (Generic, Generic1, Data, Lift) 65 | deriving Foldable via FunReverse.Reverse (t a) 66 | 67 | deriving newtype ( Functor, Applicative, Monad, Alternative, MonadPlus, MonadFix 68 | , Fail.MonadFail, Contravariant, TestEquality, TestCoercion 69 | , Eq, Eq1, Eq2, Ord, Ord1, Ord2 70 | , Base.Bifunctor, Biapplicative, Semigroup, Monoid ) 71 | 72 | instance Bifoldable t => Bifoldable (Reverse t) where 73 | bifoldMap f g (Reverse t) = getDual $ bifoldMap (coerce f) (coerce g) t 74 | bifoldr c1 c2 n (Reverse t) = bifoldl (flip c1) (flip c2) n t 75 | bifoldl c1 c2 b (Reverse t) = bifoldr (flip c1) (flip c2) b t 76 | -- We can't do anything special for bifold. 77 | 78 | instance Bitraversable t => Bitraversable (Reverse t) where 79 | bitraverse f g (Reverse t) = fmap Reverse . forwards $ bitraverse (coerce f) (coerce g) t 80 | 81 | instance Traversable (t a) => Traversable (Reverse t a) where 82 | traverse f (Reverse t) = fmap Reverse . forwards $ traverse (coerce f) t 83 | 84 | deriving via ShowRead (Reverse p a b) instance Show (p a b) => Show (Reverse p a b) 85 | 86 | deriving via ShowRead1 (Reverse p a) instance Show1 (p a) => Show1 (Reverse p a) 87 | 88 | deriving via ShowRead2 (Reverse p) instance Show2 p => Show2 (Reverse p) 89 | 90 | -- | Accepts either plain or record syntax. 91 | deriving via ShowRead (Reverse p a b) instance Read (p a b) => Read (Reverse p a b) 92 | 93 | -- | Accepts either plain or record syntax. 94 | deriving via ShowRead1 (Reverse p a) instance Read1 (p a) => Read1 (Reverse p a) 95 | 96 | -- | Accepts either plain or record syntax. 97 | deriving via ShowRead2 (Reverse p) instance Read2 p => Read2 (Reverse p) 98 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Flip.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveLift #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE Trustworthy #-} 7 | 8 | -- | 9 | -- Copyright : (C) 2008-2023 Edward Kmett 10 | -- License : BSD-2-Clause OR Apache-2.0 11 | -- Maintainer : Edward Kmett 12 | -- Stability : provisional 13 | -- Portability : portable 14 | 15 | module Data.Bifunctor.Flip 16 | ( Flip(..) 17 | ) where 18 | 19 | import qualified Control.Category as Cat 20 | import Data.Biapplicative 21 | import Data.Bifoldable 22 | import Data.Bifoldable1 (Bifoldable1(..)) 23 | import Data.Bifunctor 24 | import Data.Bifunctor.ShowRead 25 | import Data.Bifunctor.Functor 26 | import Data.Bifunctor.Swap (Swap (..)) 27 | import Data.Bifunctor.Assoc (Assoc (..)) 28 | import Data.Bitraversable 29 | import Data.Data 30 | import Data.Functor.Classes 31 | import GHC.Generics 32 | import Language.Haskell.TH.Syntax (Lift) 33 | import Text.Read (Read (..)) 34 | 35 | -- | Make a 'Bifunctor' flipping the arguments of a 'Bifunctor'. 36 | newtype Flip p a b = Flip { runFlip :: p b a } 37 | deriving ( Eq, Ord 38 | , Generic, Data, Lift 39 | ) 40 | deriving (Show, Read) via ShowRead (Flip p a b) 41 | 42 | instance (Eq2 p, Eq a) => Eq1 (Flip p a) where 43 | liftEq = liftEq2 (==) 44 | instance Eq2 p => Eq2 (Flip p) where 45 | liftEq2 f g (Flip x) (Flip y) = liftEq2 g f x y 46 | 47 | instance (Ord2 p, Ord a) => Ord1 (Flip p a) where 48 | liftCompare = liftCompare2 compare 49 | instance Ord2 p => Ord2 (Flip p) where 50 | liftCompare2 f g (Flip x) (Flip y) = liftCompare2 g f x y 51 | 52 | instance (Read2 p, Read a) => Read1 (Flip p a) where 53 | liftReadPrec = liftReadPrec2 readPrec readListPrec 54 | liftReadListPrec = liftReadListPrecDefault 55 | instance Read2 p => Read2 (Flip p) where 56 | liftReadPrec2 rp1 rl1 rp2 rl2 = 57 | liftReadPrecWhatever (liftReadPrec2 rp2 rl2 rp1 rl1) 58 | liftReadListPrec2 = liftReadListPrec2Default 59 | instance (Show2 p, Show a) => Show1 (Flip p a) where 60 | liftShowsPrec = liftShowsPrec2 showsPrec showList 61 | 62 | instance Show2 p => Show2 (Flip p) where 63 | liftShowsPrec2 sp1 sl1 sp2 sl2 = 64 | liftShowsPrecWhatever $ liftShowsPrec2 sp2 sl2 sp1 sl1 65 | 66 | instance Bifunctor p => Bifunctor (Flip p) where 67 | first f = Flip . second f . runFlip 68 | {-# INLINE first #-} 69 | second f = Flip . first f . runFlip 70 | {-# INLINE second #-} 71 | bimap f g = Flip . bimap g f . runFlip 72 | {-# INLINE bimap #-} 73 | 74 | instance Bifunctor p => Functor (Flip p a) where 75 | fmap f = Flip . first f . runFlip 76 | {-# INLINE fmap #-} 77 | 78 | instance Biapplicative p => Biapplicative (Flip p) where 79 | bipure a b = Flip (bipure b a) 80 | {-# INLINE bipure #-} 81 | 82 | Flip fg <<*>> Flip xy = Flip (fg <<*>> xy) 83 | {-# INLINE (<<*>>) #-} 84 | 85 | biliftA2 f g (Flip xy) (Flip ab) = Flip $ biliftA2 g f xy ab 86 | {-# INLINE biliftA2 #-} 87 | 88 | instance Bifoldable p => Bifoldable (Flip p) where 89 | bifoldMap f g = bifoldMap g f . runFlip 90 | {-# INLINE bifoldMap #-} 91 | 92 | instance Bifoldable1 p => Bifoldable1 (Flip p) where 93 | bifoldMap1 f g = bifoldMap1 g f . runFlip 94 | {-# INLINE bifoldMap1 #-} 95 | 96 | instance Bifoldable p => Foldable (Flip p a) where 97 | foldMap f = bifoldMap f (const mempty) . runFlip 98 | {-# INLINE foldMap #-} 99 | 100 | instance Bitraversable p => Bitraversable (Flip p) where 101 | bitraverse f g = fmap Flip . bitraverse g f . runFlip 102 | {-# INLINE bitraverse #-} 103 | 104 | instance Bitraversable p => Traversable (Flip p a) where 105 | traverse f = fmap Flip . bitraverse f pure . runFlip 106 | {-# INLINE traverse #-} 107 | 108 | instance BifunctorFunctor Flip where 109 | bifmap f (Flip p) = Flip (f p) 110 | {-# INLINE bifmap #-} 111 | 112 | instance Cat.Category c => Cat.Category (Flip c) where 113 | id = Flip Cat.id 114 | {-# INLINE id #-} 115 | Flip x . Flip y = Flip (y Cat.. x) 116 | {-# INLINE (.) #-} 117 | 118 | -- | @since 5.6.1 119 | instance Assoc p => Assoc (Flip p) where 120 | assoc = Flip . first Flip . unassoc . second runFlip . runFlip 121 | unassoc = Flip . second Flip . assoc . first runFlip . runFlip 122 | 123 | -- | @since 5.6.1 124 | instance Swap p => Swap (Flip p) where 125 | swap = Flip . swap . runFlip 126 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Clown.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE Trustworthy #-} 7 | 8 | -- | 9 | -- Copyright : (C) 2008-2021 Edward Kmett 10 | -- License : BSD-2-Clause OR Apache-2.0 11 | -- Maintainer : Edward Kmett 12 | -- Stability : provisional 13 | -- Portability : portable 14 | -- 15 | -- From the Functional Pearl \"Clowns to the Left of me, Jokers to the Right: Dissecting Data Structures\" 16 | -- by Conor McBride. 17 | 18 | module Data.Bifunctor.Clown 19 | ( Clown(..) 20 | ) where 21 | 22 | import Data.Coerce 23 | import Data.Biapplicative 24 | import Data.Bifoldable 25 | import Data.Bifoldable1 (Bifoldable1(..)) 26 | import Data.Bifunctor 27 | import Data.Bifunctor.ShowRead 28 | import Data.Bifunctor.Unsafe 29 | import Data.Bitraversable 30 | import Data.Foldable1 (Foldable1(..)) 31 | import Data.Functor.Contravariant 32 | import Data.Data 33 | import Data.Functor.Classes 34 | import GHC.Generics 35 | import Language.Haskell.TH.Syntax (Lift) 36 | import Text.Read (Read (..), readListPrecDefault) 37 | 38 | -- | Make a 'Functor' over the first argument of a 'Bifunctor'. 39 | -- 40 | -- Mnemonic: C__l__owns to the __l__eft (parameter of the Bifunctor), 41 | -- joke__r__s to the __r__ight. 42 | newtype Clown f a b = Clown { runClown :: f a } 43 | deriving (Eq, Ord, Data, Generic, Generic1, Lift) 44 | 45 | instance Eq (f a) => Eq1 (Clown f a) where 46 | liftEq _eq = eqClown (==) 47 | {-# inline liftEq #-} 48 | 49 | instance Eq1 f => Eq2 (Clown f) where 50 | liftEq2 = \f _ -> eqClown (liftEq f) 51 | {-# inline liftEq2 #-} 52 | 53 | instance Ord (f a) => Ord1 (Clown f a) where 54 | liftCompare _cmp = compareClown compare 55 | {-# inline liftCompare #-} 56 | 57 | instance Ord1 f => Ord2 (Clown f) where 58 | liftCompare2 = \f _ -> compareClown (liftCompare f) 59 | {-# inline liftCompare2 #-} 60 | 61 | instance Read (f a) => Read (Clown f a b) where 62 | readPrec = liftReadPrecWhatever readPrec 63 | readListPrec = readListPrecDefault 64 | 65 | instance Show (f a) => Show (Clown f a b) where 66 | showsPrec = liftShowsPrecWhatever showsPrec 67 | 68 | instance Read (f a) => Read1 (Clown f a) where 69 | liftReadPrec _ _ = liftReadPrecWhatever readPrec 70 | liftReadListPrec = liftReadListPrecDefault 71 | 72 | instance Show (f a) => Show1 (Clown f a) where 73 | liftShowsPrec _ _ = liftShowsPrecWhatever showsPrec 74 | 75 | instance Read1 f => Read2 (Clown f) where 76 | liftReadPrec2 rp rl _ _ = liftReadPrecWhatever (liftReadPrec rp rl) 77 | liftReadListPrec2 = liftReadListPrec2Default 78 | 79 | instance Show1 f => Show2 (Clown f) where 80 | liftShowsPrec2 sp sl _ _ = liftShowsPrecWhatever (liftShowsPrec sp sl) 81 | 82 | eqClown :: (f a1 -> f a2 -> Bool) 83 | -> Clown f a1 b1 -> Clown f a2 b2 -> Bool 84 | eqClown = coerce 85 | 86 | compareClown :: (f a1 -> f a2 -> Ordering) 87 | -> Clown f a1 b1 -> Clown f a2 b2 -> Ordering 88 | compareClown = coerce 89 | 90 | instance Functor f => Bifunctor (Clown f) where 91 | first = \f -> Clown #. fmap f .# runClown 92 | {-# INLINE first #-} 93 | second = \_ -> Clown #. runClown 94 | {-# INLINE second #-} 95 | bimap = \f _ -> Clown #. fmap f .# runClown 96 | {-# INLINE bimap #-} 97 | 98 | instance Functor (Clown f a) where 99 | fmap _ = coerce 100 | {-# inline fmap #-} 101 | 102 | instance Contravariant (Clown f a) where 103 | contramap _ = coerce 104 | {-# inline contramap #-} 105 | 106 | instance Applicative f => Biapplicative (Clown f) where 107 | bipure a _ = Clown (pure a) 108 | {-# INLINE bipure #-} 109 | 110 | (<<*>>) = \mf -> Clown #. (<*>) (runClown mf) .# runClown 111 | {-# INLINE (<<*>>) #-} 112 | 113 | instance Foldable f => Bifoldable (Clown f) where 114 | bifoldMap f _ = foldMap f .# runClown 115 | {-# INLINE bifoldMap #-} 116 | bifoldr c1 _c2 n = foldr c1 n .# runClown 117 | {-# INLINE bifoldr #-} 118 | bifoldl c1 _c2 n = foldl c1 n .# runClown 119 | {-# INLINE bifoldl #-} 120 | 121 | instance Foldable1 f => Bifoldable1 (Clown f) where 122 | bifoldMap1 f _ = foldMap1 f . runClown 123 | {-# INLINE bifoldMap1 #-} 124 | 125 | instance Foldable (Clown f a) where 126 | foldMap _ = mempty 127 | {-# INLINE foldMap #-} 128 | 129 | instance Traversable f => Bitraversable (Clown f) where 130 | bitraverse f _ = fmap Clown . traverse f .# runClown 131 | {-# INLINE bitraverse #-} 132 | 133 | instance Traversable (Clown f a) where 134 | traverse _ = pure .# coerce 135 | {-# INLINE traverse #-} 136 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Sum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE DeriveGeneric #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE Safe #-} 10 | 11 | -- | 12 | -- Copyright : (C) 2020-2023 Edward Kmett 13 | -- License : BSD-2-Clause OR Apache-2.0 14 | -- Maintainer : Edward Kmett 15 | -- Stability : provisional 16 | -- Portability : portable 17 | 18 | module Data.Bifunctor.Sum 19 | ( Sum(..) 20 | ) where 21 | 22 | import Data.Bifunctor 23 | import Data.Bifunctor.Classes 24 | import Data.Bifunctor.Functor 25 | import Data.Bifunctor.Swap (Swap (..)) 26 | import Data.Bifoldable 27 | import Data.Bitraversable 28 | import Data.Data 29 | import Data.Functor.Classes 30 | import GHC.Generics (Generic, Generic1) 31 | import Language.Haskell.TH.Syntax (Lift) 32 | import Text.Read ((+++)) 33 | 34 | data Sum p q a b 35 | = L2 (p a b) 36 | | R2 (q a b) 37 | deriving stock 38 | ( Eq, Ord, Show, Read, Data, Generic, Generic1 39 | , Functor, Foldable, Traversable, Lift ) 40 | 41 | instance (Eq1 (p a), Eq1 (q a)) => Eq1 (Sum p q a) where 42 | liftEq eq (L2 x) (L2 y) = liftEq eq x y 43 | liftEq _ (L2 _) (R2 _) = False 44 | liftEq _ (R2 _) (L2 _) = False 45 | liftEq eq (R2 x) (R2 y) = liftEq eq x y 46 | {-# inline liftEq #-} 47 | 48 | instance (Eq2 f, Eq2 g) => Eq2 (Sum f g) where 49 | liftEq2 f g (L2 x1) (L2 x2) = liftEq2 f g x1 x2 50 | liftEq2 _ _ (L2 _) (R2 _) = False 51 | liftEq2 _ _ (R2 _) (L2 _) = False 52 | liftEq2 f g (R2 y1) (R2 y2) = liftEq2 f g y1 y2 53 | {-# inline liftEq2 #-} 54 | 55 | instance (Ord1 (p a), Ord1 (q a)) => Ord1 (Sum p q a) where 56 | liftCompare cmp (L2 x) (L2 y) = liftCompare cmp x y 57 | liftCompare cmp (R2 x) (R2 y) = liftCompare cmp x y 58 | liftCompare _ (L2 _) (R2 _) = LT 59 | liftCompare _ (R2 _) (L2 _) = GT 60 | {-# inline liftCompare #-} 61 | 62 | instance (Ord2 f, Ord2 g) => Ord2 (Sum f g) where 63 | liftCompare2 f g (L2 x1) (L2 x2) = liftCompare2 f g x1 x2 64 | liftCompare2 _ _ (L2 _) (R2 _) = LT 65 | liftCompare2 _ _ (R2 _) (L2 _) = GT 66 | liftCompare2 f g (R2 y1) (R2 y2) = liftCompare2 f g y1 y2 67 | {-# inline liftCompare2 #-} 68 | 69 | instance (Read1 (f a), Read1 (g a)) => Read1 (Sum f g a) where 70 | liftReadPrec rp rl = readData $ 71 | readUnaryWith (liftReadPrec rp rl) "L2" L2 +++ 72 | readUnaryWith (liftReadPrec rp rl) "R2" R2 73 | 74 | instance (Read2 f, Read2 g) => Read2 (Sum f g) where 75 | liftReadPrec2 rp1 rl1 rp2 rl2 = readData $ 76 | readUnaryWith (liftReadPrec2 rp1 rl1 rp2 rl2) "L2" L2 +++ 77 | readUnaryWith (liftReadPrec2 rp1 rl1 rp2 rl2) "R2" R2 78 | 79 | instance (Show1 (f a), Show1 (g a)) => Show1 (Sum f g a) where 80 | liftShowsPrec sp sl p (L2 x) = 81 | showsUnaryWith (liftShowsPrec sp sl) "L2" p x 82 | liftShowsPrec sp sl p (R2 y) = 83 | showsUnaryWith (liftShowsPrec sp sl) "R2" p y 84 | 85 | instance (Show2 f, Show2 g) => Show2 (Sum f g) where 86 | liftShowsPrec2 sp1 sl1 sp2 sl2 p (L2 x) = 87 | showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "L2" p x 88 | liftShowsPrec2 sp1 sl1 sp2 sl2 p (R2 y) = 89 | showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "R2" p y 90 | 91 | instance (Bifunctor p, Bifunctor q) => Bifunctor (Sum p q) where 92 | bimap = \f g -> \case 93 | L2 p -> L2 (bimap f g p) 94 | R2 q -> R2 (bimap f g q) 95 | {-# inline bimap #-} 96 | first = \f -> \case 97 | L2 p -> L2 (first f p) 98 | R2 q -> R2 (first f q) 99 | {-# inline first #-} 100 | second = \f -> \case 101 | L2 p -> L2 (second f p) 102 | R2 q -> R2 (second f q) 103 | {-# inline second #-} 104 | 105 | instance (Bifoldable p, Bifoldable q) => Bifoldable (Sum p q) where 106 | bifoldMap = \f g -> \case 107 | L2 p -> bifoldMap f g p 108 | R2 q -> bifoldMap f g q 109 | {-# inline bifoldMap #-} 110 | 111 | instance (Bitraversable p, Bitraversable q) => Bitraversable (Sum p q) where 112 | bitraverse = \f g -> \case 113 | L2 p -> L2 <$> bitraverse f g p 114 | R2 q -> R2 <$> bitraverse f g q 115 | {-# inline bitraverse #-} 116 | 117 | instance Bifunctor' p => BifunctorFunctor (Sum p) where 118 | bifmap = \f -> \case 119 | L2 p -> L2 p 120 | R2 q -> R2 (f q) 121 | {-# inline bifmap #-} 122 | 123 | instance Bifunctor' p => BifunctorMonad (Sum p) where 124 | bireturn = R2 125 | {-# inline bireturn #-} 126 | bijoin = \case 127 | L2 p -> L2 p 128 | R2 q -> q 129 | {-# inline bijoin #-} 130 | bibind = \f -> \case 131 | L2 p -> L2 p 132 | R2 q -> f q 133 | {-# inline bibind #-} 134 | 135 | -- | @since 5.6.1 136 | instance (Swap p, Swap q) => Swap (Sum p q) where 137 | swap (L2 p) = L2 (swap p) 138 | swap (R2 q) = R2 (swap q) 139 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Joker.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE DeriveTraversable #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | {-# LANGUAGE DeriveLift #-} 7 | {-# LANGUAGE DerivingVia #-} 8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 9 | {-# LANGUAGE InstanceSigs #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | {-# LANGUAGE Trustworthy #-} 14 | 15 | -- | 16 | -- Copyright : (C) 2008-2023 Edward Kmett 17 | -- License : BSD-2-Clause OR Apache-2.0 18 | -- Maintainer : Edward Kmett 19 | -- Stability : provisional 20 | -- Portability : portable 21 | -- 22 | -- From the Functional Pearl \"Clowns to the Left of me, Jokers to the Right: Dissecting Data Structures\" 23 | -- by Conor McBride. 24 | 25 | module Data.Bifunctor.Joker 26 | ( Joker(..) 27 | ) where 28 | 29 | #if !MIN_VERSION_base(4,18,0) 30 | import Control.Applicative (Applicative (liftA2)) 31 | #endif 32 | import Data.Bifunctor 33 | import Data.Bifunctor.ShowRead 34 | import Data.Bifunctor.Unsafe 35 | import Data.Biapplicative 36 | import Data.Bifoldable 37 | import Data.Bifoldable1 (Bifoldable1(..)) 38 | import Data.Bitraversable 39 | import Data.Coerce 40 | import Data.Data 41 | import Data.Foldable1 (Foldable1(..)) 42 | import Data.Functor.Classes 43 | import Data.Type.Equality (TestEquality) 44 | import Data.Type.Coercion (TestCoercion) 45 | import GHC.Generics 46 | import Language.Haskell.TH.Syntax (Lift) 47 | 48 | -- | Make a 'Functor' over the second argument of a 'Bifunctor'. 49 | -- 50 | -- Mnemonic: C__l__owns to the __l__eft (parameter of the Bifunctor), 51 | -- joke__r__s to the __r__ight. 52 | newtype Joker g a b = Joker { runJoker :: g b } 53 | deriving stock ( Data 54 | , Traversable 55 | , Generic 56 | , Generic1 57 | , Lift 58 | ) 59 | deriving newtype (Eq, Ord, Foldable, Foldable1, TestEquality, TestCoercion) 60 | 61 | instance Eq1 g => Eq1 (Joker g a) where 62 | liftEq = eqJoker #. liftEq 63 | {-# inline liftEq #-} 64 | 65 | instance Eq1 g => Eq2 (Joker g) where 66 | liftEq2 = \_ -> eqJoker #. liftEq 67 | {-# inline liftEq2 #-} 68 | 69 | instance Ord1 g => Ord1 (Joker g a) where 70 | liftCompare = compareJoker #. liftCompare 71 | {-# inline liftCompare #-} 72 | 73 | instance Ord1 g => Ord2 (Joker g) where 74 | liftCompare2 _ = compareJoker #. liftCompare 75 | {-# inline liftCompare2 #-} 76 | 77 | deriving via ShowRead (Joker g a b) instance Show (g b) => Show (Joker g a b) 78 | 79 | deriving via ShowRead1 (Joker g a) instance Show1 g => Show1 (Joker g a) 80 | 81 | -- | Accepts either plain or record syntax. 82 | deriving via ShowRead (Joker g a b) instance Read (g b) => Read (Joker g a b) 83 | 84 | -- | Accepts either plain or record syntax. 85 | deriving via ShowRead1 (Joker g a) instance Read1 g => Read1 (Joker g a) 86 | 87 | instance Read1 g => Read2 (Joker g) where 88 | liftReadPrec2 _ _ rp2 rl2 = liftReadPrecWhatever $ liftReadPrec rp2 rl2 89 | liftReadListPrec2 = liftReadListPrec2Default 90 | 91 | instance Show1 g => Show2 (Joker g) where 92 | liftShowsPrec2 _ _ sp2 sl2 = liftShowsPrecWhatever $ liftShowsPrec sp2 sl2 93 | 94 | eqJoker :: (g b1 -> g b2 -> Bool) 95 | -> Joker g a1 b1 -> Joker g a2 b2 -> Bool 96 | eqJoker = coerce 97 | {-# inline eqJoker #-} 98 | 99 | compareJoker :: (g b1 -> g b2 -> Ordering) 100 | -> Joker g a1 b1 -> Joker g a2 b2 -> Ordering 101 | compareJoker = coerce 102 | {-# inline compareJoker #-} 103 | 104 | instance Functor g => Bifunctor (Joker g) where 105 | first _ = Joker #. runJoker 106 | {-# inline first #-} 107 | second g = Joker #. fmap g .# runJoker 108 | {-# inline second #-} 109 | bimap _ g = Joker #. fmap g .# runJoker 110 | {-# inline bimap #-} 111 | 112 | instance Functor g => Functor (Joker g a) where 113 | fmap g = Joker #. fmap g .# runJoker 114 | {-# inline fmap #-} 115 | 116 | instance Applicative g => Biapplicative (Joker g) where 117 | bipure _ = Joker #. pure 118 | {-# inline bipure #-} 119 | 120 | (<<*>>) :: forall a b c d. Joker g (a -> b) (c -> d) -> Joker g a c -> Joker g b d 121 | (<<*>>) = coerce ((<*>) :: g (c -> d) -> g c -> g d) 122 | {-# inline (<<*>>) #-} 123 | 124 | biliftA2 :: forall a b c d e f. (a -> b -> c) -> (d -> e -> f) -> Joker g a d -> Joker g b e -> Joker g c f 125 | biliftA2 _ = coerce (liftA2 :: (d -> e -> f) -> g d -> g e -> g f) 126 | 127 | instance Foldable g => Bifoldable (Joker g) where 128 | bifoldMap _ g = foldMap g .# runJoker 129 | {-# inline bifoldMap #-} 130 | 131 | bifoldr _c1 c2 n = foldr c2 n .# runJoker 132 | {-# inline bifoldr #-} 133 | 134 | bifoldl _c1 c2 n = foldl c2 n .# runJoker 135 | {-# inline bifoldl #-} 136 | 137 | instance Foldable1 g => Bifoldable1 (Joker g) where 138 | bifoldMap1 _ g = foldMap1 g . runJoker 139 | {-# INLINE bifoldMap1 #-} 140 | 141 | instance Traversable g => Bitraversable (Joker g) where 142 | bitraverse _ g = fmap Joker . traverse g .# runJoker 143 | {-# inline bitraverse #-} 144 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Biff.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DeriveLift #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE DerivingStrategies #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE Trustworthy #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | 14 | -- | 15 | -- Copyright : (C) 2008-2023 Edward Kmett 16 | -- License : BSD-2-Clause OR Apache-2.0 17 | -- Maintainer : Edward Kmett 18 | -- Stability : provisional 19 | -- Portability : portable 20 | 21 | module Data.Bifunctor.Biff 22 | ( Biff(..) 23 | ) where 24 | 25 | #if !MIN_VERSION_base(4,18,0) 26 | import Control.Applicative (Applicative (liftA2)) 27 | #endif 28 | import Data.Biapplicative 29 | import Data.Bifoldable 30 | import Data.Bifoldable1 (Bifoldable1(..)) 31 | import Data.Bifunctor 32 | import Data.Bifunctor.ShowRead 33 | import Data.Bifunctor.Unsafe 34 | import Data.Bifunctor.Swap (Swap (..)) 35 | import Data.Bitraversable 36 | import Data.Data 37 | import Data.Foldable1 (Foldable1(..)) 38 | import Data.Functor.Classes 39 | import GHC.Generics 40 | import Language.Haskell.TH.Syntax (Lift) 41 | import Text.Read (Read (..), readListPrecDefault) 42 | 43 | -- | Compose two 'Functor's on the inside of a 'Bifunctor'. 44 | newtype Biff p f g a b = Biff { runBiff :: p (f a) (g b) } 45 | deriving stock (Eq, Ord, Data, Generic, Lift) 46 | 47 | deriving stock instance Functor (p (f a)) => Generic1 (Biff p f g a) 48 | deriving stock instance (Functor (p (f a)), Functor g) => Functor (Biff p f g a) 49 | deriving stock instance (Foldable (p (f a)), Foldable g) => Foldable (Biff p f g a) 50 | deriving stock instance (Traversable (p (f a)), Traversable g) => Traversable (Biff p f g a) 51 | 52 | instance (Eq1 (p (f a)), Eq1 g) => Eq1 (Biff p f g a) where 53 | liftEq eq (Biff x) (Biff y) = liftEq (liftEq eq) x y 54 | 55 | instance (Eq2 p, Eq1 f, Eq1 g) => Eq2 (Biff p f g) where 56 | liftEq2 f g (Biff x) (Biff y) = liftEq2 (liftEq f) (liftEq g) x y 57 | 58 | instance (Ord1 (p (f a)), Ord1 g) => Ord1 (Biff p f g a) where 59 | liftCompare cmp (Biff x) (Biff y) = liftCompare (liftCompare cmp) x y 60 | 61 | instance (Ord2 p, Ord1 f, Ord1 g) => Ord2 (Biff p f g) where 62 | liftCompare2 f g (Biff x) (Biff y) = liftCompare2 (liftCompare f) (liftCompare g) x y 63 | 64 | instance Show (p (f a) (g b)) => Show (Biff p f g a b) where 65 | showsPrec = liftShowsPrecWhatever showsPrec 66 | 67 | instance Read (p (f a) (g b)) => Read (Biff p f g a b) where 68 | readPrec = liftReadPrecWhatever readPrec 69 | readListPrec = readListPrecDefault 70 | 71 | instance (Show1 (p (f a)), Show1 g) => Show1 (Biff p f g a) where 72 | liftShowsPrec sp sl = liftShowsPrecWhatever $ liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl) 73 | 74 | instance (Read1 (p (f a)), Read1 g) => Read1 (Biff p f g a) where 75 | liftReadPrec rp rl = liftReadPrecWhatever (liftReadPrec (liftReadPrec rp rl) (liftReadListPrec rp rl)) 76 | liftReadListPrec = liftReadListPrecDefault 77 | 78 | instance (Show2 p, Show1 f, Show1 g) => Show2 (Biff p f g) where 79 | liftShowsPrec2 sp1 sl1 sp2 sl2 = liftShowsPrecWhatever $ 80 | liftShowsPrec2 81 | (liftShowsPrec sp1 sl1) (liftShowList sp1 sl1) 82 | (liftShowsPrec sp2 sl2) (liftShowList sp2 sl2) 83 | 84 | instance (Read2 p, Read1 f, Read1 g) => Read2 (Biff p f g) where 85 | liftReadPrec2 rp1 rl1 rp2 rl2 = 86 | liftReadPrecWhatever 87 | (liftReadPrec2 88 | (liftReadPrec rp1 rl1) (liftReadListPrec rp1 rl1) 89 | (liftReadPrec rp2 rl2) (liftReadListPrec rp2 rl2)) 90 | liftReadListPrec2 = liftReadListPrec2Default 91 | 92 | instance (Bifunctor p, Functor f, Functor g) => Bifunctor (Biff p f g) where 93 | first = \f -> Biff #. first (fmap f) .# runBiff 94 | {-# inline first #-} 95 | second = \f -> Biff #. second (fmap f) .# runBiff 96 | {-# inline second #-} 97 | bimap = \f g -> Biff #. bimap (fmap f) (fmap g) .# runBiff 98 | {-# inline bimap #-} 99 | 100 | instance (Biapplicative p, Applicative f, Applicative g) => Biapplicative (Biff p f g) where 101 | bipure a b = Biff (bipure (pure a) (pure b)) 102 | {-# inline bipure #-} 103 | biliftA2 = \f g (Biff x) -> Biff #. biliftA2 (liftA2 f) (liftA2 g) x .# runBiff 104 | {-# inline biliftA2 #-} 105 | (<<*>>) = \(Biff fg) -> Biff #. biliftA2 (<*>) (<*>) fg .# runBiff 106 | {-# inline (<<*>>) #-} 107 | 108 | instance (Bifoldable p, Foldable f, Foldable g) => Bifoldable (Biff p f g) where 109 | bifoldMap f g = bifoldMap (foldMap f) (foldMap g) .# runBiff 110 | {-# inline bifoldMap #-} 111 | 112 | instance (Bifoldable1 p, Foldable1 f, Foldable1 g) => Bifoldable1 (Biff p f g) where 113 | bifoldMap1 f g = bifoldMap1 (foldMap1 f) (foldMap1 g) . runBiff 114 | {-# inline bifoldMap1 #-} 115 | 116 | instance (Bitraversable p, Traversable f, Traversable g) => Bitraversable (Biff p f g) where 117 | bitraverse f g = fmap Biff . bitraverse (traverse f) (traverse g) .# runBiff 118 | {-# inline bitraverse #-} 119 | 120 | -- | @since 5.6.1 121 | instance (f ~ g, Functor f, Swap p) => Swap (Biff p f g) where 122 | swap = Biff . swap . runBiff 123 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Wrapped.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE InstanceSigs #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE DeriveGeneric #-} 7 | {-# LANGUAGE DerivingVia #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE Trustworthy #-} 10 | 11 | -- | 12 | -- Copyright : (C) 2008-2023 Edward Kmett 13 | -- License : BSD-2-Clause OR Apache-2.0 14 | -- Maintainer : Edward Kmett 15 | -- Stability : provisional 16 | -- Portability : portable 17 | 18 | module Data.Bifunctor.Wrapped 19 | ( WrappedBifunctor(..) 20 | ) where 21 | 22 | import Data.Biapplicative 23 | import Data.Bifoldable 24 | import Data.Bifoldable1 (Bifoldable1(..)) 25 | import Data.Bifunctor 26 | import Data.Bifunctor.Functor 27 | import Data.Bifunctor.ShowRead 28 | import Data.Bifunctor.Unsafe 29 | import Data.Bitraversable 30 | import Data.Coerce 31 | import Data.Data 32 | import Data.Functor.Classes 33 | import GHC.Generics 34 | import Text.Read (Read (..)) 35 | 36 | -- | Make a 'Functor' over the second argument of a 'Bifunctor'. This also 37 | -- makes a 'Foldable', 'Traversable', 'Eq1', 'Ord1', 'Show1', and 'Read1' 38 | -- from a 'Bifoldable', 'Bitraversable', 'Eq2', 'Ord2', 'Show2', and 'Read2', 39 | -- respectively. 40 | newtype WrappedBifunctor p a b = WrapBifunctor { unwrapBifunctor :: p a b } 41 | deriving (Eq, Ord, Generic, Generic1, Data) 42 | deriving (Show, Read) via ShowRead (WrappedBifunctor p a b) 43 | 44 | instance (Eq2 p, Eq a) => Eq1 (WrappedBifunctor p a) where 45 | liftEq = liftEq2 (==) 46 | {-# inline liftEq #-} 47 | 48 | instance Eq2 p => Eq2 (WrappedBifunctor p) where 49 | liftEq2 50 | :: forall a b c d. 51 | (a -> b -> Bool) 52 | -> (c -> d -> Bool) 53 | -> WrappedBifunctor p a c 54 | -> WrappedBifunctor p b d 55 | -> Bool 56 | liftEq2 = coerce (liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> p a c -> p b d -> Bool) 57 | {-# inline liftEq2 #-} 58 | 59 | instance (Ord2 p, Ord a) => Ord1 (WrappedBifunctor p a) where 60 | liftCompare = liftCompare2 compare 61 | {-# inline liftCompare #-} 62 | 63 | instance Ord2 p => Ord2 (WrappedBifunctor p) where 64 | liftCompare2 65 | :: forall a b c d. 66 | (a -> b -> Ordering) 67 | -> (c -> d -> Ordering) 68 | -> WrappedBifunctor p a c 69 | -> WrappedBifunctor p b d 70 | -> Ordering 71 | liftCompare2 = coerce (liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) -> p a c -> p b d -> Ordering) 72 | {-# inline liftCompare2 #-} 73 | 74 | instance (Show2 p, Show a) => Show1 (WrappedBifunctor p a) where 75 | liftShowsPrec sp sl = liftShowsPrecWhatever $ liftShowsPrec2 showsPrec showList sp sl 76 | 77 | deriving via ShowRead2 (WrappedBifunctor p) instance Show2 p => Show2 (WrappedBifunctor p) 78 | 79 | instance (Read2 p, Read a) => Read1 (WrappedBifunctor p a) where 80 | liftReadPrec rp rl = liftReadPrecWhatever $ liftReadPrec2 readPrec readListPrec rp rl 81 | 82 | deriving via ShowRead2 (WrappedBifunctor p) instance Read2 p => Read2 (WrappedBifunctor p) 83 | 84 | instance BifunctorFunctor WrappedBifunctor where 85 | bifmap = \f -> WrapBifunctor #. f .# unwrapBifunctor 86 | {-# inline bifmap #-} 87 | 88 | instance BifunctorMonad WrappedBifunctor where 89 | bireturn = WrapBifunctor 90 | {-# inline bireturn #-} 91 | bijoin = unwrapBifunctor 92 | {-# inline bijoin #-} 93 | 94 | instance BifunctorComonad WrappedBifunctor where 95 | biextract = unwrapBifunctor 96 | {-# inline biextract #-} 97 | biduplicate = WrapBifunctor 98 | {-# inline biduplicate #-} 99 | 100 | instance Bifunctor p => Bifunctor (WrappedBifunctor p) where 101 | first f = WrapBifunctor #. first f .# unwrapBifunctor 102 | {-# inline first #-} 103 | second f = WrapBifunctor . second f . unwrapBifunctor 104 | {-# inline second #-} 105 | bimap f g = WrapBifunctor . bimap f g . unwrapBifunctor 106 | {-# inline bimap #-} 107 | 108 | instance Bifunctor p => Functor (WrappedBifunctor p a) where 109 | fmap f = WrapBifunctor . second f . unwrapBifunctor 110 | {-# inline fmap #-} 111 | 112 | instance Biapplicative p => Biapplicative (WrappedBifunctor p) where 113 | bipure a b = WrapBifunctor (bipure a b) 114 | {-# inline bipure #-} 115 | WrapBifunctor fg <<*>> WrapBifunctor xy = WrapBifunctor (fg <<*>> xy) 116 | {-# inline (<<*>>) #-} 117 | 118 | instance Bifoldable p => Foldable (WrappedBifunctor p a) where 119 | foldMap f = bifoldMap (const mempty) f . unwrapBifunctor 120 | {-# inline foldMap #-} 121 | 122 | instance Bifoldable p => Bifoldable (WrappedBifunctor p) where 123 | bifoldMap f g = bifoldMap f g . unwrapBifunctor 124 | {-# inline bifoldMap #-} 125 | 126 | instance Bifoldable1 p => Bifoldable1 (WrappedBifunctor p) where 127 | bifoldMap1 f g = bifoldMap1 f g . unwrapBifunctor 128 | {-# INLINE bifoldMap1 #-} 129 | 130 | instance Bitraversable p => Traversable (WrappedBifunctor p a) where 131 | traverse f = fmap WrapBifunctor . bitraverse pure f . unwrapBifunctor 132 | {-# inline traverse #-} 133 | 134 | instance Bitraversable p => Bitraversable (WrappedBifunctor p) where 135 | bitraverse f g = fmap WrapBifunctor . bitraverse f g . unwrapBifunctor 136 | {-# inline bitraverse #-} 137 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/ShowRead.hs: -------------------------------------------------------------------------------- 1 | {-# language ConstraintKinds #-} 2 | {-# language DataKinds #-} 3 | {-# language FlexibleInstances #-} 4 | {-# language MultiParamTypeClasses #-} 5 | {-# language QuantifiedConstraints #-} 6 | {-# language ScopedTypeVariables #-} 7 | {-# language TypeApplications #-} 8 | {-# language TypeFamilies #-} 9 | {-# language TypeOperators #-} 10 | {-# language UndecidableInstances #-} 11 | {-# language Safe #-} 12 | 13 | -- | 14 | -- Copyright : (C) 2020-2023 Edward Kmett 15 | -- License : BSD-2-Clause OR Apache-2.0 16 | -- Maintainer : Edward Kmett 17 | -- Stability : provisional 18 | -- Portability : portable 19 | -- 20 | -- Types for lifting instances of `Show`N and `Read`N for record newtypes. We 21 | -- don't show record syntax, because it's too much clutter, but we accept it 22 | -- when reading. 23 | -- 24 | -- When @a@ is a newtype (or close enough) /defined using record syntax/, and 25 | -- is an instance of 'Generic', 'Show', and 'Read', @'ShowRead' a@ is a 26 | -- @DerivingVia@ target implementing a plain 'Show' instance and a flexible 27 | -- 'Read' instance. This is a fairly specific situation, but it pops up all 28 | -- over this package. We could pretty easily expand to non-record types if 29 | -- we needed to. 30 | module Data.Bifunctor.ShowRead 31 | ( ShowRead (..) 32 | , ShowRead1 (..) 33 | , ShowRead2 (..) 34 | , liftReadPrecWhatever 35 | , liftShowsPrecWhatever 36 | ) where 37 | import qualified Text.ParserCombinators.ReadPrec as TPR 38 | import qualified Text.Read.Lex as TRL 39 | import qualified Text.Read as TR 40 | import Text.Read (ReadPrec, Read (..), readListPrecDefault) 41 | import GHC.Generics 42 | import Data.Kind 43 | import Data.Functor.Classes 44 | 45 | newtype ShowRead a = ShowRead a 46 | newtype ShowRead1 f a = ShowRead1 (f a) 47 | newtype ShowRead2 f a b = ShowRead2 (f a b) 48 | 49 | instance (Wraps n d c s o, Read o) => Read (ShowRead n) where 50 | readPrec = ShowRead <$> liftReadPrecWhatever readPrec 51 | readListPrec = readListPrecDefault 52 | 53 | instance (Wraps n d c s o, Show o) => Show (ShowRead n) where 54 | showsPrec d (ShowRead x) = liftShowsPrecWhatever showsPrec d x 55 | 56 | instance (Wraps1 n d c s o, Read1 o) => Read1 (ShowRead1 n) where 57 | liftReadPrec rp rl = ShowRead1 <$> liftReadPrecWhatever @(n _) @d @c @s @(o _) (liftReadPrec rp rl) 58 | liftReadListPrec = liftReadListPrecDefault 59 | 60 | instance (Wraps1 n f c s o, Read1 o, Read a) => Read (ShowRead1 n a) where 61 | readPrec = readPrec1 62 | readListPrec = readListPrecDefault 63 | 64 | instance (Wraps1 n d c s o, Show1 o) => Show1 (ShowRead1 n) where 65 | liftShowsPrec sp sl d (ShowRead1 x) = liftShowsPrecWhatever @(n _) @d @c @s @(o _) (liftShowsPrec sp sl) d x 66 | 67 | instance (Wraps1 n d c s o, Show1 o, Show a) => Show (ShowRead1 n a) where 68 | showsPrec = showsPrec1 69 | 70 | instance (Wraps2 n d c s o, Read2 o) => Read2 (ShowRead2 n) where 71 | liftReadPrec2 rp1 rl1 rp2 rl2 = ShowRead2 <$> liftReadPrecWhatever @(n _ _) @d @c @s @(o _ _) (liftReadPrec2 rp1 rl1 rp2 rl2) 72 | liftReadListPrec2 = liftReadListPrec2Default 73 | 74 | instance (Wraps2 n f c s o, Read2 o, Read a, Read b) => Read (ShowRead2 n a b) where 75 | readPrec = readPrec2 76 | readListPrec = readListPrecDefault 77 | 78 | instance (Wraps2 n f c s o, Read2 o, Read a) => Read1 (ShowRead2 n a) where 79 | liftReadPrec = liftReadPrec2 readPrec readListPrec 80 | liftReadListPrec = liftReadListPrecDefault 81 | 82 | instance (Wraps2 n d c s o, Show2 o) => Show2 (ShowRead2 n) where 83 | liftShowsPrec2 sp1 sl1 sp2 sl2 d (ShowRead2 x) = 84 | liftShowsPrecWhatever @(n _ _) @d @c @s @(o _ _) (liftShowsPrec2 sp1 sl1 sp2 sl2) d x 85 | 86 | instance (Wraps2 n d c s o, Show2 o, Show a, Show b) => Show (ShowRead2 n a b) where 87 | showsPrec = showsPrec2 88 | 89 | instance (Wraps2 n d c s o, Show2 o, Show a) => Show1 (ShowRead2 n a) where 90 | liftShowsPrec = liftShowsPrec2 showsPrec showList 91 | 92 | type WrapsF n d c s o = 93 | ( Generic n 94 | , Rep n ~ D1 d (C1 c (S1 s (Rec0 o))) 95 | , Constructor c 96 | , Selector s ) 97 | 98 | class WrapsF n d c s o => Wraps n d c s o 99 | instance WrapsF n d c s o => Wraps n d c s o 100 | 101 | type family Any where 102 | 103 | class (forall a. Wraps (n a) d c s (o a), Wraps (n Any) d c s (o Any)) => Wraps1 n d c s o 104 | instance (forall a. Wraps (n a) d c s (o a)) => Wraps1 n d c s o 105 | 106 | class (forall a b. Wraps (n a b) d c s (o a b), Wraps (n Any Any) d c s (o Any Any)) => Wraps2 n d c s o 107 | instance (forall a b. Wraps (n a b) d c s (o a b)) => Wraps2 n d c s o 108 | 109 | data Prox (c :: Meta) (f :: Type -> Type) a = Prox 110 | 111 | -- | Given a way to read the underlying type of a newtype 112 | -- or similar, produce a way to read the newtype itself 113 | -- using either record syntax or plain syntax. 114 | liftReadPrecWhatever 115 | :: forall n d c s o. 116 | ( Generic n 117 | , Wraps n d c s o 118 | , Constructor c 119 | , Selector s) 120 | => ReadPrec o -> ReadPrec n 121 | liftReadPrecWhatever read_p = 122 | TR.parens $ do 123 | expectP (TRL.Ident $ conName (Prox @c)) 124 | (TPR.prec 11 $ do 125 | expectP (TRL.Punc "{") 126 | expectP (TRL.Ident $ selName (Prox @s)) 127 | expectP (TRL.Punc "=") 128 | p <- read_p 129 | expectP (TRL.Punc "}") 130 | pure (to (M1 (M1 (M1 (K1 p)))))) 131 | TR.+++ 132 | (TPR.prec 10 $ do 133 | p <- TR.step read_p 134 | pure (to (M1 (M1 (M1 (K1 p)))))) 135 | 136 | -- Copied from GHC.Read 137 | expectP :: TRL.Lexeme -> ReadPrec () 138 | expectP lexeme = TR.lift (TRL.expect lexeme) 139 | 140 | -- | Given a way to show the type wrapped by a newtype, 141 | -- produce a way to show the newtype in plain syntax. 142 | liftShowsPrecWhatever 143 | :: forall n d c s o. 144 | ( Generic n 145 | , Wraps n d c s o 146 | , Constructor c ) 147 | => (Int -> o -> ShowS) -> Int -> n -> ShowS 148 | liftShowsPrecWhatever sp d n = showsUnaryWith sp (conName (Prox @c)) d (unK1 (unM1 (unM1 (unM1 (from n))))) 149 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Biap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DeriveGeneric #-} 10 | {-# LANGUAGE Trustworthy #-} 11 | 12 | -- | 13 | -- Copyright : (C) 2008-2023 Edward Kmett 14 | -- License : BSD-2-Clause OR Apache-2.0 15 | -- Maintainer : Edward Kmett 16 | -- Stability : provisional 17 | -- Portability : portable 18 | 19 | module Data.Bifunctor.Biap 20 | ( Biap(..) 21 | ) where 22 | 23 | import Control.Applicative 24 | import Control.Monad 25 | import qualified Control.Monad.Fail as Fail (MonadFail) 26 | import Data.Biapplicative 27 | import Data.Bifunctor 28 | import Data.Bifunctor.Functor 29 | import Data.Bifunctor.ShowRead 30 | import Data.Bifunctor.Unsafe 31 | import Data.Bifoldable 32 | import Data.Bitraversable 33 | -- import Data.Bifunctor.Classes 34 | import Data.Functor.Classes 35 | import Data.Type.Equality 36 | import Data.Type.Coercion 37 | import GHC.Generics 38 | import qualified Data.Semigroup as S 39 | import Language.Haskell.TH.Syntax (Lift) 40 | import Numeric 41 | 42 | -- | Pointwise lifting of a class over two arguments, using 43 | -- 'Biapplicative'. 44 | -- 45 | -- Classes that can be lifted include 'Monoid', 'Num' and 46 | -- 'Bounded'. Each method of those classes can be defined as lifting 47 | -- themselves over each argument of 'Biapplicative'. 48 | -- 49 | -- @ 50 | -- mempty = bipure mempty mempty 51 | -- minBound = bipure minBound minBound 52 | -- maxBound = bipure maxBound maxBound 53 | -- fromInteger n = bipure (fromInteger n) (fromInteger n) 54 | -- 55 | -- negate = bimap negate negate 56 | -- 57 | -- (+) = biliftA2 (+) (+) 58 | -- (<>) = biliftA2 (<>) (<>) 59 | -- @ 60 | -- 61 | -- 'Biap' is to 'Biapplicative' as 'Data.Monoid.Ap' is to 62 | -- 'Applicative'. 63 | -- 64 | -- 'Biap' can be used with @DerivingVia@ to derive a numeric instance 65 | -- for pairs: 66 | -- 67 | -- @ 68 | -- newtype Numpair a = Np (a, a) 69 | -- deriving (Semigroup, Monoid, Num, Fractional, Floating, Bounded) 70 | -- via Biap (,) a a 71 | -- @ 72 | -- 73 | newtype Biap bi a b = Biap { getBiap :: bi a b } 74 | deriving stock 75 | ( Eq 76 | , Ord 77 | , Functor 78 | , Foldable 79 | , Lift 80 | , Traversable 81 | , Generic 82 | , Generic1 83 | ) 84 | deriving newtype 85 | ( Alternative 86 | , Applicative 87 | -- @since 6: Enum removed, it isn't compatible with Bounded 88 | , Monad 89 | , Fail.MonadFail 90 | , MonadPlus 91 | , Eq1 92 | , Ord1 93 | , Bifunctor 94 | , Biapplicative 95 | , Bifoldable 96 | , Eq2 97 | , Ord2 98 | , TestEquality 99 | , TestCoercion 100 | ) 101 | 102 | instance BifunctorFunctor Biap where 103 | bifmap f = Biap #. f .# getBiap 104 | 105 | instance BifunctorMonad Biap where 106 | bireturn = Biap 107 | bijoin = getBiap 108 | 109 | instance BifunctorComonad Biap where 110 | biextract = getBiap 111 | biduplicate = Biap 112 | 113 | instance Bitraversable bi => Bitraversable (Biap bi) where 114 | bitraverse f g (Biap as) = Biap <$> bitraverse f g as 115 | {-# inline bitraverse #-} 116 | 117 | instance (Biapplicative bi, S.Semigroup a, S.Semigroup b) => S.Semigroup (Biap bi a b) where 118 | (<>) = biliftA2 (S.<>) (S.<>) 119 | {-# inline (<>) #-} 120 | 121 | instance (Biapplicative bi, Monoid a, Monoid b) => Monoid (Biap bi a b) where 122 | mempty = bipure mempty mempty 123 | {-# inline mempty #-} 124 | 125 | instance (Biapplicative bi, Bounded a, Bounded b) => Bounded (Biap bi a b) where 126 | minBound = bipure minBound minBound 127 | maxBound = bipure maxBound maxBound 128 | {-# inline minBound #-} 129 | {-# inline maxBound #-} 130 | 131 | instance 132 | ( Biapplicative bi, Num a, Num b 133 | ) => Num (Biap bi a b) where 134 | (+) = biliftA2 (+) (+) 135 | (-) = biliftA2 (-) (-) 136 | (*) = biliftA2 (*) (*) 137 | negate = bimap negate negate 138 | abs = bimap abs abs 139 | signum = bimap signum signum 140 | fromInteger n = bipure (fromInteger n) (fromInteger n) 141 | {-# inline (+) #-} 142 | {-# inline (-) #-} 143 | {-# inline (*) #-} 144 | {-# inline negate #-} 145 | {-# inline abs #-} 146 | {-# inline signum #-} 147 | {-# inline fromInteger #-} 148 | 149 | instance 150 | ( Biapplicative bi, Fractional a, Fractional b 151 | ) => Fractional (Biap bi a b) where 152 | (/) = biliftA2 (/) (/) 153 | recip = bimap recip recip 154 | fromRational r = bipure (fromRational r) (fromRational r) 155 | {-# inline (/) #-} 156 | {-# inline recip #-} 157 | {-# inline fromRational #-} 158 | 159 | 160 | instance 161 | ( Biapplicative bi, Floating a, Floating b 162 | ) => Floating (Biap bi a b) where 163 | pi = bipure pi pi 164 | exp = bimap exp exp 165 | log = bimap log log 166 | sqrt = bimap sqrt sqrt 167 | (**) = biliftA2 (**) (**) 168 | logBase = biliftA2 logBase logBase 169 | sin = bimap sin sin 170 | cos = bimap cos cos 171 | tan = bimap tan tan 172 | asin = bimap asin asin 173 | acos = bimap acos acos 174 | atan = bimap atan atan 175 | sinh = bimap sinh sinh 176 | cosh = bimap cosh cosh 177 | tanh = bimap tanh tanh 178 | asinh = bimap asinh asinh 179 | acosh = bimap acosh acosh 180 | atanh = bimap atanh atanh 181 | log1p = bimap log1p log1p 182 | expm1 = bimap expm1 expm1 183 | log1pexp = bimap log1pexp log1pexp 184 | log1mexp = bimap log1mexp log1mexp 185 | {-# inline pi #-} 186 | {-# inline exp #-} 187 | {-# inline log #-} 188 | {-# inline sqrt #-} 189 | {-# inline (**) #-} 190 | {-# inline logBase #-} 191 | {-# inline sin #-} 192 | {-# inline cos #-} 193 | {-# inline tan #-} 194 | {-# inline asin #-} 195 | {-# inline acos #-} 196 | {-# inline atan #-} 197 | {-# inline sinh #-} 198 | {-# inline cosh #-} 199 | {-# inline tanh #-} 200 | {-# inline asinh #-} 201 | {-# inline acosh #-} 202 | {-# inline atanh #-} 203 | {-# inline log1p #-} 204 | {-# inline expm1 #-} 205 | {-# inline log1pexp #-} 206 | {-# inline log1mexp #-} 207 | 208 | deriving via ShowRead (Biap p a b) instance Show (p a b) => Show (Biap p a b) 209 | 210 | deriving via ShowRead1 (Biap p a) instance Show1 (p a) => Show1 (Biap p a) 211 | 212 | deriving via ShowRead2 (Biap p) instance Show2 p => Show2 (Biap p) 213 | 214 | -- | Accepts either plain or record syntax. 215 | deriving via ShowRead (Biap p a b) instance Read (p a b) => Read (Biap p a b) 216 | 217 | -- | Accepts either plain or record syntax. 218 | deriving via ShowRead1 (Biap p a) instance Read1 (p a) => Read1 (Biap p a) 219 | 220 | -- | Accepts either plain or record syntax. 221 | deriving via ShowRead2 (Biap p) instance Read2 p => Read2 (Biap p) 222 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Product.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE DeriveGeneric #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE Safe #-} 9 | 10 | -- | 11 | -- Copyright : (C) 2008-2023 Jesse Selover, Edward Kmett 12 | -- License : BSD-2-Clause OR Apache-2.0 13 | -- Maintainer : Edward Kmett 14 | -- Stability : provisional 15 | -- Portability : portable 16 | -- 17 | -- The product of two bifunctors. 18 | 19 | module Data.Bifunctor.Product 20 | ( Product(..) 21 | ) where 22 | 23 | import qualified Control.Arrow as A 24 | import Control.Category 25 | import Data.Biapplicative 26 | import Data.Bifoldable 27 | import Data.Bifoldable1 (Bifoldable1(..)) 28 | import Data.Bifunctor 29 | import Data.Bifunctor.Classes 30 | import Data.Bifunctor.Functor 31 | import Data.Bifunctor.Monoid 32 | import Data.Bifunctor.Swap (Swap (..)) 33 | import Data.Bitraversable 34 | import Data.Data 35 | import Data.Functor.Classes 36 | import Data.Functor.Contravariant 37 | import GHC.Generics 38 | import Language.Haskell.TH.Syntax (Lift) 39 | import Prelude hiding ((.),id) 40 | 41 | -- | Form the product of two bifunctors 42 | data Product f g a b = Pair (f a b) (g a b) 43 | deriving stock 44 | ( Eq, Ord, Show, Read, Data, Generic 45 | , Generic1, Functor, Foldable, Traversable, Lift ) 46 | 47 | instance (Contravariant (f a), Contravariant (g a)) => Contravariant (Product f g a) where 48 | contramap = \f (Pair g h) -> Pair (contramap f g) (contramap f h) 49 | {-# inline contramap #-} 50 | 51 | instance (Eq1 (f a), Eq1 (g a)) => Eq1 (Product f g a) where 52 | liftEq eq (Pair x1 y1) (Pair x2 y2) = 53 | liftEq eq x1 x2 && liftEq eq y1 y2 54 | {-# inline liftEq #-} 55 | 56 | instance (Eq2 f, Eq2 g) => Eq2 (Product f g) where 57 | liftEq2 = \f g (Pair x1 y1) (Pair x2 y2) -> 58 | liftEq2 f g x1 x2 && liftEq2 f g y1 y2 59 | {-# inline liftEq2 #-} 60 | 61 | instance (Ord1 (f a), Ord1 (g a)) => Ord1 (Product f g a) where 62 | liftCompare cmp (Pair x1 y1) (Pair x2 y2) = 63 | liftCompare cmp x1 x2 <> liftCompare cmp y1 y2 64 | {-# inline liftCompare #-} 65 | 66 | instance (Ord2 f, Ord2 g) => Ord2 (Product f g) where 67 | liftCompare2 = \f g (Pair x1 y1) (Pair x2 y2) -> 68 | liftCompare2 f g x1 x2 `mappend` liftCompare2 f g y1 y2 69 | {-# inline liftCompare2 #-} 70 | 71 | instance (Read2 f, Read2 g, Read a) => Read1 (Product f g a) where 72 | liftReadsPrec = liftReadsPrec2 readsPrec readList 73 | 74 | instance (Read2 f, Read2 g) => Read2 (Product f g) where 75 | liftReadsPrec2 rp1 rl1 rp2 rl2 = readsData $ 76 | readsBinaryWith (liftReadsPrec2 rp1 rl1 rp2 rl2) 77 | (liftReadsPrec2 rp1 rl1 rp2 rl2) 78 | "Pair" Pair 79 | 80 | instance (Show2 f, Show2 g, Show a) => Show1 (Product f g a) where 81 | liftShowsPrec = liftShowsPrec2 showsPrec showList 82 | 83 | instance (Show2 f, Show2 g) => Show2 (Product f g) where 84 | liftShowsPrec2 sp1 sl1 sp2 sl2 p (Pair x y) = 85 | showsBinaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) 86 | (liftShowsPrec2 sp1 sl1 sp2 sl2) 87 | "Pair" p x y 88 | 89 | instance (Bifunctor f, Bifunctor g) => Bifunctor (Product f g) where 90 | first = \f (Pair x y) -> Pair (first f x) (first f y) 91 | {-# inline first #-} 92 | second = \g (Pair x y) -> Pair (second g x) (second g y) 93 | {-# inline second #-} 94 | bimap = \f g (Pair x y) -> Pair (bimap f g x) (bimap f g y) 95 | {-# inline bimap #-} 96 | 97 | instance (Biapplicative f, Biapplicative g) => Biapplicative (Product f g) where 98 | bipure = \a b -> Pair (bipure a b) (bipure a b) 99 | {-# inline bipure #-} 100 | biliftA2 = \f g (Pair w x) (Pair y z) -> Pair (biliftA2 f g w y) (biliftA2 f g x z) 101 | {-# inline biliftA2 #-} 102 | (<<*>>) = \(Pair w x) (Pair y z) -> Pair (w <<*>> y) (x <<*>> z) 103 | {-# inline (<<*>>) #-} 104 | 105 | instance (Bifoldable f, Bifoldable g) => Bifoldable (Product f g) where 106 | bifoldMap = \f g (Pair x y) -> bifoldMap f g x `mappend` bifoldMap f g y 107 | {-# inline bifoldMap #-} 108 | 109 | instance (Bifoldable1 f, Bifoldable1 g) => Bifoldable1 (Product f g) where 110 | bifoldMap1 f g (Pair x y) = bifoldMap1 f g x <> bifoldMap1 f g y 111 | {-# INLINE bifoldMap1 #-} 112 | 113 | instance (Bitraversable f, Bitraversable g) => Bitraversable (Product f g) where 114 | bitraverse = \f g (Pair x y) -> Pair <$> bitraverse f g x <*> bitraverse f g y 115 | {-# inline bitraverse #-} 116 | 117 | instance Bifunctor' p => BifunctorFunctor (Product p) where 118 | bifmap = \f (Pair p q) -> Pair p (f q) 119 | {-# inline bifmap #-} 120 | 121 | instance Bifunctor' p => BifunctorComonad (Product p) where 122 | biextract = \(Pair _ q) -> q 123 | {-# inline biextract #-} 124 | biduplicate = \pq@(Pair p _) -> Pair p pq 125 | {-# inline biduplicate #-} 126 | biextend = \f pq@(Pair p _) -> Pair p (f pq) 127 | {-# inline biextend #-} 128 | 129 | instance BifunctorMonoid p => BifunctorMonad (Product p) where 130 | bireturn = Pair mempty 131 | {-# inline bireturn #-} 132 | bijoin = \(Pair p (Pair q r)) -> Pair (p <> q) r 133 | {-# inline bijoin #-} 134 | 135 | instance (Category p, Category q) => Category (Product p q) where 136 | id = Pair id id 137 | {-# inline id #-} 138 | (.) = \(Pair x y) (Pair x' y') -> Pair (x . x') (y . y') 139 | {-# inline (.) #-} 140 | 141 | instance (A.Arrow p, A.Arrow q) => A.Arrow (Product p q) where 142 | arr = \f -> Pair (A.arr f) (A.arr f) 143 | {-# inline arr #-} 144 | first = \(Pair x y) -> Pair (A.first x) (A.first y) 145 | {-# inline first #-} 146 | second = \(Pair x y) -> Pair (A.second x) (A.second y) 147 | {-# inline second #-} 148 | (***) = \(Pair x y) (Pair x' y') -> Pair (x A.*** x') (y A.*** y') 149 | {-# inline (***) #-} 150 | (&&&) = \(Pair x y) (Pair x' y') -> Pair (x A.&&& x') (y A.&&& y') 151 | {-# inline (&&&) #-} 152 | 153 | instance (A.ArrowChoice p, A.ArrowChoice q) => A.ArrowChoice (Product p q) where 154 | left = \(Pair x y) -> Pair (A.left x) (A.left y) 155 | {-# inline left #-} 156 | right = \(Pair x y) -> Pair (A.right x) (A.right y) 157 | {-# inline right #-} 158 | (+++) = \(Pair x y) (Pair x' y') -> Pair (x A.+++ x') (y A.+++ y') 159 | {-# inline (+++) #-} 160 | (|||) = \(Pair x y) (Pair x' y') -> Pair (x A.||| x') (y A.||| y') 161 | {-# inline (|||) #-} 162 | 163 | instance (A.ArrowLoop p, A.ArrowLoop q) => A.ArrowLoop (Product p q) where 164 | loop = \(Pair x y) -> Pair (A.loop x) (A.loop y) 165 | {-# inline loop #-} 166 | 167 | instance (A.ArrowZero p, A.ArrowZero q) => A.ArrowZero (Product p q) where 168 | zeroArrow = Pair A.zeroArrow A.zeroArrow 169 | {-# inline zeroArrow #-} 170 | 171 | instance (A.ArrowPlus p, A.ArrowPlus q) => A.ArrowPlus (Product p q) where 172 | (<+>) = \(Pair x y) (Pair x' y') -> Pair (x A.<+> x') (y A.<+> y') 173 | {-# inline (<+>) #-} 174 | 175 | -- | @since 5.6.1 176 | instance (Swap p, Swap q) => Swap (Product p q) where 177 | swap (Pair p q) = Pair (swap p) (swap q) 178 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Tannen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE DeriveGeneric #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE Trustworthy #-} 11 | 12 | -- | 13 | -- Copyright : (C) 2008-2023 Edward Kmett 14 | -- License : BSD-2-Clause OR Apache-2.0 15 | -- Maintainer : Edward Kmett 16 | -- Stability : provisional 17 | -- Portability : portable 18 | 19 | module Data.Bifunctor.Tannen 20 | ( Tannen(..) 21 | ) where 22 | 23 | import Control.Applicative 24 | import Control.Arrow as A 25 | import Control.Category 26 | import Control.Comonad 27 | import Data.Bifunctor as B 28 | import Data.Bifunctor.Functor 29 | import Data.Bifunctor.ShowRead 30 | import Data.Bifunctor.Unsafe 31 | import Data.Bifunctor.Swap (Swap (..)) 32 | import Data.Biapplicative 33 | import Data.Bifoldable 34 | import Data.Bifoldable1 (Bifoldable1(..)) 35 | import Data.Bitraversable 36 | import Data.Data 37 | import Data.Foldable1 (Foldable1(..)) 38 | import Data.Functor.Classes 39 | import GHC.Generics 40 | import Language.Haskell.TH.Syntax (Lift) 41 | import Prelude hiding ((.),id) 42 | import Text.Read (Read (..), readListPrecDefault) 43 | 44 | -- | Compose a 'Functor' on the outside of a 'Bifunctor'. 45 | newtype Tannen f p a b = Tannen { runTannen :: f (p a b) } 46 | deriving stock ( Eq, Ord, Data, Generic, Lift) 47 | 48 | deriving stock instance Functor f => Generic1 (Tannen f p a) 49 | deriving stock instance (Functor f, Functor (p a)) => Functor (Tannen f p a) 50 | deriving stock instance (Foldable f, Foldable (p a)) => Foldable (Tannen f p a) 51 | deriving stock instance (Traversable f, Traversable (p a)) => Traversable (Tannen f p a) 52 | 53 | instance (Eq1 f, Eq1 (p a)) => Eq1 (Tannen f p a) where 54 | liftEq eq (Tannen x) (Tannen y) = liftEq (liftEq eq) x y 55 | {-# inline liftEq #-} 56 | 57 | instance (Eq1 f, Eq2 p) => Eq2 (Tannen f p) where 58 | liftEq2 f g (Tannen x) (Tannen y) = liftEq (liftEq2 f g) x y 59 | {-# inline liftEq2 #-} 60 | 61 | instance (Ord1 f, Ord1 (p a)) => Ord1 (Tannen f p a) where 62 | liftCompare cmp (Tannen x) (Tannen y) = liftCompare (liftCompare cmp) x y 63 | {-# inline liftCompare #-} 64 | 65 | instance (Ord1 f, Ord2 p) => Ord2 (Tannen f p) where 66 | liftCompare2 f g (Tannen x) (Tannen y) = liftCompare (liftCompare2 f g) x y 67 | {-# inline liftCompare2 #-} 68 | 69 | instance Show (f (p a b)) => Show (Tannen f p a b) where 70 | showsPrec = liftShowsPrecWhatever showsPrec 71 | 72 | instance Read (f (p a b)) => Read (Tannen f p a b) where 73 | readPrec = liftReadPrecWhatever readPrec 74 | readListPrec = readListPrecDefault 75 | 76 | instance (Read1 f, Read1 (p a)) => Read1 (Tannen f p a) where 77 | liftReadPrec rp rl = liftReadPrecWhatever $ liftReadPrec (liftReadPrec rp rl) (liftReadListPrec rp rl) 78 | liftReadListPrec = liftReadListPrecDefault 79 | 80 | instance (Read1 f, Read2 p) => Read2 (Tannen f p) where 81 | liftReadPrec2 rp1 rl1 rp2 rl2 = liftReadPrecWhatever $ 82 | liftReadPrec (liftReadPrec2 rp1 rl1 rp2 rl2) (liftReadListPrec2 rp1 rl1 rp2 rl2) 83 | liftReadListPrec2 = liftReadListPrec2Default 84 | 85 | instance (Show1 f, Show1 (p a)) => Show1 (Tannen f p a) where 86 | liftShowsPrec sp sl = liftShowsPrecWhatever $ 87 | liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl) 88 | 89 | instance (Show1 f, Show2 p) => Show2 (Tannen f p) where 90 | liftShowsPrec2 sp1 sl1 sp2 sl2 = liftShowsPrecWhatever $ 91 | liftShowsPrec (liftShowsPrec2 sp1 sl1 sp2 sl2) 92 | (liftShowList2 sp1 sl1 sp2 sl2) 93 | 94 | instance Functor f => BifunctorFunctor (Tannen f) where 95 | bifmap f = Tannen #. fmap f .# runTannen 96 | {-# inline bifmap #-} 97 | 98 | instance (Functor f, Monad f) => BifunctorMonad (Tannen f) where 99 | bireturn = Tannen #. return 100 | bibind = \f (Tannen fp) -> Tannen $ fp >>= runTannen . f 101 | {-# inline bireturn #-} 102 | {-# inline bibind #-} 103 | 104 | instance Comonad f => BifunctorComonad (Tannen f) where 105 | biextract = extract .# runTannen 106 | biextend = \f -> Tannen #. extend (f .# Tannen) .# runTannen 107 | {-# inline biextract #-} 108 | {-# inline biextend #-} 109 | 110 | instance (Functor f, Bifunctor p) => Bifunctor (Tannen f p) where 111 | first = \f -> Tannen #. fmap (B.first f) .# runTannen 112 | {-# inline first #-} 113 | second = \f -> Tannen #. fmap (B.second f) .# runTannen 114 | {-# inline second #-} 115 | bimap = \f g -> Tannen #. fmap (bimap f g) .# runTannen 116 | {-# inline bimap #-} 117 | 118 | instance (Applicative f, Biapplicative p) => Biapplicative (Tannen f p) where 119 | bipure = \a b -> Tannen (pure (bipure a b)) 120 | {-# inline bipure #-} 121 | 122 | (<<*>>) = \fg -> Tannen #. liftA2 (<<*>>) (runTannen fg) .# runTannen 123 | {-# inline (<<*>>) #-} 124 | 125 | biliftA2 f g = \fg -> Tannen #. liftA2 (biliftA2 f g) (runTannen fg) .# runTannen 126 | {-# inline biliftA2 #-} 127 | 128 | instance (Foldable f, Bifoldable p) => Bifoldable (Tannen f p) where 129 | bifoldMap f g = foldMap (bifoldMap f g) .# runTannen 130 | {-# inline bifoldMap #-} 131 | 132 | instance (Foldable1 f, Bifoldable1 p) => Bifoldable1 (Tannen f p) where 133 | bifoldMap1 f g = foldMap1 (bifoldMap1 f g) . runTannen 134 | {-# INLINE bifoldMap1 #-} 135 | 136 | instance (Traversable f, Bitraversable p) => Bitraversable (Tannen f p) where 137 | bitraverse f g = fmap Tannen . traverse (bitraverse f g) .# runTannen 138 | {-# inline bitraverse #-} 139 | 140 | instance (Applicative f, Category p) => Category (Tannen f p) where 141 | id = Tannen $ pure id 142 | (.) = \fg -> Tannen #. liftA2 (.) (runTannen fg) .# runTannen 143 | {-# inline id #-} 144 | {-# inline (.) #-} 145 | 146 | instance (Applicative f, Arrow p) => Arrow (Tannen f p) where 147 | arr = Tannen #. pure . arr 148 | first = Tannen #. fmap A.first .# runTannen 149 | second = Tannen #. fmap A.second .# runTannen 150 | (***) = \fg -> Tannen #. liftA2 (***) (runTannen fg) .# runTannen 151 | (&&&) = \fg -> Tannen #. liftA2 (&&&) (runTannen fg) .# runTannen 152 | {-# inline arr #-} 153 | {-# inline first #-} 154 | {-# inline second #-} 155 | {-# inline (***) #-} 156 | {-# inline (&&&) #-} 157 | 158 | instance (Applicative f, ArrowChoice p) => ArrowChoice (Tannen f p) where 159 | left = Tannen #. fmap left .# runTannen 160 | right = Tannen #. fmap right .# runTannen 161 | (+++) = \fg -> Tannen #. liftA2 (+++) (runTannen fg) .# runTannen 162 | (|||) = \fg -> Tannen #. liftA2 (|||) (runTannen fg) .# runTannen 163 | {-# inline (|||) #-} 164 | {-# inline (+++) #-} 165 | {-# inline left #-} 166 | {-# inline right #-} 167 | 168 | instance (Applicative f, ArrowLoop p) => ArrowLoop (Tannen f p) where 169 | loop = Tannen #. fmap loop .# runTannen 170 | {-# inline loop #-} 171 | 172 | instance (Applicative f, ArrowZero p) => ArrowZero (Tannen f p) where 173 | zeroArrow = Tannen $ pure zeroArrow 174 | {-# inline zeroArrow #-} 175 | 176 | instance (Applicative f, ArrowPlus p) => ArrowPlus (Tannen f p) where 177 | (<+>) = \fg -> Tannen #. liftA2 (<+>) (runTannen fg) .# runTannen 178 | {-# inline (<+>) #-} 179 | 180 | -- | @since 5.6.1 181 | instance (Functor f, Swap p) => Swap (Tannen f p) where 182 | swap = Tannen . fmap swap . runTannen 183 | -------------------------------------------------------------------------------- /LICENSES/Apache-2.0.txt: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. 10 | 11 | "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. 12 | 13 | "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. 14 | 15 | "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. 16 | 17 | "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. 18 | 19 | "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. 20 | 21 | "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). 22 | 23 | "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. 24 | 25 | "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." 26 | 27 | "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 28 | 29 | 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 30 | 31 | 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 32 | 33 | 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: 34 | 35 | (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and 36 | 37 | (b) You must cause any modified files to carry prominent notices stating that You changed the files; and 38 | 39 | (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and 40 | 41 | (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. 42 | 43 | You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 44 | 45 | 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 46 | 47 | 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 48 | 49 | 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 50 | 51 | 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 52 | 53 | 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. 54 | 55 | END OF TERMS AND CONDITIONS 56 | 57 | APPENDIX: How to apply the Apache License to your work. 58 | 59 | To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. 60 | 61 | Copyright [yyyy] [name of copyright owner] 62 | 63 | Licensed under the Apache License, Version 2.0 (the "License"); 64 | you may not use this file except in compliance with the License. 65 | You may obtain a copy of the License at 66 | 67 | http://www.apache.org/licenses/LICENSE-2.0 68 | 69 | Unless required by applicable law or agreed to in writing, software 70 | distributed under the License is distributed on an "AS IS" BASIS, 71 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 72 | See the License for the specific language governing permissions and 73 | limitations under the License. -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250216 12 | # 13 | # REGENDATA ("0.19.20250216",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-24.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.1 32 | compilerKind: ghc 33 | compilerVersion: 9.12.1 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.10.1 37 | compilerKind: ghc 38 | compilerVersion: 9.10.1 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.8.4 42 | compilerKind: ghc 43 | compilerVersion: 9.8.4 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.6.6 47 | compilerKind: ghc 48 | compilerVersion: 9.6.6 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.4.8 52 | compilerKind: ghc 53 | compilerVersion: 9.4.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.2.8 57 | compilerKind: ghc 58 | compilerVersion: 9.2.8 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-9.0.2 62 | compilerKind: ghc 63 | compilerVersion: 9.0.2 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.10.7 67 | compilerKind: ghc 68 | compilerVersion: 8.10.7 69 | setup-method: ghcup 70 | allow-failure: false 71 | - compiler: ghc-8.8.4 72 | compilerKind: ghc 73 | compilerVersion: 8.8.4 74 | setup-method: ghcup 75 | allow-failure: false 76 | - compiler: ghc-8.6.5 77 | compilerKind: ghc 78 | compilerVersion: 8.6.5 79 | setup-method: ghcup 80 | allow-failure: false 81 | fail-fast: false 82 | steps: 83 | - name: apt-get install 84 | run: | 85 | apt-get update 86 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 87 | - name: Install GHCup 88 | run: | 89 | mkdir -p "$HOME/.ghcup/bin" 90 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 91 | chmod a+x "$HOME/.ghcup/bin/ghcup" 92 | - name: Install cabal-install 93 | run: | 94 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 95 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 96 | - name: Install GHC (GHCup) 97 | if: matrix.setup-method == 'ghcup' 98 | run: | 99 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 100 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 101 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 102 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 103 | echo "HC=$HC" >> "$GITHUB_ENV" 104 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 105 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 106 | env: 107 | HCKIND: ${{ matrix.compilerKind }} 108 | HCNAME: ${{ matrix.compiler }} 109 | HCVER: ${{ matrix.compilerVersion }} 110 | - name: Set PATH and environment variables 111 | run: | 112 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 113 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 114 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 115 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 116 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 117 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 118 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 119 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 120 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 121 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 122 | env: 123 | HCKIND: ${{ matrix.compilerKind }} 124 | HCNAME: ${{ matrix.compiler }} 125 | HCVER: ${{ matrix.compilerVersion }} 126 | - name: env 127 | run: | 128 | env 129 | - name: write cabal config 130 | run: | 131 | mkdir -p $CABAL_DIR 132 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 165 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 166 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 167 | rm -f cabal-plan.xz 168 | chmod a+x $HOME/.cabal/bin/cabal-plan 169 | cabal-plan --version 170 | - name: checkout 171 | uses: actions/checkout@v4 172 | with: 173 | path: source 174 | - name: initial cabal.project for sdist 175 | run: | 176 | touch cabal.project 177 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 178 | cat cabal.project 179 | - name: sdist 180 | run: | 181 | mkdir -p sdist 182 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 183 | - name: unpack 184 | run: | 185 | mkdir -p unpacked 186 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 187 | - name: generate cabal.project 188 | run: | 189 | PKGDIR_bifunctors="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/bifunctors-[0-9.]*')" 190 | echo "PKGDIR_bifunctors=${PKGDIR_bifunctors}" >> "$GITHUB_ENV" 191 | rm -f cabal.project cabal.project.local 192 | touch cabal.project 193 | touch cabal.project.local 194 | echo "packages: ${PKGDIR_bifunctors}" >> cabal.project 195 | echo "package bifunctors" >> cabal.project 196 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 197 | cat >> cabal.project <> cabal.project.local 204 | cat cabal.project 205 | cat cabal.project.local 206 | - name: dump install plan 207 | run: | 208 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 209 | cabal-plan 210 | - name: restore cache 211 | uses: actions/cache/restore@v4 212 | with: 213 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 214 | path: ~/.cabal/store 215 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 216 | - name: install dependencies 217 | run: | 218 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 219 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 220 | - name: build 221 | run: | 222 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 223 | - name: tests 224 | run: | 225 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 226 | - name: cabal check 227 | run: | 228 | cd ${PKGDIR_bifunctors} || false 229 | ${CABAL} -vnormal check 230 | - name: haddock 231 | run: | 232 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 233 | - name: save cache 234 | if: always() 235 | uses: actions/cache/save@v4 236 | with: 237 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 238 | path: ~/.cabal/store 239 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/Yoneda.hs: -------------------------------------------------------------------------------- 1 | {-# Language CPP #-} 2 | {-# Language BlockArguments #-} 3 | {-# Language RankNTypes #-} 4 | {-# Language GADTs #-} 5 | {-# Language Trustworthy #-} 6 | {-# Language DeriveFunctor #-} 7 | {-# Language StandaloneDeriving #-} 8 | {-# Language DerivingStrategies #-} 9 | {-# Language ViewPatterns #-} 10 | {-# Language TemplateHaskellQuotes #-} 11 | 12 | -- | 13 | -- Copyright : (C) 2020-2023 Edward Kmett 14 | -- License : BSD-2-Clause OR Apache-2.0 15 | -- Maintainer : Edward Kmett 16 | -- Stability : provisional 17 | -- Portability : portable 18 | 19 | module Data.Bifunctor.Yoneda 20 | ( Yoneda(..) 21 | , Coyoneda(..) 22 | , liftYoneda 23 | , lowerYoneda 24 | , liftCoyoneda 25 | , lowerCoyoneda 26 | ) where 27 | 28 | import Data.Biapplicative 29 | import Data.Bifoldable 30 | import Data.Bifunctor 31 | import Data.Bitraversable 32 | import Data.Bifunctor.Functor 33 | import Data.Foldable 34 | import Data.Function (on) 35 | import Data.Functor.Classes 36 | import Text.Read (Read (..), readListPrecDefault) 37 | import Data.Type.Equality (TestEquality (..)) 38 | import Data.Type.Coercion (TestCoercion (..)) 39 | import qualified Language.Haskell.TH.Syntax as THS 40 | 41 | newtype Yoneda p a b = Yoneda { runYoneda :: forall x y. (a -> x) -> (b -> y) -> p x y } 42 | deriving stock Functor 43 | 44 | -- TODO: Bifoldable needs a Foldable (p a) superclass 45 | 46 | -- Aside from having (mildly) weaker constraints than bireturn and biextract, 47 | -- and helping considerably with inference, liftYoneda and lowerYoneda give us 48 | -- nice names to use for `Show` and `Read`. 49 | 50 | -- | A specialized version of 'bireturn'. 51 | liftYoneda :: Bifunctor p => p a b -> Yoneda p a b 52 | liftYoneda pab = Yoneda $ \ax by -> bimap ax by pab 53 | 54 | -- | A specialized version of 'biextract'. 55 | lowerYoneda :: Yoneda p a b -> p a b 56 | lowerYoneda (Yoneda f) = f id id 57 | 58 | instance Foldable (p a) => Foldable (Yoneda p a) where 59 | foldMap = \g yo -> fold $ runYoneda yo id g 60 | {-# inline foldMap #-} 61 | 62 | instance (Bifunctor p, Traversable (p a)) => Traversable (Yoneda p a) where 63 | traverse = \g yo -> fmap liftYoneda $ sequenceA $ runYoneda yo id g 64 | {-# inline traverse #-} 65 | 66 | instance Bifunctor (Yoneda p) where 67 | bimap = \aa' bb' k -> Yoneda \a'x b'y -> runYoneda k (a'x . aa') (b'y . bb') 68 | first = \aa' k -> Yoneda \a'x b'y -> runYoneda k (a'x . aa') b'y 69 | second = \bb' k -> Yoneda \a'x b'y -> runYoneda k a'x (b'y . bb') 70 | {-# inline bimap #-} 71 | {-# inline first #-} 72 | {-# inline second #-} 73 | 74 | instance BifunctorFunctor Yoneda where 75 | bifmap = \f p -> Yoneda \g h -> f (runYoneda p g h) 76 | {-# inline bifmap #-} 77 | 78 | instance BifunctorMonad Yoneda where 79 | bireturn = \p -> Yoneda \f g -> bimap f g p 80 | {-# inline bireturn #-} 81 | bijoin = biextract 82 | {-# inline bijoin #-} 83 | 84 | instance BifunctorComonad Yoneda where 85 | biextract = \k -> runYoneda k id id 86 | {-# inline biextract #-} 87 | biduplicate = \yo -> Yoneda \f g -> bimap f g yo 88 | {-# inline biduplicate #-} 89 | 90 | instance Bifoldable p => Bifoldable (Yoneda p) where 91 | bifoldMap = \f g yo -> bifold $ runYoneda yo f g 92 | {-# inline bifoldMap #-} 93 | 94 | instance Bitraversable p => Bitraversable (Yoneda p) where 95 | bitraverse = \f g yo -> liftYoneda <$> bisequence (runYoneda yo f g) 96 | {-# inline bitraverse #-} 97 | 98 | instance Biapplicative p => Biapplicative (Yoneda p) where 99 | bipure = \a b -> Yoneda \f g -> bipure (f a) (g b) 100 | {-# inline bipure #-} 101 | biliftA2 = \f g x y -> Yoneda \f' g' -> 102 | biliftA2 (f'.) (g'.) (runYoneda x f g) (biextract y) 103 | {-# inline biliftA2 #-} 104 | (<<*>>) = \x y -> Yoneda \f g -> 105 | runYoneda x (f.) (g.) <<*>> biextract y 106 | {-# inline (<<*>>) #-} 107 | 108 | instance Eq (p a b) => Eq (Yoneda p a b) where 109 | (==) = (==) `on` lowerYoneda 110 | 111 | instance Eq1 (p a) => Eq1 (Yoneda p a) where 112 | liftEq eq x y = liftEq eq (lowerYoneda x) (lowerYoneda y) 113 | 114 | instance Eq2 p => Eq2 (Yoneda p) where 115 | liftEq2 f g x y = liftEq2 f g (lowerYoneda x) (lowerYoneda y) 116 | 117 | instance Ord (p a b) => Ord (Yoneda p a b) where 118 | compare = compare `on` lowerYoneda 119 | -- We can't do anything special for min or max without 120 | -- a Bifunctor p constraint. Do we want one? 121 | 122 | instance Ord1 (p a) => Ord1 (Yoneda p a) where 123 | liftCompare cmp x y = liftCompare cmp (lowerYoneda x) (lowerYoneda y) 124 | 125 | instance Ord2 p => Ord2 (Yoneda p) where 126 | liftCompare2 f g x y = liftCompare2 f g (lowerYoneda x) (lowerYoneda y) 127 | 128 | instance Show (p a b) => Show (Yoneda p a b) where 129 | showsPrec = showsUnaryWith (\i -> showsPrec i . lowerYoneda) "liftYoneda" 130 | 131 | instance Show1 (p a) => Show1 (Yoneda p a) where 132 | liftShowsPrec sp sl = showsUnaryWith (\i -> liftShowsPrec sp sl i . lowerYoneda) "liftYoneda" 133 | 134 | instance Show2 p => Show2 (Yoneda p) where 135 | liftShowsPrec2 sp1 sl1 sp2 sl2 = showsUnaryWith (\i -> liftShowsPrec2 sp1 sl1 sp2 sl2 i . lowerYoneda) "liftYoneda" 136 | 137 | instance (Read (p a b), Bifunctor p) => Read (Yoneda p a b) where 138 | readPrec = readData $ readUnaryWith readPrec "liftYoneda" liftYoneda 139 | readListPrec = readListPrecDefault 140 | 141 | instance (Read1 (p a), Bifunctor p) => Read1 (Yoneda p a) where 142 | liftReadPrec rp rl = readData $ readUnaryWith (liftReadPrec rp rl) "liftYoneda" liftYoneda 143 | liftReadListPrec = liftReadListPrecDefault 144 | 145 | instance (Read2 p, Bifunctor p) => Read2 (Yoneda p) where 146 | liftReadPrec2 rp1 rl1 rp2 rl2 = readData $ 147 | readUnaryWith (liftReadPrec2 rp1 rl1 rp2 rl2) "liftYoneda" liftYoneda 148 | liftReadListPrec2 = liftReadListPrec2Default 149 | 150 | instance TestEquality (p a) => TestEquality (Yoneda p a) where 151 | testEquality x y = testEquality (lowerYoneda x) (lowerYoneda y) 152 | 153 | instance TestCoercion (p a) => TestCoercion (Yoneda p a) where 154 | testCoercion x y = testCoercion (lowerYoneda x) (lowerYoneda y) 155 | 156 | instance (THS.Lift (p a b), Bifunctor p) => THS.Lift (Yoneda p a b) where 157 | #if MIN_VERSION_template_haskell(2,16,0) 158 | liftTyped (lowerYoneda -> y) = [|| liftYoneda y ||] 159 | #else 160 | lift (lowerYoneda -> y) = [| liftYoneda y |] 161 | #endif 162 | 163 | -- ---------- 164 | -- Coyoneda 165 | 166 | data Coyoneda p a b where 167 | Coyoneda :: (x -> a) -> (y -> b) -> p x y -> Coyoneda p a b 168 | 169 | -- | A specialized version of 'bireturn'. 170 | liftCoyoneda :: p a b -> Coyoneda p a b 171 | liftCoyoneda = Coyoneda id id 172 | 173 | -- | A specialized version of 'biextract'. 174 | lowerCoyoneda :: Bifunctor p => Coyoneda p a b -> p a b 175 | lowerCoyoneda (Coyoneda f g p) = bimap f g p 176 | 177 | instance Functor (Coyoneda p a) where 178 | fmap f (Coyoneda xa yb pxy) = Coyoneda xa (f . yb) pxy 179 | 180 | instance Bifunctor (Coyoneda p) where 181 | bimap = \f g (Coyoneda h i p) -> Coyoneda (f . h) (g . i) p 182 | first = \f (Coyoneda h i p) -> Coyoneda (f . h) i p 183 | second = \g (Coyoneda h i p) -> Coyoneda h (g . i) p 184 | {-# inline bimap #-} 185 | {-# inline first #-} 186 | {-# inline second #-} 187 | 188 | instance Bifoldable p => Bifoldable (Coyoneda p) where 189 | bifoldMap = \f g (Coyoneda h i p) -> bifoldMap (f . h) (g . i) p 190 | {-# inline bifoldMap #-} 191 | 192 | instance Bitraversable p => Bitraversable (Coyoneda p) where 193 | bitraverse = \f g (Coyoneda h i p) -> liftCoyoneda <$> bitraverse (f . h) (g . i) p 194 | {-# inline bitraverse #-} 195 | 196 | instance (Foldable (p a), Bifunctor p) => Foldable (Coyoneda p a) where 197 | foldMap f (Coyoneda xa yb pxy) = fold (bimap xa (f . yb) pxy) 198 | 199 | instance (Traversable (p a), Bifunctor p) => Traversable (Coyoneda p a) where 200 | traverse f (Coyoneda xa yb pxy) = 201 | liftCoyoneda <$> sequenceA (bimap xa (f . yb) pxy) 202 | 203 | instance Biapplicative p => Biapplicative (Coyoneda p) where 204 | bipure a b = bireturn (bipure a b) 205 | {-# inline bipure #-} 206 | biliftA2 = \f g (Coyoneda h i p) (Coyoneda j k q) -> 207 | bireturn $ biliftA2 208 | (\x x1 -> f (h x) (j x1)) 209 | (\y y1 -> g (i y) (k y1)) 210 | p 211 | q 212 | {-# inline biliftA2 #-} 213 | (<<*>>) = \(Coyoneda h i p) (Coyoneda j k q) -> 214 | bireturn $ biliftA2 215 | (\x x1 -> h x (j x1)) 216 | (\y y1 -> i y (k y1)) 217 | p 218 | q 219 | {-# inline (<<*>>) #-} 220 | 221 | instance BifunctorFunctor Coyoneda where 222 | bifmap f (Coyoneda h i p) = Coyoneda h i (f p) 223 | {-# inline bifmap #-} 224 | 225 | instance BifunctorMonad Coyoneda where 226 | bireturn = Coyoneda id id 227 | bijoin = \(Coyoneda f g (Coyoneda h i p)) -> Coyoneda (f . h) (g . i) p 228 | {-# inline bireturn #-} 229 | {-# inline bijoin #-} 230 | 231 | instance BifunctorComonad Coyoneda where 232 | biextract (Coyoneda f g p) = bimap f g p 233 | biduplicate = bireturn 234 | {-# inline biextract #-} 235 | {-# inline biduplicate #-} 236 | 237 | instance (Eq (p a b), Bifunctor p) => Eq (Coyoneda p a b) where 238 | (==) = (==) `on` lowerCoyoneda 239 | 240 | instance (Eq1 (p a), Bifunctor p) => Eq1 (Coyoneda p a) where 241 | liftEq eq x y = liftEq eq (lowerCoyoneda x) (lowerCoyoneda y) 242 | 243 | instance (Eq2 p, Bifunctor p) => Eq2 (Coyoneda p) where 244 | liftEq2 f g x y = liftEq2 f g (lowerCoyoneda x) (lowerCoyoneda y) 245 | 246 | instance (Ord (p a b), Bifunctor p) => Ord (Coyoneda p a b) where 247 | compare = compare `on` lowerCoyoneda 248 | -- This min leans on the underlying instance, which is nice, but 249 | -- it also unconditionally rewraps, which isn't so nice if 250 | -- the underlying instance just does a plain compare and choose. 251 | -- I think it's still a reasonable choice, since Coyoneda may 252 | -- be used in certain lazy situations where the underlying instance 253 | -- may be important. 254 | min x y = liftCoyoneda $ (min `on` lowerCoyoneda) x y 255 | max x y = liftCoyoneda $ (max `on` lowerCoyoneda) x y 256 | 257 | instance (Ord1 (p a), Bifunctor p) => Ord1 (Coyoneda p a) where 258 | liftCompare cmp x y = liftCompare cmp (lowerCoyoneda x) (lowerCoyoneda y) 259 | 260 | instance (Ord2 p, Bifunctor p) => Ord2 (Coyoneda p) where 261 | liftCompare2 f g x y = liftCompare2 f g (lowerCoyoneda x) (lowerCoyoneda y) 262 | 263 | instance (Show (p a b), Bifunctor p) => Show (Coyoneda p a b) where 264 | showsPrec = showsUnaryWith (\i -> showsPrec i . lowerCoyoneda) "liftCoyoneda" 265 | 266 | instance (Show1 (p a), Bifunctor p) => Show1 (Coyoneda p a) where 267 | liftShowsPrec sp sl = showsUnaryWith (\i -> liftShowsPrec sp sl i . lowerCoyoneda) "liftCoyoneda" 268 | 269 | instance (Show2 p, Bifunctor p) => Show2 (Coyoneda p) where 270 | liftShowsPrec2 sp1 sl1 sp2 sl2 = showsUnaryWith (\i -> liftShowsPrec2 sp1 sl1 sp2 sl2 i . lowerCoyoneda) "liftCoyoneda" 271 | 272 | instance Read (p a b) => Read (Coyoneda p a b) where 273 | readPrec = readData $ readUnaryWith readPrec "liftCoyoneda" liftCoyoneda 274 | readListPrec = readListPrecDefault 275 | 276 | instance Read1 (p a) => Read1 (Coyoneda p a) where 277 | liftReadPrec rp rl = readData $ readUnaryWith (liftReadPrec rp rl) "liftCoyoneda" liftCoyoneda 278 | liftReadListPrec = liftReadListPrecDefault 279 | 280 | instance Read2 p => Read2 (Coyoneda p) where 281 | liftReadPrec2 rp1 rl1 rp2 rl2 = readData $ readUnaryWith (liftReadPrec2 rp1 rl1 rp2 rl2) "liftCoyoneda" liftCoyoneda 282 | liftReadListPrec2 = liftReadListPrec2Default 283 | 284 | instance (TestEquality (p a), Bifunctor p) => TestEquality (Coyoneda p a) where 285 | testEquality x y = testEquality (lowerCoyoneda x) (lowerCoyoneda y) 286 | 287 | instance (TestCoercion (p a), Bifunctor p) => TestCoercion (Coyoneda p a) where 288 | testCoercion x y = testCoercion (lowerCoyoneda x) (lowerCoyoneda y) 289 | 290 | instance (THS.Lift (p a b), Bifunctor p) => THS.Lift (Coyoneda p a b) where 291 | #if MIN_VERSION_template_haskell(2,16,0) 292 | liftTyped (lowerCoyoneda -> y) = [|| liftCoyoneda y ||] 293 | #else 294 | lift (lowerCoyoneda -> y) = [| liftCoyoneda y |] 295 | #endif 296 | -------------------------------------------------------------------------------- /CHANGELOG.markdown: -------------------------------------------------------------------------------- 1 | 6 [unreleased] 2 | -------------- 3 | * Invert dependency on `distributive`. 4 | * Drop support for GHC < 8.6. 5 | * Change the `Functor`, `Foldable` and `Traversable` for `Biff` and `Tannen` to allow 6 | better usage in `profunctors` and smooth the road to quantified constraints as 7 | superclasses of `Bifunctor`, `Bifoldable`, `Bitraversable`, which are already in 8 | `base` and harder to change, and to allow it in `Profunctor` today. 9 | * Use `DeriveTraversable` consistently. This is necessary for quantified constraints 10 | now and in the future. 11 | * `BifunctorFunctor` now has a quantified constraint on taking bifunctors to 12 | bifunctors, like it should. 13 | * Added `Day` convolution of bifunctors, which shows that `Biapplicative` expresses 14 | the notion of a monoidal bifunctor. 15 | * Adopted (#.) and (.#) internally to reduce unnecessary eta-expansion. 16 | * The instance `Enum (Data.Bifunctor.Biap a b)` has been removed as it is incompatible 17 | with the pointwise lifting of `Bounded`. 18 | * Added missing `Contravariant` instances 19 | * Add `Data.Biapplicative.Backwards` and `Data.Bifunctor.Reverse` as analogues 20 | of `Control.Applicative.Backwards` and `Data.Functor.Reverse`. 21 | * Add `TestEquality` and `TestCoercion` instances for relevant types. 22 | * Change all `Show`, `Show1`, and `Show2` instances for newtypes to plain syntax 23 | rather than record syntax, and make all their `Read`, `Read1`, and `Read2` 24 | instances flexible, so they'll accept either plain or record syntax. Consolidate 25 | almost all reading and showing details in a single internal module. 26 | * Make instances use `FlexibleContexts` instead of `Show2`, `Eq2`, etc., with certain 27 | exceptions for the `WrappedBifunctor` type. 28 | * Add `liftYoneda`, `lowerYoneda`, `liftCoyoneda`, and `lowerCoyoneda`. Use these 29 | to add many basic instances for `Yoneda` and `Coyoneda`. 30 | * Add numerous basic instances for `Data.Bifunctor.Functor.Fix`. 31 | * Slightly clarify/improve the `Biapplicative` instance for `Joker`. 32 | * Make `bifoldr` for `Joker` use `foldl` and `bifoldr` use `foldr`. Do the 33 | same for `Clown`. 34 | * Make the `Functor` instance for `Coyoneda` do the obvious `Coyoneda` 35 | thing. 36 | * Add Template Haskell `Lift` instances for all the types other than `Day`. 37 | * Add a `Category` instance for `Flip`. 38 | 39 | 5.6.2 [2024.03.19] 40 | ------------------ 41 | * Support building with `template-haskell-2.22.*` (GHC 9.10). 42 | 43 | 5.6.1 [2023.03.13] 44 | ------------------ 45 | * Provide instances for the `Swap` and `Assoc` type classes from the `assoc` 46 | package. (These instances were previously defined in `assoc` itself, but they 47 | have been migrated over to `bifunctors` in tandem with the `assoc-1.1` 48 | release.) 49 | * Only depend on `bifunctor-classes-compat` if building with GHC 8.0. 50 | 51 | 5.6 [2023.03.12] 52 | ---------------- 53 | * Drop support for GHC 7.10 and earlier. 54 | * Move the `Data.Bifunctor`, `Data.Bifoldable`, and `Data.Bitraversable` 55 | compatibility modules to the new `bifunctor-classes-compat` package. For 56 | backwards compatibility, the `bifunctors` library re-exports 57 | `Data.Bifoldable` and `Data.Bitraversable` modules from 58 | `bifunctor-classes-compat` when building with GHC 8.0. 59 | 60 | If your library depends on `bifunctors` and compiles with pre-8.2 61 | versions of GHC, be warned that it may be possible to construct a 62 | build plan involving a pre-`5.6` version of `bifunctors` where: 63 | 64 | * Some of the `Bifunctor` instances come from 65 | `bifunctor-classes-compat`'s compatibility classes, and 66 | * Other `Bifunctor` instances come from `bifunctors`'s compatibility classes. 67 | 68 | These compatibility classes are distinct, so this could lead to build errors 69 | under certain conditions. Some possible ways to mitigate this risk include: 70 | 71 | * Drop support for GHC 8.0 and older in your library. 72 | * Require `bifunctors >= 5.6` in your library. 73 | * If neither of the options above are viable, then you can temporarily 74 | define instances for the old compatibility classes from `bifunctors` like 75 | so: 76 | 77 | ```hs 78 | -- For Bifunctor instances 79 | import qualified "bifunctor-classes-compat" Data.Bifunctor as BifunctorCompat 80 | #if !MIN_VERSION_bifunctors(5,6,0) && !MIN_VERSION_base(4,8,0) 81 | import qualified "bifunctors" Data.Bifunctor as Bifunctor 82 | #endif 83 | 84 | instance BifunctorCompat.Bifunctor MyType where ... 85 | 86 | #if !MIN_VERSION_bifunctors(5,6,0) && !MIN_VERSION_base(4,8,0) 87 | instance Bifunctor.Bifunctor MyType where ... 88 | #endif 89 | ``` 90 | 91 | ```hs 92 | -- For Bifoldable and Bitraversable instances 93 | import qualified "bifunctor-classes-compat" Data.Bifoldable as BifoldableCompat 94 | import qualified "bifunctor-classes-compat" Data.Bitraversable as BitraversableCompat 95 | #if !MIN_VERSION_bifunctors(5,6,0) && !MIN_VERSION_base(4,10,0) 96 | import qualified "bifunctors" Data.Bifoldable as Bifoldable 97 | import qualified "bifunctors" Data.Bitraversable as Bitraversable 98 | #endif 99 | 100 | instance BifoldableCompat.Bifoldable MyType where ... 101 | instance BitraversableCompat.Bitraversable MyType where ... 102 | 103 | #if !MIN_VERSION_bifunctors(5,6,0) && !MIN_VERSION_base(4,10,0) 104 | instance Bifoldable.Bifoldable MyType where ... 105 | instance Bitraversable.Bitraversable MyType where ... 106 | #endif 107 | ``` 108 | 109 | If your package does nothing but define instances of `Bifunctor` _et al._, 110 | you may consider replacing your `bifunctors` dependency with 111 | `bifunctor-classes-compat` to reduce your dependency footprint. If you do, 112 | it is strongly recommended that you bump your package's major version number 113 | so that your users are alerted to the details of the migration. 114 | * Define a `Foldable1` instance for `Joker`, and define `Bifoldable1` instances 115 | for `Biff`, `Clown`, `Flip`, `Join`, `Joker`, `Product`, `Tannen`, and 116 | `WrappedBifunctor`. These instances were originally defined in the 117 | `semigroupoids` library, and they have now been migrated to `bifunctors` as 118 | a side effect of adapting to 119 | [this Core Libraries Proposal](https://github.com/haskell/core-libraries-committee/issues/9), 120 | which adds `Foldable1` and `Bifoldable1` to `base`. 121 | 122 | 5.5.15 [2023.02.27] 123 | ------------------- 124 | * Support `th-abstraction-0.5.*`. 125 | 126 | 5.5.14 [2022.12.07] 127 | ------------------- 128 | * Define `Functor`, `Foldable`, and `Traversable` instances for `Sum` and 129 | `Product`. 130 | 131 | 5.5.13 [2022.09.12] 132 | ------------------- 133 | * Make the `Biapplicative` instances for tuples lazy, to match their `Bifunctor` 134 | instances. 135 | 136 | 5.5.12 [2022.05.07] 137 | ------------------- 138 | * Backport an upstream GHC change which removes the default implementation of 139 | `bitraverse`. Per the discussion in 140 | https://github.com/haskell/core-libraries-committee/issues/47, this default 141 | implementation was completely broken, as attempting to use it would always 142 | result in an infinite loop. 143 | 144 | 5.5.11 [2021.04.30] 145 | ------------------- 146 | * Allow building with `template-haskell-2.18` (GHC 9.2). 147 | 148 | 5.5.10 [2021.01.21] 149 | ------------------- 150 | * Fix a bug in which `deriveBifoldable` could generate code that triggers 151 | `-Wunused-matches` warnings. 152 | 153 | 5.5.9 [2020.12.30] 154 | ------------------ 155 | * Explicitly mark modules as Safe or Trustworthy. 156 | 157 | 5.5.8 [2020.10.01] 158 | ------------------ 159 | * Fix a bug in which `deriveBifunctor` would fail on sufficiently complex uses 160 | of rank-n types in constructor fields. 161 | * Fix a bug in which `deriveBiunctor` and related functions would needlessly 162 | reject data types whose two last type parameters appear as oversaturated 163 | arguments to a type family. 164 | 165 | 5.5.7 [2020.01.29] 166 | ------------------ 167 | * Add `Data.Bifunctor.Biap`. 168 | 169 | 5.5.6 [2019.11.26] 170 | ------------------ 171 | * Add `Category`, `Arrow`, `ArrowChoice`, `ArrowLoop`, `ArrowZero`, and 172 | `ArrowPlus` instances for `Data.Bifunctor.Product`. 173 | 174 | 5.5.5 [2019.08.27] 175 | ------------------ 176 | * Add `Eq{1,2}`, `Ord{1,2}`, `Read{1,2}`, and `Show{1,2}` instances for data 177 | types in the `Data.Bifunctor.*` module namespace where possible. The 178 | operative phrase is "where possible" since many of these instances require 179 | the use of `Eq2`/`Ord2`/`Read2`/`Show2`, which are not available when 180 | built against `transformers-0.4.*`. 181 | 182 | 5.5.4 [2019.04.26] 183 | ------------------ 184 | * Support `th-abstraction-0.3` or later. 185 | * Don't incur a `semigroup` dependency on recent GHCs. 186 | 187 | 5.5.3 [2018.07.04] 188 | ------------------ 189 | * Make `biliftA2` a class method of `Biapplicative`. 190 | * Add the `traverseBia`, `sequenceBia`, and `traverseBiaWith` functions for 191 | traversing a `Traversable` container in a `Biapplicative`. 192 | * Avoid incurring some dependencies when using recent GHCs. 193 | 194 | 5.5.2 [2018.02.06] 195 | ------------------ 196 | * Don't enable `Safe` on GHC 7.2. 197 | 198 | 5.5.1 [2018.02.04] 199 | ------------------ 200 | * Test suite fixes for GHC 8.4. 201 | 202 | 5.5 [2017.12.07] 203 | ---------------- 204 | * `Data.Bifunctor.TH` now derives `bimap`/`bitraverse` 205 | implementations for empty data types that are strict in the argument. 206 | * `Data.Bifunctor.TH` no longer derives `bifoldr`/`bifoldMap` implementations 207 | that error on empty data types. Instead, they simply return the folded state 208 | (for `bifoldr`) or `mempty` (for `bifoldMap`). 209 | * When using `Data.Bifunctor.TH` to derive `Bifunctor` or `Bitraversable` 210 | instances for data types where the last two type variables are at phantom 211 | roles, generated `bimap`/`bitraverse` implementations now use `coerce` for 212 | efficiency. 213 | * Add `Options` to `Data.Bifunctor.TH`, along with variants of existing 214 | functions that take `Options` as an argument. For now, the only configurable 215 | option is whether derived instances for empty data types should use the 216 | `EmptyCase` extension (this is disabled by default). 217 | 218 | 5.4.2 219 | ----- 220 | * 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) 221 | * Backport slightly more efficient implementations of `bimapDefault` and `bifoldMapDefault` 222 | 223 | 5.4.1 224 | ----- 225 | * Add explicit `Safe`, `Trustworthy`, and `Unsafe` annotations. In particular, annotate the `Data.Bifoldable` module as `Trustworthy` (previously, it was inferred to be `Unsafe`). 226 | 227 | 5.4 228 | --- 229 | * Only export `Data.Bifoldable` and `Data.Bitraversable` when building on GHC < 8.1, otherwise they come from `base` 230 | * Allow TH derivation of `Bifunctor` and `Bifoldable` instances for datatypes containing unboxed tuple types 231 | 232 | 5.3 233 | --- 234 | * Added `bifoldr1`, `bifoldl1`, `bimsum`, `biasum`, `binull`, `bilength`, `bielem`, `bimaximum`, `biminimum`, `bisum`, `biproduct`, `biand`, `bior`, `bimaximumBy`, `biminimumBy`, `binotElem`, and `bifind` to `Data.Bifoldable` 235 | * Added `Bifunctor`, `Bifoldable`, and `Bitraversable` instances for `GHC.Generics.K1` 236 | * TH code no longer generates superfluous `mempty` or `pure` subexpressions in derived `Bifoldable` or `Bitraversable` instances, respectively 237 | 238 | 5.2.1 239 | ---- 240 | * Added `Bifoldable` and `Bitraversable` instances for `Constant` from `transformers` 241 | * `Data.Bifunctor.TH` now compiles warning-free on GHC 8.0 242 | 243 | 5.2 244 | ----- 245 | * Added several `Arrow`-like instances for `Tannen` so we can use it as the Cayley construction if needed. 246 | * Added `Data.Bifunctor.Sum` 247 | * Added `BifunctorFunctor`, `BifunctorMonad` and `BifunctorComonad`. 248 | * Backported `Bifunctor Constant` instance from `transformers` 249 | 250 | 5.1 251 | --- 252 | * Added `Data.Bifunctor.Fix` 253 | * Added `Data.Bifunctor.TH`, which permits `TemplateHaskell`-based deriving of `Bifunctor`, `Bifoldable` and `Bitraversable` instances. 254 | * Simplified `Bitraversable`. 255 | 256 | 5 257 | - 258 | * Inverted the dependency on `semigroupoids`. We can support a much wider array of `base` versions than it can. 259 | * Added flags 260 | 261 | 4.2.1 262 | ----- 263 | * Support `Arg` from `semigroups` 0.16.2 264 | * Fixed a typo. 265 | 266 | 4.2 267 | --- 268 | * Bumped dependency on `tagged`, which is required to build cleanly on GHC 7.9+ 269 | * Only export `Data.Bifunctor` when building on GHC < 7.9, otherwise it comes from `base`. 270 | 271 | 4.1.1.1 272 | ------- 273 | * Added documentation for 'Bifoldable' and 'Bitraversable' 274 | 275 | 4.1.1 276 | ----- 277 | * Added `Data.Bifunctor.Join` 278 | * Fixed improper lower bounds on `base` 279 | 280 | 4.1.0.1 281 | ------- 282 | * Updated to BSD 2-clause license 283 | 284 | 4.1 285 | --- 286 | * Added product bifunctors 287 | 288 | 4.0 289 | --- 290 | * Compatibility with `semigroupoids` 4.0 291 | 292 | 3.2 293 | --- 294 | * Added missing product instances for `Biapplicative` and `Biapply`. 295 | 296 | 3.1 297 | ----- 298 | * Added `Data.Biapplicative`. 299 | * Added the `Clown` and `Joker` bifunctors from Conor McBride's "Clowns to the left of me, Jokers to the right." 300 | * Added instances for `Const`, higher tuples 301 | * Added `Tagged` instances. 302 | 303 | 3.0.4 304 | ----- 305 | * Added `Data.Bifunctor.Flip` and `Data.Bifunctor.Wrapped`. 306 | 307 | 3.0.3 308 | --- 309 | * Removed upper bounds from my other package dependencies 310 | -------------------------------------------------------------------------------- /src/Data/Bifunctor/TH/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskellQuotes #-} 2 | {-# LANGUAGE Unsafe #-} 3 | 4 | -- | 5 | -- Copyright: (C) 2008-2023 Edward Kmett, (C) 2015-2016 Ryan Scott 6 | -- License: BSD-2-Clause OR Apache-2.0 7 | -- Maintainer: Edward Kmett 8 | -- Portability: Template Haskell 9 | -- 10 | -- Template Haskell-related utilities. 11 | 12 | module Data.Bifunctor.TH.Internal where 13 | 14 | import Control.Applicative 15 | import Data.Bifunctor (Bifunctor(..)) 16 | import Data.Bifoldable (Bifoldable(..)) 17 | import Data.Bitraversable (Bitraversable(..)) 18 | import Data.Coerce (coerce) 19 | import Data.Foldable (foldr') 20 | import qualified Data.List as List 21 | import qualified Data.Map as Map (singleton) 22 | import Data.Map (Map) 23 | import Data.Maybe (fromMaybe, mapMaybe) 24 | import Data.Monoid (Dual(..), Endo(..)) 25 | import qualified Data.Set as Set 26 | import Data.Set (Set) 27 | 28 | import Language.Haskell.TH.Datatype 29 | import Language.Haskell.TH.Lib 30 | import Language.Haskell.TH.Syntax 31 | 32 | ------------------------------------------------------------------------------- 33 | -- Expanding type synonyms 34 | ------------------------------------------------------------------------------- 35 | 36 | applySubstitutionKind :: Map Name Kind -> Type -> Type 37 | applySubstitutionKind = applySubstitution 38 | 39 | substNameWithKind :: Name -> Kind -> Type -> Type 40 | substNameWithKind n k = applySubstitutionKind (Map.singleton n k) 41 | 42 | substNamesWithKindStar :: [Name] -> Type -> Type 43 | substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns 44 | 45 | ------------------------------------------------------------------------------- 46 | -- Type-specialized const functions 47 | ------------------------------------------------------------------------------- 48 | 49 | bimapConst :: p b d -> (a -> b) -> (c -> d) -> p a c -> p b d 50 | bimapConst = const . const . const 51 | {-# INLINE bimapConst #-} 52 | 53 | bifoldrConst :: c -> (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c 54 | bifoldrConst = const . const . const . const 55 | {-# INLINE bifoldrConst #-} 56 | 57 | bifoldMapConst :: m -> (a -> m) -> (b -> m) -> p a b -> m 58 | bifoldMapConst = const . const . const 59 | {-# INLINE bifoldMapConst #-} 60 | 61 | bitraverseConst :: f (t c d) -> (a -> f c) -> (b -> f d) -> t a b -> f (t c d) 62 | bitraverseConst = const . const . const 63 | {-# INLINE bitraverseConst #-} 64 | 65 | ------------------------------------------------------------------------------- 66 | -- StarKindStatus 67 | ------------------------------------------------------------------------------- 68 | 69 | -- | Whether a type is not of kind *, is of kind *, or is a kind variable. 70 | data StarKindStatus = NotKindStar 71 | | KindStar 72 | | IsKindVar Name 73 | deriving Eq 74 | 75 | -- | Does a Type have kind * or k (for some kind variable k)? 76 | canRealizeKindStar :: Type -> StarKindStatus 77 | canRealizeKindStar t 78 | | hasKindStar t = KindStar 79 | | otherwise = case t of 80 | SigT _ (VarT k) -> IsKindVar k 81 | _ -> NotKindStar 82 | 83 | -- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists. 84 | -- Otherwise, returns 'Nothing'. 85 | starKindStatusToName :: StarKindStatus -> Maybe Name 86 | starKindStatusToName (IsKindVar n) = Just n 87 | starKindStatusToName _ = Nothing 88 | 89 | -- | Concat together all of the StarKindStatuses that are IsKindVar and extract 90 | -- the kind variables' Names out. 91 | catKindVarNames :: [StarKindStatus] -> [Name] 92 | catKindVarNames = mapMaybe starKindStatusToName 93 | 94 | ------------------------------------------------------------------------------- 95 | -- Assorted utilities 96 | ------------------------------------------------------------------------------- 97 | 98 | -- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed) 99 | 100 | -- | 'filterByList' takes a list of Bools and a list of some elements and 101 | -- filters out these elements for which the corresponding value in the list of 102 | -- Bools is False. This function does not check whether the lists have equal 103 | -- length. 104 | filterByList :: [Bool] -> [a] -> [a] 105 | filterByList (True:bs) (x:xs) = x : filterByList bs xs 106 | filterByList (False:bs) (_:xs) = filterByList bs xs 107 | filterByList _ _ = [] 108 | 109 | -- | 'filterByLists' takes a list of Bools and two lists as input, and 110 | -- outputs a new list consisting of elements from the last two input lists. For 111 | -- each Bool in the list, if it is 'True', then it takes an element from the 112 | -- former list. If it is 'False', it takes an element from the latter list. 113 | -- The elements taken correspond to the index of the Bool in its list. 114 | -- For example: 115 | -- 116 | -- @ 117 | -- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" 118 | -- @ 119 | -- 120 | -- This function does not check whether the lists have equal length. 121 | filterByLists :: [Bool] -> [a] -> [a] -> [a] 122 | filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys 123 | filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys 124 | filterByLists _ _ _ = [] 125 | 126 | -- | 'partitionByList' takes a list of Bools and a list of some elements and 127 | -- partitions the list according to the list of Bools. Elements corresponding 128 | -- to 'True' go to the left; elements corresponding to 'False' go to the right. 129 | -- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ 130 | -- This function does not check whether the lists have equal 131 | -- length. 132 | partitionByList :: [Bool] -> [a] -> ([a], [a]) 133 | partitionByList = go [] [] 134 | where 135 | go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs 136 | go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs 137 | go trues falses _ _ = (reverse trues, reverse falses) 138 | 139 | -- | Returns True if a Type has kind *. 140 | hasKindStar :: Type -> Bool 141 | hasKindStar VarT{} = True 142 | hasKindStar (SigT _ StarT) = True 143 | hasKindStar _ = False 144 | 145 | -- Returns True is a kind is equal to *, or if it is a kind variable. 146 | isStarOrVar :: Kind -> Bool 147 | isStarOrVar StarT = True 148 | isStarOrVar VarT{} = True 149 | isStarOrVar _ = False 150 | 151 | -- | @hasKindVarChain n kind@ Checks if @kind@ is of the form 152 | -- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or 153 | -- kind variables. 154 | hasKindVarChain :: Int -> Type -> Maybe [Name] 155 | hasKindVarChain kindArrows t = 156 | let uk = uncurryKind (tyKind t) 157 | in if (length uk - 1 == kindArrows) && all isStarOrVar uk 158 | then Just (freeVariables uk) 159 | else Nothing 160 | 161 | -- | If a Type is a SigT, returns its kind signature. Otherwise, return *. 162 | tyKind :: Type -> Kind 163 | tyKind (SigT _ k) = k 164 | tyKind _ = starK 165 | 166 | -- | A mapping of type variable Names to their map function Names. For example, in a 167 | -- Bifunctor declaration, a TyVarMap might look like (a ~> f, b ~> g), where 168 | -- a and b are the last two type variables of the datatype, and f and g are the two 169 | -- functions which map their respective type variables. 170 | type TyVarMap = Map Name Name 171 | 172 | thd3 :: (a, b, c) -> c 173 | thd3 (_, _, c) = c 174 | 175 | unsnoc :: [a] -> Maybe ([a], a) 176 | unsnoc [] = Nothing 177 | unsnoc (x:xs) = case unsnoc xs of 178 | Nothing -> Just ([], x) 179 | Just (a,b) -> Just (x:a, b) 180 | 181 | -- | Generate a list of fresh names with a common prefix, and numbered suffixes. 182 | newNameList :: String -> Int -> Q [Name] 183 | newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] 184 | 185 | -- | Applies a typeclass constraint to a type. 186 | applyClass :: Name -> Name -> Pred 187 | applyClass con t = AppT (ConT con) (VarT t) 188 | 189 | -- | Checks to see if the last types in a data family instance can be safely eta- 190 | -- reduced (i.e., dropped), given the other types. This checks for three conditions: 191 | -- 192 | -- (1) All of the dropped types are type variables 193 | -- (2) All of the dropped types are distinct 194 | -- (3) None of the remaining types mention any of the dropped types 195 | canEtaReduce :: [Type] -> [Type] -> Bool 196 | canEtaReduce remaining dropped = 197 | all isTyVar dropped 198 | && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type 199 | -- didn't have an Ord instance until template-haskell-2.10.0.0 200 | && not (any (`mentionsName` droppedNames) remaining) 201 | where 202 | droppedNames :: [Name] 203 | droppedNames = map varTToName dropped 204 | 205 | -- | Extract Just the Name from a type variable. If the argument Type is not a 206 | -- type variable, return Nothing. 207 | varTToName_maybe :: Type -> Maybe Name 208 | varTToName_maybe (VarT n) = Just n 209 | varTToName_maybe (SigT t _) = varTToName_maybe t 210 | varTToName_maybe _ = Nothing 211 | 212 | -- | Extract the Name from a type variable. If the argument Type is not a 213 | -- type variable, throw an error. 214 | varTToName :: Type -> Name 215 | varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe 216 | 217 | -- | Peel off a kind signature from a Type (if it has one). 218 | unSigT :: Type -> Type 219 | unSigT (SigT t _) = t 220 | unSigT t = t 221 | 222 | -- | Is the given type a variable? 223 | isTyVar :: Type -> Bool 224 | isTyVar (VarT _) = True 225 | isTyVar (SigT t _) = isTyVar t 226 | isTyVar _ = False 227 | 228 | -- | Detect if a Name in a list of provided Names occurs as an argument to some 229 | -- type family. This makes an effort to exclude /oversaturated/ arguments to 230 | -- type families. For instance, if one declared the following type family: 231 | -- 232 | -- @ 233 | -- type family F a :: Type -> Type 234 | -- @ 235 | -- 236 | -- Then in the type @F a b@, we would consider @a@ to be an argument to @F@, 237 | -- but not @b@. 238 | isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool 239 | isInTypeFamilyApp names tyFun tyArgs = 240 | case tyFun of 241 | ConT tcName -> go tcName 242 | _ -> return False 243 | where 244 | go :: Name -> Q Bool 245 | go tcName = do 246 | info <- reify tcName 247 | case info of 248 | FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ 249 | -> withinFirstArgs bndrs 250 | 251 | FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ 252 | -> withinFirstArgs bndrs 253 | 254 | _ -> return False 255 | where 256 | withinFirstArgs :: [a] -> Q Bool 257 | withinFirstArgs bndrs = 258 | let firstArgs = take (length bndrs) tyArgs 259 | argFVs = freeVariables firstArgs 260 | in return $ any (`elem` argFVs) names 261 | 262 | -- | Are all of the items in a list (which have an ordering) distinct? 263 | -- 264 | -- This uses Set (as opposed to nub) for better asymptotic time complexity. 265 | allDistinct :: Ord a => [a] -> Bool 266 | allDistinct = allDistinct' Set.empty 267 | where 268 | allDistinct' :: Ord a => Set a -> [a] -> Bool 269 | allDistinct' uniqs (x:xs) 270 | | x `Set.member` uniqs = False 271 | | otherwise = allDistinct' (Set.insert x uniqs) xs 272 | allDistinct' _ _ = True 273 | 274 | -- | Does the given type mention any of the Names in the list? 275 | mentionsName :: Type -> [Name] -> Bool 276 | mentionsName = go 277 | where 278 | go :: Type -> [Name] -> Bool 279 | go (AppT t1 t2) names = go t1 names || go t2 names 280 | go (SigT t _k) names = go t names 281 | || go _k names 282 | go (VarT n) names = n `elem` names 283 | go _ _ = False 284 | 285 | -- | Does an instance predicate mention any of the Names in the list? 286 | predMentionsName :: Pred -> [Name] -> Bool 287 | predMentionsName = mentionsName 288 | 289 | -- | Construct a type via curried application. 290 | applyTy :: Type -> [Type] -> Type 291 | applyTy = List.foldl' AppT 292 | 293 | -- | Fully applies a type constructor to its type variables. 294 | applyTyCon :: Name -> [Type] -> Type 295 | applyTyCon = applyTy . ConT 296 | 297 | -- | Split an applied type into its individual components. For example, this: 298 | -- 299 | -- @ 300 | -- Either Int Char 301 | -- @ 302 | -- 303 | -- would split to this: 304 | -- 305 | -- @ 306 | -- [Either, Int, Char] 307 | -- @ 308 | unapplyTy :: Type -> (Type, [Type]) 309 | unapplyTy ty = go ty ty [] 310 | where 311 | go :: Type -> Type -> [Type] -> (Type, [Type]) 312 | go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args) 313 | go origTy (SigT ty' _) args = go origTy ty' args 314 | go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args 315 | go origTy (ParensT ty') args = go origTy ty' args 316 | go origTy _ args = (origTy, args) 317 | 318 | -- | Split a type signature by the arrows on its spine. For example, this: 319 | -- 320 | -- @ 321 | -- forall a b. (a ~ b) => (a -> b) -> Char -> () 322 | -- @ 323 | -- 324 | -- would split to this: 325 | -- 326 | -- @ 327 | -- (a ~ b, [a -> b, Char, ()]) 328 | -- @ 329 | uncurryTy :: Type -> (Cxt, [Type]) 330 | uncurryTy (AppT (AppT ArrowT t1) t2) = 331 | let (ctxt, tys) = uncurryTy t2 332 | in (ctxt, t1:tys) 333 | uncurryTy (SigT t _) = uncurryTy t 334 | uncurryTy (ForallT _ ctxt t) = 335 | let (ctxt', tys) = uncurryTy t 336 | in (ctxt ++ ctxt', tys) 337 | uncurryTy t = ([], [t]) 338 | 339 | -- | Like uncurryType, except on a kind level. 340 | uncurryKind :: Kind -> [Kind] 341 | uncurryKind = snd . uncurryTy 342 | 343 | ------------------------------------------------------------------------------- 344 | -- Quoted names 345 | ------------------------------------------------------------------------------- 346 | 347 | bimapConstValName :: Name 348 | bimapConstValName = 'bimapConst 349 | 350 | bifoldrConstValName :: Name 351 | bifoldrConstValName = 'bifoldrConst 352 | 353 | bifoldMapConstValName :: Name 354 | bifoldMapConstValName = 'bifoldMapConst 355 | 356 | coerceValName :: Name 357 | coerceValName = 'coerce 358 | 359 | bitraverseConstValName :: Name 360 | bitraverseConstValName = 'bitraverseConst 361 | 362 | wrapMonadDataName :: Name 363 | wrapMonadDataName = 'WrapMonad 364 | 365 | functorTypeName :: Name 366 | functorTypeName = ''Functor 367 | 368 | foldableTypeName :: Name 369 | foldableTypeName = ''Foldable 370 | 371 | traversableTypeName :: Name 372 | traversableTypeName = ''Traversable 373 | 374 | composeValName :: Name 375 | composeValName = '(.) 376 | 377 | idValName :: Name 378 | idValName = 'id 379 | 380 | errorValName :: Name 381 | errorValName = 'error 382 | 383 | flipValName :: Name 384 | flipValName = 'flip 385 | 386 | fmapValName :: Name 387 | fmapValName = 'fmap 388 | 389 | foldrValName :: Name 390 | foldrValName = 'foldr 391 | 392 | foldMapValName :: Name 393 | foldMapValName = 'foldMap 394 | 395 | seqValName :: Name 396 | seqValName = 'seq 397 | 398 | traverseValName :: Name 399 | traverseValName = 'traverse 400 | 401 | unwrapMonadValName :: Name 402 | unwrapMonadValName = 'unwrapMonad 403 | 404 | bifunctorTypeName :: Name 405 | bifunctorTypeName = ''Bifunctor 406 | 407 | bimapValName :: Name 408 | bimapValName = 'bimap 409 | 410 | pureValName :: Name 411 | pureValName = 'pure 412 | 413 | apValName :: Name 414 | apValName = '(<*>) 415 | 416 | liftA2ValName :: Name 417 | liftA2ValName = 'liftA2 418 | 419 | mappendValName :: Name 420 | mappendValName = 'mappend 421 | 422 | memptyValName :: Name 423 | memptyValName = 'mempty 424 | 425 | bifoldableTypeName :: Name 426 | bifoldableTypeName = ''Bifoldable 427 | 428 | bitraversableTypeName :: Name 429 | bitraversableTypeName = ''Bitraversable 430 | 431 | bifoldrValName :: Name 432 | bifoldrValName = 'bifoldr 433 | 434 | bifoldMapValName :: Name 435 | bifoldMapValName = 'bifoldMap 436 | 437 | bitraverseValName :: Name 438 | bitraverseValName = 'bitraverse 439 | 440 | appEndoValName :: Name 441 | appEndoValName = 'appEndo 442 | 443 | dualDataName :: Name 444 | dualDataName = 'Dual 445 | 446 | endoDataName :: Name 447 | endoDataName = 'Endo 448 | 449 | getDualValName :: Name 450 | getDualValName = 'getDual 451 | -------------------------------------------------------------------------------- /src/Data/Biapplicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE Trustworthy #-} 6 | 7 | -- | 8 | -- Copyright : (C) 2011-2021 Edward Kmett 9 | -- License : BSD-2-Clause OR Apache-2.0 10 | -- Maintainer : Edward Kmett 11 | -- Stability : provisional 12 | -- Portability : portable 13 | -- 14 | -- A 'Biapplicative' functor is a monoidal 'Bifunctor'. 15 | -- 16 | -- That is to say it is a monoid object in the monoidal 17 | -- category 18 | -- 19 | -- @([Hask*Hask] -> Hask,'Data.Bifunctor.Day',(,))@ 20 | 21 | module Data.Biapplicative 22 | ( 23 | -- * Biapplicative bifunctors 24 | Biapplicative(..) 25 | , biempty 26 | , biappend 27 | , (<<$>>) 28 | , (<<**>>) 29 | , biliftA3 30 | , traverseBia 31 | , sequenceBia 32 | , traverseBiaWith 33 | ) where 34 | 35 | import Control.Applicative 36 | import Data.Bifunctor.Classes 37 | import Data.Functor.Identity 38 | import Data.Orphans () 39 | import GHC.Exts (inline) 40 | import Data.Semigroup (Arg(..)) 41 | import qualified Data.Tree as Tree 42 | #if MIN_VERSION_containers (0,5,8) 43 | import qualified Data.Map.Internal as Map 44 | import qualified Data.IntMap.Internal as IM 45 | import qualified Data.Sequence.Internal as Seq 46 | #endif 47 | #if MIN_VERSION_containers (0,8,0) 48 | import qualified Data.IntSet.Internal.IntTreeCommons as IS 49 | #endif 50 | 51 | #ifdef MIN_VERSION_tagged 52 | import Data.Tagged 53 | #endif 54 | 55 | infixl 4 <<$>>, <<*>>, <<*, *>>, <<**>> 56 | (<<$>>) :: (a -> b) -> a -> b 57 | (<<$>>) = id 58 | {-# INLINE (<<$>>) #-} 59 | 60 | -- | A monoidal bifunctor 61 | class Bifunctor' p => Biapplicative p where 62 | {-# MINIMAL bipure, ((<<*>>) | biliftA2 ) #-} 63 | bipure :: a -> b -> p a b 64 | 65 | (<<*>>) :: p (a -> b) (c -> d) -> p a c -> p b d 66 | (<<*>>) = biliftA2 id id 67 | {-# INLINE (<<*>>) #-} 68 | 69 | -- | Lift binary functions 70 | biliftA2 :: (a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f 71 | biliftA2 = \f g a b -> bimap f g <<$>> a <<*>> b 72 | {-# INLINE biliftA2 #-} 73 | 74 | -- | 75 | -- @ 76 | -- a '*>>' b ≡ 'bimap' ('const' 'id') ('const' 'id') '<<$>>' a '<<*>>' b 77 | -- @ 78 | (*>>) :: p a b -> p c d -> p c d 79 | (*>>) = biliftA2 (const id) (const id) 80 | {-# INLINE (*>>) #-} 81 | 82 | -- | 83 | -- @ 84 | -- a '<<*' b ≡ 'bimap' 'const' 'const' '<<$>>' a '<<*>>' b 85 | -- @ 86 | (<<*) :: p a b -> p c d -> p a b 87 | (<<*) = biliftA2 const const 88 | {-# INLINE (<<*) #-} 89 | 90 | biempty :: Biapplicative p => p () () 91 | biempty = bipure () () 92 | {-# inline biempty #-} 93 | 94 | biappend :: Biapplicative p => p a b -> p c d -> p (a, c) (b, d) 95 | biappend = biliftA2 (,) (,) 96 | {-# inline biappend #-} 97 | 98 | (<<**>>) :: Biapplicative p => p a c -> p (a -> b) (c -> d) -> p b d 99 | (<<**>>) = biliftA2 (flip id) (flip id) 100 | {-# INLINE (<<**>>) #-} 101 | 102 | -- | Lift ternary functions 103 | biliftA3 :: Biapplicative w => (a -> b -> c -> d) -> (e -> f -> g -> h) -> w a e -> w b f -> w c g -> w d h 104 | biliftA3 = \f g a b c -> biliftA2 f g a b <<*>> c 105 | {-# INLINE biliftA3 #-} 106 | 107 | -- | Traverse a 'Traversable' container in a 'Biapplicative'. 108 | -- 109 | -- 'traverseBia' satisfies the following properties: 110 | -- 111 | -- [/Pairing/] 112 | -- 113 | -- @'traverseBia' (,) t = (t, t)@ 114 | -- 115 | -- [/Composition/] 116 | -- 117 | -- @'traverseBia' ('Data.Bifunctor.Biff.Biff' . 'bimap' g h . f) = 'Data.Bifunctor.Biff.Biff' . 'bimap' ('traverse' g) ('traverse' h) . 'traverseBia' f@ 118 | -- 119 | -- @'traverseBia' ('Data.Bifunctor.Tannen.Tannen' . 'fmap' f . g) = 'Data.Bifunctor.Tannen.Tannen' . 'fmap' ('traverseBia' f) . 'traverse' g@ 120 | -- 121 | -- [/Naturality/] 122 | -- 123 | -- @ t . 'traverseBia' f = 'traverseBia' (t . f) @ 124 | -- 125 | -- for every biapplicative transformation @t@. 126 | -- 127 | -- A /biapplicative transformation/ from a 'Biapplicative' @P@ to a 'Biapplicative' @Q@ 128 | -- is a function 129 | -- 130 | -- @t :: P a b -> Q a b@ 131 | -- 132 | -- preserving the 'Biapplicative' operations. That is, 133 | -- 134 | -- * @t ('bipure' x y) = 'bipure' x y@ 135 | -- 136 | -- * @t (x '<<*>>' y) = t x '<<*>>' t y@ 137 | -- 138 | -- === Performance note 139 | -- 140 | -- 'traverseBia' is fairly efficient, and uses compiler rewrite rules 141 | -- to be even more efficient for a few important types. However, 142 | -- if performance is critical, you might consider writing a container-specific 143 | -- implementation. 144 | -- 145 | -- The types subject to rewrite rules: '[]', 'Maybe', @'Either' a@, 'Identity', 146 | -- @'Const' a@, @'(,)' a@, @'Map.Map' k@, 'IM.IntMap', 'Seq.Seq', and 'Tree.Tree'. 147 | traverseBia :: (Traversable t, Biapplicative p) 148 | => (a -> p b c) -> t a -> p (t b) (t c) 149 | traverseBia = inline (traverseBiaWith traverse) 150 | -- We explicitly inline traverseBiaWith because it seems likely to help 151 | -- specialization. I'm not much of an expert at the inlining business, 152 | -- so I won't mind if someone else decides to do this differently. 153 | 154 | -- We use a staged INLINABLE so we can rewrite traverseBia to specialized 155 | -- versions for a few important types. 156 | {-# INLINABLE [1] traverseBia #-} 157 | 158 | -- | Perform all the 'Biapplicative' actions in a 'Traversable' container 159 | -- and produce a container with all the results. 160 | -- 161 | -- @ 162 | -- sequenceBia = 'traverseBia' id 163 | -- @ 164 | sequenceBia :: (Traversable t, Biapplicative p) 165 | => t (p b c) -> p (t b) (t c) 166 | sequenceBia = inline (traverseBia id) 167 | {-# INLINABLE sequenceBia #-} 168 | 169 | -- | A version of 'traverseBia' that doesn't care how the traversal is 170 | -- done. 171 | -- 172 | -- @ 173 | -- 'traverseBia' = traverseBiaWith traverse 174 | -- @ 175 | traverseBiaWith :: forall p a b c s t. Biapplicative p 176 | => (forall f x. Applicative f => (a -> f x) -> s -> f (t x)) 177 | -> (a -> p b c) -> s -> p (t b) (t c) 178 | traverseBiaWith trav = \p s -> smash p (trav One s) 179 | {-# INLINABLE traverseBiaWith #-} 180 | 181 | smash :: forall p t a b c. Biapplicative p 182 | => (a -> p b c) 183 | -> (forall x. Mag a x (t x)) 184 | -> p (t b) (t c) 185 | smash p = \m -> go m m 186 | where 187 | go :: forall x y. Mag a b x -> Mag a c y -> p x y 188 | go (Pure t) (Pure u) = bipure t u 189 | go (Map f x) (Map g y) = bimap f g (go x y) 190 | go (Ap fs xs) (Ap gs ys) = go fs gs <<*>> go xs ys 191 | go (LiftA2 f xs ys) (LiftA2 g zs ws) = biliftA2 f g (go xs zs) (go ys ws) 192 | go (One x) (One _) = p x 193 | go _ _ = impossibleError 194 | {-# INLINABLE smash #-} 195 | 196 | -- Let's not end up with a bunch of CallStack junk in the smash 197 | -- unfolding. 198 | impossibleError :: a 199 | impossibleError = error "Impossible: the arguments are always the same." 200 | 201 | -- This is used to reify a traversal for 'traverseBia'. It's a somewhat 202 | -- bogus 'Functor' and 'Applicative' closely related to 'Magma' from the 203 | -- @lens@ package. Valid traversals don't use (<$), (<*), or (*>), so 204 | -- we leave them out. We offer all the rest of the Functor and Applicative 205 | -- operations to improve performance: we generally want to keep the structure 206 | -- as small as possible. We might even consider using RULES to widen lifts 207 | -- when we can: 208 | -- 209 | -- liftA2 f x y <*> z ==> liftA3 f x y z, 210 | -- 211 | -- etc., up to the pointer tagging limit. But we do need to be careful. I don't 212 | -- *think* GHC will ever inline the traversal into the go function (because that 213 | -- would duplicate work), but if it did, and if different RULES fired for the 214 | -- two copies, everything would break horribly. 215 | -- 216 | -- Note: if it's necessary for some reason, we *could* relax GADTs to 217 | -- ExistentialQuantification by changing the type of One to 218 | -- 219 | -- One :: (b -> c) -> a -> Mag a b c 220 | -- 221 | -- where the function will always end up being id. But we allocate a *lot* 222 | -- of One constructors, so this would definitely be bad for performance. 223 | data Mag a b t where 224 | Pure :: t -> Mag a b t 225 | Map :: (x -> t) -> Mag a b x -> Mag a b t 226 | Ap :: Mag a b (t -> u) -> Mag a b t -> Mag a b u 227 | LiftA2 :: (t -> u -> v) -> Mag a b t -> Mag a b u -> Mag a b v 228 | One :: a -> Mag a b b 229 | 230 | instance Functor (Mag a b) where 231 | fmap = Map 232 | 233 | instance Applicative (Mag a b) where 234 | pure = Pure 235 | (<*>) = Ap 236 | liftA2 = LiftA2 237 | 238 | -- Rewrite rules for traversing a few important types. These avoid the overhead 239 | -- of allocating and matching on a Mag. 240 | {-# RULES 241 | "traverseBia/list" traverseBia = traverseBiaList 242 | "traverseBia/Maybe" traverseBia = traverseBiaMaybe 243 | "traverseBia/Either" traverseBia = traverseBiaEither 244 | "traverseBia/Identity" traverseBia = traverseBiaIdentity 245 | "traverseBia/Const" traverseBia = traverseBiaConst 246 | "traverseBia/Pair" traverseBia = traverseBiaPair 247 | "traverseBia/Tree" traverseBia = traverseBiaTree 248 | #-} 249 | 250 | #if MIN_VERSION_containers (0,5,8) 251 | {-# RULES 252 | "traverseBia/Map" traverseBia = traverseBiaMap 253 | "traverseBia/IntMap" traverseBia = traverseBiaIntMap 254 | "traverseBia/Seq" traverseBia = traverseBiaSeq 255 | #-} 256 | #endif 257 | 258 | traverseBiaList :: Biapplicative p => (a -> p b c) -> [a] -> p [b] [c] 259 | traverseBiaList f = foldr go (bipure [] []) 260 | where 261 | go x r = biliftA2 (:) (:) (f x) r 262 | 263 | traverseBiaMaybe :: Biapplicative p => (a -> p b c) -> Maybe a -> p (Maybe b) (Maybe c) 264 | traverseBiaMaybe _f Nothing = bipure Nothing Nothing 265 | traverseBiaMaybe f (Just x) = bimap Just Just (f x) 266 | 267 | traverseBiaEither :: Biapplicative p => (a -> p b c) -> Either e a -> p (Either e b) (Either e c) 268 | traverseBiaEither f (Right x) = bimap Right Right (f x) 269 | traverseBiaEither _f (Left (e :: e)) = bipure m m 270 | where 271 | m :: Either e x 272 | m = Left e 273 | 274 | traverseBiaIdentity :: Biapplicative p => (a -> p b c) -> Identity a -> p (Identity b) (Identity c) 275 | traverseBiaIdentity f (Identity x) = bimap Identity Identity (f x) 276 | 277 | traverseBiaConst :: Biapplicative p => (a -> p b c) -> Const x a -> p (Const x b) (Const x c) 278 | traverseBiaConst _f (Const x) = bipure (Const x) (Const x) 279 | 280 | traverseBiaPair :: Biapplicative p => (a -> p b c) -> (e, a) -> p (e, b) (e, c) 281 | traverseBiaPair f (x,y) = bimap ((,) x) ((,) x) (f y) 282 | 283 | {-# INLINE traverseBiaTree #-} 284 | traverseBiaTree :: Biapplicative p => (a -> p b c) -> Tree.Tree a -> p (Tree.Tree b) (Tree.Tree c) 285 | traverseBiaTree f = go 286 | where 287 | go (Tree.Node a ts) = biliftA2 Tree.Node Tree.Node (f a) (traverseBiaList go ts) 288 | 289 | #if MIN_VERSION_containers (0,5,8) 290 | {-# INLINE traverseBiaMap #-} 291 | traverseBiaMap :: Biapplicative p => (a -> p b c) -> Map.Map k a -> p (Map.Map k b) (Map.Map k c) 292 | traverseBiaMap f = \m -> go m 293 | where 294 | go Map.Tip = bipure Map.Tip Map.Tip 295 | go (Map.Bin 1 k v _ _) = 296 | bimap (\v' -> Map.Bin 1 k v' Map.Tip Map.Tip) 297 | (\v' -> Map.Bin 1 k v' Map.Tip Map.Tip) 298 | (f v) 299 | go (Map.Bin s k v l r) = 300 | biliftA3 (flip (Map.Bin s k)) (flip (Map.Bin s k)) 301 | (go l) (f v) (go r) 302 | 303 | {-# INLINE traverseBiaIntMap #-} 304 | traverseBiaIntMap :: Biapplicative p => (a -> p b c) -> IM.IntMap a -> p (IM.IntMap b) (IM.IntMap c) 305 | traverseBiaIntMap f = go 306 | where 307 | go IM.Nil = bipure IM.Nil IM.Nil 308 | go (IM.Tip k v) = bimap (IM.Tip k) (IM.Tip k) (f v) 309 | # if MIN_VERSION_containers (0,8,0) 310 | go (IM.Bin p l r) 311 | | IS.signBranch p = biliftA2 (flip (IM.Bin p)) (flip (IM.Bin p)) (go r) (go l) 312 | | otherwise = biliftA2 (IM.Bin p) (IM.Bin p) (go l) (go r) 313 | # else 314 | go (IM.Bin p m l r) 315 | | m < 0 = biliftA2 (flip (IM.Bin p m)) (flip (IM.Bin p m)) (go r) (go l) 316 | | otherwise = biliftA2 (IM.Bin p m) (IM.Bin p m) (go l) (go r) 317 | # endif 318 | 319 | {-# INLINABLE traverseBiaSeq #-} 320 | traverseBiaSeq :: Biapplicative p => (a -> p b c) -> Seq.Seq a -> p (Seq.Seq b) (Seq.Seq c) 321 | traverseBiaSeq _ (Seq.Seq Seq.EmptyT) = bipure (Seq.Seq Seq.EmptyT) (Seq.Seq Seq.EmptyT) 322 | traverseBiaSeq f' (Seq.Seq (Seq.Single (Seq.Elem x'))) = 323 | bimap (\x'' -> Seq.Seq (Seq.Single (Seq.Elem x''))) (\x'' -> Seq.Seq (Seq.Single (Seq.Elem x''))) (f' x') 324 | traverseBiaSeq f' (Seq.Seq (Seq.Deep s' pr' m' sf')) = 325 | biliftA3 326 | (\pr'' m'' sf'' -> Seq.Seq (Seq.Deep s' pr'' m'' sf'')) 327 | (\pr'' m'' sf'' -> Seq.Seq (Seq.Deep s' pr'' m'' sf'')) 328 | (traverseBiaDigitE f' pr') 329 | (traverseBiaFTree (traverseBiaNodeE f') m') 330 | (traverseBiaDigitE f' sf') 331 | where 332 | traverseBiaFTree 333 | :: Biapplicative p 334 | => (Seq.Node a -> p (Seq.Node b) (Seq.Node c)) 335 | -> Seq.FingerTree (Seq.Node a) 336 | -> p (Seq.FingerTree (Seq.Node b)) (Seq.FingerTree (Seq.Node c)) 337 | traverseBiaFTree _ Seq.EmptyT = bipure Seq.EmptyT Seq.EmptyT 338 | traverseBiaFTree f (Seq.Single x) = bimap Seq.Single Seq.Single (f x) 339 | traverseBiaFTree f (Seq.Deep s pr m sf) = 340 | biliftA3 341 | (Seq.Deep s) 342 | (Seq.Deep s) 343 | (traverseBiaDigitN f pr) 344 | (traverseBiaFTree (traverseBiaNodeN f) m) 345 | (traverseBiaDigitN f sf) 346 | traverseBiaDigitE 347 | :: Biapplicative p 348 | => (a -> p b c) -> Seq.Digit (Seq.Elem a) -> p (Seq.Digit (Seq.Elem b)) (Seq.Digit (Seq.Elem c)) 349 | traverseBiaDigitE f (Seq.One (Seq.Elem a)) = 350 | bimap (\a' -> Seq.One (Seq.Elem a')) (\a' -> Seq.One (Seq.Elem a')) (f a) 351 | traverseBiaDigitE f (Seq.Two (Seq.Elem a) (Seq.Elem b)) = 352 | biliftA2 353 | (\a' b' -> Seq.Two (Seq.Elem a') (Seq.Elem b')) 354 | (\a' b' -> Seq.Two (Seq.Elem a') (Seq.Elem b')) 355 | (f a) 356 | (f b) 357 | traverseBiaDigitE f (Seq.Three (Seq.Elem a) (Seq.Elem b) (Seq.Elem c)) = 358 | biliftA3 359 | (\a' b' c' -> 360 | Seq.Three (Seq.Elem a') (Seq.Elem b') (Seq.Elem c')) 361 | (\a' b' c' -> 362 | Seq.Three (Seq.Elem a') (Seq.Elem b') (Seq.Elem c')) 363 | (f a) 364 | (f b) 365 | (f c) 366 | traverseBiaDigitE f (Seq.Four (Seq.Elem a) (Seq.Elem b) (Seq.Elem c) (Seq.Elem d)) = 367 | biliftA3 368 | (\a' b' c' d' -> Seq.Four (Seq.Elem a') (Seq.Elem b') (Seq.Elem c') (Seq.Elem d')) 369 | (\a' b' c' d' -> Seq.Four (Seq.Elem a') (Seq.Elem b') (Seq.Elem c') (Seq.Elem d')) 370 | (f a) 371 | (f b) 372 | (f c) <<*>> 373 | (f d) 374 | traverseBiaDigitN 375 | :: Biapplicative p 376 | => (Seq.Node a -> p (Seq.Node b) (Seq.Node c)) -> Seq.Digit (Seq.Node a) -> p (Seq.Digit (Seq.Node b)) (Seq.Digit (Seq.Node c)) 377 | traverseBiaDigitN f t = traverseBia f t 378 | traverseBiaNodeE 379 | :: Biapplicative p 380 | => (a -> p b c) -> Seq.Node (Seq.Elem a) -> p (Seq.Node (Seq.Elem b)) (Seq.Node (Seq.Elem c)) 381 | traverseBiaNodeE f (Seq.Node2 s (Seq.Elem a) (Seq.Elem b)) = 382 | biliftA2 383 | (\a' b' -> Seq.Node2 s (Seq.Elem a') (Seq.Elem b')) 384 | (\a' b' -> Seq.Node2 s (Seq.Elem a') (Seq.Elem b')) 385 | (f a) 386 | (f b) 387 | traverseBiaNodeE f (Seq.Node3 s (Seq.Elem a) (Seq.Elem b) (Seq.Elem c)) = 388 | biliftA3 389 | (\a' b' c' -> 390 | Seq.Node3 s (Seq.Elem a') (Seq.Elem b') (Seq.Elem c')) 391 | (\a' b' c' -> 392 | Seq.Node3 s (Seq.Elem a') (Seq.Elem b') (Seq.Elem c')) 393 | (f a) 394 | (f b) 395 | (f c) 396 | traverseBiaNodeN 397 | :: Biapplicative p 398 | => (Seq.Node a -> p (Seq.Node b) (Seq.Node c)) -> Seq.Node (Seq.Node a) -> p (Seq.Node (Seq.Node b)) (Seq.Node (Seq.Node c)) 399 | traverseBiaNodeN f t = traverseBia f t 400 | #endif 401 | 402 | ---------------------------------------------- 403 | -- 404 | -- Instances 405 | 406 | instance Biapplicative (,) where 407 | bipure = (,) 408 | {-# INLINE bipure #-} 409 | ~(f, g) <<*>> ~(a, b) = (f a, g b) 410 | {-# INLINE (<<*>>) #-} 411 | biliftA2 f g ~(x, y) ~(a, b) = (f x a, g y b) 412 | {-# INLINE biliftA2 #-} 413 | 414 | instance Biapplicative Arg where 415 | bipure = Arg 416 | {-# INLINE bipure #-} 417 | Arg f g <<*>> Arg a b = Arg (f a) (g b) 418 | {-# INLINE (<<*>>) #-} 419 | biliftA2 f g (Arg x y) (Arg a b) = Arg (f x a) (g y b) 420 | {-# INLINE biliftA2 #-} 421 | 422 | instance Monoid x => Biapplicative ((,,) x) where 423 | bipure = (,,) mempty 424 | {-# INLINE bipure #-} 425 | ~(x, f, g) <<*>> ~(x', a, b) = (mappend x x', f a, g b) 426 | {-# INLINE (<<*>>) #-} 427 | 428 | instance (Monoid x, Monoid y) => Biapplicative ((,,,) x y) where 429 | bipure = (,,,) mempty mempty 430 | {-# INLINE bipure #-} 431 | ~(x, y, f, g) <<*>> ~(x', y', a, b) = (mappend x x', mappend y y', f a, g b) 432 | {-# INLINE (<<*>>) #-} 433 | 434 | {- 435 | instance (Monoid x, Monoid y, Monoid z) => Biapplicative ((,,,,) x y z) where 436 | bipure = (,,,,) mempty mempty mempty 437 | {-# INLINE bipure #-} 438 | ~(x, y, z, f, g) <<*>> ~(x', y', z', a, b) = (mappend x x', mappend y y', mappend z z', f a, g b) 439 | {-# INLINE (<<*>>) #-} 440 | 441 | instance (Monoid x, Monoid y, Monoid z, Monoid w) => Biapplicative ((,,,,,) x y z w) where 442 | bipure = (,,,,,) mempty mempty mempty mempty 443 | {-# INLINE bipure #-} 444 | ~(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) 445 | {-# INLINE (<<*>>) #-} 446 | 447 | instance (Monoid x, Monoid y, Monoid z, Monoid w, Monoid v) => Biapplicative ((,,,,,,) x y z w v) where 448 | bipure = (,,,,,,) mempty mempty mempty mempty mempty 449 | {-# INLINE bipure #-} 450 | ~(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) 451 | {-# INLINE (<<*>>) #-} 452 | -} 453 | 454 | instance Biapplicative Tagged where 455 | bipure _ b = Tagged b 456 | {-# INLINE bipure #-} 457 | 458 | Tagged f <<*>> Tagged x = Tagged (f x) 459 | {-# INLINE (<<*>>) #-} 460 | 461 | instance Biapplicative Const where 462 | bipure a _ = Const a 463 | {-# INLINE bipure #-} 464 | Const f <<*>> Const x = Const (f x) 465 | {-# INLINE (<<*>>) #-} 466 | -------------------------------------------------------------------------------- /tests/BifunctorSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveTraversable #-} 3 | {-# LANGUAGE EmptyDataDecls #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE MagicHash #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TupleSections #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | #if __GLASGOW_HASKELL__ >= 708 17 | {-# LANGUAGE EmptyCase #-} 18 | {-# LANGUAGE RoleAnnotations #-} 19 | #endif 20 | 21 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 22 | {-# OPTIONS_GHC -fno-warn-unused-matches #-} 23 | #if __GLASGOW_HASKELL__ >= 800 24 | {-# OPTIONS_GHC -fno-warn-unused-foralls #-} 25 | #endif 26 | 27 | -- | 28 | -- Module: BifunctorSpec 29 | -- Copyright: (C) 2008-2023 Edward Kmett, (C) 2015 Ryan Scott 30 | -- License: BSD-2-Clause OR Apache-2.0 31 | -- Maintainer: Edward Kmett 32 | -- Portability: Template Haskell 33 | -- 34 | -- @hspec@ tests for the "Data.Bifunctor.TH" module. 35 | 36 | module BifunctorSpec where 37 | 38 | import Data.Bifunctor 39 | import Data.Bifunctor.TH 40 | import Data.Bifoldable 41 | import Data.Bitraversable 42 | 43 | import Data.Char (chr) 44 | import Data.Functor.Classes (Eq1, Show1) 45 | import Data.Functor.Compose (Compose(..)) 46 | import Data.Functor.Identity (Identity(..)) 47 | import Data.Monoid 48 | 49 | import GHC.Exts (Int#) 50 | 51 | import Test.Hspec 52 | import Test.Hspec.QuickCheck (prop) 53 | import Test.QuickCheck (Arbitrary) 54 | 55 | #if !(MIN_VERSION_base(4,8,0)) 56 | import Control.Applicative (Applicative(..)) 57 | import Data.Foldable (Foldable) 58 | import Data.Traversable (Traversable) 59 | #endif 60 | 61 | ------------------------------------------------------------------------------- 62 | 63 | -- Adapted from the test cases from 64 | -- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch 65 | 66 | -- Plain data types 67 | 68 | data Strange a b c 69 | = T1 a b c 70 | | T2 [a] [b] [c] -- lists 71 | | T3 [[a]] [[b]] [[c]] -- nested lists 72 | | T4 (c,(b,b),(c,c)) -- tuples 73 | | T5 ([c],Strange a b c) -- tycons 74 | deriving (Functor, Foldable, Traversable) 75 | 76 | type IntFun a b = (b -> Int) -> a 77 | data StrangeFunctions a b c 78 | = T6 (a -> c) -- function types 79 | | T7 (a -> (c,a)) -- functions and tuples 80 | | T8 ((b -> a) -> c) -- continuation 81 | | T9 (IntFun b c) -- type synonyms 82 | deriving Functor 83 | 84 | data StrangeGADT a b where 85 | T10 :: Ord d => d -> StrangeGADT c d 86 | T11 :: Int -> StrangeGADT e Int 87 | T12 :: c ~ Int => c -> StrangeGADT f Int 88 | T13 :: i ~ Int => Int -> StrangeGADT h i 89 | T14 :: k ~ Int => k -> StrangeGADT j k 90 | T15 :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADT m n 91 | deriving instance Foldable (StrangeGADT a) 92 | 93 | data NotPrimitivelyRecursive a b 94 | = S1 (NotPrimitivelyRecursive (a,a) (b, a)) 95 | | S2 a 96 | | S3 b 97 | deriving (Functor, Foldable, Traversable) 98 | 99 | newtype OneTwoCompose f g a b = OneTwoCompose (f (g a b)) 100 | deriving (Arbitrary, Eq, Foldable, Functor, Show, Traversable) 101 | 102 | newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g a,a,b)) 103 | instance (Bifunctor (f Int), Functor g) => 104 | Functor (ComplexConstraint f g a) where 105 | fmap f (ComplexConstraint x) = 106 | ComplexConstraint (bimap id (\(ga,a,b) -> (ga,a,f b)) x) 107 | instance (Bifoldable (f Int), Foldable g) => 108 | Foldable (ComplexConstraint f g a) where 109 | foldMap f (ComplexConstraint x) = 110 | bifoldMap (const mempty) (\(_,_,b) -> f b) x 111 | instance (Bitraversable (f Int), Traversable g) => 112 | Traversable (ComplexConstraint f g a) where 113 | traverse f (ComplexConstraint x) = 114 | ComplexConstraint <$> bitraverse pure (\(ga,a,b) -> (ga,a,) <$> f b) x 115 | 116 | data Universal a b 117 | = Universal (forall b. (b,[a])) 118 | | Universal2 (forall f. Bifunctor f => f a b) 119 | | Universal3 (forall a. Maybe a) -- reuse a 120 | | NotReallyUniversal (forall b. a) 121 | instance Functor (Universal a) where 122 | fmap f (Universal x) = Universal x 123 | fmap f (Universal2 x) = Universal2 (bimap id f x) 124 | fmap f (Universal3 x) = Universal3 x 125 | fmap f (NotReallyUniversal x) = NotReallyUniversal x 126 | 127 | data Existential a b 128 | = forall a. ExistentialList [a] 129 | | forall f. Bitraversable f => ExistentialFunctor (f a b) 130 | | forall b. SneakyUseSameName (Maybe b) 131 | instance Functor (Existential a) where 132 | fmap f (ExistentialList x) = ExistentialList x 133 | fmap f (ExistentialFunctor x) = ExistentialFunctor (bimap id f x) 134 | fmap f (SneakyUseSameName x) = SneakyUseSameName x 135 | instance Foldable (Existential a) where 136 | foldMap f (ExistentialList _) = mempty 137 | foldMap f (ExistentialFunctor x) = bifoldMap (const mempty) f x 138 | foldMap f (SneakyUseSameName _) = mempty 139 | instance Traversable (Existential a) where 140 | traverse f (ExistentialList x) = pure $ ExistentialList x 141 | traverse f (ExistentialFunctor x) = ExistentialFunctor <$> bitraverse pure f x 142 | traverse f (SneakyUseSameName x) = pure $ SneakyUseSameName x 143 | 144 | data IntHash a b 145 | = IntHash Int# Int# 146 | | IntHashTuple Int# a b (a, b, Int, IntHash Int (a, b, Int)) 147 | deriving (Functor, Foldable, Traversable) 148 | 149 | data IntHashFun a b 150 | = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a) 151 | deriving Functor 152 | 153 | data Empty1 a b 154 | deriving (Functor, Foldable, Traversable) 155 | 156 | data Empty2 a b 157 | deriving (Functor, Foldable, Traversable) 158 | #if __GLASGOW_HASKELL__ >= 708 159 | type role Empty2 nominal nominal 160 | #endif 161 | 162 | data TyCon81 a b 163 | = TyCon81a (forall c. c -> (forall d. a -> d) -> a) 164 | | TyCon81b (Int -> forall c. c -> b) 165 | instance Functor (TyCon81 a) where 166 | fmap f (TyCon81a g) = TyCon81a g 167 | fmap f (TyCon81b g) = TyCon81b (\x y -> f (g x y)) 168 | 169 | type family F :: * -> * -> * 170 | type instance F = Either 171 | 172 | data TyCon82 a b = TyCon82 (F a b) 173 | deriving (Functor, Foldable, Traversable) 174 | 175 | -- Data families 176 | 177 | data family StrangeFam x y z 178 | data instance StrangeFam a b c 179 | = T1Fam a b c 180 | | T2Fam [a] [b] [c] -- lists 181 | | T3Fam [[a]] [[b]] [[c]] -- nested lists 182 | | T4Fam (c,(b,b),(c,c)) -- tuples 183 | | T5Fam ([c],Strange a b c) -- tycons 184 | deriving (Functor, Foldable, Traversable) 185 | 186 | data family StrangeFunctionsFam x y z 187 | data instance StrangeFunctionsFam a b c 188 | = T6Fam (a -> c) -- function types 189 | | T7Fam (a -> (c,a)) -- functions and tuples 190 | | T8Fam ((b -> a) -> c) -- continuation 191 | | T9Fam (IntFun b c) -- type synonyms 192 | deriving Functor 193 | 194 | data family StrangeGADTFam x y 195 | data instance StrangeGADTFam a b where 196 | T10Fam :: Ord d => d -> StrangeGADTFam c d 197 | T11Fam :: Int -> StrangeGADTFam e Int 198 | T12Fam :: c ~ Int => c -> StrangeGADTFam f Int 199 | T13Fam :: i ~ Int => Int -> StrangeGADTFam h i 200 | T14Fam :: k ~ Int => k -> StrangeGADTFam j k 201 | T15Fam :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADTFam m n 202 | deriving instance Foldable (StrangeGADTFam a) 203 | 204 | data family NotPrimitivelyRecursiveFam x y 205 | data instance NotPrimitivelyRecursiveFam a b 206 | = S1Fam (NotPrimitivelyRecursive (a,a) (b, a)) 207 | | S2Fam a 208 | | S3Fam b 209 | deriving (Functor, Foldable, Traversable) 210 | 211 | data family OneTwoComposeFam (j :: * -> *) (k :: * -> * -> *) x y 212 | newtype instance OneTwoComposeFam f g a b = OneTwoComposeFam (f (g a b)) 213 | deriving (Arbitrary, Eq, Foldable, Functor, Show, Traversable) 214 | 215 | data family ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y 216 | newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b)) 217 | instance (Bifunctor (f Int), Functor g) => 218 | Functor (ComplexConstraintFam f g a) where 219 | fmap f (ComplexConstraintFam x) = 220 | ComplexConstraintFam (bimap id (\(ga,a,b) -> (ga,a,f b)) x) 221 | instance (Bifoldable (f Int), Foldable g) => 222 | Foldable (ComplexConstraintFam f g a) where 223 | foldMap f (ComplexConstraintFam x) = 224 | bifoldMap (const mempty) (\(_,_,b) -> f b) x 225 | instance (Bitraversable (f Int), Traversable g) => 226 | Traversable (ComplexConstraintFam f g a) where 227 | traverse f (ComplexConstraintFam x) = 228 | ComplexConstraintFam <$> bitraverse pure (\(ga,a,b) -> (ga,a,) <$> f b) x 229 | 230 | data family UniversalFam x y 231 | data instance UniversalFam a b 232 | = UniversalFam (forall b. (b,[a])) 233 | | Universal2Fam (forall f. Bifunctor f => f a b) 234 | | Universal3Fam (forall a. Maybe a) -- reuse a 235 | | NotReallyUniversalFam (forall b. a) 236 | instance Functor (UniversalFam a) where 237 | fmap f (UniversalFam x) = UniversalFam x 238 | fmap f (Universal2Fam x) = Universal2Fam (bimap id f x) 239 | fmap f (Universal3Fam x) = Universal3Fam x 240 | fmap f (NotReallyUniversalFam x) = NotReallyUniversalFam x 241 | 242 | data family ExistentialFam x y 243 | data instance ExistentialFam a b 244 | = forall a. ExistentialListFam [a] 245 | | forall f. Bitraversable f => ExistentialFunctorFam (f a b) 246 | | forall b. SneakyUseSameNameFam (Maybe b) 247 | instance Functor (ExistentialFam a) where 248 | fmap f (ExistentialListFam x) = ExistentialListFam x 249 | fmap f (ExistentialFunctorFam x) = ExistentialFunctorFam (bimap id f x) 250 | fmap f (SneakyUseSameNameFam x) = SneakyUseSameNameFam x 251 | instance Foldable (ExistentialFam a) where 252 | foldMap f (ExistentialListFam _) = mempty 253 | foldMap f (ExistentialFunctorFam x) = bifoldMap (const mempty) f x 254 | foldMap f (SneakyUseSameNameFam _) = mempty 255 | instance Traversable (ExistentialFam a) where 256 | traverse f (ExistentialListFam x) = pure $ ExistentialListFam x 257 | traverse f (ExistentialFunctorFam x) = ExistentialFunctorFam <$> bitraverse pure f x 258 | traverse f (SneakyUseSameNameFam x) = pure $ SneakyUseSameNameFam x 259 | 260 | data family IntHashFam x y 261 | data instance IntHashFam a b 262 | = IntHashFam Int# Int# 263 | | IntHashTupleFam Int# a b (a, b, Int, IntHashFam Int (a, b, Int)) 264 | deriving (Functor, Foldable, Traversable) 265 | 266 | data family IntHashFunFam x y 267 | data instance IntHashFunFam a b 268 | = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a) 269 | deriving Functor 270 | 271 | data family TyFamily81 x y 272 | data instance TyFamily81 a b 273 | = TyFamily81a (forall c. c -> (forall d. a -> d) -> a) 274 | | TyFamily81b (Int -> forall c. c -> b) 275 | instance Functor (TyFamily81 a) where 276 | fmap f (TyFamily81a g) = TyFamily81a g 277 | fmap f (TyFamily81b g) = TyFamily81b (\x y -> f (g x y)) 278 | 279 | data family TyFamily82 x y 280 | data instance TyFamily82 a b = TyFamily82 (F a b) 281 | deriving (Functor, Foldable, Traversable) 282 | 283 | ------------------------------------------------------------------------------- 284 | 285 | -- Plain data types 286 | 287 | $(deriveBifunctor ''Strange) 288 | $(deriveBifoldable ''Strange) 289 | $(deriveBitraversable ''Strange) 290 | 291 | $(deriveBifunctor ''StrangeFunctions) 292 | $(deriveBifoldable ''StrangeGADT) 293 | 294 | $(deriveBifunctor ''NotPrimitivelyRecursive) 295 | $(deriveBifoldable ''NotPrimitivelyRecursive) 296 | $(deriveBitraversable ''NotPrimitivelyRecursive) 297 | 298 | $(deriveBifunctor ''OneTwoCompose) 299 | $(deriveBifoldable ''OneTwoCompose) 300 | $(deriveBitraversable ''OneTwoCompose) 301 | 302 | instance (Bifunctor (f Int), Functor g) => 303 | Bifunctor (ComplexConstraint f g) where 304 | bimap = $(makeBimap ''ComplexConstraint) 305 | 306 | instance (Bifoldable (f Int), Foldable g) => 307 | Bifoldable (ComplexConstraint f g) where 308 | bifoldr = $(makeBifoldr ''ComplexConstraint) 309 | bifoldMap = $(makeBifoldMap ''ComplexConstraint) 310 | 311 | bifoldlComplexConstraint 312 | :: (Bifoldable (f Int), Foldable g) 313 | => (c -> a -> c) -> (c -> b -> c) -> c -> ComplexConstraint f g a b -> c 314 | bifoldlComplexConstraint = $(makeBifoldl ''ComplexConstraint) 315 | 316 | bifoldComplexConstraint 317 | :: (Bifoldable (f Int), Foldable g, Monoid m) 318 | => ComplexConstraint f g m m -> m 319 | bifoldComplexConstraint = $(makeBifold ''ComplexConstraint) 320 | 321 | instance (Bitraversable (f Int), Traversable g) => 322 | Bitraversable (ComplexConstraint f g) where 323 | bitraverse = $(makeBitraverse ''ComplexConstraint) 324 | 325 | bisequenceAComplexConstraint 326 | :: (Bitraversable (f Int), Traversable g, Applicative t) 327 | => ComplexConstraint f g (t a) (t b) -> t (ComplexConstraint f g a b) 328 | bisequenceAComplexConstraint = $(makeBisequenceA ''ComplexConstraint) 329 | 330 | $(deriveBifunctor ''Universal) 331 | 332 | $(deriveBifunctor ''Existential) 333 | $(deriveBifoldable ''Existential) 334 | $(deriveBitraversable ''Existential) 335 | 336 | $(deriveBifunctor ''IntHash) 337 | $(deriveBifoldable ''IntHash) 338 | $(deriveBitraversable ''IntHash) 339 | 340 | $(deriveBifunctor ''IntHashFun) 341 | 342 | $(deriveBifunctor ''Empty1) 343 | $(deriveBifoldable ''Empty1) 344 | $(deriveBitraversable ''Empty1) 345 | 346 | -- Use EmptyCase here 347 | $(deriveBifunctorOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) 348 | $(deriveBifoldableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) 349 | $(deriveBitraversableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) 350 | 351 | $(deriveBifunctor ''TyCon81) 352 | 353 | $(deriveBifunctor ''TyCon82) 354 | $(deriveBifoldable ''TyCon82) 355 | $(deriveBitraversable ''TyCon82) 356 | 357 | #if MIN_VERSION_template_haskell(2,7,0) 358 | -- Data families 359 | 360 | $(deriveBifunctor 'T1Fam) 361 | $(deriveBifoldable 'T2Fam) 362 | $(deriveBitraversable 'T3Fam) 363 | 364 | $(deriveBifunctor 'T6Fam) 365 | $(deriveBifoldable 'T10Fam) 366 | 367 | $(deriveBifunctor 'S1Fam) 368 | $(deriveBifoldable 'S2Fam) 369 | $(deriveBitraversable 'S3Fam) 370 | 371 | $(deriveBifunctor 'OneTwoComposeFam) 372 | $(deriveBifoldable 'OneTwoComposeFam) 373 | $(deriveBitraversable 'OneTwoComposeFam) 374 | 375 | instance (Bifunctor (f Int), Functor g) => 376 | Bifunctor (ComplexConstraintFam f g) where 377 | bimap = $(makeBimap 'ComplexConstraintFam) 378 | 379 | instance (Bifoldable (f Int), Foldable g) => 380 | Bifoldable (ComplexConstraintFam f g) where 381 | bifoldr = $(makeBifoldr 'ComplexConstraintFam) 382 | bifoldMap = $(makeBifoldMap 'ComplexConstraintFam) 383 | 384 | bifoldlComplexConstraintFam 385 | :: (Bifoldable (f Int), Foldable g) 386 | => (c -> a -> c) -> (c -> b -> c) -> c -> ComplexConstraintFam f g a b -> c 387 | bifoldlComplexConstraintFam = $(makeBifoldl 'ComplexConstraintFam) 388 | 389 | bifoldComplexConstraintFam 390 | :: (Bifoldable (f Int), Foldable g, Monoid m) 391 | => ComplexConstraintFam f g m m -> m 392 | bifoldComplexConstraintFam = $(makeBifold 'ComplexConstraintFam) 393 | 394 | instance (Bitraversable (f Int), Traversable g) => 395 | Bitraversable (ComplexConstraintFam f g) where 396 | bitraverse = $(makeBitraverse 'ComplexConstraintFam) 397 | 398 | bisequenceAComplexConstraintFam 399 | :: (Bitraversable (f Int), Traversable g, Applicative t) 400 | => ComplexConstraintFam f g (t a) (t b) -> t (ComplexConstraintFam f g a b) 401 | bisequenceAComplexConstraintFam = $(makeBisequenceA 'ComplexConstraintFam) 402 | 403 | $(deriveBifunctor 'UniversalFam) 404 | 405 | $(deriveBifunctor 'ExistentialListFam) 406 | $(deriveBifoldable 'ExistentialFunctorFam) 407 | $(deriveBitraversable 'SneakyUseSameNameFam) 408 | 409 | $(deriveBifunctor 'IntHashFam) 410 | $(deriveBifoldable 'IntHashTupleFam) 411 | $(deriveBitraversable 'IntHashFam) 412 | 413 | $(deriveBifunctor 'IntHashFunFam) 414 | 415 | $(deriveBifunctor 'TyFamily81a) 416 | 417 | $(deriveBifunctor 'TyFamily82) 418 | $(deriveBifoldable 'TyFamily82) 419 | $(deriveBitraversable 'TyFamily82) 420 | #endif 421 | 422 | ------------------------------------------------------------------------------- 423 | 424 | prop_BifunctorLaws :: (Bifunctor p, Eq (p a b), Eq (p c d), Show (p a b), Show (p c d)) 425 | => (a -> c) -> (b -> d) -> p a b -> Expectation 426 | prop_BifunctorLaws f g x = do 427 | bimap id id x `shouldBe` x 428 | first id x `shouldBe` x 429 | second id x `shouldBe` x 430 | bimap f g x `shouldBe` (first f . second g) x 431 | 432 | prop_BifunctorEx :: (Bifunctor p, Eq (p [Int] [Int]), Show (p [Int] [Int])) => p [Int] [Int] -> Expectation 433 | prop_BifunctorEx = prop_BifunctorLaws reverse (++ [42]) 434 | 435 | prop_BifoldableLaws :: (Eq a, Eq b, Eq z, Show a, Show b, Show z, 436 | Monoid a, Monoid b, Bifoldable p) 437 | => (a -> b) -> (a -> b) 438 | -> (a -> z -> z) -> (a -> z -> z) 439 | -> z -> p a a -> Expectation 440 | prop_BifoldableLaws f g h i z x = do 441 | bifold x `shouldBe` bifoldMap id id x 442 | bifoldMap f g x `shouldBe` bifoldr (mappend . f) (mappend . g) mempty x 443 | bifoldr h i z x `shouldBe` appEndo (bifoldMap (Endo . h) (Endo . i) x) z 444 | 445 | prop_BifoldableEx :: Bifoldable p => p [Int] [Int] -> Expectation 446 | prop_BifoldableEx = prop_BifoldableLaws reverse (++ [42]) ((+) . length) ((*) . length) 0 447 | 448 | prop_BitraversableLaws :: (Applicative f, Applicative g, Bitraversable p, 449 | Eq (g (p c c)), Eq (p a b), Eq (p d e), Eq1 f, 450 | Show (g (p c c)), Show (p a b), Show (p d e), Show1 f) 451 | => (a -> f c) -> (b -> f c) -> (c -> f d) -> (c -> f e) 452 | -> (forall x. f x -> g x) -> p a b -> Expectation 453 | prop_BitraversableLaws f g h i t x = do 454 | bitraverse (t . f) (t . g) x `shouldBe` (t . bitraverse f g) x 455 | bitraverse Identity Identity x `shouldBe` Identity x 456 | (Compose . fmap (bitraverse h i) . bitraverse f g) x 457 | `shouldBe` bitraverse (Compose . fmap h . f) (Compose . fmap i . g) x 458 | 459 | prop_BitraversableEx :: (Bitraversable p, 460 | Eq (p Char Char), Eq (p [Char] [Char]), Eq (p [Int] [Int]), 461 | Show (p Char Char), Show (p [Char] [Char]), Show (p [Int] [Int])) 462 | => p [Int] [Int] -> Expectation 463 | prop_BitraversableEx = prop_BitraversableLaws 464 | (replicate 2 . map (chr . abs)) 465 | (replicate 4 . map (chr . abs)) 466 | (++ "hello") 467 | (++ "world") 468 | reverse 469 | 470 | ------------------------------------------------------------------------------- 471 | 472 | main :: IO () 473 | main = hspec spec 474 | 475 | spec :: Spec 476 | spec = do 477 | describe "OneTwoCompose Maybe Either [Int] [Int]" $ do 478 | prop "satisfies the Bifunctor laws" 479 | (prop_BifunctorEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) 480 | prop "satisfies the Bifoldable laws" 481 | (prop_BifoldableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) 482 | prop "satisfies the Bitraversable laws" 483 | (prop_BitraversableEx :: OneTwoCompose Maybe Either [Int] [Int] -> Expectation) 484 | #if MIN_VERSION_template_haskell(2,7,0) 485 | describe "OneTwoComposeFam Maybe Either [Int] [Int]" $ do 486 | prop "satisfies the Bifunctor laws" 487 | (prop_BifunctorEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation) 488 | prop "satisfies the Bifoldable laws" 489 | (prop_BifoldableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation) 490 | prop "satisfies the Bitraversable laws" 491 | (prop_BitraversableEx :: OneTwoComposeFam Maybe Either [Int] [Int] -> Expectation) 492 | #endif 493 | --------------------------------------------------------------------------------