module Michelson.Doc.Test
( DocTest (..)
, mkDocTest
, excludeDocTest
, excludeDocTests
, runDocTests
, expectDocTestFailure
, testDocBasic
, testContractNameAtTop
, testDocNotEmpty
, testNoAdjacentDescriptions
, forEachContractLayer
, forEachContractDocItem
) where
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
data DocTest = DocTest
{ dtDeclLoc :: SrcLoc
, dtDesc :: String
, dtSuite :: HasCallStack => ContractDoc -> Assertion
}
instance Eq DocTest where
(==) = (==) `on` dtDeclLoc
instance Show DocTest where
show = pretty
instance Buildable DocTest where
build DocTest{..} = "Doc test '" <> build dtDesc <> "'"
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
excludeDocTest :: HasCallStack => DocTest -> [DocTest] -> [DocTest]
excludeDocTest toExclude tests
| toExclude `elem` tests = filter (/= toExclude) tests
| otherwise = error $ "Not in the list of doc items: " <> pretty toExclude
excludeDocTests :: [DocTest] -> [DocTest] -> [DocTest]
excludeDocTests = foldr excludeDocTest
runDocTests :: HasCallStack => [DocTest] -> ContractDoc -> [TestTree]
runDocTests tests contract =
tests <&> \DocTest{..} ->
testCase dtDesc (dtSuite contract)
expectDocTestFailure :: DocTest -> ContractDoc -> Assertion
expectDocTestFailure DocTest{..} contract = do
passed <- (dtSuite contract $> True) `catch` \HUnitFailure{} -> pure False
when passed $ assertFailure "Test didn't fail unexpectedly"
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
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)
forEachContractDocItem :: DocItem d => ContractDoc -> (d -> r) -> [r]
forEachContractDocItem contract f =
fold . forEachContractLayer contract $ \_ block ->
fmap f . maybe [] toList $ lookupDocBlockSection block
testContractNameAtTop :: DocTest
testContractNameAtTop =
mkDocTest "The whole contract is wrapped into 'DName'" $
\contractDoc ->
assertBool "There is no 'DName' at the top" . isJust $
lookupDocBlockSection @DName (cdContents contractDoc)
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)
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 <> "\""
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
testDocBasic :: [DocTest]
testDocBasic =
[ testContractNameAtTop
, testDocNotEmpty
, testNoAdjacentDescriptions
, testDescriptionsAreWellFormatted
]