{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
module Data.Generics.Product.Fields
(
HasField (..)
, HasField' (..)
, HasField_ (..)
, getField
, setField
) where
import Data.Generics.Internal.Families
import Data.Generics.Internal.VL.Lens as VL
import Data.Generics.Internal.Void
import Data.Generics.Product.Internal.GLens
import Data.Kind (Constraint, Type)
import GHC.Generics
import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
import Data.Generics.Internal.Profunctor.Lens as P
import Data.Generics.Internal.Errors
class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b -> t, t field a -> s where
field :: VL.Lens s t a b
class HasField_ (field :: Symbol) s t a b where
field_ :: VL.Lens s t a b
class HasField' (field :: Symbol) s a | s field -> a where
field' :: VL.Lens s s a a
class HasField0 (field :: Symbol) s t a b where
field0 :: VL.Lens s t a b
getField :: forall f a s. HasField' f s a => s -> a
getField :: s -> a
getField = ((a -> Const a a) -> s -> Const a s) -> s -> a
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
VL.view (forall s a. HasField' f s a => Lens s s a a
forall (field :: Symbol) s a. HasField' field s a => Lens s s a a
field' @f)
setField :: forall f s a. HasField' f s a => a -> s -> s
setField :: a -> s -> s
setField = Lens s s a a -> a -> s -> s
forall s t a b. Lens s t a b -> b -> s -> t
VL.set (forall s a. HasField' f s a => Lens s s a a
forall (field :: Symbol) s a. HasField' field s a => Lens s s a a
field' @f)
instance
( Generic s
, ErrorUnless field s (CollectField field (Rep s))
, GLens' (HasTotalFieldPSym field) (Rep s) a
, Defined (Rep s)
(NoGeneric s '[ 'Text "arising from a generic lens focusing on the "
':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a
, 'Text "in " ':<>: QuoteType s])
(() :: Constraint)
) => HasField' field s a where
field' :: (a -> f a) -> s -> f s
field' f :: a -> f a
f s :: s
s = (a -> f a) -> s -> f s
forall (field :: Symbol) s t a b.
HasField0 field s t a b =>
Lens s t a b
field0 @field a -> f a
f s
s
class (~~) (a :: k) (b :: k) | a -> b, b -> a
instance (a ~ b) => (~~) a b
instance
( HasTotalFieldP field (Rep s) ~~ 'Just a
, HasTotalFieldP field (Rep t) ~~ 'Just b
, HasTotalFieldP field (Rep (Indexed s)) ~~ 'Just a'
, HasTotalFieldP field (Rep (Indexed t)) ~~ 'Just b'
, t ~~ Infer s a' b
, s ~~ Infer t b' a
, HasField0 field s t a b
) => HasField field s t a b where
field :: (a -> f b) -> s -> f t
field f :: a -> f b
f s :: s
s = (a -> f b) -> s -> f t
forall (field :: Symbol) s t a b.
HasField0 field s t a b =>
Lens s t a b
field0 @field a -> f b
f s
s
#if __GLASGOW_HASKELL__ < 804
#else
#endif
instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
field :: (a -> f b) -> Void1 a -> f (Void1 b)
field = (a -> f b) -> Void1 a -> f (Void1 b)
forall a. HasCallStack => a
undefined
instance
( HasTotalFieldP field (Rep s) ~~ 'Just a
, HasTotalFieldP field (Rep t) ~~ 'Just b
, UnifyHead s t
, UnifyHead t s
, HasField0 field s t a b
) => HasField_ field s t a b where
field_ :: (a -> f b) -> s -> f t
field_ f :: a -> f b
f s :: s
s = (a -> f b) -> s -> f t
forall (field :: Symbol) s t a b.
HasField0 field s t a b =>
Lens s t a b
field0 @field a -> f b
f s
s
instance {-# OVERLAPPING #-} HasField_ f (Void1 a) (Void1 b) a b where
field_ :: (a -> f b) -> Void1 a -> f (Void1 b)
field_ = (a -> f b) -> Void1 a -> f (Void1 b)
forall a. HasCallStack => a
undefined
instance
( Generic s
, Generic t
, GLens (HasTotalFieldPSym field) (Rep s) (Rep t) a b
, ErrorUnless field s (CollectField field (Rep s))
, Defined (Rep s)
(NoGeneric s '[ 'Text "arising from a generic lens focusing on the "
':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a
, 'Text "in " ':<>: QuoteType s])
(() :: Constraint)
) => HasField0 field s t a b where
field0 :: (a -> f b) -> s -> f t
field0 = (ALens a b a b -> ALens a b s t) -> Lens s t a b
forall a b s t. (ALens a b a b -> ALens a b s t) -> Lens s t a b
VL.ravel (ALens a b (Rep s Any) (Rep t Any) -> ALens a b s t
forall a b x.
(Generic a, Generic b) =>
Lens a b (Rep a x) (Rep b x)
repLens (ALens a b (Rep s Any) (Rep t Any) -> ALens a b s t)
-> (ALens a b a b -> ALens a b (Rep s Any) (Rep t Any))
-> ALens a b a b
-> ALens a b s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: * -> *) (t :: * -> *) a b x.
GLens (HasTotalFieldPSym field) s t a b =>
Lens (s x) (t x) a b
forall (pred :: Pred) (s :: * -> *) (t :: * -> *) a b x.
GLens pred s t a b =>
Lens (s x) (t x) a b
glens @(HasTotalFieldPSym field))
{-# INLINE field0 #-}
type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where
ErrorUnless field s ('TypeStat _ _ '[])
= TypeError
( 'Text "The type "
':<>: 'ShowType s
':<>: 'Text " does not contain a field named '"
':<>: 'Text field ':<>: 'Text "'."
)
ErrorUnless field s ('TypeStat (n ': ns) _ _)
= TypeError
( 'Text "Not all constructors of the type "
':<>: 'ShowType s
':$$: 'Text " contain a field named '"
':<>: 'Text field ':<>: 'Text "'."
':$$: 'Text "The offending constructors are:"
':$$: ShowSymbols (n ': ns)
)
ErrorUnless _ _ ('TypeStat '[] '[] _)
= ()
data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type))
type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt