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

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

    -- * Utilities
  , allContractLayers
  , allContractDocItems

    -- * Misc
  , buildDocTest
  , buildMarkdownDocTest
  ) where

import Data.List qualified as L
import Fmt (Buildable(..), pretty)
import GHC.Stack (SrcLoc)
import Test.HUnit (Assertion, assertFailure)
import Test.HUnit.Lang (HUnitFailure(..))
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)

import Morley.Michelson.Doc

----------------------------------------------------------------------------
-- Misc test helpers
----------------------------------------------------------------------------

-- | Like 'buildDoc', but does not require documentation to be finalized.
buildDocTest :: ContainsDoc a => a -> ContractDoc
buildDocTest :: forall a. ContainsDoc a => a -> ContractDoc
buildDocTest = a -> ContractDoc
forall a. ContainsDoc a => a -> ContractDoc
buildDocUnfinalized

-- | Like 'buildMarkdownDoc', but does not require documentation to be finalized.
buildMarkdownDocTest :: ContainsDoc a => a -> LText
buildMarkdownDocTest :: forall a. ContainsDoc a => a -> LText
buildMarkdownDocTest = ContractDoc -> LText
contractDocToMarkdown (ContractDoc -> LText) -> (a -> ContractDoc) -> a -> LText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ContractDoc
forall a. ContainsDoc a => a -> ContractDoc
buildDocUnfinalized

----------------------------------------------------------------------------
-- Framework
----------------------------------------------------------------------------

-- | Test case for contract documentation.
data DocTest = DocTest
  { DocTest -> SrcLoc
dtDeclLoc :: SrcLoc
    -- ^ Declaration location, used to distinguish different test predicates.
    -- This is primarily used in 'excludeDocTest'.
  , DocTest -> String
dtDesc :: String
    -- ^ Description of predicate, which you put to 'testCase'.
  , DocTest -> HasCallStack => ContractDoc -> Assertion
dtSuite :: HasCallStack => ContractDoc -> Assertion
    -- ^ Test itself.
  }

instance Eq DocTest where
  == :: DocTest -> DocTest -> Bool
