Lorentz.hs

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

-- | Testing predicates for documentation of Lorentz contracts.
module Test.Cleveland.Doc.Lorentz
  ( -- * Test predicates
    testLorentzDoc

    -- * Individual test predicates
  , testDeclaresParameter
  , testEachEntrypointIsDescribed
  , testParamBuildingStepsAreFinalized
  , testAllEntrypointsAreCallable
  , testAllErrorsBelongToEntrypoints

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

import Data.Typeable (typeRep)
import Fmt (Buildable(..), blockListF, fmt, nameF, (+|), (|+))
import Test.HUnit (assertBool, assertFailure)

import Lorentz.Entrypoints.Doc
import Lorentz.Errors
import Morley.Michelson.Doc
import Morley.Util.Markdown
import Morley.Util.Text (dquotes)
import Test.Cleveland.Doc.Common
import Test.Cleveland.Doc.Michelson (testDocBasic)

-- | All ways of describing an entrypoint behaviour.
data DocEpDescription
  = DocEpDescription DDescription
  | DocEpReference DEntrypointReference

instance Buildable DocEpDescription where
  build = \case
    DocEpDescription (DDescription txt) ->
      "description: " <> txt
    DocEpReference (DEntrypointReference name (Anchor anchor)) ->
      "reference \"" <> build name <> "\" (" <> build anchor <> ")"

-- | Extract 'DocEpDescription's of a documentation block.
lookupDocEpDescription :: DocBlock -> [DocEpDescription]
lookupDocEpDescription block = mconcat
  [ map DocEpDescription . maybe [] toList $ lookupDocBlockSection block
  , map DocEpReference . maybe [] toList $ lookupDocBlockSection block
  ]

-- | Check that contract documents its parameter.
testDeclaresParameter :: DocTest
testDeclaresParameter =
  mkDocTest "Contract parameter is documented" $
  \contractDoc ->
    assertBool "No doc items describing contract parameter found" $
      any check (allContractLayers contractDoc)
  where
    check (Nothing, _) = False
    check (Just sdi, _) =
      -- Currently the only way to document parameter (mentioning type of each arm)
      -- is using 'entryCase'. This may not suit for small contracts, then
      -- someone needs to invent another way to document parameter and also mention
      -- it below.
      case sdi of
        DEntrypointDocItem _ -> True
        _ -> False

-- | Check that no group contains two 'DDescription' or 'DEntrypointReference'
-- items.
--
-- This is a stricter version of 'Test.Cleveland.Doc.Michelson.testNoAdjacentDescriptions' test.
testNoAdjacentEpDescriptions :: DocTest
testNoAdjacentEpDescriptions =
  mkDocTest "No two 'DDescription' appear under the same group" $
  \contractDoc ->
    forM_ (allContractLayers contractDoc) $ \(_, block) ->
      case lookupDocEpDescription block of
        ds@(_ : _ : _) ->
          assertFailure . fmt $
             nameF "Found multiple adjacent entrypoint descriptions" $
             blockListF $ map (dquotes . build) (toList ds)
        _ -> pass

-- | It's a common issue to forget to describe an entrypoint.
testEachEntrypointIsDescribed :: DocTest
testEachEntrypointIsDescribed =
  mkDocTest "Each entrypoint has 'DDescription'" $
  \contractDoc -> do
    missingDescs :: [Text] <-
      fmap catMaybes . sequence $ allContractLayers contractDoc <&>
        \(mDocItem, block) -> runMaybeT $ do
          DEntrypointDocItem dep <- MaybeT . pure $ mDocItem
          [] <- pure $ lookupDocEpDescription block
          return (depName dep)

    case nonEmpty missingDescs of
      Nothing -> pass
      Just descs ->
        assertFailure . fmt $
          "Descriptions for the following entrypoints are not found: \n" <>
          blockListF descs <>
          "Put e.g. `doc $ DDescription \"text\"` in the entrypoint logic to \
          \fix this."

-- | Check that 'finalizeParamCallingDoc' is applied to the contract as it
-- always should.
testParamBuildingStepsAreFinalized :: DocTest
testParamBuildingStepsAreFinalized =
  mkDocTest "'finalizeParamCallingDoc' is applied" $
  \contractDoc -> do
    forM_ (allContractDocItems contractDoc) $ \DEntrypointArg{..} ->
      unless (areFinalizedParamBuildingSteps epaBuilding) $
        assertFailure
          "Found unfinalized param building steps, \
          \'How to call this entrypoint' section will not be acknowledged of \
          \contract entrypoints coming from field annotations and may be incorrect.\n\
          \Do you pick documentation of the entire 'Contract', not just contract code? \
          \If the latter is necessary, please call 'finalizeParamCallingDoc' manually."

-- | Check that all documented entrypoints are callable.
--
-- Sometimes having such an entrypoint is fine, e.g. when you have an explicit
-- default entrypoint deep in one arm then other arms (entire arms, not
-- individual entrypoints within them) are uncallable unless also assigned a
-- field annotation; for example see [doc for uncallable entrypoints] note.
-- If this is your case, exclude this test suite with 'excludeDocTest'.
-- But such situations are rare.
--
-- More often, this test failure indicates that entrypoints are documented
-- incorrectly, e.g. 'Lorentz.caseT' is used in some place instead of 'entryCase'.
-- Check whether printed building steps are correct.
--
-- NB: another, simplified example of case when disabling this test is
-- justified:
--
-- @
-- data SubParam1 = Do1 | Default
-- data SubParam2 = Do2 | Do3
-- data Param = Arm1 SubParam1 | Arm2 SubParam2
--   -- ^ with entrypoints derived via t'Lorentz.Entrypoints.EpdRecursive'
-- @
--
-- In this case entire @Arm1@ and @Arm2@ are not true entrypoints, only @Default@
-- and @Do{1,2,3}@ are, but @Arm1@ and @Arm2@ will still appear in documentation
-- as entrypoints.
testAllEntrypointsAreCallable :: DocTest
testAllEntrypointsAreCallable =
  mkDocTest "All entrypoints are callable" $
  \contractDoc ->
    forM_ (allContractDocItems contractDoc) $ \DEntrypointArg{..} ->
      forM_ epaBuilding $ \case
        PbsUncallable pbs ->
          assertFailure . fmt $
            "Found an uncallable entrypoint.\n\
            \Dummy parameter building steps for it: " <> blockListF (reverse pbs)
        _ -> pass

-- | Check that no error is thrown outside of entrypoint.
--
-- This is possible e.g. when some check is performed in the beginning of the
-- contract, before an entrypoint is selected and executed.
--
-- All errors (except for internal ones) must belong to some entrypoint for
-- documetation to be constructed sanely. Thus it might be necessary to create
-- a special section common for multiple entrypoints to include that error.
testAllErrorsBelongToEntrypoints :: DocTest
testAllErrorsBelongToEntrypoints =
  mkDocTest "All errors belong to some entrypoint" $
  \contractDoc ->
    forM_ (allContractLayers contractDoc) $ \(mGroup, block) ->
      case lookupDocBlockSection @DThrows block of
        Nothing -> pass
        Just (DThrows (_ :: Proxy err) :| _) ->
          if | Just DEntrypointDocItem{} <- mGroup -> pass
                -- Internal errors might be freely used everywhere and we do not
                -- display them on per-entrypoint basis, so we don't really care
                -- if they appear outside of all entrypoints
              | isInternalErrorClass (errorDocClass @err) -> pass
              | otherwise -> assertFailure . fmt $
                "Found an error `" +| show @Text (typeRep (Proxy @err)) |+ "` \
                \thrown outside of any entrypoint.\n\n\
                \If this should not belong to any existing entrypoint,\n\
                \consider marking the code as common for other entrypoints using\n\
                \CommonContractBehaviourKind or CommonEntrypointsBehaviourKind."

-- | Tests all properties.
testLorentzDoc :: [DocTest]
testLorentzDoc = mconcat
  [ testDocBasic
  , [ testDeclaresParameter
    , testNoAdjacentEpDescriptions
    , testEachEntrypointIsDescribed
    , testParamBuildingStepsAreFinalized
    , testAllEntrypointsAreCallable
    , testAllErrorsBelongToEntrypoints
    ]
  ]