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

    -- * Test predicates
  , testDocBasic

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

    -- * Utilities
  , forEachContractLayer
  , forEachContractDocItem
  ) where

import qualified Data.List as L
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
import Michelson.Typed.Haskell.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'.
--
-- 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 possible if someone abused 'mkDocTest' and created a function
      -- which calls it and this function is used to create multiple predicates
      error "Running invalid doc predicates: multiple ones were considered equal"
    ([_], 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 :: 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 -> do
    let mSections = lookupDocBlockSection @DName (cdContents contractDoc)
    case mSections of
      Nothing -> assertFailure "There is no 'DName' at the top"
      Just _ -> return ()

-- | Check that contracts themselves do not set the git revision. It is supposed to be filled only
-- in the executable.
testNoGitInfo :: DocTest
testNoGitInfo =
  mkDocTest "Git revision is not set in the contract" $
  \contractDoc -> do
    assertions <- sequence $ forEachContractDocItem contractDoc $ \case
      DGitRevisionUnknown -> return ()
      _ -> assertFailure "Unexpected Git revision"
    assertBool "No Git revision placeholder found or more than one" $
      (length assertions == 1)

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

-- | Test whether storage documentation is included in the contract's documentation.
testStorageIsDocumented :: DocTest
testStorageIsDocumented =
  mkDocTest "Storage documentation is included" $
  \contractDoc -> assertBool "No documentation for storage in the contract." $
    or $ forEachContractDocItem contractDoc $ \(DStorageType _) -> True

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