Instances.hs

-- 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(..), hexF, (+|), (|+))
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 = unsafe . mkAnnotation . toText

instance IsString MText where
  fromString = unsafe . mkMText . toText

instance Num Mutez where

  (+) = unsafeAddMutez

  (-) = unsafeSubMutez

  (*) a b = unsafeMulMutez a $ fromIntegral $ unMutez b

  abs = unsafe . mkMutez . abs . unMutez

  signum = unsafe . mkMutez . signum . unMutez

  fromInteger = unsafe . mkMutez @Word64 . 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 Nothing 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 _ bm1 == BigMap _ bm2 = bm1 == bm2

instance Buildable ByteString where build bs = "0x" <> hexF bs
instance Buildable LByteString where build bs = "0x" <> hexF 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' = fmap withoutEsp

instance HasErrorSrcPos U.ExpandedOp where
  withoutEsp = \case
    U.SeqEx ops'     -> U.SeqEx $ withoutEsp' ops'
    U.WithSrcEx _ op -> withoutEsp op
    U.PrimEx instr   -> U.PrimEx $ withoutEsp instr

instance HasErrorSrcPos U.ExpandedInstr where
  withoutEsp = \case
    U.PUSH va ty v              -> U.PUSH va ty $ withoutEsp v
    U.IF_NONE ops1 ops2         -> U.IF_NONE (withoutEsp' ops1) (withoutEsp' ops2)
    U.IF_LEFT ops1 ops2         -> U.IF_LEFT (withoutEsp' ops1) (withoutEsp' ops2)
    U.IF_CONS ops1 ops2         -> U.IF_CONS (withoutEsp' ops1) (withoutEsp' ops2)
    U.MAP va ops                -> U.MAP va (withoutEsp' ops)
    U.ITER ops                  -> U.ITER $ withoutEsp' ops
    U.IF ops1 ops2              -> U.IF (withoutEsp' ops1) (withoutEsp' ops2)
    U.LOOP ops                  -> U.LOOP $ withoutEsp' ops
    U.LOOP_LEFT ops             -> U.LOOP_LEFT $ withoutEsp' ops
    U.LAMBDA va ty1 ty2 ops     -> U.LAMBDA va ty1 ty2 (withoutEsp' ops)
    U.LAMBDA_REC va ty1 ty2 ops -> U.LAMBDA_REC va ty1 ty2 (withoutEsp' ops)
    U.DIP ops                   -> U.DIP $ withoutEsp' ops
    U.DIPN n ops -> U.DIPN n (withoutEsp' ops)
    U.CREATE_CONTRACT va1 va2 c -> U.CREATE_CONTRACT va1 va2 (withoutEsp <$> c)
    i                           -> i

instance HasErrorSrcPos U.Value where
  withoutEsp = \case
    U.ValueLambda ops -> U.ValueLambda $ withoutEsp' ops
    v                 -> 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 = \case
    TestFailed -> "Test failed"
    TestThrewException e -> "Test threw exception: " +| displayException e |+ ""
    TestTimedOut s -> "Test timed out: " +| s |+ ""
    TestDepFailed -> "Test skipped because its dependency failed"

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

instance Default U.EpName where
  def = U.DefEpName

instance NiceEntrypointName sym => IsLabel sym U.EpName where
  fromLabel = unsafe . U.buildEpName $ symbolValT' @sym

instance IsString ImplicitAlias where
  fromString = ImplicitAlias . fromString

instance IsString ContractAlias where
  fromString = ContractAlias . fromString