{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Generics.Product.Types
(
HasTypes
, types
, Children
, ChGeneric
, HasTypesUsing
, typesUsing
, HasTypesCustom (typesCustom)
) where
import Data.Kind
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Word (Word, Word8, Word16, Word32, Word64)
import qualified Data.Text as T
import GHC.Generics
import GHC.TypeLits
import Data.Generics.Internal.VL.Traversal
import Data.Generics.Internal.Errors
types :: forall a s. HasTypes s a => Traversal' s a
types :: Traversal' s a
types = HasTypes s a => Traversal' s a
forall s a. HasTypes s a => Traversal' s a
types_ @s @a
{-# INLINE types #-}
class HasTypes s a where
types_ :: Traversal' s a
default types_ :: Traversal' s a
types_ _ = s -> f s
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE types_ #-}
instance
( HasTypesUsing ChGeneric s a
) => HasTypes s a where
types_ :: (a -> f a) -> s -> f s
types_ = forall s a. HasTypesUsing ChGeneric s a => Traversal' s a
forall ch s a. HasTypesUsing ch s a => Traversal' s a
typesUsing_ @ChGeneric
{-# INLINE types_ #-}
data Void
instance {-# OVERLAPPING #-} HasTypes Void a where
types_ :: (a -> f a) -> Void -> f Void
types_ _ = Void -> f Void
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance {-# OVERLAPPING #-} HasTypes s Void where
types_ :: (Void -> f Void) -> s -> f s
types_ _ = s -> f s
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance {-# OVERLAPPING #-} HasTypesUsing ch Void a where
typesUsing_ :: (a -> f a) -> Void -> f Void
typesUsing_ _ = Void -> f Void
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where
typesUsing_ :: (Void -> f Void) -> s -> f s
typesUsing_ _ = s -> f s
forall (f :: * -> *) a. Applicative f => a -> f a
pure
type family Children (ch :: Type) (a :: Type) :: [Type]
typesUsing :: forall ch a s. HasTypesUsing ch s a => Traversal' s a
typesUsing :: Traversal' s a
typesUsing = HasTypesUsing ch s a => Traversal' s a
forall ch s a. HasTypesUsing ch s a => Traversal' s a
typesUsing_ @ch @s @a
{-# INLINE typesUsing #-}
class HasTypesUsing (ch :: Type) s a where
typesUsing_ :: Traversal' s a
instance {-# OVERLAPPABLE #-}
( HasTypesOpt ch (Interesting ch a s) s a
) => HasTypesUsing ch s a where
typesUsing_ :: (a -> f a) -> s -> f s
typesUsing_ = forall ch (t :: Bool) s a. HasTypesOpt ch t s a => Traversal' s a
forall s a.
HasTypesOpt ch (Interesting ch a s) s a =>
Traversal' s a
typesOpt @ch @(Interesting ch a s)
{-# INLINE typesUsing_ #-}
instance {-# OVERLAPPABLE #-} HasTypesUsing ch a a where
typesUsing_ :: (a -> f a) -> a -> f a
typesUsing_ = (a -> f a) -> a -> f a
forall a. a -> a
id
class HasTypesCustom (ch :: Type) s a where
typesCustom :: Traversal' s a
instance {-# OVERLAPPABLE #-}
( GHasTypes ch (Rep s) a
, Generic s
, Defined (Rep s)
(PrettyError '[ 'Text "No instance " ':<>: QuoteType (HasTypesCustom ch s a)])
(() :: Constraint)
) => HasTypesCustom ch s a where
typesCustom :: (a -> f a) -> s -> f s
typesCustom f :: a -> f a
f s :: s
s = Rep s Any -> s
forall a x. Generic a => Rep a x -> a
to (Rep s Any -> s) -> f (Rep s Any) -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f a) -> Rep s Any -> f (Rep s Any)
forall k k (ch :: k) (s :: k -> *) a (x :: k).
GHasTypes ch s a =>
Traversal' (s x) a
gtypes_ @ch a -> f a
f (s -> Rep s Any
forall a x. Generic a => a -> Rep a x
from s
s)
data ChGeneric
type instance Children ChGeneric a = ChildrenDefault a
type family ChildrenDefault (a :: Type) :: [Type] where
ChildrenDefault Char = '[]
ChildrenDefault Double = '[]
ChildrenDefault Float = '[]
ChildrenDefault Integer = '[]
ChildrenDefault Int = '[]
ChildrenDefault Int8 = '[]
ChildrenDefault Int16 = '[]
ChildrenDefault Int32 = '[]
ChildrenDefault Int64 = '[]
ChildrenDefault Word = '[]
ChildrenDefault Word8 = '[]
ChildrenDefault Word16 = '[]
ChildrenDefault Word32 = '[]
ChildrenDefault Word64 = '[]
ChildrenDefault T.Text = '[]
ChildrenDefault a
= Defined (Rep a)
(NoGeneric a
'[ 'Text "arising from a generic traversal."
, 'Text "Either derive the instance, or define a custom traversal using " ':<>: QuoteType HasTypesCustom
])
(ChildrenGeneric (Rep a) '[])
type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where
ChildrenGeneric (M1 _ _ f) cs = ChildrenGeneric f cs
ChildrenGeneric (l :*: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
ChildrenGeneric (l :+: r) cs = ChildrenGeneric l (ChildrenGeneric r cs)
ChildrenGeneric (Rec0 a) cs = a ': cs
ChildrenGeneric _ cs = cs
class HasTypesOpt (ch :: Type) (t :: Bool) s a where
typesOpt :: Traversal' s a
instance HasTypesCustom ch s a => HasTypesOpt ch 'True s a where
typesOpt :: (a -> f a) -> s -> f s
typesOpt = forall s a. HasTypesCustom ch s a => Traversal' s a
forall ch s a. HasTypesCustom ch s a => Traversal' s a
typesCustom @ch
instance HasTypesOpt ch 'False s a where
typesOpt :: (a -> f a) -> s -> f s
typesOpt _ = s -> f s
forall (f :: * -> *) a. Applicative f => a -> f a
pure
class GHasTypes ch s a where
gtypes_ :: Traversal' (s x) a
instance
( GHasTypes ch l a
, GHasTypes ch r a
) => GHasTypes ch (l :*: r) a where
gtypes_ :: (a -> f a) -> (:*:) l r x -> f ((:*:) l r x)
gtypes_ f :: a -> f 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) -> f (l x) -> f (r x -> (:*:) l r x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f a) -> l x -> f (l x)
forall k k (ch :: k) (s :: k -> *) a (x :: k).
GHasTypes ch s a =>
Traversal' (s x) a
gtypes_ @ch a -> f a
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
<*> (a -> f a) -> r x -> f (r x)
forall k k (ch :: k) (s :: k -> *) a (x :: k).
GHasTypes ch s a =>
Traversal' (s x) a
gtypes_ @ch a -> f a
f r x
r
{-# INLINE gtypes_ #-}
instance
( GHasTypes ch l a
, GHasTypes ch r a
) => GHasTypes ch (l :+: r) a where
gtypes_ :: (a -> f a) -> (:+:) l r x -> f ((:+:) l r x)
gtypes_ f :: a -> f 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) -> f (l x) -> f ((:+:) l r x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f a) -> l x -> f (l x)
forall k k (ch :: k) (s :: k -> *) a (x :: k).
GHasTypes ch s a =>
Traversal' (s x) a
gtypes_ @ch a -> f a
f l x
l
gtypes_ f :: a -> f 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) -> f (r x) -> f ((:+:) l r x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f a) -> r x -> f (r x)
forall k k (ch :: k) (s :: k -> *) a (x :: k).
GHasTypes ch s a =>
Traversal' (s x) a
gtypes_ @ch a -> f a
f r x
r
{-# INLINE gtypes_ #-}
instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where
gtypes_ :: (a -> f a) -> M1 m meta s x -> f (M1 m meta s x)
gtypes_ f :: a -> f a
f (M1 s :: s x
s) = s x -> M1 m meta s x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (s x -> M1 m meta s x) -> f (s x) -> f (M1 m meta s x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f a) -> s x -> f (s x)
forall k k (ch :: k) (s :: k -> *) a (x :: k).
GHasTypes ch s a =>
Traversal' (s x) a
gtypes_ @ch a -> f a
f s x
s
{-# INLINE gtypes_ #-}
instance HasTypesUsing ch b a => GHasTypes ch (Rec0 b) a where
gtypes_ :: (a -> f a) -> Rec0 b x -> f (Rec0 b x)
gtypes_ f :: a -> f a
f (K1 x :: b
x) = b -> Rec0 b x
forall k i c (p :: k). c -> K1 i c p
K1 (b -> Rec0 b x) -> f b -> f (Rec0 b x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f a) -> b -> f b
forall ch s a. HasTypesUsing ch s a => Traversal' s a
typesUsing_ @ch @b @a a -> f a
f b
x
{-# INLINE gtypes_ #-}
instance {-# OVERLAPPING #-} HasTypes b a => GHasTypes ChGeneric (Rec0 b) a where
gtypes_ :: (a -> f a) -> Rec0 b x -> f (Rec0 b x)
gtypes_ f :: a -> f a
f (K1 x :: b
x) = b -> Rec0 b x
forall k i c (p :: k). c -> K1 i c p
K1 (b -> Rec0 b x) -> f b -> f (Rec0 b x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f a) -> b -> f b
forall s a. HasTypes s a => Traversal' s a
types_ @b @a a -> f a
f b
x
{-# INLINE gtypes_ #-}
instance GHasTypes ch U1 a where
gtypes_ :: (a -> f a) -> U1 x -> f (U1 x)
gtypes_ _ _ = U1 x -> f (U1 x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 x
forall k (p :: k). U1 p
U1
{-# INLINE gtypes_ #-}
instance GHasTypes ch V1 a where
gtypes_ :: (a -> f a) -> V1 x -> f (V1 x)
gtypes_ _ = V1 x -> f (V1 x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE gtypes_ #-}
type Interesting (ch :: Type) (a :: Type) (t :: Type)
= Defined_list (Children ch t) (NoChildren ch t)
(IsNothing (Interesting' ch a '[t] (Children ch t)))
type family NoChildren (ch :: Type) (a :: Type) :: Constraint where
NoChildren ch a = PrettyError
'[ 'Text "No type family instance for " ':<>: QuoteType (Children ch a)
, 'Text "arising from a traversal over " ':<>: QuoteType a
, 'Text "with custom strategy " ':<>: QuoteType ch
]
type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where
Interesting' ch _ seen '[] = 'Just seen
Interesting' ch a seen (t ': ts) =
InterestingOr ch a (InterestingUnless ch a seen t (Elem t seen)) ts
type family InterestingUnless
(ch :: Type) (a :: Type) (seen :: [Type]) (t :: Type) (alreadySeen :: Bool) ::
Maybe [Type] where
InterestingUnless ch a seen a _ = 'Nothing
InterestingUnless ch a seen t 'True = 'Just seen
InterestingUnless ch a seen t 'False
= Defined_list (Children ch t) (NoChildren ch t)
(Interesting' ch a (t ': seen) (Children ch t))
type family InterestingOr
(ch :: Type) (a :: Type) (seen' :: Maybe [Type]) (ts :: [Type]) ::
Maybe [Type] where
InterestingOr ch a 'Nothing _ = 'Nothing
InterestingOr ch a ('Just seen) ts = Interesting' ch a seen ts
type family Elem a as where
Elem a (a ': _) = 'True
Elem a (_ ': as) = Elem a as
Elem a '[] = 'False
type family IsNothing a where
IsNothing ('Just _) = 'False
IsNothing 'Nothing = 'True