{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Generics.Product.Internal.Constraints
(
GHasConstraints (..)
, GHasConstraints' (..)
) where
import Data.Kind (Type, Constraint)
import GHC.Generics
import Data.Generics.Internal.VL.Iso
import Data.Generics.Internal.VL.Traversal
import Data.Generics.Product.Internal.HList
class GHasConstraints' (c :: * -> Constraint) (f :: * -> *) where
gconstraints' :: forall g x.
Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)
instance
( GHasConstraints' c l
, GHasConstraints' c r
) => GHasConstraints' c (l :*: r) where
gconstraints' :: (forall a. c a => a -> g a) -> (:*:) l r x -> g ((:*:) l r x)
gconstraints' f :: forall a. c a => a -> g a
f (l :: l x
l :*: r :: r x
r)
= l x -> r x -> (:*:) l r x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (l x -> r x -> (:*:) l r x) -> g (l x) -> g (r x -> (:*:) l r x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. c a => a -> g a) -> l x -> g (l x)
forall (c :: * -> Constraint) (f :: * -> *) (g :: * -> *) x.
(GHasConstraints' c f, Applicative g) =>
(forall a. c a => a -> g a) -> f x -> g (f x)
gconstraints' @c forall a. c a => a -> g a
f l x
l g (r x -> (:*:) l r x) -> g (r x) -> g ((:*:) l r x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. c a => a -> g a) -> r x -> g (r x)
forall (c :: * -> Constraint) (f :: * -> *) (g :: * -> *) x.
(GHasConstraints' c f, Applicative g) =>
(forall a. c a => a -> g a) -> f x -> g (f x)
gconstraints' @c forall a. c a => a -> g a
f r x
r
instance
( GHasConstraints' c l
, GHasConstraints' c r
) => GHasConstraints' c (l :+: r) where
gconstraints' :: (forall a. c a => a -> g a) -> (:+:) l r x -> g ((:+:) l r x)
gconstraints' f :: forall a. c a => a -> g a
f (L1 l :: l x
l) = l x -> (:+:) l r x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (l x -> (:+:) l r x) -> g (l x) -> g ((:+:) l r x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. c a => a -> g a) -> l x -> g (l x)
forall (c :: * -> Constraint) (f :: * -> *) (g :: * -> *) x.
(GHasConstraints' c f, Applicative g) =>
(forall a. c a => a -> g a) -> f x -> g (f x)
gconstraints' @c forall a. c a => a -> g a
f l x
l
gconstraints' f :: forall a. c a => a -> g a
f (R1 r :: r x
r) = r x -> (:+:) l r x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (r x -> (:+:) l r x) -> g (r x) -> g ((:+:) l r x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. c a => a -> g a) -> r x -> g (r x)
forall (c :: * -> Constraint) (f :: * -> *) (g :: * -> *) x.
(GHasConstraints' c f, Applicative g) =>
(forall a. c a => a -> g a) -> f x -> g (f x)
gconstraints' @c forall a. c a => a -> g a
f r x
r
instance c a => GHasConstraints' c (Rec0 a) where
gconstraints' :: (forall a. c a => a -> g a) -> Rec0 a x -> g (Rec0 a x)
gconstraints' = (forall a. c a => a -> g a) -> Rec0 a x -> g (Rec0 a x)
forall r a p b. Iso (K1 r a p) (K1 r b p) a b
kIso
instance GHasConstraints' c f
=> GHasConstraints' c (M1 m meta f) where
gconstraints' :: (forall a. c a => a -> g a) -> M1 m meta f x -> g (M1 m meta f x)
gconstraints' f :: forall a. c a => a -> g a
f (M1 x :: f x
x) = f x -> M1 m meta f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f x -> M1 m meta f x) -> g (f x) -> g (M1 m meta f x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. c a => a -> g a) -> f x -> g (f x)
forall (c :: * -> Constraint) (f :: * -> *) (g :: * -> *) x.
(GHasConstraints' c f, Applicative g) =>
(forall a. c a => a -> g a) -> f x -> g (f x)
gconstraints' @c forall a. c a => a -> g a
f f x
x
instance GHasConstraints' c U1 where
gconstraints' :: (forall a. c a => a -> g a) -> U1 x -> g (U1 x)
gconstraints' _ _ = U1 x -> g (U1 x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 x
forall k (p :: k). U1 p
U1
class GHasConstraints (c :: * -> * -> Constraint) s t where
gconstraints :: TraversalC c (s x) (t x)
instance
( GHasConstraints c l l'
, GHasConstraints c r r'
) => GHasConstraints c (l :*: r) (l' :*: r') where
gconstraints :: (forall a b. c a b => a -> f b) -> (:*:) l r x -> f ((:*:) l' r' x)
gconstraints f :: forall a b. c a b => a -> f b
f (l :: l x
l :*: r :: r x
r)
= l' x -> r' x -> (:*:) l' r' x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (l' x -> r' x -> (:*:) l' r' x)
-> f (l' x) -> f (r' x -> (:*:) l' r' x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. c a b => a -> f b) -> l x -> f (l' x)
forall (c :: * -> * -> Constraint) (s :: * -> *) (t :: * -> *) x.
GHasConstraints c s t =>
TraversalC c (s x) (t x)
gconstraints @c forall a b. c a b => a -> f b
f l x
l f (r' x -> (:*:) l' r' x) -> f (r' x) -> f ((:*:) l' r' x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a b. c a b => a -> f b) -> r x -> f (r' x)
forall (c :: * -> * -> Constraint) (s :: * -> *) (t :: * -> *) x.
GHasConstraints c s t =>
TraversalC c (s x) (t x)
gconstraints @c forall a b. c a b => a -> f b
f r x
r
instance
( GHasConstraints c l l'
, GHasConstraints c r r'
) => GHasConstraints c (l :+: r) (l' :+: r') where
gconstraints :: (forall a b. c a b => a -> f b) -> (:+:) l r x -> f ((:+:) l' r' x)
gconstraints f :: forall a b. c a b => a -> f b
f (L1 l :: l x
l) = l' x -> (:+:) l' r' x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (l' x -> (:+:) l' r' x) -> f (l' x) -> f ((:+:) l' r' x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. c a b => a -> f b) -> l x -> f (l' x)
forall (c :: * -> * -> Constraint) (s :: * -> *) (t :: * -> *) x.
GHasConstraints c s t =>
TraversalC c (s x) (t x)
gconstraints @c forall a b. c a b => a -> f b
f l x
l
gconstraints f :: forall a b. c a b => a -> f b
f (R1 r :: r x
r) = r' x -> (:+:) l' r' x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (r' x -> (:+:) l' r' x) -> f (r' x) -> f ((:+:) l' r' x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. c a b => a -> f b) -> r x -> f (r' x)
forall (c :: * -> * -> Constraint) (s :: * -> *) (t :: * -> *) x.
GHasConstraints c s t =>
TraversalC c (s x) (t x)
gconstraints @c forall a b. c a b => a -> f b
f r x
r
instance GHasConstraints c s t
=> GHasConstraints c (M1 i m s) (M1 i m t) where
gconstraints :: (forall a b. c a b => a -> f b) -> M1 i m s x -> f (M1 i m t x)
gconstraints f :: forall a b. c a b => a -> f b
f (M1 x :: s x
x) = t x -> M1 i m t x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (t x -> M1 i m t x) -> f (t x) -> f (M1 i m t x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. c a b => a -> f b) -> s x -> f (t x)
forall (c :: * -> * -> Constraint) (s :: * -> *) (t :: * -> *) x.
GHasConstraints c s t =>
TraversalC c (s x) (t x)
gconstraints @c forall a b. c a b => a -> f b
f s x
x
instance GHasConstraints c U1 U1 where
gconstraints :: (forall a b. c a b => a -> f b) -> U1 x -> f (U1 x)
gconstraints _ _ = U1 x -> f (U1 x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 x
forall k (p :: k). U1 p
U1
instance GHasConstraints c V1 V1 where
gconstraints :: (forall a b. c a b => a -> f b) -> V1 x -> f (V1 x)
gconstraints _ = V1 x -> f (V1 x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance c a b => GHasConstraints c (Rec0 a) (Rec0 b) where
gconstraints :: (forall a b. c a b => a -> f b) -> Rec0 a x -> f (Rec0 b x)
gconstraints = (forall a b. c a b => a -> f b) -> Rec0 a x -> f (Rec0 b x)
forall r a p b. Iso (K1 r a p) (K1 r b p) a b
kIso
type family Functions (ts :: [Type]) (g :: Type -> Type) = r | r -> ts where
Functions '[] _ = '[]
Functions (t ': ts) g = ((t -> g t) ': Functions ts g)
class Contains as a where
pick :: Applicative g => HList (Functions as g) -> a -> g a
instance {-# OVERLAPPING #-} Contains (a ': as) a where
pick :: HList (Functions (a : as) g) -> a -> g a
pick (h :: a
h :> _) = a
a -> g a
h
instance Contains as a => Contains (b ': as) a where
pick :: HList (Functions (b : as) g) -> a -> g a
pick (_ :> hs :: HList as
hs) = HList (Functions as g) -> a -> g a
forall (as :: [*]) a (g :: * -> *).
(Contains as a, Applicative g) =>
HList (Functions as g) -> a -> g a
pick HList as
HList (Functions as g)
hs
instance Contains '[] a where
pick :: HList (Functions '[] g) -> a -> g a
pick _ = a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure