module Test.Cleveland.Lorentz.Import
(
importContract
, embedContract
, embedContractM
, M.ContractReadError (..)
, importValue
, embedValue
, embedValueM
, M.ValueReadError (..)
) where
import Fmt (build, pretty)
import Language.Haskell.TH qualified as TH
import Lorentz qualified as L
import Lorentz.Base
import Lorentz.Constraints
import Lorentz.ViewBase
import Morley.Michelson.Parser.Types (MichelsonSource(..))
import Morley.Michelson.Typed qualified as T
import Morley.Util.Markdown
import Test.Cleveland.Michelson.Import qualified as M
mkImportedContract
:: forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd)
=> FilePath
-> T.Contract (T.ToT cp) (T.ToT st)
-> Either L.ViewInterfaceMatchError (Contract cp st vd)
mkImportedContract :: forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd,
DemoteViewsDescriptor vd) =>
FilePath
-> Contract (ToT cp) (ToT st)
-> Either ViewInterfaceMatchError (Contract cp st vd)
mkImportedContract FilePath
path Contract (ToT cp) (ToT st)
cMichelsonContract = Contract cp st vd
-> Either ViewInterfaceMatchError (Contract cp st vd)
verifyingViews Contract :: forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd) =>
Contract (ToT cp) (ToT st)
-> ContractCode cp st -> Contract cp st vd
Contract
{ cDocumentedCode :: ContractCode cp st
cDocumentedCode = ('[(cp, st)] :-> ContractOut st) -> ContractCode cp st
forall cp st.
('[(cp, st)] :-> ContractOut st) -> ContractCode cp st
L.ContractCode (('[(cp, st)] :-> ContractOut st) -> ContractCode cp st)
-> ('[(cp, st)] :-> ContractOut st) -> ContractCode cp st
forall a b. (a -> b) -> a -> b
$
(Any :-> Any) -> '[(cp, st)] :-> ContractOut st
forall (s1 :: [*]) (s2 :: [*]) (s1' :: [*]) (s2' :: [*]).
(s1 :-> s2) -> s1' :-> s2'
L.fakeCoercing ((Any :-> Any) -> '[(cp, st)] :-> ContractOut st)
-> (Any :-> Any) -> '[(cp, st)] :-> ContractOut st
forall a b. (a -> b) -> a -> b
$
(SubDoc -> DName) -> (Any :-> Any) -> Any :-> Any
forall di (inp :: [*]) (out :: [*]).
DocItem di =>
(SubDoc -> di) -> (inp :-> out) -> inp :-> out
L.docGroup SubDoc -> DName
"Imported contract" ((Any :-> Any) -> Any :-> Any) -> (Any :-> Any) -> Any :-> Any
forall a b. (a -> b) -> a -> b
$
DDescription -> Any :-> Any
forall di (s :: [*]). DocItem di => di -> s :-> s
L.doc (DDescription -> Any :-> Any) -> DDescription -> Any :-> Any
forall a b. (a -> b) -> a -> b
$ Markdown -> DDescription
L.DDescription (Markdown -> DDescription) -> Markdown -> DDescription
forall a b. (a -> b) -> a -> b
$ Markdown
"Read from " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown -> Markdown
mdTicked (FilePath -> Markdown
forall p. Buildable p => p -> Markdown
build FilePath
path)
, Contract (ToT cp) (ToT st)
cMichelsonContract :: Contract (ToT cp) (ToT st)
cMichelsonContract :: Contract (ToT cp) (ToT st)
..
}
where
verifyingViews :: Contract cp st vd
-> Either ViewInterfaceMatchError (Contract cp st vd)
verifyingViews Contract cp st vd
r =
[ViewInterface]
-> ViewsSet (ToT st) -> Either ViewInterfaceMatchError ()
forall (st :: T).
[ViewInterface] -> ViewsSet st -> Either ViewInterfaceMatchError ()
L.checkViewsCoverInterface (forall vd. DemoteViewTyInfo (RevealViews vd) => [ViewInterface]
L.demoteViewsDescriptor @vd) (Contract (ToT cp) (ToT st) -> ViewsSet (ToT st)
forall (instr :: [T] -> [T] -> *) (cp :: T) (st :: T).
Contract' instr cp st -> ViewsSet' instr st
T.cViews Contract (ToT cp) (ToT st)
cMichelsonContract)
Either ViewInterfaceMatchError ()
-> Contract cp st vd
-> Either ViewInterfaceMatchError (Contract cp st vd)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Contract cp st vd
r
importContract
:: forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd)
=> FilePath -> IO (Contract cp st vd)
importContract :: forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd,
DemoteViewsDescriptor vd) =>
FilePath -> IO (Contract cp st vd)
importContract FilePath
file =
(ViewInterfaceMatchError -> IO (Contract cp st vd))
-> (Contract cp st vd -> IO (Contract cp st vd))
-> Either ViewInterfaceMatchError (Contract cp st vd)
-> IO (Contract cp st vd)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ViewInterfaceMatchError -> IO (Contract cp st vd)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Contract cp st vd -> IO (Contract cp st vd)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ViewInterfaceMatchError (Contract cp st vd)
-> IO (Contract cp st vd))
-> (Contract (ToT cp) (ToT st)
-> Either ViewInterfaceMatchError (Contract cp st vd))
-> Contract (ToT cp) (ToT st)
-> IO (Contract cp st vd)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath
-> Contract (ToT cp) (ToT st)
-> Either ViewInterfaceMatchError (Contract cp st vd)
forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd,
DemoteViewsDescriptor vd) =>
FilePath
-> Contract (ToT cp) (ToT st)
-> Either ViewInterfaceMatchError (Contract cp st vd)
mkImportedContract FilePath
file (Contract (ToT cp) (ToT st) -> IO (Contract cp st vd))
-> IO (Contract (ToT cp) (ToT st)) -> IO (Contract cp st vd)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO (Contract (ToT cp) (ToT st))
forall (cp :: T) (st :: T).
Each '[SingI] '[cp, st] =>
FilePath -> IO (Contract cp st)
M.importContract FilePath
file
embedContract
:: forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd)
=> FilePath -> TH.Code TH.Q (Contract cp st vd)
embedContract :: forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd,
DemoteViewsDescriptor vd) =>
FilePath -> Code Q (Contract cp st vd)
embedContract FilePath
path = IO FilePath -> Code Q (Contract cp st vd)
forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd,
DemoteViewsDescriptor vd) =>
IO FilePath -> Code Q (Contract cp st vd)
embedContractM (FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
path)
embedContractM
:: forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd)
=> IO FilePath -> TH.Code TH.Q (Contract cp st vd)
embedContractM :: forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd,
DemoteViewsDescriptor vd) =>
IO FilePath -> Code Q (Contract cp st vd)
embedContractM IO FilePath
pathM = Q (TExp (Contract cp st vd)) -> Code Q (Contract cp st vd)
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
M.embedTextFile FilePath
path
case forall (cp :: T) (st :: T).
Each '[SingI] '[cp, st] =>
MichelsonSource
-> Text -> Either ContractReadError (Contract cp st)
M.readContract @(T.ToT cp) @(T.ToT st) (FilePath -> MichelsonSource
MSFile FilePath
path) Text
contract of
Left ContractReadError
e ->
FilePath -> Q (TExp (Contract cp st vd))
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 (ToT cp) (ToT st)
tContract -> case forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd,
DemoteViewsDescriptor vd) =>
FilePath
-> Contract (ToT cp) (ToT st)
-> Either ViewInterfaceMatchError (Contract cp st vd)
mkImportedContract @cp @st @vd FilePath
path Contract (ToT cp) (ToT st)
tContract of
Left ViewInterfaceMatchError
e ->
FilePath -> Q (TExp (Contract cp st vd))
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (ViewInterfaceMatchError -> FilePath
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ViewInterfaceMatchError
e)
Right Contract cp st vd
_ -> Code Q (Contract cp st vd) -> Q (TExp (Contract cp st vd))
forall (m :: * -> *) a. Code m a -> m (TExp a)
TH.examineCode
[||
contract
& M.readContract (MSFile path)
& unsafe
& mkImportedContract path
& unsafe
||]
importValue :: forall a . T.IsoValue a => FilePath -> IO a
importValue :: forall a. IsoValue a => FilePath -> IO a
importValue = (Value (ToT a) -> a) -> IO (Value (ToT a)) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value (ToT a) -> a
forall a. IsoValue a => Value (ToT a) -> a
T.fromVal (IO (Value (ToT a)) -> IO a)
-> (FilePath -> IO (Value (ToT a))) -> FilePath -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO (Value (ToT a))
forall (t :: T). SingI t => FilePath -> IO (Value t)
M.importValue
embedValue :: forall a . T.IsoValue a => FilePath -> TH.Code TH.Q a
embedValue :: forall a. IsoValue a => FilePath -> Code Q a
embedValue = IO FilePath -> Code Q a
forall a. IsoValue a => IO FilePath -> Code Q a
embedValueM (IO FilePath -> Code Q a)
-> (FilePath -> IO FilePath) -> FilePath -> Code Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure
embedValueM :: forall a . T.IsoValue a => IO FilePath -> TH.Code TH.Q a
embedValueM :: forall a. IsoValue a => IO FilePath -> Code Q a
embedValueM IO FilePath
pathM = Q (TExp a) -> Code Q a
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
rawValue <- FilePath -> Q Text
M.embedTextFile FilePath
path
case forall (t :: T).
SingI t =>
MichelsonSource -> Text -> Either ValueReadError (Value t)
M.readValue @(T.ToT a) (FilePath -> MichelsonSource
MSFile FilePath
path) Text
rawValue of
Left ValueReadError
e -> FilePath -> Q (TExp a)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (ValueReadError -> FilePath
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ValueReadError
e)
Right Value (ToT a)
_ -> Code Q a -> Q (TExp a)
forall (m :: * -> *) a. Code m a -> m (TExp a)
TH.examineCode
[||
either (error . pretty) T.fromVal $
M.readValue (MSFile path) rawValue
||]