{-# LANGUAGE FunctionalDependencies #-}
module Lorentz.StoreClass
(
StoreHasField (..)
, StoreFieldOps (..)
, StoreHasSubmap (..)
, StoreSubmapOps (..)
, type (~>)
, StorageContains
, stToField
, stGetField
, stSetField
, stMem
, stGet
, stUpdate
, stDelete
, stInsert
, stInsertNew
, storeFieldOpsADT
, storeFieldOpsDeeper
, storeSubmapOpsDeeper
, storeFieldOpsReferTo
, storeSubmapOpsReferTo
, composeStoreFieldOps
, composeStoreSubmapOps
) where
import Data.Vinyl.Derived (Label)
import Lorentz.ADT
import Lorentz.Base
import Lorentz.Constraints
import qualified Lorentz.Instr as L
import qualified Lorentz.Macro as L
import Lorentz.Value
import Michelson.Typed.Haskell
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
}
class StoreHasField store fname ftype | store fname -> ftype where
storeFieldOps :: StoreFieldOps store fname ftype
stToField
:: StoreHasField store fname ftype
=> Label fname -> store : s :-> ftype : s
stToField = sopToField storeFieldOps
stGetField
:: StoreHasField store fname ftype
=> Label fname -> store : s :-> ftype : store : s
stGetField l = L.dup # sopToField storeFieldOps l
stSetField
:: StoreHasField store fname ftype
=> Label fname -> ftype : store : s :-> store : s
stSetField = sopSetField storeFieldOps
data StoreSubmapOps store mname key value = StoreSubmapOps
{ sopMem
:: forall s.
Label mname -> key : store : s :-> Bool : s
, sopGet
:: forall s.
Label mname -> key : store : s :-> Maybe value : s
, sopUpdate
:: forall s.
Label mname -> key : Maybe value : store : s :-> store : s
, sopDelete
:: forall s.
Maybe (Label mname -> key : store : s :-> store : s)
, sopInsert
:: forall s.
Maybe (Label mname -> key : value : store : s :-> store : s)
}
class StoreHasSubmap store mname key value | store mname -> key value where
storeSubmapOps :: StoreSubmapOps store mname key value
stMem
:: StoreHasSubmap store mname key value
=> Label mname -> key : store : s :-> Bool : s
stMem = sopMem storeSubmapOps
stGet
:: StoreHasSubmap store mname key value
=> Label mname -> key : store : s :-> Maybe value : s
stGet = sopGet storeSubmapOps
stUpdate
:: StoreHasSubmap store mname key value
=> Label mname -> key : Maybe value : store : s :-> store : s
stUpdate = sopUpdate storeSubmapOps
stDelete
:: forall store mname key value s.
(StoreHasSubmap store mname key value, KnownValue value)
=> Label mname -> key : store : s :-> store : s
stDelete l = case sopDelete storeSubmapOps of
Just delOp -> delOp l
Nothing -> L.dip L.none # stUpdate l
stInsert
:: StoreHasSubmap store mname key value
=> Label mname -> key : value : store : s :-> store : s
stInsert l = case sopInsert storeSubmapOps of
Just insOp -> insOp l
Nothing -> L.dip L.some # stUpdate l
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)
instance (key ~ key', value ~ value', IsComparable key) =>
StoreHasSubmap (BigMap key' value') name key value where
storeSubmapOps = StoreSubmapOps
{ sopMem = \_label -> L.mem
, sopGet = \_label -> L.get
, sopUpdate = \_label -> L.update
, sopDelete = Nothing
, sopInsert = Nothing
}
instance (key ~ key', value ~ value', IsComparable key) =>
StoreHasSubmap (Map key' value') name key value where
storeSubmapOps = StoreSubmapOps
{ sopMem = \_label -> L.mem
, sopGet = \_label -> L.get
, sopUpdate = \_label -> L.update
, sopDelete = Nothing
, sopInsert = Nothing
}
storeFieldOpsADT
:: HasFieldOfType dt fname ftype
=> StoreFieldOps dt fname ftype
storeFieldOpsADT = StoreFieldOps
{ sopToField = toField
, sopSetField = setField
}
storeFieldOpsDeeper
:: ( HasFieldOfType storage fieldsPartName fields
, StoreHasField fields fname ftype
)
=> Label fieldsPartName
-> StoreFieldOps storage fname ftype
storeFieldOpsDeeper fieldsLabel =
composeStoreFieldOps fieldsLabel storeFieldOpsADT storeFieldOps
storeSubmapOpsDeeper
:: ( HasFieldOfType storage bigMapPartName fields
, StoreHasSubmap fields mname key value
)
=> Label bigMapPartName
-> StoreSubmapOps storage mname key value
storeSubmapOpsDeeper submapLabel =
composeStoreSubmapOps submapLabel storeFieldOpsADT storeSubmapOps
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 = (\op _l -> op l) <$> sopDelete
, sopInsert = (\op _l -> op l) <$> sopInsert
}
storeFieldOpsReferTo
:: Label name
-> StoreFieldOps storage name field
-> StoreFieldOps storage desiredName field
storeFieldOpsReferTo l StoreFieldOps{..} =
StoreFieldOps
{ sopToField = \_l -> sopToField l
, sopSetField = \_l -> sopSetField l
}
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
}
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 = case sopDelete ops2 of
Nothing -> Nothing
Just delOp -> Just $ \l2 ->
L.dip (L.dup # sopToField ops1 l1) #
delOp l2 #
sopSetField ops1 l1
, sopInsert = case sopInsert ops2 of
Nothing -> Nothing
Just insOp -> Just $ \l2 ->
L.dip (L.dip (L.dup # sopToField ops1 l1)) #
insOp l2 #
sopSetField ops1 l1
}
data k ~> v
infix 9 ~>
type family StorageContains store (content :: [NamedField]) :: Constraint where
StorageContains _ '[] = ()
StorageContains store ((n := k ~> v) ': ct) =
(StoreHasSubmap store n k v, StorageContains store ct)
StorageContains store ((n := ty) ': ct) =
(StoreHasField store n ty, StorageContains store ct)