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
, genUStoreSubMap
, genUStoreFieldExt
) where
import Control.Lens (Wrapped)
import qualified Data.Kind as Kind
import GHC.Generics ((:*:)(..), (:+:)(..))
import qualified GHC.Generics as G
import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)
import Hedgehog (MonadGen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.QuickCheck (Arbitrary)
import Lorentz.Pack
import Lorentz.TypeAnns (HasTypeAnn)
import Lorentz.Polymorphic
import Lorentz.Value
import Michelson.Test.Util (genTuple2)
import Michelson.Text (labelToMText)
import Michelson.Typed.T
import Util.Type
newtype UStore (a :: Kind.Type) = UStore
{ UStore a -> BigMap ByteString ByteString
unUStore :: BigMap ByteString ByteString
} deriving stock (UStore a -> UStore a -> Bool
(UStore a -> UStore a -> Bool)
-> (UStore a -> UStore a -> Bool) -> Eq (UStore a)
forall a. UStore a -> UStore a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UStore a -> UStore a -> Bool
$c/= :: forall a. UStore a -> UStore a -> Bool
== :: UStore a -> UStore a -> Bool
$c== :: forall a. UStore a -> UStore a -> Bool
Eq, Int -> UStore a -> ShowS
[UStore a] -> ShowS
UStore a -> String
(Int -> UStore a -> ShowS)
-> (UStore a -> String) -> ([UStore a] -> ShowS) -> Show (UStore a)
forall a. Int -> UStore a -> ShowS
forall a. [UStore a] -> ShowS
forall a. UStore a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UStore a] -> ShowS
$cshowList :: forall a. [UStore a] -> ShowS
show :: UStore a -> String
$cshow :: forall a. UStore a -> String
showsPrec :: Int -> UStore a -> ShowS
$cshowsPrec :: forall a. Int -> UStore a -> ShowS
Show, (forall x. UStore a -> Rep (UStore a) x)
-> (forall x. Rep (UStore a) x -> UStore a) -> Generic (UStore a)
forall x. Rep (UStore a) x -> UStore a
forall x. UStore a -> Rep (UStore a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (UStore a) x -> UStore a
forall a x. UStore a -> Rep (UStore a) x
$cto :: forall a x. Rep (UStore a) x -> UStore a
$cfrom :: forall a x. UStore a -> Rep (UStore a) x
Generic)
deriving newtype (UStore a
UStore a -> Default (UStore a)
forall a. UStore a
forall a. a -> Default a
def :: UStore a
$cdef :: forall a. UStore a
Default, b -> UStore a -> UStore a
NonEmpty (UStore a) -> UStore a
UStore a -> UStore a -> UStore a
(UStore a -> UStore a -> UStore a)
-> (NonEmpty (UStore a) -> UStore a)
-> (forall b. Integral b => b -> UStore a -> UStore a)
-> Semigroup (UStore a)
forall b. Integral b => b -> UStore a -> UStore a
forall a. NonEmpty (UStore a) -> UStore a
forall a. UStore a -> UStore a -> UStore a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> UStore a -> UStore a
stimes :: b -> UStore a -> UStore a
$cstimes :: forall a b. Integral b => b -> UStore a -> UStore a
sconcat :: NonEmpty (UStore a) -> UStore a
$csconcat :: forall a. NonEmpty (UStore a) -> UStore a
<> :: UStore a -> UStore a -> UStore a
$c<> :: forall a. UStore a -> UStore a -> UStore a
Semigroup, Semigroup (UStore a)
UStore a
Semigroup (UStore a) =>
UStore a
-> (UStore a -> UStore a -> UStore a)
-> ([UStore a] -> UStore a)
-> Monoid (UStore a)
[UStore a] -> UStore a
UStore a -> UStore a -> UStore a
forall a. Semigroup (UStore a)
forall a. UStore a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [UStore a] -> UStore a
forall a. UStore a -> UStore a -> UStore a
mconcat :: [UStore a] -> UStore a
$cmconcat :: forall a. [UStore a] -> UStore a
mappend :: UStore a -> UStore a -> UStore a
$cmappend :: forall a. UStore a -> UStore a -> UStore a
mempty :: UStore a
$cmempty :: forall a. UStore a
$cp1Monoid :: forall a. Semigroup (UStore a)
Monoid, WellTypedToT (UStore a)
WellTypedToT (UStore a) =>
(UStore a -> Value (ToT (UStore a)))
-> (Value (ToT (UStore a)) -> UStore a) -> IsoValue (UStore a)
Value (ToT (UStore a)) -> UStore a
UStore a -> Value (ToT (UStore a))
forall a. WellTypedToT (UStore a)
forall a.
WellTypedToT a =>
(a -> Value (ToT a)) -> (Value (ToT a) -> a) -> IsoValue a
forall a. Value (ToT (UStore a)) -> UStore a
forall a. UStore a -> Value (ToT (UStore a))
fromVal :: Value (ToT (UStore a)) -> UStore a
$cfromVal :: forall a. Value (ToT (UStore a)) -> UStore a
toVal :: UStore a -> Value (ToT (UStore a))
$ctoVal :: forall a. UStore a -> Value (ToT (UStore a))
$cp1IsoValue :: forall a. WellTypedToT (UStore a)
IsoValue,
ToT (MemOpKeyHs (UStore a)) ~ MemOpKey (ToT (UStore a))
MemOp (ToT (UStore a))
(MemOp (ToT (UStore a)),
ToT (MemOpKeyHs (UStore a)) ~ MemOpKey (ToT (UStore a))) =>
MemOpHs (UStore a)
forall a. ToT (MemOpKeyHs (UStore a)) ~ MemOpKey (ToT (UStore a))
forall a. MemOp (ToT (UStore a))
forall c.
(MemOp (ToT c), ToT (MemOpKeyHs c) ~ MemOpKey (ToT c)) =>
MemOpHs c
$cp2MemOpHs :: forall a. ToT (MemOpKeyHs (UStore a)) ~ MemOpKey (ToT (UStore a))
$cp1MemOpHs :: forall a. MemOp (ToT (UStore a))
MemOpHs, ToT (GetOpKeyHs (UStore a)) ~ GetOpKey (ToT (UStore a))
ToT (GetOpValHs (UStore a)) ~ GetOpVal (ToT (UStore a))
GetOp (ToT (UStore a))
(GetOp (ToT (UStore a)),
ToT (GetOpKeyHs (UStore a)) ~ GetOpKey (ToT (UStore a)),
ToT (GetOpValHs (UStore a)) ~ GetOpVal (ToT (UStore a))) =>
GetOpHs (UStore a)
forall a. ToT (GetOpKeyHs (UStore a)) ~ GetOpKey (ToT (UStore a))
forall a. ToT (GetOpValHs (UStore a)) ~ GetOpVal (ToT (UStore a))
forall a. GetOp (ToT (UStore a))
forall c.
(GetOp (ToT c), ToT (GetOpKeyHs c) ~ GetOpKey (ToT c),
ToT (GetOpValHs c) ~ GetOpVal (ToT c)) =>
GetOpHs c
$cp3GetOpHs :: forall a. ToT (GetOpValHs (UStore a)) ~ GetOpVal (ToT (UStore a))
$cp2GetOpHs :: forall a. ToT (GetOpKeyHs (UStore a)) ~ GetOpKey (ToT (UStore a))
$cp1GetOpHs :: forall a. GetOp (ToT (UStore a))
GetOpHs, ToT (UpdOpKeyHs (UStore a)) ~ UpdOpKey (ToT (UStore a))
ToT (UpdOpParamsHs (UStore a)) ~ UpdOpParams (ToT (UStore a))
UpdOp (ToT (UStore a))
(UpdOp (ToT (UStore a)),
ToT (UpdOpKeyHs (UStore a)) ~ UpdOpKey (ToT (UStore a)),
ToT (UpdOpParamsHs (UStore a)) ~ UpdOpParams (ToT (UStore a))) =>
UpdOpHs (UStore a)
forall a. ToT (UpdOpKeyHs (UStore a)) ~ UpdOpKey (ToT (UStore a))
forall a.
ToT (UpdOpParamsHs (UStore a)) ~ UpdOpParams (ToT (UStore a))
forall a. UpdOp (ToT (UStore a))
forall c.
(UpdOp (ToT c), ToT (UpdOpKeyHs c) ~ UpdOpKey (ToT c),
ToT (UpdOpParamsHs c) ~ UpdOpParams (ToT c)) =>
UpdOpHs c
$cp3UpdOpHs :: forall a.
ToT (UpdOpParamsHs (UStore a)) ~ UpdOpParams (ToT (UStore a))
$cp2UpdOpHs :: forall a. ToT (UpdOpKeyHs (UStore a)) ~ UpdOpKey (ToT (UStore a))
$cp1UpdOpHs :: forall a. UpdOp (ToT (UStore a))
UpdOpHs)
deriving anyclass Notes (ToT (UStore a))
Notes (ToT (UStore a)) -> HasTypeAnn (UStore a)
forall a. Notes (ToT (UStore a))
forall a. Notes (ToT a) -> HasTypeAnn a
getTypeAnn :: Notes (ToT (UStore a))
$cgetTypeAnn :: forall a. Notes (ToT (UStore a))
HasTypeAnn
instance Wrapped (UStore a)
newtype k |~> v = UStoreSubMap { (k |~> v) -> Map k v
unUStoreSubMap :: Map k v }
deriving stock (Int -> (k |~> v) -> ShowS
[k |~> v] -> ShowS
(k |~> v) -> String
(Int -> (k |~> v) -> ShowS)
-> ((k |~> v) -> String) -> ([k |~> v] -> ShowS) -> Show (k |~> v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k v. (Show k, Show v) => Int -> (k |~> v) -> ShowS
forall k v. (Show k, Show v) => [k |~> v] -> ShowS
forall k v. (Show k, Show v) => (k |~> v) -> String
showList :: [k |~> v] -> ShowS
$cshowList :: forall k v. (Show k, Show v) => [k |~> v] -> ShowS
show :: (k |~> v) -> String
$cshow :: forall k v. (Show k, Show v) => (k |~> v) -> String
showsPrec :: Int -> (k |~> v) -> ShowS
$cshowsPrec :: forall k v. (Show k, Show v) => Int -> (k |~> v) -> ShowS
Show, (k |~> v) -> (k |~> v) -> Bool
((k |~> v) -> (k |~> v) -> Bool)
-> ((k |~> v) -> (k |~> v) -> Bool) -> Eq (k |~> v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k v. (Eq k, Eq v) => (k |~> v) -> (k |~> v) -> Bool
/= :: (k |~> v) -> (k |~> v) -> Bool
$c/= :: forall k v. (Eq k, Eq v) => (k |~> v) -> (k |~> v) -> Bool
== :: (k |~> v) -> (k |~> v) -> Bool
$c== :: forall k v. (Eq k, Eq v) => (k |~> v) -> (k |~> v) -> Bool
Eq)
deriving newtype (k |~> v
(k |~> v) -> Default (k |~> v)
forall a. a -> Default a
forall k v. k |~> v
def :: k |~> v
$cdef :: forall k v. k |~> v
Default, Gen (k |~> v)
Gen (k |~> v) -> ((k |~> v) -> [k |~> v]) -> Arbitrary (k |~> v)
(k |~> v) -> [k |~> v]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
forall k v. (Ord k, Arbitrary k, Arbitrary v) => Gen (k |~> v)
forall k v.
(Ord k, Arbitrary k, Arbitrary v) =>
(k |~> v) -> [k |~> v]
shrink :: (k |~> v) -> [k |~> v]
$cshrink :: forall k v.
(Ord k, Arbitrary k, Arbitrary v) =>
(k |~> v) -> [k |~> v]
arbitrary :: Gen (k |~> v)
$carbitrary :: forall k v. (Ord k, Arbitrary k, Arbitrary v) => Gen (k |~> v)
Arbitrary)
newtype UStoreFieldExt (m :: UStoreMarkerType) (v :: Kind.Type) = UStoreField { UStoreFieldExt m v -> v
unUStoreField :: v }
deriving stock (Int -> UStoreFieldExt m v -> ShowS
[UStoreFieldExt m v] -> ShowS
UStoreFieldExt m v -> String
(Int -> UStoreFieldExt m v -> ShowS)
-> (UStoreFieldExt m v -> String)
-> ([UStoreFieldExt m v] -> ShowS)
-> Show (UStoreFieldExt m v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (m :: UStoreMarkerType) v.
Show v =>
Int -> UStoreFieldExt m v -> ShowS
forall (m :: UStoreMarkerType) v.
Show v =>
[UStoreFieldExt m v] -> ShowS
forall (m :: UStoreMarkerType) v.
Show v =>
UStoreFieldExt m v -> String
showList :: [UStoreFieldExt m v] -> ShowS
$cshowList :: forall (m :: UStoreMarkerType) v.
Show v =>
[UStoreFieldExt m v] -> ShowS
show :: UStoreFieldExt m v -> String
$cshow :: forall (m :: UStoreMarkerType) v.
Show v =>
UStoreFieldExt m v -> String
showsPrec :: Int -> UStoreFieldExt m v -> ShowS
$cshowsPrec :: forall (m :: UStoreMarkerType) v.
Show v =>
Int -> UStoreFieldExt m v -> ShowS
Show, UStoreFieldExt m v -> UStoreFieldExt m v -> Bool
(UStoreFieldExt m v -> UStoreFieldExt m v -> Bool)
-> (UStoreFieldExt m v -> UStoreFieldExt m v -> Bool)
-> Eq (UStoreFieldExt m v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (m :: UStoreMarkerType) v.
Eq v =>
UStoreFieldExt m v -> UStoreFieldExt m v -> Bool
/= :: UStoreFieldExt m v -> UStoreFieldExt m v -> Bool
$c/= :: forall (m :: UStoreMarkerType) v.
Eq v =>
UStoreFieldExt m v -> UStoreFieldExt m v -> Bool
== :: UStoreFieldExt m v -> UStoreFieldExt m v -> Bool
$c== :: forall (m :: UStoreMarkerType) v.
Eq v =>
UStoreFieldExt m v -> UStoreFieldExt m v -> Bool
Eq)
deriving newtype Gen (UStoreFieldExt m v)
Gen (UStoreFieldExt m v)
-> (UStoreFieldExt m v -> [UStoreFieldExt m v])
-> Arbitrary (UStoreFieldExt m v)
UStoreFieldExt m v -> [UStoreFieldExt m v]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
forall (m :: UStoreMarkerType) v.
Arbitrary v =>
Gen (UStoreFieldExt m v)
forall (m :: UStoreMarkerType) v.
Arbitrary v =>
UStoreFieldExt m v -> [UStoreFieldExt m v]
shrink :: UStoreFieldExt m v -> [UStoreFieldExt m v]
$cshrink :: forall (m :: UStoreMarkerType) v.
Arbitrary v =>
UStoreFieldExt m v -> [UStoreFieldExt m v]
arbitrary :: Gen (UStoreFieldExt m v)
$carbitrary :: forall (m :: UStoreMarkerType) v.
Arbitrary v =>
Gen (UStoreFieldExt m v)
Arbitrary
data
type = UStoreMarker -> Kind.Type
type UStoreField = UStoreFieldExt UMarkerPlainField
data UMarkerPlainField :: UStoreMarkerType
type UStoreSubmapKey k = (MText, k)
type UStoreSubmapKeyT k = 'TPair (ToT MText) k
class (marker :: UStoreMarkerType) where
mkFieldMarkerUKey :: MText -> ByteString
default mkFieldMarkerUKey :: MText -> ByteString
mkFieldMarkerUKey = MText -> ByteString
forall a. NicePackedValue a => a -> ByteString
lPackValue
type ShowUStoreField marker v :: ErrorMessage
type ShowUStoreField marker v = 'Text "field of type " ':<>: 'ShowType v
mkFieldMarkerUKeyL
:: forall marker field.
KnownUStoreMarker marker
=> Label field -> ByteString
mkFieldMarkerUKeyL :: Label field -> ByteString
mkFieldMarkerUKeyL label :: Label field
label =
MText -> ByteString
forall (marker :: UStoreMarkerType).
KnownUStoreMarker marker =>
MText -> ByteString
mkFieldMarkerUKey @marker (Label field -> MText
forall (name :: Symbol). Label name -> MText
labelToMText Label field
label)
mkFieldUKey
:: forall (store :: Kind.Type) field.
KnownUStoreMarker (GetUStoreFieldMarker store field)
=> Label field -> ByteString
mkFieldUKey :: Label field -> ByteString
mkFieldUKey = forall (field :: Symbol).
KnownUStoreMarker (GetUStoreFieldMarker store field) =>
Label field -> ByteString
forall (marker :: UStoreMarkerType) (field :: Symbol).
KnownUStoreMarker marker =>
Label field -> ByteString
mkFieldMarkerUKeyL @(GetUStoreFieldMarker store field)
instance KnownUStoreMarker UMarkerPlainField where
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
FSMarker ('FieldSignature m _) = m
FSMarker ('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
genUStoreSubMap :: (MonadGen m, Ord k) => m k -> m v -> m (k |~> v)
genUStoreSubMap :: m k -> m v -> m (k |~> v)
genUStoreSubMap genK :: m k
genK genV :: m v
genV = Map k v -> k |~> v
forall k v. Map k v -> k |~> v
UStoreSubMap (Map k v -> k |~> v) -> m (Map k v) -> m (k |~> v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int -> m (k, v) -> m (Map k v)
forall (m :: * -> *) k v.
(MonadGen m, Ord k) =>
Range Int -> m (k, v) -> m (Map k v)
Gen.map (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear 0 100) (m k -> m v -> m (k, v)
forall (m :: * -> *) a b. MonadGen m => m a -> m b -> m (a, b)
genTuple2 m k
genK m v
genV)
genUStoreFieldExt :: MonadGen m => m v -> m (UStoreFieldExt marker v)
genUStoreFieldExt :: m v -> m (UStoreFieldExt marker v)
genUStoreFieldExt genV :: m v
genV = v -> UStoreFieldExt marker v
forall (m :: UStoreMarkerType) v. v -> UStoreFieldExt m v
UStoreField (v -> UStoreFieldExt marker v)
-> m v -> m (UStoreFieldExt marker v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m v
genV