module Test.Cleveland.Michelson.Import
(
readContract
, readUntypedContract
, readSomeContract
, importContract
, importUntypedContract
, importSomeContract
, embedContract
, embedContractM
, ContractReadError (..)
, readValue
, importValue
, importSomeValue
, importUntypedValue
, ValueReadError (..)
, testTreesWithContract
, testTreesWithTypedContract
, testTreesWithUntypedContract
, concatTestTrees
, 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.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
testTreesWithContract
:: (Each '[SingI] [cp, st], HasCallStack)
=> FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithContract :: forall (cp :: T) (st :: T).
(Each '[SingI] '[cp, st], HasCallStack) =>
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 :: HasCallStack =>
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 '[SingI] [cp, st], HasCallStack)
=> FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithTypedContract :: forall (cp :: T) (st :: T).
(Each '[SingI] '[cp, st], HasCallStack) =>
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
testTreesWithContractImpl
:: HasCallStack
=> (FilePath -> IO contract)
-> FilePath
-> (contract -> IO [TestTree])
-> IO [TestTree]
testTreesWithContractImpl :: forall contract.
HasCallStack =>
(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
saferImport :: (FilePath -> IO contract) -> FilePath -> IO (Either String contract)
saferImport :: forall contract.
(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.Code TH.Q (Contract cp st)
embedContract :: forall (cp :: T) (st :: T).
(SingI cp, SingI st) =>
FilePath -> Code Q (Contract cp st)
embedContract FilePath
path = IO FilePath -> Code Q (Contract cp st)
forall (cp :: T) (st :: T).
(SingI cp, SingI st) =>
IO FilePath -> Code Q (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.Code TH.Q (Contract cp st)
embedContractM :: forall (cp :: T) (st :: T).
(SingI cp, SingI st) =>
IO FilePath -> Code Q (Contract cp st)
embedContractM IO FilePath
pathM = Q (TExp (Contract cp st)) -> Code Q (Contract cp st)
forall (m :: * -> *) a. m (TExp a) -> Code m a
TH.Code 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 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 -> Q (TExp (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
_ -> Code Q (Contract cp st) -> Q (TExp (Contract cp st))
forall (m :: * -> *) a. Code m a -> m (TExp a)
TH.examineCode
[||
unsafe $
readContract (MSFile path) contract
||]