module Michelson.Doc.Test
( DocTest (..)
, mkDocTest
, excludeDocTest
, excludeDocTests
, runDocTests
, expectDocTestFailure
, testDocBasic
, testContractNameAtTop
, testNoGitInfo
, testDocNotEmpty
, testNoAdjacentDescriptions
, testStorageIsDocumented
, forEachContractLayer
, forEachContractDocItem
) where
import qualified Data.List as L
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
import Michelson.Typed.Haskell.Doc
data DocTest = DocTest
{ DocTest -> SrcLoc
dtDeclLoc :: SrcLoc
, DocTest -> String
dtDesc :: String
, DocTest -> HasCallStack => ContractDoc -> Assertion
dtSuite :: HasCallStack => ContractDoc -> Assertion
}
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 Show DocTest where
show :: DocTest -> String
show = DocTest -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty
instance Buildable DocTest where
build :: DocTest -> Builder
build DocTest{..} = "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
<> "'"
mkDocTest
:: HasCallStack
=> String
-> (HasCallStack => ContractDoc -> Assertion)
-> DocTest
mkDocTest :: String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
mkDocTest dtDesc :: String
dtDesc dtSuite :: HasCallStack => ContractDoc -> Assertion
dtSuite = $WDocTest :: SrcLoc
-> String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
DocTest{..}
where
(_, dtDeclLoc :: SrcLoc
dtDeclLoc) = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack of
[] -> Text -> (String, SrcLoc)
forall a. HasCallStack => Text -> a
error "Callstacks operate in a weird way, excluding doc tests won't work"
layer :: (String, SrcLoc)
layer : _ -> (String, SrcLoc)
layer
excludeDocTest :: HasCallStack => DocTest -> [DocTest] -> [DocTest]
excludeDocTest :: DocTest -> [DocTest] -> [DocTest]
excludeDocTest toExclude :: DocTest
toExclude tests :: [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
([], _) ->
Text -> [DocTest]
forall a. HasCallStack => Text -> a
error (Text -> [DocTest]) -> Text -> [DocTest]
forall a b. (a -> b) -> a -> b
$ "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
(_ : _ : _, _) ->
Text -> [DocTest]
forall a. HasCallStack => Text -> a
error "Running invalid doc predicates: multiple ones were considered equal"
([_], notExcluded :: [DocTest]
notExcluded) ->
[DocTest]
notExcluded
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
runDocTests :: HasCallStack => [DocTest] -> ContractDoc -> [TestTree]
runDocTests :: [DocTest] -> ContractDoc -> [TestTree]
runDocTests tests :: [DocTest]
tests contract :: ContractDoc
contract =
[DocTest]
tests [DocTest] -> (DocTest -> TestTree) -> [TestTree]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \DocTest{..} ->
String -> Assertion -> TestTree
testCase String
dtDesc (HasCallStack => ContractDoc -> Assertion
ContractDoc -> Assertion
dtSuite ContractDoc
contract)
expectDocTestFailure :: DocTest -> ContractDoc -> Assertion
expectDocTestFailure :: DocTest -> ContractDoc -> Assertion
expectDocTestFailure DocTest{..} contract :: ContractDoc
contract = do
Bool
passed <- (HasCallStack => ContractDoc -> Assertion
ContractDoc -> Assertion
dtSuite ContractDoc
contract 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 "Test didn't fail unexpectedly"
forEachLayer :: DocBlock -> (SomeDocItem -> DocBlock -> r) -> [r]
forEachLayer :: DocBlock -> (SomeDocItem -> DocBlock -> r) -> [r]
forEachLayer block :: DocBlock
block f :: SomeDocItem -> DocBlock -> r
f = do
DocSection docElems :: NonEmpty $ DocElem d
docElems <- DocBlock -> [Element DocBlock]
forall t. Container t => t -> [Element t]
toList DocBlock
block
DocElem{..} <- (NonEmpty $ DocElem d) -> [Element (NonEmpty $ DocElem d)]
forall t. Container t => t -> [Element t]
toList NonEmpty $ DocElem d
docElems
Just (SubDoc sub :: DocBlock
sub) <- Maybe SubDoc -> [Maybe SubDoc]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SubDoc
deSub
SomeDocItem -> DocBlock -> r
f (d -> SomeDocItem
forall d. DocItem d => d -> SomeDocItem
SomeDocItem d
deItem) DocBlock
sub r -> [r] -> [r]
forall a. a -> [a] -> [a]
: DocBlock -> (SomeDocItem -> DocBlock -> r) -> [r]
forall r. DocBlock -> (SomeDocItem -> DocBlock -> r) -> [r]
forEachLayer DocBlock
sub SomeDocItem -> DocBlock -> r
f
forEachContractLayer :: ContractDoc -> (Maybe SomeDocItem -> DocBlock -> r) -> [r]
forEachContractLayer :: ContractDoc -> (Maybe SomeDocItem -> DocBlock -> r) -> [r]
forEachContractLayer contract :: ContractDoc
contract f :: Maybe SomeDocItem -> DocBlock -> r
f =
let contents :: DocBlock
contents = ContractDoc -> DocBlock
cdContents ContractDoc
contract
in Maybe SomeDocItem -> DocBlock -> r
f Maybe SomeDocItem
forall a. Maybe a
Nothing DocBlock
contents
r -> [r] -> [r]
forall a. a -> [a] -> [a]
: DocBlock -> (SomeDocItem -> DocBlock -> r) -> [r]
forall r. DocBlock -> (SomeDocItem -> DocBlock -> r) -> [r]
forEachLayer DocBlock
contents (\sdi :: SomeDocItem
sdi blk :: DocBlock
blk -> Maybe SomeDocItem -> DocBlock -> r
f (SomeDocItem -> Maybe SomeDocItem
forall a. a -> Maybe a
Just SomeDocItem
sdi) DocBlock
blk)
forEachContractDocItem :: DocItem d => ContractDoc -> (d -> r) -> [r]
forEachContractDocItem :: ContractDoc -> (d -> r) -> [r]
forEachContractDocItem contract :: ContractDoc
contract f :: d -> r
f =
[[r]] -> [r]
forall t. (Container t, Monoid (Element t)) => t -> Element t
fold ([[r]] -> [r])
-> ((Maybe SomeDocItem -> DocBlock -> [r]) -> [[r]])
-> (Maybe SomeDocItem -> DocBlock -> [r])
-> [r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractDoc -> (Maybe SomeDocItem -> DocBlock -> [r]) -> [[r]]
forall r.
ContractDoc -> (Maybe SomeDocItem -> DocBlock -> r) -> [r]
forEachContractLayer ContractDoc
contract ((Maybe SomeDocItem -> DocBlock -> [r]) -> [r])
-> (Maybe SomeDocItem -> DocBlock -> [r]) -> [r]
forall a b. (a -> b) -> a -> b
$ \_ block :: DocBlock
block ->
(d -> r) -> [d] -> [r]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap d -> r
f ([d] -> [r])
-> (Maybe (NonEmpty d) -> [d]) -> Maybe (NonEmpty d) -> [r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [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) -> [r]) -> Maybe (NonEmpty d) -> [r]
forall a b. (a -> b) -> a -> b
$ DocBlock -> Maybe (NonEmpty d)
forall d. DocItem d => DocBlock -> Maybe (NonEmpty d)
lookupDocBlockSection DocBlock
block
testContractNameAtTop :: DocTest
testContractNameAtTop :: DocTest
testContractNameAtTop =
HasCallStack =>
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
mkDocTest "The whole contract is wrapped into 'DName'" ((HasCallStack => ContractDoc -> Assertion) -> DocTest)
-> (HasCallStack => ContractDoc -> Assertion) -> DocTest
forall a b. (a -> b) -> a -> b
$
\contractDoc :: ContractDoc
contractDoc -> do
let mSections :: Maybe (NonEmpty DName)
mSections = DocBlock -> Maybe (NonEmpty DName)
forall d. DocItem d => DocBlock -> Maybe (NonEmpty d)
lookupDocBlockSection @DName (ContractDoc -> DocBlock
cdContents ContractDoc
contractDoc)
case Maybe (NonEmpty DName)
mSections of
Nothing -> String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure "There is no 'DName' at the top"
Just _ -> () -> Assertion
forall (m :: * -> *) a. Monad m => a -> m a
return ()
testNoGitInfo :: DocTest
testNoGitInfo :: DocTest
testNoGitInfo =
HasCallStack =>
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
mkDocTest "Git revision is not set in the contract" ((HasCallStack => ContractDoc -> Assertion) -> DocTest)
-> (HasCallStack => ContractDoc -> Assertion) -> DocTest
forall a b. (a -> b) -> a -> b
$
\contractDoc :: ContractDoc
contractDoc -> do
[()]
assertions <- [Assertion] -> IO [()]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Assertion] -> IO [()]) -> [Assertion] -> IO [()]
forall a b. (a -> b) -> a -> b
$ ContractDoc -> (DGitRevision -> Assertion) -> [Assertion]
forall d r. DocItem d => ContractDoc -> (d -> r) -> [r]
forEachContractDocItem ContractDoc
contractDoc ((DGitRevision -> Assertion) -> [Assertion])
-> (DGitRevision -> Assertion) -> [Assertion]
forall a b. (a -> b) -> a -> b
$ \case
DGitRevisionUnknown -> () -> Assertion
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_ -> String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure "Unexpected Git revision"
HasCallStack => String -> Bool -> Assertion
String -> Bool -> Assertion
assertBool "No Git revision placeholder found or more than one" (Bool -> Assertion) -> Bool -> Assertion
forall a b. (a -> b) -> a -> b
$
([()] -> Int
forall t. Container t => t -> Int
length [()]
assertions Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1)
testDocNotEmpty :: DocTest
testDocNotEmpty :: DocTest
testDocNotEmpty =
HasCallStack =>
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
mkDocTest "There is at least one DOC_ITEM" ((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 found" (Bool -> Assertion) -> ([Bool] -> Bool) -> [Bool] -> Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> Bool
forall t. (Container t, Element t ~ Bool) => t -> Bool
or ([Bool] -> Assertion) -> [Bool] -> Assertion
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 t p. (Container t, Element t ~ DocSection) => p -> t -> Bool
hasDocItem
where
hasDocItem :: p -> t -> Bool
hasDocItem _ block :: t
block = Bool -> Bool
not (Bool -> Bool) -> ([()] -> Bool) -> [()] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Container [()] => [()] -> Bool
forall t. Container t => t -> Bool
null @[()] ([()] -> Bool) -> [()] -> Bool
forall a b. (a -> b) -> a -> b
$ do
DocSection docElems :: NonEmpty $ DocElem d
docElems <- t -> [Element t]
forall t. Container t => t -> [Element t]
toList t
block
DocElem d
docElem <- (NonEmpty $ DocElem d) -> [Element (NonEmpty $ DocElem d)]
forall t. Container t => t -> [Element t]
toList NonEmpty $ DocElem d
docElems
Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (DocElem d -> Bool
forall d. DocElem d -> Bool
deIsAtomic DocElem d
docElem)
testNoAdjacentDescriptions :: DocTest
testNoAdjacentDescriptions :: DocTest
testNoAdjacentDescriptions =
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 -> Maybe (NonEmpty DDescription)
forall d. DocItem d => DocBlock -> Maybe (NonEmpty d)
lookupDocBlockSection @DDescription DocBlock
block of
Just ds :: NonEmpty DDescription
ds@(_ :| _ : _) ->
let txts :: NonEmpty Builder
txts = NonEmpty DDescription
ds NonEmpty DDescription
-> (DDescription -> Builder) -> NonEmpty Builder
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(DDescription txt :: Builder
txt) -> Builder
txt
in 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 descriptions" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
NonEmpty Builder -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
blockListF (NonEmpty Builder -> Builder) -> NonEmpty Builder -> Builder
forall a b. (a -> b) -> a -> b
$ (Builder -> Builder) -> NonEmpty Builder -> NonEmpty 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 NonEmpty Builder
txts
_ -> 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
<> "\""
testDescriptionsAreWellFormatted :: DocTest
testDescriptionsAreWellFormatted :: DocTest
testDescriptionsAreWellFormatted =
HasCallStack =>
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
mkDocTest "Descriptions are well-formatted" ((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)
-> ((DDescription -> Assertion) -> [Assertion])
-> (DDescription -> Assertion)
-> Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractDoc -> (DDescription -> Assertion) -> [Assertion]
forall d r. DocItem d => ContractDoc -> (d -> r) -> [r]
forEachContractDocItem ContractDoc
contractDoc ((DDescription -> Assertion) -> Assertion)
-> (DDescription -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \(DDescription desc :: Builder
desc) ->
Text -> Assertion
check (Text -> Text
forall a. ToText a => a -> Text
toText (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Builder -> Text
toLazyText Builder
desc)
where
check :: Text -> Assertion
check desc :: Text
desc
| Text -> Bool
T.null Text
desc =
String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure "Empty description."
| Text -> Char
T.last (Text -> Text
T.stripEnd Text
desc) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '.' =
String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$ "Description does not end with a dot:\n\"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
Text -> String
forall a. ToString a => a -> String
toString Text
desc String -> ShowS
forall a. Semigroup a => a -> a -> a
<> "\""
| Bool
otherwise = Assertion
forall (f :: * -> *). Applicative f => f ()
pass
testStorageIsDocumented :: DocTest
testStorageIsDocumented :: DocTest
testStorageIsDocumented =
HasCallStack =>
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
String -> (HasCallStack => ContractDoc -> Assertion) -> DocTest
mkDocTest "Storage documentation is included" ((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 documentation for storage in the contract." (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 -> (DStorageType -> Bool) -> [Bool]
forall d r. DocItem d => ContractDoc -> (d -> r) -> [r]
forEachContractDocItem ContractDoc
contractDoc ((DStorageType -> Bool) -> [Bool])
-> (DStorageType -> Bool) -> [Bool]
forall a b. (a -> b) -> a -> b
$ \(DStorageType _) -> Bool
True
testDocBasic :: [DocTest]
testDocBasic :: [DocTest]
testDocBasic =
[ DocTest
testContractNameAtTop
, DocTest
testNoGitInfo
, DocTest
testDocNotEmpty
, DocTest
testNoAdjacentDescriptions
, DocTest
testDescriptionsAreWellFormatted
, DocTest
testStorageIsDocumented
]