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

-- TODO [#712]: Remove this next major release
{-# OPTIONS_GHC -Wno-deprecations #-}

-- | Functions to import contracts to be used in tests.

module Test.Cleveland.Michelson.Import
  (
    -- * Read, parse, typecheck
    readContract
  , readUntypedContract
  , readSomeContract
  , importContract
  , importUntypedContract
  , importSomeContract
  , embedContract
  , embedContractM
  , ContractReadError (..)

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

    -- * Tasty helpers
  , testTreesWithContract
  , testTreesWithTypedContract
  , testTreesWithUntypedContract
  , testTreesWithUntypedContractExt
  , testTreesWithTypedContractExt
  , concatTestTrees

    -- * HSpec helpers
  , specWithContract
  , specWithTypedContract
  , specWithUntypedContract

    -- * Helpers
  , embedTextFile
  ) where

import Control.Exception (IOException)
import Data.FileEmbed (makeRelativeToProject)
import Data.Text.IO.Utf8 qualified as Utf8 (readFile)
import Fmt (pretty)
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Syntax (qAddDependentFile)
import Test.HUnit (assertFailure)
import Test.Hspec (Spec, describe, expectationFailure, it, runIO)
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)

import Morley.Michelson.Runtime.Import
import Morley.Michelson.Typed (Contract, SingI)
import Morley.Michelson.Untyped qualified as U

{-# DEPRECATED
    specWithContract
  , specWithTypedContract
  , specWithUntypedContract

  "Use testTreesWithContract &c. instead"
  #-}

{-# DEPRECATED
    testTreesWithUntypedContractExt
  , testTreesWithTypedContractExt

  "Morley extensions are deprecated"
  #-}

----------------------------------------------------------------------------
-- tasty helpers
----------------------------------------------------------------------------

-- | Import contract and use to create test trees. Both versions of contract are
-- passed to the callback function (untyped and typed).
--
-- If contract's import fails, a tree with single failing test will be generated
-- (so test tree will likely be generated unexceptionally, but a failing
-- result will notify about problem).
testTreesWithContract
  :: (Each '[SingI] [cp, st], HasCallStack)
  => FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithContract = testTreesWithContractImpl importContract

-- | Like 'testTreesWithContract' but supplies only untyped contract.
testTreesWithUntypedContract
  :: HasCallStack
  => FilePath -> (U.Contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithUntypedContract =
  testTreesWithContractImpl importUntypedContract

-- | Like 'testTreesWithContract' but supplies only untyped contract
-- with Morley extensions (deprecated).
testTreesWithUntypedContractExt
  :: HasCallStack
  => FilePath -> (U.Contract -> IO [TestTree]) -> IO [TestTree]
testTreesWithUntypedContractExt =
  testTreesWithContractImpl (importUsing readUntypedContractExt)

-- | Like 'testTreesWithContract' but supplies only typed contract.
testTreesWithTypedContract
  :: (Each '[SingI] [cp, st], HasCallStack)
  => FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithTypedContract =
  testTreesWithContractImpl importContract

-- | Like 'testTreesWithContract' but supplies only typed contract
-- with Morley extensions (deprecated).
testTreesWithTypedContractExt
  :: (Each '[SingI] [cp, st], HasCallStack)
  => FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree]
testTreesWithTypedContractExt =
  testTreesWithContractImpl (importUsing readContractExt)

testTreesWithContractImpl
  :: HasCallStack
  => (FilePath -> IO contract)
  -> FilePath
  -> (contract -> IO [TestTree])
  -> IO [TestTree]
testTreesWithContractImpl doImport file testImpl =
  saferImport doImport file >>= \case
    Left err -> pure [testCase ("Import contract " <> file) $ assertFailure err]
    Right contract -> testImpl contract

-- A helper function which allows you to use multiple
-- 'testTreesWithTypedContract' in a single top-level test with type
-- 'IO [TestTree]'.
concatTestTrees :: [IO [TestTree]] -> IO [TestTree]
concatTestTrees = fmap concat . sequence

----------------------------------------------------------------------------
-- hspec helpers
----------------------------------------------------------------------------

-- | Import contract and use it in the spec. Both versions of contract are
-- passed to the callback function (untyped and typed).
--
-- If contract's import fails, a spec with single failing expectation
-- will be generated (so tests will likely run unexceptionally, but a failing
-- result will notify about problem).
specWithContract
  :: (Each '[SingI] [cp, st], HasCallStack)
  => FilePath -> (Contract cp st -> Spec) -> Spec
specWithContract = specWithContractImpl importContract

-- | A version of 'specWithContract' which passes only the typed
-- representation of the contract.
specWithTypedContract
  :: (Each '[SingI] [cp, st], HasCallStack)
  => FilePath -> (Contract cp st -> Spec) -> Spec
specWithTypedContract = specWithContractImpl importContract

specWithUntypedContract :: FilePath -> (U.Contract -> Spec) -> Spec
specWithUntypedContract = specWithContractImpl importUntypedContract

specWithContractImpl
  :: HasCallStack
  => (FilePath -> IO contract) -> FilePath -> (contract -> Spec) -> Spec
specWithContractImpl doImport file execSpec =
  either errorSpec (describe ("Test contract " <> file) . execSpec)
    =<< runIO (saferImport doImport file)
  where
    errorSpec = it ("Import contract " <> file) . expectationFailure

----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------

-- Catch some errors during contract import, we don't want the whole
-- test suite to crash if something like that happens.
saferImport :: (FilePath -> IO contract) -> FilePath -> IO (Either String contract)
saferImport doImport file =
  ((Right <$> doImport file)
  `catch` \(e :: ContractReadError) -> pure $ Left $ displayException e)
  `catch` \(e :: IOException) -> pure $ Left $ displayException e

----------------------------------------------------------------------------
-- Embedding contract
----------------------------------------------------------------------------

-- | Read a file with textual content at compile time.
--
-- Unlike @embedFile@ from the library, returns typed content.
embedTextFile :: FilePath -> TH.Q Text
embedTextFile rawPath = do
  path <- makeRelativeToProject rawPath
  qAddDependentFile rawPath
  Utf8.readFile path

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

Use it like:

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

or

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

-}
embedContract
  :: forall cp st. (SingI cp, SingI st)
  => FilePath -> TH.TExpQ (Contract cp st)
embedContract path = embedContractM (pure path)

-- | Version of 'embedContract' that accepts a filepath constructor in IO.
--
-- Useful when the path should depend on environmental variables or other
-- user input.
embedContractM
  :: forall cp st. (SingI cp, SingI st)
  => IO FilePath -> TH.TExpQ (Contract cp st)
embedContractM pathM = do
  path <- TH.runIO pathM
  contract <- embedTextFile path
  case readContract @cp @st (MSFile path) contract of
    Left e ->
      -- Emit a compiler error if the contract cannot be read.
      fail (pretty e)
    Right _ ->
      -- Emit a haskell expression that reads the contract.
      [||
        -- Note: it's ok to use `unsafe` here, because we just proved that the contrPact
        -- can be parsed+typechecked.
        unsafe $
          readContract (MSFile path) contract
      ||]