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

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

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

  , module Michelson.Doc.Test
  ) where

import Fmt (Buildable(..), blockListF, fmt, nameF, pretty)
import Test.HUnit (assertBool, assertFailure)

import Lorentz.EntryPoints.Doc
import Michelson.Doc
import Michelson.Doc.Test
import Util.Markdown
import Util.Typeable

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

instance Buildable DocEpDescription where
  build :: DocEpDescription -> Builder
build = \case
    DocEpDescription (DDescription txt :: Builder
txt) ->
      "description: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
txt
    DocEpReference (DEntryPointReference name :: Text
name (Anchor anchor :: Text
anchor)) ->
      "reference \"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall p. Buildable p => p -> Builder
build Text
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> "\" (" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall p. Buildable p => p -> Builder
build Text
anchor Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ")"

-- | Extract 'DocEpDescription's of a documentation block.
lookupDocEpDescription :: DocBlock -> [DocEpDescription]
lookupDocEpDescription :: DocBlock -> [DocEpDescription]
lookupDocEpDescription block :: DocBlock
block = [[DocEpDescription]] -> [DocEpDescription]
forall a. Monoid a => [a] -> a
mconcat
  [ (DDescription -> DocEpDescription)
-> [DDescription] -> [DocEpDescription]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map DDescription -> DocEpDescription
DocEpDescription ([DDescription] -> [DocEpDescription])
-> (Maybe (NonEmpty DDescription) -> [DDescription])
-> Maybe (NonEmpty DDescription)
-> [DocEpDescription]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DDescription]
-> (NonEmpty DDescription -> [DDescription])
-> Maybe (NonEmpty DDescription)
-> [DDescription]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] NonEmpty DDescription -> [DDescription]
forall t. Container t => t -> [Element t]
toList (Maybe (NonEmpty DDescription) -> [DocEpDescription])
-> Maybe (NonEmpty DDescription) -> [DocEpDescription]
forall a b. (a -> b) -> a -> b
$ DocBlock -> Maybe (NonEmpty DDescription)
forall d. DocItem d => DocBlock -> Maybe (NonEmpty d)
lookupDocBlockSection DocBlock
block
  , (DEntryPointReference -> DocEpDescription)
-> [DEntryPointReference] -> [DocEpDescription]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map DEntryPointReference -> DocEpDescription
DocEpReference ([DEntryPointReference] -> [DocEpDescription])
-> (Maybe (NonEmpty DEntryPointReference)
    -> [DEntryPointReference])
-> Maybe (NonEmpty DEntryPointReference)
-> [DocEpDescription]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DEntryPointReference]
-> (NonEmpty DEntryPointReference -> [DEntryPointReference])
-> Maybe (NonEmpty DEntryPointReference)
-> [DEntryPointReference]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] NonEmpty DEntryPointReference -> [DEntryPointReference]
forall t. Container t => t -> [Element t]
toList (Maybe (NonEmpty DEntryPointReference) -> [DocEpDescription])
-> Maybe (NonEmpty DEntryPointReference) -> [DocEpDescription]
forall a b. (a -> b) -> a -> b
$ DocBlock -> Maybe (NonEmpty DEntryPointReference)
forall d. DocItem d => DocBlock -> Maybe (NonEmpty d)
lookupDocBlockSection DocBlock
block
  ]

-- | Check that contract documents its parameter.
testDeclaresParameter :: DocTest
testDeclaresParameter :: DocTest
testDeclaresParameter =
  HasCallStack =>
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
mkDocTest "Contract parameter is documented" ((HasCallStack => ContractDoc -> Assertion) -> DocTest)
-> (HasCallStack => ContractDoc -> Assertion) -> DocTest
forall a b. (a -> b) -> a -> b
$
  \contractDoc :: ContractDoc
contractDoc ->
    HasCallStack => String -> Bool -> Assertion
String -> Bool -> Assertion
assertBool "No doc items describing contract parameter found" (Bool -> Assertion) -> Bool -> Assertion
forall a b. (a -> b) -> a -> b
$
      [Bool] -> Bool
forall t. (Container t, Element t ~ Bool) => t -> Bool
or ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ ContractDoc -> (Maybe SomeDocItem -> DocBlock -> Bool) -> [Bool]
forall r.
ContractDoc -> (Maybe SomeDocItem -> DocBlock -> r) -> [r]
forEachContractLayer ContractDoc
contractDoc Maybe SomeDocItem -> DocBlock -> Bool
forall p. Maybe SomeDocItem -> p -> Bool
check
  where
    check :: Maybe SomeDocItem -> p -> Bool
check Nothing _ = Bool
False
    check (Just sdi :: SomeDocItem
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 SomeDocItem
sdi of
        SomeDocItem (d -> Maybe (DEntryPoint DummyPhantomType)
forall k (c :: k -> *) x.
(Typeable x, Typeable c,
 forall (phantom1 :: k) (phantom2 :: k).
 Coercible (c phantom1) (c phantom2)) =>
x -> Maybe (c DummyPhantomType)
castIgnoringPhantom -> Just DEntryPoint{}) -> Bool
True
        _ -> Bool
False

-- | Check that no group contains two 'DDescription' or 'DEntryPointReference'
-- items.
--
-- This is a stricter version of 'testNoAdjacentDescriptions' test.
testNoAdjacentEpDescriptions :: DocTest
testNoAdjacentEpDescriptions :: DocTest
testNoAdjacentEpDescriptions =
  HasCallStack =>
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
mkDocTest "No two 'DDescription' appear under the same group" ((HasCallStack => ContractDoc -> Assertion) -> DocTest)
-> (HasCallStack => ContractDoc -> Assertion) -> DocTest
forall a b. (a -> b) -> a -> b
$
  \contractDoc :: ContractDoc
contractDoc ->
    [Assertion] -> Assertion
forall t (m :: * -> *) a.
(Container t, Monad m, Element t ~ m a) =>
t -> m ()
sequence_ ([Assertion] -> Assertion)
-> ((Maybe SomeDocItem -> DocBlock -> Assertion) -> [Assertion])
-> (Maybe SomeDocItem -> DocBlock -> Assertion)
-> Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractDoc
-> (Maybe SomeDocItem -> DocBlock -> Assertion) -> [Assertion]
forall r.
ContractDoc -> (Maybe SomeDocItem -> DocBlock -> r) -> [r]
forEachContractLayer ContractDoc
contractDoc ((Maybe SomeDocItem -> DocBlock -> Assertion) -> Assertion)
-> (Maybe SomeDocItem -> DocBlock -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \_ block :: DocBlock
block ->
      case DocBlock -> [DocEpDescription]
lookupDocEpDescription DocBlock
block of
        ds :: [DocEpDescription]
ds@(_ : _ : _) ->
          String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion)
-> (Builder -> String) -> Builder -> Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> String
forall b. FromBuilder b => Builder -> b
fmt (Builder -> Assertion) -> Builder -> Assertion
forall a b. (a -> b) -> a -> b
$
             Builder -> Builder -> Builder
nameF "Found multiple adjacent entrypoint descriptions" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
             [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
blockListF ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (DocEpDescription -> Builder) -> [DocEpDescription] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Builder -> Builder
forall a. (Semigroup a, IsString a) => a -> a
quotes (Builder -> Builder)
-> (DocEpDescription -> Builder) -> DocEpDescription -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocEpDescription -> Builder
forall p. Buildable p => p -> Builder
build) ([DocEpDescription] -> [Element [DocEpDescription]]
forall t. Container t => t -> [Element t]
toList [DocEpDescription]
ds)
        _ -> Assertion
forall (f :: * -> *). Applicative f => f ()
pass
    where
      quotes :: a -> a
quotes t :: a
t = "\"" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
t a -> a -> a
forall a. Semigroup a => a -> a -> a
<> "\""

-- | It's a common issue to forget to describe an entrypoint.
testEachEntrypointIsDescribed :: DocTest
testEachEntrypointIsDescribed :: DocTest
testEachEntrypointIsDescribed =
  HasCallStack =>
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
mkDocTest "Each entrypoint has 'DDescription'" ((HasCallStack => ContractDoc -> Assertion) -> DocTest)
-> (HasCallStack => ContractDoc -> Assertion) -> DocTest
forall a b. (a -> b) -> a -> b
$
  \contractDoc :: ContractDoc
contractDoc ->
    [IO (Maybe Any)] -> Assertion
forall t (m :: * -> *) a.
(Container t, Monad m, Element t ~ m a) =>
t -> m ()
sequence_ ([IO (Maybe Any)] -> Assertion)
-> ((Maybe SomeDocItem -> DocBlock -> IO (Maybe Any))
    -> [IO (Maybe Any)])
-> (Maybe SomeDocItem -> DocBlock -> IO (Maybe Any))
-> Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractDoc
-> (Maybe SomeDocItem -> DocBlock -> IO (Maybe Any))
-> [IO (Maybe Any)]
forall r.
ContractDoc -> (Maybe SomeDocItem -> DocBlock -> r) -> [r]
forEachContractLayer ContractDoc
contractDoc ((Maybe SomeDocItem -> DocBlock -> IO (Maybe Any)) -> Assertion)
-> (Maybe SomeDocItem -> DocBlock -> IO (Maybe Any)) -> Assertion
forall a b. (a -> b) -> a -> b
$ \mDocItem :: Maybe SomeDocItem
mDocItem block :: DocBlock
block ->
      MaybeT IO Any -> IO (Maybe Any)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO Any -> IO (Maybe Any))
