{-# language AllowAmbiguousTypes    #-}
{-# language DataKinds              #-}
{-# language FlexibleContexts       #-}
{-# language FlexibleInstances      #-}
{-# language FunctionalDependencies #-}
{-# language GADTs                  #-}
{-# language LambdaCase             #-}
{-# language PolyKinds              #-}
{-# language ScopedTypeVariables    #-}
{-# language TypeApplications       #-}
{-# language TypeOperators          #-}
{-# language UndecidableInstances   #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-|
Description : Optics-based interface for @mu-schema@ terms

This module provides instances of 'LabelOptic' to be
used in conjunction with the @optics@ package.
In particular, there are two kind of optics to access
different parts of a 'Term':

* With @#field@ you obtain the lens (that is, a getter
  and a setter) for the corresponding field in a record.
* With @#choice@ you obtain the prism for the
  desired choice in an enumeration. You can use then
  'review' to construct a term with the value.

In addition, we provide a utility function 'record' to
build a record out of the inner values. We intend the
interface to be very simple, so this function is overloaded
to take tuples of different size, with as many components
as values in the schema type.
-}
module Mu.Schema.Optics (
  -- * Build a term
  record, record1, enum
, _U0, _Next, _U1, _U2, _U3
  -- * Re-exported for convenience.
, module Optics.Core
  -- * Additional utilities.
, is
) where

import           Data.Kind
import           Data.Map
import           Data.Maybe   (isJust)
import           Data.Proxy
import           GHC.TypeLits
import           Optics.Core

import           Mu.Schema

instance (FieldLabel sch args fieldName r)
         => LabelOptic fieldName A_Lens
                       (Term sch ('DRecord name args))
                       (Term sch ('DRecord name args))
                       r r where
  labelOptic :: Optic
  A_Lens
  NoIx
  (Term sch ('DRecord name args))
  (Term sch ('DRecord name args))
  r
  r
labelOptic = (Term sch ('DRecord name args) -> r)
-> (Term sch ('DRecord name args)
    -> r -> Term sch ('DRecord name args))
-> Optic
     A_Lens
     NoIx
     (Term sch ('DRecord name args))
     (Term sch ('DRecord name args))
     r
     r
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(TRecord NP (Field sch) args
r) -> Proxy fieldName -> NP (Field sch) args -> r
forall (sch :: Schema Symbol Symbol)
       (args :: [FieldDef Symbol Symbol]) (fieldName :: Symbol) r.
FieldLabel sch args fieldName r =>
Proxy fieldName -> NP (Field sch) args -> r
fieldLensGet (Proxy fieldName
forall k (t :: k). Proxy t
Proxy @fieldName) NP (Field sch) args
NP (Field sch) args
r)
                    (\(TRecord NP (Field sch) args
r) r
x -> NP (Field sch) args -> Term sch ('DRecord name args)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (args :: [FieldDef typeName fieldName]) (name :: typeName).
NP (Field sch) args -> Term sch ('DRecord name args)
TRecord (NP (Field sch) args -> Term sch ('DRecord name args))
-> NP (Field sch) args -> Term sch ('DRecord name args)
forall a b. (a -> b) -> a -> b
$ Proxy fieldName -> NP (Field sch) args -> r -> NP (Field sch) args
forall (sch :: Schema Symbol Symbol)
       (args :: [FieldDef Symbol Symbol]) (fieldName :: Symbol) r.
FieldLabel sch args fieldName r =>
Proxy fieldName -> NP (Field sch) args -> r -> NP (Field sch) args
fieldLensSet (Proxy fieldName
forall k (t :: k). Proxy t
Proxy @fieldName) NP (Field sch) args
NP (Field sch) args
r r
x)

-- | Build a Mu record 'Term' from a tuple of its values.
--
--   Note: if the record has exactly _one_ field,
--   you must use 'record1' instead.
record :: BuildRecord sch args r => r -> Term sch ('DRecord name args)
record :: r -> Term sch ('DRecord name args)
record r
values = NP (Field sch) args -> Term sch ('DRecord name args)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (args :: [FieldDef typeName fieldName]) (name :: typeName).
NP (Field sch) args -> Term sch ('DRecord name args)
TRecord (NP (Field sch) args -> Term sch ('DRecord name args))
-> NP (Field sch) args -> Term sch ('DRecord name args)
forall a b. (a -> b) -> a -> b
$ r -> NP (Field sch) args
forall (sch :: Schema Symbol Symbol)
       (args :: [FieldDef Symbol Symbol]) r.
BuildRecord sch args r =>
r -> NP (Field sch) args
buildR r
values

-- | Build a Mu record 'Term' with exactly one field.
record1 :: TypeLabel sch t1 r1 => r1 -> Term sch ('DRecord name '[ 'FieldDef x1 t1 ])
record1 :: r1 -> Term sch ('DRecord name '[ 'FieldDef x1 t1])
record1 r1
value = NP (Field sch) '[ 'FieldDef x1 t1]
-> Term sch ('DRecord name '[ 'FieldDef x1 t1])
forall typeName fieldName (sch :: Schema typeName fieldName)
       (args :: [FieldDef typeName fieldName]) (name :: typeName).
NP (Field sch) args -> Term sch ('DRecord name args)
TRecord (NP (Field sch) '[ 'FieldDef x1 t1]
 -> Term sch ('DRecord name '[ 'FieldDef x1 t1]))
-> NP (Field sch) '[ 'FieldDef x1 t1]
-> Term sch ('DRecord name '[ 'FieldDef x1 t1])
forall a b. (a -> b) -> a -> b
$ FieldValue sch t1 -> Field sch ('FieldDef x1 t1)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t :: FieldType typeName) (name :: fieldName).
FieldValue sch t -> Field sch ('FieldDef name t)
Field (r1 -> FieldValue sch t1
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
r -> FieldValue sch t
typeLensSet r1
value) Field sch ('FieldDef x1 t1)
-> NP (Field sch) '[] -> NP (Field sch) '[ 'FieldDef x1 t1]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP (Field sch) '[]
forall k (a :: k -> *). NP a '[]
Nil

class BuildRecord (sch :: Schema Symbol Symbol)
                  (args :: [FieldDef Symbol Symbol])
                  (r :: Type) | sch args -> r where
  buildR :: r -> NP (Field sch) args

instance BuildRecord sch '[] () where
  buildR :: () -> NP (Field sch) '[]
buildR ()
_ = NP (Field sch) '[]
forall k (a :: k -> *). NP a '[]
Nil

instance  (TypeLabel sch t1 r1, TypeLabel sch t2 r2)
         => BuildRecord sch '[ 'FieldDef x1 t1, 'FieldDef x2 t2 ] (r1, r2) where
  buildR :: (r1, r2) -> NP (Field sch) '[ 'FieldDef x1 t1, 'FieldDef x2 t2]
buildR (r1
v1, r2
v2) = FieldValue sch t1 -> Field sch ('FieldDef x1 t1)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t :: FieldType typeName) (name :: fieldName).
FieldValue sch t -> Field sch ('FieldDef name t)
Field (r1 -> FieldValue sch t1
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
r -> FieldValue sch t
typeLensSet r1
v1)
                  Field sch ('FieldDef x1 t1)
-> NP (Field sch) '[ 'FieldDef x2 t2]
-> NP (Field sch) '[ 'FieldDef x1 t1, 'FieldDef x2 t2]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* FieldValue sch t2 -> Field sch ('FieldDef x2 t2)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t :: FieldType typeName) (name :: fieldName).
FieldValue sch t -> Field sch ('FieldDef name t)
Field (r2 -> FieldValue sch t2
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
r -> FieldValue sch t
typeLensSet r2
v2) Field sch ('FieldDef x2 t2)
-> NP (Field sch) '[] -> NP (Field sch) '[ 'FieldDef x2 t2]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP (Field sch) '[]
forall k (a :: k -> *). NP a '[]
Nil

instance (TypeLabel sch t1 r1, TypeLabel sch t2 r2, TypeLabel sch t3 r3)
         => BuildRecord sch
                        '[ 'FieldDef x1 t1, 'FieldDef x2 t2, 'FieldDef x3 t3 ] (r1, r2, r3) where
  buildR :: (r1, r2, r3)
-> NP
     (Field sch) '[ 'FieldDef x1 t1, 'FieldDef x2 t2, 'FieldDef x3 t3]
buildR (r1
v1, r2
v2, r3
v3) = FieldValue sch t1 -> Field sch ('FieldDef x1 t1)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t :: FieldType typeName) (name :: fieldName).
FieldValue sch t -> Field sch ('FieldDef name t)
Field (r1 -> FieldValue sch t1
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
r -> FieldValue sch t
typeLensSet r1
v1)
                      Field sch ('FieldDef x1 t1)
-> NP (Field sch) '[ 'FieldDef x2 t2, 'FieldDef x3 t3]
-> NP
     (Field sch) '[ 'FieldDef x1 t1, 'FieldDef x2 t2, 'FieldDef x3 t3]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* FieldValue sch t2 -> Field sch ('FieldDef x2 t2)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t :: FieldType typeName) (name :: fieldName).
FieldValue sch t -> Field sch ('FieldDef name t)
Field (r2 -> FieldValue sch t2
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
r -> FieldValue sch t
typeLensSet r2
v2)
                      Field sch ('FieldDef x2 t2)
-> NP (Field sch) '[ 'FieldDef x3 t3]
-> NP (Field sch) '[ 'FieldDef x2 t2, 'FieldDef x3 t3]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* FieldValue sch t3 -> Field sch ('FieldDef x3 t3)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t :: FieldType typeName) (name :: fieldName).
FieldValue sch t -> Field sch ('FieldDef name t)
Field (r3 -> FieldValue sch t3
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
r -> FieldValue sch t
typeLensSet r3
v3) Field sch ('FieldDef x3 t3)
-> NP (Field sch) '[] -> NP (Field sch) '[ 'FieldDef x3 t3]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP (Field sch) '[]
forall k (a :: k -> *). NP a '[]
Nil

class FieldLabel (sch :: Schema Symbol Symbol)
                 (args :: [FieldDef Symbol Symbol])
                 (fieldName :: Symbol) (r :: Type)
                 | sch args fieldName -> r where
  fieldLensGet :: Proxy fieldName -> NP (Field sch) args -> r
  fieldLensSet :: Proxy fieldName -> NP (Field sch) args -> r -> NP (Field sch) args

{- Removed due to FunDeps
instance TypeError ('Text "cannot find field " ':<>: 'ShowType f)
         => FieldLabel w sch '[] f t where
  fieldLensGet = error "this should never be run"
  fieldLensSet = error "this should never be run"
-}
instance {-# OVERLAPS #-} (TypeLabel sch t r)
         => FieldLabel sch ('FieldDef f t ': rest) f r where
  fieldLensGet :: Proxy f -> NP (Field sch) ('FieldDef f t : rest) -> r
fieldLensGet Proxy f
_ (Field FieldValue sch t
x :* NP (Field sch) xs
_) = FieldValue sch t -> r
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
FieldValue sch t -> r
typeLensGet FieldValue sch t
x
  fieldLensSet :: Proxy f
-> NP (Field sch) ('FieldDef f t : rest)
-> r
-> NP (Field sch) ('FieldDef f t : rest)
fieldLensSet Proxy f
_ (Field sch x
_ :* NP (Field sch) xs
r) r
new = FieldValue sch t -> Field sch ('FieldDef f t)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t :: FieldType typeName) (name :: fieldName).
FieldValue sch t -> Field sch ('FieldDef name t)
Field (r -> FieldValue sch t
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
r -> FieldValue sch t
typeLensSet r
new) Field sch ('FieldDef f t)
-> NP (Field sch) xs -> NP (Field sch) ('FieldDef f t : xs)
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP (Field sch) xs
r
instance {-# OVERLAPPABLE #-} FieldLabel sch rest g t
         => FieldLabel sch (f ': rest) g t where
  fieldLensGet :: Proxy g -> NP (Field sch) (f : rest) -> t
fieldLensGet Proxy g
p (Field sch x
_ :* NP (Field sch) xs
r) = Proxy g -> NP (Field sch) xs -> t
forall (sch :: Schema Symbol Symbol)
       (args :: [FieldDef Symbol Symbol]) (fieldName :: Symbol) r.
FieldLabel sch args fieldName r =>
Proxy fieldName -> NP (Field sch) args -> r
fieldLensGet Proxy g
p NP (Field sch) xs
r
  fieldLensSet :: Proxy g
-> NP (Field sch) (f : rest) -> t -> NP (Field sch) (f : rest)
fieldLensSet Proxy g
p (Field sch x
x :* NP (Field sch) xs
r) t
new = Field sch x
x Field sch x -> NP (Field sch) xs -> NP (Field sch) (x : xs)
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* Proxy g -> NP (Field sch) xs -> t -> NP (Field sch) xs
forall (sch :: Schema Symbol Symbol)
       (args :: [FieldDef Symbol Symbol]) (fieldName :: Symbol) r.
FieldLabel sch args fieldName r =>
Proxy fieldName -> NP (Field sch) args -> r -> NP (Field sch) args
fieldLensSet Proxy g
p NP (Field sch) xs
r t
new

class TypeLabel (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) (r :: Type)
      | sch t -> r where
  typeLensGet :: FieldValue sch t -> r
  typeLensSet :: r -> FieldValue sch t

instance TypeLabel sch ('TPrimitive t) t where
  typeLensGet :: FieldValue sch ('TPrimitive t) -> t
typeLensGet (FPrimitive t1
x) = t
t1
x
  typeLensSet :: t -> FieldValue sch ('TPrimitive t)
typeLensSet = t -> FieldValue sch ('TPrimitive t)
forall typeName fieldName t1 (sch :: Schema typeName fieldName).
t1 -> FieldValue sch ('TPrimitive t1)
FPrimitive

instance (r ~ (sch :/: t)) => TypeLabel sch ('TSchematic t) (Term sch r) where
  typeLensGet :: FieldValue sch ('TSchematic t) -> Term sch r
typeLensGet (FSchematic Term sch (sch :/: t1)
x) = Term sch r
Term sch (sch :/: t1)
x
  typeLensSet :: Term sch r -> FieldValue sch ('TSchematic t)
typeLensSet = Term sch r -> FieldValue sch ('TSchematic t)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t1 :: typeName).
Term sch (sch :/: t1) -> FieldValue sch ('TSchematic t1)
FSchematic

instance (TypeLabel sch o r', r ~ Maybe r')
         => TypeLabel sch ('TOption o) r where
  typeLensGet :: FieldValue sch ('TOption o) -> r
typeLensGet (FOption Maybe (FieldValue sch t1)
x) = FieldValue sch t1 -> r'
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
FieldValue sch t -> r
typeLensGet (FieldValue sch t1 -> r') -> Maybe (FieldValue sch t1) -> Maybe r'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (FieldValue sch t1)
x
  typeLensSet :: r -> FieldValue sch ('TOption o)
typeLensSet r
new = Maybe (FieldValue sch o) -> FieldValue sch ('TOption o)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t1 :: FieldType typeName).
Maybe (FieldValue sch t1) -> FieldValue sch ('TOption t1)
FOption (r' -> FieldValue sch o
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
r -> FieldValue sch t
typeLensSet (r' -> FieldValue sch o) -> Maybe r' -> Maybe (FieldValue sch o)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r
Maybe r'
new)

instance (TypeLabel sch o r', r ~ [r'])
         => TypeLabel sch ('TList o) r where
  typeLensGet :: FieldValue sch ('TList o) -> r
typeLensGet (FList [FieldValue sch t1]
x) = FieldValue sch t1 -> r'
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
FieldValue sch t -> r
typeLensGet (FieldValue sch t1 -> r') -> [FieldValue sch t1] -> [r']
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldValue sch t1]
x
  typeLensSet :: r -> FieldValue sch ('TList o)
typeLensSet r
new = [FieldValue sch o] -> FieldValue sch ('TList o)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (t1 :: FieldType typeName).
[FieldValue sch t1] -> FieldValue sch ('TList t1)
FList (r' -> FieldValue sch o
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
r -> FieldValue sch t
typeLensSet (r' -> FieldValue sch o) -> [r'] -> [FieldValue sch o]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r
[r']
new)

instance ( TypeLabel sch k k', TypeLabel sch v v'
         , r ~ Map k' v', Ord k', Ord (FieldValue sch k) )
         => TypeLabel sch ('TMap k v) r where
  typeLensGet :: FieldValue sch ('TMap k v) -> r
typeLensGet (FMap Map (FieldValue sch k) (FieldValue sch v)
x) = (FieldValue sch k -> k') -> Map (FieldValue sch k) v' -> Map k' v'
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
mapKeys FieldValue sch k -> k'
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
FieldValue sch t -> r
typeLensGet (FieldValue sch v -> v'
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
FieldValue sch t -> r
typeLensGet (FieldValue sch v -> v')
-> Map (FieldValue sch k) (FieldValue sch v)
-> Map (FieldValue sch k) v'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (FieldValue sch k) (FieldValue sch v)
x)
  typeLensSet :: r -> FieldValue sch ('TMap k v)
typeLensSet r
new = Map (FieldValue sch k) (FieldValue sch v)
-> FieldValue sch ('TMap k v)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (k :: FieldType typeName) (v :: FieldType typeName).
Ord (FieldValue sch k) =>
Map (FieldValue sch k) (FieldValue sch v)
-> FieldValue sch ('TMap k v)
FMap ((k' -> FieldValue sch k)
-> Map k' (FieldValue sch v)
-> Map (FieldValue sch k) (FieldValue sch v)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
mapKeys k' -> FieldValue sch k
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
r -> FieldValue sch t
typeLensSet (v' -> FieldValue sch v
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
r -> FieldValue sch t
typeLensSet (v' -> FieldValue sch v) -> Map k' v' -> Map k' (FieldValue sch v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r
Map k' v'
new))

instance (r ~ NS (FieldValue sch) choices)
         => TypeLabel sch ('TUnion choices) r where
  typeLensGet :: FieldValue sch ('TUnion choices) -> r
typeLensGet (FUnion NS (FieldValue sch) choices
x) = r
NS (FieldValue sch) choices
x
  typeLensSet :: r -> FieldValue sch ('TUnion choices)
typeLensSet = r -> FieldValue sch ('TUnion choices)
forall typeName fieldName (sch :: Schema typeName fieldName)
       (choices :: [FieldType typeName]).
NS (FieldValue sch) choices -> FieldValue sch ('TUnion choices)
FUnion

-- | Build a Mu enumeration 'Term' from the name of the choice.
enum :: forall (choiceName :: Symbol) choices sch name.
        EnumLabel choices choiceName
     => Term sch ('DEnum name choices)
enum :: Term sch ('DEnum name choices)
enum = NS Proxy choices -> Term sch ('DEnum name choices)
forall fieldName typeName (choices :: [ChoiceDef fieldName])
       (sch :: Schema typeName fieldName) (name :: typeName).
NS Proxy choices -> Term sch ('DEnum name choices)
TEnum (NS Proxy choices -> Term sch ('DEnum name choices))
-> NS Proxy choices -> Term sch ('DEnum name choices)
forall a b. (a -> b) -> a -> b
$ Proxy choiceName -> NS Proxy choices
forall (choices :: [ChoiceDef Symbol]) (choiceName :: Symbol).
EnumLabel choices choiceName =>
Proxy choiceName -> NS Proxy choices
enumPrismBuild (Proxy choiceName
forall k (t :: k). Proxy t
Proxy @choiceName)

-- Useful utility to check whether a value
-- matches a given enumeration choice.
--
-- > f e | e `is` #sunny = ...
-- >     | e `is` #rainy = ...
is :: Is k An_AffineFold => s -> Optic' k is s a -> Bool
is :: s -> Optic' k is s a -> Bool
is s
s Optic' k is s a
k = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Optic' k is s a -> s -> Maybe a
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' k is s a
k s
s)
{-# INLINE is #-}

instance (EnumLabel choices choiceName, r ~ ())
         => LabelOptic choiceName A_Prism
                       (Term sch ('DEnum name choices))
                       (Term sch ('DEnum name choices))
                       r r where
  labelOptic :: Optic
  A_Prism
  NoIx
  (Term sch ('DEnum name choices))
  (Term sch ('DEnum name choices))
  r
  r
labelOptic = (r -> Term sch ('DEnum name choices))
-> (Term sch ('DEnum name choices) -> Maybe r)
-> Optic
     A_Prism
     NoIx
     (Term sch ('DEnum name choices))
     (Term sch ('DEnum name choices))
     r
     r
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (\r
_ -> NS Proxy choices -> Term sch ('DEnum name choices)
forall fieldName typeName (choices :: [ChoiceDef fieldName])
       (sch :: Schema typeName fieldName) (name :: typeName).
NS Proxy choices -> Term sch ('DEnum name choices)
TEnum (NS Proxy choices -> Term sch ('DEnum name choices))
-> NS Proxy choices -> Term sch ('DEnum name choices)
forall a b. (a -> b) -> a -> b
$ Proxy choiceName -> NS Proxy choices
forall (choices :: [ChoiceDef Symbol]) (choiceName :: Symbol).
EnumLabel choices choiceName =>
Proxy choiceName -> NS Proxy choices
enumPrismBuild (Proxy choiceName
forall k (t :: k). Proxy t
Proxy @choiceName))
                     (\(TEnum NS Proxy choices
r) -> Proxy choiceName -> NS Proxy choices -> Maybe ()
forall (choices :: [ChoiceDef Symbol]) (choiceName :: Symbol).
EnumLabel choices choiceName =>
Proxy choiceName -> NS Proxy choices -> Maybe ()
enumPrismMatch (Proxy choiceName
forall k (t :: k). Proxy t
Proxy @choiceName) NS Proxy choices
r)

class EnumLabel (choices :: [ChoiceDef Symbol])
                (choiceName :: Symbol) where
  enumPrismBuild :: Proxy choiceName -> NS Proxy choices
  enumPrismMatch :: Proxy choiceName -> NS Proxy choices -> Maybe ()

instance TypeError ('Text "cannot find choice " ':<>: 'ShowType c)
         => EnumLabel '[] c where
  enumPrismBuild :: Proxy c -> NS Proxy '[]
enumPrismBuild = [Char] -> Proxy c -> NS Proxy '[]
forall a. HasCallStack => [Char] -> a
error [Char]
"this should never be run"
  enumPrismMatch :: Proxy c -> NS Proxy '[] -> Maybe ()
enumPrismMatch = [Char] -> Proxy c -> NS Proxy '[] -> Maybe ()
forall a. HasCallStack => [Char] -> a
error [Char]
"this should never be run"
instance {-# OVERLAPS #-} EnumLabel ('ChoiceDef c ': rest) c where
  enumPrismBuild :: Proxy c -> NS Proxy ('ChoiceDef c : rest)
enumPrismBuild Proxy c
_ = Proxy ('ChoiceDef c) -> NS Proxy ('ChoiceDef c : rest)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z Proxy ('ChoiceDef c)
forall k (t :: k). Proxy t
Proxy
  enumPrismMatch :: Proxy c -> NS Proxy ('ChoiceDef c : rest) -> Maybe ()
enumPrismMatch Proxy c
_ (Z Proxy x
_) = () -> Maybe ()
forall a. a -> Maybe a
Just ()
  enumPrismMatch Proxy c
_ NS Proxy ('ChoiceDef c : rest)
_     = Maybe ()
forall a. Maybe a
Nothing
instance {-# OVERLAPPABLE #-} EnumLabel rest c
         => EnumLabel (d ': rest) c where
  enumPrismBuild :: Proxy c -> NS Proxy (d : rest)
enumPrismBuild Proxy c
p = NS Proxy rest -> NS Proxy (d : rest)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (Proxy c -> NS Proxy rest
forall (choices :: [ChoiceDef Symbol]) (choiceName :: Symbol).
EnumLabel choices choiceName =>
Proxy choiceName -> NS Proxy choices
enumPrismBuild Proxy c
p)
  enumPrismMatch :: Proxy c -> NS Proxy (d : rest) -> Maybe ()
enumPrismMatch Proxy c
_ (Z Proxy x
_) = Maybe ()
forall a. Maybe a
Nothing
  enumPrismMatch Proxy c
p (S NS Proxy xs
x) = Proxy c -> NS Proxy xs -> Maybe ()
forall (choices :: [ChoiceDef Symbol]) (choiceName :: Symbol).
EnumLabel choices choiceName =>
Proxy choiceName -> NS Proxy choices -> Maybe ()
enumPrismMatch Proxy c
p NS Proxy xs
x

-- | Prism to access the first choice of a union.
_U0 :: forall (sch :: Schema') x xs r. TypeLabel sch x r
    => Prism' (NS (FieldValue sch) (x ': xs)) r
_U0 :: Prism' (NS (FieldValue sch) (x : xs)) r
_U0 = (r -> NS (FieldValue sch) (x : xs))
-> (NS (FieldValue sch) (x : xs) -> Maybe r)
-> Prism' (NS (FieldValue sch) (x : xs)) r
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (FieldValue sch x -> NS (FieldValue sch) (x : xs)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (FieldValue sch x -> NS (FieldValue sch) (x : xs))
-> (r -> FieldValue sch x) -> r -> NS (FieldValue sch) (x : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> FieldValue sch x
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
r -> FieldValue sch t
typeLensSet)
             (\case (Z FieldValue sch x
x) -> r -> Maybe r
forall a. a -> Maybe a
Just (r -> Maybe r) -> r -> Maybe r
forall a b. (a -> b) -> a -> b
$ FieldValue sch x -> r
forall (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) r.
TypeLabel sch t r =>
FieldValue sch t -> r
typeLensGet FieldValue sch x
x
                    (S NS (FieldValue sch) xs
_) -> Maybe r
forall a. Maybe a
Nothing)

-- | Prism to access all other choices of a union
--   except for the first. Intended to use be used
--   iteratively until you reach the desired choice
--   with '_U0'.
--
--   > _Next % _Next % _U0  -- access third choice
_Next :: forall (sch :: Schema') x xs.
         Prism' (NS (FieldValue sch) (x ': xs))
                (NS (FieldValue sch) xs)
_Next :: Prism' (NS (FieldValue sch) (x : xs)) (NS (FieldValue sch) xs)
_Next = (NS (FieldValue sch) xs -> NS (FieldValue sch) (x : xs))
-> (NS (FieldValue sch) (x : xs) -> Maybe (NS (FieldValue sch) xs))
-> Prism' (NS (FieldValue sch) (x : xs)) (NS (FieldValue sch) xs)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' NS (FieldValue sch) xs -> NS (FieldValue sch) (x : xs)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S
               (\case (Z FieldValue sch x
_) -> Maybe (NS (FieldValue sch) xs)
forall a. Maybe a
Nothing
                      (S NS (FieldValue sch) xs
x) -> NS (FieldValue sch) xs -> Maybe (NS (FieldValue sch) xs)
forall a. a -> Maybe a
Just NS (FieldValue sch) xs
x)

-- | Prism to access the second choice of a union.
_U1 :: forall (sch :: Schema') a b xs r. TypeLabel sch b r
    => Prism' (NS (FieldValue sch) (a ': b ': xs)) r
_U1 :: Prism' (NS (FieldValue sch) (a : b : xs)) r
_U1 = Prism'
  (NS (FieldValue sch) (a : b : xs)) (NS (FieldValue sch) (b : xs))
forall (sch :: Schema Symbol Symbol) (x :: FieldType Symbol)
       (xs :: [FieldType Symbol]).
Prism' (NS (FieldValue sch) (x : xs)) (NS (FieldValue sch) xs)
_Next Prism'
  (NS (FieldValue sch) (a : b : xs)) (NS (FieldValue sch) (b : xs))
-> Optic
     A_Prism
     NoIx
     (NS (FieldValue sch) (b : xs))
     (NS (FieldValue sch) (b : xs))
     r
     r
-> Prism' (NS (FieldValue sch) (a : b : xs)) r
forall k m l (ks :: IxList) (is :: IxList) (js :: IxList) s t u v a
       b.
(Is k m, Is l m, m ~ Join k l, ks ~ Append is js) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Prism
  NoIx
  (NS (FieldValue sch) (b : xs))
  (NS (FieldValue sch) (b : xs))
  r
  r
forall (sch :: Schema Symbol Symbol) (x :: FieldType Symbol)
       (xs :: [FieldType Symbol]) r.
TypeLabel sch x r =>
Prism' (NS (FieldValue sch) (x : xs)) r
_U0

-- | Prism to access the third choice of a union.
_U2 :: forall (sch :: Schema') a b c xs r. TypeLabel sch c r
    => Prism' (NS (FieldValue sch) (a ': b ': c ': xs)) r
_U2 :: Prism' (NS (FieldValue sch) (a : b : c : xs)) r
_U2 = Prism'
  (NS (FieldValue sch) (a : b : c : xs))
  (NS (FieldValue sch) (b : c : xs))
forall (sch :: Schema Symbol Symbol) (x :: FieldType Symbol)
       (xs :: [FieldType Symbol]).
Prism' (NS (FieldValue sch) (x : xs)) (NS (FieldValue sch) xs)
_Next Prism'
  (NS (FieldValue sch) (a : b : c : xs))
  (NS (FieldValue sch) (b : c : xs))
-> Optic
     A_Prism
     NoIx
     (NS (FieldValue sch) (b : c : xs))
     (NS (FieldValue sch) (b : c : xs))
     r
     r
-> Prism' (NS (FieldValue sch) (a : b : c : xs)) r
forall k m l (ks :: IxList) (is :: IxList) (js :: IxList) s t u v a
       b.
(Is k m, Is l m, m ~ Join k l, ks ~ Append is js) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Prism
  NoIx
  (NS (FieldValue sch) (b : c : xs))
  (NS (FieldValue sch) (b : c : xs))
  r
  r
forall (sch :: Schema Symbol Symbol) (a :: FieldType Symbol)
       (b :: FieldType Symbol) (xs :: [FieldType Symbol]) r.
TypeLabel sch b r =>
Prism' (NS (FieldValue sch) (a : b : xs)) r
_U1

-- | Prism to access the fourth choice of a union.
_U3 :: forall (sch :: Schema') a b c d xs r. TypeLabel sch d r
    => Prism' (NS (FieldValue sch) (a ': b ': c ': d ': xs)) r
_U3 :: Prism' (NS (FieldValue sch) (a : b : c : d : xs)) r
_U3 = Prism'
  (NS (FieldValue sch) (a : b : c : d : xs))
  (NS (FieldValue sch) (b : c : d : xs))
forall (sch :: Schema Symbol Symbol) (x :: FieldType Symbol)
       (xs :: [FieldType Symbol]).
Prism' (NS (FieldValue sch) (x : xs)) (NS (FieldValue sch) xs)
_Next Prism'
  (NS (FieldValue sch) (a : b : c : d : xs))
  (NS (FieldValue sch) (b : c : d : xs))
-> Optic
     A_Prism
     NoIx
     (NS (FieldValue sch) (b : c : d : xs))
     (NS (FieldValue sch) (b : c : d : xs))
     r
     r
-> Prism' (NS (FieldValue sch) (a : b : c : d : xs)) r
forall k m l (ks :: IxList) (is :: IxList) (js :: IxList) s t u v a
       b.
(Is k m, Is l m, m ~ Join k l, ks ~ Append is js) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Prism
  NoIx
  (NS (FieldValue sch) (b : c : d : xs))
  (NS (FieldValue sch) (b : c : d : xs))
  r
  r
forall (sch :: Schema Symbol Symbol) (a :: FieldType Symbol)
       (b :: FieldType Symbol) (c :: FieldType Symbol)
       (xs :: [FieldType Symbol]) r.
TypeLabel sch c r =>
Prism' (NS (FieldValue sch) (a : b : c : xs)) r
_U2