(==) = SrcLoc -> SrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
(==) (SrcLoc -> SrcLoc -> Bool)
-> (DocTest -> SrcLoc) -> DocTest -> DocTest -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` DocTest -> SrcLoc
dtDeclLoc

instance Buildable DocTest where
  build :: DocTest -> Builder
build DocTest{String
SrcLoc
HasCallStack => ContractDoc -> Assertion
dtSuite :: HasCallStack => ContractDoc -> Assertion
dtDesc :: String
dtDeclLoc :: SrcLoc
dtSuite :: DocTest -> HasCallStack => ContractDoc -> Assertion
dtDesc :: DocTest -> String
dtDeclLoc :: DocTest -> SrcLoc
..} = Builder
"Doc test '" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
forall p. Buildable p => p -> Builder
build String
dtDesc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"'"

-- | 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 :: HasCallStack =>
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
mkDocTest String
dtDesc HasCallStack => ContractDoc -> Assertion
dtSuite = DocTest :: SrcLoc
-> String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
DocTest{String
SrcLoc
HasCallStack => ContractDoc -> Assertion
dtDeclLoc :: SrcLoc
dtSuite :: HasCallStack => ContractDoc -> Assertion
dtDesc :: String
dtSuite :: HasCallStack => ContractDoc -> Assertion
dtDesc :: String
dtDeclLoc :: SrcLoc
..}
  where
  (String
_, SrcLoc
dtDeclLoc) = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack of
    [] -> Text -> (String, SrcLoc)
forall a. HasCallStack => Text -> a
error Text
"Callstacks operate in a weird way, excluding doc tests won't work"
    (String, SrcLoc)
layer : [(String, SrcLoc)]
_ -> (String, SrcLoc)
layer

-- | Exclude given test suite.
excludeDocTest :: HasCallStack => DocTest -> [DocTest] -> [DocTest]
excludeDocTest :: HasCallStack => DocTest -> [DocTest] -> [DocTest]
excludeDocTest DocTest
toExclude [DocTest]
tests =
  case (DocTest -> Bool) -> [DocTest] -> ([DocTest], [DocTest])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (DocTest -> DocTest -> Bool
forall a. Eq a => a -> a -> Bool
== DocTest
toExclude) [DocTest]
tests of
    ([], [DocTest]
_) ->
      Text -> [DocTest]
forall a. HasCallStack => Text -> a
error (Text -> [DocTest]) -> Text -> [DocTest]
forall a b. (a -> b) -> a -> b
$ Text
"Not in the list of doc items: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DocTest -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty DocTest
toExclude
    (DocTest
_ : DocTest
_ : [DocTest]
_, [DocTest]
_) ->
      -- This is e.g. possible if someone abused 'mkDocTest' and created a function
      -- which calls it and this function is used to create multiple predicates
      Text -> [DocTest]
forall a. HasCallStack => Text -> a
error Text
"Multiple test predicates were considered equal.\n\
            \Either list of tests contains identical test predicates, \
            \or used predicates were constructed incorrectly."
    ([DocTest
_], [DocTest]
notExcluded) ->
      [DocTest]
notExcluded

-- | Calling @excludeDocTests tests toExclude@ returns all test suites from
-- @tests@ which are not present in @toExclude@.
excludeDocTests :: [DocTest] -> [DocTest] -> [DocTest]
excludeDocTests :: [DocTest] -> [DocTest] -> [DocTest]
excludeDocTests = (Element [DocTest] -> [DocTest] -> [DocTest])
-> [DocTest] -> [DocTest] -> [DocTest]
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
foldr HasCallStack => DocTest -> [DocTest] -> [DocTest]
Element [DocTest] -> [DocTest] -> [DocTest]
excludeDocTest

-- | Finalize test suites.
runDocTests :: (ContainsDoc code, HasCallStack) => [DocTest] -> code -> [TestTree]
runDocTests :: forall code.
(ContainsDoc code, HasCallStack) =>
[DocTest] -> code -> [TestTree]
runDocTests [DocTest]
tests (code -> ContractDoc
forall a. ContainsDoc a => a -> ContractDoc
buildDocTest -> ContractDoc
contractDoc) =
  [DocTest]
tests [DocTest] -> (DocTest -> TestTree) -> [TestTree]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \DocTest{String
SrcLoc
HasCallStack => ContractDoc -> Assertion
dtSuite :: HasCallStack => ContractDoc -> Assertion
dtDesc :: String
dtDeclLoc :: SrcLoc
dtSuite :: DocTest -> HasCallStack => ContractDoc -> Assertion
dtDesc :: DocTest -> String
dtDeclLoc :: DocTest -> SrcLoc
..} ->
    String -> Assertion -> TestTree
testCase String
dtDesc (HasCallStack => ContractDoc -> Assertion
ContractDoc -> Assertion
dtSuite ContractDoc
contractDoc)

-- | Ensure that 'DocTest' check fires on given contract.
-- Used in tests on this module.
expectDocTestFailure :: ContainsDoc code => DocTest -> code -> Assertion
expectDocTestFailure :: forall code. ContainsDoc code => DocTest -> code -> Assertion
expectDocTestFailure DocTest{String
SrcLoc
HasCallStack => ContractDoc -> Assertion
dtSuite :: HasCallStack => ContractDoc -> Assertion
dtDesc :: String
dtDeclLoc :: SrcLoc
dtSuite :: DocTest -> HasCallStack => ContractDoc -> Assertion
dtDesc :: DocTest -> String
dtDeclLoc :: DocTest -> SrcLoc
..} (code -> ContractDoc
forall a. ContainsDoc a => a -> ContractDoc
buildDocTest -> ContractDoc
contractDoc) = do
  Bool
passed <- (HasCallStack => ContractDoc -> Assertion
ContractDoc -> Assertion
dtSuite ContractDoc
contractDoc Assertion -> Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True) IO Bool -> (HUnitFailure -> IO Bool) -> IO Bool
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \HUnitFailure{} -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
passed (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$ String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure String
"Test didn't fail unexpectedly"

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

-- Utilities
----------------------------------------------------------------------------

-- | Collect all doc groups (created with @DocGroup@ instruction)
-- recursively.
-- The result will contain grouping doc item itself and its subcontents.
allLayers :: DocBlock -> [(SomeDocItem, DocBlock)]
allLayers :: DocBlock -> [(SomeDocItem, DocBlock)]
allLayers DocBlock
block = do
  DocSection NonEmpty $ DocElem d
docElems <- DocBlock -> [Element DocBlock]
forall t. Container t => t -> [Element t]
toList DocBlock
block
  DocElem{d
Maybe SubDoc
deSub :: forall d. DocElem d -> Maybe SubDoc
deItem :: forall d. DocElem d -> d
deSub :: Maybe SubDoc
deItem :: d
..} <- (NonEmpty $ DocElem d) -> [Element (NonEmpty $ DocElem d)]
forall t. Container t => t -> [Element t]
toList NonEmpty $ DocElem d
docElems
  Just (SubDoc DocBlock
sub) <- Maybe SubDoc -> [Maybe SubDoc]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SubDoc
deSub
  (d -> SomeDocItem
forall d. DocItem d => d -> SomeDocItem
SomeDocItem d
deItem, DocBlock
sub) (SomeDocItem, DocBlock)
-> [(SomeDocItem, DocBlock)] -> [(SomeDocItem, DocBlock)]
forall a. a -> [a] -> [a]
: DocBlock -> [(SomeDocItem, DocBlock)]
allLayers DocBlock
sub


-- | Collect all doc groups (created with @DocGroup@ instruction)
-- within a contract recursively.
-- The result will contain grouping doc item itself (unless we are at root)
-- and its subcontents.
allContractLayers :: ContractDoc -> [(Maybe SomeDocItem, DocBlock)]
allContractLayers :: ContractDoc -> [(Maybe SomeDocItem, DocBlock)]
allContractLayers ContractDoc
contract =
  let contents :: DocBlock
contents = ContractDoc -> DocBlock
cdContents ContractDoc
contract
  in (Maybe SomeDocItem
forall a. Maybe a
Nothing, DocBlock
contents)
   (Maybe SomeDocItem, DocBlock)
-> [(Maybe SomeDocItem, DocBlock)]
-> [(Maybe SomeDocItem, DocBlock)]
forall a. a -> [a] -> [a]
: ((SomeDocItem -> Maybe SomeDocItem)
-> (SomeDocItem, DocBlock) -> (Maybe SomeDocItem, DocBlock)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SomeDocItem -> Maybe SomeDocItem
forall a. a -> Maybe a
Just ((SomeDocItem, DocBlock) -> (Maybe SomeDocItem, DocBlock))
-> [(SomeDocItem, DocBlock)] -> [(Maybe SomeDocItem, DocBlock)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DocBlock -> [(SomeDocItem, DocBlock)]
allLayers DocBlock
contents)

-- | Collect all doc items (atomic and grouping) recursively.
allContractDocItems :: DocItem d => ContractDoc -> [d]
allContractDocItems :: forall d. DocItem d => ContractDoc -> [d]
allContractDocItems ContractDoc
contract =
  [[d]] -> Element [[d]]
forall t. (Container t, Monoid (Element t)) => t -> Element t
fold ([[d]] -> Element [[d]]) -> [[d]] -> Element [[d]]
forall a b. (a -> b) -> a -> b
$ ContractDoc -> [(Maybe SomeDocItem, DocBlock)]
allContractLayers ContractDoc
contract [(Maybe SomeDocItem, DocBlock)]
-> ((Maybe SomeDocItem, DocBlock) -> [d]) -> [[d]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Maybe SomeDocItem
_, DocBlock
block) ->
    [d] -> (NonEmpty d -> [d]) -> Maybe (NonEmpty d) -> [d]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] NonEmpty d -> [d]
forall t. Container t => t -> [Element t]
toList (Maybe (NonEmpty d) -> [d]) -> Maybe (NonEmpty d) -> [d]
forall a b. (a -> b) -> a -> b
$ DocBlock -> Maybe (NonEmpty d)
forall d. DocItem d => DocBlock -> Maybe (NonEmpty d)
lookupDocBlockSection DocBlock
block