{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Generics.Sum.Typed
(
AsType (..)
) where
import Data.Kind
import GHC.Generics
import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)
import Data.Generics.Sum.Internal.Typed
import Data.Generics.Internal.Errors
import Data.Generics.Internal.Families
import Data.Generics.Internal.Void
import Data.Generics.Product.Internal.HList
import Data.Generics.Internal.VL.Prism
import Data.Generics.Internal.Profunctor.Iso
import Data.Generics.Internal.Profunctor.Prism (prismPRavel)
class AsType a s where
_Typed :: Prism' s a
_Typed = (a -> s) -> (s -> Either s a) -> Prism s s a a
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism a -> s
forall a s. AsType a s => a -> s
injectTyped (\i :: s
i -> Either s a -> (a -> Either s a) -> Maybe a -> Either s a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (s -> Either s a
forall a b. a -> Either a b
Left s
i) a -> Either s a
forall a b. b -> Either a b
Right (s -> Maybe a
forall a s. AsType a s => s -> Maybe a
projectTyped s
i))
{-# INLINE[2] _Typed #-}
injectTyped :: a -> s
injectTyped
= (Tagged a (Identity a) -> Tagged s (Identity s)) -> a -> s
forall b t.
(Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
build Tagged a (Identity a) -> Tagged s (Identity s)
forall a s. AsType a s => Prism s s a a
_Typed
projectTyped :: s -> Maybe a
projectTyped
= (s -> Maybe a) -> (a -> Maybe a) -> Either s a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> s -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just (Either s a -> Maybe a) -> (s -> Either s a) -> s -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism s s a a -> s -> Either s a
forall s t a b. Prism s t a b -> s -> Either t a
match forall a s. AsType a s => Prism s s a a
Prism s s a a
_Typed
{-# MINIMAL (injectTyped, projectTyped) | _Typed #-}
instance
( Generic s
, ErrorUnlessOne a s (CollectPartialType as (Rep s))
, as ~ TupleToList a
, ListTuple a as
, GAsType (Rep s) as
, Defined (Rep s)
(NoGeneric s '[ 'Text "arising from a generic prism focusing on a constructor of type " ':<>: QuoteType a])
(() :: Constraint)
) => AsType a s where
_Typed :: p a (f a) -> p s (f s)
_Typed eta :: p a (f a)
eta = (Market a a a a -> Market a a s s) -> p a (f a) -> p s (f s)
forall a b s t. (Market a b a b -> Market a b s t) -> Prism s t a b
prismRavel ((Market a a a a -> Market a a s s) -> Prism s s a a
forall s t a b. APrism s t a b -> Prism s t a b
prismPRavel (Market a a (Rep s Any) (Rep s Any) -> Market a a s s
forall a b x. (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
repIso (Market a a (Rep s Any) (Rep s Any) -> Market a a s s)
-> (Market a a a a -> Market a a (Rep s Any) (Rep s Any))
-> Market a a a a
-> Market a a s s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x.
GAsType (Rep s) as =>
Prism (Rep s x) (Rep s x) (HList as) (HList as)
forall (f :: * -> *) (as :: [*]) x.
GAsType f as =>
Prism (f x) (f x) (HList as) (HList as)
_GTyped @_ @as (Market a a (HList as) (HList as)
-> Market a a (Rep s Any) (Rep s Any))
-> (Market a a a a -> Market a a (HList as) (HList as))
-> Market a a a a
-> Market a a (Rep s Any) (Rep s Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Market a a a a -> Market a a (HList as) (HList as)
forall tuple (as :: [*]).
ListTuple tuple as =>
Iso' (HList as) tuple
tupled)) p a (f a)
eta
{-# INLINE[2] _Typed #-}
#if __GLASGOW_HASKELL__ < 804
#else
#endif
instance {-# OVERLAPPING #-} AsType a Void where
_Typed :: p a (f a) -> p Void (f Void)
_Typed = p a (f a) -> p Void (f Void)
forall a. HasCallStack => a
undefined
injectTyped :: a -> Void
injectTyped = a -> Void
forall a. HasCallStack => a
undefined
projectTyped :: Void -> Maybe a
projectTyped = Void -> Maybe a
forall a. HasCallStack => a
undefined
#if __GLASGOW_HASKELL__ < 804
#else
#endif
instance {-# OVERLAPPING #-} AsType Void a where
_Typed :: p Void (f Void) -> p a (f a)
_Typed = p Void (f Void) -> p a (f a)
forall a. HasCallStack => a
undefined
injectTyped :: Void -> a
injectTyped = Void -> a
forall a. HasCallStack => a
undefined
projectTyped :: a -> Maybe Void
projectTyped = a -> Maybe Void
forall a. HasCallStack => a
undefined
type family ErrorUnlessOne (a :: Type) (s :: Type) (ctors :: [Symbol]) :: Constraint where
ErrorUnlessOne _ _ '[_]
= ()
ErrorUnlessOne a s '[]
= TypeError
( 'Text "The type "
':<>: 'ShowType s
':<>: 'Text " does not contain a constructor whose field is of type "
':<>: 'ShowType a
)
ErrorUnlessOne a s cs
= TypeError
( 'Text "The type "
':<>: 'ShowType s
':<>: 'Text " contains multiple constructors whose fields are of type "
':<>: 'ShowType a ':<>: 'Text "."
':$$: 'Text "The choice of constructor is thus ambiguous, could be any of:"
':$$: ShowSymbols cs
)