-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

module Michelson.Runtime.Import
  (
    -- * Read, parse, typecheck contract
    readContract
  , readSomeContract
  , readUntypedContract
  , importContract
  , importSomeContract
  , importUntypedContract
  , ImportContractError(..)

    -- * Read, parse, typecheck value
  , readValue
  , importValue
  , importSomeValue
  , importUntypedValue
  , ImportValueError (..)

    -- * Generic helpers
  , importUsing
  ) where

import Data.Default (def)
import qualified Data.Text.IO.Utf8 as Utf8 (readFile)
import Fmt (Buildable(build), pretty, unlinesF, (+|), (|+))

import Michelson.Parser (parseExpandValueFromFile)
import Michelson.Parser.Error (ParserException(..))
import Michelson.Runtime (parseExpandContract)
import Michelson.TypeCheck
  (TCError, typeCheckContract, typeCheckTopLevelType, typeCheckingWith,
  typeVerifyContract, typeVerifyTopLevelType)
import Michelson.Typed (Contract(..), SingI, SomeContract(..), SomeValue, Value)
import qualified Michelson.Untyped as U

----------------------------------------------------------------------------
-- Reading, parsing, typechecking contract
----------------------------------------------------------------------------

-- | Purely read an untyped contract from Michelson textual representation.
--
-- 'FilePath' is accepted solely as a hint for error messages.
readUntypedContract
  :: FilePath
  -> Text
  -> Either ImportContractError U.Contract
readUntypedContract :: FilePath -> Text -> Either ImportContractError Contract
readUntypedContract FilePath
filePath Text
txt = do
  (ParserException -> ImportContractError)
-> Either ParserException Contract
-> Either ImportContractError Contract
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FilePath -> ParserException -> ImportContractError
ICEParse FilePath
filePath) (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

-- | Purely read a typed contract from Michelson textual representation.
readSomeContract
  :: FilePath
  -> Text
  -> Either ImportContractError SomeContract
readSomeContract :: FilePath -> Text -> Either ImportContractError SomeContract
readSomeContract FilePath
filePath Text
txt = do
  Contract
contract <- FilePath -> Text -> Either ImportContractError Contract
readUntypedContract FilePath
filePath Text
txt
  (TCError -> ImportContractError)
-> Either TCError SomeContract
-> Either ImportContractError SomeContract
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FilePath -> TCError -> ImportContractError
ICETypeCheck FilePath
filePath) (Either TCError SomeContract
 -> Either ImportContractError SomeContract)
-> Either TCError SomeContract
-> Either ImportContractError SomeContract
forall a b. (a -> b) -> a -> b
$
    TypeCheckOptions
-> TypeCheckResult SomeContract -> Either TCError SomeContract
forall a. TypeCheckOptions -> TypeCheckResult a -> Either TCError a
typeCheckingWith TypeCheckOptions
forall a. Default a => a
def (TypeCheckResult SomeContract -> Either TCError SomeContract)
-> TypeCheckResult SomeContract -> Either TCError SomeContract
forall a b. (a -> b) -> a -> b
$ Contract -> TypeCheckResult SomeContract
typeCheckContract Contract
contract

-- | Purely read a typed contract from Michelson textual representation,
-- failing if parameter or storage types mismatch with the expected ones.
readContract
  :: forall cp st .
     Each '[SingI] [cp, st]
  => FilePath
  -> Text
  -> Either ImportContractError (Contract cp st)
readContract :: FilePath -> Text -> Either ImportContractError (Contract cp st)
readContract FilePath
filePath Text
txt = do
  Contract
contract <- FilePath -> Text -> Either ImportContractError Contract
readUntypedContract FilePath
filePath Text
txt
  (TCError -> ImportContractError)
-> Either TCError (Contract cp st)
-> Either ImportContractError (Contract cp st)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FilePath -> TCError -> ImportContractError
ICETypeCheck FilePath
filePath) (Either TCError (Contract cp st)
 -> Either ImportContractError (Contract cp st))
-> Either TCError (Contract cp st)
-> Either ImportContractError (Contract cp st)
forall a b. (a -> b) -> a -> b
$
    TypeCheckOptions
