{-# OPTIONS_GHC -Wno-deprecations #-}
module Test.Cleveland.Michelson.Import
(
readContract
, readUntypedContract
, readSomeContract
, importContract
, importUntypedContract
, importSomeContract
, embedContract
, embedContractM
, ContractReadError (..)
, readValue
, importValue
, importSomeValue
, importUntypedValue
, ValueReadError (..)
, testTreesWithContract
, testTreesWithTypedContract
, testTreesWithUntypedContract
, testTreesWithUntypedContractExt
, testTreesWithTypedContractExt
, concatTestTrees
, specWithContract
, specWithTypedContract
, specWithUntypedContract
, 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.Hspec (Spec, describe, expectationFailure, it, runIO)
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
{-# DEPRECATED
specWithContract
, specWithTypedContract
, specWithUntypedContract
"Use testTreesWithContract &c. instead"
#-}
{-# DEPRECATED
testTreesWithUntypedContractExt
, testTreesWithTypedContractExt
"Morley extensions are deprecated"
#-}
testTreesWithContract
:: (Each '[SingI] [cp, st], HasCallStack)
=> FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithContract :: 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
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
testTreesWithUntypedContractExt
:: HasCallStack
=> FilePath -> (U.Contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithUntypedContractExt :: FilePath -> (Contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithUntypedContractExt =
(FilePath -> IO Contract)
-> FilePath -> (Contract -> IO [TestTree]) -> IO [TestTree]
forall contract.
HasCallStack =>
(FilePath -> IO contract)
-> FilePath -> (contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithContractImpl ((MichelsonSource -> Text -> Either ContractReadError Contract)
-> FilePath -> IO Contract
forall e a.
Exception e =>
(MichelsonSource -> Text -> Either e a) -> FilePath -> IO a
importUsing MichelsonSource -> Text -> Either ContractReadError Contract
readUntypedContractExt)
testTreesWithTypedContract
:: (Each '[SingI] [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 FilePath -> IO (Contract cp st)
forall (cp :: T) (st :: T).
Each '[SingI] '[cp, st] =>
FilePath -> IO (Contract cp st)
importContract
testTreesWithTypedContractExt
:: (Each '[SingI] [cp, st], HasCallStack)
=> FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithTypedContractExt :: FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithTypedContractExt =
(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 ((MichelsonSource
-> Text -> Either ContractReadError (Contract cp st))
-> FilePath -> IO (Contract cp st)
forall e a.
Exception e =>
(MichelsonSource -> Text -> Either e a) -> FilePath -> IO a
importUsing MichelsonSource
-> Text -> Either ContractReadError (Contract cp st)
forall (cp :: T) (st :: T).
Each '[SingI] '[cp, st] =>
MichelsonSource
-> Text -> Either ContractReadError (Contract cp st)
readContractExt)
testTreesWithContractImpl
:: HasCallStack
=> (FilePath -> IO contract)
-> FilePath
-> (contract -> IO [TestTree])
-> IO [TestTree]
testTreesWithContractImpl :: (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
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 '[SingI] [cp, st], HasCallStack)
=> FilePath -> (Contract cp st -> Spec) -> Spec
specWithContract :: FilePath -> (Contract cp st -> Spec) -> Spec
specWithContract = (FilePath -> IO (Contract cp st))
-> FilePath -> (Contract cp st -> Spec) -> Spec
forall contract.
HasCallStack =>
(FilePath -> IO contract) -> FilePath -> (contract -> Spec) -> Spec
specWithContractImpl FilePath -> IO (Contract cp st)
forall (cp :: T) (st :: T).
Each '[SingI] '[cp, st] =>
FilePath -> IO (Contract cp st)
importContract
specWithTypedContract
:: (Each '[SingI] [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 FilePath -> IO (Contract cp st)
forall (cp :: T) (st :: T).
Each '[SingI] '[cp, st] =>
FilePath -> IO (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 FilePath -> IO contract
doImport FilePath
file 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 (FilePath
"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 (FilePath
"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 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
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
embedContract
:: forall cp st. (SingI cp, SingI st)
=> FilePath -> TH.TExpQ (Contract cp st)
embedContract :: FilePath -> TExpQ (Contract cp st)
embedContract FilePath
path = IO FilePath -> TExpQ (Contract cp st)
forall (cp :: T) (st :: T).
(SingI cp, SingI st) =>
IO FilePath -> TExpQ (Contract cp st)
embedContractM (FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
path)
embedContractM
:: forall cp st. (SingI cp, SingI st)
=> IO FilePath -> TH.TExpQ (Contract cp st)
embedContractM :: IO FilePath -> TExpQ (Contract cp st)
embedContractM IO FilePath
pathM = 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 MichelsonSource
-> Text -> Either ContractReadError (Contract cp st)
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 ->
FilePath -> TExpQ (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
_ ->
[||
unsafe $
readContract (MSFile path) contract
||]