{-# 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 Data.Bifunctor import Data.Coerce import GHC.Generics hiding (S) -- | Generic implementation of 'fmap'. See also 'DeriveFunctor' 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 . gmap1 (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. gsolomap :: forall a b x y. (Generic x, Generic y, GSolomap a b x y) => (a -> b) -> (x -> y) gsolomap f = to . gmap1 (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 . gmap1 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 = multimap_ (s2 f) -- | Generic implementation of 'bimap'. See also 'DeriveBifunctor'. gbimap :: forall f a b c d. GBifunctor f => (a -> b) -> (c -> d) -> f a c -> f b d gbimap f g = with @(GBifunctorRep a b c d f) (to . gmap1 (f :+ g :+ ()) . from) -- | Generic implementation of 'first'. See also 'DeriveBifunctor'. 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 . gmap1 (f :+ ()) . from) -- | Generic implementation of 'second'. See also 'DeriveBifunctor'. gsecond :: forall f a c d. GSecond f => (c -> d) -> f a c -> f a d gsecond = gfmap -- | 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@ -- | 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 ((a -> b) :+ ()) (Rep (f a)) (Rep (f b)) => GFunctorRep a b f instance GMap1 ((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. GBifunctorRep a b c d f) => GBifunctor f instance (forall a c. Generic (f a c), forall a b c d. GBifunctorRep a b c d f) => GBifunctor f -- | Internal component of 'GBifunctor'. class GMap1 ((a -> b) :+ (c -> d) :+ ()) (Rep (f a c)) (Rep (f b d)) => GBifunctorRep a b c d f instance GMap1 ((a -> b) :+ (c -> d) :+ ()) (Rep (f a c)) (Rep (f b d)) => GBifunctorRep 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 ((a -> b) :+ ()) (Rep (f a c)) (Rep (f b c)) => GFirstRep a b c f instance GMap1 ((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 -- *** Others -- | Constraint for 'gsolomap'. class GMap1 ((a -> b) :+ ()) (Rep x) (Rep y) => GSolomap a b x y instance GMap1 ((a -> b) :+ ()) (Rep x) (Rep 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 arr (Rep x) (Rep y) => GMultimap arr x y instance GMap1 arr (Rep x) (Rep y) => GMultimap arr x y -- | Constraint for 'multimap'. class Multimap_ (S2 arr) x y => Multimap arr x y instance Multimap_ (S2 arr) x y => Multimap arr x y -- * Deriving Via -- ** Functor -- | @newtype@ for @DerivingVia@ of 'Functor' instances. -- -- Note: the GHC extension @DeriveFunctor@ 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" ('DeriveFunctor'(..)) -- -- data Twice a = Twice (Either a a) -- deriving 'Generic' -- deriving 'Functor' via ('DeriveFunctor' Twice) -- @ newtype DeriveFunctor f a = DeriveFunctor (f a) instance GFunctor f => Functor (DeriveFunctor f) where fmap = coerce1 (gfmap @f) -- ** Bifunctor -- | @newtype@ for @DerivingVia@ of 'Bifunctor' instances. -- -- Note: deriving 'Bifunctor' for a generic type often requires 'Functor' -- instances for types mentioned in the fields. -- -- === Example -- -- @ -- {-\# LANGUAGE DeriveGeneric, DerivingVia \#-} -- -- import "GHC.Generics" ('Generic') -- import "Generic.Functor" ('DeriveFunctor'(..), 'DeriveBifunctor'(..)) -- -- data Tree a b = Node a (Tree a b) (Tree a b) | Leaf b -- deriving 'Generic' -- deriving 'Functor' via ('DeriveFunctor' (Tree a)) -- deriving 'Bifunctor' via ('DeriveBifunctor' Tree) -- -- data CofreeF f a b = a :< f b -- deriving 'Generic' -- deriving 'Bifunctor' via ('DeriveBifunctor' (CofreeF f)) -- @ newtype DeriveBifunctor f a b = DeriveBifunctor (f a b) instance (GBifunctor f, GFirst f, GSecond f) => Bifunctor (DeriveBifunctor f) where bimap = coerce2 (gbimap @f) first = coerce3 (gfirst @f) second = coerce3 (gsecond @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 -- class GMap1 arr f g where gmap1 :: arr -> f () -> g () instance GMap1 arr f g => GMap1 arr (M1 i c f) (M1 i' c'' g) where gmap1 = coerce (gmap1 @arr @f @g) instance (GMap1 arr f1 g1, GMap1 arr f2 g2) => GMap1 arr (f1 :+: f2) (g1 :+: g2) where gmap1 f (L1 x) = L1 (gmap1 f x) gmap1 f (R1 x) = R1 (gmap1 f x) instance (GMap1 arr f1 g1, GMap1 arr f2 g2) => GMap1 arr (f1 :*: f2) (g1 :*: g2) where gmap1 f (x :*: y) = gmap1 f x :*: gmap1 f y instance GMap1 arr U1 U1 where gmap1 _ U1 = U1 instance GMap1 arr V1 V1 where gmap1 _ v = case v of {} instance Multimap arr x y => GMap1 arr (K1 i x) (K1 i' y) where gmap1 = coerce (multimap @arr @x @y) -- | Internal implementation of 'Solomap'. class Multimap_ arr x y where multimap_ :: arr -> 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 :+ -- | @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 instance {-# INCOHERENT #-} Multimap_ (S arr ((a -> b) :+ arr')) a b where multimap_ (S _ (f :+ _)) = f instance Multimap_ (S arr arr') x y => Multimap_ (S arr ((a -> b) :+ arr')) x y where multimap_ (S f (_ :+ g')) = multimap_ (S f g') -- "id" instance instance {-# INCOHERENT #-} Multimap_ (S arr ()) x x where multimap_ _ = id -- "Functor" instance instance {-# INCOHERENT #-} (Functor f, Multimap arr x y) => Multimap_ (S arr ()) (f x) (f y) where multimap_ (S f ()) = fmap (multimap f) -- Intersection of "id" and "Functor" instances. Prefer "id". -- When both of those instances match then this one should match and avoid an -- unnecessary and overly restrictive Functor constraint. instance {-# INCOHERENT #-} Multimap_ (S arr ()) (f x) (f x) where multimap_ _ = id instance (Multimap arr y1 x1, Multimap arr x2 y2) => Multimap_ (S arr ()) (x1 -> x2) (y1 -> y2) where multimap_ (S f ()) u = multimap f . u . multimap f -- "Bifunctor" instance. instance {-# INCOHERENT #-} (Bifunctor f, Multimap arr x1 y1, Multimap arr x2 y2) => Multimap_ (S arr ()) (f x1 x2) (f y1 y2) where multimap_ (S f ()) = bimap (multimap f) (multimap f) -- Intersection of "Bifunctor" and "Functor" instances. Prefer "Functor". instance {-# INCOHERENT #-} (Functor (f x), Multimap arr x2 y2) => Multimap_ (S arr ()) (f x x2) (f x y2) where multimap_ (S f ()) = fmap (multimap f) -- Intersection of "Bifunctor", "Functor", and "id" instances. Prefer "id". instance {-# INCOHERENT #-} Multimap_ (S arr ()) (f x y) (f x y) where multimap_ _ = id