Test.hs

-- | 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
  ) where

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)

-- 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 txts)
        _ -> pass

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