Import.hs

-- 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 txt = do
  first (ICEParse filePath) $ parseExpandContract (Just filePath) txt

-- | Purely read a typed contract from Michelson textual representation.
readSomeContract
  :: FilePath
  -> Text
  -> Either ImportContractError SomeContract
readSomeContract filePath txt = do
  contract <- readUntypedContract filePath txt
  first (ICETypeCheck filePath) $
    typeCheckingWith def $ typeCheckContract 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 txt = do
  contract <- readUntypedContract filePath txt
  first (ICETypeCheck filePath) $
    typeCheckingWith def $ typeVerifyContract contract

-- | Read a thing from a file, using the provided parsing function.
importUsing
  :: (Exception e)
  => (FilePath -> Text -> Either e a)
  -> FilePath -> IO a
importUsing readFn file =
  either throwM pure . readFn file =<< Utf8.readFile 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 = importUsing 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 = importUsing readContract

-- | Version of 'importContract' that doesn't require you to know
-- contract's parameter and storage types.
importSomeContract :: FilePath -> IO SomeContract
importSomeContract = importUsing readSomeContract

-- | Error type for 'importContract' function.
data ImportContractError
  = ICEParse FilePath ParserException
  | ICETypeCheck FilePath TCError
  deriving stock (Show, Eq)

instance Buildable ImportContractError where
  build =
    \case
      ICEParse filePath e -> unlinesF
        [ "Error at " <> build filePath
        , "Failed to parse the contract: " +| e |+ ""
        ]
      ICETypeCheck filePath e -> unlinesF
        [ "Error at " <> build filePath
        , "The contract is ill-typed: " +| e |+ ""
        ]

instance Exception ImportContractError where
  displayException = 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 txt = do
  first (IVEParse filePath) $ parseExpandValueFromFile filePath 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 txt = do
  valueU <- readUntypedValue filePath txt
  first (IVETypeCheck filePath) $
    typeCheckingWith def $ typeCheckTopLevelType Nothing ty valueU

-- | Purely read a typed Michelson value from textual representation.
readValue
  :: forall t. SingI t
  => FilePath
  -> Text
  -> Either ImportValueError (Value t)
readValue filePath txt = do
  valueU <- readUntypedValue filePath txt
  first (IVETypeCheck filePath) $
    typeCheckingWith def $ typeVerifyTopLevelType Nothing valueU

-- | Import an untyped value from a given file path.
importUntypedValue :: FilePath -> IO U.Value
importUntypedValue = importUsing readUntypedValue

-- | Import a typed value from a given file path.
--
-- Expected type is provided explicitly.
importSomeValue :: U.Ty -> FilePath -> IO SomeValue
importSomeValue = importUsing . readSomeValue

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

-- | Error type for 'importValue' function.
data ImportValueError
  = IVEParse FilePath ParserException
  | IVETypeCheck FilePath TCError
  deriving stock (Show, Eq)

instance Buildable ImportValueError where
  build =
    \case
      IVEParse filePath e -> unlinesF
        [ "Error at " <> build filePath
        , "Failed to parse the value: " +| e |+ ""
        ]
      IVETypeCheck filePath e -> unlinesF
        [ "Error at " <> build filePath
        , "The value is ill-typed: " +| e |+ ""
        ]

instance Exception ImportValueError where
  displayException = pretty