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

{-# LANGUAGE FunctionalDependencies #-}

{- | This module provides storage interfaces.

Whenever you need to write a generic code applicable to different storage
formats, consider using this module.

Use methods like 'stToField' and 'stUpdate' to work with storage from your code.

To explain how e.g. required fields are obtainable from your storage you define
'StoreHasField' instance (and a similar case is for other typeclasses).
We provide the most common building blocks for implementing these instances,
see @Implementations@ section.

-}
module Lorentz.StoreClass
  ( -- * Class
    StoreHasField (..)
  , StoreFieldOps (..)
  , StoreHasSubmap (..)
  , StoreSubmapOps (..)
  , StoreHasEntrypoint (..)
  , StoreEntrypointOps (..)

    -- * Useful type synonyms
  , EntrypointLambda
  , EntrypointsField

    -- * Expressing constraints on storage
  , type (~>)
  , type (::->)
  , StorageContains

    -- * Methods to work with storage
  , stToField
  , stGetField
  , stSetField
  , stMem
  , stGet
  , stUpdate
  , stDelete
  , stInsert
  , stInsertNew
  , stEntrypoint
  , stToEpLambda
  , stGetEpLambda
  , stSetEpLambda
  , stToEpStore
  , stGetEpStore
  , stSetEpStore

    -- * Implementations
  , storeFieldOpsADT
  , storeEntrypointOpsADT
  , storeEntrypointOpsFields
  , storeEntrypointOpsSubmapField
  , storeFieldOpsDeeper
  , storeSubmapOpsDeeper
  , storeEntrypointOpsDeeper
  , storeFieldOpsReferTo
  , storeSubmapOpsReferTo
  , mapStoreFieldOps
  , mapStoreSubmapOpsKey
  , mapStoreSubmapOpsValue
  , storeEntrypointOpsReferTo
  , composeStoreFieldOps
  , composeStoreSubmapOps
  , sequenceStoreSubmapOps
  , composeStoreEntrypointOps
  , zoomStoreSubmapOps

    -- * Storage generation
  , mkStoreEp
  ) where

import Data.Map (singleton)

import Lorentz.ADT
import Lorentz.Base
import Lorentz.Iso
import Lorentz.Constraints
import Lorentz.Errors (failUnexpected)
import qualified Lorentz.Instr as L
import qualified Lorentz.Macro as L
import Lorentz.Value
import Michelson.Text (labelToMText)

----------------------------------------------------------------------------
-- Fields
----------------------------------------------------------------------------

-- | Datatype containing the full implementation of 'StoreHasField' typeclass.
--
-- We use this grouping because in most cases the implementation will be chosen
-- among the default ones, and initializing all methods at once is simpler
-- and more consistent.
-- (One can say that we are trying to emulate the @DerivingVia@ extension.)
data StoreFieldOps store fname ftype = StoreFieldOps
  { StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField
      :: forall s.
         Label fname -> store : s :-> ftype : s
  , StoreFieldOps store fname ftype
-> forall (s :: [*]).
   Label fname -> (ftype : store : s) :-> (store : s)
sopSetField
      :: forall s.
         Label fname -> ftype : store : s :-> store : s
  }

-- Using fundeps here for the sake of less amount of boilerplate on user side,
-- switch to type families if having any issues with that.
-- | Provides operations on fields for storage.
class StoreHasField store fname ftype | store fname -> ftype where
  storeFieldOps :: StoreFieldOps store fname ftype

-- | Pick storage field.
stToField
  :: StoreHasField store fname ftype
  => Label fname -> store : s :-> ftype : s
stToField :: Label fname -> (store : s) :-> (ftype : s)
stToField = StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps store fname ftype
forall store (fname :: Symbol) ftype.
StoreHasField store fname ftype =>
StoreFieldOps store fname ftype
storeFieldOps

-- | Get storage field, preserving the storage itself on stack.
stGetField
  :: StoreHasField store fname ftype
  => Label fname -> store : s :-> ftype : store : s
stGetField :: Label fname -> (store : s) :-> (ftype : store : s)
stGetField l :: Label fname
l = (store : s) :-> (store : store : s)
forall a (s :: [*]). (a : s) :-> (a : a : s)
L.dup ((store : s) :-> (store : store : s))
-> ((store : store : s) :-> (ftype : store : s))
-> (store : s) :-> (ftype : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreFieldOps store fname ftype
-> Label fname -> (store : store : s) :-> (ftype : store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps store fname ftype
forall store (fname :: Symbol) ftype.
StoreHasField store fname ftype =>
StoreFieldOps store fname ftype
storeFieldOps Label fname
l

-- | Update storage field.
stSetField
  :: StoreHasField store fname ftype
  => Label fname -> ftype : store : s :-> store : s
stSetField :: Label fname -> (ftype : store : s) :-> (store : s)
stSetField = StoreFieldOps store fname ftype
-> forall (s :: [*]).
   Label fname -> (ftype : store : s) :-> (store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]).
   Label fname -> (ftype : store : s) :-> (store : s)
sopSetField StoreFieldOps store fname ftype
forall store (fname :: Symbol) ftype.
StoreHasField store fname ftype =>
StoreFieldOps store fname ftype
storeFieldOps

----------------------------------------------------------------------------
-- Virtual big maps
----------------------------------------------------------------------------

-- | Datatype containing the full implementation of 'StoreHasSubmap' typeclass.
--
-- We use this grouping because in most cases the implementation will be chosen
-- among the default ones, and initializing all methods at once is simpler
-- and more consistent.
-- (One can say that we are trying to emulate the @DerivingVia@ extension.)
data StoreSubmapOps store mname key value = StoreSubmapOps
  { StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : store : s) :-> (Bool : s)
sopMem
      :: forall s.
         Label mname -> key : store : s :-> Bool : s
  , StoreSubmapOps store mname key value
-> forall (s :: [*]).
   KnownValue value =>
   Label mname -> (key : store : s) :-> (Maybe value : s)
sopGet
      :: forall s.
         (KnownValue value)
      => Label mname -> key : store : s :-> Maybe value : s
  , StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : Maybe value : store : s) :-> (store : s)
sopUpdate
      :: forall s.
         Label mname -> key : Maybe value : store : s :-> store : s

    -- Methods below are derivatives of methods above, they can be provided
    -- if for given specific storage type more efficient implementation is
    -- available.
  , StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : store : s) :-> (store : s)
sopDelete
      :: forall s.
         Label mname -> key : store : s :-> store : s
  , StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : value : store : s) :-> (store : s)
sopInsert
      :: forall s.
         Label mname -> key : value : store : s :-> store : s
  }

-- | Provides operations on submaps of storage.
class StoreHasSubmap store mname key value | store mname -> key value where
  storeSubmapOps :: StoreSubmapOps store mname key value

-- | Check value presence in storage.
stMem
  :: StoreHasSubmap store mname key value
  => Label mname -> key : store : s :-> Bool : s
stMem :: Label mname -> (key : store : s) :-> (Bool : s)
stMem = StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : store : s) :-> (Bool : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : store : s) :-> (Bool : s)
sopMem StoreSubmapOps store mname key value
forall store (mname :: Symbol) key value.
StoreHasSubmap store mname key value =>
StoreSubmapOps store mname key value
storeSubmapOps

-- | Get value in storage.
stGet
  :: (StoreHasSubmap store mname key value, KnownValue value)
  => Label mname -> key : store : s :-> Maybe value : s
stGet :: Label mname -> (key : store : s) :-> (Maybe value : s)
stGet = StoreSubmapOps store mname key value
-> forall (s :: [*]).
   KnownValue value =>
   Label mname -> (key : store : s) :-> (Maybe value : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   KnownValue value =>
   Label mname -> (key : store : s) :-> (Maybe value : s)
sopGet StoreSubmapOps store mname key value
forall store (mname :: Symbol) key value.
StoreHasSubmap store mname key value =>
StoreSubmapOps store mname key value
storeSubmapOps

-- | Update a value in storage.
stUpdate
  :: StoreHasSubmap store mname key value
  => Label mname -> key : Maybe value : store : s :-> store : s
stUpdate :: Label mname -> (key : Maybe value : store : s) :-> (store : s)
stUpdate = StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : Maybe value : store : s) :-> (store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : Maybe value : store : s) :-> (store : s)
sopUpdate StoreSubmapOps store mname key value
forall store (mname :: Symbol) key value.
StoreHasSubmap store mname key value =>
StoreSubmapOps store mname key value
storeSubmapOps

-- | Delete a value in storage.
stDelete
  :: forall store mname key value s.
     (StoreHasSubmap store mname key value)
  => Label mname -> key : store : s :-> store : s
stDelete :: Label mname -> (key : store : s) :-> (store : s)
stDelete = StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : store : s) :-> (store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : store : s) :-> (store : s)
sopDelete StoreSubmapOps store mname key value
forall store (mname :: Symbol) key value.
StoreHasSubmap store mname key value =>
StoreSubmapOps store mname key value
storeSubmapOps

-- | Add a value in storage.
stInsert
  :: StoreHasSubmap store mname key value
  => Label mname -> key : value : store : s :-> store : s
stInsert :: Label mname -> (key : value : store : s) :-> (store : s)
stInsert = StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : value : store : s) :-> (store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : value : store : s) :-> (store : s)
sopInsert StoreSubmapOps store mname key value
forall store (mname :: Symbol) key value.
StoreHasSubmap store mname key value =>
StoreSubmapOps store mname key value
storeSubmapOps

-- | Add a value in storage, but fail if it will overwrite some existing entry.
stInsertNew
  :: StoreHasSubmap store mname key value
  => Label mname
  -> (forall s0 any. key : s0 :-> any)
  -> key : value : store : s
  :-> store : s
stInsertNew :: Label mname
-> (forall (s0 :: [*]) (any :: [*]). (key : s0) :-> any)
-> (key : value : store : s) :-> (store : s)
stInsertNew l :: Label mname
l doFail :: forall (s0 :: [*]) (any :: [*]). (key : s0) :-> any
doFail =
  forall (s :: [*]) (s' :: [*]) a.
ConstraintDUPNLorentz (ToPeano 3) s s' a =>
s :-> (a : s)
forall (n :: Nat) (s :: [*]) (s' :: [*]) a.
ConstraintDUPNLorentz (ToPeano n) s s' a =>
s :-> (a : s)
L.duupX @3 ((key : value : store : s) :-> (store : key : value : store : s))
-> ((store : key : value : store : s)
    :-> (key : store : key : value : store : s))
-> (key : value : store : s)
   :-> (key : store : key : value : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# forall (s :: [*]) (s' :: [*]) a.
ConstraintDUPNLorentz (ToPeano 2) s s' a =>
s :-> (a : s)
forall (n :: Nat) (s :: [*]) (s' :: [*]) a.
ConstraintDUPNLorentz (ToPeano n) s s' a =>
s :-> (a : s)
L.duupX @2 ((key : value : store : s)
 :-> (key : store : key : value : store : s))
-> ((key : store : key : value : store : s)
    :-> (Bool : key : value : store : s))
-> (key : value : store : s) :-> (Bool : key : value : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label mname
-> (key : store : key : value : store : s)
   :-> (Bool : key : value : store : s)
forall store (mname :: Symbol) key value (s :: [*]).
StoreHasSubmap store mname key value =>
Label mname -> (key : store : s) :-> (Bool : s)
stMem Label mname
l ((key : value : store : s) :-> (Bool : key : value : store : s))
-> ((Bool : key : value : store : s) :-> (store : s))
-> (key : value : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  ((key : value : store : s) :-> (store : s))
-> ((key : value : store : s) :-> (store : s))
-> (Bool : key : value : store : s) :-> (store : s)
forall (s :: [*]) (s' :: [*]).
(s :-> s') -> (s :-> s') -> (Bool : s) :-> s'
L.if_ (key : value : store : s) :-> (store : s)
forall (s0 :: [*]) (any :: [*]). (key : s0) :-> any
doFail (Label mname -> (key : value : store : s) :-> (store : s)
forall store (mname :: Symbol) key value (s :: [*]).
StoreHasSubmap store mname key value =>
Label mname -> (key : value : store : s) :-> (store : s)
stInsert Label mname
l)

-- Instances
----------------------------------------------------------------------------

-- | 'BigMap' can be used as standalone key-value storage,
-- name of submap is not accounted in this case.
instance (key ~ key', value ~ value', NiceComparable key, KnownValue value) =>
         StoreHasSubmap (BigMap key' value') name key value where
  storeSubmapOps :: StoreSubmapOps (BigMap key' value') name key value
storeSubmapOps = $WStoreSubmapOps :: forall store (mname :: Symbol) key value.
(forall (s :: [*]).
 Label mname -> (key : store : s) :-> (Bool : s))
-> (forall (s :: [*]).
    KnownValue value =>
    Label mname -> (key : store : s) :-> (Maybe value : s))
-> (forall (s :: [*]).
    Label mname -> (key : Maybe value : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : value : store : s) :-> (store : s))
-> StoreSubmapOps store mname key value
StoreSubmapOps
    { sopMem :: forall (s :: [*]).
Label name -> (key : BigMap key' value' : s) :-> (Bool : s)
sopMem = \_label :: Label name
_label -> (key : BigMap key' value' : s) :-> (Bool : s)
forall c (s :: [*]).
MemOpHs c =>
(MemOpKeyHs c : c : s) :-> (Bool : s)
L.mem
    , sopGet :: forall (s :: [*]).
KnownValue value =>
Label name -> (key : BigMap key' value' : s) :-> (Maybe value : s)
sopGet = \_label :: Label name
_label -> (key : BigMap key' value' : s) :-> (Maybe value : s)
forall c (s :: [*]).
(GetOpHs c, KnownValue (GetOpValHs c)) =>
(GetOpKeyHs c : c : s) :-> (Maybe (GetOpValHs c) : s)
L.get
    , sopUpdate :: forall (s :: [*]).
Label name
-> (key : Maybe value : BigMap key' value' : s)
   :-> (BigMap key' value' : s)
sopUpdate = \_label :: Label name
_label -> (key : Maybe value : BigMap key' value' : s)
:-> (BigMap key' value' : s)
forall c (s :: [*]).
UpdOpHs c =>
(UpdOpKeyHs c : UpdOpParamsHs c : c : s) :-> (c : s)
L.update
    , sopDelete :: forall (s :: [*]).
Label name
-> (key : BigMap key' value' : s) :-> (BigMap key' value' : s)
sopDelete = \_label :: Label name
_label -> (key : BigMap key' value' : s) :-> (BigMap key' value' : s)
forall (map :: * -> * -> *) k v (s :: [*]).
(MapInstrs map, NiceComparable k, KnownValue v) =>
(k : map k v : s) :-> (map k v : s)
L.deleteMap
    , sopInsert :: forall (s :: [*]).
Label name
-> (key : value : BigMap key' value' : s)
   :-> (BigMap key' value' : s)
sopInsert = \_label :: Label name
_label -> (key : value : BigMap key' value' : s) :-> (BigMap key' value' : s)
forall (map :: * -> * -> *) k v (s :: [*]).
(MapInstrs map, NiceComparable k) =>
(k : v : map k v : s) :-> (map k v : s)
L.mapInsert
    }

-- | 'Map' can be used as standalone key-value storage if very needed.
instance (key ~ key', value ~ value', NiceComparable key, KnownValue value) =>
         StoreHasSubmap (Map key' value') name key value where
  storeSubmapOps :: StoreSubmapOps (Map key' value') name key value
storeSubmapOps = $WStoreSubmapOps :: forall store (mname :: Symbol) key value.
(forall (s :: [*]).
 Label mname -> (key : store : s) :-> (Bool : s))
-> (forall (s :: [*]).
    KnownValue value =>
    Label mname -> (key : store : s) :-> (Maybe value : s))
-> (forall (s :: [*]).
    Label mname -> (key : Maybe value : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : value : store : s) :-> (store : s))
-> StoreSubmapOps store mname key value
StoreSubmapOps
    { sopMem :: forall (s :: [*]).
Label name -> (key : Map key' value' : s) :-> (Bool : s)
sopMem = \_label :: Label name
_label -> (key : Map key' value' : s) :-> (Bool : s)
forall c (s :: [*]).
MemOpHs c =>
(MemOpKeyHs c : c : s) :-> (Bool : s)
L.mem
    , sopGet :: forall (s :: [*]).
KnownValue value =>
Label name -> (key : Map key' value' : s) :-> (Maybe value : s)
sopGet = \_label :: Label name
_label -> (key : Map key' value' : s) :-> (Maybe value : s)
forall c (s :: [*]).
(GetOpHs c, KnownValue (GetOpValHs c)) =>
(GetOpKeyHs c : c : s) :-> (Maybe (GetOpValHs c) : s)
L.get
    , sopUpdate :: forall (s :: [*]).
Label name
-> (key : Maybe value : Map key' value' : s)
   :-> (Map key' value' : s)
sopUpdate = \_label :: Label name
_label -> (key : Maybe value : Map key' value' : s) :-> (Map key' value' : s)
forall c (s :: [*]).
UpdOpHs c =>
(UpdOpKeyHs c : UpdOpParamsHs c : c : s) :-> (c : s)
L.update
    , sopDelete :: forall (s :: [*]).
Label name -> (key : Map key' value' : s) :-> (Map key' value' : s)
sopDelete = \_label :: Label name
_label -> (key : Map key' value' : s) :-> (Map key' value' : s)
forall (map :: * -> * -> *) k v (s :: [*]).
(MapInstrs map, NiceComparable k, KnownValue v) =>
(k : map k v : s) :-> (map k v : s)
L.deleteMap
    , sopInsert :: forall (s :: [*]).
Label name
-> (key : value : Map key' value' : s) :-> (Map key' value' : s)
sopInsert = \_label :: Label name
_label -> (key : value : Map key' value' : s) :-> (Map key' value' : s)
forall (map :: * -> * -> *) k v (s :: [*]).
(MapInstrs map, NiceComparable k) =>
(k : v : map k v : s) :-> (map k v : s)
L.mapInsert
    }

instance NiceComparable key => StoreHasSubmap (Set key) name key () where
  storeSubmapOps :: StoreSubmapOps (Set key) name key ()
storeSubmapOps = $WStoreSubmapOps :: forall store (mname :: Symbol) key value.
(forall (s :: [*]).
 Label mname -> (key : store : s) :-> (Bool : s))
-> (forall (s :: [*]).
    KnownValue value =>
    Label mname -> (key : store : s) :-> (Maybe value : s))
-> (forall (s :: [*]).
    Label mname -> (key : Maybe value : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : value : store : s) :-> (store : s))
-> StoreSubmapOps store mname key value
StoreSubmapOps
    { sopMem :: forall (s :: [*]). Label name -> (key : Set key : s) :-> (Bool : s)
sopMem = \_label :: Label name
_label -> (key : Set key : s) :-> (Bool : s)
forall c (s :: [*]).
MemOpHs c =>
(MemOpKeyHs c : c : s) :-> (Bool : s)
L.mem
    , sopGet :: forall (s :: [*]).
KnownValue () =>
Label name -> (key : Set key : s) :-> (Maybe () : s)
sopGet = \_label :: Label name
_label -> (key : Set key : s) :-> (Bool : s)
forall c (s :: [*]).
MemOpHs c =>
(MemOpKeyHs c : c : s) :-> (Bool : s)
L.mem ((key : Set key : s) :-> (Bool : s))
-> ((Bool : s) :-> (Maybe () : s))
-> (key : Set key : s) :-> (Maybe () : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (s :-> (Maybe () : s))
-> (s :-> (Maybe () : s)) -> (Bool : s) :-> (Maybe () : s)
forall (s :: [*]) (s' :: [*]).
(s :-> s') -> (s :-> s') -> (Bool : s) :-> s'
L.if_ (Maybe () -> s :-> (Maybe () : s)
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
L.push (Maybe () -> s :-> (Maybe () : s))
-> Maybe () -> s :-> (Maybe () : s)
forall a b. (a -> b) -> a -> b
$ () -> Maybe ()
forall a. a -> Maybe a
Just ()) (Maybe () -> s :-> (Maybe () : s)
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
L.push Maybe ()
forall a. Maybe a
Nothing)
    , sopUpdate :: forall (s :: [*]).
Label name -> (key : Maybe () : Set key : s) :-> (Set key : s)
sopUpdate = \_label :: Label name
_label -> ((Maybe () : Set key : s) :-> (Bool : Set key : s))
-> (key : Maybe () : Set key : s) :-> (key : Bool : Set key : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (Maybe () : Set key : s) :-> (Bool : Set key : s)
forall a (s :: [*]). (Maybe a : s) :-> (Bool : s)
L.isSome ((key : Maybe () : Set key : s) :-> (key : Bool : Set key : s))
-> ((key : Bool : Set key : s) :-> (Set key : s))
-> (key : Maybe () : Set key : s) :-> (Set key : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (key : Bool : Set key : s) :-> (Set key : s)
forall c (s :: [*]).
UpdOpHs c =>
(UpdOpKeyHs c : UpdOpParamsHs c : c : s) :-> (c : s)
L.update
    , sopDelete :: forall (s :: [*]).
Label name -> (key : Set key : s) :-> (Set key : s)
sopDelete = \_label :: Label name
_label -> (key : Set key : s) :-> (Set key : s)
forall e (s :: [*]).
NiceComparable e =>
(e : Set e : s) :-> (Set e : s)
L.setDelete
    , sopInsert :: forall (s :: [*]).
Label name -> (key : () : Set key : s) :-> (Set key : s)
sopInsert = \_label :: Label name
_label -> ((() : Set key : s) :-> (Set key : s))
-> (key : () : Set key : s) :-> (key : Set key : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (() : Set key : s) :-> (Set key : s)
forall a (s :: [*]). (a : s) :-> s
L.drop ((key : () : Set key : s) :-> (key : Set key : s))
-> ((key : Set key : s) :-> (Set key : s))
-> (key : () : Set key : s) :-> (Set key : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (key : Set key : s) :-> (Set key : s)
forall e (s :: [*]).
NiceComparable e =>
(e : Set e : s) :-> (Set e : s)
L.setInsert
    }

----------------------------------------------------------------------------
-- Stored Entrypoints
----------------------------------------------------------------------------

-- | Type synonym for a 'Lambda' that can be used as an entrypoint
type EntrypointLambda param store = Lambda (param, store) ([Operation], store)

-- | Type synonym of a 'BigMap' mapping 'MText' (entrypoint names) to
-- 'EntrypointLambda'.
--
-- This is useful when defining instances of 'StoreHasEntrypoint' as a storage
-- field containing one or more entrypoints (lambdas) of the same type.
type EntrypointsField param store = BigMap MText (EntrypointLambda param store)

-- | Datatype containing the full implementation of 'StoreHasEntrypoint' typeclass.
--
-- We use this grouping because in most cases the implementation will be chosen
-- among the default ones, and initializing all methods at once is simpler
-- and more consistent.
-- (One can say that we are trying to emulate the @DerivingVia@ extension.)
data StoreEntrypointOps store epName epParam epStore = StoreEntrypointOps
  { StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]).
   Label epName
   -> (store : s) :-> (EntrypointLambda epParam epStore : s)
sopToEpLambda
      :: forall s.
         Label epName
      -> store : s :-> (EntrypointLambda epParam epStore) : s
  , StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]).
   Label epName
   -> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
sopSetEpLambda
      :: forall s.
         Label epName
      -> (EntrypointLambda epParam epStore) : store : s :-> store : s
  , StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]). Label epName -> (store : s) :-> (epStore : s)
sopToEpStore
      :: forall s.
         Label epName
      -> store : s :-> epStore : s
  , StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]).
   Label epName -> (epStore : store : s) :-> (store : s)
sopSetEpStore
      :: forall s.
         Label epName
      -> epStore : store : s :-> store : s
  }

-- | Provides operations on stored entrypoints.
--
-- @store@ is the storage containing both the entrypoint @epName@ (note: it has
-- to be in a 'BigMap' to take advantage of lazy evaluation) and the @epStore@
-- field this operates on.
class StoreHasEntrypoint store epName epParam epStore | store epName -> epParam epStore where
  storeEpOps :: StoreEntrypointOps store epName epParam epStore

-- | Extracts and executes the @epName@ entrypoint lambda from storage, returing
-- the updated full storage (@store@) and the produced 'Operation's.
stEntrypoint
  :: StoreHasEntrypoint store epName epParam epStore
  => Label epName -> epParam : store : s :-> ([Operation], store) : s
stEntrypoint :: Label epName
-> (epParam : store : s) :-> (([Operation], store) : s)
stEntrypoint l :: Label epName
l =
  ((store : s)
 :-> (epStore : EntrypointLambda epParam epStore : store : s))
-> (epParam : store : s)
   :-> (epParam
          : epStore : EntrypointLambda epParam epStore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip ((store : s) :-> (store : store : s)
forall a (s :: [*]). (a : s) :-> (a : a : s)
L.dup ((store : s) :-> (store : store : s))
-> ((store : store : s)
    :-> (EntrypointLambda epParam epStore : store : store : s))
-> (store : s)
   :-> (EntrypointLambda epParam epStore : store : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label epName
-> (store : store : s)
   :-> (EntrypointLambda epParam epStore : store : store : s)
forall store (epName :: Symbol) epParam epStore (s :: [*]).
StoreHasEntrypoint store epName epParam epStore =>
Label epName
-> (store : s) :-> (EntrypointLambda epParam epStore : store : s)
stGetEpLambda Label epName
l ((store : s)
 :-> (EntrypointLambda epParam epStore : store : store : s))
-> ((EntrypointLambda epParam epStore : store : store : s)
    :-> (store : EntrypointLambda epParam epStore : store : s))
-> (store : s)
   :-> (store : EntrypointLambda epParam epStore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (EntrypointLambda epParam epStore : store : store : s)
:-> (store : EntrypointLambda epParam epStore : store : s)
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
L.swap ((store : s)
 :-> (store : EntrypointLambda epParam epStore : store : s))
-> ((store : EntrypointLambda epParam epStore : store : s)
    :-> (epStore : EntrypointLambda epParam epStore : store : s))
-> (store : s)
   :-> (epStore : EntrypointLambda epParam epStore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label epName
-> (store : EntrypointLambda epParam epStore : store : s)
   :-> (epStore : EntrypointLambda epParam epStore : store : s)
forall store (epName :: Symbol) epParam epStore (s :: [*]).
StoreHasEntrypoint store epName epParam epStore =>
Label epName -> (store : s) :-> (epStore : s)
stToEpStore Label epName
l) ((epParam : store : s)
 :-> (epParam
        : epStore : EntrypointLambda epParam epStore : store : s))
-> ((epParam
       : epStore : EntrypointLambda epParam epStore : store : s)
    :-> ((epParam, epStore)
           : EntrypointLambda epParam epStore : store : s))
-> (epParam : store : s)
   :-> ((epParam, epStore)
          : EntrypointLambda epParam epStore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  (epParam : epStore : EntrypointLambda epParam epStore : store : s)
:-> ((epParam, epStore)
       : EntrypointLambda epParam epStore : store : s)
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
L.pair ((epParam : store : s)
 :-> ((epParam, epStore)
        : EntrypointLambda epParam epStore : store : s))
-> (((epParam, epStore)
       : EntrypointLambda epParam epStore : store : s)
    :-> (([Operation], epStore) : store : s))
-> (epParam : store : s) :-> (([Operation], epStore) : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# ((epParam, epStore) : EntrypointLambda epParam epStore : store : s)
:-> (([Operation], epStore) : store : s)
forall a b (s :: [*]). (a : Lambda a b : s) :-> (b : s)
L.exec ((epParam : store : s) :-> (([Operation], epStore) : store : s))
-> ((([Operation], epStore) : store : s)
    :-> ([Operation] : epStore : store : s))
-> (epParam : store : s) :-> ([Operation] : epStore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (([Operation], epStore) : store : s)
:-> ([Operation] : epStore : store : s)
forall a b (s :: [*]). ((a, b) : s) :-> (a : b : s)
L.unpair ((epParam : store : s) :-> ([Operation] : epStore : store : s))
-> (([Operation] : epStore : store : s)
    :-> ([Operation] : store : s))
-> (epParam : store : s) :-> ([Operation] : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  ((epStore : store : s) :-> (store : s))
-> ([Operation] : epStore : store : s)
   :-> ([Operation] : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (Label epName -> (epStore : store : s) :-> (store : s)
forall store (epName :: Symbol) epParam epStore (s :: [*]).
StoreHasEntrypoint store epName epParam epStore =>
Label epName -> (epStore : store : s) :-> (store : s)
stSetEpStore Label epName
l) ((epParam : store : s) :-> ([Operation] : store : s))
-> (([Operation] : store : s) :-> (([Operation], store) : s))
-> (epParam : store : s) :-> (([Operation], store) : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# ([Operation] : store : s) :-> (([Operation], store) : s)
forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
L.pair

-- | Pick stored entrypoint lambda.
stToEpLambda
  :: StoreHasEntrypoint store epName epParam epStore
  => Label epName -> store : s :-> (EntrypointLambda epParam epStore) : s
stToEpLambda :: Label epName
-> (store : s) :-> (EntrypointLambda epParam epStore : s)
stToEpLambda = StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]).
   Label epName
   -> (store : s) :-> (EntrypointLambda epParam epStore : s)
forall store (epName :: Symbol) epParam epStore.
StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]).
   Label epName
   -> (store : s) :-> (EntrypointLambda epParam epStore : s)
sopToEpLambda StoreEntrypointOps store epName epParam epStore
forall store (epName :: Symbol) epParam epStore.
StoreHasEntrypoint store epName epParam epStore =>
StoreEntrypointOps store epName epParam epStore
storeEpOps

-- | Get stored entrypoint lambda, preserving the storage itself on the stack.
stGetEpLambda
  :: StoreHasEntrypoint store epName epParam epStore
  => Label epName -> store : s :-> (EntrypointLambda epParam epStore) : store : s
stGetEpLambda :: Label epName
-> (store : s) :-> (EntrypointLambda epParam epStore : store : s)
stGetEpLambda l :: Label epName
l = (store : s) :-> (store : store : s)
forall a (s :: [*]). (a : s) :-> (a : a : s)
L.dup ((store : s) :-> (store : store : s))
-> ((store : store : s)
    :-> (EntrypointLambda epParam epStore : store : s))
-> (store : s) :-> (EntrypointLambda epParam epStore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label epName
-> (store : store : s)
   :-> (EntrypointLambda epParam epStore : store : s)
forall store (epName :: Symbol) epParam epStore (s :: [*]).
StoreHasEntrypoint store epName epParam epStore =>
Label epName
-> (store : s) :-> (EntrypointLambda epParam epStore : s)
stToEpLambda Label epName
l

-- | Stores the entrypoint lambda in the storage. Fails if already set.
stSetEpLambda
  :: StoreHasEntrypoint store epName epParam epStore
  => Label epName -> (EntrypointLambda epParam epStore) : store : s :-> store : s
stSetEpLambda :: Label epName
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
stSetEpLambda = StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]).
   Label epName
   -> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
forall store (epName :: Symbol) epParam epStore.
StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]).
   Label epName
   -> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
sopSetEpLambda StoreEntrypointOps store epName epParam epStore
forall store (epName :: Symbol) epParam epStore.
StoreHasEntrypoint store epName epParam epStore =>
StoreEntrypointOps store epName epParam epStore
storeEpOps

-- | Pick the sub-storage that the entrypoint operates on.
stToEpStore
  :: StoreHasEntrypoint store epName epParam epStore
  => Label epName -> store : s :-> epStore : s
stToEpStore :: Label epName -> (store : s) :-> (epStore : s)
stToEpStore = StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]). Label epName -> (store : s) :-> (epStore : s)
forall store (epName :: Symbol) epParam epStore.
StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]). Label epName -> (store : s) :-> (epStore : s)
sopToEpStore StoreEntrypointOps store epName epParam epStore
forall store (epName :: Symbol) epParam epStore.
StoreHasEntrypoint store epName epParam epStore =>
StoreEntrypointOps store epName epParam epStore
storeEpOps

-- | Get the sub-storage that the entrypoint operates on, preserving the storage
-- itself on the stack.
stGetEpStore
  :: StoreHasEntrypoint store epName epParam epStore
  => Label epName -> store : s :-> epStore : store : s
stGetEpStore :: Label epName -> (store : s) :-> (epStore : store : s)
stGetEpStore l :: Label epName
l = (store : s) :-> (store : store : s)
forall a (s :: [*]). (a : s) :-> (a : a : s)
L.dup ((store : s) :-> (store : store : s))
-> ((store : store : s) :-> (epStore : store : s))
-> (store : s) :-> (epStore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label epName -> (store : store : s) :-> (epStore : store : s)
forall store (epName :: Symbol) epParam epStore (s :: [*]).
StoreHasEntrypoint store epName epParam epStore =>
Label epName -> (store : s) :-> (epStore : s)
stToEpStore Label epName
l

-- | Update the sub-storage that the entrypoint operates on.
stSetEpStore
  :: StoreHasEntrypoint store epName epParam epStore
  => Label epName -> epStore : store : s :-> store : s
stSetEpStore :: Label epName -> (epStore : store : s) :-> (store : s)
stSetEpStore = StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]).
   Label epName -> (epStore : store : s) :-> (store : s)
forall store (epName :: Symbol) epParam epStore.
StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]).
   Label epName -> (epStore : store : s) :-> (store : s)
sopSetEpStore StoreEntrypointOps store epName epParam epStore
forall store (epName :: Symbol) epParam epStore.
StoreHasEntrypoint store epName epParam epStore =>
StoreEntrypointOps store epName epParam epStore
storeEpOps

----------------------------------------------------------------------------
-- Implementations
----------------------------------------------------------------------------

-- | Implementation of 'StoreHasField' for case of datatype
-- keeping a pack of fields.
storeFieldOpsADT
  :: HasFieldOfType dt fname ftype
  => StoreFieldOps dt fname ftype
storeFieldOpsADT :: StoreFieldOps dt fname ftype
storeFieldOpsADT = $WStoreFieldOps :: forall store (fname :: Symbol) ftype.
(forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s))
-> (forall (s :: [*]).
    Label fname -> (ftype : store : s) :-> (store : s))
-> StoreFieldOps store fname ftype
StoreFieldOps
  { sopToField :: forall (s :: [*]). Label fname -> (dt : s) :-> (ftype : s)
sopToField = forall (s :: [*]). Label fname -> (dt : s) :-> (ftype : s)
forall dt (name :: Symbol) (st :: [*]).
InstrGetFieldC dt name =>
Label name -> (dt : st) :-> (GetFieldType dt name : st)
toField
  , sopSetField :: forall (s :: [*]). Label fname -> (ftype : dt : s) :-> (dt : s)
sopSetField = forall (s :: [*]). Label fname -> (ftype : dt : s) :-> (dt : s)
forall dt (name :: Symbol) (st :: [*]).
InstrSetFieldC dt name =>
Label name -> (GetFieldType dt name : dt : st) :-> (dt : st)
setField
  }

-- | Implementation of 'StoreHasEntrypoint' for a datatype keeping a pack of
-- fields, among which one has contains the entrypoint and another is what such
-- entrypoint operates on.
storeEntrypointOpsADT
  :: ( HasFieldOfType store epmName (EntrypointsField epParam epStore)
     , HasFieldOfType store epsName epStore
     , KnownValue epParam, KnownValue epStore
     )
  => Label epmName -> Label epsName
  -> StoreEntrypointOps store epName epParam epStore
storeEntrypointOpsADT :: Label epmName
-> Label epsName -> StoreEntrypointOps store epName epParam epStore
storeEntrypointOpsADT mapLabel :: Label epmName
mapLabel fieldLabel :: Label epsName
fieldLabel = $WStoreEntrypointOps :: forall store (epName :: Symbol) epParam epStore.
(forall (s :: [*]).
 Label epName
 -> (store : s) :-> (EntrypointLambda epParam epStore : s))
-> (forall (s :: [*]).
    Label epName
    -> (EntrypointLambda epParam epStore : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label epName -> (store : s) :-> (epStore : s))
-> (forall (s :: [*]).
    Label epName -> (epStore : store : s) :-> (store : s))
-> StoreEntrypointOps store epName epParam epStore
StoreEntrypointOps
  { sopToEpLambda :: forall (s :: [*]).
Label epName
-> (store : s) :-> (EntrypointLambda epParam epStore : s)
sopToEpLambda = \l :: Label epName
l -> Label epmName -> (store : s) :-> (GetFieldType store epmName : s)
forall dt (name :: Symbol) (st :: [*]).
InstrGetFieldC dt name =>
Label name -> (dt : st) :-> (GetFieldType dt name : st)
toField Label epmName
mapLabel ((store : s) :-> (EntrypointsField epParam epStore : s))
-> ((EntrypointsField epParam epStore : s)
    :-> (MText : EntrypointsField epParam epStore : s))
-> (store : s) :-> (MText : EntrypointsField epParam epStore : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label epName
-> (EntrypointsField epParam epStore : s)
   :-> (MText : EntrypointsField epParam epStore : s)
forall (name :: Symbol) (s :: [*]). Label name -> s :-> (MText : s)
pushStEp Label epName
l ((store : s) :-> (MText : EntrypointsField epParam epStore : s))
-> ((MText : EntrypointsField epParam epStore : s)
    :-> (Maybe (EntrypointLambda epParam epStore) : s))
-> (store : s) :-> (Maybe (EntrypointLambda epParam epStore) : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (MText : EntrypointsField epParam epStore : s)
:-> (Maybe (EntrypointLambda epParam epStore) : s)
forall c (s :: [*]).
(GetOpHs c, KnownValue (GetOpValHs c)) =>
(GetOpKeyHs c : c : s) :-> (Maybe (GetOpValHs c) : s)
L.get ((store : s) :-> (Maybe (EntrypointLambda epParam epStore) : s))
-> ((Maybe (EntrypointLambda epParam epStore) : s)
    :-> (EntrypointLambda epParam epStore : s))
-> (store : s) :-> (EntrypointLambda epParam epStore : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label epName
-> (Maybe (EntrypointLambda epParam epStore) : s)
   :-> (EntrypointLambda epParam epStore : s)
forall (epName :: Symbol) epParam epStore (s :: [*]).
Label epName
-> (Maybe (EntrypointLambda epParam epStore) : s)
   :-> (EntrypointLambda epParam epStore : s)
someStEp Label epName
l
  , sopSetEpLambda :: forall (s :: [*]).
Label epName
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
sopSetEpLambda = \l :: Label epName
l -> ((store : s) :-> (EntrypointsField epParam epStore : store : s))
-> (EntrypointLambda epParam epStore : store : s)
   :-> (EntrypointLambda epParam epStore
          : EntrypointsField epParam epStore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (Label epmName
-> (store : s) :-> (GetFieldType store epmName : store : s)
forall dt (name :: Symbol) (st :: [*]).
InstrGetFieldC dt name =>
Label name -> (dt : st) :-> (GetFieldType dt name : dt : st)
getField Label epmName
mapLabel) ((EntrypointLambda epParam epStore : store : s)
 :-> (EntrypointLambda epParam epStore
        : EntrypointsField epParam epStore : store : s))
-> ((EntrypointLambda epParam epStore
       : EntrypointsField epParam epStore : store : s)
    :-> (EntrypointsField epParam epStore : store : s))
-> (EntrypointLambda epParam epStore : store : s)
   :-> (EntrypointsField epParam epStore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label epmName
-> Label epName
-> (EntrypointLambda epParam epStore
      : EntrypointsField epParam epStore : store : s)
   :-> (EntrypointsField epParam epStore : store : s)
forall store (epmName :: Symbol) epParam epStore
       (epsName :: Symbol) (s :: [*]).
StoreHasSubmap
  store epmName MText (EntrypointLambda epParam epStore) =>
Label epmName
-> Label epsName
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
setStEp Label epmName
mapLabel Label epName
l ((EntrypointLambda epParam epStore : store : s)
 :-> (EntrypointsField epParam epStore : store : s))
-> ((EntrypointsField epParam epStore : store : s) :-> (store : s))
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label epmName
-> (GetFieldType store epmName : store : s) :-> (store : s)
forall dt (name :: Symbol) (st :: [*]).
InstrSetFieldC dt name =>
Label name -> (GetFieldType dt name : dt : st) :-> (dt : st)
setField Label epmName
mapLabel
  , sopToEpStore :: forall (s :: [*]). Label epName -> (store : s) :-> (epStore : s)
sopToEpStore = \_l :: Label epName
_l -> Label epsName -> (store : s) :-> (GetFieldType store epsName : s)
forall dt (name :: Symbol) (st :: [*]).
InstrGetFieldC dt name =>
Label name -> (dt : st) :-> (GetFieldType dt name : st)
toField Label epsName
fieldLabel
  , sopSetEpStore :: forall (s :: [*]).
Label epName -> (epStore : store : s) :-> (store : s)
sopSetEpStore = \_l :: Label epName
_l -> Label epsName
-> (GetFieldType store epsName : store : s) :-> (store : s)
forall dt (name :: Symbol) (st :: [*]).
InstrSetFieldC dt name =>
Label name -> (GetFieldType dt name : dt : st) :-> (dt : st)
setField Label epsName
fieldLabel
  }

-- | Implementation of 'StoreHasEntrypoint' for a datatype that has a 'StoreHasField'
-- for an 'EntrypointsField' that contains the entrypoint and a 'StoreHasField'
-- for the field such entrypoint operates on.
storeEntrypointOpsFields
  :: ( StoreHasField store epmName (EntrypointsField epParam epStore)
     , StoreHasField store epsName epStore
     , KnownValue epParam, KnownValue epStore
     )
  => Label epmName -> Label epsName
  -> StoreEntrypointOps store epName epParam epStore
storeEntrypointOpsFields :: Label epmName
-> Label epsName -> StoreEntrypointOps store epName epParam epStore
storeEntrypointOpsFields mapLabel :: Label epmName
mapLabel fieldLabel :: Label epsName
fieldLabel = $WStoreEntrypointOps :: forall store (epName :: Symbol) epParam epStore.
(forall (s :: [*]).
 Label epName
 -> (store : s) :-> (EntrypointLambda epParam epStore : s))
-> (forall (s :: [*]).
    Label epName
    -> (EntrypointLambda epParam epStore : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label epName -> (store : s) :-> (epStore : s))
-> (forall (s :: [*]).
    Label epName -> (epStore : store : s) :-> (store : s))
-> StoreEntrypointOps store epName epParam epStore
StoreEntrypointOps
  { sopToEpLambda :: forall (s :: [*]).
Label epName
-> (store : s) :-> (EntrypointLambda epParam epStore : s)
sopToEpLambda = \l :: Label epName
l -> Label epmName
-> (store : s) :-> (EntrypointsField epParam epStore : s)
forall store (fname :: Symbol) ftype (s :: [*]).
StoreHasField store fname ftype =>
Label fname -> (store : s) :-> (ftype : s)
stToField Label epmName
mapLabel ((store : s) :-> (EntrypointsField epParam epStore : s))
-> ((EntrypointsField epParam epStore : s)
    :-> (MText : EntrypointsField epParam epStore : s))
-> (store : s) :-> (MText : EntrypointsField epParam epStore : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label epName
-> (EntrypointsField epParam epStore : s)
   :-> (MText : EntrypointsField epParam epStore : s)
forall (name :: Symbol) (s :: [*]). Label name -> s :-> (MText : s)
pushStEp Label epName
l ((store : s) :-> (MText : EntrypointsField epParam epStore : s))
-> ((MText : EntrypointsField epParam epStore : s)
    :-> (Maybe (EntrypointLambda epParam epStore) : s))
-> (store : s) :-> (Maybe (EntrypointLambda epParam epStore) : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (MText : EntrypointsField epParam epStore : s)
:-> (Maybe (EntrypointLambda epParam epStore) : s)
forall c (s :: [*]).
(GetOpHs c, KnownValue (GetOpValHs c)) =>
(GetOpKeyHs c : c : s) :-> (Maybe (GetOpValHs c) : s)
L.get ((store : s) :-> (Maybe (EntrypointLambda epParam epStore) : s))
-> ((Maybe (EntrypointLambda epParam epStore) : s)
    :-> (EntrypointLambda epParam epStore : s))
-> (store : s) :-> (EntrypointLambda epParam epStore : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label epName
-> (Maybe (EntrypointLambda epParam epStore) : s)
   :-> (EntrypointLambda epParam epStore : s)
forall (epName :: Symbol) epParam epStore (s :: [*]).
Label epName
-> (Maybe (EntrypointLambda epParam epStore) : s)
   :-> (EntrypointLambda epParam epStore : s)
someStEp Label epName
l
  , sopSetEpLambda :: forall (s :: [*]).
Label epName
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
sopSetEpLambda = \l :: Label epName
l -> ((store : s) :-> (EntrypointsField epParam epStore : store : s))
-> (EntrypointLambda epParam epStore : store : s)
   :-> (EntrypointLambda epParam epStore
          : EntrypointsField epParam epStore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (Label epmName
-> (store : s) :-> (EntrypointsField epParam epStore : store : s)
forall store (fname :: Symbol) ftype (s :: [*]).
StoreHasField store fname ftype =>
Label fname -> (store : s) :-> (ftype : store : s)
stGetField Label epmName
mapLabel) ((EntrypointLambda epParam epStore : store : s)
 :-> (EntrypointLambda epParam epStore
        : EntrypointsField epParam epStore : store : s))
-> ((EntrypointLambda epParam epStore
       : EntrypointsField epParam epStore : store : s)
    :-> (EntrypointsField epParam epStore : store : s))
-> (EntrypointLambda epParam epStore : store : s)
   :-> (EntrypointsField epParam epStore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label epmName
-> Label epName
-> (EntrypointLambda epParam epStore
      : EntrypointsField epParam epStore : store : s)
   :-> (EntrypointsField epParam epStore : store : s)
forall store (epmName :: Symbol) epParam epStore
       (epsName :: Symbol) (s :: [*]).
StoreHasSubmap
  store epmName MText (EntrypointLambda epParam epStore) =>
Label epmName
-> Label epsName
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
setStEp Label epmName
mapLabel Label epName
l ((EntrypointLambda epParam epStore : store : s)
 :-> (EntrypointsField epParam epStore : store : s))
-> ((EntrypointsField epParam epStore : store : s) :-> (store : s))
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label epmName
-> (EntrypointsField epParam epStore : store : s) :-> (store : s)
forall store (fname :: Symbol) ftype (s :: [*]).
StoreHasField store fname ftype =>
Label fname -> (ftype : store : s) :-> (store : s)
stSetField Label epmName
mapLabel
  , sopToEpStore :: forall (s :: [*]). Label epName -> (store : s) :-> (epStore : s)
sopToEpStore = \_l :: Label epName
_l -> Label epsName -> (store : s) :-> (epStore : s)
forall store (fname :: Symbol) ftype (s :: [*]).
StoreHasField store fname ftype =>
Label fname -> (store : s) :-> (ftype : s)
stToField Label epsName
fieldLabel
  , sopSetEpStore :: forall (s :: [*]).
Label epName -> (epStore : store : s) :-> (store : s)
sopSetEpStore = \_l :: Label epName
_l -> Label epsName -> (epStore : store : s) :-> (store : s)
forall store (fname :: Symbol) ftype (s :: [*]).
StoreHasField store fname ftype =>
Label fname -> (ftype : store : s) :-> (store : s)
stSetField Label epsName
fieldLabel
  }

-- | Implementation of 'StoreHasEntrypoint' for a datatype that has a 'StoreHasSubmap'
-- that contains the entrypoint and a 'StoreHasField' for the field such
-- entrypoint operates on.
storeEntrypointOpsSubmapField
  :: ( StoreHasSubmap store epmName MText (EntrypointLambda epParam epStore)
     , StoreHasField store epsName epStore
     , KnownValue epParam, KnownValue epStore
     )
  => Label epmName -> Label epsName
  -> StoreEntrypointOps store epName epParam epStore
storeEntrypointOpsSubmapField :: Label epmName
-> Label epsName -> StoreEntrypointOps store epName epParam epStore
storeEntrypointOpsSubmapField mapLabel :: Label epmName
mapLabel fieldLabel :: Label epsName
fieldLabel = $WStoreEntrypointOps :: forall store (epName :: Symbol) epParam epStore.
(forall (s :: [*]).
 Label epName
 -> (store : s) :-> (EntrypointLambda epParam epStore : s))
-> (forall (s :: [*]).
    Label epName
    -> (EntrypointLambda epParam epStore : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label epName -> (store : s) :-> (epStore : s))
-> (forall (s :: [*]).
    Label epName -> (epStore : store : s) :-> (store : s))
-> StoreEntrypointOps store epName epParam epStore
StoreEntrypointOps
  { sopToEpLambda :: forall (s :: [*]).
Label epName
-> (store : s) :-> (EntrypointLambda epParam epStore : s)
sopToEpLambda = \l :: Label epName
l -> Label epName -> (store : s) :-> (MText : store : s)
forall (name :: Symbol) (s :: [*]). Label name -> s :-> (MText : s)
pushStEp Label epName
l ((store : s) :-> (MText : store : s))
-> ((MText : store : s)
    :-> (Maybe (EntrypointLambda epParam epStore) : s))
-> (store : s) :-> (Maybe (EntrypointLambda epParam epStore) : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label epmName
-> (MText : store : s)
   :-> (Maybe (EntrypointLambda epParam epStore) : s)
forall store (mname :: Symbol) key value (s :: [*]).
(StoreHasSubmap store mname key value, KnownValue value) =>
Label mname -> (key : store : s) :-> (Maybe value : s)
stGet Label epmName
mapLabel ((store : s) :-> (Maybe (EntrypointLambda epParam epStore) : s))
-> ((Maybe (EntrypointLambda epParam epStore) : s)
    :-> (EntrypointLambda epParam epStore : s))
-> (store : s) :-> (EntrypointLambda epParam epStore : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label epName
-> (Maybe (EntrypointLambda epParam epStore) : s)
   :-> (EntrypointLambda epParam epStore : s)
forall (epName :: Symbol) epParam epStore (s :: [*]).
Label epName
-> (Maybe (EntrypointLambda epParam epStore) : s)
   :-> (EntrypointLambda epParam epStore : s)
someStEp Label epName
l
  , sopSetEpLambda :: forall (s :: [*]).
Label epName
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
sopSetEpLambda = \l :: Label epName
l -> Label epmName
-> Label epName
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
forall store (epmName :: Symbol) epParam epStore
       (epsName :: Symbol) (s :: [*]).
StoreHasSubmap
  store epmName MText (EntrypointLambda epParam epStore) =>
Label epmName
-> Label epsName
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
setStEp Label epmName
mapLabel Label epName
l
  , sopToEpStore :: forall (s :: [*]). Label epName -> (store : s) :-> (epStore : s)
sopToEpStore = \_l :: Label epName
_l -> Label epsName -> (store : s) :-> (epStore : s)
forall store (fname :: Symbol) ftype (s :: [*]).
StoreHasField store fname ftype =>
Label fname -> (store : s) :-> (ftype : s)
stToField Label epsName
fieldLabel
  , sopSetEpStore :: forall (s :: [*]).
Label epName -> (epStore : store : s) :-> (store : s)
sopSetEpStore = \_l :: Label epName
_l -> Label epsName -> (epStore : store : s) :-> (store : s)
forall store (fname :: Symbol) ftype (s :: [*]).
StoreHasField store fname ftype =>
Label fname -> (ftype : store : s) :-> (store : s)
stSetField Label epsName
fieldLabel
  }

-- | Implementation of 'StoreHasField' for a data type which has an
-- instance of 'StoreHasField' inside.
-- For instance, it can be used for top-level storage.
storeFieldOpsDeeper
  :: ( HasFieldOfType storage fieldsPartName fields
     , StoreHasField fields fname ftype
     )
  => Label fieldsPartName
  -> StoreFieldOps storage fname ftype
storeFieldOpsDeeper :: Label fieldsPartName -> StoreFieldOps storage fname ftype
storeFieldOpsDeeper fieldsLabel :: Label fieldsPartName
fieldsLabel =
  Label fieldsPartName
-> StoreFieldOps storage fieldsPartName fields
-> StoreFieldOps fields fname ftype
-> StoreFieldOps storage fname ftype
forall (nameInStore :: Symbol) store substore
       (nameInSubstore :: Symbol) field.
Label nameInStore
-> StoreFieldOps store nameInStore substore
-> StoreFieldOps substore nameInSubstore field
-> StoreFieldOps store nameInSubstore field
composeStoreFieldOps Label fieldsPartName
fieldsLabel StoreFieldOps storage fieldsPartName fields
forall dt (fname :: Symbol) ftype.
HasFieldOfType dt fname ftype =>
StoreFieldOps dt fname ftype
storeFieldOpsADT StoreFieldOps fields fname ftype
forall store (fname :: Symbol) ftype.
StoreHasField store fname ftype =>
StoreFieldOps store fname ftype
storeFieldOps

-- | Implementation of 'StoreHasSubmap' for a data type which has an
-- instance of 'StoreHasSubmap' inside.
-- For instance, it can be used for top-level storage.
storeSubmapOpsDeeper
  :: ( HasFieldOfType storage bigMapPartName fields
     , StoreHasSubmap fields mname key value
     )
  => Label bigMapPartName
  -> StoreSubmapOps storage mname key value
storeSubmapOpsDeeper :: Label bigMapPartName -> StoreSubmapOps storage mname key value
storeSubmapOpsDeeper submapLabel :: Label bigMapPartName
submapLabel =
  Label bigMapPartName
-> StoreFieldOps storage bigMapPartName fields
-> StoreSubmapOps fields mname key value
-> StoreSubmapOps storage mname key value
forall (nameInStore :: Symbol) store substore (mname :: Symbol) key
       value.
Label nameInStore
-> StoreFieldOps store nameInStore substore
-> StoreSubmapOps substore mname key value
-> StoreSubmapOps store mname key value
composeStoreSubmapOps Label bigMapPartName
submapLabel StoreFieldOps storage bigMapPartName fields
forall dt (fname :: Symbol) ftype.
HasFieldOfType dt fname ftype =>
StoreFieldOps dt fname ftype
storeFieldOpsADT StoreSubmapOps fields mname key value
forall store (mname :: Symbol) key value.
StoreHasSubmap store mname key value =>
StoreSubmapOps store mname key value
storeSubmapOps

-- | Implementation of 'StoreHasEntrypoint' for a data type which has an
-- instance of 'StoreHasEntrypoint' inside.
-- For instance, it can be used for top-level storage.
storeEntrypointOpsDeeper
  :: ( HasFieldOfType store nameInStore substore
     , StoreHasEntrypoint substore epName epParam epStore
     )
  => Label nameInStore
  -> StoreEntrypointOps store epName epParam epStore
storeEntrypointOpsDeeper :: Label nameInStore
-> StoreEntrypointOps store epName epParam epStore
storeEntrypointOpsDeeper fieldsLabel :: Label nameInStore
fieldsLabel =
  Label nameInStore
-> StoreFieldOps store nameInStore substore
-> StoreEntrypointOps substore epName epParam epStore
-> StoreEntrypointOps store epName epParam epStore
forall (nameInStore :: Symbol) store substore (epName :: Symbol)
       epParam epStore.
Label nameInStore
-> StoreFieldOps store nameInStore substore
-> StoreEntrypointOps substore epName epParam epStore
-> StoreEntrypointOps store epName epParam epStore
composeStoreEntrypointOps Label nameInStore
fieldsLabel StoreFieldOps store nameInStore substore
forall dt (fname :: Symbol) ftype.
HasFieldOfType dt fname ftype =>
StoreFieldOps dt fname ftype
storeFieldOpsADT StoreEntrypointOps substore epName epParam epStore
forall store (epName :: Symbol) epParam epStore.
StoreHasEntrypoint store epName epParam epStore =>
StoreEntrypointOps store epName epParam epStore
storeEpOps

{- | Pretend that given 'StoreSubmapOps' implementation is made up
for submap with name @desiredName@, not its actual name.
Logic of the implementation remains the same.

Use case: imagine that your code requires access to submap named @X@,
but in your storage that submap is called @Y@.
Then you implement the instance which makes @X@ refer to @Y@:

@
instance StoreHasSubmap Store X Key Value where
  storeSubmapOps = storeSubmapOpsReferTo #Y storeSubmapOpsForY
@
-}
storeSubmapOpsReferTo
  :: Label name
  -> StoreSubmapOps storage name key value
  -> StoreSubmapOps storage desiredName key value
storeSubmapOpsReferTo :: Label name
-> StoreSubmapOps storage name key value
-> StoreSubmapOps storage desiredName key value
storeSubmapOpsReferTo l :: Label name
l StoreSubmapOps{..} =
  $WStoreSubmapOps :: forall store (mname :: Symbol) key value.
(forall (s :: [*]).
 Label mname -> (key : store : s) :-> (Bool : s))
-> (forall (s :: [*]).
    KnownValue value =>
    Label mname -> (key : store : s) :-> (Maybe value : s))
-> (forall (s :: [*]).
    Label mname -> (key : Maybe value : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : value : store : s) :-> (store : s))
-> StoreSubmapOps store mname key value
StoreSubmapOps
  { sopMem :: forall (s :: [*]).
Label desiredName -> (key : storage : s) :-> (Bool : s)
sopMem = \_l :: Label desiredName
_l -> Label name -> (key : storage : s) :-> (Bool : s)
forall (s :: [*]). Label name -> (key : storage : s) :-> (Bool : s)
sopMem Label name
l
  , sopGet :: forall (s :: [*]).
KnownValue value =>
Label desiredName -> (key : storage : s) :-> (Maybe value : s)
sopGet = \_l :: Label desiredName
_l -> Label name -> (key : storage : s) :-> (Maybe value : s)
forall (s :: [*]).
KnownValue value =>
Label name -> (key : storage : s) :-> (Maybe value : s)
sopGet Label name
l
  , sopUpdate :: forall (s :: [*]).
Label desiredName
-> (key : Maybe value : storage : s) :-> (storage : s)
sopUpdate = \_l :: Label desiredName
_l -> Label name -> (key : Maybe value : storage : s) :-> (storage : s)
forall (s :: [*]).
Label name -> (key : Maybe value : storage : s) :-> (storage : s)
sopUpdate Label name
l
  , sopDelete :: forall (s :: [*]).
Label desiredName -> (key : storage : s) :-> (storage : s)
sopDelete = \_l :: Label desiredName
_l -> Label name -> (key : storage : s) :-> (storage : s)
forall (s :: [*]).
Label name -> (key : storage : s) :-> (storage : s)
sopDelete Label name
l
  , sopInsert :: forall (s :: [*]).
Label desiredName -> (key : value : storage : s) :-> (storage : s)
sopInsert = \_l :: Label desiredName
_l -> Label name -> (key : value : storage : s) :-> (storage : s)
forall (s :: [*]).
Label name -> (key : value : storage : s) :-> (storage : s)
sopInsert Label name
l
  }

-- | Pretend that given 'StoreFieldOps' implementation is made up
-- for field with name @desiredName@, not its actual name.
-- Logic of the implementation remains the same.
--
-- See also 'storeSubmapOpsReferTo'.
storeFieldOpsReferTo
  :: Label name
  -> StoreFieldOps storage name field
  -> StoreFieldOps storage desiredName field
storeFieldOpsReferTo :: Label name
-> StoreFieldOps storage name field
-> StoreFieldOps storage desiredName field
storeFieldOpsReferTo l :: Label name
l StoreFieldOps{..} =
  $WStoreFieldOps :: forall store (fname :: Symbol) ftype.
(forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s))
-> (forall (s :: [*]).
    Label fname -> (ftype : store : s) :-> (store : s))
-> StoreFieldOps store fname ftype
StoreFieldOps
  { sopToField :: forall (s :: [*]).
Label desiredName -> (storage : s) :-> (field : s)
sopToField = \_l :: Label desiredName
_l -> Label name -> (storage : s) :-> (field : s)
forall (s :: [*]). Label name -> (storage : s) :-> (field : s)
sopToField Label name
l
  , sopSetField :: forall (s :: [*]).
Label desiredName -> (field : storage : s) :-> (storage : s)
sopSetField = \_l :: Label desiredName
_l -> Label name -> (field : storage : s) :-> (storage : s)
forall (s :: [*]).
Label name -> (field : storage : s) :-> (storage : s)
sopSetField Label name
l
  }

-- | Pretend that given 'StoreEntrypointOps' implementation is made up
-- for entrypoint with name @desiredName@, not its actual name.
-- Logic of the implementation remains the same.
--
-- See also 'storeSubmapOpsReferTo'.
storeEntrypointOpsReferTo
  :: Label epName
  -> StoreEntrypointOps store epName epParam epStore
  -> StoreEntrypointOps store desiredName epParam epStore
storeEntrypointOpsReferTo :: Label epName
-> StoreEntrypointOps store epName epParam epStore
-> StoreEntrypointOps store desiredName epParam epStore
storeEntrypointOpsReferTo l :: Label epName
l StoreEntrypointOps{..} = $WStoreEntrypointOps :: forall store (epName :: Symbol) epParam epStore.
(forall (s :: [*]).
 Label epName
 -> (store : s) :-> (EntrypointLambda epParam epStore : s))
-> (forall (s :: [*]).
    Label epName
    -> (EntrypointLambda epParam epStore : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label epName -> (store : s) :-> (epStore : s))
-> (forall (s :: [*]).
    Label epName -> (epStore : store : s) :-> (store : s))
-> StoreEntrypointOps store epName epParam epStore
StoreEntrypointOps
  { sopToEpLambda :: forall (s :: [*]).
Label desiredName
-> (store : s) :-> (EntrypointLambda epParam epStore : s)
sopToEpLambda = \_l :: Label desiredName
_l -> Label epName
-> (store : s) :-> (EntrypointLambda epParam epStore : s)
forall (s :: [*]).
Label epName
-> (store : s) :-> (EntrypointLambda epParam epStore : s)
sopToEpLambda Label epName
l
  , sopSetEpLambda :: forall (s :: [*]).
Label desiredName
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
sopSetEpLambda = \_l :: Label desiredName
_l -> Label epName
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
forall (s :: [*]).
Label epName
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
sopSetEpLambda Label epName
l
  , sopToEpStore :: forall (s :: [*]).
Label desiredName -> (store : s) :-> (epStore : s)
sopToEpStore = \_l :: Label desiredName
_l -> Label epName -> (store : s) :-> (epStore : s)
forall (s :: [*]). Label epName -> (store : s) :-> (epStore : s)
sopToEpStore Label epName
l
  , sopSetEpStore :: forall (s :: [*]).
Label desiredName -> (epStore : store : s) :-> (store : s)
sopSetEpStore = \_l :: Label desiredName
_l -> Label epName -> (epStore : store : s) :-> (store : s)
forall (s :: [*]).
Label epName -> (epStore : store : s) :-> (store : s)
sopSetEpStore Label epName
l
  }

-- | Change field operations so that they work on a modified field.
--
-- For instance, to go from
-- @StoreFieldOps Storage "name" Integer@
-- to
-- @StoreFieldOps Storage "name" (value :! Integer)@
-- you can use
-- @mapStoreFieldOps (namedIso #value)@
mapStoreFieldOps
  :: LIso field1 field2
  -> StoreFieldOps store name field1
  -> StoreFieldOps store name field2
mapStoreFieldOps :: LIso field1 field2
-> StoreFieldOps store name field1
-> StoreFieldOps store name field2
mapStoreFieldOps LIso{..} StoreFieldOps{..} = $WStoreFieldOps :: forall store (fname :: Symbol) ftype.
(forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s))
-> (forall (s :: [*]).
    Label fname -> (ftype : store : s) :-> (store : s))
-> StoreFieldOps store fname ftype
StoreFieldOps
  { sopToField :: forall (s :: [*]). Label name -> (store : s) :-> (field2 : s)
sopToField = \l :: Label name
l -> Label name -> (store : s) :-> (field1 : s)
forall (s :: [*]). Label name -> (store : s) :-> (field1 : s)
sopToField Label name
l ((store : s) :-> (field1 : s))
-> ((field1 : s) :-> (field2 : s)) -> (store : s) :-> (field2 : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (field1 : s) :-> (field2 : s)
forall (s :: [*]). (field1 : s) :-> (field2 : s)
liTo
  , sopSetField :: forall (s :: [*]).
Label name -> (field2 : store : s) :-> (store : s)
sopSetField = \l :: Label name
l -> (field2 : store : s) :-> (field1 : store : s)
forall (s :: [*]). (field2 : s) :-> (field1 : s)
liFrom ((field2 : store : s) :-> (field1 : store : s))
-> ((field1 : store : s) :-> (store : s))
-> (field2 : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label name -> (field1 : store : s) :-> (store : s)
forall (s :: [*]).
Label name -> (field1 : store : s) :-> (store : s)
sopSetField Label name
l
  }

-- | Change submap operations so that they work on a modified key.
mapStoreSubmapOpsKey
  :: Lambda key2 key1
  -> StoreSubmapOps store name key1 value
  -> StoreSubmapOps store name key2 value
mapStoreSubmapOpsKey :: Lambda key2 key1
-> StoreSubmapOps store name key1 value
-> StoreSubmapOps store name key2 value
mapStoreSubmapOpsKey mapper :: Lambda key2 key1
mapper StoreSubmapOps{..} = $WStoreSubmapOps :: forall store (mname :: Symbol) key value.
(forall (s :: [*]).
 Label mname -> (key : store : s) :-> (Bool : s))
-> (forall (s :: [*]).
    KnownValue value =>
    Label mname -> (key : store : s) :-> (Maybe value : s))
-> (forall (s :: [*]).
    Label mname -> (key : Maybe value : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : value : store : s) :-> (store : s))
-> StoreSubmapOps store mname key value
StoreSubmapOps
  { sopMem :: forall (s :: [*]). Label name -> (key2 : store : s) :-> (Bool : s)
sopMem = \l :: Label name
l ->
      Lambda key2 key1
-> ('[key2] ++ (store : s)) :-> ('[key1] ++ (store : s))
forall (s :: [*]) (i :: [*]) (o :: [*]).
(KnownList i, KnownList o) =>
(i :-> o) -> (i ++ s) :-> (o ++ s)
L.framed Lambda key2 key1
mapper ((key2 : store : s) :-> (key1 : store : s))
-> ((key1 : store : s) :-> (Bool : s))
-> (key2 : store : s) :-> (Bool : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label name -> (key1 : store : s) :-> (Bool : s)
forall (s :: [*]). Label name -> (key1 : store : s) :-> (Bool : s)
sopMem Label name
l
  , sopGet :: forall (s :: [*]).
KnownValue value =>
Label name -> (key2 : store : s) :-> (Maybe value : s)
sopGet = \l :: Label name
l ->
      Lambda key2 key1
-> ('[key2] ++ (store : s)) :-> ('[key1] ++ (store : s))
forall (s :: [*]) (i :: [*]) (o :: [*]).
(KnownList i, KnownList o) =>
(i :-> o) -> (i ++ s) :-> (o ++ s)
L.framed Lambda key2 key1
mapper ((key2 : store : s) :-> (key1 : store : s))
-> ((key1 : store : s) :-> (Maybe value : s))
-> (key2 : store : s) :-> (Maybe value : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label name -> (key1 : store : s) :-> (Maybe value : s)
forall (s :: [*]).
KnownValue value =>
Label name -> (key1 : store : s) :-> (Maybe value : s)
sopGet Label name
l
  , sopUpdate :: forall (s :: [*]).
Label name -> (key2 : Maybe value : store : s) :-> (store : s)
sopUpdate = \l :: Label name
l ->
      Lambda key2 key1
-> ('[key2] ++ (Maybe value : store : s))
   :-> ('[key1] ++ (Maybe value : store : s))
forall (s :: [*]) (i :: [*]) (o :: [*]).
(KnownList i, KnownList o) =>
(i :-> o) -> (i ++ s) :-> (o ++ s)
L.framed Lambda key2 key1
mapper ((key2 : Maybe value : store : s)
 :-> (key1 : Maybe value : store : s))
-> ((key1 : Maybe value : store : s) :-> (store : s))
-> (key2 : Maybe value : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label name -> (key1 : Maybe value : store : s) :-> (store : s)
forall (s :: [*]).
Label name -> (key1 : Maybe value : store : s) :-> (store : s)
sopUpdate Label name
l
  , sopDelete :: forall (s :: [*]). Label name -> (key2 : store : s) :-> (store : s)
sopDelete = \l :: Label name
l ->
      Lambda key2 key1
-> ('[key2] ++ (store : s)) :-> ('[key1] ++ (store : s))
forall (s :: [*]) (i :: [*]) (o :: [*]).
(KnownList i, KnownList o) =>
(i :-> o) -> (i ++ s) :-> (o ++ s)
L.framed Lambda key2 key1
mapper ((key2 : store : s) :-> (key1 : store : s))
-> ((key1 : store : s) :-> (store : s))
-> (key2 : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label name -> (key1 : store : s) :-> (store : s)
forall (s :: [*]). Label name -> (key1 : store : s) :-> (store : s)
sopDelete Label name
l
  , sopInsert :: forall (s :: [*]).
Label name -> (key2 : value : store : s) :-> (store : s)
sopInsert = \l :: Label name
l ->
      Lambda key2 key1
-> ('[key2] ++ (value : store : s))
   :-> ('[key1] ++ (value : store : s))
forall (s :: [*]) (i :: [*]) (o :: [*]).
(KnownList i, KnownList o) =>
(i :-> o) -> (i ++ s) :-> (o ++ s)
L.framed Lambda key2 key1
mapper ((key2 : value : store : s) :-> (key1 : value : store : s))
-> ((key1 : value : store : s) :-> (store : s))
-> (key2 : value : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label name -> (key1 : value : store : s) :-> (store : s)
forall (s :: [*]).
Label name -> (key1 : value : store : s) :-> (store : s)
sopInsert Label name
l
  }

-- | Change submap operations so that they work on a modified value.
mapStoreSubmapOpsValue
  :: (KnownValue value1)
  => LIso value1 value2
  -> StoreSubmapOps store name key value1
  -> StoreSubmapOps store name key value2
mapStoreSubmapOpsValue :: LIso value1 value2
-> StoreSubmapOps store name key value1
-> StoreSubmapOps store name key value2
mapStoreSubmapOpsValue LIso{..} StoreSubmapOps{..} = $WStoreSubmapOps :: forall store (mname :: Symbol) key value.
(forall (s :: [*]).
 Label mname -> (key : store : s) :-> (Bool : s))
-> (forall (s :: [*]).
    KnownValue value =>
    Label mname -> (key : store : s) :-> (Maybe value : s))
-> (forall (s :: [*]).
    Label mname -> (key : Maybe value : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : value : store : s) :-> (store : s))
-> StoreSubmapOps store mname key value
StoreSubmapOps
  { sopMem :: forall (s :: [*]). Label name -> (key : store : s) :-> (Bool : s)
sopMem = \l :: Label name
l ->
      Label name -> (key : store : s) :-> (Bool : s)
forall (s :: [*]). Label name -> (key : store : s) :-> (Bool : s)
sopMem Label name
l
  , sopGet :: forall (s :: [*]).
KnownValue value2 =>
Label name -> (key : store : s) :-> (Maybe value2 : s)
sopGet = \l :: Label name
l ->
      Label name -> (key : store : s) :-> (Maybe value1 : s)
forall (s :: [*]).
KnownValue value1 =>
Label name -> (key : store : s) :-> (Maybe value1 : s)
sopGet Label name
l ((key : store : s) :-> (Maybe value1 : s))
-> ((Maybe value1 : s) :-> (Maybe value2 : s))
-> (key : store : s) :-> (Maybe value2 : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# ((value1 : s) :-> (value2 : s))
-> (Maybe value1 : s) :-> (Maybe value2 : s)
forall (c :: * -> *) b a (s :: [*]).
(LorentzFunctor c, KnownValue b) =>
((a : s) :-> (b : s)) -> (c a : s) :-> (c b : s)
L.lmap (value1 : s) :-> (value2 : s)
forall (s :: [*]). (value1 : s) :-> (value2 : s)
liTo
  , sopUpdate :: forall (s :: [*]).
Label name -> (key : Maybe value2 : store : s) :-> (store : s)
sopUpdate = \l :: Label name
l ->
      ((Maybe value2 : store : s) :-> (Maybe value1 : store : s))
-> (key : Maybe value2 : store : s)
   :-> (key : Maybe value1 : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (((value2 : store : s) :-> (value1 : store : s))
-> (Maybe value2 : store : s) :-> (Maybe value1 : store : s)
forall (c :: * -> *) b a (s :: [*]).
(LorentzFunctor c, KnownValue b) =>
((a : s) :-> (b : s)) -> (c a : s) :-> (c b : s)
L.lmap (value2 : store : s) :-> (value1 : store : s)
forall (s :: [*]). (value2 : s) :-> (value1 : s)
liFrom) ((key : Maybe value2 : store : s)
 :-> (key : Maybe value1 : store : s))
-> ((key : Maybe value1 : store : s) :-> (store : s))
-> (key : Maybe value2 : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label name -> (key : Maybe value1 : store : s) :-> (store : s)
forall (s :: [*]).
Label name -> (key : Maybe value1 : store : s) :-> (store : s)
sopUpdate Label name
l
  , sopInsert :: forall (s :: [*]).
Label name -> (key : value2 : store : s) :-> (store : s)
sopInsert = \l :: Label name
l ->
      ((value2 : store : s) :-> (value1 : store : s))
-> (key : value2 : store : s) :-> (key : value1 : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (value2 : store : s) :-> (value1 : store : s)
forall (s :: [*]). (value2 : s) :-> (value1 : s)
liFrom ((key : value2 : store : s) :-> (key : value1 : store : s))
-> ((key : value1 : store : s) :-> (store : s))
-> (key : value2 : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label name -> (key : value1 : store : s) :-> (store : s)
forall (s :: [*]).
Label name -> (key : value1 : store : s) :-> (store : s)
sopInsert Label name
l
  , sopDelete :: forall (s :: [*]). Label name -> (key : store : s) :-> (store : s)
sopDelete = \l :: Label name
l ->
      Label name -> (key : store : s) :-> (store : s)
forall (s :: [*]). Label name -> (key : store : s) :-> (store : s)
sopDelete Label name
l
  }

-- | Chain two implementations of field operations.
--
-- Suits for a case when your store does not contain its fields directly
-- rather has a nested structure.
composeStoreFieldOps
  :: Label nameInStore
  -> StoreFieldOps store nameInStore substore
  -> StoreFieldOps substore nameInSubstore field
  -> StoreFieldOps store nameInSubstore field
composeStoreFieldOps :: Label nameInStore
-> StoreFieldOps store nameInStore substore
-> StoreFieldOps substore nameInSubstore field
-> StoreFieldOps store nameInSubstore field
composeStoreFieldOps l1 :: Label nameInStore
l1 ops1 :: StoreFieldOps store nameInStore substore
ops1 ops2 :: StoreFieldOps substore nameInSubstore field
ops2 =
  $WStoreFieldOps :: forall store (fname :: Symbol) ftype.
(forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s))
-> (forall (s :: [*]).
    Label fname -> (ftype : store : s) :-> (store : s))
-> StoreFieldOps store fname ftype
StoreFieldOps
  { sopToField :: forall (s :: [*]).
Label nameInSubstore -> (store : s) :-> (field : s)
sopToField = \l2 :: Label nameInSubstore
l2 ->
      StoreFieldOps store nameInStore substore
-> Label nameInStore -> (store : s) :-> (substore : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1 ((store : s) :-> (substore : s))
-> ((substore : s) :-> (field : s)) -> (store : s) :-> (field : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreFieldOps substore nameInSubstore field
-> Label nameInSubstore -> (substore : s) :-> (field : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps substore nameInSubstore field
ops2 Label nameInSubstore
l2
  , sopSetField :: forall (s :: [*]).
Label nameInSubstore -> (field : store : s) :-> (store : s)
sopSetField = \l2 :: Label nameInSubstore
l2 ->
      ((store : s) :-> (substore : store : s))
-> (field : store : s) :-> (field : substore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip ((store : s) :-> (store : store : s)
forall a (s :: [*]). (a : s) :-> (a : a : s)
L.dup ((store : s) :-> (store : store : s))
-> ((store : store : s) :-> (substore : store : s))
-> (store : s) :-> (substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreFieldOps store nameInStore substore
-> Label nameInStore
-> (store : store : s) :-> (substore : store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1) ((field : store : s) :-> (field : substore : store : s))
-> ((field : substore : store : s) :-> (substore : store : s))
-> (field : store : s) :-> (substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreFieldOps substore nameInSubstore field
-> Label nameInSubstore
-> (field : substore : store : s) :-> (substore : store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]).
   Label fname -> (ftype : store : s) :-> (store : s)
sopSetField StoreFieldOps substore nameInSubstore field
ops2 Label nameInSubstore
l2 ((field : store : s) :-> (substore : store : s))
-> ((substore : store : s) :-> (store : s))
-> (field : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreFieldOps store nameInStore substore
-> Label nameInStore -> (substore : store : s) :-> (store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]).
   Label fname -> (ftype : store : s) :-> (store : s)
sopSetField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1
  }

-- | Chain implementations of field and submap operations.
composeStoreSubmapOps
  :: Label nameInStore
  -> StoreFieldOps store nameInStore substore
  -> StoreSubmapOps substore mname key value
  -> StoreSubmapOps store mname key value
composeStoreSubmapOps :: Label nameInStore
-> StoreFieldOps store nameInStore substore
-> StoreSubmapOps substore mname key value
-> StoreSubmapOps store mname key value
composeStoreSubmapOps l1 :: Label nameInStore
l1 ops1 :: StoreFieldOps store nameInStore substore
ops1 ops2 :: StoreSubmapOps substore mname key value
ops2 =
  $WStoreSubmapOps :: forall store (mname :: Symbol) key value.
(forall (s :: [*]).
 Label mname -> (key : store : s) :-> (Bool : s))
-> (forall (s :: [*]).
    KnownValue value =>
    Label mname -> (key : store : s) :-> (Maybe value : s))
-> (forall (s :: [*]).
    Label mname -> (key : Maybe value : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : value : store : s) :-> (store : s))
-> StoreSubmapOps store mname key value
StoreSubmapOps
  { sopMem :: forall (s :: [*]). Label mname -> (key : store : s) :-> (Bool : s)
sopMem = \l2 :: Label mname
l2 ->
      ((store : s) :-> (substore : s))
-> (key : store : s) :-> (key : substore : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (StoreFieldOps store nameInStore substore
-> Label nameInStore -> (store : s) :-> (substore : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1) ((key : store : s) :-> (key : substore : s))
-> ((key : substore : s) :-> (Bool : s))
-> (key : store : s) :-> (Bool : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreSubmapOps substore mname key value
-> Label mname -> (key : substore : s) :-> (Bool : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : store : s) :-> (Bool : s)
sopMem StoreSubmapOps substore mname key value
ops2 Label mname
l2
  , sopGet :: forall (s :: [*]).
KnownValue value =>
Label mname -> (key : store : s) :-> (Maybe value : s)
sopGet = \l2 :: Label mname
l2 ->
      ((store : s) :-> (substore : s))
-> (key : store : s) :-> (key : substore : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (StoreFieldOps store nameInStore substore
-> Label nameInStore -> (store : s) :-> (substore : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1) ((key : store : s) :-> (key : substore : s))
-> ((key : substore : s) :-> (Maybe value : s))
-> (key : store : s) :-> (Maybe value : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreSubmapOps substore mname key value
-> Label mname -> (key : substore : s) :-> (Maybe value : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   KnownValue value =>
   Label mname -> (key : store : s) :-> (Maybe value : s)
sopGet StoreSubmapOps substore mname key value
ops2 Label mname
l2
  , sopUpdate :: forall (s :: [*]).
Label mname -> (key : Maybe value : store : s) :-> (store : s)
sopUpdate = \l2 :: Label mname
l2 ->
      ((Maybe value : store : s)
 :-> (Maybe value : substore : store : s))
-> (key : Maybe value : store : s)
   :-> (key : Maybe value : substore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (((store : s) :-> (substore : store : s))
-> (Maybe value : store : s)
   :-> (Maybe value : substore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip ((store : s) :-> (store : store : s)
forall a (s :: [*]). (a : s) :-> (a : a : s)
L.dup ((store : s) :-> (store : store : s))
-> ((store : store : s) :-> (substore : store : s))
-> (store : s) :-> (substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreFieldOps store nameInStore substore
-> Label nameInStore
-> (store : store : s) :-> (substore : store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1)) ((key : Maybe value : store : s)
 :-> (key : Maybe value : substore : store : s))
-> ((key : Maybe value : substore : store : s)
    :-> (substore : store : s))
-> (key : Maybe value : store : s) :-> (substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreSubmapOps substore mname key value
-> Label mname
-> (key : Maybe value : substore : store : s)
   :-> (substore : store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : Maybe value : store : s) :-> (store : s)
sopUpdate StoreSubmapOps substore mname key value
ops2 Label mname
l2 ((key : Maybe value : store : s) :-> (substore : store : s))
-> ((substore : store : s) :-> (store : s))
-> (key : Maybe value : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreFieldOps store nameInStore substore
-> Label nameInStore -> (substore : store : s) :-> (store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]).
   Label fname -> (ftype : store : s) :-> (store : s)
sopSetField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1
  , sopDelete :: forall (s :: [*]). Label mname -> (key : store : s) :-> (store : s)
sopDelete = \l2 :: Label mname
l2 ->
      ((store : s) :-> (substore : store : s))
-> (key : store : s) :-> (key : substore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip ((store : s) :-> (store : store : s)
forall a (s :: [*]). (a : s) :-> (a : a : s)
L.dup ((store : s) :-> (store : store : s))
-> ((store : store : s) :-> (substore : store : s))
-> (store : s) :-> (substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreFieldOps store nameInStore substore
-> Label nameInStore
-> (store : store : s) :-> (substore : store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1) ((key : store : s) :-> (key : substore : store : s))
-> ((key : substore : store : s) :-> (substore : store : s))
-> (key : store : s) :-> (substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreSubmapOps substore mname key value
-> Label mname
-> (key : substore : store : s) :-> (substore : store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : store : s) :-> (store : s)
sopDelete StoreSubmapOps substore mname key value
ops2 Label mname
l2 ((key : store : s) :-> (substore : store : s))
-> ((substore : store : s) :-> (store : s))
-> (key : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreFieldOps store nameInStore substore
-> Label nameInStore -> (substore : store : s) :-> (store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]).
   Label fname -> (ftype : store : s) :-> (store : s)
sopSetField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1
  , sopInsert :: forall (s :: [*]).
Label mname -> (key : value : store : s) :-> (store : s)
sopInsert = \l2 :: Label mname
l2 ->
      ((value : store : s) :-> (value : substore : store : s))
-> (key : value : store : s)
   :-> (key : value : substore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (((store : s) :-> (substore : store : s))
-> (value : store : s) :-> (value : substore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip ((store : s) :-> (store : store : s)
forall a (s :: [*]). (a : s) :-> (a : a : s)
L.dup ((store : s) :-> (store : store : s))
-> ((store : store : s) :-> (substore : store : s))
-> (store : s) :-> (substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreFieldOps store nameInStore substore
-> Label nameInStore
-> (store : store : s) :-> (substore : store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1)) ((key : value : store : s)
 :-> (key : value : substore : store : s))
-> ((key : value : substore : store : s)
    :-> (substore : store : s))
-> (key : value : store : s) :-> (substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreSubmapOps substore mname key value
-> Label mname
-> (key : value : substore : store : s) :-> (substore : store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : value : store : s) :-> (store : s)
sopInsert StoreSubmapOps substore mname key value
ops2 Label mname
l2 ((key : value : store : s) :-> (substore : store : s))
-> ((substore : store : s) :-> (store : s))
-> (key : value : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreFieldOps store nameInStore substore
-> Label nameInStore -> (substore : store : s) :-> (store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]).
   Label fname -> (ftype : store : s) :-> (store : s)
sopSetField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1
  }

-- | Chain implementations of two submap operations sets.
-- Used to provide shortcut access to a nested submap.
--
-- This is very inefficient since on each access to substore
-- it has to be serialized/deserialized. Use this implementation
-- only if due to historical reasons migrating storage is difficult.
--
-- @LIso (Maybe substore) substore@ argument describes how to get
-- @substore@ value if it was absent in map and how to detect when
-- it can be safely removed.
--
-- Example of use:
-- @sequenceStoreSubmapOps #mySubmap nonDefIso storeSubmapOps storeSubmapOps@
sequenceStoreSubmapOps
  :: forall store substore value name subName key1 key2.
     (NiceConstant substore, KnownValue value)
  => Label name
  -> LIso (Maybe substore) substore
  -> StoreSubmapOps store name key1 substore
  -> StoreSubmapOps substore subName key2 value
  -> StoreSubmapOps store subName (key1, key2) value
sequenceStoreSubmapOps :: Label name
-> LIso (Maybe substore) substore
-> StoreSubmapOps store name key1 substore
-> StoreSubmapOps substore subName key2 value
-> StoreSubmapOps store subName (key1, key2) value
sequenceStoreSubmapOps l1 :: Label name
l1 substoreIso :: LIso (Maybe substore) substore
substoreIso ops1 :: StoreSubmapOps store name key1 substore
ops1 ops2 :: StoreSubmapOps substore subName key2 value
ops2 =
  (StoreSubmapOps store subName (key1, key2) value
 -> StoreSubmapOps store subName (key1, key2) value)
-> StoreSubmapOps store subName (key1, key2) value
forall a. (a -> a) -> a
fix ((StoreSubmapOps store subName (key1, key2) value
  -> StoreSubmapOps store subName (key1, key2) value)
 -> StoreSubmapOps store subName (key1, key2) value)
-> (StoreSubmapOps store subName (key1, key2) value
    -> StoreSubmapOps store subName (key1, key2) value)
-> StoreSubmapOps store subName (key1, key2) value
forall a b. (a -> b) -> a -> b
$ \res :: StoreSubmapOps store subName (key1, key2) value
res ->
  $WStoreSubmapOps :: forall store (mname :: Symbol) key value.
(forall (s :: [*]).
 Label mname -> (key : store : s) :-> (Bool : s))
-> (forall (s :: [*]).
    KnownValue value =>
    Label mname -> (key : store : s) :-> (Maybe value : s))
-> (forall (s :: [*]).
    Label mname -> (key : Maybe value : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : value : store : s) :-> (store : s))
-> StoreSubmapOps store mname key value
StoreSubmapOps
  { sopMem :: forall (s :: [*]).
Label subName -> ((key1, key2) : store : s) :-> (Bool : s)
sopMem = \l2 :: Label subName
l2 ->
      ((key1, key2) : store : s) :-> (key1 : key2 : store : s)
forall a b (s :: [*]). ((a, b) : s) :-> (a : b : s)
L.unpair (((key1, key2) : store : s) :-> (key1 : key2 : store : s))
-> ((key1 : key2 : store : s) :-> (key2 : key1 : store : s))
-> ((key1, key2) : store : s) :-> (key2 : key1 : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (key1 : key2 : store : s) :-> (key2 : key1 : store : s)
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
L.swap (((key1, key2) : store : s) :-> (key2 : key1 : store : s))
-> ((key2 : key1 : store : s) :-> (key2 : Maybe substore : s))
-> ((key1, key2) : store : s) :-> (key2 : Maybe substore : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      ((key1 : store : s) :-> (Maybe substore : s))
-> (key2 : key1 : store : s) :-> (key2 : Maybe substore : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (StoreSubmapOps store name key1 substore
-> Label name -> (key1 : store : s) :-> (Maybe substore : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   KnownValue value =>
   Label mname -> (key : store : s) :-> (Maybe value : s)
sopGet StoreSubmapOps store name key1 substore
ops1 Label name
l1) (((key1, key2) : store : s) :-> (key2 : Maybe substore : s))
-> ((key2 : Maybe substore : s) :-> (Maybe substore : key2 : s))
-> ((key1, key2) : store : s) :-> (Maybe substore : key2 : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (key2 : Maybe substore : s) :-> (Maybe substore : key2 : s)
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
L.swap (((key1, key2) : store : s) :-> (Maybe substore : key2 : s))
-> ((Maybe substore : key2 : s) :-> (Bool : s))
-> ((key1, key2) : store : s) :-> (Bool : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      ((substore : key2 : s) :-> (Bool : s))
-> ((key2 : s) :-> (Bool : s))
-> (Maybe substore : key2 : s) :-> (Bool : s)
forall a (s :: [*]) (s' :: [*]).
((a : s) :-> s') -> (s :-> s') -> (Maybe a : s) :-> s'
L.ifSome
        ((substore : key2 : s) :-> (key2 : substore : s)
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
L.swap ((substore : key2 : s) :-> (key2 : substore : s))
-> ((key2 : substore : s) :-> (Bool : s))
-> (substore : key2 : s) :-> (Bool : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreSubmapOps substore subName key2 value
-> Label subName -> (key2 : substore : s) :-> (Bool : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : store : s) :-> (Bool : s)
sopMem StoreSubmapOps substore subName key2 value
ops2 Label subName
l2)
        ((key2 : s) :-> s
forall a (s :: [*]). (a : s) :-> s
L.drop ((key2 : s) :-> s)
-> (s :-> (Bool : s)) -> (key2 : s) :-> (Bool : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Bool -> s :-> (Bool : s)
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
L.push Bool
False)
  , sopGet :: forall (s :: [*]).
KnownValue value =>
Label subName -> ((key1, key2) : store : s) :-> (Maybe value : s)
sopGet = \l2 :: Label subName
l2 ->
      ((key1, key2) : store : s) :-> (key1 : key2 : store : s)
forall a b (s :: [*]). ((a, b) : s) :-> (a : b : s)
L.unpair (((key1, key2) : store : s) :-> (key1 : key2 : store : s))
-> ((key1 : key2 : store : s) :-> (key2 : key1 : store : s))
-> ((key1, key2) : store : s) :-> (key2 : key1 : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (key1 : key2 : store : s) :-> (key2 : key1 : store : s)
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
L.swap (((key1, key2) : store : s) :-> (key2 : key1 : store : s))
-> ((key2 : key1 : store : s) :-> (key2 : Maybe substore : s))
-> ((key1, key2) : store : s) :-> (key2 : Maybe substore : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      ((key1 : store : s) :-> (Maybe substore : s))
-> (key2 : key1 : store : s) :-> (key2 : Maybe substore : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (StoreSubmapOps store name key1 substore
-> Label name -> (key1 : store : s) :-> (Maybe substore : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   KnownValue value =>
   Label mname -> (key : store : s) :-> (Maybe value : s)
sopGet StoreSubmapOps store name key1 substore
ops1 Label name
l1) (((key1, key2) : store : s) :-> (key2 : Maybe substore : s))
-> ((key2 : Maybe substore : s) :-> (Maybe substore : key2 : s))
-> ((key1, key2) : store : s) :-> (Maybe substore : key2 : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (key2 : Maybe substore : s) :-> (Maybe substore : key2 : s)
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
L.swap (((key1, key2) : store : s) :-> (Maybe substore : key2 : s))
-> ((Maybe substore : key2 : s) :-> (Maybe value : s))
-> ((key1, key2) : store : s) :-> (Maybe value : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      ((substore : key2 : s) :-> (Maybe value : s))
-> ((key2 : s) :-> (Maybe value : s))
-> (Maybe substore : key2 : s) :-> (Maybe value : s)
forall a (s :: [*]) (s' :: [*]).
((a : s) :-> s') -> (s :-> s') -> (Maybe a : s) :-> s'
L.ifSome
        ((substore : key2 : s) :-> (key2 : substore : s)
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
L.swap ((substore : key2 : s) :-> (key2 : substore : s))
-> ((key2 : substore : s) :-> (Maybe value : s))
-> (substore : key2 : s) :-> (Maybe value : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreSubmapOps substore subName key2 value
-> Label subName -> (key2 : substore : s) :-> (Maybe value : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   KnownValue value =>
   Label mname -> (key : store : s) :-> (Maybe value : s)
sopGet StoreSubmapOps substore subName key2 value
ops2 Label subName
l2)
        ((key2 : s) :-> s
forall a (s :: [*]). (a : s) :-> s
L.drop ((key2 : s) :-> s)
-> (s :-> (Maybe value : s)) -> (key2 : s) :-> (Maybe value : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# s :-> (Maybe value : s)
forall a (s :: [*]). KnownValue a => s :-> (Maybe a : s)
L.none)
  , sopUpdate :: forall (s :: [*]).
Label subName
-> ((key1, key2) : Maybe value : store : s) :-> (store : s)
sopUpdate = \l2 :: Label subName
l2 ->
      ((key1, key2) : Maybe value : store : s)
:-> (key1 : key2 : Maybe value : substore : store : s)
forall value' (s :: [*]).
((key1, key2) : value' : store : s)
:-> (key1 : key2 : value' : substore : store : s)
prepareUpdate (((key1, key2) : Maybe value : store : s)
 :-> (key1 : key2 : Maybe value : substore : store : s))
-> ((key1 : key2 : Maybe value : substore : store : s)
    :-> (key1 : Maybe substore : store : s))
-> ((key1, key2) : Maybe value : store : s)
   :-> (key1 : Maybe substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      ((key2 : Maybe value : substore : store : s)
 :-> (Maybe substore : store : s))
-> (key1 : key2 : Maybe value : substore : store : s)
   :-> (key1 : Maybe substore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (StoreSubmapOps substore subName key2 value
-> Label subName
-> (key2 : Maybe value : substore : store : s)
   :-> (substore : store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : Maybe value : store : s) :-> (store : s)
sopUpdate StoreSubmapOps substore subName key2 value
ops2 Label subName
l2 ((key2 : Maybe value : substore : store : s)
 :-> (substore : store : s))
-> ((substore : store : s) :-> (Maybe substore : store : s))
-> (key2 : Maybe value : substore : store : s)
   :-> (Maybe substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# LIso (Maybe substore) substore
-> forall (s :: [*]). (substore : s) :-> (Maybe substore : s)
forall a b. LIso a b -> forall (s :: [*]). (b : s) :-> (a : s)
liFrom LIso (Maybe substore) substore
substoreIso) (((key1, key2) : Maybe value : store : s)
 :-> (key1 : Maybe substore : store : s))
-> ((key1 : Maybe substore : store : s) :-> (store : s))
-> ((key1, key2) : Maybe value : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreSubmapOps store name key1 substore
-> Label name
-> (key1 : Maybe substore : store : s) :-> (store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : Maybe value : store : s) :-> (store : s)
sopUpdate StoreSubmapOps store name key1 substore
ops1 Label name
l1
  , sopDelete :: forall (s :: [*]).
Label subName -> ((key1, key2) : store : s) :-> (store : s)
sopDelete = \l2 :: Label subName
l2 ->
      ((store : s) :-> (Maybe value : store : s))
-> ((key1, key2) : store : s)
   :-> ((key1, key2) : Maybe value : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (store : s) :-> (Maybe value : store : s)
forall a (s :: [*]). KnownValue a => s :-> (Maybe a : s)
L.none (((key1, key2) : store : s)
 :-> ((key1, key2) : Maybe value : store : s))
-> (((key1, key2) : Maybe value : store : s) :-> (store : s))
-> ((key1, key2) : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreSubmapOps store subName (key1, key2) value
-> Label subName
-> ((key1, key2) : Maybe value : store : s) :-> (store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : Maybe value : store : s) :-> (store : s)
sopUpdate StoreSubmapOps store subName (key1, key2) value
res Label subName
l2
  , sopInsert :: forall (s :: [*]).
Label subName -> ((key1, key2) : value : store : s) :-> (store : s)
sopInsert = \l2 :: Label subName
l2 ->
      ((key1, key2) : value : store : s)
:-> (key1 : key2 : value : substore : store : s)
forall value' (s :: [*]).
((key1, key2) : value' : store : s)
:-> (key1 : key2 : value' : substore : store : s)
prepareUpdate (((key1, key2) : value : store : s)
 :-> (key1 : key2 : value : substore : store : s))
-> ((key1 : key2 : value : substore : store : s)
    :-> (key1 : substore : store : s))
-> ((key1, key2) : value : store : s)
   :-> (key1 : substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      ((key2 : value : substore : store : s) :-> (substore : store : s))
-> (key1 : key2 : value : substore : store : s)
   :-> (key1 : substore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (StoreSubmapOps substore subName key2 value
-> Label subName
-> (key2 : value : substore : store : s) :-> (substore : store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : value : store : s) :-> (store : s)
sopInsert StoreSubmapOps substore subName key2 value
ops2 Label subName
l2) (((key1, key2) : value : store : s)
 :-> (key1 : substore : store : s))
-> ((key1 : substore : store : s) :-> (store : s))
-> ((key1, key2) : value : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreSubmapOps store name key1 substore
-> Label name -> (key1 : substore : store : s) :-> (store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : value : store : s) :-> (store : s)
sopInsert StoreSubmapOps store name key1 substore
ops1 Label name
l1
  }
  where
    -- Extract all the necessary things prior to update
    prepareUpdate
      :: (key1, key2) : value' : store : s
         :-> key1 : key2 : value' : substore : store : s
    prepareUpdate :: ((key1, key2) : value' : store : s)
:-> (key1 : key2 : value' : substore : store : s)
prepareUpdate =
      ((key1, key2) : value' : store : s)
:-> ((key1, key2) : (key1, key2) : value' : store : s)
forall a (s :: [*]). (a : s) :-> (a : a : s)
L.dup (((key1, key2) : value' : store : s)
 :-> ((key1, key2) : (key1, key2) : value' : store : s))
-> (((key1, key2) : (key1, key2) : value' : store : s)
    :-> (key1 : (key1, key2) : value' : store : s))
-> ((key1, key2) : value' : store : s)
   :-> (key1 : (key1, key2) : value' : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# ((key1, key2) : (key1, key2) : value' : store : s)
:-> (key1 : (key1, key2) : value' : store : s)
forall a b (s :: [*]). ((a, b) : s) :-> (a : s)
L.car (((key1, key2) : value' : store : s)
 :-> (key1 : (key1, key2) : value' : store : s))
-> ((key1 : (key1, key2) : value' : store : s)
    :-> (key1 : key2 : value' : substore : store : s))
-> ((key1, key2) : value' : store : s)
   :-> (key1 : key2 : value' : substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      (((key1, key2) : value' : store : s)
 :-> (key2 : value' : substore : store : s))
-> (key1 : (key1, key2) : value' : store : s)
   :-> (key1 : key2 : value' : substore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip
        ( ((key1, key2) : value' : store : s)
:-> (value' : (key1, key2) : store : s)
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
L.swap (((key1, key2) : value' : store : s)
 :-> (value' : (key1, key2) : store : s))
-> ((value' : (key1, key2) : store : s)
    :-> (value' : key2 : substore : store : s))
-> ((key1, key2) : value' : store : s)
   :-> (value' : key2 : substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
          (((key1, key2) : store : s) :-> (key2 : substore : store : s))
-> (value' : (key1, key2) : store : s)
   :-> (value' : key2 : substore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip
            ( ((key1, key2) : store : s) :-> (key1 : key2 : store : s)
forall a b (s :: [*]). ((a, b) : s) :-> (a : b : s)
L.unpair (((key1, key2) : store : s) :-> (key1 : key2 : store : s))
-> ((key1 : key2 : store : s) :-> (key2 : key1 : store : s))
-> ((key1, key2) : store : s) :-> (key2 : key1 : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (key1 : key2 : store : s) :-> (key2 : key1 : store : s)
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
L.swap (((key1, key2) : store : s) :-> (key2 : key1 : store : s))
-> ((key2 : key1 : store : s) :-> (key2 : substore : store : s))
-> ((key1, key2) : store : s) :-> (key2 : substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
              ((key1 : store : s) :-> (substore : store : s))
-> (key2 : key1 : store : s) :-> (key2 : substore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip
                ( ((store : s) :-> (store : store : s))
-> (key1 : store : s) :-> (key1 : store : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (forall (s :: [*]). (store : s) :-> (store : store : s)
forall a (s :: [*]). (a : s) :-> (a : a : s)
L.dup @store) ((key1 : store : s) :-> (key1 : store : store : s))
-> ((key1 : store : store : s) :-> (Maybe substore : store : s))
-> (key1 : store : s) :-> (Maybe substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
                  StoreSubmapOps store name key1 substore
-> Label name
-> (key1 : store : store : s) :-> (Maybe substore : store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   KnownValue value =>
   Label mname -> (key : store : s) :-> (Maybe value : s)
sopGet StoreSubmapOps store name key1 substore
ops1 Label name
l1 ((key1 : store : s) :-> (Maybe substore : store : s))
-> ((Maybe substore : store : s) :-> (substore : store : s))
-> (key1 : store : s) :-> (substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# LIso (Maybe substore) substore
-> forall (s :: [*]). (Maybe substore : s) :-> (substore : s)
forall a b. LIso a b -> forall (s :: [*]). (a : s) :-> (b : s)
liTo LIso (Maybe substore) substore
substoreIso
                )
            ) (((key1, key2) : value' : store : s)
 :-> (value' : key2 : substore : store : s))
-> ((value' : key2 : substore : store : s)
    :-> (key2 : value' : substore : store : s))
-> ((key1, key2) : value' : store : s)
   :-> (key2 : value' : substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
          (value' : key2 : substore : store : s)
:-> (key2 : value' : substore : store : s)
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
L.swap
        )

composeStoreEntrypointOps
  :: Label nameInStore
  -> StoreFieldOps store nameInStore substore
  -> StoreEntrypointOps substore epName epParam epStore
  -> StoreEntrypointOps store epName epParam epStore
composeStoreEntrypointOps :: Label nameInStore
-> StoreFieldOps store nameInStore substore
-> StoreEntrypointOps substore epName epParam epStore
-> StoreEntrypointOps store epName epParam epStore
composeStoreEntrypointOps l1 :: Label nameInStore
l1 ops1 :: StoreFieldOps store nameInStore substore
ops1 ops2 :: StoreEntrypointOps substore epName epParam epStore
ops2 = $WStoreEntrypointOps :: forall store (epName :: Symbol) epParam epStore.
(forall (s :: [*]).
 Label epName
 -> (store : s) :-> (EntrypointLambda epParam epStore : s))
-> (forall (s :: [*]).
    Label epName
    -> (EntrypointLambda epParam epStore : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label epName -> (store : s) :-> (epStore : s))
-> (forall (s :: [*]).
    Label epName -> (epStore : store : s) :-> (store : s))
-> StoreEntrypointOps store epName epParam epStore
StoreEntrypointOps
  { sopToEpLambda :: forall (s :: [*]).
Label epName
-> (store : s) :-> (EntrypointLambda epParam epStore : s)
sopToEpLambda = \l2 :: Label epName
l2 ->
      StoreFieldOps store nameInStore substore
-> Label nameInStore -> (store : s) :-> (substore : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1 ((store : s) :-> (substore : s))
-> ((substore : s) :-> (EntrypointLambda epParam epStore : s))
-> (store : s) :-> (EntrypointLambda epParam epStore : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreEntrypointOps substore epName epParam epStore
-> Label epName
-> (substore : s) :-> (EntrypointLambda epParam epStore : s)
forall store (epName :: Symbol) epParam epStore.
StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]).
   Label epName
   -> (store : s) :-> (EntrypointLambda epParam epStore : s)
sopToEpLambda StoreEntrypointOps substore epName epParam epStore
ops2 Label epName
l2
  , sopSetEpLambda :: forall (s :: [*]).
Label epName
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
sopSetEpLambda = \l2 :: Label epName
l2 ->
      ((store : s) :-> (substore : store : s))
-> (EntrypointLambda epParam epStore : store : s)
   :-> (EntrypointLambda epParam epStore : substore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip ((store : s) :-> (store : store : s)
forall a (s :: [*]). (a : s) :-> (a : a : s)
L.dup ((store : s) :-> (store : store : s))
-> ((store : store : s) :-> (substore : store : s))
-> (store : s) :-> (substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreFieldOps store nameInStore substore
-> Label nameInStore
-> (store : store : s) :-> (substore : store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1) ((EntrypointLambda epParam epStore : store : s)
 :-> (EntrypointLambda epParam epStore : substore : store : s))
-> ((EntrypointLambda epParam epStore : substore : store : s)
    :-> (substore : store : s))
-> (EntrypointLambda epParam epStore : store : s)
   :-> (substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreEntrypointOps substore epName epParam epStore
-> Label epName
-> (EntrypointLambda epParam epStore : substore : store : s)
   :-> (substore : store : s)
forall store (epName :: Symbol) epParam epStore.
StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]).
   Label epName
   -> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
sopSetEpLambda StoreEntrypointOps substore epName epParam epStore
ops2 Label epName
l2 ((EntrypointLambda epParam epStore : store : s)
 :-> (substore : store : s))
-> ((substore : store : s) :-> (store : s))
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreFieldOps store nameInStore substore
-> Label nameInStore -> (substore : store : s) :-> (store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]).
   Label fname -> (ftype : store : s) :-> (store : s)
sopSetField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1
  , sopToEpStore :: forall (s :: [*]). Label epName -> (store : s) :-> (epStore : s)
sopToEpStore = \l2 :: Label epName
l2 ->
      StoreFieldOps store nameInStore substore
-> Label nameInStore -> (store : s) :-> (substore : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1 ((store : s) :-> (substore : s))
-> ((substore : s) :-> (epStore : s))
-> (store : s) :-> (epStore : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreEntrypointOps substore epName epParam epStore
-> Label epName -> (substore : s) :-> (epStore : s)
forall store (epName :: Symbol) epParam epStore.
StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]). Label epName -> (store : s) :-> (epStore : s)
sopToEpStore StoreEntrypointOps substore epName epParam epStore
ops2 Label epName
l2
  , sopSetEpStore :: forall (s :: [*]).
Label epName -> (epStore : store : s) :-> (store : s)
sopSetEpStore = \l2 :: Label epName
l2 ->
      ((store : s) :-> (substore : store : s))
-> (epStore : store : s) :-> (epStore : substore : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip ((store : s) :-> (store : store : s)
forall a (s :: [*]). (a : s) :-> (a : a : s)
L.dup ((store : s) :-> (store : store : s))
-> ((store : store : s) :-> (substore : store : s))
-> (store : s) :-> (substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreFieldOps store nameInStore substore
-> Label nameInStore
-> (store : store : s) :-> (substore : store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1) ((epStore : store : s) :-> (epStore : substore : store : s))
-> ((epStore : substore : store : s) :-> (substore : store : s))
-> (epStore : store : s) :-> (substore : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreEntrypointOps substore epName epParam epStore
-> Label epName
-> (epStore : substore : store : s) :-> (substore : store : s)
forall store (epName :: Symbol) epParam epStore.
StoreEntrypointOps store epName epParam epStore
-> forall (s :: [*]).
   Label epName -> (epStore : store : s) :-> (store : s)
sopSetEpStore StoreEntrypointOps substore epName epParam epStore
ops2 Label epName
l2 ((epStore : store : s) :-> (substore : store : s))
-> ((substore : store : s) :-> (store : s))
-> (epStore : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreFieldOps store nameInStore substore
-> Label nameInStore -> (substore : store : s) :-> (store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]).
   Label fname -> (ftype : store : s) :-> (store : s)
sopSetField StoreFieldOps store nameInStore substore
ops1 Label nameInStore
l1
  }


{- | Turn submap operations into operations on a part of the submap value.

Normally, if you need this set of operations, it would be better to split your
submap into several separate submaps, each operating with its own part of the value.
This set of operations is pretty inefficient and exists only as a temporary
measure, if due to historical reasons you have to leave storage format intact.

This implementation puts no distinction between @value == Nothing@ and
@value == Just defValue@ cases.
Getters, when notice a value equal to the default value, report its absence.
Setters tend to remove the value from submap when possible.

@LIso (Maybe value) value@ and @LIso (Maybe subvalue) subvalue@ arguments
describe how to get a value if it was absent in map and how to detect when
it can be safely removed from map.

Example of use:
@zoomStoreSubmapOps #mySubmap nonDefIso nonDefIso storeSubmapOps storeFieldOpsADT@
-}
zoomStoreSubmapOps
  :: forall store submapName nameInSubmap key value subvalue.
     (NiceConstant value, NiceConstant subvalue)
  => Label submapName
  -> LIso (Maybe value) value
  -> LIso (Maybe subvalue) subvalue
  -> StoreSubmapOps store submapName key value
  -> StoreFieldOps value nameInSubmap subvalue
  -> StoreSubmapOps store nameInSubmap key subvalue
zoomStoreSubmapOps :: Label submapName
-> LIso (Maybe value) value
-> LIso (Maybe subvalue) subvalue
-> StoreSubmapOps store submapName key value
-> StoreFieldOps value nameInSubmap subvalue
-> StoreSubmapOps store nameInSubmap key subvalue
zoomStoreSubmapOps l1 :: Label submapName
l1 valueIso :: LIso (Maybe value) value
valueIso subvalueIso :: LIso (Maybe subvalue) subvalue
subvalueIso ops1 :: StoreSubmapOps store submapName key value
ops1 ops2 :: StoreFieldOps value nameInSubmap subvalue
ops2 =
  (StoreSubmapOps store nameInSubmap key subvalue
 -> StoreSubmapOps store nameInSubmap key subvalue)
-> StoreSubmapOps store nameInSubmap key subvalue
forall a. (a -> a) -> a
fix ((StoreSubmapOps store nameInSubmap key subvalue
  -> StoreSubmapOps store nameInSubmap key subvalue)
 -> StoreSubmapOps store nameInSubmap key subvalue)
-> (StoreSubmapOps store nameInSubmap key subvalue
    -> StoreSubmapOps store nameInSubmap key subvalue)
-> StoreSubmapOps store nameInSubmap key subvalue
forall a b. (a -> b) -> a -> b
$ \res :: StoreSubmapOps store nameInSubmap key subvalue
res ->
  $WStoreSubmapOps :: forall store (mname :: Symbol) key value.
(forall (s :: [*]).
 Label mname -> (key : store : s) :-> (Bool : s))
-> (forall (s :: [*]).
    KnownValue value =>
    Label mname -> (key : store : s) :-> (Maybe value : s))
-> (forall (s :: [*]).
    Label mname -> (key : Maybe value : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : store : s) :-> (store : s))
-> (forall (s :: [*]).
    Label mname -> (key : value : store : s) :-> (store : s))
-> StoreSubmapOps store mname key value
StoreSubmapOps
  { sopMem :: forall (s :: [*]).
Label nameInSubmap -> (key : store : s) :-> (Bool : s)
sopMem = \l2 :: Label nameInSubmap
l2 ->
      StoreSubmapOps store submapName key value
-> Label submapName -> (key : store : s) :-> (Maybe value : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   KnownValue value =>
   Label mname -> (key : store : s) :-> (Maybe value : s)
sopGet StoreSubmapOps store submapName key value
ops1 Label submapName
l1 ((key : store : s) :-> (Maybe value : s))
-> ((Maybe value : s) :-> (Bool : s))
-> (key : store : s) :-> (Bool : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      ((value : s) :-> (Bool : s))
-> (s :-> (Bool : s)) -> (Maybe value : s) :-> (Bool : s)
forall a (s :: [*]) (s' :: [*]).
((a : s) :-> s') -> (s :-> s') -> (Maybe a : s) :-> s'
L.ifSome
        (StoreFieldOps value nameInSubmap subvalue
-> Label nameInSubmap -> (value : s) :-> (subvalue : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps value nameInSubmap subvalue
ops2 Label nameInSubmap
l2 ((value : s) :-> (subvalue : s))
-> ((subvalue : s) :-> (Maybe subvalue : s))
-> (value : s) :-> (Maybe subvalue : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# LIso (Maybe subvalue) subvalue
-> forall (s :: [*]). (subvalue : s) :-> (Maybe subvalue : s)
forall a b. LIso a b -> forall (s :: [*]). (b : s) :-> (a : s)
liFrom LIso (Maybe subvalue) subvalue
subvalueIso ((value : s) :-> (Maybe subvalue : s))
-> ((Maybe subvalue : s) :-> (Bool : s))
-> (value : s) :-> (Bool : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (Maybe subvalue : s) :-> (Bool : s)
forall a (s :: [*]). (Maybe a : s) :-> (Bool : s)
L.isSome)
        (Bool -> s :-> (Bool : s)
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
L.push Bool
False)
  , sopGet :: forall (s :: [*]).
KnownValue subvalue =>
Label nameInSubmap -> (key : store : s) :-> (Maybe subvalue : s)
sopGet = \l2 :: Label nameInSubmap
l2 ->
      StoreSubmapOps store submapName key value
-> Label submapName -> (key : store : s) :-> (Maybe value : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   KnownValue value =>
   Label mname -> (key : store : s) :-> (Maybe value : s)
sopGet StoreSubmapOps store submapName key value
ops1 Label submapName
l1 ((key : store : s) :-> (Maybe value : s))
-> ((Maybe value : s) :-> (Maybe subvalue : s))
-> (key : store : s) :-> (Maybe subvalue : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      ((value : s) :-> (Maybe subvalue : s))
-> (s :-> (Maybe subvalue : s))
-> (Maybe value : s) :-> (Maybe subvalue : s)
forall a (s :: [*]) (s' :: [*]).
((a : s) :-> s') -> (s :-> s') -> (Maybe a : s) :-> s'
L.ifSome
        (StoreFieldOps value nameInSubmap subvalue
-> Label nameInSubmap -> (value : s) :-> (subvalue : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]). Label fname -> (store : s) :-> (ftype : s)
sopToField StoreFieldOps value nameInSubmap subvalue
ops2 Label nameInSubmap
l2 ((value : s) :-> (subvalue : s))
-> ((subvalue : s) :-> (Maybe subvalue : s))
-> (value : s) :-> (Maybe subvalue : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# LIso (Maybe subvalue) subvalue
-> forall (s :: [*]). (subvalue : s) :-> (Maybe subvalue : s)
forall a b. LIso a b -> forall (s :: [*]). (b : s) :-> (a : s)
liFrom LIso (Maybe subvalue) subvalue
subvalueIso)
        s :-> (Maybe subvalue : s)
forall a (s :: [*]). KnownValue a => s :-> (Maybe a : s)
L.none
  , sopUpdate :: forall (s :: [*]).
Label nameInSubmap
-> (key : Maybe subvalue : store : s) :-> (store : s)
sopUpdate = \l2 :: Label nameInSubmap
l2 ->
      ((Maybe subvalue : store : s) :-> (subvalue : store : s))
-> (key : Maybe subvalue : store : s)
   :-> (key : subvalue : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (LIso (Maybe subvalue) subvalue
-> forall (s :: [*]). (Maybe subvalue : s) :-> (subvalue : s)
forall a b. LIso a b -> forall (s :: [*]). (a : s) :-> (b : s)
liTo LIso (Maybe subvalue) subvalue
subvalueIso) ((key : Maybe subvalue : store : s)
 :-> (key : subvalue : store : s))
-> ((key : subvalue : store : s) :-> (key : value : store : s))
-> (key : Maybe subvalue : store : s) :-> (key : value : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      Label nameInSubmap
-> (key : subvalue : store : s) :-> (key : value : store : s)
forall (s :: [*]).
Label nameInSubmap
-> (key : subvalue : store : s) :-> (key : value : store : s)
updateSubmapValue Label nameInSubmap
l2 ((key : Maybe subvalue : store : s) :-> (key : value : store : s))
-> ((key : value : store : s) :-> (key : Maybe value : store : s))
-> (key : Maybe subvalue : store : s)
   :-> (key : Maybe value : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      ((value : store : s) :-> (Maybe value : store : s))
-> (key : value : store : s) :-> (key : Maybe value : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (LIso (Maybe value) value
-> forall (s :: [*]). (value : s) :-> (Maybe value : s)
forall a b. LIso a b -> forall (s :: [*]). (b : s) :-> (a : s)
liFrom LIso (Maybe value) value
valueIso) ((key : Maybe subvalue : store : s)
 :-> (key : Maybe value : store : s))
-> ((key : Maybe value : store : s) :-> (store : s))
-> (key : Maybe subvalue : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreSubmapOps store submapName key value
-> Label submapName
-> (key : Maybe value : store : s) :-> (store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : Maybe value : store : s) :-> (store : s)
sopUpdate StoreSubmapOps store submapName key value
ops1 Label submapName
l1
  , sopDelete :: forall (s :: [*]).
Label nameInSubmap -> (key : store : s) :-> (store : s)
sopDelete = \l2 :: Label nameInSubmap
l2 ->
      ((store : s) :-> (Maybe subvalue : store : s))
-> (key : store : s) :-> (key : Maybe subvalue : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (store : s) :-> (Maybe subvalue : store : s)
forall a (s :: [*]). KnownValue a => s :-> (Maybe a : s)
L.none ((key : store : s) :-> (key : Maybe subvalue : store : s))
-> ((key : Maybe subvalue : store : s) :-> (store : s))
-> (key : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreSubmapOps store nameInSubmap key subvalue
-> Label nameInSubmap
-> (key : Maybe subvalue : store : s) :-> (store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : Maybe value : store : s) :-> (store : s)
sopUpdate StoreSubmapOps store nameInSubmap key subvalue
res Label nameInSubmap
l2
  , sopInsert :: forall (s :: [*]).
Label nameInSubmap -> (key : subvalue : store : s) :-> (store : s)
sopInsert = \l2 :: Label nameInSubmap
l2 ->
      Label nameInSubmap
-> (key : subvalue : store : s) :-> (key : value : store : s)
forall (s :: [*]).
Label nameInSubmap
-> (key : subvalue : store : s) :-> (key : value : store : s)
updateSubmapValue Label nameInSubmap
l2 ((key : subvalue : store : s) :-> (key : value : store : s))
-> ((key : value : store : s) :-> (store : s))
-> (key : subvalue : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      StoreSubmapOps store submapName key value
-> Label submapName -> (key : value : store : s) :-> (store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   Label mname -> (key : value : store : s) :-> (store : s)
sopInsert StoreSubmapOps store submapName key value
ops1 Label submapName
l1
  }
  where
    updateSubmapValue
      :: Label nameInSubmap
      -> key : subvalue : store : s
         :-> key : value : store : s
    updateSubmapValue :: Label nameInSubmap
-> (key : subvalue : store : s) :-> (key : value : store : s)
updateSubmapValue l2 :: Label nameInSubmap
l2 =
      (key : subvalue : store : s) :-> (key : key : subvalue : store : s)
forall a (s :: [*]). (a : s) :-> (a : a : s)
L.dup ((key : subvalue : store : s)
 :-> (key : key : subvalue : store : s))
-> ((key : key : subvalue : store : s)
    :-> (key : value : store : s))
-> (key : subvalue : store : s) :-> (key : value : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
      ((key : subvalue : store : s) :-> (value : store : s))
-> (key : key : subvalue : store : s) :-> (key : value : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip
          -- First getting the existing value
        ( (key : subvalue : store : s) :-> (subvalue : key : store : s)
forall a b (s :: [*]). (a : b : s) :-> (b : a : s)
L.swap ((key : subvalue : store : s) :-> (subvalue : key : store : s))
-> ((subvalue : key : store : s)
    :-> (subvalue : value : store : s))
-> (key : subvalue : store : s) :-> (subvalue : value : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
          ((key : store : s) :-> (value : store : s))
-> (subvalue : key : store : s) :-> (subvalue : value : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (((store : s) :-> (store : store : s))
-> (key : store : s) :-> (key : store : store : s)
forall a (s :: [*]) (s' :: [*]).
HasCallStack =>
(s :-> s') -> (a : s) :-> (a : s')
L.dip (store : s) :-> (store : store : s)
forall a (s :: [*]). (a : s) :-> (a : a : s)
L.dup ((key : store : s) :-> (key : store : store : s))
-> ((key : store : store : s) :-> (Maybe value : store : s))
-> (key : store : s) :-> (Maybe value : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# StoreSubmapOps store submapName key value
-> Label submapName
-> (key : store : store : s) :-> (Maybe value : store : s)
forall store (mname :: Symbol) key value.
StoreSubmapOps store mname key value
-> forall (s :: [*]).
   KnownValue value =>
   Label mname -> (key : store : s) :-> (Maybe value : s)
sopGet StoreSubmapOps store submapName key value
ops1 Label submapName
l1 ((key : store : s) :-> (Maybe value : store : s))
-> ((Maybe value : store : s) :-> (value : store : s))
-> (key : store : s) :-> (value : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# LIso (Maybe value) value
-> forall (s :: [*]). (Maybe value : s) :-> (value : s)
forall a b. LIso a b -> forall (s :: [*]). (a : s) :-> (b : s)
liTo LIso (Maybe value) value
valueIso) ((key : subvalue : store : s) :-> (subvalue : value : store : s))
-> ((subvalue : value : store : s) :-> (value : store : s))
-> (key : subvalue : store : s) :-> (value : store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
          -- Injecting new subvalue into value
          StoreFieldOps value nameInSubmap subvalue
-> Label nameInSubmap
-> (subvalue : value : store : s) :-> (value : store : s)
forall store (fname :: Symbol) ftype.
StoreFieldOps store fname ftype
-> forall (s :: [*]).
   Label fname -> (ftype : store : s) :-> (store : s)
sopSetField StoreFieldOps value nameInSubmap subvalue
ops2 Label nameInSubmap
l2
        )

-- | Utility to 'push' the 'MText' name of and entrypoint from its 'Label'
pushStEp :: Label name -> s :-> MText : s
pushStEp :: Label name -> s :-> (MText : s)
pushStEp = MText -> s :-> (MText : s)
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
L.push (MText -> s :-> (MText : s))
-> (Label name -> MText) -> Label name -> s :-> (MText : s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label name -> MText
forall (name :: Symbol). Label name -> MText
labelToMText

-- | Utility to extract an 'EntrypointLambda' from a 'Maybe', fails in case of
-- 'Nothing'.
someStEp
  :: Label epName
  -> Maybe (EntrypointLambda epParam epStore) : s :-> (EntrypointLambda epParam epStore) : s
someStEp :: Label epName
-> (Maybe (EntrypointLambda epParam epStore) : s)
   :-> (EntrypointLambda epParam epStore : s)
someStEp l :: Label epName
l = ((EntrypointLambda epParam epStore : s)
 :-> (EntrypointLambda epParam epStore : s))
-> (s :-> (EntrypointLambda epParam epStore : s))
-> (Maybe (EntrypointLambda epParam epStore) : s)
   :-> (EntrypointLambda epParam epStore : s)
forall a (s :: [*]) (s' :: [*]).
((a : s) :-> s') -> (s :-> s') -> (Maybe a : s) :-> s'
L.ifSome (EntrypointLambda epParam epStore : s)
:-> (EntrypointLambda epParam epStore : s)
forall (s :: [*]). s :-> s
L.nop ((s :-> (EntrypointLambda epParam epStore : s))
 -> (Maybe (EntrypointLambda epParam epStore) : s)
    :-> (EntrypointLambda epParam epStore : s))
-> (s :-> (EntrypointLambda epParam epStore : s))
-> (Maybe (EntrypointLambda epParam epStore) : s)
   :-> (EntrypointLambda epParam epStore : s)
forall a b. (a -> b) -> a -> b
$
  MText -> s :-> (EntrypointLambda epParam epStore : s)
forall (s :: [*]) (t :: [*]). MText -> s :-> t
failUnexpected ([mt|unknown storage entrypoint: |] MText -> MText -> MText
forall a. Semigroup a => a -> a -> a
<> Label epName -> MText
forall (name :: Symbol). Label name -> MText
labelToMText Label epName
l)

-- | Utility to set an 'EntrypointLambda' into a store.
-- Fails in case the entrypoint is already set.
setStEp
  :: StoreHasSubmap store epmName MText (EntrypointLambda epParam epStore)
  => Label epmName -> Label epsName
  -> (EntrypointLambda epParam epStore) : store : s :-> store : s
setStEp :: Label epmName
-> Label epsName
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
setStEp ml :: Label epmName
ml l :: Label epsName
l = Label epsName
-> (EntrypointLambda epParam epStore : store : s)
   :-> (MText : EntrypointLambda epParam epStore : store : s)
forall (name :: Symbol) (s :: [*]). Label name -> s :-> (MText : s)
pushStEp Label epsName
l ((EntrypointLambda epParam epStore : store : s)
 :-> (MText : EntrypointLambda epParam epStore : store : s))
-> ((MText : EntrypointLambda epParam epStore : store : s)
    :-> (store : s))
-> (EntrypointLambda epParam epStore : store : s) :-> (store : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label epmName
-> (forall (s0 :: [*]) (any :: [*]). (MText : s0) :-> any)
-> (MText : EntrypointLambda epParam epStore : store : s)
   :-> (store : s)
forall store (mname :: Symbol) key value (s :: [*]).
StoreHasSubmap store mname key value =>
Label mname
-> (forall (s0 :: [*]) (any :: [*]). (key : s0) :-> any)
-> (key : value : store : s) :-> (store : s)
stInsertNew Label epmName
ml forall (s0 :: [*]) (any :: [*]). (MText : s0) :-> any
failAlreadySetEp
  where
    failAlreadySetEp :: MText : s :-> any
    failAlreadySetEp :: (MText : s) :-> any
failAlreadySetEp =
      MText -> (MText : s) :-> (MText : MText : s)
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
L.push [mt|Storage entrypoint already set: |] ((MText : s) :-> (MText : MText : s))
-> ((MText : MText : s) :-> (MText : s))
-> (MText : s) :-> (MText : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (MText : MText : s) :-> (MText : s)
forall c (s :: [*]). ConcatOpHs c => (c : c : s) :-> (c : s)
L.concat ((MText : s) :-> (MText : s))
-> ((MText : s) :-> any) -> (MText : s) :-> any
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (MText : s) :-> any
forall a (s :: [*]) (t :: [*]). NiceConstant a => (a : s) :-> t
L.failWith

----------------------------------------------------------------------------
-- Storage generation
----------------------------------------------------------------------------

-- Note: we could make this safer with a 'StoreHasEntrypoint' constraint, but GHC
-- would flag it as redundant and we'd also need to annotate the @store@
--
-- | Utility to create 'EntrypointsField's from an entrypoint name (@epName@) and
-- an 'EntrypointLambda' implementation. Note that you need to merge multiple of
-- these (with '<>') if your field contains more than one entrypoint lambda.
mkStoreEp
  :: Label epName
  -> EntrypointLambda epParam epStore
  -> EntrypointsField epParam epStore
mkStoreEp :: Label epName
-> EntrypointLambda epParam epStore
-> EntrypointsField epParam epStore
mkStoreEp l :: Label epName
l = Map MText (EntrypointLambda epParam epStore)
-> EntrypointsField epParam epStore
forall k v. Map k v -> BigMap k v
BigMap (Map MText (EntrypointLambda epParam epStore)
 -> EntrypointsField epParam epStore)
-> (EntrypointLambda epParam epStore
    -> Map MText (EntrypointLambda epParam epStore))
-> EntrypointLambda epParam epStore
-> EntrypointsField epParam epStore
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MText
-> EntrypointLambda epParam epStore
-> Map MText (EntrypointLambda epParam epStore)
forall k a. k -> a -> Map k a
singleton (Label epName -> MText
forall (name :: Symbol). Label name -> MText
labelToMText Label epName
l)


----------------------------------------------------------------------------
-- Utilities
----------------------------------------------------------------------------

-- | Indicates a submap with given key and value types.
data k ~> v
infix 9 ~>

-- | Indicates a stored entrypoint with the given @param@ and @store@ types.
data param ::-> store
infix 9 ::->

{- | Concise way to write down constraints with expected content of a storage.

Use it like follows:

@
type StorageConstraint store = StorageContains store
  [ "fieldInt" := Int
  , "fieldNat" := Nat
  , "epsToNat" := Int ::-> Nat
  , "balances" := Address ~> Int
  ]
@

-}
type family StorageContains store (content :: [NamedField]) :: Constraint where
  StorageContains _ '[] = ()
  StorageContains store ((n := Identity ty) ': ct) =
    (StoreHasField store n ty, StorageContains store ct)
  StorageContains store ((n := k ~> v) ': ct) =
    (StoreHasSubmap store n k v, StorageContains store ct)
  StorageContains store ((n := ep ::-> es) ': ct) =
    (StoreHasEntrypoint store n ep es, StorageContains store ct)
  -- Convenient default case, but not applicable when field type is polymorphic
  StorageContains store ((n := ty) ': ct) =
    (StoreHasField store n ty, StorageContains store ct)