module Lorentz.UStore.Types
(
UStore (..)
, type (|~>)(..)
, UStoreFieldExt (..)
, UStoreField
, UStoreMarkerType
, UMarkerPlainField
, KnownUStoreMarker (..)
, mkFieldMarkerUKeyL
, mkFieldUKey
, UStoreSubmapKey
, UStoreSubmapKeyT
, GetUStoreKey
, GetUStoreValue
, GetUStoreField
, GetUStoreFieldMarker
, PickMarkedFields
, ElemSignature (..)
, GetUStore
, MSKey
, MSValue
, FSValue
, FSMarker
) where
import Data.Default (Default)
import Control.Lens (Wrapped)
import Data.Vinyl.Derived (Label)
import qualified Data.Kind as Kind
import Data.Type.Equality (type (==))
import GHC.Generics ((:*:)(..), (:+:)(..))
import qualified GHC.Generics as G
import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError, KnownSymbol)
import Test.QuickCheck (Arbitrary)
import Lorentz.Pack
import Lorentz.Doc
import Lorentz.Polymorphic
import Michelson.Typed.T
import Michelson.Typed.Haskell.Value
import Lorentz.UStore.Common
import Lorentz.Value
import Util.Type
newtype UStore (a :: Kind.Type) = UStore
{ unUStore :: BigMap ByteString ByteString
} deriving stock (Eq, Show, Generic)
deriving newtype (Default, Semigroup, Monoid, IsoValue,
MemOpHs, GetOpHs, UpdOpHs)
instance Wrapped (UStore a)
newtype k |~> v = UStoreSubMap { unUStoreSubMap :: Map k v }
deriving stock (Show, Eq)
deriving newtype (Default, Arbitrary)
newtype UStoreFieldExt (m :: UStoreMarkerType) (v :: Kind.Type) = UStoreField { unUStoreField :: v }
deriving stock (Show, Eq)
deriving newtype Arbitrary
data UStoreMarker
type UStoreMarkerType = UStoreMarker -> Kind.Type
type UStoreField = UStoreFieldExt UMarkerPlainField
data UMarkerPlainField :: UStoreMarkerType
instance Typeable template => TypeHasDoc (UStore template) where
typeDocName _ = "Upgradeable storage"
typeDocMdDescription =
"Storage with not hardcoded structure, which allows upgrading the contract \
\in place. UStore is capable of storing simple fields and multiple submaps. \
\For simple fields key is serialized field name. For submap element big_map \
\key is serialized `(submapName, keyValue)`."
typeDocMdReference tp =
customTypeDocMdReference ("UStore", DType tp) []
typeDocHaskellRep = homomorphicTypeDocHaskellRep
typeDocMichelsonRep = homomorphicTypeDocMichelsonRep
type UStoreSubmapKey k = (MText, k)
type UStoreSubmapKeyT k = 'TPair (ToT MText) k
class KnownUStoreMarker (marker :: UStoreMarkerType) where
mkFieldMarkerUKey :: MText -> ByteString
default mkFieldMarkerUKey :: MText -> ByteString
mkFieldMarkerUKey = lPackValue
type ShowUStoreField marker v :: ErrorMessage
type ShowUStoreField marker v = 'Text "field of type " ':<>: 'ShowType v
mkFieldMarkerUKeyL
:: forall marker field.
(KnownUStoreMarker marker, KnownSymbol field)
=> Label field -> ByteString
mkFieldMarkerUKeyL _ =
mkFieldMarkerUKey @marker (fieldNameToMText @field)
mkFieldUKey
:: forall (store :: Kind.Type) field.
(KnownSymbol field, KnownUStoreMarker (GetUStoreFieldMarker store field))
=> Label field -> ByteString
mkFieldUKey = mkFieldMarkerUKeyL @(GetUStoreFieldMarker store field)
instance KnownUStoreMarker UMarkerPlainField where
data ElemSignature
= MapSignature Kind.Type Kind.Type
| FieldSignature UStoreMarkerType Kind.Type
type family MSKey (ms :: ElemSignature) :: Kind.Type where
MSKey ('MapSignature k _) = k
MSKey ('FieldSignature _ _) =
TypeError ('Text "Expected UStore submap, but field was referred")
type family MSValue (ms :: ElemSignature) :: Kind.Type where
MSValue ('MapSignature _ v) = v
MSValue ('FieldSignature _ _) =
TypeError ('Text "Expected UStore submap, but field was referred")
type family FSValue (ms :: ElemSignature) :: Kind.Type where
FSValue ('FieldSignature _ v) = v
FSValue ('MapSignature _ _) =
TypeError ('Text "Expected UStore field, but submap was referred")
type family FSMarker (ms :: ElemSignature) :: UStoreMarkerType where
FSValue ('FieldSignature m _) = m
FSValue ('MapSignature _ _) =
TypeError ('Text "Expected UStore field, but submap was referred")
type GetUStore name a = MERequireFound name a (GLookupStore name (G.Rep a))
type family MERequireFound
(name :: Symbol)
(a :: Kind.Type)
(mlr :: Maybe ElemSignature)
:: ElemSignature where
MERequireFound _ _ ('Just ms) = ms
MERequireFound name a 'Nothing = TypeError
('Text "Failed to find plain field or submap in store template: datatype `"
':<>: 'ShowType a ':<>: 'Text "` has no field " ':<>: 'ShowType name)
type family GLookupStore (name :: Symbol) (x :: Kind.Type -> Kind.Type)
:: Maybe ElemSignature where
GLookupStore name (G.D1 _ x) = GLookupStore name x
GLookupStore _ (_ :+: _) =
TypeError ('Text "Templates used in UStore should have only one constructor")
GLookupStore _ G.V1 =
TypeError ('Text "No constructors in UStore template")
GLookupStore name (G.C1 _ x) = GLookupStore name x
GLookupStore name (x :*: y) = LSMergeFound name (GLookupStore name x)
(GLookupStore name y)
GLookupStore name (G.S1 ('G.MetaSel mFieldName _ _ _) (G.Rec0 (k |~> v))) =
Guard ('Just name == mFieldName) ('MapSignature k v)
GLookupStore name (G.S1 ('G.MetaSel mFieldName _ _ _) (G.Rec0 (UStoreFieldExt m v))) =
Guard ('Just name == mFieldName) ('FieldSignature m v)
GLookupStore name (G.S1 _ (G.Rec0 a)) =
GLookupStore name (G.Rep a)
GLookupStore _ G.U1 = 'Nothing
type family LSMergeFound (name :: Symbol)
(f1 :: Maybe ElemSignature) (f2 :: Maybe ElemSignature)
:: Maybe ElemSignature where
LSMergeFound _ 'Nothing 'Nothing = 'Nothing
LSMergeFound _ ('Just ms) 'Nothing = 'Just ms
LSMergeFound _ 'Nothing ('Just ms) = 'Just ms
LSMergeFound ctor ('Just _) ('Just _) = TypeError
('Text "Found more than one constructor matching " ':<>: 'ShowType ctor)
type GetUStoreKey store name = MSKey (GetUStore name store)
type GetUStoreValue store name = MSValue (GetUStore name store)
type GetUStoreField store name = FSValue (GetUStore name store)
type GetUStoreFieldMarker store name = FSMarker (GetUStore name store)
type PickMarkedFields marker template = GPickMarkedFields marker (G.Rep template)
type family GPickMarkedFields (marker :: UStoreMarkerType) (x :: Kind.Type -> Kind.Type)
:: [(Symbol, Kind.Type)] where
GPickMarkedFields m (G.D1 _ x) = GPickMarkedFields m x
GPickMarkedFields m (G.C1 _ x) = GPickMarkedFields m x
GPickMarkedFields m (x :*: y) = GPickMarkedFields m x ++ GPickMarkedFields m y
GPickMarkedFields _ G.U1 = '[]
GPickMarkedFields m (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) (G.Rec0 (UStoreFieldExt m v))) =
'[ '(fieldName, v) ]
GPickMarkedFields _ (G.S1 _ (G.Rec0 (UStoreFieldExt _ _))) =
'[]
GPickMarkedFields _ (G.S1 _ (G.Rec0 (_ |~> _))) =
'[]
GPickMarkedFields m (G.S1 _ (G.Rec0 a)) =
PickMarkedFields m a