{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Generics.Product.Param
( Rec (Rec)
, HasParam (..)
) where
import GHC.TypeLits
import Data.Generics.Internal.Void
import Data.Generics.Internal.Families.Changing
import Data.Generics.Internal.VL.Traversal
import GHC.Generics
import Data.Kind
import Data.Generics.Internal.VL.Iso
import Data.Generics.Internal.GenericN
import Data.Generics.Internal.Errors
class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where
param :: Applicative g => (a -> g b) -> s -> g t
instance
( GenericN s
, GenericN t
, Defined (Rep s)
(NoGeneric s
'[ 'Text "arising from a generic traversal of the type parameter at position " ':<>: QuoteType n
, 'Text "of type " ':<>: QuoteType a ':<>: 'Text " in " ':<>: QuoteType s
])
(() :: Constraint)
, s ~ Infer t (P n b 'PTag) a
, t ~ Infer s (P n a 'PTag) b
, Error ((ArgCount s) <=? n) n (ArgCount s) s
, a ~ ArgAt s n
, b ~ ArgAt t n
, GHasParam n (RepN s) (RepN t) a b
) => HasParam n s t a b where
param :: (a -> g b) -> s -> g t
param = (forall (g :: * -> *). Applicative g => (a -> g b) -> s -> g t)
-> (a -> g b) -> s -> g t
forall (f :: * -> *) s t a b.
Applicative f =>
Traversal s t a b -> (a -> f b) -> s -> f t
confusing (\f :: a -> f b
f s :: s
s -> Zip (Rep (Indexed t 0)) (Rep t) Any -> t
forall a x. GenericN a => RepN a x -> a
toN (Zip (Rep (Indexed t 0)) (Rep t) Any -> t)
-> f (Zip (Rep (Indexed t 0)) (Rep t) Any) -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b)
-> Zip (Rep (Indexed s 0)) (Rep s) Any
-> f (Zip (Rep (Indexed t 0)) (Rep t) Any)
forall (p :: Nat) (s :: * -> *) (t :: * -> *) a b (g :: * -> *) x.
(GHasParam p s t a b, Applicative g) =>
(a -> g b) -> s x -> g (t x)
gparam @n a -> f b
f (s -> RepN s Any
forall a x. GenericN a => a -> RepN a x
fromN s
s))
{-# INLINE param #-}
type family Error (b :: Bool) (expected :: Nat) (actual :: Nat) (s :: Type) :: Constraint where
Error 'False _ _ _
= ()
Error 'True expected actual typ
= TypeError
( 'Text "Expected a type with at least "
':<>: 'ShowType (expected + 1)
':<>: 'Text " parameters, but "
':$$: 'ShowType typ
':<>: 'Text " only has "
':<>: 'ShowType actual
)
instance {-# OVERLAPPING #-} HasParam p (Void1 a) (Void1 b) a b where
param :: (a -> g b) -> Void1 a -> g (Void1 b)
param = (a -> g b) -> Void1 a -> g (Void1 b)
forall a. HasCallStack => a
undefined
class GHasParam (p :: Nat) s t a b where
gparam :: forall g (x :: Type). Applicative g => (a -> g b) -> s x -> g (t x)
instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :*: r) (l' :*: r') a b where
gparam :: (a -> g b) -> (:*:) l r x -> g ((:*:) l' r' x)
gparam f :: a -> g 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)
-> g (l' x) -> g (r' x -> (:*:) l' r' x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> g b) -> l x -> g (l' x)
forall (p :: Nat) (s :: * -> *) (t :: * -> *) a b (g :: * -> *) x.
(GHasParam p s t a b, Applicative g) =>
(a -> g b) -> s x -> g (t x)
gparam @p a -> g b
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
<*> (a -> g b) -> r x -> g (r' x)
forall (p :: Nat) (s :: * -> *) (t :: * -> *) a b (g :: * -> *) x.
(GHasParam p s t a b, Applicative g) =>
(a -> g b) -> s x -> g (t x)
gparam @p a -> g b
f r x
r
instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :+: r) (l' :+: r') a b where
gparam :: (a -> g b) -> (:+:) l r x -> g ((:+:) l' r' x)
gparam f :: a -> g 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) -> g (l' x) -> g ((:+:) l' r' x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> g b) -> l x -> g (l' x)
forall (p :: Nat) (s :: * -> *) (t :: * -> *) a b (g :: * -> *) x.
(GHasParam p s t a b, Applicative g) =>
(a -> g b) -> s x -> g (t x)
gparam @p a -> g b
f l x
l
gparam f :: a -> g 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) -> g (r' x) -> g ((:+:) l' r' x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> g b) -> r x -> g (r' x)
forall (p :: Nat) (s :: * -> *) (t :: * -> *) a b (g :: * -> *) x.
(GHasParam p s t a b, Applicative g) =>
(a -> g b) -> s x -> g (t x)
gparam @p a -> g b
f r x
r
instance GHasParam p U1 U1 a b where
gparam :: (a -> g b) -> U1 x -> g (U1 x)
gparam _ _ = U1 x -> g (U1 x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 x
forall k (p :: k). U1 p
U1
instance GHasParam p s t a b => GHasParam p (M1 m meta s) (M1 m meta t) a b where
gparam :: (a -> g b) -> M1 m meta s x -> g (M1 m meta t x)
gparam f :: a -> g b
f (M1 x :: s x
x) = t x -> M1 m meta t x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (t x -> M1 m meta t x) -> g (t x) -> g (M1 m meta t x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> g b) -> s x -> g (t x)
forall (p :: Nat) (s :: * -> *) (t :: * -> *) a b (g :: * -> *) x.
(GHasParam p s t a b, Applicative g) =>
(a -> g b) -> s x -> g (t x)
gparam @p a -> g b
f s x
x
instance GHasParam p (Rec (param p) a) (Rec (param p) b) a b where
gparam :: (a -> g b) -> Rec (param p) a x -> g (Rec (param p) b x)
gparam = (a -> g b) -> Rec (param p) a x -> g (Rec (param p) b x)
forall r a p b. Iso (Rec r a p) (Rec r b p) a b
recIso
instance {-# OVERLAPPABLE #-}
( GHasParamRec (LookupParam si p) s t a b
) => GHasParam p (Rec si s) (Rec ti t) a b where
gparam :: (a -> g b) -> Rec si s x -> g (Rec ti t x)
gparam f :: a -> g b
f (Rec (K1 x :: s
x)) = K1 R t x -> Rec ti t x
forall k p a (x :: k). K1 R a x -> Rec p a x
Rec (K1 R t x -> Rec ti t x) -> (t -> K1 R t x) -> t -> Rec ti t x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> K1 R t x
forall k i c (p :: k). c -> K1 i c p
K1 (t -> Rec ti t x) -> g t -> g (Rec ti t x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> g b) -> s -> g t
forall (param :: Maybe Nat) s t a b (g :: * -> *).
(GHasParamRec param s t a b, Applicative g) =>
(a -> g b) -> s -> g t
gparamRec @(LookupParam si p) a -> g b
f s
x
class GHasParamRec (param :: Maybe Nat) s t a b | param t a b -> s, param s a b -> t where
gparamRec :: forall g. Applicative g => (a -> g b) -> s -> g t
instance GHasParamRec 'Nothing a a c d where
gparamRec :: (c -> g d) -> a -> g a
gparamRec _ = a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance (HasParam n s t a b) => GHasParamRec ('Just n) s t a b where
gparamRec :: (a -> g b) -> s -> g t
gparamRec = forall s t a b (g :: * -> *).
(HasParam n s t a b, Applicative g) =>
(a -> g b) -> s -> g t
forall (n :: Nat) s t a b (g :: * -> *).
(HasParam n s t a b, Applicative g) =>
(a -> g b) -> s -> g t
param @n