module Michelson.Typed.EntryPoints
( EpName (..)
, pattern NoEpName
, epNameFromParamAnn
, epNameToParamAnn
, epNameFromRefAnn
, epNameToRefAnn
, EpNameFromRefAnnError (..)
, EpAddress (..)
, ParseEpAddressError (..)
, formatEpAddress
, mformatEpAddress
, parseEpAddress
, unsafeParseEpAddress
, ParamNotes (..)
, ArmCoord (..)
, ArmCoords
, ParamEpError (..)
, mkParamNotes
, EpLiftSequence (..)
, EntryPointCallT (..)
, SomeEntryPointCallT (..)
, sepcName
, mkEntryPointCall
, tyImplicitAccountParam
) where
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(..), suchThatMap)
import Michelson.Text
import Michelson.Typed.Annotation
import Michelson.Typed.Scope
import Michelson.Typed.Sing
import Michelson.Typed.T
import Michelson.Untyped.Annotation
import Tezos.Address (Address, ParseAddressError, formatAddress, parseAddress)
import Util.Typeable
newtype EpName = EpNameUnsafe { unEpName :: Text }
deriving (Show, Eq, Ord)
pattern NoEpName :: EpName
pattern NoEpName = EpNameUnsafe ""
instance Buildable EpName where
build = \case
NoEpName -> "<default>"
EpNameUnsafe name -> build name
instance Default EpName where
def = EpNameUnsafe ""
epNameFromParamAnn :: FieldAnn -> Maybe EpName
epNameFromParamAnn an@(Annotation a)
| an == noAnn = Nothing
| a == "default" = Just (EpNameUnsafe "")
| otherwise = Just (EpNameUnsafe a)
epNameToParamAnn :: EpName -> FieldAnn
epNameToParamAnn (EpNameUnsafe name)
| name == "" = Annotation "default"
| otherwise = Annotation name
data EpNameFromRefAnnError
= InEpNameBadAnnotation FieldAnn
deriving (Show, Eq)
instance Buildable EpNameFromRefAnnError where
build = \case
InEpNameBadAnnotation (Annotation an) ->
"Invalid entrypoint reference `" +| an |+ "`"
epNameFromRefAnn :: FieldAnn -> Either EpNameFromRefAnnError EpName
epNameFromRefAnn an@(Annotation a)
| a == "default" = Left $ InEpNameBadAnnotation an
| otherwise = Right (EpNameUnsafe a)
epNameToRefAnn :: EpName -> FieldAnn
epNameToRefAnn (EpNameUnsafe name) =
Annotation name
instance Arbitrary FieldAnn => Arbitrary EpName where
arbitrary = arbitrary `suchThatMap` (rightToMaybe . epNameFromRefAnn)
data EpAddress = EpAddress
{ eaAddress :: Address
, eaEntryPoint :: EpName
} deriving (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
| ParseEpAddressRefAnnError EpNameFromRefAnnError
deriving (Show, Eq)
instance Buildable ParseEpAddressError where
build = \case
ParseEpAddressBadAddress err -> build err
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
let annot = case T.stripPrefix "%" annotTxt' of
Nothing -> error "impossible"
Just a -> Annotation 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 (Show, Eq)
type ArmCoords = [ArmCoord]
data ArmCoord = AcLeft | AcRight
deriving (Show, Eq)
instance Buildable ArmCoord where
build = \case
AcLeft -> "left"
AcRight -> "right"
data ParamEpError
= ParamEpDuplicatedNames (NonEmpty EpName)
| ParamEpUncallableArm ArmCoords
deriving (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 instance Eq (EpLiftSequence arg param)
deriving 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) = EntryPointCall
{ epcName :: EpName
, epcParamProxy :: Proxy param
, epcLiftSequence :: EpLiftSequence arg param
}
deriving instance Eq (EntryPointCallT param arg)
deriving instance Show (EntryPointCallT param arg)
instance Buildable (EntryPointCallT param arg) where
build EntryPointCall{..} =
"Call " +| epcName |+ ": " +| epcLiftSequence |+ ""
instance (param ~ arg) => Default (EntryPointCallT param arg) where
def = EntryPointCall
{ epcName = def
, epcParamProxy = Proxy
, epcLiftSequence = EplArgHere
}
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 instance Show (SomeEntryPointCallT arg)
instance Buildable (SomeEntryPointCallT arg) where
build (SomeEpc epc) = build epc
instance ParameterScope arg => Default (SomeEntryPointCallT arg) where
def = SomeEpc def
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
mkEntryPointCall
:: (ParameterScope param)
=> EpName
-> (Sing param, Notes param)
-> (forall arg. (ParameterScope arg) => (Notes arg, EntryPointCallT param arg) -> r)
-> Maybe r
mkEntryPointCall epName param@(_, paramNotes) cont =
asum
[ withEpLiftSequence epName param $ \(argInfo, liftSeq) ->
cont . (argInfo, ) $ EntryPointCall
{ epcName = epName
, epcParamProxy = Proxy
, epcLiftSequence = liftSeq
}
, do
guard (epName == def)
return $ cont . (paramNotes, ) $ EntryPointCall
{ epcName = def
, epcParamProxy = Proxy
, epcLiftSequence = EplArgHere
}
]
tyImplicitAccountParam :: (Sing 'TUnit, Notes 'TUnit)
tyImplicitAccountParam = (sing, starNotes)