-- 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
  { sopToField
      :: forall s.
         Label fname -> store : s :-> ftype : 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 = sopToField storeFieldOps

-- | Get storage field, preserving the storage itself on stack.
stGetField
  :: StoreHasField store fname ftype
  => Label fname -> store : s :-> ftype : store : s
stGetField l = L.dup # sopToField storeFieldOps l

-- | Update storage field.
stSetField
  :: StoreHasField store fname ftype
  => Label fname -> ftype : store : s :-> store : s
stSetField = sopSetField 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
  { sopMem
      :: forall s.
         Label mname -> key : store : s :-> Bool : s
  , sopGet
      :: forall s.
         (KnownValue value)
      => Label mname -> key : store : s :-> Maybe value : 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.
  , sopDelete
      :: forall s.
         Label mname -> key : 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 = sopMem storeSubmapOps

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

-- | Update a value in storage.
stUpdate
  :: StoreHasSubmap store mname key value
  => Label mname -> key : Maybe value : store : s :-> store : s
stUpdate = sopUpdate 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 = sopDelete storeSubmapOps

-- | Add a value in storage.
stInsert
  :: StoreHasSubmap store mname key value
  => Label mname -> key : value : store : s :-> store : s
stInsert = sopInsert 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 l doFail =
  L.duupX @3 # L.duupX @2 # stMem l #
  L.if_ doFail (stInsert 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
    { sopMem = \_label -> L.mem
    , sopGet = \_label -> L.get
    , sopUpdate = \_label -> L.update
    , sopDelete = \_label -> L.deleteMap
    , sopInsert = \_label -> 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
    { sopMem = \_label -> L.mem
    , sopGet = \_label -> L.get
    , sopUpdate = \_label -> L.update
    , sopDelete = \_label -> L.deleteMap
    , sopInsert = \_label -> L.mapInsert
    }

instance NiceComparable key => StoreHasSubmap (Set key) name key () where
  storeSubmapOps = StoreSubmapOps
    { sopMem = \_label -> L.mem
    , sopGet = \_label -> L.mem # L.if_ (L.push $ Just ()) (L.push Nothing)
    , sopUpdate = \_label -> L.dip L.isSome # L.update
    , sopDelete = \_label -> L.setDelete
    , sopInsert = \_label -> L.dip L.drop # 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
  { sopToEpLambda
      :: forall s.
         Label epName
      -> store : s :-> (EntrypointLambda epParam epStore) : s
  , sopSetEpLambda
      :: forall s.
         Label epName
      -> (EntrypointLambda epParam epStore) : store : s :-> store : s
  , sopToEpStore
      :: forall s.
         Label epName
      -> store : s :-> epStore : 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 l =
  L.dip (L.dup # stGetEpLambda l # L.swap # stToEpStore l) #
  L.pair # L.exec # L.unpair #
  L.dip (stSetEpStore l) # L.pair

-- | Pick stored entrypoint lambda.
stToEpLambda
  :: StoreHasEntrypoint store epName epParam epStore
  => Label epName -> store : s :-> (EntrypointLambda epParam epStore) : s
stToEpLambda = sopToEpLambda 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 l = L.dup # stToEpLambda 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 = sopSetEpLambda storeEpOps

-- | Pick the sub-storage that the entrypoint operates on.
stToEpStore
  :: StoreHasEntrypoint store epName epParam epStore
  => Label epName -> store : s :-> epStore : s
stToEpStore = sopToEpStore 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 l = L.dup # stToEpStore l

-- | Update the sub-storage that the entrypoint operates on.
stSetEpStore
  :: StoreHasEntrypoint store epName epParam epStore
  => Label epName -> epStore : store : s :-> store : s
stSetEpStore = sopSetEpStore 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
  { sopToField = toField
  , sopSetField = 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 mapLabel fieldLabel = StoreEntrypointOps
  { sopToEpLambda = \l -> toField mapLabel # pushStEp l # L.get # someStEp l
  , sopSetEpLambda = \l -> L.dip (getField mapLabel) # setStEp mapLabel l # setField mapLabel
  , sopToEpStore = \_l -> toField fieldLabel
  , sopSetEpStore = \_l -> setField 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 mapLabel fieldLabel = StoreEntrypointOps
  { sopToEpLambda = \l -> stToField mapLabel # pushStEp l # L.get # someStEp l
  , sopSetEpLambda = \l -> L.dip (stGetField mapLabel) # setStEp mapLabel l # stSetField mapLabel
  , sopToEpStore = \_l -> stToField fieldLabel
  , sopSetEpStore = \_l -> stSetField 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 mapLabel fieldLabel = StoreEntrypointOps
  { sopToEpLambda = \l -> pushStEp l # stGet mapLabel # someStEp l
  , sopSetEpLambda = \l -> setStEp mapLabel l
  , sopToEpStore = \_l -> stToField fieldLabel
  , sopSetEpStore = \_l -> stSetField 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 fieldsLabel =
  composeStoreFieldOps fieldsLabel storeFieldOpsADT 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 submapLabel =
  composeStoreSubmapOps submapLabel storeFieldOpsADT 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 fieldsLabel =
  composeStoreEntrypointOps fieldsLabel storeFieldOpsADT 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 l StoreSubmapOps{..} =
  StoreSubmapOps
  { sopMem = \_l -> sopMem l
  , sopGet = \_l -> sopGet l
  , sopUpdate = \_l -> sopUpdate l
  , sopDelete = \_l -> sopDelete l
  , sopInsert = \_l -> sopInsert 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 l StoreFieldOps{..} =
  StoreFieldOps
  { sopToField = \_l -> sopToField l
  , sopSetField = \_l -> sopSetField 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 l StoreEntrypointOps{..} = StoreEntrypointOps
  { sopToEpLambda = \_l -> sopToEpLambda l
  , sopSetEpLambda = \_l -> sopSetEpLambda l
  , sopToEpStore = \_l -> sopToEpStore l
  , sopSetEpStore = \_l -> sopSetEpStore 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{..} StoreFieldOps{..} = StoreFieldOps
  { sopToField = \l -> sopToField l # liTo
  , sopSetField = \l -> liFrom # sopSetField 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 mapper StoreSubmapOps{..} = StoreSubmapOps
  { sopMem = \l ->
      L.framed mapper # sopMem l
  , sopGet = \l ->
      L.framed mapper # sopGet l
  , sopUpdate = \l ->
      L.framed mapper # sopUpdate l
  , sopDelete = \l ->
      L.framed mapper # sopDelete l
  , sopInsert = \l ->
      L.framed mapper # sopInsert 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{..} StoreSubmapOps{..} = StoreSubmapOps
  { sopMem = \l ->
      sopMem l
  , sopGet = \l ->
      sopGet l # L.lmap liTo
  , sopUpdate = \l ->
      L.dip (L.lmap liFrom) # sopUpdate l
  , sopInsert = \l ->
      L.dip liFrom # sopInsert l
  , sopDelete = \l ->
      sopDelete 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 l1 ops1 ops2 =
  StoreFieldOps
  { sopToField = \l2 ->
      sopToField ops1 l1 # sopToField ops2 l2
  , sopSetField = \l2 ->
      L.dip (L.dup # sopToField ops1 l1) #
      sopSetField ops2 l2 #
      sopSetField ops1 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 l1 ops1 ops2 =
  StoreSubmapOps
  { sopMem = \l2 ->
      L.dip (sopToField ops1 l1) # sopMem ops2 l2
  , sopGet = \l2 ->
      L.dip (sopToField ops1 l1) # sopGet ops2 l2
  , sopUpdate = \l2 ->
      L.dip (L.dip (L.dup # sopToField ops1 l1)) #
      sopUpdate ops2 l2 #
      sopSetField ops1 l1
  , sopDelete = \l2 ->
      L.dip (L.dup # sopToField ops1 l1) #
      sopDelete ops2 l2 #
      sopSetField ops1 l1
  , sopInsert = \l2 ->
      L.dip (L.dip (L.dup # sopToField ops1 l1)) #
      sopInsert ops2 l2 #
      sopSetField ops1 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 l1 substoreIso ops1 ops2 =
  fix $ \res ->
  StoreSubmapOps
  { sopMem = \l2 ->
      L.unpair # L.swap #
      L.dip (sopGet ops1 l1) # L.swap #
      L.ifSome
        (L.swap # sopMem ops2 l2)
        (L.drop # L.push False)
  , sopGet = \l2 ->
      L.unpair # L.swap #
      L.dip (sopGet ops1 l1) # L.swap #
      L.ifSome
        (L.swap # sopGet ops2 l2)
        (L.drop # L.none)
  , sopUpdate = \l2 ->
      prepareUpdate #
      L.dip (sopUpdate ops2 l2 # liFrom substoreIso) #
      sopUpdate ops1 l1
  , sopDelete = \l2 ->
      L.dip L.none # sopUpdate res l2
  , sopInsert = \l2 ->
      prepareUpdate #
      L.dip (sopInsert ops2 l2) #
      sopInsert ops1 l1
  }
  where
    -- Extract all the necessary things prior to update
    prepareUpdate
      :: (key1, key2) : value' : store : s
         :-> key1 : key2 : value' : substore : store : s
    prepareUpdate =
      L.dup # L.car #
      L.dip
        ( L.swap #
          L.dip
            ( L.unpair # L.swap #
              L.dip
                ( L.dip (L.dup @store) #
                  sopGet ops1 l1 # liTo substoreIso
                )
            ) #
          L.swap
        )

composeStoreEntrypointOps
  :: Label nameInStore
  -> StoreFieldOps store nameInStore substore
  -> StoreEntrypointOps substore epName epParam epStore
  -> StoreEntrypointOps store epName epParam epStore
composeStoreEntrypointOps l1 ops1 ops2 = StoreEntrypointOps
  { sopToEpLambda = \l2 ->
      sopToField ops1 l1 # sopToEpLambda ops2 l2
  , sopSetEpLambda = \l2 ->
      L.dip (L.dup # sopToField ops1 l1) #
      sopSetEpLambda ops2 l2 #
      sopSetField ops1 l1
  , sopToEpStore = \l2 ->
      sopToField ops1 l1 # sopToEpStore ops2 l2
  , sopSetEpStore = \l2 ->
      L.dip (L.dup # sopToField ops1 l1) #
      sopSetEpStore ops2 l2 #
      sopSetField ops1 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 l1 valueIso subvalueIso ops1 ops2 =
  fix $ \res ->
  StoreSubmapOps
  { sopMem = \l2 ->
      sopGet ops1 l1 #
      L.ifSome
        (sopToField ops2 l2 # liFrom subvalueIso # L.isSome)
        (L.push False)
  , sopGet = \l2 ->
      sopGet ops1 l1 #
      L.ifSome
        (sopToField ops2 l2 # liFrom subvalueIso)
        L.none
  , sopUpdate = \l2 ->
      L.dip (liTo subvalueIso) #
      updateSubmapValue l2 #
      L.dip (liFrom valueIso) #
      sopUpdate ops1 l1
  , sopDelete = \l2 ->
      L.dip L.none # sopUpdate res l2
  , sopInsert = \l2 ->
      updateSubmapValue l2 #
      sopInsert ops1 l1
  }
  where
    updateSubmapValue
      :: Label nameInSubmap
      -> key : subvalue : store : s
         :-> key : value : store : s
    updateSubmapValue l2 =
      L.dup #
      L.dip
          -- First getting the existing value
        ( L.swap #
          L.dip (L.dip L.dup # sopGet ops1 l1 # liTo valueIso) #
          -- Injecting new subvalue into value
          sopSetField ops2 l2
        )

-- | Utility to 'push' the 'MText' name of and entrypoint from its 'Label'
pushStEp :: Label name -> s :-> MText : s
pushStEp = L.push . 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 l = L.ifSome L.nop $
  failUnexpected ([mt|unknown storage entrypoint: |] <> labelToMText 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 ml l = pushStEp l # stInsertNew ml failAlreadySetEp
  where
    failAlreadySetEp :: MText : s :-> any
    failAlreadySetEp =
      L.push [mt|Storage entrypoint already set: |] # L.concat # 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 l = BigMap . singleton (labelToMText 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)