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

-- TODO [#712]: Remove this next major release
{-# OPTIONS_GHC -Wno-deprecations #-}

-- | Functions to import contracts to be used in tests.

module Test.Cleveland.Michelson.Import
  (
    -- * Read, parse, typecheck
    readContract
  , readUntypedContract
  , readSomeContract
  , importContract
  , importUntypedContract
  , importSomeContract
  , embedContract
  , embedContractM
  , ContractReadError (..)

  -- * Read, parse, typecheck value
  , readValue
  , importValue
  , importSomeValue
  , importUntypedValue
  , ValueReadError (..)

    -- * Tasty helpers
  , testTreesWithContract
  , testTreesWithTypedContract
  , testTreesWithUntypedContract
  , testTreesWithUntypedContractExt
  , testTreesWithTypedContractExt
  , concatTestTrees

    -- * HSpec helpers
  , specWithContract
  , specWithTypedContract
  , specWithUntypedContract

    -- * Helpers
  , embedTextFile
  ) where

import Control.Exception (IOException)
import Data.FileEmbed (makeRelativeToProject)
import Data.Text.IO.Utf8 qualified as Utf8 (readFile)
import Fmt (pretty)
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Syntax (qAddDependentFile)
import Test.HUnit (assertFailure)
import Test.Hspec (Spec, describe, expectationFailure, it, runIO)
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)

import Morley.Michelson.Runtime.Import
import Morley.Michelson.Typed (Contract, SingI)
import Morley.Michelson.Untyped qualified as U

{-# DEPRECATED
    specWithContract
  , specWithTypedContract
  , specWithUntypedContract

  "Use testTreesWithContract &c. instead"
  #-}

{-# DEPRECATED
    testTreesWithUntypedContractExt
  , testTreesWithTypedContractExt

  "Morley extensions are deprecated"
  #-}

----------------------------------------------------------------------------
-- tasty helpers
----------------------------------------------------------------------------

-- | Import contract and use to create test trees. Both versions of contract are
-- passed to the callback function (untyped and typed).
--
-- If contract's import fails, a tree with single failing test will be generated
-- (so test tree will likely be generated unexceptionally, but a failing
-- result will notify about problem).
testTreesWithContract
  :: (Each '[SingI] [cp, st], HasCallStack)
  => FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithContract :: FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithContract = (FilePath -> IO (Contract cp st))
-> FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
forall contract.
HasCallStack =>
(FilePath -> IO contract)
-> FilePath -> (contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithContractImpl FilePath -> IO (Contract cp st)
forall (cp :: T) (st :: T).
Each '[SingI] '[cp, st] =>
FilePath -> IO (Contract cp st)
importContract

-- | Like 'testTreesWithContract' but supplies only untyped contract.
testTreesWithUntypedContract
  :: HasCallStack
  => FilePath -> (U.Contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithUntypedContract :: FilePath -> (Contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithUntypedContract =
  (FilePath -> IO Contract)
-> FilePath -> (Contract -> IO [TestTree]) -> IO [TestTree]
forall contract.
HasCallStack =>
(FilePath -> IO contract)
-> FilePath -> (contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithContractImpl FilePath -> IO Contract
importUntypedContract

-- | Like 'testTreesWithContract' but supplies only untyped contract
-- with Morley extensions (deprecated).
testTreesWithUntypedContractExt
  :: HasCallStack
  => FilePath -> (U.Contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithUntypedContractExt :: FilePath -> (Contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithUntypedContractExt =
  (FilePath -> IO Contract)
-> FilePath -> (Contract -> IO [TestTree]) -> IO [TestTree]
forall contract.
HasCallStack =>
(FilePath -> IO contract)
-> FilePath -> (contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithContractImpl ((MichelsonSource -> Text -> Either ContractReadError Contract)
-> FilePath -> IO Contract
forall e a.
Exception e =>
(MichelsonSource -> Text -> Either e a) -> FilePath -> IO a
importUsing MichelsonSource -> Text -> Either ContractReadError Contract
readUntypedContractExt)

-- | Like 'testTreesWithContract' but supplies only typed contract.
testTreesWithTypedContract
  :: (Each '[SingI] [cp, st], HasCallStack)
  => FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithTypedContract :: FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithTypedContract =
  (FilePath -> IO (Contract cp st))
-> FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
forall contract.
HasCallStack =>
(FilePath -> IO contract)
-> FilePath -> (contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithContractImpl FilePath -> IO (Contract cp st)
forall (cp :: T) (st :: T).
Each '[SingI] '[cp, st] =>
FilePath -> IO (Contract cp st)
importContract

-- | Like 'testTreesWithContract' but supplies only typed contract
-- with Morley extensions (deprecated).
testTreesWithTypedContractExt
  :: (Each '[SingI] [cp, st], HasCallStack)
  => FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithTypedContractExt :: FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithTypedContractExt =
  (FilePath -> IO (Contract cp st))
-> FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
forall contract.
HasCallStack =>
(FilePath -> IO contract)
-> FilePath -> (contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithContractImpl ((MichelsonSource
 -> Text -> Either ContractReadError (Contract cp st))
-> FilePath -> IO (Contract cp st)
forall e a.
Exception e =>
(MichelsonSource -> Text -> Either e a) -> FilePath -> IO a
importUsing MichelsonSource
-> Text -> Either ContractReadError (Contract cp st)
forall (cp :: T) (st :: T).
Each '[SingI] '[cp, st] =>
MichelsonSource
-> Text -> Either ContractReadError (Contract cp st)
readContractExt)

testTreesWithContractImpl
  :: HasCallStack
  => (FilePath -> IO contract)
  -> FilePath
  -> (contract -> IO [TestTree])
  -> IO [TestTree]
testTreesWithContractImpl :: (FilePath -> IO contract)
-> FilePath -> (contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithContractImpl FilePath -> IO contract
doImport FilePath
file contract -> IO [TestTree]
testImpl =
  (FilePath -> IO contract)
-> FilePath -> IO (Either FilePath contract)
forall contract.
(FilePath -> IO contract)
-> FilePath -> IO (Either FilePath contract)
saferImport FilePath -> IO contract
doImport FilePath
file IO (Either FilePath contract)
-> (Either FilePath contract -> IO [TestTree]) -> IO [TestTree]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left FilePath
err -> [TestTree] -> IO [TestTree]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath -> Assertion -> TestTree
testCase (FilePath
"Import contract " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
file) (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ FilePath -> Assertion
forall a. HasCallStack => FilePath -> IO a
assertFailure FilePath
err]
    Right contract
contract -> contract -> IO [TestTree]
testImpl contract
contract

-- A helper function which allows you to use multiple
-- 'testTreesWithTypedContract' in a single top-level test with type
-- 'IO [TestTree]'.
concatTestTrees :: [IO [TestTree]] -> IO [TestTree]
concatTestTrees :: [IO [TestTree]] -> IO [TestTree]
concatTestTrees = ([[TestTree]] -> [TestTree]) -> IO [[TestTree]] -> IO [TestTree]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[TestTree]] -> [TestTree]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[TestTree]] -> IO [TestTree])
-> ([IO [TestTree]] -> IO [[TestTree]])
-> [IO [TestTree]]
-> IO [TestTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IO [TestTree]] -> IO [[TestTree]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence

----------------------------------------------------------------------------
-- hspec helpers
----------------------------------------------------------------------------

-- | Import contract and use it in the spec. Both versions of contract are
-- passed to the callback function (untyped and typed).
--
-- If contract's import fails, a spec with single failing expectation
-- will be generated (so tests will likely run unexceptionally, but a failing
-- result will notify about problem).
specWithContract
  :: (Each '[SingI] [cp, st], HasCallStack)
  => FilePath -> (Contract cp st -> Spec) -> Spec
specWithContract :: FilePath -> (Contract cp st -> Spec) -> Spec
specWithContract = (FilePath -> IO (Contract cp st))
-> FilePath -> (Contract cp st -> Spec) -> Spec
forall contract.
HasCallStack =>
(FilePath -> IO contract) -> FilePath -> (contract -> Spec) -> Spec
specWithContractImpl FilePath -> IO (Contract cp st)
forall (cp :: T) (st :: T).
Each '[SingI] '[cp, st] =>
FilePath -> IO (Contract cp st)
importContract

-- | A version of 'specWithContract' which passes only the typed
-- representation of the contract.
specWithTypedContract
  :: (Each '[SingI] [cp, st], HasCallStack)
  => FilePath -> (Contract cp st -> Spec) -> Spec
specWithTypedContract :: FilePath -> (Contract cp st -> Spec) -> Spec
specWithTypedContract = (FilePath -> IO (Contract cp st))
-> FilePath -> (Contract cp st -> Spec) -> Spec
forall contract.
HasCallStack =>
(FilePath -> IO contract) -> FilePath -> (contract -> Spec) -> Spec
specWithContractImpl FilePath -> IO (Contract cp st)
forall (cp :: T) (st :: T).
Each '[SingI] '[cp, st] =>
FilePath -> IO (Contract cp st)
importContract

specWithUntypedContract :: FilePath -> (U.Contract -> Spec) -> Spec
specWithUntypedContract :: FilePath -> (Contract -> Spec) -> Spec
specWithUntypedContract = (FilePath -> IO Contract) -> FilePath -> (Contract -> Spec) -> Spec
forall contract.
HasCallStack =>
(FilePath -> IO contract) -> FilePath -> (contract -> Spec) -> Spec
specWithContractImpl FilePath -> IO Contract
importUntypedContract

specWithContractImpl
  :: HasCallStack
  => (FilePath -> IO contract) -> FilePath -> (contract -> Spec) -> Spec
specWithContractImpl :: (FilePath -> IO contract) -> FilePath -> (contract -> Spec) -> Spec
specWithContractImpl FilePath -> IO contract
doImport FilePath
file contract -> Spec
execSpec =
  (FilePath -> Spec)
-> (contract -> Spec) -> Either FilePath contract -> Spec
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Spec
errorSpec (FilePath -> Spec -> Spec
forall a. HasCallStack => FilePath -> SpecWith a -> SpecWith a
describe (FilePath
"Test contract " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
file) (Spec -> Spec) -> (contract -> Spec) -> contract -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. contract -> Spec
execSpec)
    (Either FilePath contract -> Spec)
-> SpecM () (Either FilePath contract) -> Spec
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either FilePath contract)
-> SpecM () (Either FilePath contract)
forall r a. IO r -> SpecM a r
runIO ((FilePath -> IO contract)
-> FilePath -> IO (Either FilePath contract)
forall contract.
(FilePath -> IO contract)
-> FilePath -> IO (Either FilePath contract)
saferImport FilePath -> IO contract
doImport FilePath
file)
  where
    errorSpec :: FilePath -> Spec
errorSpec = FilePath -> Assertion -> SpecWith (Arg Assertion)
forall a.
(HasCallStack, Example a) =>
FilePath -> a -> SpecWith (Arg a)
it (FilePath
"Import contract " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
file) (Assertion -> Spec) -> (FilePath -> Assertion) -> FilePath -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => FilePath -> Assertion
FilePath -> Assertion
expectationFailure

----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------

-- Catch some errors during contract import, we don't want the whole
-- test suite to crash if something like that happens.
saferImport :: (FilePath -> IO contract) -> FilePath -> IO (Either String contract)
saferImport :: (FilePath -> IO contract)
-> FilePath -> IO (Either FilePath contract)
saferImport FilePath -> IO contract
doImport FilePath
file =
  ((contract -> Either FilePath contract
forall a b. b -> Either a b
Right (contract -> Either FilePath contract)
-> IO contract -> IO (Either FilePath contract)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO contract
doImport FilePath
file)
  IO (Either FilePath contract)
-> (ContractReadError -> IO (Either FilePath contract))
-> IO (Either FilePath contract)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(ContractReadError
e :: ContractReadError) -> Either FilePath contract -> IO (Either FilePath contract)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath contract -> IO (Either FilePath contract))
-> Either FilePath contract -> IO (Either FilePath contract)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath contract
forall a b. a -> Either a b
Left (FilePath -> Either FilePath contract)
-> FilePath -> Either FilePath contract
forall a b. (a -> b) -> a -> b
$ ContractReadError -> FilePath
forall e. Exception e => e -> FilePath
displayException ContractReadError
e)
  IO (Either FilePath contract)
-> (IOException -> IO (Either FilePath contract))
-> IO (Either FilePath contract)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(IOException
e :: IOException) -> Either FilePath contract -> IO (Either FilePath contract)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath contract -> IO (Either FilePath contract))
-> Either FilePath contract -> IO (Either FilePath contract)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath contract
forall a b. a -> Either a b
Left (FilePath -> Either FilePath contract)
-> FilePath -> Either FilePath contract
forall a b. (a -> b) -> a -> b
$ IOException -> FilePath
forall e. Exception e => e -> FilePath
displayException IOException
e

----------------------------------------------------------------------------
-- Embedding contract
----------------------------------------------------------------------------

-- | Read a file with textual content at compile time.
--
-- Unlike @embedFile@ from the library, returns typed content.
embedTextFile :: FilePath -> TH.Q Text
embedTextFile :: FilePath -> Q Text
embedTextFile FilePath
rawPath = do
  FilePath
path <- FilePath -> Q FilePath
makeRelativeToProject FilePath
rawPath
  FilePath -> Q ()
forall (m :: * -> *). Quasi m => FilePath -> m ()
qAddDependentFile FilePath
rawPath
  FilePath -> Q Text
forall (m :: * -> *). MonadIO m => FilePath -> m Text
Utf8.readFile FilePath
path

{- | Import a contract at compile time assuming its expected type is known.

Use it like:

> myContract :: Contract (ToT Parameter) (ToT Storage)
> myContract = $$(embedContract "my_contract.tz")

or

> let myContract = $$(embedContract @(ToT Parameter) @(ToT Storage) "my_contract.tz")

-}
embedContract
  :: forall cp st. (SingI cp, SingI st)
  => FilePath -> TH.TExpQ (Contract cp st)
embedContract :: FilePath -> TExpQ (Contract cp st)
embedContract FilePath
path = IO FilePath -> TExpQ (Contract cp st)
forall (cp :: T) (st :: T).
(SingI cp, SingI st) =>
IO FilePath -> TExpQ (Contract cp st)
embedContractM (FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
path)

-- | Version of 'embedContract' that accepts a filepath constructor in IO.
--
-- Useful when the path should depend on environmental variables or other
-- user input.
embedContractM
  :: forall cp st. (SingI cp, SingI st)
  => IO FilePath -> TH.TExpQ (Contract cp st)
embedContractM :: IO FilePath -> TExpQ (Contract cp st)
embedContractM IO FilePath
pathM = do
  FilePath
path <- IO FilePath -> Q FilePath
forall a. IO a -> Q a
TH.runIO IO FilePath
pathM
  Text
contract <- FilePath -> Q Text
embedTextFile FilePath
path
  case MichelsonSource
-> Text -> Either ContractReadError (Contract cp st)
forall (cp :: T) (st :: T).
Each '[SingI] '[cp, st] =>
MichelsonSource
-> Text -> Either ContractReadError (Contract cp st)
readContract @cp @st (FilePath -> MichelsonSource
MSFile FilePath
path) Text
contract of
    Left ContractReadError
e ->
      -- Emit a compiler error if the contract cannot be read.
      FilePath -> TExpQ (Contract cp st)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (ContractReadError -> FilePath
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ContractReadError
e)
    Right Contract cp st
_ ->
      -- Emit a haskell expression that reads the contract.
      [||
        -- Note: it's ok to use `unsafe` here, because we just proved that the contrPact
        -- can be parsed+typechecked.
        unsafe $
          readContract (MSFile path) contract
      ||]