module Test.Cleveland.Doc.Common
( DocTest (..)
, mkDocTest
, excludeDocTest
, excludeDocTests
, runDocTests
, expectDocTestFailure
, allContractLayers
, allContractDocItems
, 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
buildDocTest :: ContainsDoc a => a -> ContractDoc
buildDocTest :: forall a. ContainsDoc a => a -> ContractDoc
buildDocTest = a -> ContractDoc
forall a. ContainsDoc a => a -> ContractDoc
buildDocUnfinalized
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
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 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
"'"
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
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]
_) ->
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
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 :: (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)
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"
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
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)
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