-> TypeCheckResult (Contract cp st)
-> Either TCError (Contract cp st)
forall a. TypeCheckOptions -> TypeCheckResult a -> Either TCError a
typeCheckingWith TypeCheckOptions
forall a. Default a => a
def (TypeCheckResult (Contract cp st)
 -> Either TCError (Contract cp st))
-> TypeCheckResult (Contract cp st)
-> Either TCError (Contract cp st)
forall a b. (a -> b) -> a -> b
$ Contract -> TypeCheckResult (Contract cp st)
forall (cp :: T) (st :: T).
(SingI cp, SingI st) =>
Contract -> TypeCheckResult (Contract cp st)
typeVerifyContract Contract
contract

-- | Read a thing from a file, using the provided parsing function.
importUsing
  :: (Exception e)
  => (FilePath -> Text -> Either e a)
  -> FilePath -> IO a
importUsing :: (FilePath -> Text -> Either e a) -> FilePath -> IO a
importUsing FilePath -> Text -> Either e a
readFn FilePath
file =
  (e -> IO a) -> (a -> IO a) -> Either e a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> IO a) -> (Text -> Either e a) -> Text -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text -> Either e a
readFn FilePath
file (Text -> IO a) -> IO Text -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO Text
forall (m :: * -> *). MonadIO m => FilePath -> m Text
Utf8.readFile FilePath
file

-- | Import untyped contract from a given file path.
--
-- This function reads file, and parses a contract.
--
-- This function may throw 'IOException' and 'ImportContractError'.
importUntypedContract :: FilePath -> IO U.Contract
importUntypedContract :: FilePath -> IO Contract
importUntypedContract = (FilePath -> Text -> Either ImportContractError Contract)
-> FilePath -> IO Contract
forall e a.
Exception e =>
(FilePath -> Text -> Either e a) -> FilePath -> IO a
importUsing FilePath -> Text -> Either ImportContractError Contract
readUntypedContract

-- | Import contract from a given file path.
--
-- This function reads file, parses and type checks a contract.
-- Within the typechecking we assume that no contracts are originated,
-- otherwise a type checking error will be caused.
--
-- This function may throw 'IOException' and 'ImportContractError'.
importContract
  :: forall cp st .
     Each '[SingI] [cp, st]
  => FilePath -> IO (Contract cp st)
importContract :: FilePath -> IO (Contract cp st)
importContract = (FilePath -> Text -> Either ImportContractError (Contract cp st))
-> FilePath -> IO (Contract cp st)
forall e a.
Exception e =>
(FilePath -> Text -> Either e a) -> FilePath -> IO a
importUsing FilePath -> Text -> Either ImportContractError (Contract cp st)
forall (cp :: T) (st :: T).
Each '[SingI] '[cp, st] =>
FilePath -> Text -> Either ImportContractError (Contract cp st)
readContract

-- | Version of 'importContract' that doesn't require you to know
-- contract's parameter and storage types.
importSomeContract :: FilePath -> IO SomeContract
importSomeContract :: FilePath -> IO SomeContract
importSomeContract = (FilePath -> Text -> Either ImportContractError SomeContract)
-> FilePath -> IO SomeContract
forall e a.
Exception e =>
(FilePath -> Text -> Either e a) -> FilePath -> IO a
importUsing FilePath -> Text -> Either ImportContractError SomeContract
readSomeContract

-- | Error type for 'importContract' function.
data ImportContractError
  = ICEParse FilePath ParserException
  | ICETypeCheck FilePath TCError
  deriving stock (Int -> ImportContractError -> ShowS
[ImportContractError] -> ShowS
ImportContractError -> FilePath
(Int -> ImportContractError -> ShowS)
-> (ImportContractError -> FilePath)
-> ([ImportContractError] -> ShowS)
-> Show ImportContractError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ImportContractError] -> ShowS
$cshowList :: [ImportContractError] -> ShowS
show :: ImportContractError -> FilePath
$cshow :: ImportContractError -> FilePath
showsPrec :: Int -> ImportContractError -> ShowS
$cshowsPrec :: Int -> ImportContractError -> ShowS
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
      ICEParse FilePath
