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

-- | 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
  , concatTestTrees

    -- * 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.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

----------------------------------------------------------------------------
-- 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 :: forall (cp :: T) (st :: T).
(Each '[SingI] '[cp, st], HasCallStack) =>
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 :: HasCallStack =>
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 typed contract.
testTreesWithTypedContract
  :: (Each '[SingI] [cp, st], HasCallStack)
  => FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithTypedContract :: forall (cp :: T) (st :: T).
(Each '[SingI] '[cp, st], HasCallStack) =>
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

testTreesWithContractImpl
  :: HasCallStack
  => (FilePath -> IO contract)
  -> FilePath
  -> (contract -> IO [TestTree])
  -> IO [TestTree]
testTreesWithContractImpl :: forall contract.
HasCallStack =>
(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

----------------------------------------------------------------------------
-- 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 :: forall contract.
(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.Code TH.Q (Contract cp st)
embedContract :: forall (cp :: T) (st :: T).
(SingI cp, SingI st) =>
FilePath -> Code Q (Contract cp st)
embedContract FilePath
path = IO FilePath -> Code Q (Contract cp st)
forall (cp :: T) (st :: T).
(SingI cp, SingI st) =>
IO FilePath -> Code Q (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.Code TH.Q (Contract cp st)
embedContractM :: forall (cp :: T) (st :: T).
(SingI cp, SingI st) =>
IO FilePath -> Code Q (Contract cp st)
embedContractM IO FilePath
pathM = Q (TExp (Contract cp st)) -> Code Q (Contract cp st)
forall (m :: * -> *) a. m (TExp a) -> Code m a
TH.Code 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 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 -> Q (TExp (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
_ -> Code Q (Contract cp st) -> Q (TExp (Contract cp st))
forall (m :: * -> *) a. Code m a -> m (TExp a)
TH.examineCode
      -- 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
      ||]