module Michelson.Test.Import
(
readContract
, importContract
, importUntypedContract
, ImportContractError (..)
, testTreesWithContract
, testTreesWithTypedContract
, testTreesWithUntypedContract
, concatTestTrees
, specWithContract
, specWithTypedContract
, specWithUntypedContract
) where
import Control.Exception (IOException)
import Data.Singletons (SingI, 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, FullContract(..), toUType)
import qualified Michelson.Untyped as U
import Util.IO
testTreesWithContract
:: (Each [Typeable, SingI] [cp, st], HasCallStack)
=> FilePath -> ((U.Contract, Contract cp st) -> IO [TestTree]) -> IO [TestTree]
testTreesWithContract = testTreesWithContractImpl importContract
testTreesWithUntypedContract
:: HasCallStack
=> FilePath -> (U.Contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithUntypedContract =
testTreesWithContractImpl importUntypedContract
testTreesWithTypedContract
:: (Each [Typeable, SingI] [cp, st], HasCallStack)
=> FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithTypedContract =
testTreesWithContractImpl (fmap snd . importContract)
testTreesWithContractImpl
:: HasCallStack
=> (FilePath -> IO contract)
-> FilePath
-> (contract -> IO [TestTree])
-> IO [TestTree]
testTreesWithContractImpl doImport file testImpl =
saferImport doImport file >>= \case
Left err -> pure [testCase ("Import contract " <> file) $ assertFailure err]
Right contract -> testImpl contract
concatTestTrees :: [IO [TestTree]] -> IO [TestTree]
concatTestTrees = fmap concat . sequence
specWithContract
:: (Each [Typeable, SingI] [cp, st], HasCallStack)
=> FilePath -> ((U.Contract, Contract cp st) -> Spec) -> Spec
specWithContract = specWithContractImpl importContract
specWithTypedContract
:: (Each [Typeable, SingI] [cp, st], HasCallStack)
=> FilePath -> (Contract cp st -> Spec) -> Spec
specWithTypedContract = specWithContractImpl (fmap snd . importContract)
specWithUntypedContract :: FilePath -> (U.Contract -> Spec) -> Spec
specWithUntypedContract = specWithContractImpl importUntypedContract
specWithContractImpl
:: HasCallStack
=> (FilePath -> IO contract) -> FilePath -> (contract -> Spec) -> Spec
specWithContractImpl doImport file execSpec =
either errorSpec (describe ("Test contract " <> file) . execSpec)
=<< runIO (saferImport doImport file)
where
errorSpec = it ("Import contract " <> file) . expectationFailure
saferImport :: (FilePath -> IO contract) -> FilePath -> IO (Either String contract)
saferImport doImport file =
((Right <$> doImport file)
`catch` \(e :: ImportContractError) -> pure $ Left $ displayException e)
`catch` \(e :: IOException) -> pure $ Left $ displayException e
readContract
:: forall cp st .
Each [Typeable, SingI] [cp, st]
=> FilePath
-> Text
-> Either ImportContractError (U.Contract, Contract cp st)
readContract filePath txt = do
contract <- first ICEParse $ parseExpandContract (Just filePath) txt
SomeContract (FullContract (instr :: Contract cp' st') _ _)
<- first ICETypeCheck $ typeCheckContract mempty contract
case (eqT @cp @cp', eqT @st @st') of
(Just Refl, Just Refl) -> pure (contract, instr)
(Nothing, _) -> Left $
ICEUnexpectedParamType (U.para contract) (toUType $ demote @cp)
_ -> Left (ICEUnexpectedStorageType (U.stor contract) (toUType $ demote @st))
importContract
:: forall cp st .
Each [Typeable, SingI] [cp, st]
=> FilePath -> IO (U.Contract, Contract cp st)
importContract file = either throwM pure =<< readContract file <$> readFileUtf8 file
importUntypedContract :: FilePath -> IO U.Contract
importUntypedContract = prepareContract . Just
data ImportContractError
= ICEUnexpectedParamType U.Type U.Type
| ICEUnexpectedStorageType U.Type U.Type
| ICEParse ParserException
| ICETypeCheck TCError
deriving stock (Show, Eq)
instance Buildable ImportContractError where
build =
\case
ICEUnexpectedParamType actual expected ->
"Unexpected parameter type: " +| actual |+
", expected: " +| expected |+ ""
ICEUnexpectedStorageType actual expected ->
"Unexpected storage type: " +| actual |+
", expected: " +| expected |+ ""
ICEParse e -> "Failed to parse the contract: " +| e |+ ""
ICETypeCheck e -> "The contract is ill-typed: " +| e |+ ""
instance Exception ImportContractError where
displayException = pretty