-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- NOTE this pragmas.
-- We disable some wargnings for the sake of speed up.
-- Write code with care.
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}

-- | Typical usages of FAILWITH instruction.

module Michelson.FailPattern
  ( TypicalFailWith
  , typicalFailWithTag
  , isTypicalFailWith
  , modifyTypicalFailWith
  ) where

import Data.Singletons (withSingI)

import Michelson.Text (MText)
import Michelson.Typed

-- | This data type captures typical ways to use `FAILWITH` instruction.
-- Each constructor corresponds to a usage pattern.
data TypicalFailWith
  = FailWithString MText
  -- ^ Push a constant string and fail with it.
  | FailWithConstantPair MText (SomeConstrainedValue ConstantScope)
  -- ^ Push a constant pair where the first item is a string and the
  -- second one is an arbitrary constant. Fail afterwards.
  | FailWithStackValue MText
  -- ^ Push a constant string and apply the 'PAIR' instruction, then fail.

-- | Extract error tag out of 'TypicalFailWith'.
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

-- | Check whether given instruction ends with a typical 'FAILWITH'
-- usage. It does not recursively check instructions that can be
-- passed to other instructions.
--
-- The instruction MUST be linearized to the left (see 'linearizeLeft').
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 =
      -- We need to pattern match to deduce `singI` for second item of the pair.
      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

-- | If given instruction ends with a typical 'FAILWITH' usage, modify
-- the tag used there using given transformation function. It can
-- return any value, not necessarily a string.
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)

            -- It is quite hard to move the body of these very similar
            -- cases into a separate function because involved types
            -- are quite sophisticated.
            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