module Michelson.Test.Import
(
readContract
, importContract
, importUntypedContract
, ImportContractError (..)
, testTreesWithContract
, testTreesWithTypedContract
, testTreesWithUntypedContract
, concatTestTrees
, 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
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
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
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
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
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
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
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
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))
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
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