filePath ParserException
e -> [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
        [ Builder
"Error at " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Builder
forall p. Buildable p => p -> Builder
build FilePath
filePath
        , Builder
"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
|+ Builder
""
        ]
      ICETypeCheck FilePath
filePath TCError
e -> [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
        [ Builder
"Error at " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Builder
forall p. Buildable p => p -> Builder
build FilePath
filePath
        , Builder
"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
|+ Builder
""
        ]

instance Exception ImportContractError where
  displayException :: ImportContractError -> FilePath
displayException = ImportContractError -> FilePath
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty

----------------------------------------------------------------------------
-- Reading, parsing, typechecking value
----------------------------------------------------------------------------

-- | Purely read an untyped Michelson value from textual representation.
--
-- 'FilePath' is accepted solely as a hint for error messages.
readUntypedValue
  :: FilePath
  -> Text
  -> Either ImportValueError U.Value
readUntypedValue :: FilePath -> Text -> Either ImportValueError Value
readUntypedValue FilePath
filePath Text
txt = do
  (ParserException -> ImportValueError)
-> Either ParserException Value -> Either ImportValueError Value
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FilePath -> ParserException -> ImportValueError
IVEParse FilePath
filePath) (Either ParserException Value -> Either ImportValueError Value)
-> Either ParserException Value -> Either ImportValueError Value
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> Either ParserException Value
parseExpandValueFromFile FilePath
filePath Text
txt

-- | Purely read a typed Michelson value from textual representation.
--
-- Expected type is provided explicitly.
readSomeValue
  :: U.Ty
  -> FilePath
  -> Text
  -> Either ImportValueError SomeValue
readSomeValue :: Ty -> FilePath -> Text -> Either ImportValueError SomeValue
readSomeValue Ty
ty FilePath
filePath Text
txt = do
  Value
valueU <- FilePath -> Text -> Either ImportValueError Value
readUntypedValue FilePath
filePath Text
txt
  (TCError -> ImportValueError)
-> Either TCError SomeValue -> Either ImportValueError SomeValue
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FilePath -> TCError -> ImportValueError
IVETypeCheck FilePath
filePath) (Either TCError SomeValue -> Either ImportValueError SomeValue)
-> Either TCError SomeValue -> Either ImportValueError SomeValue
forall a b. (a -> b) -> a -> b
$
    TypeCheckOptions
-> TypeCheckResult SomeValue -> Either TCError SomeValue
forall a. TypeCheckOptions -> TypeCheckResult a -> Either TCError a
typeCheckingWith TypeCheckOptions
forall a. Default a => a
def (TypeCheckResult SomeValue -> Either TCError SomeValue)
-> TypeCheckResult SomeValue -> Either TCError SomeValue
forall a b. (a -> b) -> a -> b
$ Maybe TcOriginatedContracts
-> Ty -> Value -> TypeCheckResult SomeValue
typeCheckTopLevelType Maybe TcOriginatedContracts
forall a. Maybe a
Nothing Ty
ty Value
valueU

-- | Purely read a typed Michelson value from textual representation.
readValue
  :: forall t. SingI t
  => FilePath
  -> Text
  -> Either ImportValueError (Value t)
readValue :: FilePath -> Text -> Either ImportValueError (Value t)
readValue FilePath
filePath Text
txt = do
  Value
valueU <- FilePath -> Text -> Either ImportValueError Value
readUntypedValue FilePath
filePath Text
txt
  (TCError -> ImportValueError)
-> Either TCError (Value t) -> Either ImportValueError (Value t)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FilePath -> TCError -> ImportValueError
IVETypeCheck FilePath
filePath) (Either TCError (Value t) -> Either ImportValueError (Value t))
-> Either TCError (Value t) -> Either ImportValueError (Value t)
forall a b. (a -> b) -> a -> b
$
    TypeCheckOptions
