-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | Functions to import contracts to be used in tests.
module Test.Cleveland.Lorentz.Import
  ( -- * Read, parse, typecheck contracts
    importContract
  , embedContract
  , embedContractM
  , M.ContractReadError (..)

    -- * Read, parse, typecheck values
  , importValue
  , embedValue
  , embedValueM
  , M.ValueReadError (..)

    -- * Notes
    -- $embedDepends
  ) 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

-- | Import contract from a given 'FilePath'.
--
-- In this and similar functions, parameter and storage types must exactly match
-- the ones in the contract, while for views this is not necessary. Only
-- make sure that all views beyond @vd@ type are present in the contract; @()@
-- always works as views descriptor of the contract.
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

{- | Import a contract at compile time assuming its expected type is known.

Use it like:

> myContract :: Contract Parameter Storage
> myContract = $$(embedContract "my_contract.tz")

or

> let myContract = $$(embedContract @Parameter @Storage "my_contract.tz")

See also the note in "Test.Cleveland.Lorentz.Import#embedDepends"
-}
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)

-- | Version of 'embedContract' that accepts a filepath constructor in IO.
--
-- Useful when the path should depend on environmental variables or other
-- user input.
--
-- See also the note in "Test.Cleveland.Lorentz.Import#embedDepends"
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 ->
      -- Emit a compiler error if the contract cannot be read.
      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 ->
        -- Emit a compiler error if there are issues with constructing contract
        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)
      -- Emit a haskell expression that reads the contract.
      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
        [||
          -- Note: it's ok to use `unsafe` here, because we just proved that the contract
          -- can be parsed+typechecked.
          contract
            & M.readContract (MSFile path)
            & unsafe
            & mkImportedContract path
            & unsafe
        ||]

-- | Import a value from a given 'FilePath'
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

{- | Import a value from a given 'FilePath' at compile time
and embed it as a value using Template Haskell, f. ex.

> let someAddress = $$(embedValue @Address "/path/to/addressFile.tz")

See also the note in "Test.Cleveland.Lorentz.Import#embedDepends"
-}
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

-- | A variant of 'embedValue' that accepts 'FilePath' in 'IO'.
--
-- Can be useful when 'FilePath' depends on the environment.
--
-- See also the note in "Test.Cleveland.Lorentz.Import#embedDepends"
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
          [||
            -- Note: it's ok to use `error` here, because we just proved that the value
            -- can be parsed+typechecked.
            either (error . pretty) T.fromVal $
              M.readValue (MSFile path) rawValue
          ||]

{- $embedDepends

= On 'FilePath' argument with 'embedContract', 'embedValue' and variants #embedDepends#

The 'FilePath' argument is specified relative to the project root (if
using cabal-install or stack, the directory containing the Cabal file and/or @package.yaml@).

As an additional caveat, any files embedded this way are essentially compile-time dependencies. However,
build systems can't track these automatically. In general, it's advisable to add the files used
with 'embedContract', 'embedValue' and variants to the @extra-source-files@ section of the Cabal
file or @package.yaml@, if possible.
-}