-- | Utilities for testing documentations sanity.
--
-- These tests serve to ensure that documentation generation is not broken and
-- that user follows sane documentation structure (e.g. contract should be
-- named, some entities require description, e.t.c).
module Michelson.Doc.Test
  ( DocTest (..)
  , mkDocTest
  , excludeDocTest
  , excludeDocTests
  , runDocTests
  , expectDocTestFailure

    -- * Test predicates
  , testDocBasic

    -- ** Individual test predicates
  , testContractNameAtTop
  , testDocNotEmpty
  , testNoAdjacentDescriptions

    -- * Utilities
  , forEachContractLayer
  , forEachContractDocItem
  ) where

import qualified Data.Text as T
import Data.Text.Lazy.Builder (toLazyText)
import Fmt (Buildable(..), blockListF, fmt, nameF, pretty)
import GHC.Stack (SrcLoc)
import Test.HUnit (Assertion, assertBool, assertFailure)
import Test.HUnit.Lang (HUnitFailure(..))
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)
import qualified Text.Show

import Michelson.Doc

----------------------------------------------------------------------------
-- Framework
----------------------------------------------------------------------------

-- | Test case for contract documentation.
data DocTest = DocTest
  { dtDeclLoc :: SrcLoc
    -- ^ Declaration location, used to distinguish different test predicates.
    -- This is primarily used in 'excludeDocTest'.
  , dtDesc :: String
    -- ^ Description of predicate, which you put to 'testCase'.
  , dtSuite :: HasCallStack => ContractDoc -> Assertion
    -- ^ Test itself.
  }

instance Eq DocTest where
  (==) = (==) `on` dtDeclLoc

instance Show DocTest where
  show = pretty

instance Buildable DocTest where
  build DocTest{..} = "Doc test '" <> build dtDesc <> "'"

-- | Construct 'DocTest'.
mkDocTest
  :: HasCallStack
  => String
  -> (HasCallStack => ContractDoc -> Assertion)
  -> DocTest
mkDocTest dtDesc dtSuite = DocTest{..}
  where
  (_, dtDeclLoc) = case getCallStack callStack of
    [] -> error "Callstacks operate in a weird way, excluding doc tests won't work"
    layer : _ -> layer

-- | Exclude given test suite.
excludeDocTest :: HasCallStack => DocTest -> [DocTest] -> [DocTest]
excludeDocTest toExclude tests
  | toExclude `elem` tests = filter (/= toExclude) tests
  | otherwise = error $ "Not in the list of doc items: " <> pretty toExclude

-- | Calling @excludeDocTests tests toExclude@ returns all test suites from
-- @tests@ which are not present in @toExclude@.
excludeDocTests :: [DocTest] -> [DocTest] -> [DocTest]
excludeDocTests = foldr excludeDocTest

-- | Finalize test suites.
runDocTests :: HasCallStack => [DocTest] -> ContractDoc -> [TestTree]
runDocTests tests contract =
  tests <&> \DocTest{..} ->
    testCase dtDesc (dtSuite contract)

-- | Ensure that 'DocTest' check fires on given contract.
-- Used in tests on this module.
expectDocTestFailure :: DocTest -> ContractDoc -> Assertion
expectDocTestFailure DocTest{..} contract = do
  passed <- (dtSuite contract $> True) `catch` \HUnitFailure{} -> pure False
  when passed $ assertFailure "Test didn't fail unexpectedly"

----------------------------------------------------------------------------
-- Test predicates
----------------------------------------------------------------------------

-- Utilities
----------------------------------------------------------------------------

-- | Apply given function to each group (created with 'DocGroup' instruction)
-- recursively.
-- This function will accept grouping doc item itself and its subcontents.
forEachLayer :: DocBlock -> (SomeDocItem -> DocBlock -> r) -> [r]
forEachLayer block f = do
  DocSection docElems <- toList block
  DocElem{..} <- toList docElems
  Just (SubDoc sub) <- pure deSub
  f (SomeDocItem deItem) sub : forEachLayer sub f

-- | Apply given function to each group (created with 'DocGroup' instruction)
-- within a contract recursively.
-- This function will accept grouping doc item itself (unless we are at root)
-- and its subcontents.
forEachContractLayer :: ContractDoc -> (Maybe SomeDocItem -> DocBlock -> r) -> [r]
forEachContractLayer contract f =
  let contents = cdContents contract
  in f Nothing contents
   : forEachLayer contents (\sdi blk -> f (Just sdi) blk)

-- | Apply given function to each doc item within a contract.
forEachContractDocItem :: DocItem d => ContractDoc -> (d -> r) -> [r]
forEachContractDocItem contract f =
  fold . forEachContractLayer contract $ \_ block ->
    fmap f . maybe [] toList $ lookupDocBlockSection block

-- Basic predicates
----------------------------------------------------------------------------

-- | Check that contract documentation is wrapped with 'contractName'.
testContractNameAtTop :: DocTest
testContractNameAtTop =
  mkDocTest "The whole contract is wrapped into 'DName'" $
  \contractDoc ->
    assertBool "There is no 'DName' at the top" . isJust $
      lookupDocBlockSection @DName (cdContents contractDoc)

-- | Check that there is at least one non-grouping doc item.
--
-- If there is no such, rendered documentation will be empty which signals about
-- most of the documentation pieces being lost.
testDocNotEmpty :: DocTest
testDocNotEmpty =
  mkDocTest "There is at least one DOC_ITEM" $
  \contractDoc ->
    assertBool "No doc items found" . or $
      forEachContractLayer contractDoc hasDocItem
  where
    hasDocItem _ block = not . null @[()] $ do
      DocSection docElems <- toList block
      docElem <- toList docElems
      guard (deIsAtomic docElem)

-- | Check that no group contains two 'DDescription' items.
--
-- Normally such behaviour is allowed and can be exploited, but often it is not
-- and multiple descriptions appearence under the same group signals about
-- missing grouping wrapper (e.g. use of 'caseT' instead of 'entryCase').
testNoAdjacentDescriptions :: DocTest
testNoAdjacentDescriptions =
  mkDocTest "No two 'DDescription' appear under the same group" $
  \contractDoc ->
    sequence_ . forEachContractLayer contractDoc $ \_ block ->
      case lookupDocBlockSection @DDescription block of
        Just ds@(_ :| _ : _) ->
          let txts = ds <&> \(DDescription txt) -> txt
          in assertFailure . fmt $
             nameF "Found multiple adjacent descriptions" $
             blockListF $ map quotes txts
        _ -> pass
    where
      quotes t = "\"" <> t <> "\""

-- | Check that all descriptions are proper.
testDescriptionsAreWellFormatted :: DocTest
testDescriptionsAreWellFormatted =
  mkDocTest "Descriptions are well-formatted" $
  \contractDoc ->
    sequence_ . forEachContractDocItem contractDoc $ \(DDescription desc) ->
      check (toText $ toLazyText desc)
  where
    check desc
      | T.null desc =
          assertFailure "Empty description."
      | T.last (T.stripEnd desc) /= '.' =
          assertFailure $ "Description does not end with a dot:\n\"" <>
                          toString desc <> "\""
      | otherwise = pass

-- | Base properties which should comply for all documentations.
testDocBasic :: [DocTest]
testDocBasic =
  [ testContractNameAtTop
  , testDocNotEmpty
  , testNoAdjacentDescriptions
  , testDescriptionsAreWellFormatted
  ]