module Michelson.Test.Import
(
readContract
, importContract
, importUntypedContract
, ImportContractError (..)
, testTreesWithContract
, testTreesWithContractL
, testTreesWithTypedContract
, testTreesWithUntypedContract
, concatTestTrees
, specWithContract
, specWithContractL
, 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.Tasty (TestTree)
import Test.Tasty.HUnit (assertFailure, testCase)
import qualified Lorentz as L
import Michelson.Parser.Error (ParserException(..))
import Michelson.Runtime (parseExpandContract, prepareContract)
import Michelson.TypeCheck (SomeContract(..), TCError, typeCheckContract)
import Michelson.Typed (Contract, FullContract(..), ToT, 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
testTreesWithContractL
:: (Each [Typeable, SingI] [ToT cp, ToT st], HasCallStack)
=> FilePath -> ((U.Contract, L.Contract cp st) -> IO [TestTree]) -> IO [TestTree]
testTreesWithContractL file testImpl = testTreesWithContract file (testImpl . second L.I)
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
specWithContractL
:: (Each [Typeable, SingI] [ToT cp, ToT st], HasCallStack)
=> FilePath -> ((U.Contract, L.Contract cp st) -> Spec) -> Spec
specWithContractL file mkSpec = specWithContract file (mkSpec . second L.I)
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