module Michelson.FailPattern
( TypicalFailWith
, typicalFailWithTag
, isTypicalFailWith
, modifyTypicalFailWith
) where
import Data.Singletons (sing)
import Michelson.Text (MText)
import Michelson.Typed
class (Typeable a, ConstantScope a) => ConstantScope' a
instance (Typeable a, ConstantScope a) => ConstantScope' a
data TypicalFailWith
= FailWithString MText
| FailWithConstantPair MText (SomeConstrainedValue ConstantScope')
| FailWithStackValue MText
typicalFailWithTag :: TypicalFailWith -> MText
typicalFailWithTag = \case
FailWithString str -> str
FailWithConstantPair str _ -> str
FailWithStackValue str -> str
isTypicalFailWith :: Instr inp out -> Maybe TypicalFailWith
isTypicalFailWith = isTypicalFailWith' . linearizeLeft
where
isTypicalFailWith' :: Instr inp out -> Maybe TypicalFailWith
isTypicalFailWith' =
\case
Seq i1 FAILWITH -> isTypicalPreFailWith i1
_ -> Nothing
isTypicalPreFailWith ::
Instr inp (a ': out) -> Maybe TypicalFailWith
isTypicalPreFailWith =
\case
PUSH v -> isTypicalErrorConstant v
Seq _ (PUSH v) -> isTypicalErrorConstant v
Seq (PUSH v) PAIR -> FailWithStackValue <$> isStringValue v
Seq (Seq _ (PUSH v)) PAIR -> FailWithStackValue <$> isStringValue v
_ -> Nothing
isTypicalErrorConstant ::
forall t. ConstantScope t => Value t -> Maybe TypicalFailWith
isTypicalErrorConstant v
| Just str <- isStringValue v = Just (FailWithString str)
| VPair (VC (CvString str), secondItem) <- v =
case sing @t of
STPair {} -> Just (FailWithConstantPair str (SomeConstrainedValue secondItem))
| otherwise = Nothing
modifyTypicalFailWith ::
(HasCallStack, ConstantScope t, Typeable t) =>
(MText -> Value t) -> Instr inp out -> Instr inp out
modifyTypicalFailWith f = modifyTypicalFailWith' . linearizeLeft
where
modifyTypicalFailWith' :: HasCallStack => Instr inp out -> Instr inp out
modifyTypicalFailWith' =
\case
Seq i1 FAILWITH ->
case i1 of
PUSH v -> onPush v
Seq i0 (PUSH v) -> Seq i0 (onPush v)
Seq (PUSH v) PAIR
| _ :: Value a <- v
, _ :: Instr (b ': s) ('TPair a b ': s) <- i1 ->
case sing @('TPair a b) of
STPair {} -> case isStringValue v of
Just str -> PUSH (f str) `Seq` PAIR `Seq` FAILWITH
Nothing -> PUSH v `Seq` PAIR `Seq` FAILWITH
Seq (Seq i0 (PUSH v)) PAIR
| _ :: Value a <- v
, _ :: Instr s0 ('TPair a b ': s) <- i1 ->
case sing @('TPair a b) of
STPair {} -> Seq i0 $ case isStringValue v of
Just str -> PUSH (f str) `Seq` PAIR `Seq` FAILWITH
Nothing -> PUSH v `Seq` PAIR `Seq` FAILWITH
_ -> Seq i1 FAILWITH
i -> i
onPush ::
(HasCallStack, Typeable v, ConstantScope v) => Value v -> Instr inp out
onPush v = case isTypicalErrorConstant v of
Just (FailWithString str) -> PUSH (f str) `Seq` FAILWITH
Just (FailWithConstantPair str (SomeConstrainedValue arg)) ->
PUSH (VPair (f str, arg)) `Seq` FAILWITH
Just _ -> error "Unexpected TypicalFailWith"
Nothing -> PUSH v `Seq` FAILWITH