{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
module Morley.Michelson.FailPattern
( TypicalFailWith
, typicalFailWithTag
, isTypicalFailWith
, modifyTypicalFailWith
) where
import Data.Singletons (withSingI)
import Morley.Michelson.Text (MText)
import Morley.Michelson.Typed
data TypicalFailWith
= FailWithString MText
| FailWithConstantPair MText (SomeConstrainedValue ConstantScope)
| FailWithStackValue MText
typicalFailWithTag :: TypicalFailWith -> MText
typicalFailWithTag :: TypicalFailWith -> MText
typicalFailWithTag = \case
FailWithString MText
str -> MText
str
FailWithConstantPair MText
str SomeConstrainedValue ConstantScope
_ -> MText
str
FailWithStackValue MText
str -> MText
str
isTypicalFailWith :: Instr inp out -> Maybe TypicalFailWith
isTypicalFailWith :: Instr inp out -> Maybe TypicalFailWith
isTypicalFailWith = \case
Seq Instr inp b
i1 Instr b out
FAILWITH -> Instr inp (a : s) -> Maybe TypicalFailWith
forall (inp :: [T]) (a :: T) (out :: [T]).
Instr inp (a : out) -> Maybe TypicalFailWith
isTypicalPreFailWith Instr inp b
Instr inp (a : s)
i1
Instr inp out
_ -> Maybe TypicalFailWith
forall a. Maybe a
Nothing
where
isTypicalPreFailWith ::
Instr inp (a ': out) -> Maybe TypicalFailWith
isTypicalPreFailWith :: Instr inp (a : out) -> Maybe TypicalFailWith
isTypicalPreFailWith =
\case
PUSH Value' Instr t
v -> Value' Instr t -> Maybe TypicalFailWith
forall (t :: T).
ConstantScope t =>
Value t -> Maybe TypicalFailWith
isTypicalErrorConstant Value' Instr t
v
Seq Instr inp b
_ (PUSH Value' Instr t
v) -> Value' Instr t -> Maybe TypicalFailWith
forall (t :: T).
ConstantScope t =>
Value t -> Maybe TypicalFailWith
isTypicalErrorConstant Value' Instr t
v
Seq (PUSH Value' Instr t
v) Instr b (a : out)
PAIR -> MText -> TypicalFailWith
FailWithStackValue (MText -> TypicalFailWith) -> Maybe MText -> Maybe TypicalFailWith
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value' Instr t -> Maybe MText
forall (t :: T). Value t -> Maybe MText
isStringValue Value' Instr t
v
Seq (Seq Instr inp b
_ (PUSH Value' Instr t
v)) Instr b (a : out)
PAIR -> MText -> TypicalFailWith
FailWithStackValue (MText -> TypicalFailWith) -> Maybe MText -> Maybe TypicalFailWith
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value' Instr t -> Maybe MText
forall (t :: T). Value t -> Maybe MText
isStringValue Value' Instr t
v
Instr inp (a : out)
_ -> Maybe TypicalFailWith
forall a. Maybe a
Nothing
isTypicalErrorConstant ::
forall t. ConstantScope t => Value t -> Maybe TypicalFailWith
isTypicalErrorConstant :: Value t -> Maybe TypicalFailWith
isTypicalErrorConstant Value t
v
| Just MText
str <- Value t -> Maybe MText
forall (t :: T). Value t -> Maybe MText
isStringValue Value t
v = TypicalFailWith -> Maybe TypicalFailWith
forall a. a -> Maybe a
Just (MText -> TypicalFailWith
FailWithString MText
str)
| VPair (VString MText
str, Value' Instr r
secondItem) <- Value t
v =
case SingI t => Sing t
forall k (a :: k). SingI a => Sing a
sing @t of
STPair l r -> Sing 'TString
-> (SingI 'TString => Maybe TypicalFailWith)
-> Maybe TypicalFailWith
forall k (n :: k) r. Sing n -> (SingI n => r) -> r
withSingI Sing n
Sing 'TString
l ((SingI 'TString => Maybe TypicalFailWith)
-> Maybe TypicalFailWith)
-> (SingI 'TString => Maybe TypicalFailWith)
-> Maybe TypicalFailWith
forall a b. (a -> b) -> a -> b
$ Sing r
-> (SingI r => Maybe TypicalFailWith) -> Maybe TypicalFailWith
forall k (n :: k) r. Sing n -> (SingI n => r) -> r
withSingI Sing r
Sing n
r ((SingI r => Maybe TypicalFailWith) -> Maybe TypicalFailWith)
-> (SingI r => Maybe TypicalFailWith) -> Maybe TypicalFailWith
forall a b. (a -> b) -> a -> b
$ TypicalFailWith -> Maybe TypicalFailWith
forall a. a -> Maybe a
Just (MText -> SomeConstrainedValue ConstantScope -> TypicalFailWith
FailWithConstantPair MText
str (Value' Instr r -> SomeConstrainedValue ConstantScope
forall (t :: T) (c :: T -> Constraint).
c t =>
Value t -> SomeConstrainedValue c
SomeConstrainedValue Value' Instr r
secondItem))
| Bool
otherwise = Maybe TypicalFailWith
forall a. Maybe a
Nothing
modifyTypicalFailWith
:: HasCallStack
=> (MText -> SomeConstrainedValue ConstantScope)
-> Instr inp out
-> Instr inp out
modifyTypicalFailWith :: (MText -> SomeConstrainedValue ConstantScope)
-> Instr inp out -> Instr inp out
modifyTypicalFailWith MText -> SomeConstrainedValue ConstantScope
f = Instr inp out -> Instr inp out
forall (inp :: [T]) (out :: [T]).
HasCallStack =>
Instr inp out -> Instr inp out
modifyTypicalFailWith' (Instr inp out -> Instr inp out)
-> (Instr inp out -> Instr inp out)
-> Instr inp out
-> Instr inp out
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instr inp out -> Instr inp out
forall (inp :: [T]) (out :: [T]). Instr inp out -> Instr inp out
linearizeLeft
where
modifyTypicalFailWith' :: HasCallStack => Instr inp out -> Instr inp out
modifyTypicalFailWith' :: Instr inp out -> Instr inp out
modifyTypicalFailWith' =
\case
Seq Instr inp b
i1 Instr b out
FAILWITH ->
case Instr inp b
i1 of
PUSH Value' Instr t
v -> Value' Instr t -> Instr inp out
forall (v :: T) (inp :: [T]) (out :: [T]).
(HasCallStack, ConstantScope v) =>
Value v -> Instr inp out
onPush Value' Instr t
v
Seq Instr inp b
i0 (PUSH Value' Instr t
v) -> Instr inp b -> Instr b out -> Instr inp out
forall (a :: [T]) (b :: [T]) (c :: [T]).
Instr a b -> Instr b c -> Instr a c
Seq Instr inp b
i0 (Value' Instr t -> Instr b out
forall (v :: T) (inp :: [T]) (out :: [T]).
(HasCallStack, ConstantScope v) =>
Value v -> Instr inp out
onPush Value' Instr t
v)
Seq (PUSH Value' Instr t
v) Instr b b
PAIR
| Value' Instr t
_ :: Value a <- Value' Instr t
v
, _ :: Instr (b ': s) ('TPair a b ': s) <- Instr inp b
i1 ->
case SingI ('TPair t b) => Sing ('TPair t b)
forall k (a :: k). SingI a => Sing a
sing @('TPair a b) of
STPair l r -> Sing t -> (SingI t => Instr inp out) -> Instr inp out
forall k (n :: k) r. Sing n -> (SingI n => r) -> r
withSingI Sing t
Sing n
l ((SingI t => Instr inp out) -> Instr inp out)
-> (SingI t => Instr inp out) -> Instr inp out
forall a b. (a -> b) -> a -> b
$ Sing b -> (SingI b => Instr inp out) -> Instr inp out
forall k (n :: k) r. Sing n -> (SingI n => r) -> r
withSingI Sing b
Sing n
r ((SingI b => Instr inp out) -> Instr inp out)
-> (SingI b => Instr inp out) -> Instr inp out
forall a b. (a -> b) -> a -> b
$ case Value' Instr t -> Maybe MText
forall (t :: T). Value t -> Maybe MText
isStringValue Value' Instr t
v of
Just (MText -> SomeConstrainedValue ConstantScope
f -> SomeConstrainedValue Value t
v') ->
Value t -> Instr (b : s) (t : b : s)
forall (t :: T) (s :: [T]).
ConstantScope t =>
Value' Instr t -> Instr s (t : s)
PUSH Value t
v' Instr (b : s) (t : b : s)
-> Instr (t : b : s) ('TPair t b : s)
-> Instr (b : s) ('TPair t b : s)
forall (a :: [T]) (b :: [T]) (c :: [T]).
Instr a b -> Instr b c -> Instr a c
`Seq` Instr (t : b : s) ('TPair t b : s)
forall (i :: [T]) (o :: [T]) (a :: T) (b :: T) (s :: [T]).
(i ~ (a : b : s), o ~ ('TPair a b : s)) =>
Instr i o
PAIR Instr (b : s) ('TPair t b : s)
-> Instr ('TPair t b : s) out -> Instr (b : s) out
forall (a :: [T]) (b :: [T]) (c :: [T]).
Instr a b -> Instr b c -> Instr a c
`Seq` Instr ('TPair t b : s) out
forall (a :: T) (s :: [T]) (t :: [T]).
(SingI a, ConstantScope a) =>
Instr (a : s) t
FAILWITH
Maybe MText
Nothing ->
Value' Instr t -> Instr (b : s) (t : b : s)
forall (t :: T) (s :: [T]).
ConstantScope t =>
Value' Instr t -> Instr s (t : s)
PUSH Value' Instr t
v Instr (b : s) (t : b : s)
-> Instr (t : b : s) ('TPair t b : s)
-> Instr (b : s) ('TPair t b : s)
forall (a :: [T]) (b :: [T]) (c :: [T]).
Instr a b -> Instr b c -> Instr a c
`Seq` Instr (t : b : s) ('TPair t b : s)
forall (i :: [T]) (o :: [T]) (a :: T) (b :: T) (s :: [T]).
(i ~ (a : b : s), o ~ ('TPair a b : s)) =>
Instr i o
PAIR Instr (b : s) ('TPair t b : s)
-> Instr ('TPair t b : s) out -> Instr (b : s) out
forall (a :: [T]) (b :: [T]) (c :: [T]).
Instr a b -> Instr b c -> Instr a c
`Seq` Instr ('TPair t b : s) out
forall (a :: T) (s :: [T]) (t :: [T]).
(SingI a, ConstantScope a) =>
Instr (a : s) t
FAILWITH
Seq (Seq Instr inp b
i0 (PUSH Value' Instr t
v)) Instr b b
PAIR
| Value' Instr t
_ :: Value a <- Value' Instr t
v
, _ :: Instr s0 ('TPair a b ': s) <- Instr inp b
i1 ->
case SingI ('TPair t b) => Sing ('TPair t b)
forall k (a :: k). SingI a => Sing a
sing @('TPair a b) of
STPair l r -> Sing t -> (SingI t => Instr inp out) -> Instr inp out
forall k (n :: k) r. Sing n -> (SingI n => r) -> r
withSingI Sing t
Sing n
l ((SingI t => Instr inp out) -> Instr inp out)
-> (SingI t => Instr inp out) -> Instr inp out
forall a b. (a -> b) -> a -> b
$ Sing b -> (SingI b => Instr inp out) -> Instr inp out
forall k (n :: k) r. Sing n -> (SingI n => r) -> r
withSingI Sing b
Sing n
r ((SingI b => Instr inp out) -> Instr inp out)
-> (SingI b => Instr inp out) -> Instr inp out
forall a b. (a -> b) -> a -> b
$ Instr inp b -> Instr b out -> Instr inp out
forall (a :: [T]) (b :: [T]) (c :: [T]).
Instr a b -> Instr b c -> Instr a c
Seq Instr inp b
i0 (Instr b out -> Instr inp out) -> Instr b out -> Instr inp out
forall a b. (a -> b) -> a -> b
$ case Value' Instr t -> Maybe MText
forall (t :: T). Value t -> Maybe MText
isStringValue Value' Instr t
v of
Just (MText -> SomeConstrainedValue ConstantScope
f -> SomeConstrainedValue Value t
v') ->
Value t -> Instr b (t : b)
forall (t :: T) (s :: [T]).
ConstantScope t =>
Value' Instr t -> Instr s (t : s)
PUSH Value t
v' Instr b (t : b)
-> Instr (t : b) ('TPair t b : s) -> Instr b ('TPair t b : s)
forall (a :: [T]) (b :: [T]) (c :: [T]).
Instr a b -> Instr b c -> Instr a c
`Seq` Instr (t : b) ('TPair t b : s)
forall (i :: [T]) (o :: [T]) (a :: T) (b :: T) (s :: [T]).
(i ~ (a : b : s), o ~ ('TPair a b : s)) =>
Instr i o
PAIR Instr b ('TPair t b : s)
-> Instr ('TPair t b : s) out -> Instr b out
forall (a :: [T]) (b :: [T]) (c :: [T]).
Instr a b -> Instr b c -> Instr a c
`Seq` Instr ('TPair t b : s) out
forall (a :: T) (s :: [T]) (t :: [T]).
(SingI a, ConstantScope a) =>
Instr (a : s) t
FAILWITH
Maybe MText
Nothing ->
Value' Instr t -> Instr b (t : b)
forall (t :: T) (s :: [T]).
ConstantScope t =>
Value' Instr t -> Instr s (t : s)
PUSH Value' Instr t
v Instr b (t : b)
-> Instr (t : b) ('TPair t b : s) -> Instr b ('TPair t b : s)
forall (a :: [T]) (b :: [T]) (c :: [T]).
Instr a b -> Instr b c -> Instr a c
`Seq` Instr (t : b) ('TPair t b : s)
forall (i :: [T]) (o :: [T]) (a :: T) (b :: T) (s :: [T]).
(i ~ (a : b : s), o ~ ('TPair a b : s)) =>
Instr i o
PAIR Instr b ('TPair t b : s)
-> Instr ('TPair t b : s) out -> Instr b out
forall (a :: [T]) (b :: [T]) (c :: [T]).
Instr a b -> Instr b c -> Instr a c
`Seq` Instr ('TPair t b : s) out
forall (a :: T) (s :: [T]) (t :: [T]).
(SingI a, ConstantScope a) =>
Instr (a : s) t
FAILWITH
Instr inp b
_ -> Instr inp b -> Instr b out -> Instr inp out
forall (a :: [T]) (b :: [T]) (c :: [T]).
Instr a b -> Instr b c -> Instr a c
Seq Instr inp b
i1 Instr b out
forall (a :: T) (s :: [T]) (t :: [T]).
(SingI a, ConstantScope a) =>
Instr (a : s) t
FAILWITH
Instr inp out
i -> Instr inp out
i
onPush ::
(HasCallStack, ConstantScope v) => Value v -> Instr inp out
onPush :: Value v -> Instr inp out
onPush Value v
v = case Value v -> Maybe TypicalFailWith
forall (t :: T).
ConstantScope t =>
Value t -> Maybe TypicalFailWith
isTypicalErrorConstant Value v
v of
Just (FailWithString (MText -> SomeConstrainedValue ConstantScope
f -> SomeConstrainedValue Value t
v')) -> Value t -> Instr inp (t : inp)
forall (t :: T) (s :: [T]).
ConstantScope t =>
Value' Instr t -> Instr s (t : s)
PUSH Value t
v' Instr inp (t : inp) -> Instr (t : inp) out -> Instr inp out
forall (a :: [T]) (b :: [T]) (c :: [T]).
Instr a b -> Instr b c -> Instr a c
`Seq` Instr (t : inp) out
forall (a :: T) (s :: [T]) (t :: [T]).
(SingI a, ConstantScope a) =>
Instr (a : s) t
FAILWITH
Just (FailWithConstantPair (MText -> SomeConstrainedValue ConstantScope
f -> SomeConstrainedValue Value t
v') (SomeConstrainedValue Value t
arg)) ->
Value' Instr ('TPair t t) -> Instr inp ('TPair t t : inp)
forall (t :: T) (s :: [T]).
ConstantScope t =>
Value' Instr t -> Instr s (t : s)
PUSH ((Value t, Value t) -> Value' Instr ('TPair t t)
forall (l :: T) (r :: T) (instr :: [T] -> [T] -> *).
(Value' instr l, Value' instr r) -> Value' instr ('TPair l r)
VPair (Value t
v', Value t
arg)) Instr inp ('TPair t t : inp)
-> Instr ('TPair t t : inp) out -> Instr inp out
forall (a :: [T]) (b :: [T]) (c :: [T]).
Instr a b -> Instr b c -> Instr a c
`Seq` Instr ('TPair t t : inp) out
forall (a :: T) (s :: [T]) (t :: [T]).
(SingI a, ConstantScope a) =>
Instr (a : s) t
FAILWITH
Just TypicalFailWith
_ -> Text -> Instr inp out
forall a. HasCallStack => Text -> a
error Text
"Unexpected TypicalFailWith"
Maybe TypicalFailWith
Nothing -> Value v -> Instr inp (v : inp)
forall (t :: T) (s :: [T]).
ConstantScope t =>
Value' Instr t -> Instr s (t : s)
PUSH Value v
v Instr inp (v : inp) -> Instr (v : inp) out -> Instr inp out
forall (a :: [T]) (b :: [T]) (c :: [T]).
Instr a b -> Instr b c -> Instr a c
`Seq` Instr (v : inp) out
forall (a :: T) (s :: [T]) (t :: [T]).
(SingI a, ConstantScope a) =>
Instr (a : s) t
FAILWITH