-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# OPTIONS_GHC -Wno-orphans #-}

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

import Data.Default (Default(..))
import Fmt (Buildable(..), eitherF, hexF, tupleF, (+|), (|+))
import GHC.Num qualified (fromInteger)
import Test.Tasty.Runners (FailureReason(..))
import Time (Time)

import Lorentz.Entrypoints.Core (EntrypointRef(..), NiceEntrypointName)
import Morley.Michelson.Text (MText, mkMText)
import Morley.Michelson.Typed.Haskell.Value (BigMap(..))
import Morley.Michelson.Untyped qualified as U
import Morley.Michelson.Untyped.Annotation (Annotation(..), mkAnnotation)
import Morley.Tezos.Address.Alias
import Morley.Tezos.Core (Mutez(..), mkMutez, unsafeAddMutez, unsafeMulMutez, unsafeSubMutez)
import Morley.Util.TypeLits (symbolValT')

instance IsString (Annotation tag) where
  fromString :: String -> Annotation tag
fromString = Either Text (Annotation tag) -> Annotation tag
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either Text (Annotation tag) -> Annotation tag)
-> (String -> Either Text (Annotation tag))
-> String
-> Annotation tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (Annotation tag)
forall {k} (a :: k). Text -> Either Text (Annotation a)
mkAnnotation (Text -> Either Text (Annotation tag))
-> (String -> Text) -> String -> Either Text (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 = Either Text MText -> MText
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either Text MText -> MText)
-> (String -> Either Text MText) -> String -> MText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text MText
mkMText (Text -> Either Text MText)
-> (String -> Text) -> String -> Either Text 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
$ Word63 -> Natural
forall a b. (Integral a, Integral b, CheckIntSubType a b) => a -> b
fromIntegral (Word63 -> Natural) -> Word63 -> Natural
forall a b. (a -> b) -> a -> b
$ Mutez -> Word63
unMutez Mutez
b

  abs :: Mutez -> Mutez
abs = Either Text Mutez -> Mutez
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either Text Mutez -> Mutez)
-> (Mutez -> Either Text Mutez) -> Mutez -> Mutez
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word63 -> Either Text Mutez
forall i. Integral i => i -> Either Text Mutez
mkMutez (Word63 -> Either Text Mutez)
-> (Mutez -> Word63) -> Mutez -> Either Text Mutez
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word63 -> Word63
forall a. Num a => a -> a
abs (Word63 -> Word63) -> (Mutez -> Word63) -> Mutez -> Word63
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mutez -> Word63
unMutez

  signum :: Mutez -> Mutez
signum = Either Text Mutez -> Mutez
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either Text Mutez -> Mutez)
-> (Mutez -> Either Text Mutez) -> Mutez -> Mutez
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word63 -> Either Text Mutez
forall i. Integral i => i -> Either Text Mutez
mkMutez (Word63 -> Either Text Mutez)
-> (Mutez -> Word63) -> Mutez -> Either Text Mutez
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word63 -> Word63
forall a. Num a => a -> a
signum (Word63 -> Word63) -> (Mutez -> Word63) -> Mutez -> Word63
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mutez -> Word63
unMutez

  fromInteger :: Integer -> Mutez
fromInteger = Either Text Mutez -> Mutez
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either Text Mutez -> Mutez)
-> (Integer -> Either Text Mutez) -> Integer -> Mutez
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Integral i => i -> Either Text Mutez
mkMutez @Word64 (Word64 -> Either Text Mutez)
-> (Integer -> Word64) -> Integer -> Either Text 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 () where build :: () -> Builder
build ()
_ = Builder
"()"

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
instance (Buildable a, Buildable b, Buildable c, Buildable d, Buildable e) =>
    Buildable (a, b, c, d, e) where build :: (a, b, c, d, e) -> Builder
build = (a, b, c, d, e) -> Builder
forall a. TupleF a => a -> Builder
tupleF
instance (Buildable a, Buildable b, Buildable c,
          Buildable d, Buildable e, Buildable f) =>
          Buildable (a, b, c, d, e, f) where build :: (a, b, c, d, e, f) -> Builder
build = (a, b, c, d, e, f) -> Builder
forall a. TupleF a => a -> Builder
tupleF
instance (Buildable a, Buildable b, Buildable c,
          Buildable d, Buildable e, Buildable f,
          Buildable g) => Buildable (a, b, c, d, e, f, g) where build :: (a, b, c, d, e, f, g) -> Builder
build = (a, b, c, d, e, f, g) -> Builder
forall a. TupleF a => a -> Builder
tupleF
instance (Buildable a, Buildable b, Buildable c,
          Buildable d, Buildable e, Buildable f,
          Buildable g, Buildable h) =>
          Buildable (a, b, c, d, e, f, g, h) where build :: (a, b, c, d, e, f, g, h) -> Builder
build = (a, b, c, d, e, f, g, h) -> Builder
forall a. TupleF a => a -> Builder
tupleF

instance Buildable ByteString where build :: ByteString -> Builder
build ByteString
bs = Builder
"0x" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
forall a. FormatAsHex a => a -> Builder
hexF ByteString
bs
instance Buildable LByteString where build :: LByteString -> Builder
build LByteString
bs = Builder
"0x" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> LByteString -> Builder
forall a. FormatAsHex a => a -> Builder
hexF LByteString
bs

