Entrypoints.hs

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

{-# OPTIONS_HADDOCK not-home #-}

-- | Internal utilities for unit testing.
module Test.Cleveland.Michelson.Internal.Entrypoints
  ( module Test.Cleveland.Michelson.Internal.Entrypoints
  ) where

import Data.Aeson (eitherDecode, encode)
import Data.Map qualified as Map
import Fmt (Buildable(..), blockMapF, isEmpty, nameF, pretty, unlinesF)
import Test.HUnit (Assertion, assertFailure)
import Test.Tasty (TestName, TestTree, testGroup)
import Test.Tasty.HUnit (testCase)

import Morley.Micheline (fromExpression, toExpression)
import Morley.Michelson.Parser (MichelsonSource(MSUnspecified))
import Morley.Michelson.Printer (printUntypedContract)
import Morley.Michelson.Runtime (parseExpandContract)
import Morley.Michelson.TypeCheck (TcTypeError, mkSomeParamType)
import Morley.Michelson.Untyped hiding (Contract)
import Morley.Michelson.Untyped qualified as U
import Morley.Util.MismatchError (MismatchError(..))
import Morley.Util.Named

-- | Convenience type synonym for a list of pairs of entrypoint names and types
type EPList = [(EpName, U.Ty)]

-- | A pattern syononym for no mismatches
pattern EPComparisonResultOK :: EPMismatch
pattern EPComparisonResultOK <- EPMismatch [] [] []

-- | Entrypoint comparison mismatch report
data EPMismatch = EPMismatch
  { epmmExtra :: EPList
    -- ^ Extraneous entrypoints, i.e. those that exist in the actual contract, but not
    -- in the specification
  , epmmMissing :: EPList
    -- ^ Missing entrypoints, i.e. those that exist in the specification, but not the
    -- actual contract
  , epmmTypeMismatch :: [(EpName, MismatchError Ty)]
    -- ^ Entrypoints that exist in both the contract and the specification, but types do not
    -- match.
  }

instance Buildable EPMismatch where
  build EPComparisonResultOK = "Entrypoints match specificaton"
  build EPMismatch{..} = nameF "Entrypoints do not match specification" $
    unlinesF $ filter (not . isEmpty) [extra, missing, typemm]
    where
    extra | null epmmExtra = mempty
          | otherwise = nameF "Extraneous entrypoints in the contract" $ blockMapF epmmExtra
    missing | null epmmMissing = mempty
            | otherwise = nameF "Missing entrypoints in the contract" $ blockMapF epmmMissing
    typemm | null epmmTypeMismatch = mempty
           | otherwise = nameF "Type mismatch in entrypoints" $ blockMapF epmmTypeMismatch

-- | Ignore extraneous entrypoint names in 'EPMismatch'. Essentially sets
-- 'epmmExtra' to @[]@.
ignoreExtraEntrypoints :: EPMismatch -> EPMismatch
ignoreExtraEntrypoints mm = mm{ epmmExtra = [] }

-- | Compare two sets of entrypoints. Accepts ordered 'Map's to enforce sorting order.
compareEntrypoints :: "expected" :! Map EpName U.Ty -> "actual" :! (Map EpName U.Ty) -> EPMismatch
compareEntrypoints (arg #expected -> expected) (arg #actual -> actual) = EPMismatch{..}
  where
    epmmExtra = Map.toList $ Map.difference actual expected
    epmmMissing = Map.toList $ Map.difference expected actual
    inBoth = Map.intersectionWith (,) expected actual
    epmmTypeMismatch = Map.toList $ flip Map.mapMaybe inBoth \(e, a) ->
      if e /= a
      then Just $ MkMismatchError { meExpected = e, meActual = a }
      else Nothing

-- | Check if the contract exactly matches the given entrypoints. Will report both
-- missing and extraneous entrypoint names, and type mismatches.
contractMatchesEntrypoints :: U.Contract -> Map EpName U.Ty -> Either TcTypeError EPMismatch
contractMatchesEntrypoints (contractParameter -> pt) expected = case mkSomeParamType pt of
  Right{} -> Right $ compareEntrypoints
    (#expected :! expected)
    (#actual :! mkEntrypointsMap wantsDefaultEp pt)
  Left err -> Left err
  where
    wantsDefaultEp
      | Map.member DefEpName expected = WithImplicitDefaultEp
      | otherwise = WithoutImplicitDefaultEp

-- | Check if the contract contains the entrypoints given in spec (with matching types).
-- Ignores any additional entrypoints present in the contract.
contractCoversEntrypoints :: U.Contract -> Map EpName U.Ty -> Either TcTypeError EPMismatch
contractCoversEntrypoints = second ignoreExtraEntrypoints ... contractMatchesEntrypoints

-- | Turn 'Either' 'TcTypeError' 'EPMismatch' into an 'Assertion'
assertEPComparisonSuccessful :: Either TcTypeError EPMismatch -> Assertion
assertEPComparisonSuccessful = \case
  Right EPComparisonResultOK -> pass
  Left tcerr -> assertFailure $ pretty tcerr
  Right mismatch -> assertFailure $ pretty mismatch

-- | Expect the contract to match with the entrypoints given in spec (with matching types).
-- Comparison is defined by the first argument; use @ignoreExtraEntrypoints@ for cover test,
-- @id@ for match test.
--
-- Also tests if the same holds after Michelson and Micheline roundtrips of the contract.
testContractEntrypoints
  :: (EPMismatch -> EPMismatch)
  -> TestName
  -> U.Contract
  -> Map EpName U.Ty
  -> TestTree
testContractEntrypoints compMode name contract spec
  = testGroup name
      [ testCase "Contract itself" $ test id
      , testCase "After Michelson roundtrip" $ test michelsonRoundtripContract
      , testCase "After Micheline roundtrip" $ test michelineRoundtripContract
      ]
  where test modifier = assertEPComparisonSuccessful $ second compMode $ contractMatchesEntrypoints (modifier contract) spec

-- | Round-trip the contract through Michelson text representation.
--
-- This is useful if you're intending to use the contract with Michelson text output and want to
-- check if that output satisfies tests (which /should be/ the same for internal representation
-- and output, but bugs happen)
michelsonRoundtripContract :: HasCallStack => U.Contract -> U.Contract
michelsonRoundtripContract contract =
  unsafe . parseExpandContract MSUnspecified . toText
    $ printUntypedContract True contract

-- | Round-trip the contract through Micheline JSON representation.
--
-- This is useful if you're intending to use the contract with Micheline JSON output and want to
-- check if that output satisfies tests (which /should be/ the same for internal representation
-- and output, but bugs happen)
michelineRoundtripContract :: HasCallStack => U.Contract -> U.Contract
michelineRoundtripContract contract =
  unsafe . fromExpression
    . either (error . toText) id
    . eitherDecode . encode
    $ toExpression contract