diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,19 +1,23 @@ -## 0.2.0.0 - -- Add `gfoldMap`, `gtraverse`, `gbifoldMap`, `gbitraverse` `GFoldable`, `GFoldMap`, `GTraversable`, `GTraverse`, `GBiFoldable`, `GBifoldMap`, `GBitraversable`, `GBitraverse` -- Rename `GBifunctor` to `GBimap`, and add new `GBifunctor` (class synonym for `GBimap`, `GFirst`, and `GSecond`) -- Rename `DeriveFunctor` to `GenericFunctor`, and rename `DeriveBifunctor` to `GenericBifunctor` -- Add instances for deriving-via `Foldable` and `Bifoldable` - -## 0.1.0.0 - -- Add `gmultimap`, `multimap`, `(:+)` -- Add `DeriveBifunctor`, `gbimap`, `gfirst`, `gsecond` - -## 0.0.1.1 - -* Include README - -## 0.0.1.0 - -* Create generic-functor +## 1.0.0.0 + +- Split `Generic.Functor`, moving `gsolomap`, `solomap`, `gmultimap`, `multimap` to `Generic.Functor.Multimap` + +## 0.2.0.0 + +- Add `gfoldMap`, `gtraverse`, `gbifoldMap`, `gbitraverse` `GFoldable`, `GFoldMap`, `GTraversable`, `GTraverse`, `GBiFoldable`, `GBifoldMap`, `GBitraversable`, `GBitraverse` +- Rename `GBifunctor` to `GBimap`, and add new `GBifunctor` (class synonym for `GBimap`, `GFirst`, and `GSecond`) +- Rename `DeriveFunctor` to `GenericFunctor`, and rename `DeriveBifunctor` to `GenericBifunctor` +- Add instances for deriving-via `Foldable` and `Bifoldable` + +## 0.1.0.0 + +- Add `gmultimap`, `multimap`, `(:+)` +- Add `DeriveBifunctor`, `gbimap`, `gfirst`, `gsecond` + +## 0.0.1.1 + +* Include README + +## 0.0.1.0 + +* Create generic-functor diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,19 +1,19 @@ -Copyright Li-yao Xia (c) 2020 - -Permission is hereby granted, free of charge, to any person obtaining a copy of -this software and associated documentation files (the “Software”), to deal in -the Software without restriction, including without limitation the rights to -use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies -of the Software, and to permit persons to whom the Software is furnished to do -so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. +Copyright Li-yao Xia (c) 2020 + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the “Software”), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,209 +1,209 @@ -# Generic functors [![Hackage](https://img.shields.io/hackage/v/generic-functor.svg)](https://hackage.haskell.org/package/generic-functor) [![pipeline status](https://gitlab.com/lysxia/generic-functor/badges/main/pipeline.svg)](https://gitlab.com/lysxia/generic-functor/-/commits/main) - - -Implementation of `Functor` instances and other functor-like structures -using `GHC.Generics`. - -## Functors not over the last type parameter - -The standard `Functor` class only applies to types that are functors over their -last type parameter. For example, in `Either e r`, `fmap` maps only `r`. - -Using this library, `fmap`-like functions can be derived over any type -parameter of a `Generic` data type, all from the same definition `gsolomap`. - -```haskell -{-# LANGUAGE DeriveGeneric #-} - -import GHC.Generics (Generic) -import Generic.Functor (gsolomap) - -data Result a r = Error a | Ok r -- Another name for Either - deriving Generic - -mapError :: (a -> b) -> Result a r -> Result b r -mapError = gsolomap - --- This one is fmap -mapOk :: (a -> b) -> Result e a -> Result e b -mapOk = gsolomap - -mapBoth :: (a -> b) -> Result a a -> Result b b -mapBoth = gsolomap -``` - -`gsolomap` is **unsafe**. Misuse will break your program. -Read on for specifics. - -### Usage - -`gsolomap` should only be used to define **polymorphic** "`fmap`-like functions" -for `Generic` types. - -The signature of `gsolomap` is: - -```haskell -gsolomap :: (Generic x, Generic y, GSolomap a b x y) => (a -> b) -> (x -> y) -``` - -The types `x` and `y` must be specializations of the same user-defined `data` -type which is an instance of `Generic`, with some type parameters equal to `a` -or `b` respectively. At use sites of `gsolomap`, `a` and `b` must also be two -distinct universally quantified type variables, with no equality constraint -relating them with each other or any other type. - -The guarantee is that `gsolomap` satisfies `gsolomap id = id`. Under the -condition that `a` and `b` are abstract, that equation uniquely determines the -implementation. (That uniqueness claim may be broken with GADTs and other -explicit uses of type equality constraints.) - -In particular, `gsolomap` *must not* be specialized with types `a` and `b` that -are equal. A function defined using `gsolomap` is safe to specialize once -the `GSolomap` constraint has been discharged. - -For instance the three functions above, `mapError`, `mapOk`, `mapBoth` are -sufficiently polymorphic. -They are each uniquely determined by their types and the equation `mapX id = id`. -(Without that equation, `mapBoth` has four implementations of the same type.) - -## Compositions of functors - -How many `fmap` do you need to map a function `a -> b` over -`(t, Maybe [Either Bool a])`? - -You only need one `solomap`: - -```haskell -type F t a = (t, Maybe [Either Bool a]) - -maps :: (a -> b) -> F t a -> F t b -maps = solomap -``` - -`solomap` can also see through bifunctors and there may be more than -one occurrence of the type parameter `a`. - -```haskell -type F a = ([a], Either a ()) - -maps2 :: (a -> b) -> F a -> F b -maps2 = solomap -``` - -`solomap` is **unsafe**, subject to the same restrictions as `gsolomap`: -where `solomap` is used, the type of its first argument `(a -> b)` must refer -to two distinct universally quantified variables `a` and `b`. -Functions are safe to specialize only once the `Solomap` constraint is out of -their contexts. - -```haskell -solomap :: Solomap a b x y => (a -> b) -> (x -> y) -``` - -## Functors of multiple parameters - -You can also map with more than one function simultaneously. -For example with `a -> b` and `c -> d` over `(Maybe a, [(c, a)])`: - -```haskell -type F a c = (Maybe a, [(c, a)]) - -bimaps :: (a -> b) -> (c -> d) -> F a c -> F b d -bimaps f g = multimap (f :+ g :+ ()) -``` - -`multimap` takes a list of functions separated by `(:+)` and terminated by `()`. - -There is also a `gmultimap`, generalizing `gsolomap`. - -`gmultimap` and `multimap` are **unsafe**, similarly to `gsolomap` and `solomap`. - -## Deriving `Functor` - -This library enables `DerivingVia` for the `Functor` class. - -```haskell -{-# LANGUAGE DeriveGeneric, DerivingVia #-} - -import GHC.Generics (Generic) -import Generic.Functor (GenericFunctor(..)) - -data Twice a = Twice (Either a a) - deriving Generic - deriving Functor via (GenericFunctor Twice) -``` - -Note that there is already built-in support for deriving `Functor` in GHC with the -`DeriveFunctor` extension instead. If that extension ever chokes on a type, this -library might have a chance at handling it. (Open an issue if it does not!) - -The `Twice` example just above is not handled by the `DeriveFunctor` extension: - -```haskell -{-# LANGUAGE DeriveFunctor #-} - -data Twice a = Twice (Either a a) deriving Functor - -{- - error: - • Can't make a derived instance of ‘Functor Twice’: - Constructor ‘Twice’ must use the type variable only as the last argument of a data type --} -``` - -The [*generic-data*][generic-data] library also includes a generic implementation of `Functor`, -but only for instances of `Generic1`, which applies to much more restricted shapes -of `data` than `Generic`. - -## Deriving `Bifunctor` - -Similarly, we can use `DerivingVia` for the `Bifunctor` class -(from *base*, module `Data.Bifunctor`). - -```haskell -{-# LANGUAGE DeriveGeneric, DerivingVia #-} - -import GHC.Generics (Generic) -import Generic.Functor (GenericFunctor(..), GenericBifunctor(..)) - -data Tree a b = Node a (Tree a b) (Tree a b) | Leaf b - deriving Generic - deriving Functor via (GenericFunctor (Tree a)) - deriving Bifunctor via (GenericBifunctor Tree) -``` - -In summary, the newtype `GenericFunctor` can be used for `DerivingVia` -of the classes `Functor` and `Foldable`, and the newtype `GenericBifunctor` -for the classes `Bifunctor` and `Bifoldable`. - -Default implementations for the above classes are also available as standalone -functions (`gfmap`, `gfoldMap`, `gbimap`, `gbifoldMap`) and also for -`Traversable` and `Bitraversable` (`gtraverse`, `gbitraverse`). - ---- - -## Internal module policy - -The public API is `Generic.Functor`. Don't use `Generic.Functor.Internal`. - -## Future work - -- Functors in arbitrary categories. - -## Related links - -- [*generic-data*][generic-data]: utilities for `GHC.Generics` and deriving for - other standard classes. - -- [*generic-lens*][generic-lens]: the `params` traversal uses a very similar implementation. - -- [*one-liner*][one-liner]. [*product-profunctors*][pp] - -- [*Deriving Bifunctors with Generics*](https://kcsongor.github.io/generic-deriving-bifunctor/), - blogpost by Csongor Kiss, - describing the main idea for the implementation (using incoherent instances). - -[generic-data]: https://hackage.haskell.org/package/generic-data -[generic-lens]: https://hackage.haskell.org/package/generic-lens -[one-liner]: https://hackage.haskell.org/package/one-liner -[pp]: https://hackage.haskell.org/package/product-profunctors +# Generic functors [![Hackage](https://img.shields.io/hackage/v/generic-functor.svg)](https://hackage.haskell.org/package/generic-functor) [![pipeline status](https://gitlab.com/lysxia/generic-functor/badges/main/pipeline.svg)](https://gitlab.com/lysxia/generic-functor/-/commits/main) + + +Implementation of `Functor` instances and other functor-like structures +using `GHC.Generics`. + +## Functors not over the last type parameter + +The standard `Functor` class only applies to types that are functors over their +last type parameter. For example, in `Either e r`, `fmap` maps only `r`. + +Using this library, `fmap`-like functions can be derived over any type +parameter of a `Generic` data type, all from the same definition `gsolomap`. + +```haskell +{-# LANGUAGE DeriveGeneric #-} + +import GHC.Generics (Generic) +import Generic.Functor (gsolomap) + +data Result a r = Error a | Ok r -- Another name for Either + deriving Generic + +mapError :: (a -> b) -> Result a r -> Result b r +mapError = gsolomap + +-- This one is fmap +mapOk :: (a -> b) -> Result e a -> Result e b +mapOk = gsolomap + +mapBoth :: (a -> b) -> Result a a -> Result b b +mapBoth = gsolomap +``` + +`gsolomap` is **unsafe**. Misuse will break your program. +Read on for specifics. + +### Usage + +`gsolomap` should only be used to define **polymorphic** "`fmap`-like functions" +for `Generic` types. + +The signature of `gsolomap` is: + +```haskell +gsolomap :: (Generic x, Generic y, GSolomap a b x y) => (a -> b) -> (x -> y) +``` + +The types `x` and `y` must be specializations of the same user-defined `data` +type which is an instance of `Generic`, with some type parameters equal to `a` +or `b` respectively. At use sites of `gsolomap`, `a` and `b` must also be two +distinct universally quantified type variables, with no equality constraint +relating them with each other or any other type. + +The guarantee is that `gsolomap` satisfies `gsolomap id = id`. Under the +condition that `a` and `b` are abstract, that equation uniquely determines the +implementation. (That uniqueness claim may be broken with GADTs and other +explicit uses of type equality constraints.) + +In particular, `gsolomap` *must not* be specialized with types `a` and `b` that +are equal. A function defined using `gsolomap` is safe to specialize once +the `GSolomap` constraint has been discharged. + +For instance the three functions above, `mapError`, `mapOk`, `mapBoth` are +sufficiently polymorphic. +They are each uniquely determined by their types and the equation `mapX id = id`. +(Without that equation, `mapBoth` has four implementations of the same type.) + +## Compositions of functors + +How many `fmap` do you need to map a function `a -> b` over +`(t, Maybe [Either Bool a])`? + +You only need one `solomap`: + +```haskell +type F t a = (t, Maybe [Either Bool a]) + +maps :: (a -> b) -> F t a -> F t b +maps = solomap +``` + +`solomap` can also see through bifunctors and there may be more than +one occurrence of the type parameter `a`. + +```haskell +type F a = ([a], Either a ()) + +maps2 :: (a -> b) -> F a -> F b +maps2 = solomap +``` + +`solomap` is **unsafe**, subject to the same restrictions as `gsolomap`: +where `solomap` is used, the type of its first argument `(a -> b)` must refer +to two distinct universally quantified variables `a` and `b`. +Functions are safe to specialize only once the `Solomap` constraint is out of +their contexts. + +```haskell +solomap :: Solomap a b x y => (a -> b) -> (x -> y) +``` + +## Functors of multiple parameters + +You can also map with more than one function simultaneously. +For example with `a -> b` and `c -> d` over `(Maybe a, [(c, a)])`: + +```haskell +type F a c = (Maybe a, [(c, a)]) + +bimaps :: (a -> b) -> (c -> d) -> F a c -> F b d +bimaps f g = multimap (f :+ g :+ ()) +``` + +`multimap` takes a list of functions separated by `(:+)` and terminated by `()`. + +There is also a `gmultimap`, generalizing `gsolomap`. + +`gmultimap` and `multimap` are **unsafe**, similarly to `gsolomap` and `solomap`. + +## Deriving `Functor` + +This library enables `DerivingVia` for the `Functor` class. + +```haskell +{-# LANGUAGE DeriveGeneric, DerivingVia #-} + +import GHC.Generics (Generic) +import Generic.Functor (GenericFunctor(..)) + +data Twice a = Twice (Either a a) + deriving Generic + deriving Functor via (GenericFunctor Twice) +``` + +Note that there is already built-in support for deriving `Functor` in GHC with the +`DeriveFunctor` extension instead. If that extension ever chokes on a type, this +library might have a chance at handling it. (Open an issue if it does not!) + +The `Twice` example just above is not handled by the `DeriveFunctor` extension: + +```haskell +{-# LANGUAGE DeriveFunctor #-} + +data Twice a = Twice (Either a a) deriving Functor + +{- + error: + • Can't make a derived instance of ‘Functor Twice’: + Constructor ‘Twice’ must use the type variable only as the last argument of a data type +-} +``` + +The [*generic-data*][generic-data] library also includes a generic implementation of `Functor`, +but only for instances of `Generic1`, which applies to much more restricted shapes +of `data` than `Generic`. + +## Deriving `Bifunctor` + +Similarly, we can use `DerivingVia` for the `Bifunctor` class +(from *base*, module `Data.Bifunctor`). + +```haskell +{-# LANGUAGE DeriveGeneric, DerivingVia #-} + +import GHC.Generics (Generic) +import Generic.Functor (GenericFunctor(..), GenericBifunctor(..)) + +data Tree a b = Node a (Tree a b) (Tree a b) | Leaf b + deriving Generic + deriving Functor via (GenericFunctor (Tree a)) + deriving Bifunctor via (GenericBifunctor Tree) +``` + +In summary, the newtype `GenericFunctor` can be used for `DerivingVia` +of the classes `Functor` and `Foldable`, and the newtype `GenericBifunctor` +for the classes `Bifunctor` and `Bifoldable`. + +Default implementations for the above classes are also available as standalone +functions (`gfmap`, `gfoldMap`, `gbimap`, `gbifoldMap`) and also for +`Traversable` and `Bitraversable` (`gtraverse`, `gbitraverse`). + +--- + +## Internal module policy + +The public API is `Generic.Functor`. Don't use `Generic.Functor.Internal`. + +## Future work + +- Functors in arbitrary categories. + +## Related links + +- [*generic-data*][generic-data]: utilities for `GHC.Generics` and deriving for + other standard classes. + +- [*generic-lens*][generic-lens]: the `params` traversal uses a very similar implementation. + +- [*one-liner*][one-liner]. [*product-profunctors*][pp] + +- [*Deriving Bifunctors with Generics*](https://kcsongor.github.io/generic-deriving-bifunctor/), + blogpost by Csongor Kiss, + describing the main idea for the implementation (using incoherent instances). + +[generic-data]: https://hackage.haskell.org/package/generic-data +[generic-lens]: https://hackage.haskell.org/package/generic-lens +[one-liner]: https://hackage.haskell.org/package/one-liner +[pp]: https://hackage.haskell.org/package/product-profunctors diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/generic-functor.cabal b/generic-functor.cabal --- a/generic-functor.cabal +++ b/generic-functor.cabal @@ -1,44 +1,45 @@ -cabal-version: >=1.10 -name: generic-functor -version: 0.2.0.0 -synopsis: Deriving generalized functors with GHC.Generics -description: - Derive @fmap@, and other @fmap@-like functions where the - parameter of the functor could occur anywhere. - . - See the README for details. -homepage: https://gitlab.com/lysxia/generic-functor -bug-reports: https://gitlab.com/lysxia/generic-functor/-/issues -license: MIT -license-file: LICENSE -author: Li-yao Xia -maintainer: lysxia@gmail.com -copyright: Li-yao Xia 2020 -category: Generics -build-type: Simple -extra-source-files: CHANGELOG.md, README.md - -library - hs-source-dirs: src - exposed-modules: - Generic.Functor - Generic.Functor.Internal - Generic.Functor.Internal.Implicit - build-depends: - ap-normalize, - base >=4.12 && <4.15 - default-language: Haskell2010 - -test-suite examples - hs-source-dirs: test - main-is: test.hs - build-depends: - generic-functor, - transformers, - base - type: exitcode-stdio-1.0 - default-language: Haskell2010 - -source-repository head - type: git - location: https://gitlab.com/lysxia/generic-functor +cabal-version: >=1.10 +name: generic-functor +version: 1.0.0.0 +synopsis: Deriving generalized functors with GHC.Generics +description: + Derive @fmap@, and other @fmap@-like functions where the + parameter of the functor could occur anywhere. + . + See the README for details. +homepage: https://gitlab.com/lysxia/generic-functor +bug-reports: https://gitlab.com/lysxia/generic-functor/-/issues +license: MIT +license-file: LICENSE +author: Li-yao Xia +maintainer: lysxia@gmail.com +copyright: Li-yao Xia 2020 +category: Generics +build-type: Simple +extra-source-files: CHANGELOG.md, README.md + +library + hs-source-dirs: src + exposed-modules: + Generic.Functor + Generic.Functor.Multimap + Generic.Functor.Internal + Generic.Functor.Internal.Implicit + build-depends: + ap-normalize, + base >=4.12 && <5 + default-language: Haskell2010 + +test-suite examples + hs-source-dirs: test + main-is: test.hs + build-depends: + generic-functor, + transformers, + base + type: exitcode-stdio-1.0 + default-language: Haskell2010 + +source-repository head + type: git + location: https://gitlab.com/lysxia/generic-functor diff --git a/src/Generic/Functor.hs b/src/Generic/Functor.hs --- a/src/Generic/Functor.hs +++ b/src/Generic/Functor.hs @@ -1,63 +1,47 @@ --- | Generic and generalized functors. - -module Generic.Functor - ( -- * Derive functors - - -- ** Unary functors - gsolomap - , solomap - - -- ** N-ary functors - , gmultimap - , multimap - , (:+)(..) - - -- ** Derive Functor, Bifunctor, Foldable, Traversable - - -- *** DerivingVia - -- | The type synonyms 'GenericFunctor' and 'GenericBifunctor' can be - -- used with the @DerivingVia@ extension to derive 'Functor', 'Bifunctor', and 'Foldable'. - -- Sadly, 'Traversable' cannot be derived-via. - , GenericFunctor(..) - , GenericBifunctor(..) - - -- *** Generic method definitions - , gfmap - , gfoldMap - , gtraverse - - -- **** Bifunctors - , gbimap - , gfirst - , gsecond - , gbifoldMap - , gbitraverse - - -- * Auxiliary classes - - -- ** Related to standard classes - , GFunctor() - , GFoldable() - , GFoldMap() - , GTraversable() - , GTraverse() - - -- *** Bifunctors - , GBifunctor() - , GBimap() - , GFirst() - , GSecond() - , GBifoldable() - , GBifoldMap() - , GBitraversable() - , GBitraverse() - - -- ** Generalized functors - , GSolomap() - , Solomap() - , GMultimap() - , Multimap() - ) where - -import Generic.Functor.Internal -import Generic.Functor.Internal.Implicit +-- | Generic functors, foldables, and traversables. + +module Generic.Functor + ( -- * Derive functors + + -- ** Derive Functor, Bifunctor, Foldable, Traversable + + -- *** DerivingVia + -- | The type synonyms 'GenericFunctor' and 'GenericBifunctor' can be + -- used with the @DerivingVia@ extension to derive 'Functor', 'Bifunctor', and 'Foldable'. + -- Sadly, 'Traversable' cannot be derived-via. + GenericFunctor(..) + , GenericBifunctor(..) + + -- *** Generic method definitions + , gfmap + , gfoldMap + , gtraverse + + -- **** Bifunctors + , gbimap + , gfirst + , gsecond + , gbifoldMap + , gbitraverse + + -- * Auxiliary classes + + -- ** Related to standard classes + , GFunctor() + , GFoldable() + , GFoldMap() + , GTraversable() + , GTraverse() + + -- *** Bifunctors + , GBifunctor() + , GBimap() + , GFirst() + , GSecond() + , GBifoldable() + , GBifoldMap() + , GBitraversable() + , GBitraverse() + ) where + +import Generic.Functor.Internal diff --git a/src/Generic/Functor/Internal.hs b/src/Generic/Functor/Internal.hs --- a/src/Generic/Functor/Internal.hs +++ b/src/Generic/Functor/Internal.hs @@ -1,511 +1,511 @@ -{-# LANGUAGE - AllowAmbiguousTypes, - ConstraintKinds, - EmptyCase, - FlexibleContexts, - FlexibleInstances, - MultiParamTypeClasses, - QuantifiedConstraints, - RankNTypes, - ScopedTypeVariables, - TypeApplications, - TypeOperators, - UndecidableInstances #-} - -{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} - --- | This is an internal module. Look, don't touch. --- --- "Generic.Functor" is the public API. - -module Generic.Functor.Internal where - -import ApNormalize -import Control.Applicative (liftA2) -import Data.Bifoldable (Bifoldable(..)) -import Data.Bifunctor (Bifunctor(..)) -import Data.Coerce (coerce, Coercible) -import Data.Functor.Identity (Identity(..)) -import Data.Functor.Const (Const(..)) -import Data.Monoid (Endo(..)) -import GHC.Generics hiding (S) - -import Generic.Functor.Internal.Implicit - --- | Generic implementation of 'fmap'. See also 'GenericFunctor' for @DerivingVia@, --- using 'gfmap' under the hood. --- --- === Example --- --- @ --- {-\# LANGUAGE DeriveGeneric \#-} --- --- import "GHC.Generics" ('Generic') --- import "Generic.Functor" ('gfmap') --- --- data Twice a = Twice (Either a a) --- deriving 'Generic' --- --- instance 'Functor' Twice where --- 'fmap' = 'gfmap' --- @ --- --- Unlike 'gsolomap', 'gfmap' is safe to use in all contexts. -gfmap :: forall f a b. GFunctor f => (a -> b) -> (f a -> f b) -gfmap f = with @(GFunctorRep a b f) (to . gmapRep (defaultIncoherent f) . from) - --- | Generalized generic functor. --- --- 'gsolomap' is a generalization of 'gfmap' (generic 'fmap'), --- where the type parameter to be \"mapped\" does not have to be the last one. --- --- 'gsolomap' is __unsafe__: misuse will break your programs. --- Read the <#gsolomapusage Usage> section below for details. --- --- === Example --- --- @ --- {-\# LANGUAGE DeriveGeneric \#-} --- --- import "GHC.Generics" ('Generic') --- import "Generic.Functor" ('gsolomap') --- --- data Result a r = Error a | Ok r -- Another name for Either --- deriving 'Generic' --- --- mapError :: (a -> b) -> Result a r -> Result b r --- mapError = 'gsolomap' --- --- mapOk :: (r -> s) -> Result a r -> Result a s --- mapOk = 'gsolomap' --- --- mapBoth :: (a -> b) -> Result a a -> Result b b --- mapBoth = 'gsolomap' --- @ --- --- === Usage #gsolomapusage# --- --- (This also applies to 'solomap', 'gmultimap', and 'multimap'.) --- --- 'gsolomap' should only be used to define __polymorphic__ "@fmap@-like functions". --- It works only in contexts where @a@ and @b@ are two distinct, non-unifiable --- type variables. This is usually the case when they are bound by universal --- quantification (@forall a b. ...@), with no equality constraints on @a@ and --- @b@. --- --- The one guarantee of 'gsolomap' is that @'gsolomap' 'id' = 'id'@. --- Under the above conditions, that law and the types should uniquely determine --- the implementation, which 'gsolomap' seeks automatically. --- --- The unsafety is due to the use of incoherent instances as part of the --- definition of 'GSolomap'. Functions are safe to specialize after 'GSolomap' --- (and 'Solomap') constraints have been discharged. --- --- Note also that the type parameters of 'gsolomap' must all be determined by --- the context. For instance, composing two 'gsolomap', as in --- @'gsolomap' f . 'gsolomap' g@, is a type error because the type in the middle --- cannot be inferred. -gsolomap :: forall a b x y. (Generic x, Generic y, GSolomap a b x y) => (a -> b) -> (x -> y) -gsolomap f = to . gmapRep (defaultIncoherent f) . from - --- | Generalized implicit functor. --- --- Use this when @x@ and @y@ are applications of existing functors --- ('Functor', 'Bifunctor'). --- --- This is a different use case from 'gfmap' and 'gsolomap', which make --- functors out of freshly declared @data@ types. --- --- 'solomap' is __unsafe__: misuse will break your programs. --- --- See the <#gsolomapusage Usage> section of 'gsolomap' for details. --- --- === Example --- --- @ --- map1 :: (a -> b) -> Either e (Maybe [IO a]) -> Either e (Maybe [IO b]) --- map1 = 'solomap' --- -- equivalent to: fmap . fmap . fmap . fmap --- --- map2 :: (a -> b) -> (e -> Either [a] r) -> (e -> Either [b] r) --- map2 = 'solomap' --- -- equivalent to: \\f -> fmap (bimap (fmap f) id) --- @ -solomap :: forall a b x y. Solomap a b x y => (a -> b) -> (x -> y) -solomap f = multimap f - --- | Generic n-ary functor. --- --- A generalization of 'gsolomap' to map over multiple parameters simultaneously. --- 'gmultimap' takes a list of functions separated by @(':+')@ and terminated by @()@. --- --- 'gmultimap' is __unsafe__: misuse will break your programs. --- The type of every function in the list must be some @(a -> b)@ --- where @a@ and @b@ are distinct type variables. --- --- See the <#gsolomapusage Usage> section of 'gsolomap' for details. --- --- === Example --- --- @ --- {-\# LANGUAGE DeriveGeneric \#-} --- --- import "GHC.Generics" ('Generic') --- import "Generic.Functor" ('gmultimap') --- --- data Three a b c = One a | Two b | Three c --- deriving 'Generic' --- --- mapThree :: (a -> a') -> (b -> b') -> (c -> c') -> Three a b c -> Three a' b' c' --- mapThree f g h = 'gmultimap' (f ':+' g ':+' h ':+' ()) --- @ -gmultimap :: forall arr x y. (Generic x, Generic y, GMultimap arr x y) => arr -> (x -> y) -gmultimap f = to . gmapRep (defaultIncoherent f) . from - --- | Implicit n-ary functor. --- --- A generalization of 'solomap' to map over multiple parameters simultaneously. --- 'multimap' takes a list of functions separated by @(':+')@ and terminated by @()@. --- --- 'multimap' is __unsafe__: misuse will break your programs. --- The type of every function in the list must be some @(a -> b)@ --- where @a@ and @b@ are distinct type variables. --- --- See the <#gsolomapusage Usage> section of 'gsolomap' for details. --- --- === Example --- --- @ --- type F a b c = Either a (b, c) --- --- map3 :: (a -> a') -> (b -> b') -> (c -> c') -> F a b c -> F a' b' c' --- map3 f g h = 'multimap' (f ':+' g ':+' h ':+' ()) --- -- equivalent to: \\f g h -> bimap f (bimap g h) --- @ -multimap :: forall arr x y. Multimap arr x y => arr -> (x -> y) -multimap f = multimapI (defaultIncoherent f) - --- | Generic implementation of 'bimap' from 'Bifunctor'. See also 'GenericBifunctor'. -gbimap :: forall f a b c d. GBimap f => (a -> b) -> (c -> d) -> f a c -> f b d -gbimap f g = with @(GBimapRep a b c d f) (to . gmapRep (defaultIncoherent (f :+ g)) . from) - --- | Generic implementation of 'first' from 'Bifunctor'. See also 'GenericBifunctor'. -gfirst :: forall f a b c. GFirst f => (a -> b) -> f a c -> f b c -gfirst f = with @(GFirstRep a b c f) (to . gmapRep (defaultIncoherent f) . from) - --- | Generic implementation of 'second' from 'Bifunctor'. See also 'GenericBifunctor'. -gsecond :: forall f a c d. GSecond f => (c -> d) -> f a c -> f a d -gsecond = gfmap - --- *** Fold - --- | Generic implementation of 'foldMap' from 'Foldable'. -gfoldMap :: forall t m a. (GFoldMap m t, Monoid m) => (a -> m) -> t a -> m -gfoldMap f = - with @(GFoldMapRep a a m t) (gfoldMapRep (defaultIncoherent (Fold @m @a @a f)) . from) - --- | Generic implementation of 'bifoldMap' from 'Bifoldable'. -gbifoldMap :: forall t m a b. (GBifoldMap m t, Monoid m) => (a -> m) -> (b -> m) -> t a b -> m -gbifoldMap f g = - with @(GBifoldMapRep a a b b m t) (gfoldMapRep (defaultIncoherent (Fold @m @a @a f :+ Fold @m @b @b g)) . from) - --- *** Traverse - --- | Generic implementation of 'traverse' from 'Traversable'. -gtraverse :: forall t f a b. (GTraverse f t, Applicative f) => (a -> f b) -> t a -> f (t b) -gtraverse f = with @(GTraverseRep a b f t) (lowerAps . fmap to . gtraverseRep (defaultIncoherent f) . from) - --- | Generic implementation of 'bitraverse' from 'Bitraversable'. -gbitraverse :: forall t f a b c d. (GBitraverse f t, Applicative f) => (a -> f b) -> (c -> f d) -> t a c -> f (t b d) -gbitraverse f g = - with @(GBitraverseRep a b c d f t) (lowerAps . fmap to . gtraverseRep (defaultIncoherent (f :+ g)) . from) - - --- | Explicitly require a constraint, to force the instantiation of a quantified constraint. -with :: forall c r. (c => r) -> (c => r) -with x = x - --- ** Top-level constraints - --- *** @gfmap@ - --- | Generic 'Functor'. Constraint for 'gfmap'. -class (forall a. Generic (f a), forall a b. GFunctorRep a b f) => GFunctor f -instance (forall a. Generic (f a), forall a b. GFunctorRep a b f) => GFunctor f - --- | Internal component of 'GFunctor'. --- --- This is an example of the \"quantified constraints trick\" to encode --- @forall a b. GMap1 a b (Rep (f a)) (Rep (f b))@ which doesn't actually --- work as-is. -class GMap1 (Default Incoherent (a -> b)) (Rep (f a)) (Rep (f b)) => GFunctorRep a b f -instance GMap1 (Default Incoherent (a -> b)) (Rep (f a)) (Rep (f b)) => GFunctorRep a b f - --- *** @gbimap@ - --- | Constraint for 'gbimap'. -class (forall a c. Generic (f a c), forall a b c d. GBimapRep a b c d f) => GBimap f -instance (forall a c. Generic (f a c), forall a b c d. GBimapRep a b c d f) => GBimap f - --- | Internal component of 'GBifunctor'. -class GMap1 (Default Incoherent ((a -> b) :+ (c -> d))) (Rep (f a c)) (Rep (f b d)) => GBimapRep a b c d f -instance GMap1 (Default Incoherent ((a -> b) :+ (c -> d))) (Rep (f a c)) (Rep (f b d)) => GBimapRep a b c d f - --- *** @gfirst@ - --- | Constraint for 'gfirst'. -class (forall a c. Generic (f a c), forall a b c. GFirstRep a b c f) => GFirst f -instance (forall a c. Generic (f a c), forall a b c. GFirstRep a b c f) => GFirst f - --- | Internal component of 'GFirst'. -class GMap1 (Default Incoherent (a -> b)) (Rep (f a c)) (Rep (f b c)) => GFirstRep a b c f -instance GMap1 (Default Incoherent (a -> b)) (Rep (f a c)) (Rep (f b c)) => GFirstRep a b c f - --- *** @gsecond@ - --- | Constraint for 'gsecond'. -class (forall a c. Generic (f a c), forall a c d. GFunctorRep c d (f a)) => GSecond f -instance (forall a c. Generic (f a c), forall a c d. GFunctorRep c d (f a)) => GSecond f - --- | Generic 'Bifunctor'. -class (GBimap f, GFirst f, GSecond f) => GBifunctor f -instance (GBimap f, GFirst f, GSecond f) => GBifunctor f - --- *** @gtraverse@ - --- | Constraint for 'gtraverse'. -class (forall a. Generic (t a), forall a b. GTraverseRep a b f t) => GTraverse f t -instance (forall a. Generic (t a), forall a b. GTraverseRep a b f t) => GTraverse f t - -class GTraverse1 f (Default Incoherent (a -> f b)) (Rep (t a)) (Rep (t b)) => GTraverseRep a b f t -instance GTraverse1 f (Default Incoherent (a -> f b)) (Rep (t a)) (Rep (t b)) => GTraverseRep a b f t - --- | Generic 'Traversable'. -class (forall f. Applicative f => GBitraverse f t) => GTraversable t -instance (forall f. Applicative f => GBitraverse f t) => GTraversable t - --- | Constraint for 'gtraverse'. -class (forall a b. Generic (t a b), forall a b c d. GBitraverseRep a b c d f t) => GBitraverse f t -instance (forall a b. Generic (t a b), forall a b c d. GBitraverseRep a b c d f t) => GBitraverse f t - -class GTraverse1 f (Default Incoherent ((a -> f b) :+ (c -> f d))) (Rep (t a c)) (Rep (t b d)) => GBitraverseRep a b c d f t -instance GTraverse1 f (Default Incoherent ((a -> f b) :+ (c -> f d))) (Rep (t a c)) (Rep (t b d)) => GBitraverseRep a b c d f t - --- | Generic 'Bitraversable'. -class (forall f. Applicative f => GBitraverse f t) => GBitraversable t -instance (forall f. Applicative f => GBitraverse f t) => GBitraversable t - --- *** @foldMap@ - --- | Constraint for 'gfoldMap'. -class (forall a. Generic (t a), forall a b. GFoldMapRep a b m t) => GFoldMap m t -instance (forall a. Generic (t a), forall a b. GFoldMapRep a b m t) => GFoldMap m t - -class GFoldMap1 m (Default Incoherent (Fold m a b)) (Rep (t a)) (Rep (t b)) => GFoldMapRep a b m t -instance GFoldMap1 m (Default Incoherent (Fold m a b)) (Rep (t a)) (Rep (t b)) => GFoldMapRep a b m t - --- | Generic 'Foldable'. Constraint for 'GenericFunctor' (deriving-via 'Foldable'). -class (forall m. Monoid m => GFoldMap m t) => GFoldable t -instance (forall m. Monoid m => GFoldMap m t) => GFoldable t - --- | Constraint for 'gbifoldMap'. -class (forall a b. Generic (t a b), forall a b c d. GBifoldMapRep a b c d m t) => GBifoldMap m t -instance (forall a b. Generic (t a b), forall a b c d. GBifoldMapRep a b c d m t) => GBifoldMap m t - -class GFoldMap1 m (Default Incoherent (Fold m a b :+ Fold m c d)) (Rep (t a c)) (Rep (t b d)) => GBifoldMapRep a b c d m t -instance GFoldMap1 m (Default Incoherent (Fold m a b :+ Fold m c d)) (Rep (t a c)) (Rep (t b d)) => GBifoldMapRep a b c d m t - --- | Generic 'Foldable'. Constraint for 'GenericFunctor' (deriving-via 'Foldable'). -class (forall m. Monoid m => GBifoldMap m t) => GBifoldable t -instance (forall m. Monoid m => GBifoldMap m t) => GBifoldable t - --- *** Others - --- | Constraint for 'gsolomap'. -class GMultimap (a -> b) x y => GSolomap a b x y -instance GMultimap (a -> b) x y => GSolomap a b x y - --- | Constraint for 'solomap'. -class Multimap (a -> b) x y => Solomap a b x y -instance Multimap (a -> b) x y => Solomap a b x y - --- | Constraint for 'gmultimap'. -class GMap1 (Default Incoherent arr) (Rep x) (Rep y) => GMultimap arr x y -instance GMap1 (Default Incoherent arr) (Rep x) (Rep y) => GMultimap arr x y - --- | Constraint for 'multimap'. -class MultimapI (Default Incoherent arr) x y => Multimap arr x y -instance MultimapI (Default Incoherent arr) x y => Multimap arr x y - --- * Deriving Via - --- ** Functor - --- | @newtype@ for @DerivingVia@ of 'Functor' and 'Foldable' instances. --- --- Note: the GHC extensions @DeriveFunctor@, @DeriveFoldable@, and @DeriveTraversable@ --- (which implies all three) already works out-of-the-box in most cases. --- There are exceptions, such as the following example. --- --- === Example --- --- @ --- {-\# LANGUAGE DeriveGeneric, DerivingVia \#-} --- --- import "GHC.Generics" ('Generic') --- import "Generic.Functor" ('GenericFunctor'(..)) --- --- data Twice a = Twice (Either a a) --- deriving 'Generic' --- deriving ('Functor', 'Foldable') via ('GenericFunctor' Twice) --- @ -newtype GenericFunctor f a = GenericFunctor (f a) - -instance GFunctor f => Functor (GenericFunctor f) where - fmap = coerce1 (gfmap @f) - -instance GFoldable f => Foldable (GenericFunctor f) where - foldMap = coerceFoldMap (gfoldMap @f) - --- ** Bifunctor - --- | @newtype@ for @DerivingVia@ of 'Bifunctor' and 'Bifoldable' instances. --- --- Note: deriving 'Bifunctor' for a generic type often requires 'Functor' --- instances for types mentioned in the fields. --- --- === Example --- --- @ --- {-\# LANGUAGE DeriveGeneric, DerivingVia \#-} --- --- import "Data.Bifoldable" ('Bifoldable') --- import "Data.Bifunctor" ('Bifunctor') --- import "GHC.Generics" ('Generic') --- import "Generic.Functor" ('GenericFunctor'(..), 'GenericBifunctor'(..)) --- --- data Tree a b = Node a (Tree a b) (Tree a b) | Leaf b --- deriving 'Generic' --- deriving ('Functor', 'Foldable') via ('GenericFunctor' (Tree a)) --- deriving ('Bifunctor', 'Bifoldable') via ('GenericBifunctor' Tree) --- --- data CofreeF f a b = a :< f b --- deriving 'Generic' --- deriving ('Bifunctor', 'Bifoldable') via ('GenericBifunctor' (CofreeF f)) --- @ -newtype GenericBifunctor f a b = GenericBifunctor (f a b) - -instance GBifunctor f => Bifunctor (GenericBifunctor f) where - bimap = coerce2 (gbimap @f) - first = coerce3 (gfirst @f) - second = coerce3 (gsecond @f) - -instance GBifoldable f => Bifoldable (GenericBifunctor f) where - bifoldMap = coerceBifoldMap (gbifoldMap @f) - --- ** Internal coercions - -coerce1 :: Coercible s t => (r -> s) -> (r -> t) -coerce1 = coerce - -coerce2 :: Coercible t u => (r -> s -> t) -> (r -> s -> u) -coerce2 = coerce - -coerce3 :: (Coercible w v, Coercible (f b d) (g b d)) => (r -> w -> f b d) -> (r -> v -> g b d) -coerce3 = coerce - -coerceFoldMap :: Coercible t u => (am -> t -> m) -> (am -> u -> m) -coerceFoldMap = coerce - -coerceBifoldMap :: Coercible t u => (am -> bm -> t -> m) -> (am -> bm -> u -> m) -coerceBifoldMap = coerce - --- ** @GMultimapK@ - --- | We use the same class to implement all of 'fmap', 'foldMap', 'traverse', --- instantiating @m@ as 'Identity', 'Const (EndoM mm)' and 'Aps n' respectively. --- Those three cases differ in their instances for 'K1'. --- --- (the K stands for @Kleisli@, because the result is @Kleisli m (f ()) (g ())@ -class GMultimapK m arr f g where - gmultimapK :: arr -> f () -> m (g ()) - --- *** Instance for @fmap@ - -instance MultimapI arr x y => GMultimapK Identity arr (K1 i x) (K1 i' y) where - gmultimapK = coerce (multimapI @arr @x @y) - -class GMultimapK Identity arr f g => GMap1 arr f g -instance GMultimapK Identity arr f g => GMap1 arr f g - -gmapRep :: GMap1 arr f g => arr -> f () -> g () -gmapRep f x = runIdentity (gmultimapK f x) - --- *** Instance for @foldMap@ - -instance (Multifold_ m arr x y, Monoid m) => GMultimapK (Const (EndoM m)) arr (K1 i x) (K1 i' y) where - gmultimapK f (K1 x) = K1 <$> foldToConst (multifold_ f) x - --- Spooky instance. It makes sense only because @GMultimapK (Const (EndoM m))@ --- occurs exclusively under a quantified constraint (in the definition of GFoldMap). -instance {-# INCOHERENT #-} GMultimapK (Const (EndoM m)) arr (K1 i x) (K1 i x) where - gmultimapK _ (K1 _) = Const (Endo id) - --- An extra wrapper to simplify away @(mempty <> _)@ and @(_ <> mempty)@. -type EndoM m = Endo (Maybe m) - -unEndoM :: Monoid m => EndoM m -> m -unEndoM (Endo f) = case f Nothing of - Nothing -> mempty - Just y -> y - -liftEndoM :: Monoid m => m -> EndoM m -liftEndoM y = Endo (Just . app) - where - app Nothing = y - app (Just y') = y `mappend` y' - -foldToConst :: Monoid m => Fold m x y -> x -> Const (EndoM m) y -foldToConst (Fold f) x = Const (liftEndoM (f x)) - -class GMultimapK (Const (EndoM m)) arr f g => GFoldMap1 m arr f g -instance GMultimapK (Const (EndoM m)) arr f g => GFoldMap1 m arr f g - --- | Danger! @GFoldMap1 m arr f f@ MUST come from a quantified constraint (see use in 'gfoldMap'). -gfoldMapRep :: forall m arr f. (GFoldMap1 m arr f f, Monoid m) => arr -> f () -> m -gfoldMapRep f x = unEndoM (getConst (gmultimapK f x :: Const (EndoM m) (f ()))) - --- *** Instance for @traverse@ - -instance (Multitraverse m arr x y) => GMultimapK (Aps m) arr (K1 i x) (K1 i' y) where - gmultimapK f (K1 x) = K1 <$>^ multitraverse f x - -class GMultimapK (Aps m) arr f g => GTraverse1 m arr f g -instance GMultimapK (Aps m) arr f g => GTraverse1 m arr f g - -gtraverseRep :: GTraverse1 m arr f g => arr -> f () -> Aps m (g ()) -gtraverseRep = gmultimapK - --- *** Common instances - -instance (GMultimapK m arr f g, Functor m) => GMultimapK m arr (M1 i c f) (M1 i' c' g) where - gmultimapK f (M1 x) = M1 <$> gmultimapK f x - -instance - (GMultimapK m arr f1 g1, GMultimapK m arr f2 g2, Applicative m) => - GMultimapK m arr (f1 :+: f2) (g1 :+: g2) - where - gmultimapK f (L1 x) = L1 <$> gmultimapK f x - gmultimapK f (R1 y) = R1 <$> gmultimapK f y - -instance - (GMultimapK m arr f1 g1, GMultimapK m arr f2 g2, Applicative m) => - GMultimapK m arr (f1 :*: f2) (g1 :*: g2) - where - gmultimapK f (x :*: y) = liftA2 (:*:) (gmultimapK f x) (gmultimapK f y) - -instance Applicative m => GMultimapK m arr U1 U1 where - gmultimapK _ U1 = pure U1 - -instance GMultimapK m arr V1 V1 where - gmultimapK _ v = case v of +{-# LANGUAGE + AllowAmbiguousTypes, + ConstraintKinds, + EmptyCase, + FlexibleContexts, + FlexibleInstances, + MultiParamTypeClasses, + QuantifiedConstraints, + RankNTypes, + ScopedTypeVariables, + TypeApplications, + TypeOperators, + UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} + +-- | This is an internal module. Look, don't touch. +-- +-- "Generic.Functor" is the public API. + +module Generic.Functor.Internal where + +import ApNormalize +import Control.Applicative (liftA2) +import Data.Bifoldable (Bifoldable(..)) +import Data.Bifunctor (Bifunctor(..)) +import Data.Coerce (coerce, Coercible) +import Data.Functor.Identity (Identity(..)) +import Data.Functor.Const (Const(..)) +import Data.Monoid (Endo(..)) +import GHC.Generics hiding (S) + +import Generic.Functor.Internal.Implicit + +-- | Generic implementation of 'fmap'. See also 'GenericFunctor' for @DerivingVia@, +-- using 'gfmap' under the hood. +-- +-- === Example +-- +-- @ +-- {-\# LANGUAGE DeriveGeneric \#-} +-- +-- import "GHC.Generics" ('Generic') +-- import "Generic.Functor" ('gfmap') +-- +-- data Twice a = Twice (Either a a) +-- deriving 'Generic' +-- +-- instance 'Functor' Twice where +-- 'fmap' = 'gfmap' +-- @ +-- +-- Unlike 'gsolomap', 'gfmap' is safe to use in all contexts. +gfmap :: forall f a b. GFunctor f => (a -> b) -> (f a -> f b) +gfmap f = with @(GFunctorRep a b f) (to . gmapRep (defaultIncoherent f) . from) + +-- | Generalized generic functor. +-- +-- 'gsolomap' is a generalization of 'gfmap' (generic 'fmap'), +-- where the type parameter to be \"mapped\" does not have to be the last one. +-- +-- 'gsolomap' is __unsafe__: misuse will break your programs. +-- Read the <#gsolomapusage Usage> section below for details. +-- +-- === Example +-- +-- @ +-- {-\# LANGUAGE DeriveGeneric \#-} +-- +-- import "GHC.Generics" ('Generic') +-- import "Generic.Functor" ('gsolomap') +-- +-- data Result a r = Error a | Ok r -- Another name for Either +-- deriving 'Generic' +-- +-- mapError :: (a -> b) -> Result a r -> Result b r +-- mapError = 'gsolomap' +-- +-- mapOk :: (r -> s) -> Result a r -> Result a s +-- mapOk = 'gsolomap' +-- +-- mapBoth :: (a -> b) -> Result a a -> Result b b +-- mapBoth = 'gsolomap' +-- @ +-- +-- === Usage #gsolomapusage# +-- +-- (This also applies to 'solomap', 'gmultimap', and 'multimap'.) +-- +-- 'gsolomap' should only be used to define __polymorphic__ "@fmap@-like functions". +-- It works only in contexts where @a@ and @b@ are two distinct, non-unifiable +-- type variables. This is usually the case when they are bound by universal +-- quantification (@forall a b. ...@), with no equality constraints on @a@ and +-- @b@. +-- +-- The one guarantee of 'gsolomap' is that @'gsolomap' 'id' = 'id'@. +-- Under the above conditions, that law and the types should uniquely determine +-- the implementation, which 'gsolomap' seeks automatically. +-- +-- The unsafety is due to the use of incoherent instances as part of the +-- definition of 'GSolomap'. Functions are safe to specialize after 'GSolomap' +-- (and 'Solomap') constraints have been discharged. +-- +-- Note also that the type parameters of 'gsolomap' must all be determined by +-- the context. For instance, composing two 'gsolomap', as in +-- @'gsolomap' f . 'gsolomap' g@, is a type error because the type in the middle +-- cannot be inferred. +gsolomap :: forall a b x y. (Generic x, Generic y, GSolomap a b x y) => (a -> b) -> (x -> y) +gsolomap f = to . gmapRep (defaultIncoherent f) . from + +-- | Generalized implicit functor. +-- +-- Use this when @x@ and @y@ are applications of existing functors +-- ('Functor', 'Bifunctor'). +-- +-- This is a different use case from 'Generic.Functor.gfmap' and 'gsolomap', which make +-- functors out of freshly declared @data@ types. +-- +-- 'solomap' is __unsafe__: misuse will break your programs. +-- +-- See the <#gsolomapusage Usage> section of 'gsolomap' for details. +-- +-- === Example +-- +-- @ +-- map1 :: (a -> b) -> Either e (Maybe [IO a]) -> Either e (Maybe [IO b]) +-- map1 = 'solomap' +-- -- equivalent to: fmap . fmap . fmap . fmap +-- +-- map2 :: (a -> b) -> (e -> Either [a] r) -> (e -> Either [b] r) +-- map2 = 'solomap' +-- -- equivalent to: \\f -> fmap (bimap (fmap f) id) +-- @ +solomap :: forall a b x y. Solomap a b x y => (a -> b) -> (x -> y) +solomap f = multimap f + +-- | Generic n-ary functor. +-- +-- A generalization of 'gsolomap' to map over multiple parameters simultaneously. +-- 'gmultimap' takes a list of functions separated by @(':+')@ and terminated by @()@. +-- +-- 'gmultimap' is __unsafe__: misuse will break your programs. +-- The type of every function in the list must be some @(a -> b)@ +-- where @a@ and @b@ are distinct type variables. +-- +-- See the <#gsolomapusage Usage> section of 'gsolomap' for details. +-- +-- === Example +-- +-- @ +-- {-\# LANGUAGE DeriveGeneric \#-} +-- +-- import "GHC.Generics" ('Generic') +-- import "Generic.Functor" ('gmultimap') +-- +-- data Three a b c = One a | Two b | Three c +-- deriving 'Generic' +-- +-- mapThree :: (a -> a') -> (b -> b') -> (c -> c') -> Three a b c -> Three a' b' c' +-- mapThree f g h = 'gmultimap' (f ':+' g ':+' h ':+' ()) +-- @ +gmultimap :: forall arr x y. (Generic x, Generic y, GMultimap arr x y) => arr -> (x -> y) +gmultimap f = to . gmapRep (defaultIncoherent f) . from + +-- | Implicit n-ary functor. +-- +-- A generalization of 'solomap' to map over multiple parameters simultaneously. +-- 'multimap' takes a list of functions separated by @(':+')@ and terminated by @()@. +-- +-- 'multimap' is __unsafe__: misuse will break your programs. +-- The type of every function in the list must be some @(a -> b)@ +-- where @a@ and @b@ are distinct type variables. +-- +-- See the <#gsolomapusage Usage> section of 'gsolomap' for details. +-- +-- === Example +-- +-- @ +-- type F a b c = Either a (b, c) +-- +-- map3 :: (a -> a') -> (b -> b') -> (c -> c') -> F a b c -> F a' b' c' +-- map3 f g h = 'multimap' (f ':+' g ':+' h ':+' ()) +-- -- equivalent to: \\f g h -> bimap f (bimap g h) +-- @ +multimap :: forall arr x y. Multimap arr x y => arr -> (x -> y) +multimap f = multimapI (defaultIncoherent f) + +-- | Generic implementation of 'bimap' from 'Bifunctor'. See also 'GenericBifunctor'. +gbimap :: forall f a b c d. GBimap f => (a -> b) -> (c -> d) -> f a c -> f b d +gbimap f g = with @(GBimapRep a b c d f) (to . gmapRep (defaultIncoherent (f :+ g)) . from) + +-- | Generic implementation of 'first' from 'Bifunctor'. See also 'GenericBifunctor'. +gfirst :: forall f a b c. GFirst f => (a -> b) -> f a c -> f b c +gfirst f = with @(GFirstRep a b c f) (to . gmapRep (defaultIncoherent f) . from) + +-- | Generic implementation of 'second' from 'Bifunctor'. See also 'GenericBifunctor'. +gsecond :: forall f a c d. GSecond f => (c -> d) -> f a c -> f a d +gsecond = gfmap + +-- *** Fold + +-- | Generic implementation of 'foldMap' from 'Foldable'. +gfoldMap :: forall t m a. (GFoldMap m t, Monoid m) => (a -> m) -> t a -> m +gfoldMap f = + with @(GFoldMapRep a a m t) (gfoldMapRep (defaultIncoherent (Fold @m @a @a f)) . from) + +-- | Generic implementation of 'bifoldMap' from 'Bifoldable'. +gbifoldMap :: forall t m a b. (GBifoldMap m t, Monoid m) => (a -> m) -> (b -> m) -> t a b -> m +gbifoldMap f g = + with @(GBifoldMapRep a a b b m t) (gfoldMapRep (defaultIncoherent (Fold @m @a @a f :+ Fold @m @b @b g)) . from) + +-- *** Traverse + +-- | Generic implementation of 'traverse' from 'Traversable'. +gtraverse :: forall t f a b. (GTraverse f t, Applicative f) => (a -> f b) -> t a -> f (t b) +gtraverse f = with @(GTraverseRep a b f t) (lowerAps . fmap to . gtraverseRep (defaultIncoherent f) . from) + +-- | Generic implementation of 'bitraverse' from 'Bitraversable'. +gbitraverse :: forall t f a b c d. (GBitraverse f t, Applicative f) => (a -> f b) -> (c -> f d) -> t a c -> f (t b d) +gbitraverse f g = + with @(GBitraverseRep a b c d f t) (lowerAps . fmap to . gtraverseRep (defaultIncoherent (f :+ g)) . from) + + +-- | Explicitly require a constraint, to force the instantiation of a quantified constraint. +with :: forall c r. (c => r) -> (c => r) +with x = x + +-- ** Top-level constraints + +-- *** @gfmap@ + +-- | Generic 'Functor'. Constraint for 'gfmap'. +class (forall a. Generic (f a), forall a b. GFunctorRep a b f) => GFunctor f +instance (forall a. Generic (f a), forall a b. GFunctorRep a b f) => GFunctor f + +-- | Internal component of 'GFunctor'. +-- +-- This is an example of the \"quantified constraints trick\" to encode +-- @forall a b. GMap1 a b (Rep (f a)) (Rep (f b))@ which doesn't actually +-- work as-is. +class GMap1 (Default Incoherent (a -> b)) (Rep (f a)) (Rep (f b)) => GFunctorRep a b f +instance GMap1 (Default Incoherent (a -> b)) (Rep (f a)) (Rep (f b)) => GFunctorRep a b f + +-- *** @gbimap@ + +-- | Constraint for 'gbimap'. +class (forall a c. Generic (f a c), forall a b c d. GBimapRep a b c d f) => GBimap f +instance (forall a c. Generic (f a c), forall a b c d. GBimapRep a b c d f) => GBimap f + +-- | Internal component of 'GBifunctor'. +class GMap1 (Default Incoherent ((a -> b) :+ (c -> d))) (Rep (f a c)) (Rep (f b d)) => GBimapRep a b c d f +instance GMap1 (Default Incoherent ((a -> b) :+ (c -> d))) (Rep (f a c)) (Rep (f b d)) => GBimapRep a b c d f + +-- *** @gfirst@ + +-- | Constraint for 'gfirst'. +class (forall a c. Generic (f a c), forall a b c. GFirstRep a b c f) => GFirst f +instance (forall a c. Generic (f a c), forall a b c. GFirstRep a b c f) => GFirst f + +-- | Internal component of 'GFirst'. +class GMap1 (Default Incoherent (a -> b)) (Rep (f a c)) (Rep (f b c)) => GFirstRep a b c f +instance GMap1 (Default Incoherent (a -> b)) (Rep (f a c)) (Rep (f b c)) => GFirstRep a b c f + +-- *** @gsecond@ + +-- | Constraint for 'gsecond'. +class (forall a c. Generic (f a c), forall a c d. GFunctorRep c d (f a)) => GSecond f +instance (forall a c. Generic (f a c), forall a c d. GFunctorRep c d (f a)) => GSecond f + +-- | Generic 'Bifunctor'. +class (GBimap f, GFirst f, GSecond f) => GBifunctor f +instance (GBimap f, GFirst f, GSecond f) => GBifunctor f + +-- *** @gtraverse@ + +-- | Constraint for 'gtraverse'. +class (forall a. Generic (t a), forall a b. GTraverseRep a b f t) => GTraverse f t +instance (forall a. Generic (t a), forall a b. GTraverseRep a b f t) => GTraverse f t + +class GTraverse1 f (Default Incoherent (a -> f b)) (Rep (t a)) (Rep (t b)) => GTraverseRep a b f t +instance GTraverse1 f (Default Incoherent (a -> f b)) (Rep (t a)) (Rep (t b)) => GTraverseRep a b f t + +-- | Generic 'Traversable'. +class (forall f. Applicative f => GBitraverse f t) => GTraversable t +instance (forall f. Applicative f => GBitraverse f t) => GTraversable t + +-- | Constraint for 'gtraverse'. +class (forall a b. Generic (t a b), forall a b c d. GBitraverseRep a b c d f t) => GBitraverse f t +instance (forall a b. Generic (t a b), forall a b c d. GBitraverseRep a b c d f t) => GBitraverse f t + +class GTraverse1 f (Default Incoherent ((a -> f b) :+ (c -> f d))) (Rep (t a c)) (Rep (t b d)) => GBitraverseRep a b c d f t +instance GTraverse1 f (Default Incoherent ((a -> f b) :+ (c -> f d))) (Rep (t a c)) (Rep (t b d)) => GBitraverseRep a b c d f t + +-- | Generic 'Bitraversable'. +class (forall f. Applicative f => GBitraverse f t) => GBitraversable t +instance (forall f. Applicative f => GBitraverse f t) => GBitraversable t + +-- *** @foldMap@ + +-- | Constraint for 'gfoldMap'. +class (forall a. Generic (t a), forall a b. GFoldMapRep a b m t) => GFoldMap m t +instance (forall a. Generic (t a), forall a b. GFoldMapRep a b m t) => GFoldMap m t + +class GFoldMap1 m (Default Incoherent (Fold m a b)) (Rep (t a)) (Rep (t b)) => GFoldMapRep a b m t +instance GFoldMap1 m (Default Incoherent (Fold m a b)) (Rep (t a)) (Rep (t b)) => GFoldMapRep a b m t + +-- | Generic 'Foldable'. Constraint for 'GenericFunctor' (deriving-via 'Foldable'). +class (forall m. Monoid m => GFoldMap m t) => GFoldable t +instance (forall m. Monoid m => GFoldMap m t) => GFoldable t + +-- | Constraint for 'gbifoldMap'. +class (forall a b. Generic (t a b), forall a b c d. GBifoldMapRep a b c d m t) => GBifoldMap m t +instance (forall a b. Generic (t a b), forall a b c d. GBifoldMapRep a b c d m t) => GBifoldMap m t + +class GFoldMap1 m (Default Incoherent (Fold m a b :+ Fold m c d)) (Rep (t a c)) (Rep (t b d)) => GBifoldMapRep a b c d m t +instance GFoldMap1 m (Default Incoherent (Fold m a b :+ Fold m c d)) (Rep (t a c)) (Rep (t b d)) => GBifoldMapRep a b c d m t + +-- | Generic 'Foldable'. Constraint for 'GenericFunctor' (deriving-via 'Foldable'). +class (forall m. Monoid m => GBifoldMap m t) => GBifoldable t +instance (forall m. Monoid m => GBifoldMap m t) => GBifoldable t + +-- *** Others + +-- | Constraint for 'gsolomap'. +class GMultimap (a -> b) x y => GSolomap a b x y +instance GMultimap (a -> b) x y => GSolomap a b x y + +-- | Constraint for 'solomap'. +class Multimap (a -> b) x y => Solomap a b x y +instance Multimap (a -> b) x y => Solomap a b x y + +-- | Constraint for 'gmultimap'. +class GMap1 (Default Incoherent arr) (Rep x) (Rep y) => GMultimap arr x y +instance GMap1 (Default Incoherent arr) (Rep x) (Rep y) => GMultimap arr x y + +-- | Constraint for 'multimap'. +class MultimapI (Default Incoherent arr) x y => Multimap arr x y +instance MultimapI (Default Incoherent arr) x y => Multimap arr x y + +-- * Deriving Via + +-- ** Functor + +-- | @newtype@ for @DerivingVia@ of 'Functor' and 'Foldable' instances. +-- +-- Note: the GHC extensions @DeriveFunctor@, @DeriveFoldable@, and @DeriveTraversable@ +-- (which implies all three) already works out-of-the-box in most cases. +-- There are exceptions, such as the following example. +-- +-- === Example +-- +-- @ +-- {-\# LANGUAGE DeriveGeneric, DerivingVia \#-} +-- +-- import "GHC.Generics" ('Generic') +-- import "Generic.Functor" ('GenericFunctor'(..)) +-- +-- data Twice a = Twice (Either a a) +-- deriving 'Generic' +-- deriving ('Functor', 'Foldable') via ('GenericFunctor' Twice) +-- @ +newtype GenericFunctor f a = GenericFunctor (f a) + +instance GFunctor f => Functor (GenericFunctor f) where + fmap = coerce1 (gfmap @f) + +instance GFoldable f => Foldable (GenericFunctor f) where + foldMap = coerceFoldMap (gfoldMap @f) + +-- ** Bifunctor + +-- | @newtype@ for @DerivingVia@ of 'Bifunctor' and 'Bifoldable' instances. +-- +-- Note: deriving 'Bifunctor' for a generic type often requires 'Functor' +-- instances for types mentioned in the fields. +-- +-- === Example +-- +-- @ +-- {-\# LANGUAGE DeriveGeneric, DerivingVia \#-} +-- +-- import "Data.Bifoldable" ('Bifoldable') +-- import "Data.Bifunctor" ('Bifunctor') +-- import "GHC.Generics" ('Generic') +-- import "Generic.Functor" ('GenericFunctor'(..), 'GenericBifunctor'(..)) +-- +-- data Tree a b = Node a (Tree a b) (Tree a b) | Leaf b +-- deriving 'Generic' +-- deriving ('Functor', 'Foldable') via ('GenericFunctor' (Tree a)) +-- deriving ('Bifunctor', 'Bifoldable') via ('GenericBifunctor' Tree) +-- +-- data CofreeF f a b = a :< f b +-- deriving 'Generic' +-- deriving ('Bifunctor', 'Bifoldable') via ('GenericBifunctor' (CofreeF f)) +-- @ +newtype GenericBifunctor f a b = GenericBifunctor (f a b) + +instance GBifunctor f => Bifunctor (GenericBifunctor f) where + bimap = coerce2 (gbimap @f) + first = coerce3 (gfirst @f) + second = coerce3 (gsecond @f) + +instance GBifoldable f => Bifoldable (GenericBifunctor f) where + bifoldMap = coerceBifoldMap (gbifoldMap @f) + +-- ** Internal coercions + +coerce1 :: Coercible s t => (r -> s) -> (r -> t) +coerce1 = coerce + +coerce2 :: Coercible t u => (r -> s -> t) -> (r -> s -> u) +coerce2 = coerce + +coerce3 :: (Coercible w v, Coercible (f b d) (g b d)) => (r -> w -> f b d) -> (r -> v -> g b d) +coerce3 = coerce + +coerceFoldMap :: Coercible t u => (am -> t -> m) -> (am -> u -> m) +coerceFoldMap = coerce + +coerceBifoldMap :: Coercible t u => (am -> bm -> t -> m) -> (am -> bm -> u -> m) +coerceBifoldMap = coerce + +-- ** @GMultimapK@ + +-- | We use the same class to implement all of 'fmap', 'foldMap', 'traverse', +-- instantiating @m@ as 'Identity', 'Const (EndoM mm)' and 'Aps n' respectively. +-- Those three cases differ in their instances for 'K1'. +-- +-- (the K stands for @Kleisli@, because the result is @Kleisli m (f ()) (g ())@ +class GMultimapK m arr f g where + gmultimapK :: arr -> f () -> m (g ()) + +-- *** Instance for @fmap@ + +instance MultimapI arr x y => GMultimapK Identity arr (K1 i x) (K1 i' y) where + gmultimapK = coerce (multimapI @arr @x @y) + +class GMultimapK Identity arr f g => GMap1 arr f g +instance GMultimapK Identity arr f g => GMap1 arr f g + +gmapRep :: GMap1 arr f g => arr -> f () -> g () +gmapRep f x = runIdentity (gmultimapK f x) + +-- *** Instance for @foldMap@ + +instance (Multifold_ m arr x y, Monoid m) => GMultimapK (Const (EndoM m)) arr (K1 i x) (K1 i' y) where + gmultimapK f (K1 x) = K1 <$> foldToConst (multifold_ f) x + +-- Spooky instance. It makes sense only because @GMultimapK (Const (EndoM m))@ +-- occurs exclusively under a quantified constraint (in the definition of GFoldMap). +instance {-# INCOHERENT #-} GMultimapK (Const (EndoM m)) arr (K1 i x) (K1 i x) where + gmultimapK _ (K1 _) = Const (Endo id) + +-- An extra wrapper to simplify away @(mempty <> _)@ and @(_ <> mempty)@. +type EndoM m = Endo (Maybe m) + +unEndoM :: Monoid m => EndoM m -> m +unEndoM (Endo f) = case f Nothing of + Nothing -> mempty + Just y -> y + +liftEndoM :: Monoid m => m -> EndoM m +liftEndoM y = Endo (Just . app) + where + app Nothing = y + app (Just y') = y `mappend` y' + +foldToConst :: Monoid m => Fold m x y -> x -> Const (EndoM m) y +foldToConst (Fold f) x = Const (liftEndoM (f x)) + +class GMultimapK (Const (EndoM m)) arr f g => GFoldMap1 m arr f g +instance GMultimapK (Const (EndoM m)) arr f g => GFoldMap1 m arr f g + +-- | Danger! @GFoldMap1 m arr f f@ MUST come from a quantified constraint (see use in 'gfoldMap'). +gfoldMapRep :: forall m arr f. (GFoldMap1 m arr f f, Monoid m) => arr -> f () -> m +gfoldMapRep f x = unEndoM (getConst (gmultimapK f x :: Const (EndoM m) (f ()))) + +-- *** Instance for @traverse@ + +instance (Multitraverse m arr x y) => GMultimapK (Aps m) arr (K1 i x) (K1 i' y) where + gmultimapK f (K1 x) = K1 <$>^ multitraverse f x + +class GMultimapK (Aps m) arr f g => GTraverse1 m arr f g +instance GMultimapK (Aps m) arr f g => GTraverse1 m arr f g + +gtraverseRep :: GTraverse1 m arr f g => arr -> f () -> Aps m (g ()) +gtraverseRep = gmultimapK + +-- *** Common instances + +instance (GMultimapK m arr f g, Functor m) => GMultimapK m arr (M1 i c f) (M1 i' c' g) where + gmultimapK f (M1 x) = M1 <$> gmultimapK f x + +instance + (GMultimapK m arr f1 g1, GMultimapK m arr f2 g2, Applicative m) => + GMultimapK m arr (f1 :+: f2) (g1 :+: g2) + where + gmultimapK f (L1 x) = L1 <$> gmultimapK f x + gmultimapK f (R1 y) = R1 <$> gmultimapK f y + +instance + (GMultimapK m arr f1 g1, GMultimapK m arr f2 g2, Applicative m) => + GMultimapK m arr (f1 :*: f2) (g1 :*: g2) + where + gmultimapK f (x :*: y) = liftA2 (:*:) (gmultimapK f x) (gmultimapK f y) + +instance Applicative m => GMultimapK m arr U1 U1 where + gmultimapK _ U1 = pure U1 + +instance GMultimapK m arr V1 V1 where + gmultimapK _ v = case v of diff --git a/src/Generic/Functor/Internal/Implicit.hs b/src/Generic/Functor/Internal/Implicit.hs --- a/src/Generic/Functor/Internal/Implicit.hs +++ b/src/Generic/Functor/Internal/Implicit.hs @@ -1,225 +1,225 @@ -{-# LANGUAGE - ConstraintKinds, - FlexibleContexts, - FlexibleInstances, - InstanceSigs, - MultiParamTypeClasses, - RankNTypes, - ScopedTypeVariables, - TypeApplications, - TypeFamilies, - TypeOperators, - UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} - -module Generic.Functor.Internal.Implicit where - -import Control.Arrow (Kleisli (..)) -import Data.Bifunctor (Bifunctor (..)) -import Data.Bifoldable (Bifoldable (..)) -import Data.Bitraversable (Bitraversable (..)) -import Data.Coerce (Coercible, coerce) -import Data.Kind (Type) - --- | Core of 'multimap' -multimapI :: forall arr x y. MultimapI arr x y => arr -> (x -> y) -multimapI = multimapOf - -multitraverse :: forall f arr x y. Multitraverse f arr x y => arr -> (x -> f y) -multitraverse f = runKleisli (multimapOf (coerce f :: WrapKleisli f arr)) - --- | This is kept internal because of the 'Fold' wrapping. -multifold_ :: forall m arr x y. Multifold_ m arr x y => arr -> Fold m x y -multifold_ = multimapOf - -multimapOf :: forall cat arr x y. MultimapOf cat arr x y => arr -> cat x y -multimapOf f = multimap_ (s2 f) - --- | Core of 'multimap'. -class MultimapOf (->) arr x y => MultimapI arr x y -instance MultimapOf (->) arr x y => MultimapI arr x y - --- | Constraint for 'multifold_'. -class MultimapOf (Fold m) arr x y => Multifold_ m arr x y -instance MultimapOf (Fold m) arr x y => Multifold_ m arr x y - --- | Constraint for 'multitraverse'. -class Multitraverse_ f arr x y => Multitraverse f arr x y -instance Multitraverse_ f arr x y => Multitraverse f arr x y - --- | Internal definition of 'Multitraverse' -type Multitraverse_ f arr x y = - ( MultimapOf (Kleisli f) (WrapKleisli f arr) x y, - CoercibleKleisli f (WrapKleisli f arr) arr - ) - -type family WrapKleisli (f :: Type -> Type) (arr :: Type) -type instance WrapKleisli _f NilArr = NilArr -type instance WrapKleisli _f (Rule rule mode)= Rule rule mode -type instance WrapKleisli f (a :+ arr) = WrapKleisli f a :+ WrapKleisli f arr -type instance WrapKleisli f (a -> f b) = Kleisli f a b - --- | Auxiliary constraint for 'Multitraverse' -class Coercible warr arr => CoercibleKleisli (f :: Type -> Type) warr arr -instance (d ~ NilArr) => CoercibleKleisli f d NilArr -instance (d ~ Rule rule mode) => CoercibleKleisli f d (Rule rule mode) -instance (CoercibleKleisli f a b, CoercibleKleisli f arr arr') => CoercibleKleisli f (a :+ arr) (b :+ arr') -instance (b2 ~ f c, a ~ Kleisli f b1 c) => CoercibleKleisli f a (b1 -> b2) - -class Multimap_ cat (S2 arr) x y => MultimapOf cat arr x y -instance Multimap_ cat (S2 arr) x y => MultimapOf cat arr x y - --- | @Fold m@ is like @Kleisli (Const m)@, but it has a different @FunctorOf@ instance, --- with 'Foldable' instead of 'Traversable'. -newtype Fold m x y = Fold { unFold :: x -> m } - -instance Monoid m => CatLike (Fold m) where - catid = Fold (\_ -> mempty) - -instance (Foldable t, Monoid m) => FunctorOf (Fold m) t where - catmap (Fold f) = Fold (foldMap f) - -instance (Bifoldable t, Monoid m) => BifunctorOf (Fold m) t where - catbimap (Fold f) (Fold g) = Fold (bifoldMap f g) - --- * Internal - -class CatLike cat where - catid :: cat x x - -instance CatLike (->) where - catid = id - -instance Applicative f => CatLike (Kleisli f) where - catid = Kleisli pure - -class FunctorOf cat t where - catmap :: cat a b -> cat (t a) (t b) - -instance Functor t => FunctorOf (->) t where - catmap = fmap - -instance (Applicative f, Traversable t) => FunctorOf (Kleisli f) t where - catmap :: forall a b. Kleisli f a b -> Kleisli f (t a) (t b) - catmap = coerce (traverse @t @f @a @b) - -class BifunctorOf cat t where - catbimap :: cat a b -> cat c d -> cat (t a c) (t b d) - -instance Bifunctor t => BifunctorOf (->) t where - catbimap = bimap - -instance (Applicative f, Bitraversable t) => BifunctorOf (Kleisli f) t where - catbimap :: forall a b c d. Kleisli f a b -> Kleisli f c d -> Kleisli f (t a c) (t b d) - catbimap = coerce (bitraverse @t @f @a @b @c @d) - --- | Internal implementation of 'MultimapOf'. -class Multimap_ cat arr x y where - multimap_ :: arr -> cat x y - --- | Heterogeneous lists of arrows are constructed as lists separated by --- @(':+')@ and terminated by @()@. --- --- === Example --- --- Given @f :: a -> a'@ and @g :: b -> b'@, --- @(f ':+' g ':+' ())@ is a list with the two elements @f@ and @g@. --- --- @ --- if --- f :: a -> a' --- g :: b -> b' --- --- then --- f ':+' g ':+' () :: (a -> a') ':+' (b -> b') ':+' () --- @ --- --- Those lists are used by 'gmultimap' and 'multimap'. --- --- @ --- bimap_ :: (a -> a') -> (b -> b') -> (Maybe a, [Either b a]) -> (Maybe a', [Either b' a']) --- bimap_ f g = 'multimap' (f ':+' g ':+' ()) --- @ -data a :+ b = a :+ b - -infixr 1 :+ - --- Special arrows - -data Rule rule mode = Rule rule mode -data AnyId = AnyId -data AnyFunctor = AnyFunctor -data AnyBifunctor = AnyBifunctor -data NilArr = NilArr - -data Incoherent = Incoherent - -type Default mode arr = arr :+ Rule AnyId mode :+ Rule AnyFunctor mode :+ Rule AnyBifunctor mode :+ NilArr - -defaultIncoherent :: arr -> Default Incoherent arr -defaultIncoherent = def Incoherent - -def :: mode -> arr -> Default mode arr -def mode arr = arr :+ Rule AnyId mode :+ Rule AnyFunctor mode :+ Rule AnyBifunctor mode :+ NilArr - --- | @arr@ is the list of arrows provided by the user. It is constant. --- When testing whether any arrow matches, @arr'@ is the remaining list of --- arrows to be tested. -data S arr arr' = S arr arr' - -type S2 arr = S arr arr - -s2 :: arr -> S2 arr -s2 f = S f f - --- The head doesn't match anything, go to the next thing. -instance {-# OVERLAPPABLE #-} Multimap_ cat (S arr arr') x y => Multimap_ cat (S arr (arr0 :+ arr')) x y where - multimap_ (S f (_ :+ g')) = multimap_ (S f g') - --- Reassociate to even handle tree-shaped parameters. -instance Multimap_ cat (S arr (arr0 :+ arr1 :+ arr2)) x y => Multimap_ cat (S arr ((arr0 :+ arr1) :+ arr2)) x y where - multimap_ (S f ((f0 :+ f1) :+ f2)) = multimap_ (S f (f0 :+ f1 :+ f2)) - -instance Multimap_ cat (S arr arr') x y => Multimap_ cat (S arr (NilArr :+ arr')) x y where - multimap_ (S f (NilArr :+ f')) = multimap_ (S f f') - -instance Multimap_ cat (S arr arr') x y => Multimap_ cat (S arr (() :+ arr')) x y where - multimap_ (S f (() :+ f')) = multimap_ (S f f') - -instance {-# INCOHERENT #-} Multimap_ cat (S arr (cat a b :+ arr')) a b where - multimap_ (S _ (f :+ _)) = f - --- "id" instance -instance {-# INCOHERENT #-} CatLike cat => Multimap_ cat (S arr (Rule AnyId Incoherent :+ arr')) x x where - multimap_ _ = catid - --- "Functor" instance --- Note: if x ~ y, then @AnyId Incoherent@ should already have matched earlier --- (if you remembered to put it in the list), --- so we don't need another overlapping instance here. -instance - {-# INCOHERENT #-} - (FunctorOf cat f, MultimapOf cat arr x y) => - Multimap_ cat (S arr (Rule AnyFunctor Incoherent :+ arr')) (f x) (f y) - where - multimap_ (S f (Rule AnyFunctor Incoherent :+ _)) = catmap (multimapOf f) - --- "Bifunctor" instance. --- Note: the overlap with AnyId (where x1 ~ y1, x2 ~ y2) and AnyFunctor (where x1 ~ x2) --- is handled by putting those rules before AnyBifunctor in the list. -instance - {-# INCOHERENT #-} - (BifunctorOf cat f, MultimapOf cat arr x1 y1, MultimapOf cat arr x2 y2) => - Multimap_ cat (S arr (Rule AnyBifunctor Incoherent :+ arr')) (f x1 x2) (f y1 y2) - where - multimap_ (S f (Rule AnyBifunctor Incoherent :+ _)) = catbimap (multimapOf f) (multimapOf f) - --- Hardcoded special case for (->) --- We know how to "Multimap_ (->)" over (->), --- not "Multimap_ (Kleisli f)". -instance - {-# INCOHERENT #-} - (MultimapOf (->) arr y1 x1, MultimapOf (->) arr x2 y2) => - Multimap_ (->) (S arr (Rule AnyBifunctor Incoherent :+ arr')) (x1 -> x2) (y1 -> y2) - where +{-# LANGUAGE + ConstraintKinds, + FlexibleContexts, + FlexibleInstances, + InstanceSigs, + MultiParamTypeClasses, + RankNTypes, + ScopedTypeVariables, + TypeApplications, + TypeFamilies, + TypeOperators, + UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} + +module Generic.Functor.Internal.Implicit where + +import Control.Arrow (Kleisli (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Bifoldable (Bifoldable (..)) +import Data.Bitraversable (Bitraversable (..)) +import Data.Coerce (Coercible, coerce) +import Data.Kind (Type) + +-- | Core of 'multimap' +multimapI :: forall arr x y. MultimapI arr x y => arr -> (x -> y) +multimapI = multimapOf + +multitraverse :: forall f arr x y. Multitraverse f arr x y => arr -> (x -> f y) +multitraverse f = runKleisli (multimapOf (coerce f :: WrapKleisli f arr)) + +-- | This is kept internal because of the 'Fold' wrapping. +multifold_ :: forall m arr x y. Multifold_ m arr x y => arr -> Fold m x y +multifold_ = multimapOf + +multimapOf :: forall cat arr x y. MultimapOf cat arr x y => arr -> cat x y +multimapOf f = multimap_ (s2 f) + +-- | Core of 'multimap'. +class MultimapOf (->) arr x y => MultimapI arr x y +instance MultimapOf (->) arr x y => MultimapI arr x y + +-- | Constraint for 'multifold_'. +class MultimapOf (Fold m) arr x y => Multifold_ m arr x y +instance MultimapOf (Fold m) arr x y => Multifold_ m arr x y + +-- | Constraint for 'multitraverse'. +class Multitraverse_ f arr x y => Multitraverse f arr x y +instance Multitraverse_ f arr x y => Multitraverse f arr x y + +-- | Internal definition of 'Multitraverse' +type Multitraverse_ f arr x y = + ( MultimapOf (Kleisli f) (WrapKleisli f arr) x y, + CoercibleKleisli f (WrapKleisli f arr) arr + ) + +type family WrapKleisli (f :: Type -> Type) (arr :: Type) +type instance WrapKleisli _f NilArr = NilArr +type instance WrapKleisli _f (Rule rule mode)= Rule rule mode +type instance WrapKleisli f (a :+ arr) = WrapKleisli f a :+ WrapKleisli f arr +type instance WrapKleisli f (a -> f b) = Kleisli f a b + +-- | Auxiliary constraint for 'Multitraverse' +class Coercible warr arr => CoercibleKleisli (f :: Type -> Type) warr arr +instance (d ~ NilArr) => CoercibleKleisli f d NilArr +instance (d ~ Rule rule mode) => CoercibleKleisli f d (Rule rule mode) +instance (CoercibleKleisli f a b, CoercibleKleisli f arr arr') => CoercibleKleisli f (a :+ arr) (b :+ arr') +instance (b2 ~ f c, a ~ Kleisli f b1 c) => CoercibleKleisli f a (b1 -> b2) + +class Multimap_ cat (S2 arr) x y => MultimapOf cat arr x y +instance Multimap_ cat (S2 arr) x y => MultimapOf cat arr x y + +-- | @Fold m@ is like @Kleisli (Const m)@, but it has a different @FunctorOf@ instance, +-- with 'Foldable' instead of 'Traversable'. +newtype Fold m x y = Fold { unFold :: x -> m } + +instance Monoid m => CatLike (Fold m) where + catid = Fold (\_ -> mempty) + +instance (Foldable t, Monoid m) => FunctorOf (Fold m) t where + catmap (Fold f) = Fold (foldMap f) + +instance (Bifoldable t, Monoid m) => BifunctorOf (Fold m) t where + catbimap (Fold f) (Fold g) = Fold (bifoldMap f g) + +-- * Internal + +class CatLike cat where + catid :: cat x x + +instance CatLike (->) where + catid = id + +instance Applicative f => CatLike (Kleisli f) where + catid = Kleisli pure + +class FunctorOf cat t where + catmap :: cat a b -> cat (t a) (t b) + +instance Functor t => FunctorOf (->) t where + catmap = fmap + +instance (Applicative f, Traversable t) => FunctorOf (Kleisli f) t where + catmap :: forall a b. Kleisli f a b -> Kleisli f (t a) (t b) + catmap = coerce (traverse @t @f @a @b) + +class BifunctorOf cat t where + catbimap :: cat a b -> cat c d -> cat (t a c) (t b d) + +instance Bifunctor t => BifunctorOf (->) t where + catbimap = bimap + +instance (Applicative f, Bitraversable t) => BifunctorOf (Kleisli f) t where + catbimap :: forall a b c d. Kleisli f a b -> Kleisli f c d -> Kleisli f (t a c) (t b d) + catbimap = coerce (bitraverse @t @f @a @b @c @d) + +-- | Internal implementation of 'MultimapOf'. +class Multimap_ cat arr x y where + multimap_ :: arr -> cat x y + +-- | Heterogeneous lists of arrows are constructed as lists separated by +-- @(':+')@ and terminated by @()@. +-- +-- === Example +-- +-- Given @f :: a -> a'@ and @g :: b -> b'@, +-- @(f ':+' g ':+' ())@ is a list with the two elements @f@ and @g@. +-- +-- @ +-- if +-- f :: a -> a' +-- g :: b -> b' +-- +-- then +-- f ':+' g ':+' () :: (a -> a') ':+' (b -> b') ':+' () +-- @ +-- +-- Those lists are used by 'gmultimap' and 'multimap'. +-- +-- @ +-- bimap_ :: (a -> a') -> (b -> b') -> (Maybe a, [Either b a]) -> (Maybe a', [Either b' a']) +-- bimap_ f g = 'multimap' (f ':+' g ':+' ()) +-- @ +data a :+ b = a :+ b + +infixr 1 :+ + +-- Special arrows + +data Rule rule mode = Rule rule mode +data AnyId = AnyId +data AnyFunctor = AnyFunctor +data AnyBifunctor = AnyBifunctor +data NilArr = NilArr + +data Incoherent = Incoherent + +type Default mode arr = arr :+ Rule AnyId mode :+ Rule AnyFunctor mode :+ Rule AnyBifunctor mode :+ NilArr + +defaultIncoherent :: arr -> Default Incoherent arr +defaultIncoherent = def Incoherent + +def :: mode -> arr -> Default mode arr +def mode arr = arr :+ Rule AnyId mode :+ Rule AnyFunctor mode :+ Rule AnyBifunctor mode :+ NilArr + +-- | @arr@ is the list of arrows provided by the user. It is constant. +-- When testing whether any arrow matches, @arr'@ is the remaining list of +-- arrows to be tested. +data S arr arr' = S arr arr' + +type S2 arr = S arr arr + +s2 :: arr -> S2 arr +s2 f = S f f + +-- The head doesn't match anything, go to the next thing. +instance {-# OVERLAPPABLE #-} Multimap_ cat (S arr arr') x y => Multimap_ cat (S arr (arr0 :+ arr')) x y where + multimap_ (S f (_ :+ g')) = multimap_ (S f g') + +-- Reassociate to even handle tree-shaped parameters. +instance Multimap_ cat (S arr (arr0 :+ arr1 :+ arr2)) x y => Multimap_ cat (S arr ((arr0 :+ arr1) :+ arr2)) x y where + multimap_ (S f ((f0 :+ f1) :+ f2)) = multimap_ (S f (f0 :+ f1 :+ f2)) + +instance Multimap_ cat (S arr arr') x y => Multimap_ cat (S arr (NilArr :+ arr')) x y where + multimap_ (S f (NilArr :+ f')) = multimap_ (S f f') + +instance Multimap_ cat (S arr arr') x y => Multimap_ cat (S arr (() :+ arr')) x y where + multimap_ (S f (() :+ f')) = multimap_ (S f f') + +instance {-# INCOHERENT #-} Multimap_ cat (S arr (cat a b :+ arr')) a b where + multimap_ (S _ (f :+ _)) = f + +-- "id" instance +instance {-# INCOHERENT #-} CatLike cat => Multimap_ cat (S arr (Rule AnyId Incoherent :+ arr')) x x where + multimap_ _ = catid + +-- "Functor" instance +-- Note: if x ~ y, then @AnyId Incoherent@ should already have matched earlier +-- (if you remembered to put it in the list), +-- so we don't need another overlapping instance here. +instance + {-# INCOHERENT #-} + (FunctorOf cat f, MultimapOf cat arr x y) => + Multimap_ cat (S arr (Rule AnyFunctor Incoherent :+ arr')) (f x) (f y) + where + multimap_ (S f (Rule AnyFunctor Incoherent :+ _)) = catmap (multimapOf f) + +-- "Bifunctor" instance. +-- Note: the overlap with AnyId (where x1 ~ y1, x2 ~ y2) and AnyFunctor (where x1 ~ x2) +-- is handled by putting those rules before AnyBifunctor in the list. +instance + {-# INCOHERENT #-} + (BifunctorOf cat f, MultimapOf cat arr x1 y1, MultimapOf cat arr x2 y2) => + Multimap_ cat (S arr (Rule AnyBifunctor Incoherent :+ arr')) (f x1 x2) (f y1 y2) + where + multimap_ (S f (Rule AnyBifunctor Incoherent :+ _)) = catbimap (multimapOf f) (multimapOf f) + +-- Hardcoded special case for (->) +-- We know how to "Multimap_ (->)" over (->), +-- not "Multimap_ (Kleisli f)". +instance + {-# INCOHERENT #-} + (MultimapOf (->) arr y1 x1, MultimapOf (->) arr x2 y2) => + Multimap_ (->) (S arr (Rule AnyBifunctor Incoherent :+ arr')) (x1 -> x2) (y1 -> y2) + where multimap_ (S f (Rule AnyBifunctor Incoherent :+ _)) u = multimapOf f . u . multimapOf f diff --git a/src/Generic/Functor/Multimap.hs b/src/Generic/Functor/Multimap.hs new file mode 100644 --- /dev/null +++ b/src/Generic/Functor/Multimap.hs @@ -0,0 +1,70 @@ +{- | Generalized functors, where the type parameter(s) may be nested in +arbitrary compositions of functors. + +Note that these functions are __unsafe__ because they rely on incoherent +instances. + +See the <#gsolomapusage Usage> section of 'gsolomap' for details. + +=== Example + +@ +{-\# LANGUAGE DeriveGeneric \#-} +module Main where + +import "Generic.Functor" +import "GHC.Generics" ('GHC.Generics.Generic') + +data T a b = C Int a b + deriving (Show, 'GHC.Generics.Generic') + +fmapT :: (b -> b') -> T a b -> T a b' +fmapT = 'gsolomap' + +firstT :: (a -> a') -> T a b -> T a' b +firstT = 'gsolomap' + +bothT :: (a -> a') -> T a a -> T a' a' +bothT = 'gsolomap' + +watT :: + (a -> a') -> + T (a , a ) ((a -> a') -> Maybe a ) -> + T (a', a') ((a' -> a ) -> Maybe a') +watT = 'gsolomap' + +-- Incoherence test +main :: IO () +main = do + print (fmapT ((+1) :: Int -> Int) (C 0 0 0 :: T Int Int)) + print ('gsolomap' ((+1) :: Int -> Int) (C 0 0 0 :: T Int Int) :: T Int Int) + -- NB: Type annotations are needed on both the input and output T Int Int. + putStrLn "We are not the same." + + -- Output: + -- C 0 0 1 + -- C 1 1 1 + -- We are not the same. +@ +-} + +module Generic.Functor.Multimap + ( + -- ** Unary functors + gsolomap + , solomap + + -- ** N-ary functors + , gmultimap + , multimap + , (:+)(..) + + -- ** Generalized functors + , GSolomap() + , Solomap() + , GMultimap() + , Multimap() + ) where + +import Generic.Functor.Internal +import Generic.Functor.Internal.Implicit diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,220 +1,221 @@ -{-# LANGUAGE - DeriveFoldable, - DeriveGeneric, - DerivingVia, - StandaloneDeriving, - TypeOperators #-} - -import Control.Monad.Trans.State ( evalState, state, State ) -import Data.Bifoldable ( Bifoldable() ) -import Data.Bifunctor ( Bifunctor(bimap) ) -import GHC.Generics ( Generic ) -import System.Exit (exitFailure) - -import Generic.Functor - ( gmultimap, - gsolomap, - gtraverse, - multimap, - solomap, - GenericBifunctor(..), - GenericFunctor(..), - type (:+)((:+)) ) - --- Testing GenericFunctor (gfmap) and gsolomap - -data Empty a - deriving Generic - deriving (Functor, Foldable) via (GenericFunctor Empty) - -data Unit a = Unit - deriving (Eq, Show, Generic) - deriving (Functor, Foldable) via (GenericFunctor Unit) - -data Result a r = Error a | Ok r - deriving (Eq, Show, Generic) - deriving (Functor, Foldable) via (GenericFunctor (Result a)) - -instance Traversable Empty where - traverse = gtraverse - -instance Traversable Unit where - traverse = gtraverse - -instance Traversable (Result a) where - traverse = gtraverse - -mapError :: (a -> b) -> Result a r -> Result b r -mapError = gsolomap - -mapOk :: (r -> s) -> Result a r -> Result a s -mapOk = gsolomap - -mapBoth :: (a -> b) -> Result a a -> Result b b -mapBoth = gsolomap - -data Writer w a = Writer w a - deriving (Eq, Show, Generic) - deriving (Functor, Foldable) via (GenericFunctor (Writer w)) - -instance Traversable (Writer w) where - traverse = gtraverse - -mapW :: (w -> w') -> Writer w a -> Writer w' a -mapW = gsolomap - -data Square a b = Square a a b b - deriving (Eq, Show, Generic) - deriving (Functor, Foldable) via (GenericFunctor (Square a)) - -instance Traversable (Square a) where - traverse = gtraverse - -mapFirst :: (a -> a') -> Square a b -> Square a' b -mapFirst = gsolomap - -data Twice a = Twice (Either a a) - deriving (Eq, Show, Generic) - deriving (Functor, Foldable) via (GenericFunctor Twice) - -instance Traversable Twice where - traverse = gtraverse - --- Testing solomap - -map1, map1' :: (a -> b) -> Either e (Maybe [(e, a)]) -> Either e (Maybe [(e, b)]) -map1 = solomap -map1' = fmap . fmap . fmap . fmap -- equivalent definition, just making sure it typechecks - -map2, map2' :: (a -> b) -> (e -> Either [a] r) -> (e -> Either [b] r) -map2 = solomap -map2' f = fmap (bimap (fmap f) id) - -type F a = ([a], Either a ()) - -map3, map3' :: (a -> b) -> F a -> F b -map3 = solomap -map3' f = bimap (fmap f) (bimap f id) - -type G t a = (t, Maybe [Either Bool a]) - -map4, map4', map4'' :: (a -> b) -> G t a -> G t b -map4 = solomap -map4' = fmap . fmap . fmap . fmap -map4'' = multimap - -map6, map6' :: (a -> b) -> (c -> d) -> G a c -> G b d -map6 f g = multimap (f :+ g) -map6' f = bimap f . fmap . fmap . fmap - --- Deriving Bifunctor - -data Tree a b = Node a (Tree a b) (Tree a b) | Leaf b - deriving (Eq, Show, Generic) - deriving (Functor, Foldable) via (GenericFunctor (Tree a)) - deriving (Bifunctor, Bifoldable) via (GenericBifunctor Tree) - -instance Traversable (Tree a) where - traverse = gtraverse - -data CofreeF f a b = a :< f b - deriving (Eq, Show, Generic) - deriving (Bifunctor, Bifoldable) via (GenericBifunctor (CofreeF f)) - -deriving via GenericFunctor (CofreeF f a) instance Foldable f => Foldable (CofreeF f a) -deriving via GenericFunctor (CofreeF f a) instance Functor f => Functor (CofreeF f a) - -instance Traversable f => Traversable (CofreeF f a) where - traverse = gtraverse - -bimapCofreeF' :: Functor f => (a -> b) -> (c -> d) -> CofreeF f a c -> CofreeF f b d -bimapCofreeF' f g = gmultimap (f :+ g) - --- Multimap - -data Three a b c = One a | Two b | Three c - deriving (Eq, Show, Generic) - deriving (Functor, Foldable) via (GenericFunctor (Three a b)) - -instance Traversable (Three a b) where - traverse = gtraverse - -mapThree :: (a -> a') -> (b -> b') -> (c -> c') -> Three a b c -> Three a' b' c' -mapThree f g h = gmultimap (f :+ g :+ h) - -type F5 a b c = Either a (b, c) - -map5, map5' :: (a -> a') -> (b -> b') -> (c -> c') -> F5 a b c -> F5 a' b' c' -map5 f g h = multimap (f :+ g :+ h) -map5' f g h = bimap f (bimap g h) - --- Run at least once - -twice :: Int -> Int -twice = (* 2) - -foldTest :: Foldable t => t Int -> Int -foldTest = sum -- specialized - -tick :: Int -> State Int Int -tick _ = state (\i -> (i, i+1)) - -travTest :: Traversable t => t Int -> t Int -travTest = (`evalState` 0) . traverse tick - -main :: IO () -main = do - Unit @= fmap twice Unit - Ok 8 @= fmap twice (Ok 4 :: Result () Int) - Error 8 @= mapError twice (Error 4 :: Result Int ()) - Writer () 8 @= fmap twice (Writer () 4) - Writer 8 () @= mapW twice (Writer 4 ()) - Square () () 8 10 @= fmap twice (Square () () 4 5) - Square 8 10 () () @= mapFirst twice (Square 4 5 () ()) - [Twice (Left 8), Twice (Right 10)] @= (fmap . fmap) twice [Twice (Left 4), Twice (Right 5)] - Node 8 (Leaf 10) (Leaf 12) @= bimap twice twice (Node 4 (Leaf 5) (Leaf 6)) - (8 :< Just 10) @= bimap twice twice (4 :< Just 5) - [One 8, Two False, Three 1] @= fmap (mapThree twice not length) [One 4, Two True, Three [()]] - - let t1 = Right (Just [((), 4)]) - map1 twice t1 @= map1' twice t1 - - let t2 x = Left [x] :: Either [Int] () - map2 twice t2 4 @= map2' twice t2 4 - - let t3 = ([4], Left 5) - map3 twice t3 @= map3' twice t3 - - let t4 = ((), Just [Right 4]) - map4 twice t4 @= map4' twice t4 - map4 twice t4 @= map4'' twice t4 - - map6 (const True) twice t4 @= map6' (const True) twice t4 - - let t5 = [Left 4, Right (False, [()])] - fmap (map5 twice not length) t5 @= fmap (map5 twice not length) t5 - - -- Foldable - 0 @= foldTest Unit - 4 @= foldTest (Ok 4 :: Result () Int) - 0 @= foldTest (Error 4 :: Result Int Int) - 4 @= foldTest (Writer () 4) - 9 @= foldTest (Square () () 4 5) - 3 @= foldTest (Node 4 (Leaf 1) (Leaf 2) :: Tree Int Int) - - -- Traversable - Unit @= travTest Unit - Ok 0 @= travTest (Ok 4 :: Result () Int) - Error 4 @= travTest (Error 4 :: Result Int Int) - Writer () 0 @= travTest (Writer () 4) - Square () () 0 1 @= travTest (Square () () 4 5) - Node 4 (Leaf 0) (Leaf 1) @= travTest (Node 4 (Leaf 5) (Leaf 6) :: Tree Int Int) - --- Assert equality -(@=) :: (Eq a, Show a) => a -> a -> IO () -(@=) x y | x == y = pure () - | otherwise = do - putStrLn "Not equal:" - print x - print y - exitFailure +{-# LANGUAGE + DeriveFoldable, + DeriveGeneric, + DerivingVia, + StandaloneDeriving, + TypeOperators #-} + +import Control.Monad.Trans.State ( evalState, state, State ) +import Data.Bifoldable ( Bifoldable() ) +import Data.Bifunctor ( Bifunctor(bimap) ) +import GHC.Generics ( Generic ) +import System.Exit (exitFailure) + +import Generic.Functor + ( gtraverse, + GenericBifunctor(..), + GenericFunctor(..) ) +import Generic.Functor.Multimap + ( gmultimap, + gsolomap, + multimap, + solomap, + type (:+)((:+)) ) + +-- Testing GenericFunctor (gfmap) and gsolomap + +data Empty a + deriving Generic + deriving (Functor, Foldable) via (GenericFunctor Empty) + +data Unit a = Unit + deriving (Eq, Show, Generic) + deriving (Functor, Foldable) via (GenericFunctor Unit) + +data Result a r = Error a | Ok r + deriving (Eq, Show, Generic) + deriving (Functor, Foldable) via (GenericFunctor (Result a)) + +instance Traversable Empty where + traverse = gtraverse + +instance Traversable Unit where + traverse = gtraverse + +instance Traversable (Result a) where + traverse = gtraverse + +mapError :: (a -> b) -> Result a r -> Result b r +mapError = gsolomap + +mapOk :: (r -> s) -> Result a r -> Result a s +mapOk = gsolomap + +mapBoth :: (a -> b) -> Result a a -> Result b b +mapBoth = gsolomap + +data Writer w a = Writer w a + deriving (Eq, Show, Generic) + deriving (Functor, Foldable) via (GenericFunctor (Writer w)) + +instance Traversable (Writer w) where + traverse = gtraverse + +mapW :: (w -> w') -> Writer w a -> Writer w' a +mapW = gsolomap + +data Square a b = Square a a b b + deriving (Eq, Show, Generic) + deriving (Functor, Foldable) via (GenericFunctor (Square a)) + +instance Traversable (Square a) where + traverse = gtraverse + +mapFirst :: (a -> a') -> Square a b -> Square a' b +mapFirst = gsolomap + +data Twice a = Twice (Either a a) + deriving (Eq, Show, Generic) + deriving (Functor, Foldable) via (GenericFunctor Twice) + +instance Traversable Twice where + traverse = gtraverse + +-- Testing solomap + +map1, map1' :: (a -> b) -> Either e (Maybe [(e, a)]) -> Either e (Maybe [(e, b)]) +map1 = solomap +map1' = fmap . fmap . fmap . fmap -- equivalent definition, just making sure it typechecks + +map2, map2' :: (a -> b) -> (e -> Either [a] r) -> (e -> Either [b] r) +map2 = solomap +map2' f = fmap (bimap (fmap f) id) + +type F a = ([a], Either a ()) + +map3, map3' :: (a -> b) -> F a -> F b +map3 = solomap +map3' f = bimap (fmap f) (bimap f id) + +type G t a = (t, Maybe [Either Bool a]) + +map4, map4', map4'' :: (a -> b) -> G t a -> G t b +map4 = solomap +map4' = fmap . fmap . fmap . fmap +map4'' = multimap + +map6, map6' :: (a -> b) -> (c -> d) -> G a c -> G b d +map6 f g = multimap (f :+ g) +map6' f = bimap f . fmap . fmap . fmap + +-- Deriving Bifunctor + +data Tree a b = Node a (Tree a b) (Tree a b) | Leaf b + deriving (Eq, Show, Generic) + deriving (Functor, Foldable) via (GenericFunctor (Tree a)) + deriving (Bifunctor, Bifoldable) via (GenericBifunctor Tree) + +instance Traversable (Tree a) where + traverse = gtraverse + +data CofreeF f a b = a :< f b + deriving (Eq, Show, Generic) + deriving (Bifunctor, Bifoldable) via (GenericBifunctor (CofreeF f)) + +deriving via GenericFunctor (CofreeF f a) instance Foldable f => Foldable (CofreeF f a) +deriving via GenericFunctor (CofreeF f a) instance Functor f => Functor (CofreeF f a) + +instance Traversable f => Traversable (CofreeF f a) where + traverse = gtraverse + +bimapCofreeF' :: Functor f => (a -> b) -> (c -> d) -> CofreeF f a c -> CofreeF f b d +bimapCofreeF' f g = gmultimap (f :+ g) + +-- Multimap + +data Three a b c = One a | Two b | Three c + deriving (Eq, Show, Generic) + deriving (Functor, Foldable) via (GenericFunctor (Three a b)) + +instance Traversable (Three a b) where + traverse = gtraverse + +mapThree :: (a -> a') -> (b -> b') -> (c -> c') -> Three a b c -> Three a' b' c' +mapThree f g h = gmultimap (f :+ g :+ h) + +type F5 a b c = Either a (b, c) + +map5, map5' :: (a -> a') -> (b -> b') -> (c -> c') -> F5 a b c -> F5 a' b' c' +map5 f g h = multimap (f :+ g :+ h) +map5' f g h = bimap f (bimap g h) + +-- Run at least once + +twice :: Int -> Int +twice = (* 2) + +foldTest :: Foldable t => t Int -> Int +foldTest = sum -- specialized + +tick :: Int -> State Int Int +tick _ = state (\i -> (i, i+1)) + +travTest :: Traversable t => t Int -> t Int +travTest = (`evalState` 0) . traverse tick + +main :: IO () +main = do + Unit @= fmap twice Unit + Ok 8 @= fmap twice (Ok 4 :: Result () Int) + Error 8 @= mapError twice (Error 4 :: Result Int ()) + Writer () 8 @= fmap twice (Writer () 4) + Writer 8 () @= mapW twice (Writer 4 ()) + Square () () 8 10 @= fmap twice (Square () () 4 5) + Square 8 10 () () @= mapFirst twice (Square 4 5 () ()) + [Twice (Left 8), Twice (Right 10)] @= (fmap . fmap) twice [Twice (Left 4), Twice (Right 5)] + Node 8 (Leaf 10) (Leaf 12) @= bimap twice twice (Node 4 (Leaf 5) (Leaf 6)) + (8 :< Just 10) @= bimap twice twice (4 :< Just 5) + [One 8, Two False, Three 1] @= fmap (mapThree twice not length) [One 4, Two True, Three [()]] + + let t1 = Right (Just [((), 4)]) + map1 twice t1 @= map1' twice t1 + + let t2 x = Left [x] :: Either [Int] () + map2 twice t2 4 @= map2' twice t2 4 + + let t3 = ([4], Left 5) + map3 twice t3 @= map3' twice t3 + + let t4 = ((), Just [Right 4]) + map4 twice t4 @= map4' twice t4 + map4 twice t4 @= map4'' twice t4 + + map6 (const True) twice t4 @= map6' (const True) twice t4 + + let t5 = [Left 4, Right (False, [()])] + fmap (map5 twice not length) t5 @= fmap (map5 twice not length) t5 + + -- Foldable + 0 @= foldTest Unit + 4 @= foldTest (Ok 4 :: Result () Int) + 0 @= foldTest (Error 4 :: Result Int Int) + 4 @= foldTest (Writer () 4) + 9 @= foldTest (Square () () 4 5) + 3 @= foldTest (Node 4 (Leaf 1) (Leaf 2) :: Tree Int Int) + + -- Traversable + Unit @= travTest Unit + Ok 0 @= travTest (Ok 4 :: Result () Int) + Error 4 @= travTest (Error 4 :: Result Int Int) + Writer () 0 @= travTest (Writer () 4) + Square () () 0 1 @= travTest (Square () () 4 5) + Node 4 (Leaf 0) (Leaf 1) @= travTest (Node 4 (Leaf 5) (Leaf 6) :: Tree Int Int) + +-- Assert equality +(@=) :: (Eq a, Show a) => a -> a -> IO () +(@=) x y | x == y = pure () + | otherwise = do + putStrLn "Not equal:" + print x + print y + exitFailure