-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

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

module Michelson.Test.Import
  (
    -- * Read, parse, typecheck
    readContract
  , importContract
  , importUntypedContract
  , ImportContractError (..)

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

    -- * HSpec helpers
  , specWithContract
  , specWithTypedContract
  , specWithUntypedContract
  ) where

import Control.Exception (IOException)
import Data.Singletons (demote)
import Data.Typeable ((:~:)(..), eqT)
import Fmt (Buildable(build), pretty, (+|), (|+))
import Test.Hspec (Spec, describe, expectationFailure, it, runIO)
import Test.HUnit (assertFailure)
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)

import Michelson.Parser.Error (ParserException(..))
import Michelson.Runtime (parseExpandContract, prepareContract)
import Michelson.TypeCheck (SomeContract(..), TCError, typeCheckContract)
import Michelson.Typed (Contract(..), KnownT, toUType)
import qualified Michelson.Untyped as U
import Util.IO

----------------------------------------------------------------------------
-- 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 '[KnownT] [cp, st], HasCallStack)
  => FilePath -> ((U.Contract, Contract cp st) -> IO [TestTree]) -> IO [TestTree]
testTreesWithContract :: FilePath
-> ((Contract, Contract cp st) -> IO [TestTree]) -> IO [TestTree]
testTreesWithContract = (FilePath -> IO (Contract, Contract cp st))
-> FilePath
-> ((Contract, Contract cp st) -> IO [TestTree])
-> IO [TestTree]
forall contract.
HasCallStack =>
(FilePath -> IO contract)
-> FilePath -> (contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithContractImpl FilePath -> IO (Contract, Contract cp st)
forall (cp :: T) (st :: T).
Each '[KnownT] '[cp, st] =>
FilePath -> IO (Contract, 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 typed contract.
testTreesWithTypedContract
  :: (Each '[KnownT] [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 (((Contract, Contract cp st) -> Contract cp st)
-> IO (Contract, Contract cp st) -> IO (Contract cp st)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Contract, Contract cp st) -> Contract cp st
forall a b. (a, b) -> b
snd (IO (Contract, Contract cp st) -> IO (Contract cp st))
-> (FilePath -> IO (Contract, Contract cp st))
-> FilePath
-> IO (Contract cp st)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO (Contract, Contract cp st)
forall (cp :: T) (st :: T).
Each '[KnownT] '[cp, st] =>
FilePath -> IO (Contract, Contract cp st)
importContract)

testTreesWithContractImpl
  :: HasCallStack
  => (FilePath -> IO contract)
  -> FilePath
  -> (contract -> IO [TestTree])
  -> IO [TestTree]
testTreesWithContractImpl :: (FilePath -> IO contract)
-> FilePath -> (contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithContractImpl doImport :: FilePath -> IO contract
doImport file :: FilePath
file testImpl :: 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 err :: FilePath
err -> [TestTree] -> IO [TestTree]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath -> Assertion -> TestTree
testCase ("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 -> 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 '[KnownT] [cp, st], HasCallStack)
  => FilePath -> ((U.Contract, Contract cp st) -> Spec) -> Spec
specWithContract :: FilePath -> ((Contract, Contract cp st) -> Spec) -> Spec
specWithContract = (FilePath -> IO (Contract, Contract cp st))
-> FilePath -> ((Contract, Contract cp st) -> Spec) -> Spec
forall contract.
HasCallStack =>
(FilePath -> IO contract) -> FilePath -> (contract -> Spec) -> Spec
specWithContractImpl FilePath -> IO (Contract, Contract cp st)
forall (cp :: T) (st :: T).
Each '[KnownT] '[cp, st] =>
FilePath -> IO (Contract, Contract cp st)
importContract

-- | A version of 'specWithContract' which passes only the typed
-- representation of the contract.
specWithTypedContract
  :: (Each '[KnownT] [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 (((Contract, Contract cp st) -> Contract cp st)
-> IO (Contract, Contract cp st) -> IO (Contract cp st)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Contract, Contract cp st) -> Contract cp st
forall a b. (a, b) -> b
snd (IO (Contract, Contract cp st) -> IO (Contract cp st))
-> (FilePath -> IO (Contract, Contract cp st))
-> FilePath
-> IO (Contract cp st)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO (Contract, Contract cp st)
forall (cp :: T) (st :: T).
Each '[KnownT] '[cp, st] =>
FilePath -> IO (Contract, 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 doImport :: FilePath -> IO contract
doImport file :: FilePath
file execSpec :: 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 ("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 ("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 doImport :: FilePath -> IO contract
doImport file :: 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)
-> (ImportContractError -> IO (Either FilePath contract))
-> IO (Either FilePath contract)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(ImportContractError
e :: ImportContractError) -> 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
$ ImportContractError -> FilePath
forall e. Exception e => e -> FilePath
displayException ImportContractError
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

----------------------------------------------------------------------------
-- Reading, parsing, typechecking
----------------------------------------------------------------------------

readContract
  :: forall cp st .
     Each '[KnownT] [cp, st]
  => FilePath
  -> Text
  -> Either ImportContractError (U.Contract, Contract cp st)
readContract :: FilePath
-> Text -> Either ImportContractError (Contract, Contract cp st)
readContract filePath :: FilePath
filePath txt :: Text
txt = do
  Contract
contract <- (ParserException -> ImportContractError)
-> Either ParserException Contract
-> Either ImportContractError Contract
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParserException -> ImportContractError
ICEParse (Either ParserException Contract
 -> Either ImportContractError Contract)
-> Either ParserException Contract
-> Either ImportContractError Contract
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> Text -> Either ParserException Contract
parseExpandContract (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
filePath) Text
txt
  SomeContract (tContract :: Contract cp st
tContract@Contract{} :: Contract cp' st')
    <- (TCError -> ImportContractError)
-> Either TCError SomeContract
-> Either ImportContractError SomeContract
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TCError -> ImportContractError
ICETypeCheck (Either TCError SomeContract
 -> Either ImportContractError SomeContract)
-> Either TCError SomeContract
-> Either ImportContractError SomeContract
forall a b. (a -> b) -> a -> b
$ TcOriginatedContracts -> Contract -> Either TCError SomeContract
typeCheckContract TcOriginatedContracts
forall a. Monoid a => a
mempty Contract
contract
  case ((Typeable cp, Typeable cp) => Maybe (cp :~: cp)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @cp @cp', (Typeable st, Typeable st) => Maybe (st :~: st)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @st @st') of
    (Just Refl, Just Refl) -> (Contract, Contract cp st)
-> Either ImportContractError (Contract, Contract cp st)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Contract
contract, Contract cp st
tContract)
    (Nothing, _) -> ImportContractError
-> Either ImportContractError (Contract, Contract cp st)
forall a b. a -> Either a b
Left (ImportContractError
 -> Either ImportContractError (Contract, Contract cp st))
-> ImportContractError
-> Either ImportContractError (Contract, Contract cp st)
forall a b. (a -> b) -> a -> b
$
      ParameterType -> Type -> ImportContractError
ICEUnexpectedParamType (Contract -> ParameterType
forall op. Contract' op -> ParameterType
U.contractParameter Contract
contract) (T -> Type
toUType (T -> Type) -> T -> Type
forall a b. (a -> b) -> a -> b
$ (SingKind T, SingI cp) => Demote T
forall k (a :: k). (SingKind k, SingI a) => Demote k
demote @cp)
    _ -> ImportContractError
-> Either ImportContractError (Contract, Contract cp st)
forall a b. a -> Either a b
Left (Type -> Type -> ImportContractError
ICEUnexpectedStorageType (Contract -> Type
forall op. Contract' op -> Type
U.contractStorage Contract
contract) (T -> Type
toUType (T -> Type) -> T -> Type
forall a b. (a -> b) -> a -> b
$ (SingKind T, SingI st) => Demote T
forall k (a :: k). (SingKind k, SingI a) => Demote k
demote @st))

-- | Import contract from a given file path.
--
-- This function reads file, parses and type checks a contract.
-- Within the typechecking we assume that no contracts are originated,
-- otherwise a type checking error will be caused.
--
-- This function may throw 'IOException' and 'ImportContractError'.
importContract
  :: forall cp st .
     Each '[KnownT] [cp, st]
  => FilePath -> IO (U.Contract, Contract cp st)
importContract :: FilePath -> IO (Contract, Contract cp st)
importContract file :: FilePath
file = (ImportContractError -> IO (Contract, Contract cp st))
-> ((Contract, Contract cp st) -> IO (Contract, Contract cp st))
-> Either ImportContractError (Contract, Contract cp st)
-> IO (Contract, Contract cp st)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ImportContractError -> IO (Contract, Contract cp st)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Contract, Contract cp st) -> IO (Contract, Contract cp st)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ImportContractError (Contract, Contract cp st)
 -> IO (Contract, Contract cp st))
-> IO (Either ImportContractError (Contract, Contract cp st))
-> IO (Contract, Contract cp st)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath
-> Text -> Either ImportContractError (Contract, Contract cp st)
forall (cp :: T) (st :: T).
Each '[KnownT] '[cp, st] =>
FilePath
-> Text -> Either ImportContractError (Contract, Contract cp st)
readContract FilePath
file (Text -> Either ImportContractError (Contract, Contract cp st))
-> IO Text
-> IO (Either ImportContractError (Contract, Contract cp st))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
readFileUtf8 FilePath
file

importUntypedContract :: FilePath -> IO U.Contract
importUntypedContract :: FilePath -> IO Contract
importUntypedContract = Maybe FilePath -> IO Contract
prepareContract (Maybe FilePath -> IO Contract)
-> (FilePath -> Maybe FilePath) -> FilePath -> IO Contract
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just

-- | Error type for 'importContract' function.
data ImportContractError
  = ICEUnexpectedParamType U.ParameterType U.Type
  | ICEUnexpectedStorageType U.Type U.Type
  | ICEParse ParserException
  | ICETypeCheck TCError
  deriving stock (Int -> ImportContractError -> FilePath -> FilePath
[ImportContractError] -> FilePath -> FilePath
ImportContractError -> FilePath
(Int -> ImportContractError -> FilePath -> FilePath)
-> (ImportContractError -> FilePath)
-> ([ImportContractError] -> FilePath -> FilePath)
-> Show ImportContractError
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [ImportContractError] -> FilePath -> FilePath
$cshowList :: [ImportContractError] -> FilePath -> FilePath
show :: ImportContractError -> FilePath
$cshow :: ImportContractError -> FilePath
showsPrec :: Int -> ImportContractError -> FilePath -> FilePath
$cshowsPrec :: Int -> ImportContractError -> FilePath -> FilePath
Show, ImportContractError -> ImportContractError -> Bool
(ImportContractError -> ImportContractError -> Bool)
-> (ImportContractError -> ImportContractError -> Bool)
-> Eq ImportContractError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImportContractError -> ImportContractError -> Bool
$c/= :: ImportContractError -> ImportContractError -> Bool
== :: ImportContractError -> ImportContractError -> Bool
$c== :: ImportContractError -> ImportContractError -> Bool
Eq)

instance Buildable ImportContractError where
  build :: ImportContractError -> Builder
build =
    \case
      ICEUnexpectedParamType actual :: ParameterType
actual expected :: Type
expected ->
        "Unexpected parameter type: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| ParameterType
actual ParameterType -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+
        ", expected: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Type
expected Type -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""
      ICEUnexpectedStorageType actual :: Type
actual expected :: Type
expected ->
        "Unexpected storage type: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Type
actual Type -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+
        ", expected: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Type
expected Type -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""
      ICEParse e :: ParserException
e -> "Failed to parse the contract: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| ParserException
e ParserException -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""
      ICETypeCheck e :: TCError
e -> "The contract is ill-typed: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| TCError
e TCError -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""

instance Exception ImportContractError where
  displayException :: ImportContractError -> FilePath
displayException = ImportContractError -> FilePath
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty