-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | 'UStore' definition and common type-level stuff.
module Lorentz.UStore.Types
  ( -- * UStore and related type definitions
    UStore (..)
  , type (|~>)(..)
  , UStoreFieldExt (..)
  , UStoreField
  , UStoreMarkerType
  , UMarkerPlainField

    -- ** Extras
  , KnownUStoreMarker (..)
  , mkFieldMarkerUKeyL
  , mkFieldUKey
  , UStoreSubmapKey
  , UStoreSubmapKeyT

    -- ** Type-lookup-by-name
  , GetUStoreKey
  , GetUStoreValue
  , GetUStoreField
  , GetUStoreFieldMarker

    -- ** Marked fields
  , PickMarkedFields

   -- * Internals
  , ElemSignature (..)
  , GetUStore
  , MSKey
  , MSValue
  , FSValue
  , FSMarker
  ) where

import qualified Data.Kind as Kind
import GHC.Generics ((:*:)(..), (:+:)(..))
import qualified GHC.Generics as G
import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)
import Test.QuickCheck (Arbitrary)

import Lorentz.Annotation (HasAnnotation)
import Lorentz.Coercions (Wrappable)
import Lorentz.Pack
import Lorentz.Polymorphic
import Lorentz.Value
import Michelson.Text (labelToMText)
import Michelson.Typed.T
import Util.Type

-- | Gathers multple fields and 'BigMap's under one object.
--
-- Type argument of this datatype stands for a "store template" -
-- a datatype with one constructor and multiple fields, each containing
-- an object of type 'UStoreField' or '|~>' and corresponding to single
-- virtual field or 'BigMap' respectively.
-- It's also possible to parameterize it with a larger type which is
-- a product of types satisfying the above property.
newtype UStore (a :: Kind.Type) = UStore
  { UStore a -> BigMap ByteString ByteString
unUStore :: BigMap ByteString ByteString
  } deriving stock (UStore a -> UStore a -> Bool
(UStore a -> UStore a -> Bool)
-> (UStore a -> UStore a -> Bool) -> Eq (UStore a)
forall a. UStore a -> UStore a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UStore a -> UStore a -> Bool
$c/= :: forall a. UStore a -> UStore a -> Bool
== :: UStore a -> UStore a -> Bool
$c== :: forall a. UStore a -> UStore a -> Bool
Eq, Int -> UStore a -> ShowS
[UStore a] -> ShowS
UStore a -> String
(Int -> UStore a -> ShowS)
-> (UStore a -> String) -> ([UStore a] -> ShowS) -> Show (UStore a)
forall a. Int -> UStore a -> ShowS
forall a. [UStore a] -> ShowS
forall a. UStore a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UStore a] -> ShowS
$cshowList :: forall a. [UStore a] -> ShowS
show :: UStore a -> String
$cshow :: forall a. UStore a -> String
showsPrec :: Int -> UStore a -> ShowS
$cshowsPrec :: forall a. Int -> UStore a -> ShowS
Show, (forall x. UStore a -> Rep (UStore a) x)
-> (forall x. Rep (UStore a) x -> UStore a) -> Generic (UStore a)
forall x. Rep (UStore a) x -> UStore a
forall x. UStore a -> Rep (UStore a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (UStore a) x -> UStore a
forall a x. UStore a -> Rep (UStore a) x
$cto :: forall a x. Rep (UStore a) x -> UStore a
$cfrom :: forall a x. UStore a -> Rep (UStore a) x
Generic)
    deriving newtype (UStore a
UStore a -> Default (UStore a)
forall a. UStore a
forall a. a -> Default a
def :: UStore a
$cdef :: forall a. UStore a
Default, b -> UStore a -> UStore a
NonEmpty (UStore a) -> UStore a
UStore a -> UStore a -> UStore a
(UStore a -> UStore a -> UStore a)
-> (NonEmpty (UStore a) -> UStore a)
-> (forall b. Integral b => b -> UStore a -> UStore a)
-> Semigroup (UStore a)
forall b. Integral b => b -> UStore a -> UStore a
forall a. NonEmpty (UStore a) -> UStore a
forall a. UStore a -> UStore a -> UStore a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> UStore a -> UStore a
stimes :: b -> UStore a -> UStore a
$cstimes :: forall a b. Integral b => b -> UStore a -> UStore a
sconcat :: NonEmpty (UStore a) -> UStore a
$csconcat :: forall a. NonEmpty (UStore a) -> UStore a
<> :: UStore a -> UStore a -> UStore a
$c<> :: forall a. UStore a -> UStore a -> UStore a
Semigroup, Semigroup (UStore a)
UStore a
Semigroup (UStore a) =>
UStore a
-> (UStore a -> UStore a -> UStore a)
-> ([UStore a] -> UStore a)
-> Monoid (UStore a)
[UStore a] -> UStore a
UStore a -> UStore a -> UStore a
forall a. Semigroup (UStore a)
forall a. UStore a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [UStore a] -> UStore a
forall a. UStore a -> UStore a -> UStore a
mconcat :: [UStore a] -> UStore a
$cmconcat :: forall a. [UStore a] -> UStore a
mappend :: UStore a -> UStore a -> UStore a
$cmappend :: forall a. UStore a -> UStore a -> UStore a
mempty :: UStore a
$cmempty :: forall a. UStore a
$cp1Monoid :: forall a. Semigroup (UStore a)
Monoid, WellTypedToT (UStore a)
WellTypedToT (UStore a) =>
(UStore a -> Value (ToT (UStore a)))
-> (Value (ToT (UStore a)) -> UStore a) -> IsoValue (UStore a)
Value (ToT (UStore a)) -> UStore a
UStore a -> Value (ToT (UStore a))
forall a. WellTypedToT (UStore a)
forall a.
WellTypedToT a =>
(a -> Value (ToT a)) -> (Value (ToT a) -> a) -> IsoValue a
forall a. Value (ToT (UStore a)) -> UStore a
forall a. UStore a -> Value (ToT (UStore a))
fromVal :: Value (ToT (UStore a)) -> UStore a
$cfromVal :: forall a. Value (ToT (UStore a)) -> UStore a
toVal :: UStore a -> Value (ToT (UStore a))
$ctoVal :: forall a. UStore a -> Value (ToT (UStore a))
$cp1IsoValue :: forall a. WellTypedToT (UStore a)
IsoValue,
                      ToT (MemOpKeyHs (UStore a)) ~ MemOpKey (ToT (UStore a))
MemOp (ToT (UStore a))
(MemOp (ToT (UStore a)),
 ToT (MemOpKeyHs (UStore a)) ~ MemOpKey (ToT (UStore a))) =>
MemOpHs (UStore a)
forall a. ToT (MemOpKeyHs (UStore a)) ~ MemOpKey (ToT (UStore a))
forall a. MemOp (ToT (UStore a))
forall c.
(MemOp (ToT c), ToT (MemOpKeyHs c) ~ MemOpKey (ToT c)) =>
MemOpHs c
$cp2MemOpHs :: forall a. ToT (MemOpKeyHs (UStore a)) ~ MemOpKey (ToT (UStore a))
$cp1MemOpHs :: forall a. MemOp (ToT (UStore a))
MemOpHs, ToT (GetOpKeyHs (UStore a)) ~ GetOpKey (ToT (UStore a))
ToT (GetOpValHs (UStore a)) ~ GetOpVal (ToT (UStore a))
GetOp (ToT (UStore a))
(GetOp (ToT (UStore a)),
 ToT (GetOpKeyHs (UStore a)) ~ GetOpKey (ToT (UStore a)),
 ToT (GetOpValHs (UStore a)) ~ GetOpVal (ToT (UStore a))) =>
GetOpHs (UStore a)
forall a. ToT (GetOpKeyHs (UStore a)) ~ GetOpKey (ToT (UStore a))
forall a. ToT (GetOpValHs (UStore a)) ~ GetOpVal (ToT (UStore a))
forall a. GetOp (ToT (UStore a))
forall c.
(GetOp (ToT c), ToT (GetOpKeyHs c) ~ GetOpKey (ToT c),
 ToT (GetOpValHs c) ~ GetOpVal (ToT c)) =>
GetOpHs c
$cp3GetOpHs :: forall a. ToT (GetOpValHs (UStore a)) ~ GetOpVal (ToT (UStore a))
$cp2GetOpHs :: forall a. ToT (GetOpKeyHs (UStore a)) ~ GetOpKey (ToT (UStore a))
$cp1GetOpHs :: forall a. GetOp (ToT (UStore a))
GetOpHs, ToT (UpdOpKeyHs (UStore a)) ~ UpdOpKey (ToT (UStore a))
ToT (UpdOpParamsHs (UStore a)) ~ UpdOpParams (ToT (UStore a))
UpdOp (ToT (UStore a))
(UpdOp (ToT (UStore a)),
 ToT (UpdOpKeyHs (UStore a)) ~ UpdOpKey (ToT (UStore a)),
 ToT (UpdOpParamsHs (UStore a)) ~ UpdOpParams (ToT (UStore a))) =>
UpdOpHs (UStore a)
forall a. ToT (UpdOpKeyHs (UStore a)) ~ UpdOpKey (ToT (UStore a))
forall a.
ToT (UpdOpParamsHs (UStore a)) ~ UpdOpParams (ToT (UStore a))
forall a. UpdOp (ToT (UStore a))
forall c.
(UpdOp (ToT c), ToT (UpdOpKeyHs c) ~ UpdOpKey (ToT c),
 ToT (UpdOpParamsHs c) ~ UpdOpParams (ToT c)) =>
UpdOpHs c
$cp3UpdOpHs :: forall a.
ToT (UpdOpParamsHs (UStore a)) ~ UpdOpParams (ToT (UStore a))
$cp2UpdOpHs :: forall a. ToT (UpdOpKeyHs (UStore a)) ~ UpdOpKey (ToT (UStore a))
$cp1UpdOpHs :: forall a. UpdOp (ToT (UStore a))
UpdOpHs)
    deriving anyclass (FollowEntrypointFlag -> Notes (ToT (UStore a))
(FollowEntrypointFlag -> Notes (ToT (UStore a)))
-> HasAnnotation (UStore a)
forall a. FollowEntrypointFlag -> Notes (ToT (UStore a))
forall a.
(FollowEntrypointFlag -> Notes (ToT a)) -> HasAnnotation a
getAnnotation :: FollowEntrypointFlag -> Notes (ToT (UStore a))
$cgetAnnotation :: forall a. FollowEntrypointFlag -> Notes (ToT (UStore a))
HasAnnotation, ToT (UStore a) ~ ToT (Unwrappable (UStore a))
(ToT (UStore a) ~ ToT (Unwrappable (UStore a))) =>
Wrappable (UStore a)
forall a. ToT (UStore a) ~ ToT (Unwrappable (UStore a))
forall s. (ToT s ~ ToT (Unwrappable s)) => Wrappable s
Wrappable)

