module Michelson.Typed.EntryPoints
( EpAddress (..)
, ParseEpAddressError (..)
, formatEpAddress
, mformatEpAddress
, parseEpAddress
, unsafeParseEpAddress
, ParamNotes (..)
, pattern ParamNotes
, ArmCoord (..)
, ArmCoords
, ParamEpError (..)
, mkParamNotes
, EpLiftSequence (..)
, EntryPointCallT (..)
, epcPrimitive
, epcCallRootUnsafe
, SomeEntryPointCallT (..)
, sepcCallRootUnsafe
, sepcPrimitive
, sepcName
, ForbidOr
, MkEntryPointCallRes (..)
, mkEntryPointCall
, tyImplicitAccountParam
, EpName (..)
, pattern DefEpName
, epNameFromParamAnn
, epNameToParamAnn
, epNameFromRefAnn
, epNameToRefAnn
, EpNameFromRefAnnError (..)
) where
import Data.Constraint (Dict(..))
import Data.Default (Default(..))
import qualified Data.List.NonEmpty as NE
import Data.Singletons (Sing, SingI(..))
import qualified Data.Text as T
import Data.Typeable ((:~:)(..))
import Fmt (Buildable(..), pretty, (+|), (|+))
import Test.QuickCheck (Arbitrary(..))
import Michelson.Text
import Michelson.Typed.Annotation
import Michelson.Typed.Scope
import Michelson.Typed.Sing
import Michelson.Typed.T
import Michelson.Untyped.Annotation
import Michelson.Untyped.EntryPoints
import Tezos.Address (Address, ParseAddressError, formatAddress, parseAddress)
import Util.Typeable
import Util.TypeLits
data EpAddress = EpAddress
{ eaAddress :: Address
, eaEntryPoint :: EpName
} deriving stock (Show, Eq, Ord)
instance Buildable EpAddress where
build = build . formatEpAddress
formatEpAddress :: EpAddress -> Text
formatEpAddress (EpAddress addr ep)
| ep == def = formatAddress addr
| otherwise = formatAddress addr <> "%" <> pretty ep
mformatEpAddress :: EpAddress -> MText
mformatEpAddress ea =
let t = formatEpAddress ea
in mkMTextUnsafe t
data ParseEpAddressError
= ParseEpAddressBadAddress ParseAddressError
| ParseEpAddressBadRefAnn Text
| ParseEpAddressRefAnnError EpNameFromRefAnnError
deriving stock (Show, Eq)
instance Buildable ParseEpAddressError where
build = \case
ParseEpAddressBadAddress err -> build err
ParseEpAddressBadRefAnn txt -> pretty $ "Invalid reference annotation: " <> txt
ParseEpAddressRefAnnError err -> build err
parseEpAddress :: Text -> Either ParseEpAddressError EpAddress
parseEpAddress txt =
let (addrTxt, mannotTxt) = T.breakOn "%" txt
in case mannotTxt of
"" -> do
addr <- first ParseEpAddressBadAddress $ parseAddress addrTxt
return $ EpAddress addr def
annotTxt' -> do
addr <- first ParseEpAddressBadAddress $ parseAddress addrTxt
annot <- first ParseEpAddressBadRefAnn $ case T.stripPrefix "%" annotTxt' of
Nothing -> error "impossible"
Just a -> mkAnnotation a
epName <- first ParseEpAddressRefAnnError $ epNameFromRefAnn annot
return $ EpAddress addr epName
unsafeParseEpAddress :: HasCallStack => Text -> EpAddress
unsafeParseEpAddress = either (error . pretty) id . parseEpAddress
instance Arbitrary FieldAnn => Arbitrary EpAddress where
arbitrary = EpAddress <$> arbitrary <*> arbitrary
newtype ParamNotes (t :: T) = ParamNotesUnsafe
{ unParamNotes :: Notes t
} deriving stock (Show, Eq)
pattern ParamNotes :: Notes t -> ParamNotes t
pattern ParamNotes t <- ParamNotesUnsafe t
{-# COMPLETE ParamNotes #-}
type ArmCoords = [ArmCoord]
data ArmCoord = AcLeft | AcRight
deriving stock (Show, Eq)
instance Buildable ArmCoord where
build = \case
AcLeft -> "left"
AcRight -> "right"
data ParamEpError
= ParamEpDuplicatedNames (NonEmpty EpName)
| ParamEpUncallableArm ArmCoords
deriving stock (Show, Eq)
instance Buildable ParamEpError where
build = \case
ParamEpDuplicatedNames names -> mconcat
[ "Duplicated entrypoint names: "
, mconcat . intersperse ", " $ map (surround "'" "'" . build) (toList names)
]
ParamEpUncallableArm arm -> mconcat
[ "Due to presence of 'default' entrypoint, one of contract \"arms\" \
\cannot be called: \""
, mconcat . intersperse " - " $ map build arm
, "\""
, if length arm > 1 then " (in top-to-bottom order)" else ""
]
where
surround pre post builder = pre <> builder <> post
verifyParamNotes :: Notes t -> Either ParamEpError ()
verifyParamNotes notes = do
let allEps = appEndo (gatherEntrypoints notes) []
duplicatedEps = mapMaybe (safeHead . tail) . NE.group $ sort allEps
whenJust (nonEmpty duplicatedEps) $ \dups ->
Left $ ParamEpDuplicatedNames dups
void $ ensureAllCallable notes
& first ParamEpUncallableArm
where
gatherEntrypoints :: Notes t -> Endo [EpName]
gatherEntrypoints = \case
NTOr _ fn1 fn2 l r -> mconcat
[ Endo $ maybe id (:) (epNameFromParamAnn fn1)
, Endo $ maybe id (:) (epNameFromParamAnn fn2)
, gatherEntrypoints l
, gatherEntrypoints r
]
_ -> mempty
ensureAllCallable :: Notes t -> Either ArmCoords Bool
ensureAllCallable = \case
NTOr _ fnL fnR l r -> do
let epNameL = epNameFromParamAnn fnL
let epNameR = epNameFromParamAnn fnR
haveDefLL <- first (AcLeft :) $ ensureAllCallable l
haveDefRR <- first (AcRight :) $ ensureAllCallable r
let haveDefL = or [haveDefLL, epNameL == Just (def @EpName)]
let haveDefR = or [haveDefRR, epNameR == Just (def @EpName)]
when haveDefL $
first (AcRight :) $ checkAllEpsNamed epNameR r
when haveDefR $
first (AcLeft :) $ checkAllEpsNamed epNameL l
return $ or [haveDefL, haveDefR]
_ -> return False
checkAllEpsNamed :: Maybe EpName -> Notes t -> Either ArmCoords ()
checkAllEpsNamed epNameRoot
| isJust epNameRoot = \_ -> pass
| otherwise = \case
NTOr _ fnL fnR l r -> do
let epNameL = epNameFromParamAnn fnL
epNameR = epNameFromParamAnn fnR
first (AcLeft :) $ checkAllEpsNamed epNameL l
first (AcRight :) $ checkAllEpsNamed epNameR r
_ -> Left []
mkParamNotes :: Notes t -> Either ParamEpError (ParamNotes t)
mkParamNotes nt = verifyParamNotes nt $> ParamNotesUnsafe nt
data EpLiftSequence (arg :: T) (param :: T) where
EplArgHere :: EpLiftSequence arg arg
EplWrapLeft :: EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr subparam r)
EplWrapRight :: EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr l subparam)
deriving stock instance Eq (EpLiftSequence arg param)
deriving stock instance Show (EpLiftSequence arg param)
instance Buildable (EpLiftSequence arg param) where
build = \case
EplArgHere -> "×"
EplWrapLeft es -> "Left (" <> build es <> ")"
EplWrapRight es -> "Right (" <> build es <> ")"
data EntryPointCallT (param :: T) (arg :: T) =
ParameterScope arg => EntryPointCall
{ epcName :: EpName
, epcParamProxy :: Proxy param
, epcLiftSequence :: EpLiftSequence arg param
}
deriving stock instance Eq (EntryPointCallT param arg)
deriving stock instance Show (EntryPointCallT param arg)
instance Buildable (EntryPointCallT param arg) where
build EntryPointCall{..} =
"Call " +| epcName |+ ": " +| epcLiftSequence |+ ""
epcCallRootUnsafe :: ParameterScope param => EntryPointCallT param param
epcCallRootUnsafe = EntryPointCall
{ epcName = def
, epcParamProxy = Proxy
, epcLiftSequence = EplArgHere
}
epcPrimitive
:: forall p.
(ParameterScope p, ForbidOr p)
=> EntryPointCallT p p
epcPrimitive = epcCallRootUnsafe
where
_requireNoOr = Dict @(ForbidOr p)
type family ForbidOr (t :: T) :: Constraint where
ForbidOr ('TOr l r) =
TypeError
('Text "Cannot apply to sum type parameter " ':<>: 'ShowType ('TOr l r))
ForbidOr _ = ()
data SomeEntryPointCallT (arg :: T) =
forall param. (ParameterScope param) =>
SomeEpc (EntryPointCallT param arg)
instance Eq (SomeEntryPointCallT arg) where
SomeEpc epc1 == SomeEpc epc2 = isJust @() $ do
Refl <- eqP (epcParamProxy epc1) (epcParamProxy epc2)
guard (epc1 == epc2)
deriving stock instance Show (SomeEntryPointCallT arg)
instance Buildable (SomeEntryPointCallT arg) where
build (SomeEpc epc) = build epc
sepcCallRootUnsafe :: ParameterScope param => SomeEntryPointCallT param
sepcCallRootUnsafe = SomeEpc epcCallRootUnsafe
sepcPrimitive
:: forall t.
(ParameterScope t, ForbidOr t)
=> SomeEntryPointCallT t
sepcPrimitive = SomeEpc epcPrimitive
sepcName :: SomeEntryPointCallT arg -> EpName
sepcName (SomeEpc epc) = epcName epc
withEpLiftSequence
:: (ParameterScope param)
=> EpName
-> (Sing param, Notes param)
-> (forall arg. (ParameterScope arg) => (Notes arg, EpLiftSequence arg param) -> r)
-> Maybe r
withEpLiftSequence epName@(epNameToParamAnn -> epAnn) param cont =
case param of
(STOr lSing rSing, NTOr _ lFieldAnn rFieldAnn lNotes rNotes) ->
case (checkOpPresence lSing, checkNestedBigMapsPresence lSing) of
(OpAbsent, NestedBigMapsAbsent) -> asum
[ guard (lFieldAnn == epAnn) $> cont (lNotes, EplWrapLeft EplArgHere)
, guard (rFieldAnn == epAnn) $> cont (rNotes, EplWrapRight EplArgHere)
, withEpLiftSequence epName (lSing, lNotes) (cont . fmap @((,) _) EplWrapLeft)
, withEpLiftSequence epName (rSing, rNotes) (cont . fmap @((,) _) EplWrapRight)
]
_ -> Nothing
data MkEntryPointCallRes param where
MkEntryPointCallRes
:: ParameterScope arg
=> Notes arg
-> EntryPointCallT param arg
-> MkEntryPointCallRes param
mkEntryPointCall
:: (ParameterScope param)
=> EpName
-> (Sing param, ParamNotes param)
-> Maybe (MkEntryPointCallRes param)
mkEntryPointCall epName (paramSing, ParamNotes paramNotes) =
asum
[ withEpLiftSequence epName (paramSing, paramNotes) $ \(argInfo, liftSeq) ->
MkEntryPointCallRes argInfo $ EntryPointCall
{ epcName = epName
, epcParamProxy = Proxy
, epcLiftSequence = liftSeq
}
, guard (epName == def) $>
MkEntryPointCallRes paramNotes EntryPointCall
{ epcName = def
, epcParamProxy = Proxy
, epcLiftSequence = EplArgHere
}
]
tyImplicitAccountParam :: (Sing 'TUnit, ParamNotes 'TUnit)
tyImplicitAccountParam = (sing, ParamNotesUnsafe starNotes)