-> TypeCheckResult (Value t) -> Either TCError (Value t)
forall a. TypeCheckOptions -> TypeCheckResult a -> Either TCError a
typeCheckingWith TypeCheckOptions
forall a. Default a => a
def (TypeCheckResult (Value t) -> Either TCError (Value t))
-> TypeCheckResult (Value t) -> Either TCError (Value t)
forall a b. (a -> b) -> a -> b
$ Maybe TcOriginatedContracts -> Value -> TypeCheckResult (Value t)
forall (t :: T).
SingI t =>
Maybe TcOriginatedContracts -> Value -> TypeCheckResult (Value t)
typeVerifyTopLevelType Maybe TcOriginatedContracts
forall a. Maybe a
Nothing Value
valueU

-- | Import an untyped value from a given file path.
importUntypedValue :: FilePath -> IO U.Value
importUntypedValue :: FilePath -> IO Value
importUntypedValue = (FilePath -> Text -> Either ImportValueError Value)
-> FilePath -> IO Value
forall e a.
Exception e =>
(FilePath -> Text -> Either e a) -> FilePath -> IO a
importUsing FilePath -> Text -> Either ImportValueError Value
readUntypedValue

-- | Import a typed value from a given file path.
--
-- Expected type is provided explicitly.
importSomeValue :: U.Ty -> FilePath -> IO SomeValue
importSomeValue :: Ty -> FilePath -> IO SomeValue
importSomeValue = (FilePath -> Text -> Either ImportValueError SomeValue)
-> FilePath -> IO SomeValue
forall e a.
Exception e =>
(FilePath -> Text -> Either e a) -> FilePath -> IO a
importUsing ((FilePath -> Text -> Either ImportValueError SomeValue)
 -> FilePath -> IO SomeValue)
-> (Ty -> FilePath -> Text -> Either ImportValueError SomeValue)
-> Ty
-> FilePath
-> IO SomeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty -> FilePath -> Text -> Either ImportValueError SomeValue
readSomeValue

-- | Import a typed value from a given file path.
importValue
  :: forall t . SingI t
  => FilePath -> IO (Value t)
importValue :: FilePath -> IO (Value t)
importValue = (FilePath -> Text -> Either ImportValueError (Value t))
-> FilePath -> IO (Value t)
forall e a.
Exception e =>
(FilePath -> Text -> Either e a) -> FilePath -> IO a
importUsing FilePath -> Text -> Either ImportValueError (Value t)
forall (t :: T).
SingI t =>
FilePath -> Text -> Either ImportValueError (Value t)
readValue

-- | Error type for 'importValue' function.
data ImportValueError
  = IVEParse FilePath ParserException
  | IVETypeCheck FilePath TCError
  deriving stock (Int -> ImportValueError -> ShowS
[ImportValueError] -> ShowS
ImportValueError -> FilePath
(Int -> ImportValueError -> ShowS)
-> (ImportValueError -> FilePath)
-> ([ImportValueError] -> ShowS)
-> Show ImportValueError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ImportValueError] -> ShowS
$cshowList :: [ImportValueError] -> ShowS
show :: ImportValueError -> FilePath
$cshow :: ImportValueError -> FilePath
showsPrec :: Int -> ImportValueError -> ShowS
$cshowsPrec :: Int -> ImportValueError -> ShowS
Show, ImportValueError -> ImportValueError -> Bool
(ImportValueError -> ImportValueError -> Bool)
-> (ImportValueError -> ImportValueError -> Bool)
-> Eq ImportValueError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImportValueError -> ImportValueError -> Bool
$c/= :: ImportValueError -> ImportValueError -> Bool
== :: ImportValueError -> ImportValueError -> Bool
$c== :: ImportValueError -> ImportValueError -> Bool
Eq)

instance Buildable ImportValueError where
  build :: ImportValueError -> Builder
build =
    \case
      IVEParse FilePath
filePath ParserException
e -> [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
        [ Builder
"Error at " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Builder
forall p. Buildable p => p -> Builder
build FilePath
filePath
        , Builder
"Failed to parse the value: " 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
|+ Builder
""
        ]
      IVETypeCheck FilePath
filePath TCError
e -> [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
        [ Builder
"Error at " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Builder
forall p. Buildable p => p -> Builder
build FilePath
filePath
        , Builder
"The value 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
|+ Builder
""
        ]

instance Exception ImportValueError where
  displayException :: ImportValueError -> FilePath
displayException = ImportValueError -> FilePath
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty