Michelson.hs

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

-- | Testing predicates for documentation of Michelson contracts
module Test.Cleveland.Doc.Michelson
  ( testDocBasic

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

    -- ** Re-exports
  , module Test.Cleveland.Doc.Common
  ) where

import Data.Text qualified as T
import Fmt (blockListF, fmt, nameF, pretty)
import Test.HUnit (assertBool, assertFailure)

import Morley.Michelson.Doc
import Morley.Michelson.Typed.Haskell.Doc
import Morley.Util.Text (dquotes)
import Test.Cleveland.Doc.Common

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

-- 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
    found <- forM (allContractDocItems contractDoc) $ \case
      DGitRevisionUnknown -> return ()
      _ -> assertFailure
        "Git revision already attached.\n\
        \This is considered a bad practice to attach it right in the library\n\
        \because updating git info will require more modules to rebuild.\n\n\
        \Consider using `DGitRevisionUnknown` in the contract and then\n\
        \`attachGitInfo` in executable, or derivative methods."
    case found of
      [] -> assertFailure
        "No Git revision placeholder found, Git info won't be included.\n\
        \Consider inserting 'contractGeneralDefault' to your contract."
      [()] -> pass
      _ -> assertFailure
        "Too many `DGitRevisionUnknown`s in the contract."

-- | 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" $
      any hasDocItem (allContractLayers contractDoc)
  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 'Lorentz.caseT' instead of 'Lorentz.entryCase').
testNoAdjacentDescriptions :: DocTest
testNoAdjacentDescriptions =
  mkDocTest "No two 'DDescription' appear under the same group" $
  \contractDoc ->
    forM_ (allContractLayers 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 dquotes txts
        _ -> pass

-- | Check that all descriptions are proper.
testDescriptionsAreWellFormatted :: DocTest
testDescriptionsAreWellFormatted =
  mkDocTest "Descriptions are well-formatted" $
  \contractDoc ->
    let res =
          allContractDocItems contractDoc <&> \(DDescription desc) ->
            check (pretty desc)
    in case nonEmpty (lefts res) of
      Nothing -> pass
      Just errs -> assertFailure . fmt $
        "Some descripions are not well formatted:\n" <> blockListF errs
  where
    check desc
      | T.null desc =
          Left "Empty description."
      | T.last (T.stripEnd desc) /= '.' =
          Left $ "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.\
               \Consider using `dStorage` to attach it." $
      not . null $ allContractDocItems @DStorageType contractDoc

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