Instances.hs

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

{-# OPTIONS_GHC -Wno-orphans #-}

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

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

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 (Alias(..))
import Morley.Tezos.Core (Mutez(..), mkMutez, unsafeAddMutez, unsafeMulMutez, unsafeSubMutez)

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 () where build _ = "()"

instance (Buildable a, Buildable b) => Buildable (a, b) where build = tupleF
instance (Buildable a, Buildable b, Buildable c) => Buildable (a, b, c) where
  build = tupleF
instance (Buildable a, Buildable b, Buildable c, Buildable d) =>
  Buildable (a, b, c, d) where build = tupleF
instance (Buildable a, Buildable b, Buildable c, Buildable d, Buildable e) =>
    Buildable (a, b, c, d, e) where build = tupleF
instance (Buildable a, Buildable b, Buildable c,
          Buildable d, Buildable e, Buildable f) =>
          Buildable (a, b, c, d, e, f) where build = 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 = 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 = tupleF

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.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 (U.mapContractCode 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 (Buildable a, Buildable b) => Buildable (Either a b) where
  build = eitherF

instance IsString Alias where
  fromString = Alias . fromString