-- 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

   -- * Generators
  , genUStoreSubMap
  , genUStoreFieldExt
  ) where

import Control.Lens (Wrapped)
import qualified Data.Kind as Kind
import GHC.Generics ((:*:)(..), (:+:)(..))
import qualified GHC.Generics as G
import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)
import Hedgehog (MonadGen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.QuickCheck (Arbitrary)

import Lorentz.Pack
import Lorentz.TypeAnns (HasTypeAnn)
import Lorentz.Polymorphic
import Lorentz.Value
import Michelson.Test.Util (genTuple2)
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 Notes (ToT (UStore a))
Notes (ToT (UStore a)) -> HasTypeAnn (UStore a)
forall a. Notes (ToT (UStore a))
forall a. Notes (ToT a) -> HasTypeAnn a
getTypeAnn :: Notes (ToT (UStore a))
$cgetTypeAnn :: forall a. Notes (ToT (UStore a))
HasTypeAnn

instance Wrapped (UStore a)

-- | 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

----------------------------------------------------------------------------
-- Generators
----------------------------------------------------------------------------

genUStoreSubMap :: (MonadGen m, Ord k) => m k -> m v -> m (k |~> v)
genUStoreSubMap :: m k -> m v -> m (k |~> v)
genUStoreSubMap genK :: m k
genK genV :: m v
genV = Map k v -> k |~> v
forall k v. Map k v -> k |~> v
UStoreSubMap (Map k v -> k |~> v) -> m (Map k v) -> m (k |~> v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int -> m (k, v) -> m (Map k v)
forall (m :: * -> *) k v.
(MonadGen m, Ord k) =>
Range Int -> m (k, v) -> m (Map k v)
Gen.map (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear 0 100) (m k -> m v -> m (k, v)
forall (m :: * -> *) a b. MonadGen m => m a -> m b -> m (a, b)
genTuple2 m k
genK m v
genV)

genUStoreFieldExt :: MonadGen m => m v -> m (UStoreFieldExt marker v)
genUStoreFieldExt :: m v -> m (UStoreFieldExt marker v)
genUStoreFieldExt genV :: m v
genV = v -> UStoreFieldExt marker v
forall (m :: UStoreMarkerType) v. v -> UStoreFieldExt m v
UStoreField (v -> UStoreFieldExt marker v)
-> m v -> m (UStoreFieldExt marker v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m v
genV