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

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

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

    -- * Generic helpers
  , MichelsonSource(..)
  , importUsing
  ) where

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

import Morley.Michelson.Parser (parseExpandValue)
import Morley.Michelson.Parser.Error (ParserException(..))
import Morley.Michelson.Parser.Types (MichelsonSource(..))
import Morley.Michelson.Runtime (parseExpandContract)
import Morley.Michelson.TypeCheck
  (TcError, typeCheckContract, typeCheckTopLevelType, typeCheckingWith, typeVerifyContract,
  typeVerifyTopLevelType)
import Morley.Michelson.Typed (Contract, SingI, SomeContract(..), SomeValue, Value)
import Morley.Michelson.Untyped qualified as U

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

-- | Purely read an untyped contract from Michelson textual representation.
--
-- 'MichelsonSource' is accepted solely as a hint for error messages.
readUntypedContract
  :: MichelsonSource
  -> Text
  -> Either ContractReadError U.Contract
readUntypedContract :: MichelsonSource -> Text -> Either ContractReadError Contract
readUntypedContract MichelsonSource
source Text
txt = do
  (ParserException -> ContractReadError)
-> Either ParserException Contract
-> Either ContractReadError Contract
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (MichelsonSource -> ParserException -> ContractReadError
CREParse MichelsonSource
source) (Either ParserException Contract
 -> Either ContractReadError Contract)
-> Either ParserException Contract
-> Either ContractReadError Contract
forall a b. (a -> b) -> a -> b
$ MichelsonSource -> Text -> Either ParserException Contract
parseExpandContract MichelsonSource
source Text
txt

-- | Purely read a typed contract from Michelson textual representation.
readSomeContract
  :: MichelsonSource
  -> Text
  -> Either ContractReadError SomeContract
readSomeContract :: MichelsonSource -> Text -> Either ContractReadError SomeContract
readSomeContract MichelsonSource
source Text
txt = do
  Contract
contract <- MichelsonSource -> Text -> Either ContractReadError Contract
readUntypedContract MichelsonSource
source Text
txt
  (TcError -> ContractReadError)
-> Either TcError SomeContract
-> Either ContractReadError SomeContract
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (MichelsonSource -> TcError -> ContractReadError
CRETypeCheck MichelsonSource
source) (Either TcError SomeContract
 -> Either ContractReadError SomeContract)
-> Either TcError SomeContract
-> Either ContractReadError SomeContract
forall a b. (a -> b) -> a -> b
$
    TypeCheckOptions
-> TypeCheckResult ExpandedOp SomeContract
-> Either TcError SomeContract
forall op a.
TypeCheckOptions -> TypeCheckResult op a -> Either (TcError' op) a
typeCheckingWith TypeCheckOptions
forall a. Default a => a
def (TypeCheckResult ExpandedOp SomeContract
 -> Either TcError SomeContract)
-> TypeCheckResult ExpandedOp SomeContract
-> Either TcError SomeContract
forall a b. (a -> b) -> a -> b
$ Contract -> TypeCheckResult ExpandedOp 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]
  => MichelsonSource
  -> Text
  -> Either ContractReadError (Contract cp st)
readContract :: forall (cp :: T) (st :: T).
Each '[SingI] '[cp, st] =>
MichelsonSource
-> Text -> Either ContractReadError (Contract cp st)
readContract MichelsonSource
source Text
txt = do
  Contract
contract <- MichelsonSource -> Text -> Either ContractReadError Contract
readUntypedContract MichelsonSource
source Text
txt
  (TcError -> ContractReadError)
-> Either TcError (Contract cp st)
-> Either ContractReadError (Contract cp st)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (MichelsonSource -> TcError -> ContractReadError
CRETypeCheck MichelsonSource
source) (Either TcError (Contract cp st)
 -> Either ContractReadError (Contract cp st))
-> Either TcError (Contract cp st)
-> Either ContractReadError (Contract cp st)
forall a b. (a -> b) -> a -> b
$
    TypeCheckOptions
