module Indigo.Common.Field
( AccessFieldC
, fetchField
, assignField
, FieldLens (..)
, flSFO
, HasField (..)
, fieldLensDeeper
, fieldLensADT
) where
import Data.Vinyl (RElem)
import Data.Vinyl.Lens (rget, rput)
import Data.Vinyl.TypeLevel (RIndex)
import GHC.TypeLits (KnownSymbol)
import Indigo.Lorentz
import Indigo.Prelude
import Lorentz.ADT qualified as L
import Morley.Michelson.Typed.Haskell.Instr.Product
(ConstructorFieldNames, GetFieldType, InstrGetFieldC, InstrSetFieldC)
type AccessFieldC a name =
RElem name (ConstructorFieldNames a) (RIndex name (ConstructorFieldNames a))
fetchField
:: forall a name f proxy . AccessFieldC a name
=> proxy name -> Rec f (ConstructorFieldNames a) -> f name
fetchField :: forall a (name :: Symbol) (f :: Symbol -> *)
(proxy :: Symbol -> *).
AccessFieldC a name =>
proxy name -> Rec f (ConstructorFieldNames a) -> f name
fetchField proxy name
_ = forall {k} (r :: k) (rs :: [k]) (f :: k -> *)
(record :: (k -> *) -> [k] -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
record f rs -> f r
forall (r :: Symbol) (rs :: [Symbol]) (f :: Symbol -> *)
(record :: (Symbol -> *) -> [Symbol] -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
record f rs -> f r
rget @name
assignField
:: forall a name f proxy . AccessFieldC a name
=> proxy name -> f name -> Rec f (ConstructorFieldNames a) -> Rec f (ConstructorFieldNames a)
assignField :: forall a (name :: Symbol) (f :: Symbol -> *)
(proxy :: Symbol -> *).
AccessFieldC a name =>
proxy name
-> f name
-> Rec f (ConstructorFieldNames a)
-> Rec f (ConstructorFieldNames a)
assignField proxy name
_ = forall k (r :: k) (rs :: [k]) (record :: (k -> *) -> [k] -> *)
(f :: k -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
f r -> record f rs -> record f rs
rput @_ @name
data FieldLens dt fname ftype where
TargetField
:: ( InstrGetFieldC dt fname
, InstrSetFieldC dt fname
, GetFieldType dt fname ~ targetFType
, AccessFieldC dt fname
)
=> Label fname
-> StoreFieldOps dt targetFName targetFType
-> FieldLens dt targetFName targetFType
DeeperField
:: ( AccessFieldC dt fname
, InstrSetFieldC dt fname
, HasField (GetFieldType dt fname) targetFName targetFType
)
=> Label fname
-> StoreFieldOps dt targetFName targetFType
-> FieldLens dt targetFName targetFType
flSFO :: FieldLens dt fname ftype -> StoreFieldOps dt fname ftype
flSFO :: forall {k} dt (fname :: k) ftype.
FieldLens dt fname ftype -> StoreFieldOps dt fname ftype
flSFO (TargetField Label fname
_ StoreFieldOps dt fname ftype
sfo) = StoreFieldOps dt fname ftype
sfo
flSFO (DeeperField Label fname
_ StoreFieldOps dt fname ftype
sfo) = StoreFieldOps dt fname ftype
sfo
class (KnownValue ftype, KnownValue dt) => HasField dt fname ftype | dt fname -> ftype where
fieldLens :: FieldLens dt fname ftype
fieldLensADT
:: forall dt targetFName targetFType fname .
( InstrGetFieldC dt fname
, InstrSetFieldC dt fname
, GetFieldType dt fname ~ targetFType
, AccessFieldC dt fname
)
=> Label fname -> FieldLens dt targetFName targetFType
fieldLensADT :: forall {k} dt (targetFName :: k) targetFType (fname :: Symbol).
(InstrGetFieldC dt fname, InstrSetFieldC dt fname,
GetFieldType dt fname ~ targetFType, AccessFieldC dt fname) =>
Label fname -> FieldLens dt targetFName targetFType
fieldLensADT Label fname
lb =
let sfo :: StoreFieldOps dt fname targetFType
sfo = forall dt (fname :: Symbol) ftype.
HasFieldOfType dt fname ftype =>
StoreFieldOps dt fname ftype
storeFieldOpsADT @dt @fname in
Label fname
-> StoreFieldOps dt targetFName targetFType
-> FieldLens dt targetFName targetFType
forall {k} dt (fname :: Symbol) targetFType (targetFName :: k).
(InstrGetFieldC dt fname, InstrSetFieldC dt fname,
GetFieldType dt fname ~ targetFType, AccessFieldC dt fname) =>
Label fname
-> StoreFieldOps dt targetFName targetFType
-> FieldLens dt targetFName targetFType
TargetField Label fname
lb (StoreFieldOps dt targetFName targetFType
-> FieldLens dt targetFName targetFType)
-> StoreFieldOps dt targetFName targetFType
-> FieldLens dt targetFName targetFType
forall a b. (a -> b) -> a -> b
$ FieldRef fname
-> StoreFieldOps dt fname targetFType
-> StoreFieldOps dt targetFName targetFType
forall {k1} {k2} (name :: k1) storage field (desiredName :: k2).
FieldRef name
-> StoreFieldOps storage name field
-> StoreFieldOps storage desiredName field
storeFieldOpsReferTo (Label fname -> FieldRef fname
forall (n :: Symbol). Label n -> FieldSymRef n
fieldNameFromLabel Label fname
lb) StoreFieldOps dt fname targetFType
sfo
fieldLensDeeper
:: forall dt targetName targetType fname .
( AccessFieldC dt fname
, L.HasFieldOfType dt fname (GetFieldType dt fname)
, HasDupableGetters (GetFieldType dt fname)
, HasField (GetFieldType dt fname) targetName targetType
)
=> Label fname
-> FieldLens dt targetName targetType
fieldLensDeeper :: forall {k} dt (targetName :: k) targetType (fname :: Symbol).
(AccessFieldC dt fname,
HasFieldOfType dt fname (GetFieldType dt fname),
HasDupableGetters (GetFieldType dt fname),
HasField (GetFieldType dt fname) targetName targetType) =>
Label fname -> FieldLens dt targetName targetType
fieldLensDeeper Label fname
lb =
Label fname
-> StoreFieldOps dt targetName targetType
-> FieldLens dt targetName targetType
forall {k} dt (fname :: Symbol) (targetFName :: k) targetFType.
(AccessFieldC dt fname, InstrSetFieldC dt fname,
HasField (GetFieldType dt fname) targetFName targetFType) =>
Label fname
-> StoreFieldOps dt targetFName targetFType
-> FieldLens dt targetFName targetFType
DeeperField Label fname
lb (StoreFieldOps dt targetName targetType
-> FieldLens dt targetName targetType)
-> StoreFieldOps dt targetName targetType
-> FieldLens dt targetName targetType
forall a b. (a -> b) -> a -> b
$
FieldRef fname
-> StoreFieldOps dt fname (GetFieldType dt fname)
-> StoreFieldOps (GetFieldType dt fname) targetName targetType
-> StoreFieldOps dt targetName targetType
forall {k1} {k2} substore (nameInStore :: k1) store
(nameInSubstore :: k2) field.
HasDupableGetters substore =>
FieldRef nameInStore
-> StoreFieldOps store nameInStore substore
-> StoreFieldOps substore nameInSubstore field
-> StoreFieldOps store nameInSubstore field
composeStoreFieldOps (Label fname -> FieldRef fname
forall (n :: Symbol). Label n -> FieldSymRef n
fieldNameFromLabel Label fname
lb) (forall dt (fname :: Symbol) ftype.
HasFieldOfType dt fname ftype =>
StoreFieldOps dt fname ftype
storeFieldOpsADT @dt) (FieldLens (GetFieldType dt fname) targetName targetType
-> StoreFieldOps (GetFieldType dt fname) targetName targetType
forall {k} dt (fname :: k) ftype.
FieldLens dt fname ftype -> StoreFieldOps dt fname ftype
flSFO FieldLens (GetFieldType dt fname) targetName targetType
forall {k} dt (fname :: k) ftype.
HasField dt fname ftype =>
FieldLens dt fname ftype
fieldLens)
instance {-# OVERLAPPABLE #-}
( InstrSetFieldC dt fname
, InstrGetFieldC dt fname
, GetFieldType dt fname ~ ftype
, AccessFieldC dt fname
, KnownSymbol fname
, KnownValue ftype, KnownValue dt
)
=> HasField dt fname ftype where
fieldLens :: FieldLens dt fname ftype
fieldLens = Label fname
-> StoreFieldOps dt fname ftype -> FieldLens dt fname ftype
forall {k} dt (fname :: Symbol) targetFType (targetFName :: k).
(InstrGetFieldC dt fname, InstrSetFieldC dt fname,
GetFieldType dt fname ~ targetFType, AccessFieldC dt fname) =>
Label fname
-> StoreFieldOps dt targetFName targetFType
-> FieldLens dt targetFName targetFType
TargetField (forall (name :: Symbol). KnownSymbol name => Label name
Label @fname) StoreFieldOps dt fname ftype
forall dt (fname :: Symbol) ftype.
HasFieldOfType dt fname ftype =>
StoreFieldOps dt fname ftype
storeFieldOpsADT