{-# LANGUAGE QuantifiedConstraints #-}
module Indigo.Common.Object
( IndigoObjectF (..)
, NamedFieldObj (..)
, TypedFieldObj (..)
, FieldTypes
, Object
, SomeObject (..)
, namedToTypedRec
, typedToNamedRec
, namedToTypedFieldObj
, typedToNamedFieldObj
, IsObject
, complexObjectDict
, ComplexObjectC
, castFieldConstructors
, withInstrDeconstructC
) where
import Data.Constraint (Dict(..))
import Data.Vinyl (RMap, RecordToList)
import Data.Vinyl.TypeLevel (AllConstrained)
import GHC.Generics qualified as G
import Indigo.Backend.Prelude
import Indigo.Common.Var (RefId)
import Indigo.Lorentz
import Morley.Michelson.Typed (IsPrimitiveValue, ToTs)
import Morley.Michelson.Typed.Haskell.Instr.Product
(CastFieldConstructors(..), ConstructorFieldNames, FieldConstructor(..), GetFieldType,
InstrDeconstructC)
import Morley.Util.Type (KList(..), KnownList(..), type (++))
data IndigoObjectF f a where
Cell :: KnownValue a => RefId -> IndigoObjectF f a
Decomposed :: ComplexObjectC a => Rec f (ConstructorFieldNames a) -> IndigoObjectF f a
type family MapGFT a rs where
MapGFT _ '[] = '[]
MapGFT a (name ': xs) = GetFieldType a name ': MapGFT a xs
namedToTypedRec
:: forall a f g .
(forall name . f name -> g (GetFieldType a name))
-> Rec f (ConstructorFieldNames a)
-> Rec g (FieldTypes a)
namedToTypedRec :: forall a (f :: Symbol -> *) (g :: * -> *).
(forall (name :: Symbol). f name -> g (GetFieldType a name))
-> Rec f (ConstructorFieldNames a) -> Rec g (FieldTypes a)
namedToTypedRec forall (name :: Symbol). f name -> g (GetFieldType a name)
fun = Rec f (GFieldNames (Rep a))
-> Rec g (MapGFT a (GFieldNames (Rep a)))
forall (rs :: [Symbol]). Rec f rs -> Rec g (MapGFT a rs)
namedToTypedRecImpl
where
namedToTypedRecImpl :: Rec f rs -> Rec g (MapGFT a rs)
namedToTypedRecImpl :: forall (rs :: [Symbol]). Rec f rs -> Rec g (MapGFT a rs)
namedToTypedRecImpl Rec f rs
RNil = Rec g (MapGFT a rs)
forall {u} (a :: u -> *). Rec a '[]
RNil
namedToTypedRecImpl (f r
v :& Rec f rs
xs) = f r -> g (GetFieldType a r)
forall (name :: Symbol). f name -> g (GetFieldType a name)
fun f r
v g (GetFieldType a r)
-> Rec g (MapGFT a rs) -> Rec g (GetFieldType a r : MapGFT a rs)
forall {u} (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec f rs -> Rec g (MapGFT a rs)
forall (rs :: [Symbol]). Rec f rs -> Rec g (MapGFT a rs)
namedToTypedRecImpl Rec f rs
xs
typedToNamedRec :: forall a f g . KnownList (ConstructorFieldNames a)
=> (forall name . f (GetFieldType a name) -> g name)
-> Rec f (FieldTypes a)
-> Rec g (ConstructorFieldNames a)
typedToNamedRec :: forall a (f :: * -> *) (g :: Symbol -> *).
KnownList (ConstructorFieldNames a) =>
(forall (name :: Symbol). f (GetFieldType a name) -> g name)
-> Rec f (FieldTypes a) -> Rec g (ConstructorFieldNames a)
typedToNamedRec forall (name :: Symbol). f (GetFieldType a name) -> g name
fun = Rec f (MapGFT a (ConstructorFieldNames a))
-> Rec g (ConstructorFieldNames a)
forall (rs :: [Symbol]).
KnownList rs =>
Rec f (MapGFT a rs) -> Rec g rs
typedToNamedRecImpl
where
typedToNamedRecImpl :: forall rs . KnownList rs => Rec f (MapGFT a rs) -> Rec g rs
typedToNamedRecImpl :: forall (rs :: [Symbol]).
KnownList rs =>
Rec f (MapGFT a rs) -> Rec g rs
typedToNamedRecImpl Rec f (MapGFT a rs)
re = case (forall (l :: [Symbol]). KnownList l => KList l
forall {k} (l :: [k]). KnownList l => KList l
klist @rs, Rec f (MapGFT a rs)
re) of
(KList rs
KNil, Rec f '[]
Rec f (MapGFT a rs)
RNil) -> Rec g rs
forall {u} (a :: u -> *). Rec a '[]
RNil
(KCons (Proxy x
_ :: Proxy nm) (Proxy xs
_ :: Proxy rs'), f r
v :& Rec f rs
vs) -> f (LnrFieldType (LNRequireFound x a (GLookupNamed x (Rep a))))
-> g x
forall (name :: Symbol). f (GetFieldType a name) -> g name
fun f r
f (LnrFieldType (LNRequireFound x a (GLookupNamed x (Rep a))))
v g x -> Rec g xs -> Rec g (x : xs)
forall {u} (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec f (MapGFT a xs) -> Rec g xs
forall (rs :: [Symbol]).
KnownList rs =>
Rec f (MapGFT a rs) -> Rec g rs
typedToNamedRecImpl Rec f rs
Rec f (MapGFT a xs)
vs
castFieldConstructors
:: forall a st . CastFieldConstructors (FieldTypes a) (ConstructorFieldTypes a)
=> Rec (FieldConstructor st) (FieldTypes a) -> Rec (FieldConstructor st) (ConstructorFieldTypes a)
castFieldConstructors :: forall {k} a (st :: [k]).
CastFieldConstructors (FieldTypes a) (ConstructorFieldTypes a) =>
Rec (FieldConstructor st) (FieldTypes a)
-> Rec (FieldConstructor st) (ConstructorFieldTypes a)
castFieldConstructors = Rec (FieldConstructor st) (FieldTypes a)
-> Rec (FieldConstructor st) (ConstructorFieldTypes a)
forall (xs :: [*]) (ys :: [*]) {k} (st :: [k]).
CastFieldConstructors xs ys =>
Rec (FieldConstructor st) xs -> Rec (FieldConstructor st) ys
castFieldConstructorsImpl
data NamedFieldObj a name where
NamedFieldObj
:: IsObject (GetFieldType a name)
=> { forall a (name :: Symbol).
NamedFieldObj a name -> Object (GetFieldType a name)
unFieldObj :: Object (GetFieldType a name)
}
-> NamedFieldObj a name
type Object a = IndigoObjectF (NamedFieldObj a) a
data SomeObject where
SomeObject :: IsObject a => Object a -> SomeObject
data TypedFieldObj a where
TypedFieldObj :: IsObject a => Object a -> TypedFieldObj a
namedToTypedFieldObj :: forall a name . NamedFieldObj a name -> TypedFieldObj (GetFieldType a name)
namedToTypedFieldObj :: forall a (name :: Symbol).
NamedFieldObj a name -> TypedFieldObj (GetFieldType a name)
namedToTypedFieldObj (NamedFieldObj Object (GetFieldType a name)
f) = Object (GetFieldType a name) -> TypedFieldObj (GetFieldType a name)
forall a. IsObject a => Object a -> TypedFieldObj a
TypedFieldObj Object (GetFieldType a name)
f
typedToNamedFieldObj :: forall a name . TypedFieldObj (GetFieldType a name) -> NamedFieldObj a name
typedToNamedFieldObj :: forall a (name :: Symbol).
TypedFieldObj (GetFieldType a name) -> NamedFieldObj a name
typedToNamedFieldObj (TypedFieldObj Object (GetFieldType a name)
f) = Object (GetFieldType a name) -> NamedFieldObj a name
forall a (name :: Symbol).
IsObject (GetFieldType a name) =>
Object (GetFieldType a name) -> NamedFieldObj a name
NamedFieldObj Object (GetFieldType a name)
f
class IsObject' (TypeDecision a) a => IsObject a
instance IsObject' (TypeDecision a) a => IsObject a
type FieldTypes a = MapGFT a (ConstructorFieldNames a)
type InstrDeconstructCClassConstraint a st =
( InstrDeconstructC a (ToTs st)
, ToTs (ConstructorFieldTypes a) ++ (ToTs st) ~ ToTs (ConstructorFieldTypes a ++ st)
)
class InstrDeconstructCClassConstraint a st => InstrDeconstructCClass (a :: Type) (st :: [Type])
instance InstrDeconstructCClassConstraint a st => InstrDeconstructCClass a st
class (forall st. InstrDeconstructCClass a st) => InstrDeconstructCGeneral a
instance (forall st. InstrDeconstructCClass a st) => InstrDeconstructCGeneral a
withInstrDeconstructC
:: forall a st r. InstrDeconstructCGeneral a
=> (InstrDeconstructCClass a st => r) -> r
withInstrDeconstructC :: forall a (st :: [*]) r.
InstrDeconstructCGeneral a =>
(InstrDeconstructCClass a st => r) -> r
withInstrDeconstructC InstrDeconstructCClass a st => r
f = r
InstrDeconstructCClass a st => r
f
type ToDeconstructC a =
( InstrDeconstructCGeneral a
, KnownList (FieldTypes a)
, AllConstrained KnownValue (FieldTypes a)
, FieldTypes a ~ ConstructorFieldTypes a
)
type ToConstructC a =
( KnownValue a
, InstrConstructC a
, RMap (ConstructorFieldNames a)
, RMap (ConstructorFieldTypes a)
, RMap (FieldTypes a)
, KnownList (ConstructorFieldNames a)
, CastFieldConstructors (FieldTypes a) (ConstructorFieldTypes a)
)
type ComplexObjectC a =
( ToDeconstructC a
, ToConstructC a
, AllConstrained IsObject (FieldTypes a)
, RecordToList (FieldTypes a)
)
class KnownValue a => IsObject' (decision :: Decision) a where
complexObjectDict' :: Maybe (Dict (ComplexObjectC a))
instance KnownValue a => IsObject' 'PrimitiveD a where
complexObjectDict' :: Maybe (Dict (ComplexObjectC a))
complexObjectDict' = Maybe (Dict (ComplexObjectC a))
forall a. Maybe a
Nothing
instance KnownValue a => IsObject' 'SumTypeD a where
complexObjectDict' :: Maybe (Dict (ComplexObjectC a))
complexObjectDict' = Maybe (Dict (ComplexObjectC a))
forall a. Maybe a
Nothing
instance ComplexObjectC a => IsObject' 'ProductTypeD a where
complexObjectDict' :: Maybe (Dict (ComplexObjectC a))
complexObjectDict' = Dict
((InstrDeconstructCGeneral a, KnownList (ConstructorFieldTypes a),
AllConstrained KnownValue (FieldTypes a),
ConstructorFieldTypes a ~ ConstructorFieldTypes a),
(KnownValue a,
((IsoValue a, Generic a, GValueType (Rep a) ~ GValueType (Rep a)),
GInstrConstruct (Rep a) '[]),
RMap (GFieldNames (Rep a)), RMap (ConstructorFieldTypes a),
RMap (ConstructorFieldTypes a), KnownList (GFieldNames (Rep a)),
CastFieldConstructors
(ConstructorFieldTypes a) (ConstructorFieldTypes a)),
AllConstrained IsObject (FieldTypes a),
RecordToList (ConstructorFieldTypes a))
-> Maybe
(Dict
((InstrDeconstructCGeneral a, KnownList (ConstructorFieldTypes a),
AllConstrained KnownValue (FieldTypes a),
ConstructorFieldTypes a ~ ConstructorFieldTypes a),
(KnownValue a,
((IsoValue a, Generic a, GValueType (Rep a) ~ GValueType (Rep a)),
GInstrConstruct (Rep a) '[]),
RMap (GFieldNames (Rep a)), RMap (ConstructorFieldTypes a),
RMap (ConstructorFieldTypes a), KnownList (GFieldNames (Rep a)),
CastFieldConstructors
(ConstructorFieldTypes a) (ConstructorFieldTypes a)),
AllConstrained IsObject (FieldTypes a),
RecordToList (ConstructorFieldTypes a)))
forall a. a -> Maybe a
Just Dict
((InstrDeconstructCGeneral a, KnownList (ConstructorFieldTypes a),
AllConstrained KnownValue (FieldTypes a),
ConstructorFieldTypes a ~ ConstructorFieldTypes a),
(KnownValue a,
((IsoValue a, Generic a, GValueType (Rep a) ~ GValueType (Rep a)),
GInstrConstruct (Rep a) '[]),
RMap (GFieldNames (Rep a)), RMap (ConstructorFieldTypes a),
RMap (ConstructorFieldTypes a), KnownList (GFieldNames (Rep a)),
CastFieldConstructors
(ConstructorFieldTypes a) (ConstructorFieldTypes a)),
AllConstrained IsObject (FieldTypes a),
RecordToList (ConstructorFieldTypes a))
forall (a :: Constraint). a => Dict a
Dict
complexObjectDict :: forall a . IsObject a => Maybe (Dict (ComplexObjectC a))
complexObjectDict :: forall a. IsObject a => Maybe (Dict (ComplexObjectC a))
complexObjectDict = forall (decision :: Decision) a.
IsObject' decision a =>
Maybe (Dict (ComplexObjectC a))
complexObjectDict' @(TypeDecision a) @a
type TypeDecision a = Decide (IsPrimitiveValue a) (IsSumType (G.Rep a))
data Decision
= PrimitiveD
| SumTypeD
| ProductTypeD
type family Decide flagPrimitive flagSumType where
Decide 'True _ = 'PrimitiveD
Decide 'False 'True = 'SumTypeD
Decide 'False 'False = 'ProductTypeD
type family IsSumType x where
IsSumType (G.D1 _ x) = IsSumType x
IsSumType (G.C1 _ x) = IsSumType x
IsSumType (G.M1 _ _ x) = IsSumType x
IsSumType (_ G.:*: _) = 'False
IsSumType (G.Rec0 _) = 'False
IsSumType G.V1 = 'False
IsSumType G.U1 = 'False
IsSumType (_ G.:+: _) = 'True