-> TypeCheckResult ExpandedOp (Contract cp st)
-> Either TcError (Contract cp st)
forall op a.
TypeCheckOptions -> TypeCheckResult op a -> Either (TcError' op) a
typeCheckingWith TypeCheckOptions
forall a. Default a => a
def (TypeCheckResult ExpandedOp (Contract cp st)
 -> Either TcError (Contract cp st))
-> TypeCheckResult ExpandedOp (Contract cp st)
-> Either TcError (Contract cp st)
forall a b. (a -> b) -> a -> b
$ Contract -> TypeCheckResult ExpandedOp (Contract cp st)
forall (cp :: T) (st :: T).
(SingI cp, SingI st) =>
Contract -> TypeCheckResult ExpandedOp (Contract cp st)
typeVerifyContract Contract
contract

-- | Read a thing from a file, using the provided parsing function.
importUsing
  :: (Exception e)
  => (MichelsonSource -> Text -> Either e a)
  -> FilePath -> IO a
importUsing :: forall e a.
Exception e =>
(MichelsonSource -> Text -> Either e a) -> FilePath -> IO a
importUsing MichelsonSource -> 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 a. 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
. MichelsonSource -> Text -> Either e a
readFn (FilePath -> MichelsonSource
MSFile 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 t'Control.Exception.IOException' and 'ContractReadError'.
importUntypedContract :: FilePath -> IO U.Contract
importUntypedContract :: FilePath -> IO Contract
importUntypedContract = (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
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 t'Control.Exception.IOException' and 'ContractReadError'.
importContract
  :: forall cp st .
     Each '[SingI] [cp, st]
  => FilePath -> IO (Contract cp st)
importContract :: forall (cp :: T) (st :: T).
Each '[SingI] '[cp, st] =>
FilePath -> IO (Contract cp st)
importContract = (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)
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 = (MichelsonSource -> Text -> Either ContractReadError SomeContract)
-> FilePath -> IO SomeContract
forall e a.
Exception e =>
(MichelsonSource -> Text -> Either e a) -> FilePath -> IO a
importUsing MichelsonSource -> Text -> Either ContractReadError SomeContract
readSomeContract

-- | Error type for 'importContract' function.
data ContractReadError
  = CREParse MichelsonSource ParserException
  | CRETypeCheck MichelsonSource TcError
  deriving stock (Int -> ContractReadError -> ShowS
[ContractReadError] -> ShowS
ContractReadError -> FilePath
(Int -> ContractReadError -> ShowS)
-> (ContractReadError -> FilePath)
-> ([ContractReadError] -> ShowS)
-> Show ContractReadError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ContractReadError -> ShowS
showsPrec :: Int -> ContractReadError -> ShowS
$cshow :: ContractReadError -> FilePath
show :: ContractReadError -> FilePath
$cshowList :: [ContractReadError] -> ShowS
showList :: [ContractReadError] -> ShowS
Show, ContractReadError -> ContractReadError -> Bool
(ContractReadError -> ContractReadError -> Bool)
-> (ContractReadError -> ContractReadError -> Bool)
-> Eq ContractReadError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ContractReadError -> ContractReadError -> Bool
== :: ContractReadError -> ContractReadError -> Bool
$c/= :: ContractReadError -> ContractReadError -> Bool
/= :: ContractReadError -> ContractReadError -> Bool
Eq)

instance Buildable ContractReadError where
  build :: ContractReadError -> Doc
build =
    \case
      CREParse MichelsonSource
source ParserException
e -> [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat
        [ Bool -> Doc -> Doc
unlessF (MichelsonSource
source MichelsonSource -> MichelsonSource -> Bool
forall a. Eq a => a -> a -> Bool
== MichelsonSource
MSUnspecified) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
            Doc
"Error at " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| MichelsonSource
source MichelsonSource -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
"\n"
        , Doc
"Failed to parse the contract: " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ParserException
e ParserException -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
"\n"
        ]
      CRETypeCheck MichelsonSource
source TcError
e -> [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat
        [ Bool -> Doc -> Doc
unlessF (MichelsonSource
source MichelsonSource -> MichelsonSource -> Bool
forall a. Eq a => a -> a -> Bool
== MichelsonSource
MSUnspecified) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
            Doc
"Error at " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| MichelsonSource
source MichelsonSource -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
"\n"
        , Doc
"The contract is ill-typed: " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| TcError
e TcError -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
"\n"
        ]

instance Exception ContractReadError where
  displayException :: ContractReadError -> FilePath
displayException = ContractReadError -> FilePath
forall a b. (Buildable a, FromDoc 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
  :: MichelsonSource
  -> Text
  -> Either ValueReadError U.Value
readUntypedValue :: MichelsonSource -> Text -> Either ValueReadError Value
readUntypedValue MichelsonSource
source Text
txt = do
  (ParserException -> ValueReadError)
-> Either ParserException Value -> Either ValueReadError Value
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (MichelsonSource -> ParserException -> ValueReadError
VREParse MichelsonSource
source) (Either ParserException Value -> Either ValueReadError Value)
-> Either ParserException Value -> Either ValueReadError Value
forall a b. (a -> b) -> a -> b
$ MichelsonSource -> Text -> Either ParserException Value
parseExpandValue MichelsonSource
source Text
txt

-- | Purely read a typed Michelson value from textual representation.
--
-- Expected type is provided explicitly.
readSomeValue
  :: U.Ty
  -> MichelsonSource
  -> Text
  -> Either ValueReadError SomeValue
readSomeValue :: Ty -> MichelsonSource -> Text -> Either ValueReadError SomeValue
readSomeValue Ty
ty MichelsonSource
source Text
txt = do
  Value
valueU <- MichelsonSource -> Text -> Either ValueReadError Value
readUntypedValue MichelsonSource
source Text
txt
  (TcError -> ValueReadError)
-> Either TcError SomeValue -> Either ValueReadError SomeValue
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (MichelsonSource -> TcError -> ValueReadError
VRETypeCheck MichelsonSource
source) (Either TcError SomeValue -> Either ValueReadError SomeValue)
-> Either TcError SomeValue -> Either ValueReadError SomeValue
forall a b. (a -> b) -> a -> b
$
    TypeCheckOptions
-> TypeCheckResult ExpandedOp SomeValue -> Either TcError SomeValue
forall op a.
TypeCheckOptions -> TypeCheckResult op a -> Either (TcError' op) a
typeCheckingWith TypeCheckOptions
forall a. Default a => a
def (TypeCheckResult ExpandedOp SomeValue -> Either TcError SomeValue)
-> TypeCheckResult ExpandedOp SomeValue -> Either TcError SomeValue
forall a b. (a -> b) -> a -> b
$ Maybe TcOriginatedContracts
-> Ty -> Value -> TypeCheckResult ExpandedOp 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
  => MichelsonSource
  -> Text
  -> Either ValueReadError (Value t)
readValue :: forall (t :: T).
SingI t =>
MichelsonSource -> Text -> Either ValueReadError (Value t)
readValue MichelsonSource
source Text
txt = do
  Value
valueU <- MichelsonSource -> Text -> Either ValueReadError Value
readUntypedValue MichelsonSource
source Text
txt
  (TcError -> ValueReadError)
-> Either TcError (Value t) -> Either ValueReadError (Value t)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (MichelsonSource -> TcError -> ValueReadError
VRETypeCheck MichelsonSource
source) (Either TcError (Value t) -> Either ValueReadError (Value t))
-> Either TcError (Value t) -> Either ValueReadError (Value t)
forall a b. (a -> b) -> a -> b
$
    TypeCheckOptions
-> TypeCheckResult ExpandedOp (Value t) -> Either TcError (Value t)
forall op a.
TypeCheckOptions -> TypeCheckResult op a -> Either (TcError' op) a
typeCheckingWith TypeCheckOptions
forall a. Default a => a
def (TypeCheckResult ExpandedOp (Value t) -> Either TcError (Value t))
-> TypeCheckResult ExpandedOp (Value t) -> Either TcError (Value t)
forall a b. (a -> b) -> a -> b
$ Maybe TcOriginatedContracts
-> Value -> TypeCheckResult ExpandedOp (Value t)
forall (t :: T).
SingI t =>
Maybe TcOriginatedContracts
-> Value -> TypeCheckResult ExpandedOp (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 = (MichelsonSource -> Text -> Either ValueReadError Value)
-> FilePath -> IO Value
forall e a.
Exception e =>
(MichelsonSource -> Text -> Either e a) -> FilePath -> IO a
importUsing MichelsonSource -> Text -> Either ValueReadError 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 = (MichelsonSource -> Text -> Either ValueReadError SomeValue)
-> FilePath -> IO SomeValue
forall e a.
Exception e =>
(MichelsonSource -> Text -> Either e a) -> FilePath -> IO a
importUsing ((MichelsonSource -> Text -> Either ValueReadError SomeValue)
 -> FilePath -> IO SomeValue)
-> (Ty
    -> MichelsonSource -> Text -> Either ValueReadError SomeValue)
-> Ty
-> FilePath
-> IO SomeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty -> MichelsonSource -> Text -> Either ValueReadError SomeValue
readSomeValue

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

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

instance Buildable ValueReadError where
  build :: ValueReadError -> Doc
build =
    \case
      VREParse MichelsonSource
source ParserException
e -> [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat
        [ Bool -> Doc -> Doc
unlessF (MichelsonSource
source MichelsonSource -> MichelsonSource -> Bool
forall a. Eq a => a -> a -> Bool
== MichelsonSource
MSUnspecified) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
            Doc
"Error at " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| MichelsonSource
source MichelsonSource -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
"\n"
        , Doc
"Failed to parse the value: " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ParserException
e ParserException -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
"\n"
        ]
      VRETypeCheck MichelsonSource
source TcError
e -> [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat
        [ Bool -> Doc -> Doc
unlessF (MichelsonSource
source MichelsonSource -> MichelsonSource -> Bool
forall a. Eq a => a -> a -> Bool
== MichelsonSource
MSUnspecified) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
            Doc
"Error at " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| MichelsonSource
source MichelsonSource -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
"\n"
        , Doc
"Invalid value for required type: " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| TcError
e TcError -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
"\n"
        ]

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