purescript-0.15.5: tests/TestDocs.hs

module TestDocs where

import Prelude

import Data.Bifunctor (first)
import Data.List (findIndex)
import Data.Foldable
import Safe (headMay)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isNothing, mapMaybe)
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import qualified Text.PrettyPrint.Boxes as Boxes

import qualified Language.PureScript as P
import qualified Language.PureScript.Docs as Docs
import Language.PureScript.Docs.AsMarkdown (codeToString)
import qualified Language.PureScript.Publish.ErrorsWarnings as Publish

import Web.Bower.PackageMeta (parsePackageName, runPackageName)

import TestPscPublish (preparePackage)

import Test.Hspec

spec :: Spec
spec = beforeAll (handleDocPrepFailure <$> preparePackage "tests/purs/docs" "purs.json" "resolutions.json") $
  context "Language.PureScript.Docs" $ do
    context "Doc generation tests:" $
      mkSpec testCases displayAssertion $ \a pkg mdl ->
        case runAssertion a (Docs.getLinksContext pkg) mdl of
          Pass ->
            pure ()
          Fail reason ->
            expectationFailure (T.unpack (displayAssertionFailure reason))

    context "Tag generation tests:" $
      mkSpec testTagsCases displayTagsAssertion $ \a _ mdl ->
        case runTagsAssertion a (Map.fromList $ Docs.tags mdl) of
          TagsPass ->
            pure ()
          TagsFail reason ->
            expectationFailure (T.unpack (displayTagsAssertionFailure reason))
  where
  handleDocPrepFailure = first (expectationFailure . ("failed to produce docs: " <>) . Boxes.render . Publish.renderError)

  mkSpec cases displayAssertion' runner =
    forM_ cases $ \(mnString, assertions) -> do
      let mn = P.moduleNameFromString mnString
      context ("in module " ++ T.unpack mnString) $
        forM_ assertions $ \a ->
          it (T.unpack (displayAssertion' a)) . either id $ \pkg@Docs.Package{..} ->
            case find ((==) mn . Docs.modName) pkgModules of
              Nothing ->
                expectationFailure ("module not found in docs: " ++ T.unpack mnString)
              Just mdl ->
                runner a pkg mdl

data DocsAssertion
  -- | Assert that a particular declaration is documented with the given
  -- children
  = ShouldBeDocumented P.ModuleName Text [Text]
  -- | Assert that a particular declaration is not documented
  | ShouldNotBeDocumented P.ModuleName Text
  -- | Assert that a particular declaration exists, but without a particular
  -- child.
  | ChildShouldNotBeDocumented P.ModuleName Text Text
  -- | Assert that a particular declaration has a particular type class
  -- constraint.
  | ShouldBeConstrained P.ModuleName Text Text
  -- | Assert that a particular typeclass declaration has a functional
  -- dependency list.
  | ShouldHaveFunDeps P.ModuleName Text [([Text],[Text])]
  -- | Assert that a particular value declaration exists, and its type
  -- satisfies the given predicate.
  | ValueShouldHaveTypeSignature P.ModuleName Text (Docs.Type' -> Bool)
  -- | Assert that a particular instance declaration exists under some class or
  -- type declaration, and that its type satisfies the given predicate.
  | InstanceShouldHaveTypeSignature P.ModuleName Text Text (Docs.Type' -> Bool)
  -- | Assert that a particular type alias exists, and its corresponding
  -- type, when rendered, matches a given string exactly
  -- fields: module, type synonym name, expected type
  | TypeSynonymShouldRenderAs P.ModuleName Text Text
  -- | Assert that a documented declaration includes a documentation comment
  -- containing a particular string
  | ShouldHaveDocComment P.ModuleName Text Text
  -- | Assert that a documented data declaration includes a documentation comment
  -- | containing a particular string
  | ShouldHaveDataConstructorDocComment P.ModuleName Text Text Text
  -- | Assert that a documented data declaration has no documentation comment
  | ShouldHaveNoDataConstructorDocComment P.ModuleName Text Text
  -- | Assert that a documented class method includes a documentation comment
  -- | containing a particular string
  | ShouldHaveClassMethodDocComment P.ModuleName Text Text Text
  -- | Assert that a class method has no documentation comment
  | ShouldNotHaveClassMethodDocComment P.ModuleName Text Text
  -- | Assert that there should be some declarations re-exported from a
  -- particular module in a particular package.
  | ShouldHaveReExport (Docs.InPackage P.ModuleName)
  -- | Assert that a link to some specific declaration exists within the
  -- rendered code for a declaration. Fields are: local module, local
  -- declaration title, title of linked declaration, namespace of linked
  -- declaration, destination of link.
  | ShouldHaveLink P.ModuleName Text Text Docs.Namespace Docs.LinkLocation
  -- | Assert that a given declaration comes before another in the output
  | ShouldComeBefore P.ModuleName Text Text
  -- | Assert that a given declaration has the given kind signature
  | ShouldHaveKindSignature P.ModuleName Text Text
  -- | Assert that a given declaration does not have a kind signature
  | ShouldNotHaveKindSignature P.ModuleName Text
  -- | Assert that a given declaration with doc-comments on its
  -- kind signature, type declaration, and role declaration are properly
  -- merged into one doc-comment.
  | ShouldMergeDocComments P.ModuleName Text (Maybe Text)
  -- | Assert that a given declaration's type parameters have the
  -- given role annotations
  | ShouldHaveRoleAnnotation P.ModuleName Text [P.Role]
  -- | Assert that a given module has the expected doc comments
  | ShouldHaveModuleDocs P.ModuleName (Maybe Text)

data TagsAssertion
  -- | Assert that a particular declaration is tagged
  = ShouldBeTagged Text Int
  -- | Assert that a particular declaration is not tagged
  | ShouldNotBeTagged Text

displayAssertion :: DocsAssertion -> Text
displayAssertion = \case
  ShouldBeDocumented mn decl children ->
    showQual mn decl <> " should be documented" <>
    (if not (null children)
       then " with children: " <> T.pack (show children)
       else "")
  ShouldNotBeDocumented mn decl ->
    showQual mn decl <> " should not be documented"
  ChildShouldNotBeDocumented mn decl child ->
    showQual mn decl <> " should not have " <> child <> " as a child declaration"
  ShouldBeConstrained mn decl constraint ->
    showQual mn decl <> " should have a " <> constraint <> " constraint"
  ShouldHaveFunDeps mn decl fundeps ->
    showQual mn decl <> " should have fundeps: " <> T.pack (show fundeps)
  ValueShouldHaveTypeSignature mn decl _ ->
    "the type signature for " <> showQual mn decl <>
    " should satisfy the given predicate"
  InstanceShouldHaveTypeSignature _ parent instName _ ->
    "the instance " <> instName <> " (under " <> parent <> ") should have" <>
    " a type signature satisfying the given predicate"
  TypeSynonymShouldRenderAs mn synName code ->
    "the RHS of the type synonym " <> showQual mn synName <>
    " should be rendered as " <> code
  ShouldHaveDocComment mn decl excerpt ->
    "the string " <> T.pack (show excerpt) <> " should appear in the" <>
    " doc-comments for " <> showQual mn decl
  ShouldHaveDataConstructorDocComment mn decl constr excerpt ->
    "the string " <> T.pack (show excerpt) <> " should appear in the" <>
    " doc-comments for data constructor " <> T.pack (show constr) <> " for " <> showQual mn decl
  ShouldHaveNoDataConstructorDocComment mn decl constr ->
    "Doc-comments for data constructor " <> T.pack (show constr) <> " for " <> showQual mn decl <>
    " should be empty"
  ShouldHaveClassMethodDocComment mn decl method excerpt ->
    "the string " <> T.pack (show excerpt) <> " should appear in the" <>
    " doc-comment for class method " <> T.pack (show method) <> " for " <> showQual mn decl
  ShouldNotHaveClassMethodDocComment mn decl method ->
    "Doc-comments for class method " <> T.pack (show method) <> " for " <> showQual mn decl <>
    " should be empty"
  ShouldHaveReExport inPkg ->
    "there should be some re-exports from " <>
    showInPkg P.runModuleName inPkg
  ShouldHaveLink mn decl targetTitle targetNs _ ->
    "the rendered code for " <> showQual mn decl <> " should contain a link" <>
    " to " <> targetTitle <> " (" <> T.pack (show targetNs) <> ")"
  ShouldComeBefore mn declA declB ->
    showQual mn declA <> " should come before " <> showQual mn declB <>
    " in the docs"
  ShouldHaveKindSignature mn decl expected ->
    showQual mn decl <> " should have the kind signature `" <> expected <> "`"
  ShouldNotHaveKindSignature mn decl ->
    showQual mn decl <> " should not have a kind signature."
  ShouldMergeDocComments mn decl _ ->
    showQual mn decl <> " should merge the doc-comments of its kind " <>
    "declaration (if any), type declaration, and role declaration (if any) " <>
    "into one doc-comment."
  ShouldHaveRoleAnnotation mn decl expected ->
    showQual mn decl <> " should have the expected role annotations: " <>
    T.intercalate ", " (fmap P.displayRole expected)
  ShouldHaveModuleDocs mn expected ->
    "Module doc comments for module `" <> P.runModuleName mn <> "` should be " <>
      maybe "empty" (\t -> "'" <> t <> "`") expected

displayTagsAssertion :: TagsAssertion -> Text
displayTagsAssertion = \case
  ShouldBeTagged decl l ->
    decl <> " should be tagged at line " <> T.pack (show l)
  ShouldNotBeTagged decl ->
    decl <> " should not be tagged"

data DocsAssertionFailure
  -- | A declaration was not documented, but should have been
  = NotDocumented P.ModuleName Text
  -- | The expected list of child declarations did not match the actual list
  | ChildrenNotDocumented P.ModuleName Text [Text]
  -- | A declaration was documented, but should not have been
  | Documented P.ModuleName Text
  -- | A child declaration was documented, but should not have been
  | ChildDocumented P.ModuleName Text Text
  -- | A constraint was missing.
  | ConstraintMissing P.ModuleName Text Text
  -- | A functional dependency was missing.
  | FunDepMissing P.ModuleName Text [([Text], [Text])]
  -- | A declaration had the wrong "type" (ie, value, type, type class)
  -- Fields: declaration title, expected "type", actual "type".
  | WrongDeclarationType P.ModuleName Text Text Text
  -- | A declaration had the wrong type (in the sense of "type checking"), eg,
  -- because the inferred type was used when the explicit type should have
  -- been.
  -- Fields: module name, declaration name, actual type.
  | DeclarationWrongType P.ModuleName Text Docs.Type'
  -- | A Type synonym has been rendered in an unexpected format
  -- Fields: module name, declaration name, expected rendering, actual rendering
  | TypeSynonymMismatch P.ModuleName Text Text Text
  -- | A doc comment was not found or did not match what was expected
  -- Fields: module name, declaration, actual comments
  | DocCommentMissing P.ModuleName Text (Maybe Text)
  -- | A doc comment was found where none was expected
  -- Fields: module name, declaration, actual comments
  | DocCommentPresent P.ModuleName Text (Maybe Text)
  -- | A module was missing re-exports from a particular module.
  -- Fields: module name, expected re-export, actual re-exports.
  | ReExportMissing P.ModuleName (Docs.InPackage P.ModuleName) [Docs.InPackage P.ModuleName]
  -- | Expected to find some other declaration mentioned in this declaration's
  -- rendered code, but did not find anything.
  -- Fields: module name, declaration title, title of declaration which was
  -- expected but not found in.
  | LinkedDeclarationMissing P.ModuleName Text Text
  -- | Expected one link location for a declaration mentioned in some other
  -- declaration's rendered code, but found a different one. Fields: module
  -- name, title of the local declaration which links to some other
  -- declaration, title of the linked declaration, expected location, actual
  -- location.
  | BadLinkLocation P.ModuleName Text Text Docs.LinkLocation Docs.LinkLocation
  -- | Declarations were in the wrong order
  | WrongOrder P.ModuleName Text Text
  -- | Expected a kind signature for a declaration, but did not find one
  -- Fields: module name, declaration title.
  | KindSignatureMissing P.ModuleName Text
  -- | The rendered kind signature did not match the expected one.
  -- Fields: module name, declaration title, expected kind signature (text),
  -- actual kind signature (text), actual kind signature (structure)
  | KindSignatureMismatch P.ModuleName Text Text Text (P.Type ())
  -- | A kind signature was found where none was expected.
  -- Fields: module name, declaration title, actual kind signature (text),
  -- actual kind signature (structure)
  | KindSignaturePresent P.ModuleName Text Text (P.Type ())
  -- | The doc comments for the kind signature (if any), type declaration, and
  -- role declaration (if any) were not properly merged into the expected one.
  -- Fields: module name, declaration title, expected doc-comments,
  -- actual doc-comments
  | DocCommentMergeFailure P.ModuleName Text Text Text
  -- | The given declaration cannot have role annotations.
  -- Fields: module name, declaration title
  | CannotHaveRoles P.ModuleName Text
  -- | The list of expected roles did not match the list of actual roles
  -- fields: module name, declaration title, expected role list,
  -- actual role list
  | RoleMismatch P.ModuleName Text [P.Role] [P.Role]
  -- | The module's doc comments should be the expected
  -- fields: module name, expected docs, actual docs
  | WrongModuleDocs P.ModuleName (Maybe Text) (Maybe Text)

data TagsAssertionFailure
  -- | A declaration was not tagged, but should have been
  = NotTagged Text
  -- | A declaration was tagged, but should not have been
  | Tagged Text Int
  -- | A declaration was tagged on the wrong line
  | TaggedWrongLine Text Int Int

displayAssertionFailure :: DocsAssertionFailure -> Text
displayAssertionFailure = \case
  NotDocumented _ decl ->
    decl <> " was not documented, but should have been"
  ChildrenNotDocumented _ decl children ->
    decl <> " had the wrong children; got " <> T.pack (show children)
  Documented _ decl ->
    decl <> " was documented, but should not have been"
  ChildDocumented _ decl child ->
    decl <> " had " <> child <> " as a child"
  ConstraintMissing _ decl constraint ->
    decl <> " did not have a " <> constraint <> " constraint"
  FunDepMissing _ decl fundeps ->
    decl <> " had the wrong fundeps; got " <> T.pack (show fundeps)
  WrongDeclarationType _ decl expected actual ->
    "expected " <> decl <> " to be a " <> expected <> " declaration, but it" <>
    " was a " <> actual <> " declaration"
  DeclarationWrongType _ decl actual ->
    decl <> " had the wrong type; got " <> T.pack (P.prettyPrintType maxBound actual)
  TypeSynonymMismatch _ decl expected actual ->
    "expected the RHS of " <> decl <> " to be " <> expected <>
    "; got " <> actual
  DocCommentMissing _ decl actual ->
    "the doc-comment for " <> decl <> " did not contain the expected substring;" <>
    " got " <> T.pack (show actual)
  DocCommentPresent _ decl actual ->
    "the doc-comment for " <> decl <> " was not empty. Got " <> T.pack (show actual)
  ReExportMissing _ expected actuals ->
    "expected to see some re-exports from " <>
    showInPkg P.runModuleName expected <>
    "; instead only saw re-exports from " <>
    T.pack (show (map (showInPkg P.runModuleName) actuals))
  LinkedDeclarationMissing _ decl target ->
    "expected to find a link to " <> target <> " within the rendered code" <>
    " for " <> decl <> ", but no such link was found"
  BadLinkLocation _ decl target expected actual ->
    "in rendered code for " <> decl <> ", bad link location for " <> target <>
    ": expected " <> T.pack (show expected) <>
    " got " <> T.pack (show actual)
  WrongOrder _ before' after' ->
    "expected to see " <> before' <> " before " <> after'
  KindSignatureMissing _ decl ->
    "the kind signature for " <> decl <> " is missing."
  KindSignatureMismatch _ decl expected actualTxt actualKind ->
    "expected the kind signature for " <> decl <> "\n" <>
    "to be `" <> expected <> "`\n" <>
    "  got `" <> actualTxt <> "`\n" <>
    "Structure of kind: " <> T.pack (show actualKind)
  KindSignaturePresent _ decl actualTxt actualKind ->
    "the kind signature for " <> decl <> " was not empty.\n" <>
    "got `" <> actualTxt <> "`\n" <>
    "Structure of kind: " <> T.pack (show actualKind)
  DocCommentMergeFailure _ decl expected actual ->
    "Expected the doc-comment for " <> decl <> " to merge comments and be `" <>
    expected <> "`; got `" <> actual <> "`"
  CannotHaveRoles _ decl ->
    decl <> " is a type of declaration that cannot have roles."
  RoleMismatch _ decl expected actual ->
    "Expected the role annotations for " <> decl <> " to be \n" <>
    "`" <> displayRoleList expected <> "`, but got\n" <>
    "`" <> displayRoleList actual <> "`"
    where
      displayRoleList = T.intercalate ", " . fmap P.displayRole
  WrongModuleDocs mn expected actual ->
    "Expected module docs for " <> P.runModuleName mn <> "\n" <>
    "to be `" <> fromMaybe "<Nothing>" expected <> "`\n" <>
    "  got `" <> fromMaybe "<Nothing>" actual <> "`"

displayTagsAssertionFailure :: TagsAssertionFailure -> Text
displayTagsAssertionFailure = \case
  NotTagged decl ->
    decl <> " was not tagged, but should have been"
  Tagged decl line ->
    decl <> " was tagged at line " <> T.pack (show line) <>
    ", but should not have been"
  TaggedWrongLine decl taggedLine desiredLine ->
    decl <> " was tagged at line " <> T.pack (show taggedLine) <>
    ", but should have been tagged at line " <> T.pack (show desiredLine)

data DocsAssertionResult
  = Pass
  | Fail DocsAssertionFailure

data TagsAssertionResult
  = TagsPass
  | TagsFail TagsAssertionFailure

runAssertion :: DocsAssertion -> Docs.LinksContext -> Docs.Module -> DocsAssertionResult
runAssertion assertion linksCtx Docs.Module{..} =
  case assertion of
    ShouldBeDocumented mn decl children ->
      case findChildren decl (declarationsFor mn) of
        Nothing ->
          Fail (NotDocumented mn decl)
        Just actualChildren ->
          if children == actualChildren
            then Pass
            else Fail (ChildrenNotDocumented mn decl actualChildren)

    ShouldNotBeDocumented mn decl ->
      case findChildren decl (declarationsFor mn) of
        Just _ ->
          Fail (Documented mn decl)
        Nothing ->
          Pass

    ChildShouldNotBeDocumented mn decl child ->
      case findChildren decl (declarationsFor mn) of
        Just children ->
          if child `elem` children
            then Fail (ChildDocumented mn decl child)
            else Pass
        Nothing ->
          Fail (NotDocumented mn decl)

    ShouldBeConstrained mn decl tyClass ->
      findDecl mn decl $ \Docs.Declaration{..} ->
        case declInfo of
          Docs.ValueDeclaration ty ->
            if checkConstrained ty tyClass
              then Pass
              else Fail (ConstraintMissing mn decl tyClass)
          _ ->
            Fail (WrongDeclarationType mn decl "value"
                   (Docs.declInfoToString declInfo))

    ShouldHaveFunDeps mn decl fds ->
      findDecl mn decl $ \Docs.Declaration{..} ->
        case declInfo of
          Docs.TypeClassDeclaration _ _ fundeps ->
            if fundeps == fds
              then Pass
              else Fail (FunDepMissing mn decl fds)
          _ ->
            Fail (WrongDeclarationType mn decl "value"
                   (Docs.declInfoToString declInfo))

    ValueShouldHaveTypeSignature mn decl tyPredicate ->
      findDecl mn decl $ \Docs.Declaration{..} ->
        case declInfo of
          Docs.ValueDeclaration ty ->
            if tyPredicate ty
              then Pass
              else Fail (DeclarationWrongType mn decl ty)
          _ ->
            Fail (WrongDeclarationType mn decl "value"
                   (Docs.declInfoToString declInfo))

    InstanceShouldHaveTypeSignature mn parent decl tyPredicate ->
      case find ((==) parent . Docs.declTitle) (declarationsFor mn) >>= findTarget of
        Just ty ->
          if tyPredicate ty
            then Pass
            else Fail (DeclarationWrongType mn decl ty)
        Nothing ->
          Fail (NotDocumented mn decl)

      where
      findTarget =
        headMay .
        mapMaybe (extractInstanceType . Docs.cdeclInfo) .
        filter (\cdecl -> Docs.cdeclTitle cdecl == decl) .
        Docs.declChildren

      extractInstanceType = \case
        (Docs.ChildInstance _ ty) ->
          Just ty
        _ ->
          Nothing

    TypeSynonymShouldRenderAs mn decl expected ->
      findDecl mn decl $ \Docs.Declaration{..} ->
        case declInfo of
          Docs.TypeSynonymDeclaration [] ty ->
            let actual = codeToString (Docs.renderType ty) in
            if actual == expected
               then Pass
               else Fail (TypeSynonymMismatch mn decl expected actual)
          _ ->
            Fail (WrongDeclarationType mn decl "synonym"
                  (Docs.declInfoToString declInfo))

    ShouldHaveDocComment mn decl expected ->
      findDecl mn decl $ \Docs.Declaration{..} ->
        if maybe False (expected `T.isInfixOf`) declComments
          then Pass
          else Fail (DocCommentMissing mn decl declComments)

    ShouldHaveDataConstructorDocComment mn decl constr expected ->
      findDeclChildrenComment mn decl constr expected

    ShouldHaveNoDataConstructorDocComment mn decl constr ->
      findDeclChildrenNoComment mn decl constr

    ShouldHaveClassMethodDocComment mn decl constr expected ->
      findDeclChildrenComment mn decl constr expected

    ShouldNotHaveClassMethodDocComment mn decl method ->
      findDeclChildrenNoComment mn decl method

    ShouldHaveReExport reExp ->
      let
        reExps = map fst modReExports
      in
        if reExp `elem` reExps
          then Pass
          else Fail (ReExportMissing modName reExp reExps)

    ShouldHaveLink mn decl destTitle destNs expectedLoc ->
      findDecl mn decl $ \decl' ->
        let
          rendered = Docs.renderDeclaration decl'
        in
          case extract rendered destNs destTitle of
            Just (Docs.linkLocation -> actualLoc) ->
              if expectedLoc == actualLoc
                then Pass
                else Fail (BadLinkLocation mn decl destTitle expectedLoc actualLoc)
            Nothing ->
              Fail (LinkedDeclarationMissing mn decl destTitle)

    ShouldComeBefore mn before' after' ->
      let
        decls = declarationsFor mn

        indexOf :: Text -> Maybe Int
        indexOf title = findIndex ((==) title . Docs.declTitle) decls
      in
        case (indexOf before', indexOf after') of
          (Just i, Just j) ->
            if i < j
              then Pass
              else Fail (WrongOrder mn before' after')
          (Nothing, _) ->
            Fail (NotDocumented mn before')
          (_, Nothing) ->
            Fail (NotDocumented mn after')

    ShouldHaveKindSignature mn decl expected ->
      findDeclKinds mn decl $ \case
        Just Docs.KindInfo{..} ->
          if expected /= actual
              then Fail (KindSignatureMismatch mn decl expected actual kiKind)
              else Pass
          where
            actual = codeToString $ Docs.renderKindSig decl $
              Docs.KindInfo kiKeyword kiKind
        Nothing -> Fail (KindSignatureMissing mn decl)

    ShouldNotHaveKindSignature mn decl ->
      findDeclKinds mn decl $ \case
        Just Docs.KindInfo{..} ->
          Fail (KindSignaturePresent mn decl actual kiKind)
          where
            actual = codeToString $ Docs.renderKindSig decl $
              Docs.KindInfo kiKeyword kiKind
        Nothing -> Pass

    ShouldMergeDocComments mn decl expected ->
      findDecl mn decl $ \Docs.Declaration{..} ->
        if expected == declComments
            then Pass
            else Fail (DocCommentMergeFailure mn decl (display expected) (display declComments))
        where
          display = fromMaybe ""

    ShouldHaveRoleAnnotation mn decl expected ->
      findDeclRoles mn decl $ \actual ->
        if expected == actual
          then Pass
          else Fail (RoleMismatch mn decl expected actual)

    ShouldHaveModuleDocs mn expected ->
      if expected == modComments then
        Pass
      else
        Fail (WrongModuleDocs mn expected modComments)
  where
  declarationsFor mn =
    if mn == modName
      then modDeclarations
      else fromMaybe [] (lookup mn (map (first Docs.ignorePackage) modReExports))

  findChildren title =
    fmap childrenTitles . find ((==) title . Docs.declTitle)

  findDecl mn title f =
      case find ((==) title . Docs.declTitle) (declarationsFor mn) of
        Nothing ->
          Fail (NotDocumented mn title)
        Just decl ->
          f decl

  findDeclKinds mn title f =
      case find ((==) title . Docs.declTitle) (declarationsFor mn) of
        Nothing ->
          Fail (NotDocumented mn title)
        Just Docs.Declaration{..} ->
          f declKind

  findDeclRoles mn title f =
      case find ((==) title . Docs.declTitle) (declarationsFor mn) of
        Nothing ->
          Fail (NotDocumented mn title)
        Just Docs.Declaration{..} ->
          case getRoles declInfo of
            Nothing ->
              Fail (CannotHaveRoles mn title)
            Just roles ->
              f roles

  findDeclChildren mn title child f =
    findDecl mn title $ \Docs.Declaration{..} ->
      case find ((==) child . Docs.cdeclTitle) declChildren of
        Nothing ->
          Fail (NotDocumented mn child)
        Just decl ->
          f decl

  findDeclChildrenComment mn decl constr expected =
    findDeclChildren mn decl constr $ \Docs.ChildDeclaration{..} ->
      if maybe False (expected `T.isInfixOf`) cdeclComments
        then Pass
        else Fail (DocCommentMissing mn constr cdeclComments)

  findDeclChildrenNoComment mn decl constr =
    findDeclChildren mn decl constr $ \Docs.ChildDeclaration{..} ->
      if isNothing cdeclComments
      then Pass
      else Fail (DocCommentPresent mn constr cdeclComments)

  childrenTitles = map Docs.cdeclTitle . Docs.declChildren

  getRoles :: Docs.DeclarationInfo -> Maybe [P.Role]
  getRoles = \case
    Docs.DataDeclaration _ _ roles -> Just roles
    _ -> Nothing

  extract :: Docs.RenderedCode -> Docs.Namespace -> Text -> Maybe Docs.DocLink
  extract rc ns title = getFirst (Docs.outputWith (First . go) rc) >>= getLink
    where
      getLink =
        Docs.getLink linksCtx (P.moduleNameFromString "$DocsTest") ns title
      go = \case
        Docs.Symbol ns' title' (Docs.Link containingMod)
          | ns' == ns && title' == title -> Just containingMod
        _ ->
          Nothing

runTagsAssertion :: TagsAssertion -> Map.Map String Int -> TagsAssertionResult
runTagsAssertion assertion tags =
  case assertion of
    ShouldBeTagged decl line ->
      case Map.lookup (T.unpack decl) tags of
        Just taggedLine ->
          if taggedLine == line
            then TagsPass
            else TagsFail $ TaggedWrongLine decl taggedLine line
        Nothing -> TagsFail $ NotTagged decl

    ShouldNotBeTagged decl ->
      case Map.lookup (T.unpack decl) tags of
        Just taggedLine -> TagsFail $ Tagged decl taggedLine
        Nothing -> TagsPass

checkConstrained :: P.Type a -> Text -> Bool
checkConstrained ty tyClass =
  case ty of
    P.ConstrainedType _ c ty'
      | matches tyClass c -> True
      | otherwise -> checkConstrained ty' tyClass
    P.ForAll _ _ _ ty' _ ->
      checkConstrained ty' tyClass
    _ ->
      False
  where
  matches className =
    (==) className . P.runProperName . P.disqualify . P.constraintClass

testCases :: [(Text, [DocsAssertion])]
testCases =
  [ ("Example",
      [ -- From dependencies
        ShouldBeDocumented    (n "Prelude") "Unit" []
      , ShouldNotBeDocumented (n "Prelude") "unit"

        -- From local files
      , ShouldBeDocumented    (n "Example2") "one" []
      , ShouldNotBeDocumented (n "Example2") "two"

        -- Re-exports
      , ShouldHaveReExport (Docs.FromDep (pkg "purescript-prelude") (n "Prelude"))
      , ShouldHaveReExport (Docs.Local (n "Example2"))
      ])

  , ("Example2",
      [ ShouldBeDocumented (n "Example2") "one" []
      , ShouldBeDocumented (n "Example2") "two" []

      , ShouldHaveLink (n "Example2") "one" "Int" Docs.TypeLevel (Docs.BuiltinModule (n "Prim"))
      ])

  , ("UTF8",
      [ ShouldBeDocumented (n "UTF8") "thing" []
      ])

  , ("Transitive1",
      [ ShouldBeDocumented (n "Transitive2") "transitive3" []
      ])

  , ("NotAllCtors",
      [ ShouldBeDocumented         (n "Prelude") "Boolean2" ["True"]
      , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False"
      ])

  , ("DuplicateNames",
      [ ShouldBeDocumented    (n "Prelude")        "Unit" []
      , ShouldBeDocumented    (n "DuplicateNames") "unit" []
      , ShouldNotBeDocumented (n "Prelude")        "unit"
      ])

  , ("MultiVirtual",
      [ ShouldBeDocumented (n "MultiVirtual1") "foo" []
      , ShouldBeDocumented (n "MultiVirtual2") "bar" []
      , ShouldBeDocumented (n "MultiVirtual2") "baz" []
      ])

  , ("Clash",
      [ ShouldBeDocumented (n "Clash1") "value" []
      , ShouldBeDocumented (n "Clash1") "Type'" []
      , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"]
      ])

  , ("SolitaryTypeClassMember",
      [ ShouldBeDocumented    (n "SomeTypeClass") "member" []
      , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass"
      , ShouldBeConstrained   (n "SomeTypeClass") "member" "SomeClass"
      ])

  , ("ReExportedTypeClass",
      [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"]
      ])

  , ("TypeClassWithoutMembers",
      [ ShouldBeDocumented         (n "TypeClassWithoutMembersIntermediate") "SomeClass" []
      , ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member"
      ])

  , ("TypeClassWithFunDeps",
      [ ShouldHaveFunDeps          (n "TypeClassWithFunDeps") "TypeClassWithFunDeps" [(["a","b"], ["c"]), (["c"], ["d","e"])]
      ])

  , ("NewOperators",
      [ ShouldBeDocumented (n "NewOperators2") "(>>>)" []
      ])

  , ("ExplicitTypeSignatures",
      [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (hasTypeVar "something")
      , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt"    (P.tyInt `P.eqType`)
      , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber"  (P.tyNumber `P.eqType`)
      ])

  , ("ConstrainedArgument",
      [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a"
      , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a"
      , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. (Partial => Partial => a) -> a"
      , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. (Foo a => Foo b => a) -> a"
      ])

  , ("TypeOpAliases",
      [ ValueShouldHaveTypeSignature (n "TypeOpAliases") "test1" (renderedType "forall a b. a ~> b")
      , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test2" (renderedType "forall a b c. a ~> b ~> c")
      , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test3" (renderedType "forall a b c d. a ~> (b ~> c) ~> d")
      , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test4" (renderedType "forall a b c d. ((a ~> b) ~> c) ~> d")
      , ValueShouldHaveTypeSignature (n "TypeOpAliases") "third" (renderedType "forall a b c. a × b × c -> c")

      , ShouldBeDocumented (n "TypeOpAliases") "Tuple" ["Tuple","showTuple", "testLEither", "testREither"]
      , ShouldBeDocumented (n "TypeOpAliases") "Either" ["Left", "Right","testLEither", "testREither"]
      , ShouldBeDocumented (n "TypeOpAliases") "Show" ["show","showTuple"]

      , InstanceShouldHaveTypeSignature (n "TypeOpAliases") "Either" "testLEither" (renderedType "TestL (Either Int (Tuple Int String))")
      , InstanceShouldHaveTypeSignature (n "TypeOpAliases") "Either" "testREither" (renderedType "TestR (Either (Tuple Int Int) String)")
      ])

  , ("DocComments",
      [ ShouldHaveDocComment (n "DocComments") "example" "    example == 0"
      ])

  , ("DocCommentsDataConstructor",
      [ ShouldHaveDataConstructorDocComment (n "DocCommentsDataConstructor") "Foo" "Bar" "data constructor comment"
      , ShouldHaveNoDataConstructorDocComment (n "DocCommentsDataConstructor") "Foo" "Baz"
      , ShouldHaveNoDataConstructorDocComment (n "DocCommentsDataConstructor") "ComplexFoo" "ComplexBar"
      , ShouldHaveDataConstructorDocComment (n "DocCommentsDataConstructor") "ComplexFoo" "ComplexBaz" "another data constructor comment"
      , ShouldHaveDataConstructorDocComment (n "DocCommentsDataConstructor") "NewtypeFoo" "NewtypeFoo" "newtype data constructor comment"
      ])

  , ("DocCommentsClassMethod",
      [ ShouldHaveClassMethodDocComment (n "DocCommentsClassMethod") "Foo" "bar" "class method comment"
      , ShouldNotHaveClassMethodDocComment (n "DocCommentsClassMethod") "Foo" "baz"
      ])

  , ("TypeLevelString",
      [ ShouldBeDocumented (n "TypeLevelString") "Foo" ["fooBar"]
      ])

  , ("Desugar",
      [ ValueShouldHaveTypeSignature (n "Desugar") "test" (renderedType "forall a b. X (a -> b) a -> b")
      ])

  , ("ChildDeclOrder",
      [ ShouldBeDocumented (n "ChildDeclOrder") "Two" ["First", "Second", "showTwo", "fooTwo"]
      , ShouldBeDocumented (n "ChildDeclOrder") "Foo" ["foo1", "foo2", "fooTwo", "fooInt"]
      ])

  , ("DeclOrder",
      shouldBeOrdered (n "DeclOrder")
        ["A", "x1", "X2", "x3", "X4", "B"])

  , ("DeclOrderNoExportList",
      shouldBeOrdered (n "DeclOrderNoExportList")
        [ "x1", "x3", "X2", "X4", "A", "B" ])

  , ("Ado",
      [ ValueShouldHaveTypeSignature (n "Ado") "test" (renderedType "Int")
      ]
    )

  , ("TypeSynonymInstance",
      [ ShouldBeDocumented (n "TypeSynonymInstance") "MyNT" ["MyNT", "ntMyNT"]
      ]
    )
  , ("KindSignatureDocs",
      -- expected kind signatures
      [ ShouldHaveKindSignature (n "KindSignatureDocs") "DKindAndType" "data DKindAndType :: forall k. k -> Type"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "TKindAndType" "type TKindAndType :: forall k. k -> Type"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "NKindAndType" "newtype NKindAndType :: forall k. k -> Type"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "CKindAndType" "class CKindAndType :: forall k. (k -> Type) -> k -> Constraint"

      , ShouldHaveKindSignature (n "KindSignatureDocs") "DKindOnly" "data DKindOnly :: forall k. k -> Type"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "TKindOnly" "type TKindOnly :: forall k. k -> Type"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "NKindOnly" "newtype NKindOnly :: forall k. k -> Type"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "CKindOnly" "class CKindOnly :: forall k. (k -> Type) -> k -> Constraint"

      , ShouldHaveKindSignature (n "KindSignatureDocs") "DTypeOnly" "data DTypeOnly :: forall k. k -> Type"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "TTypeOnly" "type TTypeOnly :: forall k. k -> Type"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "NTypeOnly" "newtype NTypeOnly :: forall k. k -> Type"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "CTypeOnly" "class CTypeOnly :: forall k. (k -> Type) -> k -> Constraint"

      -- Declarations with no explicit kind signatures should still have
      -- their inferred kind signatures displayed as long as at least one
      -- type parameter does not have kind `Type`.
      , ShouldHaveKindSignature (n "KindSignatureDocs") "DImplicit" "data DImplicit :: forall k. k -> Type"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "TImplicit" "type TImplicit :: forall k. k -> Type"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "NImplicit" "newtype NImplicit :: forall k. k -> Type"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "CImplicit" "class CImplicit :: forall k1. (k1 -> Type) -> k1 -> Constraint"

      -- Declarations with no explicit kind signatures should not be displayed
      -- if each type parameter in their inferred kind signature
      -- has kind `Type`.
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DHidden"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DNothing"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "THidden"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "NHidden"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "CHidden"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "CNothing"

      -- FFI declarations always have an explicit kind signature
      -- but only show them if they are "interesting."
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "FFI_Hidden"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "FFI_Shown" "data FFI_Shown :: (Type -> Type) -> Type"

      -- Declarations with an explicit kind signature that is wrapped
      -- in parenthesis at various points, but which "desugars" so to speak
      -- to an uninteresting kind signature should not be displayed.
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "FFI_RedundantParenthesis"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataRedundantParenthesis"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "ClassRedundantParenthesis"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataHeadParens"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataTailParens"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataWholeParens"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataSelfParens"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "ClassSelfParens"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataKindAnnotation"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataKindAnnotationWithParens"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "FunctionParens1"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "FunctionParens2"
      , ShouldNotHaveKindSignature (n "KindSignatureDocs") "FunctionParens3"

      -- Declarations with no explicit kind signatures should be displayed
      -- if at least one type parameter has a kind other than `Type`
      -- despite all others having kind `Type`.
      , ShouldHaveKindSignature (n "KindSignatureDocs") "DShown" "data DShown :: Type -> Type -> (Type -> Type) -> Type"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "TShown" "type TShown :: (Type -> Type) -> Type -> Type -> Type"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "NShown" "newtype NShown :: Type -> (Type -> Type) -> Type -> Type"
      , ShouldHaveKindSignature (n "KindSignatureDocs") "CShown" "class CShown :: (Type -> Type) -> Type -> Type -> Constraint"
      ]
    )
  , ("RoleAnnotationDocs",
      [ ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "D_RNP" [P.Representational, P.Nominal, P.Phantom]
      , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "D_NPR" [P.Nominal, P.Phantom, P.Representational]
      , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "D_PRN" [P.Phantom, P.Representational, P.Nominal]
      , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_NNN" [P.Nominal, P.Nominal, P.Nominal]
      , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_RNP" [P.Representational, P.Nominal, P.Phantom]

      , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_Higher1" [P.Representational, P.Nominal, P.Phantom]
      , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_Higher2" [P.Representational, P.Nominal, P.Phantom]
      , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_Higher3" [P.Representational, P.Nominal, P.Phantom]
      , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_Higher4" [P.Representational, P.Nominal, P.Phantom]

      , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_HeadParens" [P.Representational, P.Nominal, P.Phantom]
      , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_TailParens" [P.Representational, P.Nominal, P.Phantom]
      , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_WholeParens" [P.Representational, P.Nominal, P.Phantom]
      ]
    )
  , ("DocCommentsMerge",
      [ ShouldMergeDocComments (n "DocCommentsMerge") "DataOnly" $ Just "decl\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "KindOnlyData" $ Just "kind\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "KindAndData" $ Just "kind\n\ndecl\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "DataRoleOnly" $ Just "role\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "DataAndRole" $ Just "decl\n\nrole\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "KindOnlyDataRoleOnly" $ Just "kind\n\nrole\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "KindDataAndRole" $ Just "kind\n\ndecl\n\nrole\n"

      , ShouldMergeDocComments (n "DocCommentsMerge") "FFIOnly" $ Just "decl\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "FFIRoleOnly" $ Just "role\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "FFIAndRole" $ Just "decl\n\nrole\n"

      , ShouldMergeDocComments (n "DocCommentsMerge") "NewtypeOnly" $ Just "decl\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "KindOnlyNewtype" $ Just "kind\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "KindAndNewtype" $ Just "kind\n\ndecl\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "NewtypeRoleOnly" $ Just "role\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "NewtypeAndRole" $ Just "decl\n\nrole\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "KindOnlyNewtypeRoleOnly" $ Just "kind\n\nrole\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "KindNewtypeAndRole" $ Just "kind\n\ndecl\n\nrole\n"

      , ShouldMergeDocComments (n "DocCommentsMerge") "TypeOnly" $ Just "decl\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "KindOnlyType" $ Just "kind\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "KindAndType" $ Just "kind\n\ndecl\n"

      , ShouldMergeDocComments (n "DocCommentsMerge") "ClassOnly" $ Just "decl\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "KindOnlyClass" $ Just "kind\n"
      , ShouldMergeDocComments (n "DocCommentsMerge") "KindAndClass" $ Just "kind\n\ndecl\n"
      ]
    )
  , ("Shebang1Undocumented",
      [ ShouldHaveModuleDocs (n "Shebang1Undocumented") Nothing
      ]
    )
  , ("Shebang2Undocumented",
      [ ShouldHaveModuleDocs (n "Shebang2Undocumented") Nothing
      ]
    )
  , ("Shebang3Undocumented",
      [ ShouldHaveModuleDocs (n "Shebang3Undocumented") $ Just "Normal doc comment\n"
      ]
    )
  , ("Shebang4Undocumented",
      [ ShouldHaveModuleDocs (n "Shebang4Undocumented") $ Just "Normal doc comment\n"
      ]
    )
  ]

  where
  n = P.moduleNameFromString
  pkg str = let Right p = parsePackageName str in p

  hasTypeVar varName =
    getAny . P.everythingOnTypes (<>) (Any . isVar varName)

  isVar varName (P.TypeVar _ name) | varName == T.unpack name = True
  isVar _ _ = False

  renderedType expected ty =
    codeToString (Docs.renderType ty) == expected

  shouldBeOrdered mn declNames =
    zipWith (ShouldComeBefore mn) declNames (tail declNames)

testTagsCases :: [(Text, [TagsAssertion])]
testTagsCases =
  [ ("DeclOrder",
      [ -- explicit exports
        ShouldBeTagged "x1" 10
      , ShouldBeTagged "x3" 11
      , ShouldBeTagged "X2" 13
      , ShouldBeTagged "X4" 14
      , ShouldBeTagged "A" 16
      , ShouldBeTagged "B" 17
      ])
  , ("Example2",
      [ -- all symbols exported
        ShouldBeTagged "one" 3
      , ShouldBeTagged "two" 6
      ])
  , ("ExplicitExport",
      [ -- only one of two symbols exported
        ShouldBeTagged "one" 3
      , ShouldNotBeTagged "two"
      ])
  ]

showQual :: P.ModuleName -> Text -> Text
showQual mn decl =
  P.runModuleName mn <> "." <> decl

showInPkg :: (a -> Text) -> Docs.InPackage a -> Text
showInPkg f = \case
  Docs.Local x ->
    f x <> " (local)"
  Docs.FromDep pkgName x ->
    f x <> " (from dep: " <> runPackageName pkgName <> ")"