-- | Describes one virtual big map in the storage.
newtype k |~> v = UStoreSubMap { (k |~> v) -> Map k v
unUStoreSubMap :: Map k v }
  deriving stock (Int -> (k |~> v) -> ShowS
[k |~> v] -> ShowS
(k |~> v) -> String
(Int -> (k |~> v) -> ShowS)
-> ((k |~> v) -> String) -> ([k |~> v] -> ShowS) -> Show (k |~> v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k v. (Show k, Show v) => Int -> (k |~> v) -> ShowS
forall k v. (Show k, Show v) => [k |~> v] -> ShowS
forall k v. (Show k, Show v) => (k |~> v) -> String
showList :: [k |~> v] -> ShowS
$cshowList :: forall k v. (Show k, Show v) => [k |~> v] -> ShowS
show :: (k |~> v) -> String
$cshow :: forall k v. (Show k, Show v) => (k |~> v) -> String
showsPrec :: Int -> (k |~> v) -> ShowS
$cshowsPrec :: forall k v. (Show k, Show v) => Int -> (k |~> v) -> ShowS
Show, (k |~> v) -> (k |~> v) -> Bool
((k |~> v) -> (k |~> v) -> Bool)
-> ((k |~> v) -> (k |~> v) -> Bool) -> Eq (k |~> v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k v. (Eq k, Eq v) => (k |~> v) -> (k |~> v) -> Bool
/= :: (k |~> v) -> (k |~> v) -> Bool
$c/= :: forall k v. (Eq k, Eq v) => (k |~> v) -> (k |~> v) -> Bool
== :: (k |~> v) -> (k |~> v) -> Bool
$c== :: forall k v. (Eq k, Eq v) => (k |~> v) -> (k |~> v) -> Bool
Eq)
  deriving newtype (k |~> v
(k |~> v) -> Default (k |~> v)
forall a. a -> Default a
forall k v. k |~> v
def :: k |~> v
$cdef :: forall k v. k |~> v
Default, Gen (k |~> v)
Gen (k |~> v) -> ((k |~> v) -> [k |~> v]) -> Arbitrary (k |~> v)
(k |~> v) -> [k |~> v]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
forall k v. (Ord k, Arbitrary k, Arbitrary v) => Gen (k |~> v)
forall k v.
(Ord k, Arbitrary k, Arbitrary v) =>
(k |~> v) -> [k |~> v]
shrink :: (k |~> v) -> [k |~> v]
$cshrink :: forall k v.
(Ord k, Arbitrary k, Arbitrary v) =>
(k |~> v) -> [k |~> v]
arbitrary :: Gen (k |~> v)
$carbitrary :: forall k v. (Ord k, Arbitrary k, Arbitrary v) => Gen (k |~> v)
Arbitrary)

-- | Describes plain field in the storage.
newtype UStoreFieldExt (m :: UStoreMarkerType) (v :: Kind.Type) = UStoreField { UStoreFieldExt m v -> v
unUStoreField :: v }
  deriving stock (Int -> UStoreFieldExt m v -> ShowS
[UStoreFieldExt m v] -> ShowS
UStoreFieldExt m v -> String
(Int -> UStoreFieldExt m v -> ShowS)
-> (UStoreFieldExt m v -> String)
-> ([UStoreFieldExt m v] -> ShowS)
-> Show (UStoreFieldExt m v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (m :: UStoreMarkerType) v.
Show v =>
Int -> UStoreFieldExt m v -> ShowS
forall (m :: UStoreMarkerType) v.
Show v =>
[UStoreFieldExt m v] -> ShowS
forall (m :: UStoreMarkerType) v.
Show v =>
UStoreFieldExt m v -> String
showList :: [UStoreFieldExt m v] -> ShowS
$cshowList :: forall (m :: UStoreMarkerType) v.
Show v =>
[UStoreFieldExt m v] -> ShowS
show :: UStoreFieldExt m v -> String
$cshow :: forall (m :: UStoreMarkerType) v.
Show v =>
UStoreFieldExt m v -> String
showsPrec :: Int -> UStoreFieldExt m v -> ShowS
$cshowsPrec :: forall (m :: UStoreMarkerType) v.
Show v =>
Int -> UStoreFieldExt m v -> ShowS
Show, UStoreFieldExt m v -> UStoreFieldExt m v -> Bool
(UStoreFieldExt m v -> UStoreFieldExt m v -> Bool)
-> (UStoreFieldExt m v -> UStoreFieldExt m v -> Bool)
-> Eq (UStoreFieldExt m v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (m :: UStoreMarkerType) v.
Eq v =>
UStoreFieldExt m v -> UStoreFieldExt m v -> Bool
/= :: UStoreFieldExt m v -> UStoreFieldExt m v -> Bool
$c/= :: forall (m :: UStoreMarkerType) v.
Eq v =>
UStoreFieldExt m v -> UStoreFieldExt m v -> Bool
== :: UStoreFieldExt m v -> UStoreFieldExt m v -> Bool
$c== :: forall (m :: UStoreMarkerType) v.
Eq v =>
UStoreFieldExt m v -> UStoreFieldExt m v -> Bool
Eq)
  deriving newtype Gen (UStoreFieldExt m v)
Gen (UStoreFieldExt m v)
-> (UStoreFieldExt m v -> [UStoreFieldExt m v])
-> Arbitrary (UStoreFieldExt m v)
UStoreFieldExt m v -> [UStoreFieldExt m v]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
forall (m :: UStoreMarkerType) v.
Arbitrary v =>
Gen (UStoreFieldExt m v)
forall (m :: UStoreMarkerType) v.
Arbitrary v =>
UStoreFieldExt m v -> [UStoreFieldExt m v]
shrink :: UStoreFieldExt m v -> [UStoreFieldExt m v]
$cshrink :: forall (m :: UStoreMarkerType) v.
Arbitrary v =>
UStoreFieldExt m v -> [UStoreFieldExt m v]
arbitrary :: Gen (UStoreFieldExt m v)
$carbitrary :: forall (m :: UStoreMarkerType) v.
Arbitrary v =>
Gen (UStoreFieldExt m v)
Arbitrary

-- | Just a servant type.
data UStoreMarker

-- | Specific kind used to designate markers for 'UStoreFieldExt'.
--
-- We suggest that fields may serve different purposes and so annotated with
-- special markers accordingly, which influences translation to Michelson.
-- See example below.
--
-- This Haskell kind is implemented like that because we want markers to differ from all
-- other types in kind; herewith 'UStoreMarkerType' is still an open kind
-- (has potentially infinite number of inhabitants).
type UStoreMarkerType = UStoreMarker -> Kind.Type

-- | Just a plain field used as data.
type UStoreField = UStoreFieldExt UMarkerPlainField
data UMarkerPlainField :: UStoreMarkerType

-- | What do we serialize when constructing big_map key for accessing
-- an UStore submap.
type UStoreSubmapKey k = (MText, k)
type UStoreSubmapKeyT k = 'TPair (ToT MText) k

-- Extra attributes of fields
----------------------------------------------------------------------------

-- | Allows to specify format of key under which fields of this type are stored.
-- Useful to avoid collisions.
class KnownUStoreMarker (marker :: UStoreMarkerType) where
  -- | By field name derive key under which field should be stored.
  mkFieldMarkerUKey :: MText -> ByteString
  default mkFieldMarkerUKey :: MText -> ByteString
  mkFieldMarkerUKey = MText -> ByteString
forall a. NicePackedValue a => a -> ByteString
lPackValue

  -- | Display type-level information about UStore field with given marker and
  -- field value type.
  -- Used for error messages.
  type ShowUStoreField marker v :: ErrorMessage
  type ShowUStoreField marker v = 'Text "field of type " ':<>: 'ShowType v

-- | Version of 'mkFieldMarkerUKey' which accepts label.
mkFieldMarkerUKeyL
  :: forall marker field.
     KnownUStoreMarker marker
  => Label field -> ByteString
mkFieldMarkerUKeyL :: Label field -> ByteString
mkFieldMarkerUKeyL label :: Label field
label =
  MText -> ByteString
forall (marker :: UStoreMarkerType).
KnownUStoreMarker marker =>
MText -> ByteString
mkFieldMarkerUKey @marker (Label field -> MText
forall (name :: Symbol). Label name -> MText
labelToMText Label field
label)

-- | Shortcut for 'mkFieldMarkerUKey' which accepts not marker but store template
-- and name of entry.
mkFieldUKey
  :: forall (store :: Kind.Type) field.
     KnownUStoreMarker (GetUStoreFieldMarker store field)
  => Label field -> ByteString
mkFieldUKey :: Label field -> ByteString
mkFieldUKey = forall (field :: Symbol).
KnownUStoreMarker (GetUStoreFieldMarker store field) =>
Label field -> ByteString
forall (marker :: UStoreMarkerType) (field :: Symbol).
KnownUStoreMarker marker =>
Label field -> ByteString
mkFieldMarkerUKeyL @(GetUStoreFieldMarker store field)

instance KnownUStoreMarker UMarkerPlainField where

----------------------------------------------------------------------------
-- Type-safe lookup magic
----------------------------------------------------------------------------

{- Again we use generic magic to implement methods for 'Store'
(and thus 'Store' type constructor accepts a datatype, not a type-level list).

There are two reasons for this:

1. This gives us expected balanced tree of 'Or's for free.

2. This allows us selecting a map by field name, not by
e.g. type of map value. This is subjective, but looks like a good thing
for me (@martoon). On the other hand, it prevents us from sharing the
same interface between maps and 'Store'.

-}

-- | What was found on lookup by constructor name.
--
-- This keeps either type arguments of '|~>' or 'UStoreField'.
data ElemSignature
  = MapSignature Kind.Type Kind.Type
  | FieldSignature UStoreMarkerType Kind.Type

-- Again, we will use these getters instead of binding types within
-- 'MapSignature' using type equality because getters does not produce extra
-- compile errors on "field not found" cases.
type family MSKey (ms :: ElemSignature) :: Kind.Type where
  MSKey ('MapSignature k _) = k
  MSKey ('FieldSignature _ _) =
    TypeError ('Text "Expected UStore submap, but field was referred")
type family MSValue (ms :: ElemSignature) :: Kind.Type where
  MSValue ('MapSignature _ v) = v
  MSValue ('FieldSignature _ _) =
    TypeError ('Text "Expected UStore submap, but field was referred")
type family FSValue (ms :: ElemSignature) :: Kind.Type where
  FSValue ('FieldSignature _ v) = v
  FSValue ('MapSignature _ _) =
    TypeError ('Text "Expected UStore field, but submap was referred")
type family FSMarker (ms :: ElemSignature) :: UStoreMarkerType where
  FSMarker ('FieldSignature m _) = m
  FSMarker ('MapSignature _ _) =
    TypeError ('Text "Expected UStore field, but submap was referred")

-- | Get map signature from the constructor with a given name.
type GetUStore name a = MERequireFound name a (GLookupStore name (G.Rep a))

type family MERequireFound
  (name :: Symbol)
  (a :: Kind.Type)
  (mlr :: Maybe ElemSignature)
    :: ElemSignature where
  MERequireFound _ _ ('Just ms) = ms
  MERequireFound name a 'Nothing = TypeError
    ('Text "Failed to find plain field or submap in store template: datatype `"
     ':<>: 'ShowType a ':<>: 'Text "` has no field " ':<>: 'ShowType name)

type family GLookupStore (name :: Symbol) (x :: Kind.Type -> Kind.Type)
              :: Maybe ElemSignature where
  GLookupStore name (G.D1 _ x) = GLookupStore name x
  GLookupStore _ (_ :+: _) =
    TypeError ('Text "Templates used in UStore should have only one constructor")
  GLookupStore _ G.V1 =
    TypeError ('Text "No constructors in UStore template")

  GLookupStore name (G.C1 _ x) = GLookupStore name x

  GLookupStore name (x :*: y) = LSMergeFound name (GLookupStore name x)
                                                  (GLookupStore name y)

  -- When we encounter a field there are three cases we are interested in:
  -- 1. This field has type '|~>'. Then we check its name and return 'Just'
  -- with all required info on match, and 'Nothing' otherwise.
  -- 2. This field has type 'UStoreField'. We act in the same way
  -- as for '|~>', attaching 'ThePlainFieldKey' as key.
  -- 3. This field type is a different one. Then we expect this field to store
  -- '|~>' or 'UStoreField' somewhere deeper and try to find it there.
  GLookupStore name (G.S1 ('G.MetaSel mFieldName _ _ _) (G.Rec0 (k |~> v))) =
    Guard ('Just name == mFieldName) ('MapSignature k v)
  GLookupStore name (G.S1 ('G.MetaSel mFieldName _ _ _) (G.Rec0 (UStoreFieldExt m v))) =
    Guard ('Just name == mFieldName) ('FieldSignature m v)

  GLookupStore name (G.S1 _ (G.Rec0 a)) =
    GLookupStore name (G.Rep a)

  GLookupStore _ G.U1 = 'Nothing

type family LSMergeFound (name :: Symbol)
  (f1 :: Maybe ElemSignature) (f2 :: Maybe ElemSignature)
  :: Maybe ElemSignature where
  LSMergeFound _ 'Nothing 'Nothing = 'Nothing
  LSMergeFound _ ('Just ms) 'Nothing = 'Just ms
  LSMergeFound _ 'Nothing ('Just ms) = 'Just ms
  -- It's possible that there are two constructors with the same name,
  -- because main template pattern may be a sum of smaller template
  -- patterns with same constructor names.
  LSMergeFound ctor ('Just _) ('Just _) = TypeError
    ('Text "Found more than one constructor matching " ':<>: 'ShowType ctor)


-- | Get type of submap key.
type GetUStoreKey store name = MSKey (GetUStore name store)

-- | Get type of submap value.
type GetUStoreValue store name = MSValue (GetUStore name store)

-- | Get type of plain field.
-- This ignores marker with field type.
type GetUStoreField store name = FSValue (GetUStore name store)

-- | Get kind of field.
type GetUStoreFieldMarker store name = FSMarker (GetUStore name store)

-- One more magic
----------------------------------------------------------------------------

-- | Collect all fields with the given marker.
type PickMarkedFields marker template = GPickMarkedFields marker (G.Rep template)

type family GPickMarkedFields (marker :: UStoreMarkerType) (x :: Kind.Type -> Kind.Type)
             :: [(Symbol, Kind.Type)] where
  GPickMarkedFields m (G.D1 _ x) = GPickMarkedFields m x
  GPickMarkedFields m (G.C1 _ x) = GPickMarkedFields m x
  GPickMarkedFields m (x :*: y) = GPickMarkedFields m x ++ GPickMarkedFields m y
  GPickMarkedFields _ G.U1 = '[]

  GPickMarkedFields m (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) (G.Rec0 (UStoreFieldExt m v))) =
    '[ '(fieldName, v) ]
  GPickMarkedFields _ (G.S1 _ (G.Rec0 (UStoreFieldExt _ _))) =
    '[]
  GPickMarkedFields _ (G.S1 _ (G.Rec0 (_ |~> _))) =
    '[]
  GPickMarkedFields m (G.S1 _ (G.Rec0 a)) =
    PickMarkedFields m a