Instances.hs

-- 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 = unsafeMkAnnotation . toText

instance IsString MText where
  fromString = unsafeMkMText . toText

instance Num Mutez where

  (+) = unsafeAddMutez

  (-) = unsafeSubMutez

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

  abs = unsafeMkMutez . abs . unMutez

  signum = unsafeMkMutez . signum . unMutez

  fromInteger = unsafeMkMutez . 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 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

-- | 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' = fmap withoutIcs

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

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

instance HasInstrCallStack U.Value where
  withoutIcs = \case
    U.ValueLambda ops -> U.ValueLambda $ withoutIcs' ops
    v                 -> v