Common.hs

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

-- | 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 Test.Cleveland.Doc.Common
  ( DocTest (..)
  , mkDocTest
  , excludeDocTest
  , excludeDocTests
  , runDocTests
  , expectDocTestFailure

    -- * Utilities
  , allContractLayers
  , allContractDocItems

    -- * Misc
  , buildDocTest
  , buildMarkdownDocTest
  ) where

import qualified Data.List as L
import Fmt (Buildable(..), pretty)
import GHC.Stack (SrcLoc)
import Test.HUnit (Assertion, assertFailure)
import Test.HUnit.Lang (HUnitFailure(..))
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)
import qualified Text.Show

import Morley.Michelson.Doc

----------------------------------------------------------------------------
-- Misc test helpers
----------------------------------------------------------------------------

-- | Like 'buildDoc', but does not require documentation to be finalized.
buildDocTest :: ContainsDoc a => a -> ContractDoc
buildDocTest = buildDocUnfinalized

-- | Like 'buildMarkdownDoc', but does not require documentation to be finalized.
buildMarkdownDocTest :: ContainsDoc a => a -> LText
buildMarkdownDocTest = contractDocToMarkdown . buildDocUnfinalized

----------------------------------------------------------------------------
-- 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'.
--
-- Note: you should not declare helpers with this function rather use it
-- directly in every test suite.
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 =
  case L.partition (== toExclude) tests of
    ([], _) ->
      error $ "Not in the list of doc items: " <> pretty toExclude
    (_ : _ : _, _) ->
      -- This is e.g. possible if someone abused 'mkDocTest' and created a function
      -- which calls it and this function is used to create multiple predicates
      error "Multiple test predicates were considered equal.\n\
            \Either list of tests contains identical test predicates, \
            \or used predicates were constructed incorrectly."
    ([_], notExcluded) ->
      notExcluded

-- | 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 :: (ContainsDoc code, HasCallStack) => [DocTest] -> code -> [TestTree]
runDocTests tests (buildDocTest -> contractDoc) =
  tests <&> \DocTest{..} ->
    testCase dtDesc (dtSuite contractDoc)

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

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

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

-- | Collect all doc groups (created with @DocGroup@ instruction)
-- recursively.
-- The result will contain grouping doc item itself and its subcontents.
allLayers :: DocBlock -> [(SomeDocItem, DocBlock)]
allLayers block = do
  DocSection docElems <- toList block
  DocElem{..} <- toList docElems
  Just (SubDoc sub) <- pure deSub
  (SomeDocItem deItem, sub) : allLayers sub


-- | Collect all doc groups (created with @DocGroup@ instruction)
-- within a contract recursively.
-- The result will contain grouping doc item itself (unless we are at root)
-- and its subcontents.
allContractLayers :: ContractDoc -> [(Maybe SomeDocItem, DocBlock)]
allContractLayers contract =
  let contents = cdContents contract
  in (Nothing, contents)
   : (first Just <$> allLayers contents)

-- | Collect all doc items (atomic and grouping) recursively.
allContractDocItems :: DocItem d => ContractDoc -> [d]
allContractDocItems contract =
  fold $ allContractLayers contract <&> \(_, block) ->
    maybe [] toList $ lookupDocBlockSection block