module Michelson.FailPattern
( TypicalFailWith
, typicalFailWithTag
, isTypicalFailWith
, modifyTypicalFailWith
, ConstantScope'
) 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
=> (MText -> SomeConstrainedValue ConstantScope')
-> 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 (f -> SomeConstrainedValue v') ->
PUSH v' `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 (f -> SomeConstrainedValue v') ->
PUSH v' `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 (f -> SomeConstrainedValue v')) -> PUSH v' `Seq` FAILWITH
Just (FailWithConstantPair (f -> SomeConstrainedValue v') (SomeConstrainedValue arg)) ->
PUSH (VPair (v', arg)) `Seq` FAILWITH
Just _ -> error "Unexpected TypicalFailWith"
Nothing -> PUSH v `Seq` FAILWITH