{-# LANGUAGE CPP #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Generics.Product.Typed
(
HasType (..)
) 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 (Generic (Rep))
import GHC.TypeLits (TypeError, ErrorMessage (..))
import Data.Generics.Internal.Profunctor.Lens
import Data.Generics.Internal.Errors
class HasType a s where
typed :: VL.Lens s s a a
typed
= (s -> a) -> ((s, a) -> s) -> Lens s s a a
forall s a b t. (s -> a) -> ((s, b) -> t) -> Lens s t a b
VL.lens (forall s. HasType a s => s -> a
forall a s. HasType a s => s -> a
getTyped @a) ((a -> s -> s) -> (a, s) -> s
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall s. HasType a s => a -> s -> s
forall a s. HasType a s => a -> s -> s
setTyped @a) ((a, s) -> s) -> ((s, a) -> (a, s)) -> (s, a) -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s, a) -> (a, s)
forall a b. (a, b) -> (b, a)
swap)
{-# INLINE typed #-}
getTyped :: s -> a
getTyped s :: s
s = s
s s -> ((a -> Const a a) -> s -> Const a s) -> a
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall s. HasType a s => Lens s s a a
forall a s. HasType a s => Lens s s a a
typed @a
setTyped :: a -> s -> s
setTyped = 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. HasType a s => Lens s s a a
forall a s. HasType a s => Lens s s a a
typed @a)
{-# MINIMAL typed | setTyped, getTyped #-}
instance
( Generic s
, ErrorUnlessOne a s (CollectTotalType a (Rep s))
, Defined (Rep s)
(NoGeneric s '[ 'Text "arising from a generic lens focusing on a field of type " ':<>: QuoteType a])
(() :: Constraint)
, GLens (HasTotalTypePSym a) (Rep s) (Rep s) a a
) => HasType a s where
typed :: (a -> f a) -> s -> f s
typed f :: a -> f a
f s :: s
s = (ALens a a a a -> ALens a a s s) -> (a -> f a) -> s -> f s
forall a b s t. (ALens a b a b -> ALens a b s t) -> Lens s t a b
VL.ravel (ALens a a (Rep s Any) (Rep s Any) -> ALens a a s s
forall a b x.
(Generic a, Generic b) =>
Lens a b (Rep a x) (Rep b x)
repLens (ALens a a (Rep s Any) (Rep s Any) -> ALens a a s s)
-> (ALens a a a a -> ALens a a (Rep s Any) (Rep s Any))
-> ALens a a a a
-> ALens a a s s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: * -> *) (t :: * -> *) a b x.
GLens (HasTotalTypePSym a) 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 @(HasTotalTypePSym a)) a -> f a
f s
s
instance {-# OVERLAPPING #-} HasType a a where
getTyped :: a -> a
getTyped = a -> a
forall a. a -> a
id
{-# INLINE getTyped #-}
setTyped :: a -> a -> a
setTyped a :: a
a _ = a
a
{-# INLINE setTyped #-}
#if __GLASGOW_HASKELL__ < 804
#else
#endif
instance {-# OVERLAPPING #-} HasType a Void where
typed :: (a -> f a) -> Void -> f Void
typed = (a -> f a) -> Void -> f Void
forall a. HasCallStack => a
undefined
type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constraint where
ErrorUnlessOne a s ('TypeStat '[_] '[] '[])
= TypeError
( 'Text "The type "
':<>: 'ShowType s
':<>: 'Text " does not contain a value of type "
':<>: 'ShowType a
)
ErrorUnlessOne a s ('TypeStat (n ': ns) _ _)
= TypeError
( 'Text "Not all constructors of the type "
':<>: 'ShowType s
':<>: 'Text " contain a field of type "
':<>: 'ShowType a ':<>: 'Text "."
':$$: 'Text "The offending constructors are:"
':$$: ShowSymbols (n ': ns)
)
ErrorUnlessOne a s ('TypeStat _ (m ': ms) _)
= TypeError
( 'Text "The type "
':<>: 'ShowType s
':<>: 'Text " contains multiple values of type "
':<>: 'ShowType a ':<>: 'Text "."
':$$: 'Text "The choice of value is thus ambiguous. The offending constructors are:"
':$$: ShowSymbols (m ': ms)
)
ErrorUnlessOne _ _ ('TypeStat '[] '[] _)
= ()
data HasTotalTypePSym :: Type -> (TyFun (Type -> Type) (Maybe Type))
type instance Eval (HasTotalTypePSym t) tt = HasTotalTypeP t tt