-> MaybeT IO Any -> IO (Maybe Any)
forall a b. (a -> b) -> a -> b
$ do
        SomeDocItem docItem :: d
docItem <- IO (Maybe SomeDocItem) -> MaybeT IO SomeDocItem
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe SomeDocItem) -> MaybeT IO SomeDocItem)
-> (Maybe SomeDocItem -> IO (Maybe SomeDocItem))
-> Maybe SomeDocItem
-> MaybeT IO SomeDocItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SomeDocItem -> IO (Maybe SomeDocItem)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SomeDocItem -> MaybeT IO SomeDocItem)
-> Maybe SomeDocItem -> MaybeT IO SomeDocItem
forall a b. (a -> b) -> a -> b
$ Maybe SomeDocItem
mDocItem
        dep :: DEntryPoint DummyPhantomType
dep@DEntryPoint{} <- IO (Maybe (DEntryPoint DummyPhantomType))
-> MaybeT IO (DEntryPoint DummyPhantomType)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe (DEntryPoint DummyPhantomType))
 -> MaybeT IO (DEntryPoint DummyPhantomType))
-> (Maybe (DEntryPoint DummyPhantomType)
    -> IO (Maybe (DEntryPoint DummyPhantomType)))
-> Maybe (DEntryPoint DummyPhantomType)
-> MaybeT IO (DEntryPoint DummyPhantomType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (DEntryPoint DummyPhantomType)
-> IO (Maybe (DEntryPoint DummyPhantomType))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (DEntryPoint DummyPhantomType)
 -> MaybeT IO (DEntryPoint DummyPhantomType))
-> Maybe (DEntryPoint DummyPhantomType)
-> MaybeT IO (DEntryPoint DummyPhantomType)
forall a b. (a -> b) -> a -> b
$ d -> Maybe (DEntryPoint DummyPhantomType)
forall k (c :: k -> *) x.
(Typeable x, Typeable c,
 forall (phantom1 :: k) (phantom2 :: k).
 Coercible (c phantom1) (c phantom2)) =>
x -> Maybe (c DummyPhantomType)
castIgnoringPhantom d
docItem
        [] <- [DocEpDescription] -> MaybeT IO [DocEpDescription]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DocEpDescription] -> MaybeT IO [DocEpDescription])
-> [DocEpDescription] -> MaybeT IO [DocEpDescription]
forall a b. (a -> b) -> a -> b
$ DocBlock -> [DocEpDescription]
lookupDocEpDescription DocBlock
block
        IO (Maybe Any) -> MaybeT IO Any
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Any) -> MaybeT IO Any)
-> (String -> IO (Maybe Any)) -> String -> MaybeT IO Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe Any)
forall a. HasCallStack => String -> IO a
assertFailure (String -> MaybeT IO Any) -> String -> MaybeT IO Any
forall a b. (a -> b) -> a -> b
$
          "Entrypoint '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (DEntryPoint DummyPhantomType -> Text
forall kind. DEntryPoint kind -> Text
depName DEntryPoint DummyPhantomType
dep) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "' does not contain \
          \any description.\n\
          \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 :: DocTest
testParamBuildingStepsAreFinalized =
  HasCallStack =>
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
mkDocTest "'finalizeParamCallingDoc' is applied" ((HasCallStack => ContractDoc -> Assertion) -> DocTest)
-> (HasCallStack => ContractDoc -> Assertion) -> DocTest
forall a b. (a -> b) -> a -> b
$
  \contractDoc :: ContractDoc
contractDoc ->
    [Assertion] -> Assertion
forall t (m :: * -> *) a.
(Container t, Monad m, Element t ~ m a) =>
t -> m ()
sequence_ ([Assertion] -> Assertion)
-> ((DEntryPointArg -> Assertion) -> [Assertion])
-> (DEntryPointArg -> Assertion)
-> Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractDoc -> (DEntryPointArg -> Assertion) -> [Assertion]
forall d r. DocItem d => ContractDoc -> (d -> r) -> [r]
forEachContractDocItem ContractDoc
contractDoc ((DEntryPointArg -> Assertion) -> Assertion)
-> (DEntryPointArg -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \DEntryPointArg{..} ->
      Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ParamBuildingStep] -> Bool
areFinalizedParamBuildingSteps [ParamBuildingStep]
epaBuilding) (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$
        String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure
          "Found unfinalized param building steps, \
          \'How to call this entrypoint' section may be incorrect.\n\
          \Have you applied 'finalizeParamCallingDoc' to your contract?"

-- | 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. `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 '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 :: DocTest
testAllEntrypointsAreCallable =
  HasCallStack =>
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
mkDocTest "All entrypoints are callable" ((HasCallStack => ContractDoc -> Assertion) -> DocTest)
-> (HasCallStack => ContractDoc -> Assertion) -> DocTest
forall a b. (a -> b) -> a -> b
$
  \contractDoc :: ContractDoc
contractDoc ->
    [Assertion] -> Assertion
forall t (m :: * -> *) a.
(Container t, Monad m, Element t ~ m a) =>
t -> m ()
sequence_ ([Assertion] -> Assertion)
-> ((DEntryPointArg -> Assertion) -> [Assertion])
-> (DEntryPointArg -> Assertion)
-> Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractDoc -> (DEntryPointArg -> Assertion) -> [Assertion]
forall d r. DocItem d => ContractDoc -> (d -> r) -> [r]
forEachContractDocItem ContractDoc
contractDoc ((DEntryPointArg -> Assertion) -> Assertion)
-> (DEntryPointArg -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \DEntryPointArg{..} ->
      [ParamBuildingStep]
-> (Element [ParamBuildingStep] -> Assertion) -> Assertion
forall t (m :: * -> *) b.
(Container t, Monad m) =>
t -> (Element t -> m b) -> m ()
forM_ [ParamBuildingStep]
epaBuilding ((Element [ParamBuildingStep] -> Assertion) -> Assertion)
-> (Element [ParamBuildingStep] -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \case
        PbsUncallable pbs ->
          String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion)
-> (Builder -> String) -> Builder -> Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> String
forall b. FromBuilder b => Builder -> b
fmt (Builder -> Assertion) -> Builder -> Assertion
forall a b. (a -> b) -> a -> b
$
            "Found an uncallable entrypoint.\n\
            \Dummy parameter building steps for it: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [ParamBuildingStep] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
blockListF ([ParamBuildingStep] -> [ParamBuildingStep]
forall a. [a] -> [a]
reverse [ParamBuildingStep]
pbs)
        _ -> Assertion
forall (f :: * -> *). Applicative f => f ()
pass

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