{-# LANGUAGE UndecidableSuperClasses #-}
module Lorentz.EntryPoints.Core
( CanHaveEntryPoints
, EntryPointsDerivation (..)
, EpConstructionRes (..)
, RequireAllUniqueEntryPoints
, ParameterHasEntryPoints (..)
, ParameterDeclaresEntryPoints
, GetParameterEpDerivation
, pepNotes
, pepCall
, AllParameterEntryPoints
, LookupParameterEntryPoint
, parameterEntryPointsToNotes
, GetEntryPointArg
, parameterEntryPointCall
, GetDefaultEntryPointArg
, parameterEntryPointCallDefault
, flattenEntryPoints
, ForbidExplicitDefaultEntryPoint
, NoExplicitDefaultEntryPoint
, sepcCallRootChecked
, EntryPointRef (..)
, NiceEntryPointName
, eprName
, GetEntryPointArgCustom
, TrustEpName (..)
, HasEntryPointArg (..)
, HasDefEntryPointArg
, parameterEntryPointCallCustom
, EpdNone
, RequireAllUniqueEntryPoints'
) where
import Data.Constraint (Dict(..), (\\))
import qualified Data.Kind as Kind
import Data.Map (Map, insert)
import Data.Singletons (SingI, sing)
import Data.Typeable (typeRep)
import Data.Vinyl.Derived (Label)
import Fcf (Eval, Exp)
import qualified Fcf
import qualified Fcf.Utils as Fcf
import Fmt (pretty)
import Michelson.Typed
import qualified Michelson.Untyped as U
import Util.Type
import Util.TypeLits
import Lorentz.Constraints.Scopes
import Lorentz.EntryPoints.Helpers
class EntryPointsDerivation deriv cp where
type EpdAllEntryPoints deriv cp :: [(Symbol, Kind.Type)]
type EpdLookupEntryPoint deriv cp :: Symbol -> Exp (Maybe Kind.Type)
epdNotes :: Notes (ToT cp)
epdCall
:: (KnownSymbol name, ParameterScope (ToT cp))
=> Label name
-> EpConstructionRes (ToT cp) (Eval (EpdLookupEntryPoint deriv cp name))
type RequireAllUniqueEntryPoints' deriv cp =
RequireAllUnique
"entrypoint name"
(Eval (Fcf.Map Fcf.Fst $ EpdAllEntryPoints deriv cp))
type RequireAllUniqueEntryPoints cp =
RequireAllUniqueEntryPoints' (ParameterEntryPointsDerivation cp) cp
data EpConstructionRes (param :: T) (marg :: Maybe Kind.Type) where
EpConstructed
:: ParameterScope (ToT arg)
=> EpLiftSequence (ToT arg) param -> EpConstructionRes param ('Just arg)
EpConstructionFailed
:: EpConstructionRes param 'Nothing
class ( EntryPointsDerivation (ParameterEntryPointsDerivation cp) cp
, RequireAllUniqueEntryPoints cp
) =>
ParameterHasEntryPoints cp where
type ParameterEntryPointsDerivation cp :: Kind.Type
type ParameterDeclaresEntryPoints cp =
( If (CanHaveEntryPoints cp)
(ParameterHasEntryPoints cp)
(() :: Constraint)
, NiceParameter cp
, EntryPointsDerivation (GetParameterEpDerivation cp) cp
)
type GetParameterEpDerivation cp =
If (CanHaveEntryPoints cp)
(ParameterEntryPointsDerivation cp)
EpdNone
pepNotes :: forall cp. ParameterDeclaresEntryPoints cp => Notes (ToT cp)
pepNotes = epdNotes @(GetParameterEpDerivation cp) @cp
pepCall
:: forall cp name deriv.
( ParameterDeclaresEntryPoints cp, ParameterScope (ToT cp)
, KnownSymbol name, deriv ~ GetParameterEpDerivation cp
)
=> Label name
-> EpConstructionRes (ToT cp) (Eval (EpdLookupEntryPoint deriv cp name))
pepCall = epdCall @(GetParameterEpDerivation cp) @cp
type family AllParameterEntryPoints (cp :: Kind.Type)
:: [(Symbol, Kind.Type)] where
AllParameterEntryPoints cp =
EpdAllEntryPoints (GetParameterEpDerivation cp) cp
type family LookupParameterEntryPoint (cp :: Kind.Type)
:: Symbol -> Exp (Maybe Kind.Type) where
LookupParameterEntryPoint cp =
EpdLookupEntryPoint (GetParameterEpDerivation cp) cp
parameterEntryPointsToNotes
:: forall cp.
(Typeable cp, ParameterDeclaresEntryPoints cp)
=> ParamNotes (ToT cp)
parameterEntryPointsToNotes =
let notes = pepNotes @cp
in case mkParamNotes notes of
Right n -> n
Left e -> error $ mconcat
[ "Lorentz unexpectedly compiled into contract with \
\illegal parameter declaration.\n"
, "Parameter: " <> show (typeRep (Proxy @cp)) <> "\n"
, "Derived annotations: " <> show notes <> "\n"
, "Failure reason: " <> pretty e
]
parameterEntryPointCall
:: forall cp name.
( ParameterDeclaresEntryPoints cp
, KnownSymbol name
)
=> Label name
-> EntryPointCall cp (GetEntryPointArg cp name)
parameterEntryPointCall label =
withDict (niceParameterEvi @cp) $
case pepCall @cp label of
EpConstructed liftSeq -> EntryPointCall
{ epcName = epNameFromParamAnn (ctorNameToAnn @name)
?: error "Empty constructor-entrypoint name"
, epcParamProxy = Proxy
, epcLiftSequence = liftSeq
}
EpConstructionFailed ->
error "impossible"
type GetEntryPointArg cp name = Eval
( Fcf.LiftM2
Fcf.FromMaybe
(Fcf.TError ('Text "Entrypoint not found: " ':<>: 'ShowType name ':$$:
'Text "In contract parameter `" ':<>: 'ShowType cp ':<>: 'Text "`"))
(LookupParameterEntryPoint cp name)
)
type DefaultEpName = "Default"
parameterEntryPointCallDefault
:: forall cp.
(ParameterDeclaresEntryPoints cp)
=> EntryPointCall cp (GetDefaultEntryPointArg cp)
parameterEntryPointCallDefault =
withDict (niceParameterEvi @cp) $
case pepCall @cp (fromLabel @DefaultEpName) of
EpConstructed liftSeq -> EntryPointCall
{ epcName = DefEpName
, epcParamProxy = Proxy
, epcLiftSequence = liftSeq
}
EpConstructionFailed ->
EntryPointCall
{ epcName = DefEpName
, epcParamProxy = Proxy
, epcLiftSequence = EplArgHere
}
type GetDefaultEntryPointArg cp = Eval
( Fcf.LiftM2
Fcf.FromMaybe
(Fcf.Pure cp)
(LookupParameterEntryPoint cp DefaultEpName)
)
type ForbidExplicitDefaultEntryPoint cp = Eval
(Fcf.LiftM3
Fcf.UnMaybe
(Fcf.Pure (Fcf.Pure (() :: Constraint)))
(Fcf.TError
('Text "Parameter used here must have no explicit \"default\" entrypoint" ':$$:
'Text "In parameter type `" ':<>: 'ShowType cp ':<>: 'Text "`"
)
)
(LookupParameterEntryPoint cp DefaultEpName)
)
type NoExplicitDefaultEntryPoint cp =
Eval (LookupParameterEntryPoint cp DefaultEpName) ~ 'Nothing
sepcCallRootChecked
:: forall cp.
(NiceParameter cp, ForbidExplicitDefaultEntryPoint cp)
=> SomeEntryPointCall cp
sepcCallRootChecked = sepcCallRootUnsafe \\ niceParameterEvi @cp
where
_validUsage = Dict @(ForbidExplicitDefaultEntryPoint cp)
data EntryPointRef (mname :: Maybe Symbol) where
CallDefault :: EntryPointRef 'Nothing
Call :: NiceEntryPointName name => EntryPointRef ('Just name)
type NiceEntryPointName name = (KnownSymbol name, ForbidDefaultName name)
type family ForbidDefaultName (name :: Symbol) :: Constraint where
ForbidDefaultName "Default" =
TypeError ('Text "Calling `Default` entrypoint is not allowed here")
ForbidDefaultName _ = ()
eprName :: forall mname. EntryPointRef mname -> EpName
eprName = \case
CallDefault -> DefEpName
Call | (_ :: Proxy ('Just name)) <- Proxy @mname ->
epNameFromParamAnn (ctorNameToAnn @name)
?: error "Empty constructor-entrypoint name"
parameterEntryPointCallCustom
:: forall cp mname.
(ParameterDeclaresEntryPoints cp)
=> EntryPointRef mname
-> EntryPointCall cp (GetEntryPointArgCustom cp mname)
parameterEntryPointCallCustom = \case
CallDefault ->
parameterEntryPointCallDefault @cp
Call | (_ :: Proxy ('Just name)) <- Proxy @mname ->
parameterEntryPointCall @cp (fromLabel @name)
flattenEntryPoints :: SingI t => ParamNotes t -> Map EpName U.Type
flattenEntryPoints (unParamNotes -> notes) = appEndo (gatherEPs (sing, notes)) mempty
where
gatherEPs
:: forall n.
(Sing n, Notes n)
-> Endo (Map EpName U.Type)
gatherEPs = \case
(STOr ls rs, NTOr _ fn1 fn2 ln rn) -> mconcat
[ Endo . maybe id (uncurry insert) . psi ln $ epNameFromParamAnn fn1
, Endo . maybe id (uncurry insert) . psi rn $ epNameFromParamAnn fn2
, gatherEPs (ls, ln)
, gatherEPs (rs, rn)
]
_ -> mempty
psi
:: forall n.
SingI n
=> Notes n
-> Maybe EpName
-> Maybe (EpName, U.Type)
psi n x = tensor x $ mkUType sing n
tensor :: Functor f => f a -> b -> f (a,b)
tensor fa b = fmap (,b) fa
type family GetEntryPointArgCustom cp mname :: Kind.Type where
GetEntryPointArgCustom cp 'Nothing = GetDefaultEntryPointArg cp
GetEntryPointArgCustom cp ('Just name) = GetEntryPointArg cp name
class HasEntryPointArg cp name arg where
useHasEntryPointArg :: name -> (Dict (ParameterScope (ToT arg)), EpName)
type HasDefEntryPointArg cp defEpName defArg =
( defEpName ~ EntryPointRef 'Nothing
, HasEntryPointArg cp defEpName defArg
)
instance
(GetEntryPointArgCustom cp mname ~ arg, ParameterDeclaresEntryPoints cp) =>
HasEntryPointArg cp (EntryPointRef mname) arg where
useHasEntryPointArg epRef =
withDict (niceParameterEvi @cp) $
case parameterEntryPointCallCustom @cp epRef of
EntryPointCall{} -> (Dict, eprName epRef)
newtype TrustEpName = TrustEpName EpName
instance (NiceParameter arg) =>
HasEntryPointArg cp TrustEpName arg where
useHasEntryPointArg (TrustEpName epName) = (Dict, epName) \\ niceParameterEvi @arg
data EpdNone
instance SingI (ToT cp) => EntryPointsDerivation EpdNone cp where
type EpdAllEntryPoints EpdNone cp = '[]
type EpdLookupEntryPoint EpdNone cp = Fcf.ConstFn 'Nothing
epdNotes = starNotes
epdCall _ = EpConstructionFailed