-- | Class of types with t'Morley.Michelson.ErrorPos.ErrorSrcPos' allowing to remove it.
-- Can be used in tests when we want to compare only values without source positions.
class HasErrorSrcPos a where
  withoutEsp :: a -> a

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

instance HasErrorSrcPos U.ExpandedOp where
  withoutEsp :: ExpandedOp -> ExpandedOp
withoutEsp = \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, HasErrorSrcPos a) => f a -> f a
withoutEsp' [ExpandedOp]
ops'
    U.WithSrcEx ErrorSrcPos
_ ExpandedOp
op -> ExpandedOp -> ExpandedOp
forall a. HasErrorSrcPos a => a -> a
withoutEsp 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. HasErrorSrcPos a => a -> a
withoutEsp ExpandedInstr
instr

instance HasErrorSrcPos U.ExpandedInstr where
  withoutEsp :: ExpandedInstr -> ExpandedInstr
withoutEsp = \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. HasErrorSrcPos a => a -> a
withoutEsp 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, HasErrorSrcPos a) => f a -> f a
withoutEsp' [ExpandedOp]
ops1) ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a. (Functor f, HasErrorSrcPos a) => f a -> f a
withoutEsp' [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, HasErrorSrcPos a) => f a -> f a
withoutEsp' [ExpandedOp]
ops1) ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a. (Functor f, HasErrorSrcPos a) => f a -> f a
withoutEsp' [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, HasErrorSrcPos a) => f a -> f a
withoutEsp' [ExpandedOp]
ops1) ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a. (Functor f, HasErrorSrcPos a) => f a -> f a
withoutEsp' [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, HasErrorSrcPos a) => f a -> f a
withoutEsp' [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, HasErrorSrcPos a) => f a -> f a
withoutEsp' [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, HasErrorSrcPos a) => f a -> f a
withoutEsp' [ExpandedOp]
ops1) ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a. (Functor f, HasErrorSrcPos a) => f a -> f a
withoutEsp' [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, HasErrorSrcPos a) => f a -> f a
withoutEsp' [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, HasErrorSrcPos a) => f a -> f a
withoutEsp' [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, HasErrorSrcPos a) => f a -> f a
withoutEsp' [ExpandedOp]
ops)
    U.LAMBDA_REC VarAnn
va Ty
ty1 Ty
ty2 [ExpandedOp]
ops -> VarAnn -> Ty -> Ty -> [ExpandedOp] -> ExpandedInstr
forall op. VarAnn -> Ty -> Ty -> [op] -> InstrAbstract op
U.LAMBDA_REC VarAnn
va Ty
ty1 Ty
ty2 ([ExpandedOp] -> [ExpandedOp]
forall (f :: * -> *) a. (Functor f, HasErrorSrcPos a) => f a -> f a
withoutEsp' [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, HasErrorSrcPos a) => f a -> f a
withoutEsp' [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, HasErrorSrcPos a) => f a -> f a
withoutEsp' [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
forall a. HasErrorSrcPos a => a -> a
withoutEsp (ExpandedOp -> ExpandedOp)
-> Contract' ExpandedOp -> Contract' ExpandedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contract' ExpandedOp
c)
    ExpandedInstr
i                           -> ExpandedInstr
i

instance HasErrorSrcPos U.Value where
  withoutEsp :: Value' ExpandedOp -> Value' ExpandedOp
withoutEsp = \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, HasErrorSrcPos a) => f a -> f a
withoutEsp' NonEmpty ExpandedOp
ops
    Value' ExpandedOp
v                 -> Value' ExpandedOp
v

-- We don't want to depend on o-clock in morley-prelude, hence we're defining
-- the instance here.
type instance PrettyShow (Time _) = ()

instance Buildable FailureReason where
  build :: FailureReason -> Builder
build = \case
    FailureReason
TestFailed -> Builder
"Test failed"
    TestThrewException SomeException
e -> Builder
"Test threw exception: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e String -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
    TestTimedOut Integer
s -> Builder
"Test timed out: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Integer
s Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
    FailureReason
TestDepFailed -> Builder
"Test skipped because its dependency failed"

instance (Buildable a, Buildable b) => Buildable (Either a b) where
  build :: Either a b -> Builder
build = Either a b -> Builder
forall a b. (Buildable a, Buildable b) => Either a b -> Builder
eitherF

instance mname ~ 'Nothing => Default (EntrypointRef mname) where
  def :: EntrypointRef mname
def = EntrypointRef mname
EntrypointRef 'Nothing
CallDefault

instance Default U.EpName where
  def :: EpName
def = EpName
U.DefEpName

instance NiceEntrypointName sym => IsLabel sym U.EpName where
  fromLabel :: EpName
fromLabel = Either String EpName -> EpName
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either String EpName -> EpName)
-> (Text -> Either String EpName) -> Text -> EpName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String EpName
U.buildEpName (Text -> EpName) -> Text -> EpName
forall a b. (a -> b) -> a -> b
$ forall (s :: Symbol). KnownSymbol s => Text
symbolValT' @sym

instance IsString ImplicitAlias where
  fromString :: String -> ImplicitAlias
fromString = Text -> ImplicitAlias
ImplicitAlias (Text -> ImplicitAlias)
-> (String -> Text) -> String -> ImplicitAlias
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString

instance IsString ContractAlias where
  fromString :: String -> ContractAlias
fromString = Text -> ContractAlias
ContractAlias (Text -> ContractAlias)
-> (String -> Text) -> String -> ContractAlias
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString