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

{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cleveland.Instances
  ( HasInstrCallStack (..)
  ) where

import Fmt (Buildable(..), tupleF)
import qualified GHC.Num (fromInteger)
import Morley.Michelson.Text (MText, unsafeMkMText)
import Morley.Michelson.Typed.Haskell.Value (BigMap(..))
import qualified Morley.Michelson.Untyped as U
import Morley.Michelson.Untyped.Annotation (Annotation(..), unsafeMkAnnotation)
import Morley.Tezos.Core (Mutez(..), unsafeAddMutez, unsafeMkMutez, unsafeMulMutez, unsafeSubMutez)

instance IsString (Annotation tag) where
  fromString :: String -> Annotation tag
fromString = Text -> Annotation tag
forall k (a :: k). HasCallStack => Text -> Annotation a
unsafeMkAnnotation (Text -> Annotation tag)
-> (String -> Text) -> String -> Annotation tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText

instance IsString MText where
  fromString :: String -> MText
fromString = HasCallStack => Text -> MText
Text -> MText
unsafeMkMText (Text -> MText) -> (String -> Text) -> String -> MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText

instance Num Mutez where

  + :: Mutez -> Mutez -> Mutez
(+) = HasCallStack => Mutez -> Mutez -> Mutez
Mutez -> Mutez -> Mutez
unsafeAddMutez

  (-) = HasCallStack => Mutez -> Mutez -> Mutez
Mutez -> Mutez -> Mutez
unsafeSubMutez

  * :: Mutez -> Mutez -> Mutez
(*) Mutez
a Mutez
b = Mutez -> Natural -> Mutez
unsafeMulMutez Mutez
a (Natural -> Mutez) -> Natural -> Mutez
forall a b. (a -> b) -> a -> b
$ Word64 -> Natural
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
fromIntegral (Word64 -> Natural) -> Word64 -> Natural
forall a b. (a -> b) -> a -> b
$ Mutez -> Word64
unMutez Mutez
b

  abs :: Mutez -> Mutez
abs = HasCallStack => Word64 -> Mutez
Word64 -> Mutez
unsafeMkMutez (Word64 -> Mutez) -> (Mutez -> Word64) -> Mutez -> Mutez
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word64
forall a. Num a => a -> a
abs (Word64 -> Word64) -> (Mutez -> Word64) -> Mutez -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mutez -> Word64
unMutez

  signum :: Mutez -> Mutez
signum = HasCallStack => Word64 -> Mutez
Word64 -> Mutez
unsafeMkMutez (Word64 -> Mutez) -> (Mutez -> Word64) -> Mutez -> Mutez
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word64
forall a. Num a => a -> a
signum (Word64 -> Word64) -> (Mutez -> Word64) -> Mutez -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mutez -> Word64
unMutez

  fromInteger :: Integer -> Mutez
fromInteger = HasCallStack => Word64 -> Mutez
Word64 -> Mutez
unsafeMkMutez (Word64 -> Mutez) -> (Integer -> Word64) -> Integer -> Mutez
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word64
forall a. (HasCallStack, Integral a) => Integer -> a
fromInteger

deriving newtype instance Real Mutez
deriving newtype instance Integral Mutez

-- | This instance is declared in this test module because it's not lawful,
-- i.e. it breaks the right and left-identity laws:
--
-- @
-- x = BigMap (Just 1) mempty :: BigMap Int Int
-- bmId (x <> mempty) == bmId x
-- False
-- bmId (mempty <> x) == bmId x
-- False
-- @
instance Ord k => Monoid (BigMap k v) where
  mempty :: BigMap k v
mempty = Maybe (BigMapId k v) -> Map k v -> BigMap k v
forall k v. Maybe (BigMapId k v) -> Map k v -> BigMap k v
BigMap Maybe (BigMapId k v)
forall a. Maybe a
Nothing Map k v
forall a. Monoid a => a
mempty

-- | This instance is declared in this test module because it's not lawful,
-- i.e. it breaks the substitutivity law.
--
-- This laws says that @x == y@ implies @f x == f y@, however:
--
-- @
-- x = BigMap (Just 1) mempty :: BigMap Int Int
-- y = BigMap (Just 2) mempty :: BigMap Int Int
-- x == y
-- True
-- bmId x == bmId y
-- False
-- @
instance (Eq k, Eq v) => Eq (BigMap k v) where
  BigMap Maybe (BigMapId k v)
_ Map k v
bm1 == :: BigMap k v -> BigMap k v -> Bool
== BigMap Maybe (BigMapId k v)
_ Map k v
bm2 = Map k v
bm1 Map k v -> Map k v -> Bool
forall a. Eq a => a -> a -> Bool
== Map k v
bm2

instance (Buildable a, Buildable b) => Buildable (a, b) where build :: (a, b) -> Builder
build = (a, b) -> Builder
forall a. TupleF a => a -> Builder
tupleF
instance (Buildable a, Buildable b, Buildable c) => Buildable (a, b, c) where build :: (a, b, c) -> Builder
build = (a, b, c) -> Builder
forall a. TupleF a => a -> Builder
tupleF
instance (Buildable a, Buildable b, Buildable c, Buildable d) => Buildable (a, b, c, d) where build :: (a, b, c, d) -> Builder
build = (a, b, c, d) -> Builder
forall a. TupleF a => a -> Builder
tupleF

-- | Class of types with t'Morley.Michelson.ErrorPos.InstrCallStack' allowing to remove it.
-- Can be used in tests when we want to compare only values without callstack.
class HasInstrCallStack a where
  withoutIcs :: a -> a

withoutIcs' :: (Functor f, HasInstrCallStack a) =>  f a -> f a
withoutIcs' :: f a -> f a
withoutIcs' = (a -> a) -> f a -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. HasInstrCallStack a => a -> a
withoutIcs

instance HasInstrCallStack U.ExpandedOp where
  withoutIcs :: ExpandedOp -> ExpandedOp
withoutIcs = \case
    U.SeqEx [ExpandedOp]
ops'     -> [ExpandedOp] -> ExpandedOp
U.SeqEx ([ExpandedOp] -> ExpandedOp) -> [ExpandedOp] -> ExpandedOp
forall a b. (a -> b) -> a -> b
$ [ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops'
    U.WithSrcEx InstrCallStack
_ ExpandedOp
op -> ExpandedOp -> ExpandedOp
forall a. HasInstrCallStack a => a -> a
withoutIcs ExpandedOp
op
    U.PrimEx ExpandedInstr
instr   -> ExpandedInstr -> ExpandedOp
U.PrimEx (ExpandedInstr -> ExpandedOp) -> ExpandedInstr -> ExpandedOp
forall a b. (a -> b) -> a -> b
$ ExpandedInstr -> ExpandedInstr
forall a. HasInstrCallStack a => a -> a
withoutIcs ExpandedInstr
instr

instance HasInstrCallStack U.ExpandedInstr where
  withoutIcs :: ExpandedInstr -> ExpandedInstr
withoutIcs = \case
    U.PUSH VarAnn
va Ty
ty Value' ExpandedOp
v              -> VarAnn -> Ty -> Value' ExpandedOp -> ExpandedInstr
forall op. VarAnn -> Ty -> Value' op -> InstrAbstract op
U.PUSH VarAnn
va Ty
ty (Value' ExpandedOp -> ExpandedInstr)
-> Value' ExpandedOp -> ExpandedInstr
forall a b. (a -> b) -> a -> b
$ Value' ExpandedOp -> Value' ExpandedOp
forall a. HasInstrCallStack a => a -> a
withoutIcs Value' ExpandedOp
v
    U.IF_NONE [ExpandedOp]
ops1 [ExpandedOp]
ops2         -> [ExpandedOp] -> [ExpandedOp] -> ExpandedInstr
forall op. [op] -> [op] -> InstrAbstract op
U.IF_NONE ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops1) ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops2)
    U.IF_LEFT [ExpandedOp]
ops1 [ExpandedOp]
ops2         -> [ExpandedOp] -> [ExpandedOp] -> ExpandedInstr
forall op. [op] -> [op] -> InstrAbstract op
U.IF_LEFT ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops1) ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops2)
    U.IF_CONS [ExpandedOp]
ops1 [ExpandedOp]
ops2         -> [ExpandedOp] -> [ExpandedOp] -> ExpandedInstr
forall op. [op] -> [op] -> InstrAbstract op
U.IF_CONS ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops1) ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops2)
    U.MAP VarAnn
va [ExpandedOp]
ops                -> VarAnn -> [ExpandedOp] -> ExpandedInstr
forall op. VarAnn -> [op] -> InstrAbstract op
U.MAP VarAnn
va ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops)
    U.ITER [ExpandedOp]
ops                  -> [ExpandedOp] -> ExpandedInstr
forall op. [op] -> InstrAbstract op
U.ITER ([ExpandedOp] -> ExpandedInstr) -> [ExpandedOp] -> ExpandedInstr
forall a b. (a -> b) -> a -> b
$ [ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops
    U.IF [ExpandedOp]
ops1 [ExpandedOp]
ops2              -> [ExpandedOp] -> [ExpandedOp] -> ExpandedInstr
forall op. [op] -> [op] -> InstrAbstract op
U.IF ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops1) ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops2)
    U.LOOP [ExpandedOp]
ops                  -> [ExpandedOp] -> ExpandedInstr
forall op. [op] -> InstrAbstract op
U.LOOP ([ExpandedOp] -> ExpandedInstr) -> [ExpandedOp] -> ExpandedInstr
forall a b. (a -> b) -> a -> b
$ [ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops
    U.LOOP_LEFT [ExpandedOp]
ops             -> [ExpandedOp] -> ExpandedInstr
forall op. [op] -> InstrAbstract op
U.LOOP_LEFT ([ExpandedOp] -> ExpandedInstr) -> [ExpandedOp] -> ExpandedInstr
forall a b. (a -> b) -> a -> b
$ [ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops
    U.LAMBDA VarAnn
va Ty
ty1 Ty
ty2 [ExpandedOp]
ops     -> VarAnn -> Ty -> Ty -> [ExpandedOp] -> ExpandedInstr
forall op. VarAnn -> Ty -> Ty -> [op] -> InstrAbstract op
U.LAMBDA VarAnn
va Ty
ty1 Ty
ty2 ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops)
    U.DIP [ExpandedOp]
ops                   -> [ExpandedOp] -> ExpandedInstr
forall op. [op] -> InstrAbstract op
U.DIP ([ExpandedOp] -> ExpandedInstr) -> [ExpandedOp] -> ExpandedInstr
forall a b. (a -> b) -> a -> b
$ [ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops
    U.DIPN Word
n [ExpandedOp]
ops -> Word -> [ExpandedOp] -> ExpandedInstr
forall op. Word -> [op] -> InstrAbstract op
U.DIPN Word
n ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' [ExpandedOp]
ops)
    U.CREATE_CONTRACT VarAnn
va1 VarAnn
va2 Contract' ExpandedOp
c ->
      VarAnn -> VarAnn -> Contract' ExpandedOp -> ExpandedInstr
forall op. VarAnn -> VarAnn -> Contract' op -> InstrAbstract op
U.CREATE_CONTRACT VarAnn
va1 VarAnn
va2 ((ExpandedOp -> ExpandedOp)
-> Contract' ExpandedOp -> Contract' ExpandedOp
forall op. (op -> op) -> Contract' op -> Contract' op
U.mapContractCode ExpandedOp -> ExpandedOp
forall a. HasInstrCallStack a => a -> a
withoutIcs Contract' ExpandedOp
c)
    ExpandedInstr
i                           -> ExpandedInstr
i

instance HasInstrCallStack U.Value where
  withoutIcs :: Value' ExpandedOp -> Value' ExpandedOp
withoutIcs = \case
    U.ValueLambda NonEmpty ExpandedOp
ops -> NonEmpty ExpandedOp -> Value' ExpandedOp
forall op. NonEmpty op -> Value' op
U.ValueLambda (NonEmpty ExpandedOp -> Value' ExpandedOp)
-> NonEmpty ExpandedOp -> Value' ExpandedOp
forall a b. (a -> b) -> a -> b
$ NonEmpty ExpandedOp -> NonEmpty ExpandedOp
forall (f :: * -> *) a.
(Functor f, HasInstrCallStack a) =>
f a -> f a
withoutIcs' NonEmpty ExpandedOp
ops
    Value' ExpandedOp
v                 -> Value' ExpandedOp
v