diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,19 @@ +# Revision history for `doxygen-parser` + +## ?.?.? -- YYYY-mm-dd + +### Breaking changes + +### New features + +### Minor changes + +### Bug fixes + +## 0.1.0 -- 2026-06-18 + +* First version. Extracted from + [`hs-bindgen`](https://github.com/well-typed/hs-bindgen). See + [hs-bindgen#1884][hs-bindgen-is-1884]. + +[hs-bindgen-is-1884]: https://github.com/well-typed/hs-bindgen/issues/1884 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2024-2026, Well-Typed LLP and Anduril Industries Inc. + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,79 @@ +# `doxygen-parser`: Parse Doxygen XML output into a typed Haskell AST + +[![Build and test](https://github.com/well-typed/doxygen-parser/actions/workflows/haskell.yml/badge.svg)](https://github.com/well-typed/doxygen-parser/actions/workflows/haskell.yml) + +`doxygen-parser` is a standalone Haskell library that invokes the +[`doxygen`](https://www.doxygen.nl/) binary on C/C++ header files and +turns its XML output into a typed Haskell AST. It works on any C/C++ +headers `doxygen` understands. + +## Requirements + +The `doxygen` executable must be installed and on `PATH` (or the path +must be supplied via the `binary` field of `Config`). Tested with +`doxygen` 1.15.0; older versions usually work but the XML schema +shifts subtly between releases. + +## Quick start + +```haskell +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +import Doxygen.Parser +import Data.List.NonEmpty (NonEmpty (..)) + +main :: IO () +main = do + Result{doxygen, warnings, doxygenVersion} <- + parse defaultConfig ("myheader.h" :| []) + putStrLn $ "doxygen version: " ++ show doxygenVersion + mapM_ print warnings + -- `doxygen` is opaque; query it with the lookup helpers: + print $ lookupComment (KeyDecl "myFunc") doxygen +``` + +`Result` carries: + + * `doxygen :: Doxygen`: opaque map of `DoxygenKey` to comment trees, + queried via `lookupComment`, `lookupGroupMembership`, + and `lookupGroupInfo`. + * `warnings :: [Warning]`: non-fatal degradations encountered while + parsing (unknown elements, malformed refs, etc.). + * `doxygenVersion :: Text`: the version of the `doxygen` binary + that was invoked. + +If the `doxygen` invocation itself fails, `parse` throws +`DoxygenException`. + +## Public modules + +| Module | Purpose | +| ------------------------ | --------------------------------------------- | +| `Doxygen.Parser` | Top-level public API. Start here. | +| `Doxygen.Parser.Types` | The `Comment` / `Block` / `Inline` AST. | +| `Doxygen.Parser.Warning` | Warning, `Context`, and `Degradation` types. | + +## Stability + +`doxygen-parser` follows the [Haskell Package Versioning +Policy](https://pvp.haskell.org/). The `Doxygen.Parser`, +`Doxygen.Parser.Types`, and `Doxygen.Parser.Warning` modules form the +supported public API; breaking changes there bump the major version +(`A.B`). + +## Used by + + * [`hs-bindgen`](https://github.com/well-typed/hs-bindgen): automatic + Haskell FFI binding generation from C headers. + +## Contributors + +Contributors are listed in the [`hs-bindgen` +README](https://github.com/well-typed/hs-bindgen#contributors), which +covers `doxygen-parser` along with the other supporting packages. + +## License + +BSD-3-Clause. Copyright 2024-2026 Well-Typed LLP and Anduril Industries Inc. +See [`LICENSE`](./LICENSE). diff --git a/doxygen-parser.cabal b/doxygen-parser.cabal new file mode 100644 --- /dev/null +++ b/doxygen-parser.cabal @@ -0,0 +1,122 @@ +cabal-version: 3.0 +name: doxygen-parser +version: 0.1.0 +license: BSD-3-Clause +license-file: LICENSE +copyright: 2024-2026 Well-Typed LLP and Anduril Industries Inc. +author: Well-Typed LLP +maintainer: info@well-typed.com +homepage: https://github.com/well-typed/doxygen-parser +bug-reports: https://github.com/well-typed/doxygen-parser/issues +category: Development, Documentation, Parsing +build-type: Simple +synopsis: Parse Doxygen XML output into a typed Haskell AST +description: + A standalone library for invoking the @doxygen@ binary on C\/C++ headers + and turning its XML output into a typed Haskell AST. + + The library spawns @doxygen@ on a set of header files, walks the resulting + @xml\/@ directory, and assembles a 'Doxygen.Parser.Doxygen' value mapping + each documented C entity to a structured 'Doxygen.Parser.Comment' tree + (with paragraphs, inline markup, parameter docs, group memberships, and + cross-references). + + See the "Doxygen.Parser" module for the public API and the project + README for a quick-start example. The @doxygen@ executable must be + installed separately. + +extra-doc-files: + CHANGELOG.md + README.md + +tested-with: + GHC ==9.2.8 + || ==9.4.8 + || ==9.6.7 + || ==9.8.4 + || ==9.10.3 + || ==9.12.2 + || ==9.14.1 + +source-repository head + type: git + location: https://github.com/well-typed/doxygen-parser + +common lang + ghc-options: + -Wall -Widentities -Wprepositive-qualified-module + -Wredundant-constraints -Wunused-packages -Wmissing-export-lists + + build-depends: base >=4.16 && <4.23 + default-language: GHC2021 + default-extensions: + DerivingStrategies + DuplicateRecordFields + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + +library internal + import: lang + visibility: private + hs-source-dirs: src-internal + exposed-modules: + Doxygen.Parser.Internal + Doxygen.Parser.Types + Doxygen.Parser.Warning + + build-depends: + , containers >=0.6.5.1 && <0.9 + , directory >=1.3.6.2 && <1.4 + , filepath >=1.4 && <1.6 + , process >=1.6 && <1.7 + , temporary >=1.3 && <1.4 + , text >=1.2 && <2.2 + , xml-conduit >=1.9 && <1.11 + +library + import: lang + hs-source-dirs: src + exposed-modules: Doxygen.Parser + reexported-modules: + , Doxygen.Parser.Types + , Doxygen.Parser.Warning + + build-depends: doxygen-parser:internal + +test-suite test-doxygen-parser + import: lang + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -threaded + other-modules: + Test.Doxygen.Parser.Block + Test.Doxygen.Parser.CodeBlock + Test.Doxygen.Parser.Comment + Test.Doxygen.Parser.Helpers + Test.Doxygen.Parser.InlineNesting + Test.Doxygen.Parser.InlineParsing + Test.Doxygen.Parser.List + Test.Doxygen.Parser.NormalizeWhitespace + Test.Doxygen.Parser.Param + Test.Doxygen.Parser.Properties + Test.Doxygen.Parser.SimpleSect + Test.Doxygen.Parser.StructuralWarnings + Test.Doxygen.Parser.Whitespace + Test.Doxygen.Parser.XMLFileResult + + -- Internal dependencies + build-depends: + , doxygen-parser + , doxygen-parser:internal + + -- External dependencies + build-depends: + , containers >=0.6.5.1 && <0.9 + , QuickCheck >=2.14.3 && <2.16 + , tasty >=1.5 && <1.6 + , tasty-hunit >=0.10.2 && <0.11 + , tasty-quickcheck >=0.10.2 && <0.12 + , text >=1.2 && <2.2 + , xml-conduit >=1.9 && <1.11 diff --git a/src-internal/Doxygen/Parser/Internal.hs b/src-internal/Doxygen/Parser/Internal.hs new file mode 100644 --- /dev/null +++ b/src-internal/Doxygen/Parser/Internal.hs @@ -0,0 +1,1257 @@ +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_HADDOCK hide #-} + +-- | Doxygen XML parser — internal implementation. +-- +-- This module contains the full implementation of the Doxygen XML parser. +-- The public API is re-exported by "Doxygen.Parser"; this module additionally +-- exposes internal functions for testing. +-- +-- === What doxygen generates +-- +-- Given a C header, @doxygen@ produces an @xml\/@ directory containing: +-- +-- [@index.xml@] +-- Master index of all "compounds" (files, groups, structs, unions) and their +-- members. Each member's @refid@ attribute encodes which group it belongs +-- to, e.g. @\"group__core__types_1ga...\"@ means the member is in the +-- @core_types@ group, while @\"myheader_8h_1a...\"@ means ungrouped. +-- +-- [@\_8h.xml@] +-- One per input file (e.g. @myheader_8h.xml@). Lists all declarations +-- with their @refid@s — we don't parse comments from these directly. +-- +-- [@group__\.xml@] +-- One per @\@defgroup@\/@\@addtogroup@ group. Contains the group title, +-- member comments, inner-group references, and enum value docs. +-- +-- [@struct\.xml@ \/ @union\.xml@] +-- One per struct\/union. Contains the compound-level comment and +-- per-field comments (brief + detailed). +-- +-- We parse @index.xml@ first for the member→group mapping, then iterate +-- over all other @.xml@ files to extract comments. Each file is parsed +-- into a 'XMLFileResult' and the results are merged into 'Doxygen'. +-- +module Doxygen.Parser.Internal ( + -- * Configuration + Config(..) + , defaultConfig + -- * Parsing + , parse + , Result(..) + -- * State type + , Doxygen(..) + , emptyDoxygen + -- * Lookup keys + , DoxygenKey(..) + , lookupComment + -- * Group sections + , lookupGroupMembership + , lookupGroupInfo + -- * Errors + , DoxygenException(..) + -- * Internals (exported for testing) + , buildComment + , extractBriefAndDetail + , parseBlockElement + , parseInline + , parseInlineChildren + , normalizeWhitespace + , trimEdges + , XMLFileResult(..) + , extractEntity + , nodeElementName + , forChildren + , ChildAction(..) + , readXML + , parseXMLOutput + ) where + +import Control.Exception (Exception, SomeException, catch, throwIO) +import Control.Monad (unless) +import Data.Char qualified as Char +import Data.List qualified as List +import Data.List.NonEmpty (NonEmpty, toList) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe, maybeToList) +import Data.Text (Text) +import Data.Text qualified as Text +import System.Directory (doesDirectoryExist, listDirectory) +import System.Exit (ExitCode (..)) +import System.FilePath (takeExtension, ()) +import System.IO.Error (isDoesNotExistError) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (CreateProcess (..), StdStream (..), proc, + readCreateProcessWithExitCode) +import Text.XML qualified as XML +import Text.XML.Cursor (Cursor, ($/), ($//)) +import Text.XML.Cursor qualified as Cursor + +import Doxygen.Parser.Types +import Doxygen.Parser.Warning + +{------------------------------------------------------------------------------- + Configuration +-------------------------------------------------------------------------------} + +-- | Configuration for the doxygen invocation +-- +data Config = Config { + binary :: FilePath + -- ^ Path to doxygen executable (default: @\"doxygen\"@) + , extractAll :: Bool + -- ^ @EXTRACT_ALL@ option: document all entities even without + -- Doxygen comments (default: @True@) + , quiet :: Bool + -- ^ @QUIET@ option: suppress doxygen output (default: @True@) + , outputDir :: Maybe FilePath + -- ^ When @Just dir@, doxygen XML output is written to @dir@ + -- and persists after 'parse' returns. When 'Nothing' (default), + -- a temporary directory is used and cleaned up automatically. + } + deriving stock (Show, Eq) + +-- | Default configuration: uses @\"doxygen\"@ from @PATH@, extracts all, +-- quiet mode enabled, temporary output directory +-- +defaultConfig :: Config +defaultConfig = Config { + binary = "doxygen" + , extractAll = True + , quiet = True + , outputDir = Nothing + } + +{------------------------------------------------------------------------------- + Lookup keys +-------------------------------------------------------------------------------} + +-- | Key for looking up a comment in the 'Doxygen' state +-- +-- Unifies the four separate map lookups (declarations, structs, fields, +-- enum values) into a single 'Map' keyed by this type. +-- +data DoxygenKey + = KeyDecl { name :: Text } + -- ^ Function, typedef, variable, or enum (keyed by C name) + | KeyStruct { name :: Text } + -- ^ Struct\/union compound (keyed by C type name) + | KeyField { structName :: Text, fieldName :: Text } + -- ^ Struct\/union field + | KeyEnumValue { enumName :: Text, valueName :: Text } + -- ^ Enum value + deriving stock (Eq, Ord, Show) + +{------------------------------------------------------------------------------- + State +-------------------------------------------------------------------------------} + +-- | Parsed doxygen state for C\/C++ headers +-- +-- The 'comments' map uses 'DoxygenKey' to distinguish declaration-level, +-- struct-level, field-level, and enum-value-level comments. +-- The @Comment DoxyRef@ values contain @DoxyRef@ at cross-reference +-- positions (@\@ elements in the XML). Each @DoxyRef@ carries +-- the C name and the optional @kindref@ attribute ('RefKind'). +-- Consumers can resolve these to their own identifier types +-- via 'Functor'\/'Traversable' on 'Comment'. +-- +data Doxygen = Doxygen { + -- | All extracted comments, keyed by 'DoxygenKey'. + comments :: Map DoxygenKey (Comment DoxyRef) + -- | Group membership: declaration name -> group name. + -- + -- Useful for generating export-list sections from Doxygen + -- @\@defgroup@ annotations. + , groupMembership :: Map Text Text + -- | Group info: group name -> (title, parent group name). + -- + -- Useful for generating export-list sections from Doxygen + -- @\@defgroup@ annotations. + , groupInfo :: Map Text (Text, Maybe Text) + } + deriving stock (Show) + +-- | Empty doxygen state (no comments, no group information). +-- +-- Useful as a fallback when doxygen is unavailable or fails, so that +-- downstream code can proceed without documentation rather than aborting. +emptyDoxygen :: Doxygen +emptyDoxygen = Doxygen { + comments = Map.empty + , groupMembership = Map.empty + , groupInfo = Map.empty + } + +{------------------------------------------------------------------------------- + Lookups +-------------------------------------------------------------------------------} + +-- | Look up a comment by key +lookupComment :: DoxygenKey -> Doxygen -> Maybe (Comment DoxyRef) +lookupComment key doxy = Map.lookup key doxy.comments + +-- | Look up which group a declaration belongs to +lookupGroupMembership :: Text -> Doxygen -> Maybe Text +lookupGroupMembership declName doxy = + Map.lookup declName doxy.groupMembership + +-- | Look up group info: @(title, parent group name)@ +lookupGroupInfo :: Text -> Doxygen -> Maybe (Text, Maybe Text) +lookupGroupInfo groupName doxy = + Map.lookup groupName doxy.groupInfo + +{------------------------------------------------------------------------------- + Result +-------------------------------------------------------------------------------} + +-- | Result of parsing doxygen XML output +data Result = Result { + doxygen :: Doxygen + -- ^ The parsed comments and group information + , warnings :: [Warning] + -- ^ Parser warnings about unsupported or degraded content. + -- These are non-fatal issues detected during XML parsing (e.g., + -- unsupported HTML elements). For fatal errors, see 'DoxygenException'. + , doxygenVersion :: Text + -- ^ The doxygen version that produced the XML (e.g., @\"1.15.0\"@). + -- Defaults to @\"unknown\"@ if the version could not be determined. + } + deriving stock (Show) + +{------------------------------------------------------------------------------- + Errors +-------------------------------------------------------------------------------} + +-- | Exception thrown when doxygen invocation or XML parsing fails +data DoxygenException + = DoxygenNotFound + -- ^ The @doxygen@ binary was not found on @PATH@ + | DoxygenFailed Int String + -- ^ @doxygen@ exited with a non-zero exit code. + -- The 'Int' is the exit code; the 'String' is stderr output from the + -- @doxygen@ process. + | DoxygenXMLParseError FilePath String + -- ^ Failed to parse a doxygen XML output file. + -- The 'String' is the parse error as reported by @xml-conduit@. + | DoxygenIOError IOError + -- ^ An IO error occurred while invoking @doxygen@ (e.g., permission + -- denied). The 'DoxygenNotFound' constructor handles the specific case + -- where the binary is absent; this covers all other 'IOError's. + | DoxygenOutputDirMissing FilePath + -- ^ The 'outputDir' specified in 'Config' does not exist. + deriving stock (Show) + +instance Exception DoxygenException + +{------------------------------------------------------------------------------- + Public API +-------------------------------------------------------------------------------} + +-- | Parse C\/C++ header files using doxygen +-- +-- Invokes the @doxygen@ binary on the given header files, parses the XML +-- output, and returns a 'Result' containing all extracted comments, group +-- information, and any warnings about unsupported content. +-- +-- When 'outputDir' is @Just dir@ in the 'Config', doxygen writes its XML +-- output to @dir\/xml\/@ and the files persist after this function returns. +-- When 'Nothing', a temporary directory is used and cleaned up automatically. +-- +-- Throws 'DoxygenException' on failure. +-- +parse :: Config -> NonEmpty FilePath -> IO Result +parse config headerPaths = + withDir $ \dir -> do + runDoxygen config headerPaths dir + parseXMLOutput (dir "xml") + where + withDir :: (FilePath -> IO a) -> IO a + withDir = case config.outputDir of + Nothing -> withSystemTempDirectory "doxygen-parser" + Just dir -> \f -> do + exists <- doesDirectoryExist dir + unless exists $ throwIO $ DoxygenOutputDirMissing dir + f dir + +{------------------------------------------------------------------------------- + Doxygen invocation +-------------------------------------------------------------------------------} + +-- | Run the @doxygen@ binary, writing XML output to @outputDir\/xml\/@ +runDoxygen :: Config -> NonEmpty FilePath -> FilePath -> IO () +runDoxygen config headerPaths dir = do + let doxyConfig = generateConfig config headerPaths dir + (exitCode, _stdout, stderr) <- readCreateProcessWithExitCode + (proc config.binary ["-"]) { std_in = CreatePipe } + (Text.unpack doxyConfig) + `catch` \e -> + if isDoesNotExistError e + then throwIO DoxygenNotFound + else throwIO (DoxygenIOError e) + case exitCode of + ExitFailure code -> throwIO $ DoxygenFailed code stderr + ExitSuccess -> pure () + +-- | Generate the doxygen configuration string +generateConfig :: Config -> NonEmpty FilePath -> FilePath -> Text +generateConfig config inputPaths outputDir = Text.unlines $ + [ "INPUT = " <> Text.unwords (map Text.pack (toList inputPaths)) + , "OUTPUT_DIRECTORY = " <> Text.pack outputDir + , "GENERATE_XML = " <> boolOption True + , "GENERATE_HTML = " <> boolOption False + , "GENERATE_LATEX = " <> boolOption False + , "XML_PROGRAMLISTING = " <> boolOption False + , "EXTRACT_ALL = " <> boolOption config.extractAll + , "JAVADOC_BANNER = " <> boolOption True + , "QUIET = " <> boolOption config.quiet + ] + where + boolOption :: Bool -> Text + boolOption True = "YES" + boolOption False = "NO" + +{------------------------------------------------------------------------------- + XML parsing — assembles Doxygen directly from XML files +-------------------------------------------------------------------------------} + +-- | Parse the XML output directory into a 'Result' +-- +parseXMLOutput :: FilePath -> IO Result +parseXMLOutput xmlDir = do + -- Parse index.xml for declaration→group mappings and doxygen version + (indexWarns, memberGroupMap, version) <- parseIndexXML (xmlDir "index.xml") + + -- Parse all per-entity XML files (groups, structs, unions, file) and + -- accumulate results + xmlFiles <- List.sort . filter isEntityXML <$> listDirectory xmlDir + results <- mapM (\f -> parseEntityXML (xmlDir f)) xmlFiles + + -- Merge results from all XML files into a single state. + -- Left-biased: if two XML files define the same key, the first one wins. + -- This is fine because doxygen produces at most one comment per entity + -- per run. + let allComments = Map.unionsWith const [r.comments | r <- results] + + -- child→parent map from elements + childToParent = Map.fromList $ concatMap (.groupChildren) results + + allGroupInfo = Map.fromList + [ (gname, (title, Map.lookup gname childToParent)) + | r <- results + , (gname, title) <- r.groupTitles + ] + innerClassMembers = Map.fromList $ concatMap (.groupMembers) results + + allGroupMembership = Map.union memberGroupMap innerClassMembers + + allWarnings = concatMap (.warnings) results + + pure Result { + doxygen = Doxygen { + comments = allComments + , groupMembership = allGroupMembership + , groupInfo = allGroupInfo + } + , warnings = indexWarns ++ allWarnings + , doxygenVersion = version + } + +-- | Intermediate result from parsing one XML file +-- +-- Each XML file (group, struct, union, file) produces one of these. +-- They are merged into the final 'Doxygen' by 'parseXMLOutput'. +-- +data XMLFileResult = XMLFileResult { + comments :: Map DoxygenKey (Comment DoxyRef) + , groupTitles :: [(Text, Text)] + -- ^ (group name, title) — only populated for group XML files + , groupChildren :: [(Text, Text)] + -- ^ (child group name, parent group name) — derived from + -- @\@ elements in group XML files + , groupMembers :: [(Text, Text)] + -- ^ (declaration name, group name) — derived from + -- @\@ elements in group XML files (structs\/unions) + , warnings :: [Warning] + } + +{------------------------------------------------------------------------------- + index.xml parsing + + The index lists every compound and its members. Example: + + + myheader.h + + my_int + + + ungrouped_func + + + + core_types + ... + + + + We extract two things: + 1. member→group mapping: parse "group__core__types" from the refid prefix + to learn that "my_int" belongs to group "core_types". Members whose + refid starts with the file name (e.g. "myheader_8h_1a...") are ungrouped. + 2. group refs: which group compounds exist (titles come later from compound + XML files). +-------------------------------------------------------------------------------} + +-- | Parse @index.xml@ to extract the declaration→group mapping and version. +parseIndexXML :: FilePath -> IO ([Warning], Map Text Text, Text) +parseIndexXML path = do + doc <- readXML path + let root = Cursor.fromDocument doc + version = fromMaybe "unknown" + $ listToMaybe + $ Cursor.attribute "version" root + + (rootWarns, compounds) = + forChildren "doxygenindex" (Cursor.child root) $ + \n c -> case n of + "compound" -> Just (Yield c) + _ -> Nothing + + (compoundWarns, memberGroups) = collectWarnings $ map processCompound compounds + + pure ( rootWarns ++ compoundWarns + , Map.fromList memberGroups + , version + ) + where + processCompound :: Cursor -> ([Warning], [(Text, Text)]) + processCompound c = case listToMaybe $ Cursor.attribute "kind" c of + Just "file" -> + let (warns, members) = + forChildren "compound" (Cursor.child c) $ + \n ch -> case n of + "member" -> Just (Yield ch) + "name" -> Just Skip + _ -> Nothing + (memberWarns, pairs) = collectWarnings $ map processMember members + in (warns ++ memberWarns, pairs) + _otherwise -> ([], []) + + processMember :: Cursor -> ([Warning], [(Text, Text)]) + processMember c = + let (warns, names) = + forChildren "member" (Cursor.child c) $ + \n ch -> case n of + "name" -> Just (Yield (extractText ch)) + _ -> Nothing + result = do + name <- listToMaybe names + refid <- listToMaybe $ Cursor.attribute "refid" c + group <- groupFromRefid refid + pure (name, group) + in (warns, maybeToList result) + +-- | Extract group name from a refid like @\"group__core__types_1ga...\"@ +-- +-- Uses 'Text.breakOnEnd' to find the /last/ @\"_1\"@ (the member separator), +-- so that group names containing @\"_1\"@ as a substring are handled correctly +-- (e.g., @group__v1__helpers_1ga...@ → @\"v1_helpers\"@). +groupFromRefid :: Text -> Maybe Text +groupFromRefid refid + | Just rest <- Text.stripPrefix "group__" refid + = let (before, after) = Text.breakOnEnd "_1" rest + in Just $ Text.replace "__" "_" $ + if Text.null before || Text.null after + then rest + else Text.dropEnd 2 before + | otherwise + = Nothing + +{------------------------------------------------------------------------------- + Per-entity XML parsing + + Each entity XML file has the structure: + + + + → entity name + → group title (groups only) + <briefdescription> → compound-level brief + <detaileddescription> + <innergroup> → group hierarchy (groups only) + <sectiondef kind="func|enum|typedef|public-attrib|..."> + <memberdef kind="function|enum|variable|typedef|..."> + <name> → member name + <qualifiedname> → e.g. "config_t::id" (struct fields) + <briefdescription> + <detaileddescription> + <enumvalue> → per-enumerator (enum memberdefs only) + <name> + <briefdescription> + <detaileddescription> + + type, definition, argsstring, param, location, ... (ignored) + + header, description (ignored) + + includes, location, listofallmembers, graphs, ... (ignored) + + See 'classifyCompoundDef', 'classifyMemberDef', and 'classifyEnumValue' + for the full list of known-but-ignored elements at each level. +-------------------------------------------------------------------------------} + +-- | Parse a single XML file (group, struct, union, or file) +parseEntityXML :: FilePath -> IO XMLFileResult +parseEntityXML path = do + doc <- readXML path + let root = Cursor.fromDocument doc + (rootWarns, compoundDefs) = + forChildren "doxygen" (Cursor.child root) $ + \n c -> case n of + "compounddef" -> Just (Yield c) + _ -> Nothing + results = map extractEntity compoundDefs + + pure XMLFileResult { + comments = Map.unionsWith const [r.comments | r <- results] + , groupTitles = concatMap (.groupTitles) results + , groupChildren = concatMap (.groupChildren) results + , groupMembers = concatMap (.groupMembers) results + , warnings = rootWarns ++ concatMap (.warnings) results + } + +-- | Extract all information from a @\<compounddef\>@ element. +-- +-- A compounddef represents one documented entity (struct, union, group, or +-- file). This function classifies its children, extracts comments from +-- members, and assembles a 'XMLFileResult' with all comment map entries. +-- +extractEntity :: Cursor -> XMLFileResult +extractEntity cd = + let kind = Text.concat $ Cursor.attribute "kind" cd + children = Cursor.child cd + + -- Classify <compounddef> children into buckets + parts = classifyCompoundDef children + + -- Compound-level comment (struct/union docs) + (commentWarns, mComment) = extractBriefAndDetail parts.briefs parts.details + structDocs = case (kind `elem` ["struct", "union"], parts.name, mComment) of + (True, Just sname, Just comment) -> [(KeyStruct sname, comment)] + _ -> [] + + -- Group metadata (only for kind="group") + groupTitles = case (kind, parts.name, parts.title) of + ("group", Just gname, Just gtitle) -> [(gname, Text.strip gtitle)] + _ -> [] + groupChildren = case (kind, parts.name) of + ("group", Just parentName) -> + [ (childName, parentName) + | c <- parts.innerGroups + , refid <- Cursor.attribute "refid" c + , childName <- maybeToList (groupFromRefid refid) + ] + _ -> [] + + groupMembers = case (kind, parts.name) of + ("group", Just groupName) -> + [ (extractText c, groupName) + | c <- parts.innerClasses + ] + _ -> [] + + -- Member comments from <sectiondef>s → keyed as KeyDecl / KeyField + (membersWarns, members) = extractAllMembers parts.sections + declDocs = toDeclMap members + fieldDocs = toFieldMap kind parts.name members + + -- Enum value comments → keyed as KeyEnumValue + (enumWarns, enumDocs) = extractAllEnumValues members + + in XMLFileResult { + comments = Map.fromList (structDocs ++ declDocs ++ fieldDocs ++ enumDocs) + , groupTitles = groupTitles + , groupChildren = groupChildren + , groupMembers = groupMembers + , warnings = parts.warnings ++ commentWarns ++ membersWarns ++ enumWarns + } + where + + {------------------------------------------------------------------- + Comment map construction + -------------------------------------------------------------------} + + -- Top-level declarations (functions, typedefs, enums). + -- Struct fields have a qualifiedname containing "::" — exclude those. + toDeclMap :: [MemberInfo] -> [(DoxygenKey, Comment DoxyRef)] + toDeclMap ms = + [ (KeyDecl mi.miName, mi.miComment) + | mi <- ms + , not (isStructField mi.miQualName) ] + + -- Struct/union field comments. + -- For struct/union compounds, all members are fields of that struct. + -- For other compounds (groups, files), fields are identified by their + -- <qualifiedname> (e.g. "config_t::id" → KeyField "config_t" "id"). + toFieldMap :: Text -> Maybe Text -> [MemberInfo] -> [(DoxygenKey, Comment DoxyRef)] + toFieldMap k mEntityName ms + | k `elem` ["struct", "union"] + , Just sname <- mEntityName + = [(KeyField sname mi.miName, mi.miComment) | mi <- ms] + | otherwise + = [ (KeyField sname fname, mi.miComment) + | mi <- ms + , Just qn <- [mi.miQualName] + , (sname, fname) <- maybeToList (splitQualifiedName qn) + ] + + {------------------------------------------------------------------- + <sectiondef> → <memberdef> extraction + -------------------------------------------------------------------} + + extractAllMembers :: [Cursor] -> ([Warning], [MemberInfo]) + extractAllMembers = collectWarnings . map extractSectionMembers + + -- A sectiondef groups memberdefs by kind (func, typedef, public-attrib, …) + extractSectionMembers :: Cursor -> ([Warning], [MemberInfo]) + extractSectionMembers secCursor = + let (warns, memberDefs) = forChildren "sectiondef" (Cursor.child secCursor) $ \n c -> + case n of + "memberdef" -> Just (Yield c) + "header" -> Just Skip + "description" -> Just Skip + _ -> Nothing + pairs = map extractMember memberDefs + in (warns ++ concatMap fst pairs, mapMaybe snd pairs) + + extractMember :: Cursor -> ([Warning], Maybe MemberInfo) + extractMember mc = + let mp = classifyMemberDef (Cursor.child mc) + (commentWarns, mComment) = extractBriefAndDetail mp.briefs mp.details + in case (mp.name, mComment) of + (Just mname, Just comment) -> + ( mp.warnings ++ commentWarns + , Just MemberInfo { miName = mname, miComment = comment + , miQualName = mp.qualifiedName + , miEnumValues = mp.enumValues } + ) + _ -> (mp.warnings ++ commentWarns, Nothing) + + {------------------------------------------------------------------- + <enumvalue> extraction + -------------------------------------------------------------------} + + extractAllEnumValues :: [MemberInfo] -> ([Warning], [(DoxygenKey, Comment DoxyRef)]) + extractAllEnumValues = collectWarnings . map extractEnumValuesFrom + + extractEnumValuesFrom :: MemberInfo -> ([Warning], [(DoxygenKey, Comment DoxyRef)]) + extractEnumValuesFrom mi = + collectWarnings $ map (extractEnumValue mi.miName) mi.miEnumValues + + extractEnumValue :: Text -> Cursor -> ([Warning], [(DoxygenKey, Comment DoxyRef)]) + extractEnumValue ename ev = + let evp = classifyEnumValue (Cursor.child ev) + (commentWarns, mComment) = extractBriefAndDetail evp.briefs evp.details + in case (evp.name, mComment) of + (Just vname, Just comment) -> + (evp.warnings ++ commentWarns, [(KeyEnumValue ename vname, comment)]) + _ -> + (evp.warnings ++ commentWarns, []) + + {------------------------------------------------------------------- + Child classifiers — one fold per XML element type + + Each classifier iterates children exactly once, dispatching on + element name. Known-but-ignored elements are listed explicitly + so that only truly unknown elements trigger warnings. + -------------------------------------------------------------------} + + classifyCompoundDef :: [Cursor] -> CompoundParts + classifyCompoundDef = foldr go (CompoundParts [] Nothing Nothing [] [] [] [] []) + where + go c acc@CompoundParts{..} = case nodeElementName c of + -- Processed: + Just "compoundname" -> CompoundParts { name = Just (extractText c), .. } + Just "title" -> CompoundParts { title = Just (extractText c), .. } + Just "briefdescription" -> CompoundParts { briefs = c : briefs, .. } + Just "detaileddescription" -> CompoundParts { details = c : details, .. } + Just "sectiondef" -> CompoundParts { sections = c : sections, .. } + Just "innergroup" -> CompoundParts { innerGroups = c : innerGroups, .. } + Just "innerclass" -> CompoundParts { innerClasses = c : innerClasses, .. } + -- Known but ignored (expected doxygen output): + Just "includes" -> acc + Just "includedby" -> acc + Just "innernamespace" -> acc + Just "listofallmembers" -> acc + Just "location" -> acc + Just "collaborationgraph" -> acc + Just "inheritancegraph" -> acc + Just "incdepgraph" -> acc + Just "invincdepgraph" -> acc + Just "templateparamlist" -> acc + Just "basecompoundref" -> acc + Just "derivedcompoundref" -> acc + Just "programlisting" -> acc + -- Unknown → warn + Just other -> CompoundParts + { warnings = unknownChildWarning "compounddef" other : warnings, .. } + Nothing -> acc + + classifyMemberDef :: [Cursor] -> MemberParts + classifyMemberDef = foldr go (MemberParts [] Nothing Nothing [] [] []) + where + go c acc@MemberParts{..} = case nodeElementName c of + Just "name" -> MemberParts { name = Just (extractText c), .. } + Just "qualifiedname" -> MemberParts { qualifiedName = Just (extractText c), .. } + Just "briefdescription" -> MemberParts { briefs = c : briefs, .. } + Just "detaileddescription" -> MemberParts { details = c : details, .. } + Just "enumvalue" -> MemberParts { enumValues = c : enumValues, .. } + -- Known but ignored: + Just "type" -> acc + Just "definition" -> acc + Just "argsstring" -> acc + Just "location" -> acc + Just "param" -> acc + Just "initializer" -> acc + Just "reimplements" -> acc + Just "reimplementedby" -> acc + Just "references" -> acc + Just "referencedby" -> acc + Just "templateparamlist" -> acc + Just "inbodydescription" -> acc + Just "scope" -> acc + Just "bitfield" -> acc + -- Unknown → warn + Just other -> MemberParts + { warnings = unknownChildWarning "memberdef" other : warnings, .. } + Nothing -> acc + + classifyEnumValue :: [Cursor] -> EnumValueParts + classifyEnumValue = foldr go (EnumValueParts [] Nothing [] []) + where + go c acc@EnumValueParts{..} = case nodeElementName c of + Just "name" -> EnumValueParts { name = Just (extractText c), .. } + Just "briefdescription" -> EnumValueParts { briefs = c : briefs, .. } + Just "detaileddescription" -> EnumValueParts { details = c : details, .. } + -- Known but ignored: + Just "initializer" -> acc + Just "inbodydescription" -> acc + Just "location" -> acc + -- Unknown → warn + Just other -> EnumValueParts + { warnings = unknownChildWarning "enumvalue" other : warnings, .. } + Nothing -> acc + +-- | Classified children of a @\<compounddef\>@ element +data CompoundParts = CompoundParts { + warnings :: [Warning] + , name :: Maybe Text + , title :: Maybe Text + , briefs :: [Cursor] + , details :: [Cursor] + , sections :: [Cursor] + , innerGroups :: [Cursor] + , innerClasses :: [Cursor] + } + +-- | Classified children of a @\<memberdef\>@ element +data MemberParts = MemberParts { + warnings :: [Warning] + , name :: Maybe Text + , qualifiedName :: Maybe Text + , briefs :: [Cursor] + , details :: [Cursor] + , enumValues :: [Cursor] + } + +-- | Classified children of an @\<enumvalue\>@ element +data EnumValueParts = EnumValueParts { + warnings :: [Warning] + , name :: Maybe Text + , briefs :: [Cursor] + , details :: [Cursor] + } + +-- | Intermediate result from extracting a single @\<memberdef\>@ +data MemberInfo = MemberInfo { + miName :: Text + , miComment :: Comment DoxyRef + , miQualName :: Maybe Text -- ^ e.g. @\"config_t::id\"@ for struct fields + , miEnumValues :: [Cursor] -- ^ @\<enumvalue\>@ children (enum memberdefs only) + } + +{------------------------------------------------------------------------------- + Shared XML helpers +-------------------------------------------------------------------------------} + +-- | Extract text content from an element's children +extractText :: Cursor -> Text +extractText c = Text.concat $ c $/ Cursor.content + +-- | Get the local element name from a cursor, if it's an element node +nodeElementName :: Cursor -> Maybe Text +nodeElementName c = case Cursor.node c of + XML.NodeElement el -> Just (XML.nameLocalName (XML.elementName el)) + _ -> Nothing + +-- | What to do with a child element +data ChildAction a + = Skip -- ^ Known child, not needed here — skip silently + | Yield a -- ^ Known child, include in results + +-- | Process element children, dispatching on element name. +-- +-- For each element child, calls the handler with the element name and +-- cursor. The handler returns: +-- +-- * @Just (Yield x)@ — include @x@ in the result list +-- * @Just Skip@ — known child, skip silently +-- * @Nothing@ — unknown child, emit a 'StructureLevel' warning +-- +-- Text and other non-element nodes are silently skipped. +forChildren + :: Text -- ^ Parent element name (for warnings) + -> [Cursor] -- ^ Children to iterate + -> (Text -> Cursor -> Maybe (ChildAction a)) -- ^ Handler + -> ([Warning], [a]) +forChildren parent cs handler = foldr go ([], []) cs + where + go c (ws, xs) = case nodeElementName c of + Just n -> case handler n c of + Just (Yield x) -> (ws, x : xs) + Just Skip -> (ws, xs) + Nothing -> (unknownChildWarning parent n : ws, xs) + Nothing -> (ws, xs) + +-- | Construct a 'StructureLevel' warning for an unknown child element +unknownChildWarning :: Text -> Text -> Warning +unknownChildWarning parent child = Warning { + element = child + , context = StructureLevel parent + , degradation = Omitted + , explanation = "unknown child <" <> child <> "> of <" <> parent <> ">; ignored" + } + +-- | Unsupported block-level element (preserved as 'Tag') +unsupportedBlockWarning :: Text -> Warning +unsupportedBlockWarning el = Warning { + element = el + , context = BlockLevel + , degradation = Omitted + , explanation = "unsupported block element: " <> el + } + +-- | Unsupported inline-level element (content preserved as plain text) +degradedInlineWarning :: Text -> Warning +degradedInlineWarning el = Warning { + element = el + , context = InlineLevel + , degradation = DegradedToText + , explanation = el <> " text preserved as plain text (no AST representation)" + } + +-- | Unknown @\<simplesect\>@ kind (defaulted to Note) +unknownSectKindWarning :: Text -> Warning +unknownSectKindWarning kind = Warning { + element = kind + , context = UnknownSectKind + , degradation = DefaultedTo "Note" + , explanation = "unknown simplesect kind '" <> kind <> "'; defaulted to Note" + } + +-- | Missing kind attribute on @\<simplesect\>@ (defaulted to Note) +missingSectKindWarning :: Warning +missingSectKindWarning = Warning { + element = "simplesect" + , context = UnknownSectKind + , degradation = DefaultedTo "Note" + , explanation = "simplesect with no kind attribute; defaulted to Note" + } + +-- | Collect warnings and results from a list of warning\/result pairs +collectWarnings :: [([a], [b])] -> ([a], [b]) +collectWarnings pairs = (concatMap fst pairs, concatMap snd pairs) + +-- | Extract brief and detailed descriptions, build a 'Comment'. +-- +-- Takes the @\<briefdescription\>@ and @\<detaileddescription\>@ cursors +-- (already classified by the caller's fold). Enumerates brief children +-- for @\<para\>@s, warning on unexpected elements. +extractBriefAndDetail :: [Cursor] -> [Cursor] -> ([Warning], Maybe (Comment DoxyRef)) +extractBriefAndDetail briefDescs detailDescs = + let (briefDescWarns, briefParas) = + collectWarnings $ map classifyBriefChildren briefDescs + detailChildren = concatMap Cursor.child detailDescs + (commentWarns, mComment) = buildComment briefParas detailChildren + in (briefDescWarns ++ commentWarns, mComment) + where + classifyBriefChildren :: Cursor -> ([Warning], [Cursor]) + classifyBriefChildren bd = + forChildren "briefdescription" (Cursor.child bd) $ + \n c -> case n of + "para" -> Just (Yield c) + _ -> Nothing + +-- | Build a 'Comment' from pre-classified brief @\<para\>@s and detailed +-- children. +buildComment :: [Cursor] -> [Cursor] -> ([Warning], Maybe (Comment DoxyRef)) +buildComment briefParas detailChildren = + let (briefWarns, briefInlines) = + collectWarnings $ map parseInlineChildren briefParas + trimmedBrief = trimEdges briefInlines + (detailWarns, detailedBlocks) = + collectWarnings $ map parseBlockElement detailChildren + in case (trimmedBrief, detailedBlocks) of + ([], []) -> (briefWarns ++ detailWarns, Nothing) + _ -> ( briefWarns ++ detailWarns + , Just Comment { + brief = trimmedBrief + , detailed = detailedBlocks + }) + +{------------------------------------------------------------------------------- + Block and inline parsing +-------------------------------------------------------------------------------} + +-- | Parse block-level content from a cursor +parseBlockElement :: Cursor -> ([Warning], [Block DoxyRef]) +parseBlockElement cursor = + case Cursor.node cursor of + XML.NodeElement el -> parseBlock el cursor + _ -> ([], []) + +-- | Parse a block-level XML element +parseBlock :: XML.Element -> Cursor -> ([Warning], [Block DoxyRef]) +parseBlock el cursor = case XML.nameLocalName (XML.elementName el) of + "para" -> + let children = Cursor.child cursor + (warns, blocks, inlines) = partitionContent children + trimmed = trimEdges inlines + in (warns, + [Paragraph trimmed | not (null trimmed)] + ++ blocks) + + "parameterlist" -> + let kind = case listToMaybe $ Cursor.attribute "kind" cursor of + Just "retval" -> ParamListRetVal + _ -> ParamListParam + (childWarns, items) = forChildren "parameterlist" (Cursor.child cursor) $ \n c -> + case n of + "parameteritem" -> Just (Yield c) + _ -> Nothing + (warns, params) = parseParamItems items + in (childWarns ++ warns, [ParamList kind params]) + + "simplesect" -> + let children = Cursor.child cursor + titles = [extractText c | c <- children, nodeElementName c == Just "title"] + (kindWarns, kind) = parseSimpleSectKind cursor (listToMaybe titles) + -- Filter <title> — already consumed by parseSimpleSectKind for SSPar + contentChildren = filter (not . isTitle) children + (contentWarns, content) = unzipBlocks contentChildren + in (kindWarns ++ contentWarns, [SimpleSect kind content]) + + "programlisting" -> + let (childWarns, codelines) = forChildren "programlisting" (Cursor.child cursor) $ \n c -> + case n of + "codeline" -> Just (Yield c) + _ -> Nothing + (codeWarns, codeLines) = unzip $ map extractCodeLine codelines + in (childWarns ++ concat codeWarns, [CodeBlock codeLines]) + + "itemizedlist" -> + let (childWarns, items) = forChildren "itemizedlist" (Cursor.child cursor) $ \n c -> + case n of + "listitem" -> Just (Yield c) + _ -> Nothing + (warns, blocks) = unzipListItems items + in (childWarns ++ warns, [ItemizedList blocks]) + + "orderedlist" -> + let (childWarns, items) = forChildren "orderedlist" (Cursor.child cursor) $ \n c -> + case n of + "listitem" -> Just (Yield c) + _ -> Nothing + (warns, blocks) = unzipListItems items + in (childWarns ++ warns, [OrderedList blocks]) + + "xrefsect" -> + let (childWarns, parts) = forChildren "xrefsect" (Cursor.child cursor) $ \n c -> + case n of + "xreftitle" -> Just (Yield (Left (Text.strip (extractText c)))) + "xrefdescription" -> Just (Yield (Right (Cursor.child c))) + _ -> Nothing + title = fromMaybe "" $ listToMaybe [t | Left t <- parts] + (descWarns, desc) = unzipBlocks (concat [cs | Right cs <- parts]) + in (childWarns ++ descWarns, [XRefSect title desc]) + + "table" -> + let (childWarns, children) = unzipBlocks (Cursor.child cursor) + in (childWarns, [Tag "table" children]) + + other -> + let (childWarns, children) = unzipBlocks (Cursor.child cursor) + in (unsupportedBlockWarning other : childWarns, [Tag other children]) + +-- | Partition children of a @\<para\>@ into block and inline content +-- +partitionContent :: [Cursor] -> ([Warning], [Block DoxyRef], [Inline DoxyRef]) +partitionContent = go [] [] [] + where + go warns blocks inlines [] = (reverse warns, reverse blocks, reverse inlines) + go warns blocks inlines (c : rest) = + case Cursor.node c of + XML.NodeContent txt + | Text.all Char.isSpace txt -> + go warns blocks (Text " " : inlines) rest + | otherwise -> + go warns blocks (Text (normalizeWhitespace txt) : inlines) rest + XML.NodeElement el + | XML.nameLocalName (XML.elementName el) `elem` blockElements + -> let (bw, bs) = parseBlock el c + in go (bw ++ warns) (reverse bs ++ blocks) inlines rest + | otherwise + -> let (iw, is) = parseInline el c + in go (iw ++ warns) blocks (reverse is ++ inlines) rest + _ -> go warns blocks inlines rest + + blockElements :: [Text] + blockElements = + [ "parameterlist", "simplesect", "programlisting" + , "itemizedlist", "orderedlist", "xrefsect" + , "table" + ] + +-- | Parse inline content from an XML element +parseInline :: XML.Element -> Cursor -> ([Warning], [Inline DoxyRef]) +parseInline el cursor = case XML.nameLocalName (XML.elementName el) of + "bold" -> let (w, is) = parseInlineChildren cursor in (w, [Bold is]) + "emphasis" -> let (w, is) = parseInlineChildren cursor in (w, [Emph is]) + "computeroutput" -> let (w, is) = parseInlineChildren cursor in (w, [Mono is]) + "ref" -> let t = Text.strip $ Text.concat $ cursor $/ Cursor.content + k = case listToMaybe $ Cursor.attribute "kindref" cursor of + Just "compound" -> Just RefCompound + Just "member" -> Just RefMember + _ -> Nothing + in ([], [Ref (DoxyRef t k) t]) + "anchor" -> ([], [Anchor $ Text.concat $ Cursor.attribute "id" cursor]) + "ulink" -> let (w, is) = parseInlineChildren cursor + in (w, [Link is (Text.concat $ Cursor.attribute "url" cursor)]) + "linebreak" -> ([], [Text "\n"]) + "sp" -> ([], [Text " "]) + other -> + let txt = Text.strip $ Text.concat $ cursor $// Cursor.content + w = degradedInlineWarning other + in if Text.null txt + then ([w], []) + else ([w], [Text txt]) + +-- | Parse all inline children of a cursor +parseInlineChildren :: Cursor -> ([Warning], [Inline DoxyRef]) +parseInlineChildren cursor = collectWarnings $ map go (Cursor.child cursor) + where + go :: Cursor -> ([Warning], [Inline DoxyRef]) + go c = case Cursor.node c of + XML.NodeContent txt + | Text.all Char.isSpace txt -> ([], [Text " "]) + | otherwise -> ([], [Text (normalizeWhitespace txt)]) + XML.NodeElement el -> parseInline el c + _ -> ([], []) + +{------------------------------------------------------------------------------- + Helpers +-------------------------------------------------------------------------------} + +-- | Normalize whitespace in an XML text node +-- +-- Collapses runs of whitespace to a single space, preserving a leading +-- and\/or trailing space when the original text started\/ended with +-- whitespace. This is important for mixed-content XML: the text node +-- @\"Hello \"@ in @\<para\>Hello \<bold\>world\<\/bold\>\<\/para\>@ must +-- keep its trailing space so that the rendered output reads +-- @\"Hello world\"@ rather than @\"Helloworld\"@. +-- +normalizeWhitespace :: Text -> Text +normalizeWhitespace txt + | Text.null txt = txt + | otherwise = + let leading = if Char.isSpace (Text.head txt) then " " else "" + trailing = if Char.isSpace (Text.last txt) then " " else "" + inner = Text.unwords $ Text.words txt + in leading <> inner <> trailing + +-- | Trim leading whitespace from the first 'Text' and trailing +-- whitespace from the last 'Text' in an inline sequence. +-- +-- This is applied at paragraph boundaries (when constructing +-- 'Paragraph' and the brief description) to remove XML formatting +-- whitespace from paragraph edges while preserving inter-element +-- whitespace within the paragraph. +-- +trimEdges :: [Inline ref] -> [Inline ref] +trimEdges = trimTrailing . trimLeading + where + trimLeading :: [Inline ref] -> [Inline ref] + trimLeading (Text t : rest) + | Text.null stripped = trimLeading rest + | otherwise = Text stripped : rest + where stripped = Text.stripStart t + trimLeading xs = xs + + trimTrailing :: [Inline ref] -> [Inline ref] + trimTrailing [] = [] + trimTrailing [Text t] + | Text.null stripped = [] + | otherwise = [Text stripped] + where stripped = Text.stripEnd t + trimTrailing (x : xs) = x : trimTrailing xs + +parseParamItems :: [Cursor] -> ([Warning], [Param DoxyRef]) +parseParamItems cursors = + let pairs = map parseParamItem cursors + in (concatMap fst pairs, mapMaybe snd pairs) + +parseParamItem :: Cursor -> ([Warning], Maybe (Param DoxyRef)) +parseParamItem cursor = + let (itemWarns, parts) = + forChildren "parameteritem" (Cursor.child cursor) $ + \n c -> case n of + "parameternamelist" -> Just (Yield (Left c)) + "parameterdescription" -> Just (Yield (Right (Cursor.child c))) + _ -> Nothing + + nameListCursors = [c | Left c <- parts] + descChildren = concat [cs | Right cs <- parts] + + (nameListWarns, nameElems) = + collectWarnings $ map classifyParamNameList nameListCursors + + in case listToMaybe $ map extractText nameElems of + Nothing -> (itemWarns ++ nameListWarns, Nothing) + Just pname -> + let direction = listToMaybe nameElems >>= \n -> + case listToMaybe $ Cursor.attribute "direction" n of + Just "in" -> Just DirIn + Just "out" -> Just DirOut + Just "inout" -> Just DirInOut + _ -> Nothing + (descWarns, desc) = unzipBlocks descChildren + in (itemWarns ++ nameListWarns ++ descWarns, + Just Param { paramName = pname, paramDirection = direction, paramDesc = desc }) + where + classifyParamNameList :: Cursor -> ([Warning], [Cursor]) + classifyParamNameList nl = + forChildren "parameternamelist" (Cursor.child nl) $ + \n c -> case n of + "parametername" -> Just (Yield c) + _ -> Nothing + +parseSimpleSectKind :: Cursor -> Maybe Text -> ([Warning], SimpleSectKind) +parseSimpleSectKind cursor mTitle = + case listToMaybe $ Cursor.attribute "kind" cursor of + Just "return" -> ([], SSReturn) + Just "warning" -> ([], SSWarning) + Just "note" -> ([], SSNote) + Just "see" -> ([], SSSee) + Just "since" -> ([], SSSince) + Just "version" -> ([], SSVersion) + Just "pre" -> ([], SSPre) + Just "post" -> ([], SSPost) + Just "deprecated" -> ([], SSDeprecated) + Just "remark" -> ([], SSRemark) + Just "attention" -> ([], SSAttention) + Just "todo" -> ([], SSTodo) + Just "invariant" -> ([], SSInvariant) + Just "author" -> ([], SSAuthor) + Just "date" -> ([], SSDate) + Just "par" -> ([], SSPar $ maybe "" Text.strip mTitle) + Just other -> ([unknownSectKindWarning other], SSNote) + Nothing -> ([missingSectKindWarning], SSNote) + +extractCodeLine :: Cursor -> ([Warning], Text) +extractCodeLine cursor = + let (childWarns, highlights) = + forChildren "codeline" (Cursor.child cursor) $ + \n c -> case n of + "highlight" -> Just (Yield c) + _ -> Nothing + in (childWarns, Text.concat $ map extractHighlight highlights) + where + extractHighlight :: Cursor -> Text + extractHighlight c = Text.concat $ map nodeText (Cursor.child c) + + nodeText :: Cursor -> Text + nodeText c = case Cursor.node c of + XML.NodeContent txt -> txt + XML.NodeElement el -> case XML.nameLocalName (XML.elementName el) of + "sp" -> " " + "ref" -> Text.concat $ c $/ Cursor.content + _ -> Text.concat $ c $// Cursor.content + _ -> "" + +-- | Collect block elements from children, threading warnings +unzipBlocks :: [Cursor] -> ([Warning], [Block DoxyRef]) +unzipBlocks = collectWarnings . map parseBlockElement + +-- | Collect list items, threading warnings +unzipListItems :: [Cursor] -> ([Warning], [[Block DoxyRef]]) +unzipListItems items = + let pairs = map parseListItem items + in (concatMap fst pairs, map snd pairs) + +parseListItem :: Cursor -> ([Warning], [Block DoxyRef]) +parseListItem cursor = unzipBlocks (Cursor.child cursor) + +-- | Check if a cursor points at a @\<title\>@ element +isTitle :: Cursor -> Bool +isTitle c = case Cursor.node c of + XML.NodeElement el -> XML.nameLocalName (XML.elementName el) == "title" + _ -> False + +-- | Check if a @\<memberdef\>@ is a struct\/union field. +-- +-- Struct fields have a @\<qualifiedname\>@ child like @\"config_t::id\"@, +-- whereas top-level declarations do not. +isStructField :: Maybe Text -> Bool +isStructField (Just qn) = "::" `Text.isInfixOf` qn +isStructField Nothing = False + +-- | Split a qualified name like @\"config_t::id\"@ into @(\"config_t\", \"id\")@. +splitQualifiedName :: Text -> Maybe (Text, Text) +splitQualifiedName qualName = + case Text.breakOn "::" qualName of + (sname, rest) + | Just fn <- Text.stripPrefix "::" rest + , not (Text.null sname) + , not (Text.null fn) + -> Just (sname, fn) + _ -> Nothing + +-- | Filter for entity XML files (groups, structs, unions, files). +-- +-- This is a deny-list: it excludes known non-entity files. If future doxygen +-- versions add new auxiliary XML files, they would pass through and be parsed +-- as entities — harmlessly yielding an empty result since they won't contain +-- a recognised @\<compounddef\>@. +-- +-- Excludes schema files (@.xsd@), XSLT files, @index.xml@, @Doxyfile.xml@, +-- @dir_*.xml@ (directory compounds), @namespace*.xml@ and @class*.xml@ +-- (C++-only compounds), @deprecated.xml@, and @indexpage.xml@. +isEntityXML :: FilePath -> Bool +isEntityXML f = + takeExtension f == ".xml" + && f /= "index.xml" + && not ("Doxyfile" `List.isPrefixOf` f) + && not ("dir_" `List.isPrefixOf` f) + && not ("namespace" `List.isPrefixOf` f) + && not ("class" `List.isPrefixOf` f) + && f /= "deprecated.xml" + && f /= "indexpage.xml" + +-- | Read an XML file, wrapping parse errors in 'DoxygenXMLParseError' +readXML :: FilePath -> IO XML.Document +readXML path = + XML.readFile XML.def path + `catch` \(e :: SomeException) -> + throwIO $ DoxygenXMLParseError path (show e) diff --git a/src-internal/Doxygen/Parser/Types.hs b/src-internal/Doxygen/Parser/Types.hs new file mode 100644 --- /dev/null +++ b/src-internal/Doxygen/Parser/Types.hs @@ -0,0 +1,208 @@ +-- | Doxygen comment types parameterized by cross-reference type +-- +-- These types represent structured Doxygen comments parsed from XML output. +-- They are parameterized by @ref@ so that cross-references can be threaded +-- through consumer-specific pipelines and resolved later. +-- +-- The structure closely mirrors Doxygen's XML schema: +-- +-- * 'Comment' splits brief and detailed descriptions +-- * 'Block' represents block-level content (paragraphs, lists, code, etc.) +-- * 'Inline' represents inline formatting and cross-references +-- * 'Param' represents documented parameters with direction +-- +-- Intended for qualified import: +-- +-- @ +-- import Doxygen.Parser.Types qualified as Doxy +-- @ +-- +module Doxygen.Parser.Types ( + -- * Comment types + Comment(..) + , Block(..) + , Inline(..) + , Param(..) + -- * Cross-reference types + , DoxyRef(..) + , RefKind(..) + -- * Enumerations + , ParamListKind(..) + , ParamDirection(..) + , SimpleSectKind(..) + ) where + +import Data.Text (Text) +import GHC.Generics (Generic) + +{------------------------------------------------------------------------------- + Comment types +-------------------------------------------------------------------------------} + +-- | A Doxygen comment with brief and detailed sections +-- +-- The @ref@ parameter is the cross-reference type. The parser produces +-- @Comment DoxyRef@, where each 'DoxyRef' carries the raw C name and the +-- optional @kindref@. Consumers can 'fmap' or 'traverse' to resolve these +-- to their own identifier types. +-- +-- Corresponds to the @\<briefdescription\>@ and @\<detaileddescription\>@ +-- elements in Doxygen XML output. +-- +data Comment ref = Comment { + brief :: [Inline ref] + -- ^ Brief one-line summary, from the @\<briefdescription\>@ element. + , detailed :: [Block ref] + -- ^ Detailed description blocks, from @\<detaileddescription\>@. + } + deriving stock (Functor, Foldable, Traversable, Show, Eq, Generic) + +-- | Block-level content in a Doxygen comment +-- +data Block ref + = Paragraph [Inline ref] + -- ^ A paragraph: @\<para\>@ element + | ParamList ParamListKind [Param ref] + -- ^ Parameter or return value list: @\<parameterlist\>@ + | SimpleSect SimpleSectKind [Block ref] + -- ^ Special section: @\<simplesect kind=\"...\"\>@ + | CodeBlock [Text] + -- ^ Code block: @\<programlisting\>@ + | ItemizedList [[Block ref]] + -- ^ Bullet list: @\<itemizedlist\>@. Each element is one list item. + | OrderedList [[Block ref]] + -- ^ Numbered list: @\<orderedlist\>@. Each element is one list item. + | XRefSect Text [Block ref] + -- ^ Cross-reference section: @\<xrefsect\>@ + -- + -- Used for @\@deprecated@ and similar. First field is the title + -- (e.g., \"Deprecated\"), second is the description. + | Tag Text [Block ref] + -- ^ Unsupported or unrecognised XML\/HTML tag. + -- + -- Used for tags that do not have a dedicated constructor (e.g., HTML + -- @\<table\>@). The 'Text' is the element name; the @[Block ref]@ + -- are the recursively-parsed children, so that content inside + -- unsupported tags is still preserved. + deriving stock (Functor, Foldable, Traversable, Show, Eq, Generic) + +-- | Inline content in a Doxygen comment +data Inline ref + = Text Text + -- ^ Plain text + | Bold [Inline ref] + -- ^ Bold text: @\<bold\>@ element (from @\@b@ or @\<b\>@) + | Emph [Inline ref] + -- ^ Emphasized text: @\<emphasis\>@ element (from @\@e@, @\@a@, or @\<i\>@) + | Mono [Inline ref] + -- ^ Monospace text: @\<computeroutput\>@ element (from @\@c@, @\@p@, or @\<code\>@) + | Ref ref Text + -- ^ Cross-reference: @\<ref\>@ element + -- + -- First field is the reference (consumer-specific type). + -- Second field is the display text (the C name as shown in the comment). + | Anchor Text + -- ^ Anchor: @\<anchor\>@ element + | Link [Inline ref] Text + -- ^ Hyperlink: @\<ulink\>@ element. First field is the label, second is the URL. + deriving stock (Functor, Foldable, Traversable, Show, Eq, Generic) + +-- | A documented parameter +-- +data Param ref = Param { + paramName :: Text + -- ^ Parameter name, from the @\<parametername\>@ element. + , paramDirection :: Maybe ParamDirection + -- ^ Direction annotation (@in@, @out@, @inout@), when present. + , paramDesc :: [Block ref] + -- ^ Parameter description blocks. + } + deriving stock (Functor, Foldable, Traversable, Show, Eq, Generic) + +{------------------------------------------------------------------------------- + Enumerations +-------------------------------------------------------------------------------} + +-- | Kind of parameter list +-- +data ParamListKind + = ParamListParam + -- ^ @\@param@ documentation + | ParamListRetVal + -- ^ @\@retval@ documentation + deriving stock (Show, Eq, Generic) + +-- | Parameter passing direction +-- +data ParamDirection + = DirIn + -- ^ Input parameter: @\@param[in]@ + | DirOut + -- ^ Output parameter: @\@param[out]@ + | DirInOut + -- ^ Input/output parameter: @\@param[in,out]@ + deriving stock (Show, Eq, Generic) + +-- | Kind of simple section +-- +data SimpleSectKind + = SSReturn + -- ^ @\@return@ / @\@returns@ / @\@result@ + | SSWarning + -- ^ @\@warning@ + | SSNote + -- ^ @\@note@ + | SSSee + -- ^ @\@see@ / @\@sa@ + | SSSince + -- ^ @\@since@ + | SSVersion + -- ^ @\@version@ + | SSPre + -- ^ @\@pre@ + | SSPost + -- ^ @\@post@ + | SSPar Text + -- ^ @\@par Title:@ (the 'Text' is the paragraph title) + | SSDeprecated + -- ^ @\@deprecated@ + | SSRemark + -- ^ @\@remark@ / @\@remarks@ + | SSAttention + -- ^ @\@attention@ + | SSTodo + -- ^ @\@todo@ + | SSInvariant + -- ^ @\@invariant@ + | SSAuthor + -- ^ @\@author@ + | SSDate + -- ^ @\@date@ + deriving stock (Show, Eq, Generic) + +{------------------------------------------------------------------------------- + Cross-reference types +-------------------------------------------------------------------------------} + +-- | Kind of a Doxygen cross-reference target +-- +-- Corresponds to the @kindref@ attribute on @\<ref\>@ elements in Doxygen XML. +data RefKind + = RefCompound + -- ^ Compound type (struct, union, class, namespace, etc.) + | RefMember + -- ^ Member (function, variable, typedef, macro, enum value, etc.) + deriving stock (Show, Eq, Generic) + +-- | Doxygen cross-reference with optional kind information +-- +-- The parser produces @'DoxyRef'@ values at cross-reference positions +-- (@\<ref\>@ elements in Doxygen XML), preserving the @kindref@ attribute +-- when present. +data DoxyRef = DoxyRef { + doxyRefName :: Text + -- ^ The referenced C name, as shown in the comment. + , doxyRefKind :: Maybe RefKind + -- ^ The @kindref@ attribute, when Doxygen records it. + } + deriving stock (Show, Eq, Generic) diff --git a/src-internal/Doxygen/Parser/Warning.hs b/src-internal/Doxygen/Parser/Warning.hs new file mode 100644 --- /dev/null +++ b/src-internal/Doxygen/Parser/Warning.hs @@ -0,0 +1,52 @@ +-- | Structured warnings for unsupported or degraded Doxygen content +-- +-- When the parser encounters Doxygen XML elements it cannot fully represent +-- in the typed AST, it emits a 'Warning' describing what happened and how +-- the content was degraded. +-- +module Doxygen.Parser.Warning ( + Warning(..) + , Context(..) + , Degradation(..) + ) where + +import Data.Text (Text) +import GHC.Generics (Generic) + +-- | A structured warning about unsupported or degraded content +data Warning = Warning { + element :: Text + -- ^ The XML element or feature that triggered the warning + , context :: Context + -- ^ Where in the AST the element appeared + , degradation :: Degradation + -- ^ How the content was degraded + , explanation :: Text + -- ^ Human-readable description of what happened + } + deriving stock (Show, Eq, Generic) + +-- | Where in the AST hierarchy the unsupported element appeared +data Context + = BlockLevel + -- ^ Inside a block-level context (e.g., child of @\<para\>@ or + -- @\<detaileddescription\>@) + | InlineLevel + -- ^ Inside an inline context (e.g., child of @\<bold\>@ or inline + -- content within @\<para\>@) + | UnknownSectKind + -- ^ An unrecognised @kind@ attribute on @\<simplesect\>@ + | StructureLevel Text + -- ^ Inside a structural element. The 'Text' identifies the parent + -- (e.g. @\"compounddef\"@, @\"sectiondef\"@, @\"memberdef\"@). + deriving stock (Show, Eq, Generic) + +-- | How the unsupported content was handled +data Degradation + = Omitted + -- ^ Content was entirely dropped from the AST + | DegradedToText + -- ^ Formatting was lost; content preserved as plain text + | DefaultedTo Text + -- ^ An unknown value was replaced with a default + deriving stock (Show, Eq, Generic) diff --git a/src/Doxygen/Parser.hs b/src/Doxygen/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Doxygen/Parser.hs @@ -0,0 +1,73 @@ +-- | Public API for parsing Doxygen XML output into a typed Haskell AST. +-- +-- = Overview +-- +-- 'parse' invokes the @doxygen@ binary on a non-empty list of C\/C++ +-- header files, walks the resulting @xml\/@ directory, and assembles a +-- 'Doxygen' value that maps each documented entity to a structured +-- 'Comment' tree. The @doxygen@ binary must be available on @PATH@ (or +-- configured via 'Config'). +-- +-- = Quick start +-- +-- @ +-- {-\# LANGUAGE NamedFieldPuns \#-} +-- {-\# LANGUAGE OverloadedStrings \#-} +-- +-- import "Doxygen.Parser" +-- import Data.List.NonEmpty (NonEmpty (..)) +-- +-- main :: IO () +-- main = do +-- 'Result'{doxygen, warnings, doxygenVersion} \<- +-- 'parse' 'defaultConfig' (\"myheader.h\" :| []) +-- mapM_ print warnings +-- print ('lookupComment' ('KeyDecl' \"myFunc\") doxygen) +-- @ +-- +-- 'parse' throws 'DoxygenException' if the @doxygen@ invocation itself +-- fails; recoverable problems (unknown XML elements, malformed refs, +-- etc.) are returned as 'Warning's in the 'Result'. +-- +-- = Stability +-- +-- This module, "Doxygen.Parser.Types", and "Doxygen.Parser.Warning" +-- form the supported public API. +-- +module Doxygen.Parser ( + -- * Configuration + Config(..) + , defaultConfig + -- * Parsing + , parse + , Result(..) + -- * State type + , Doxygen -- Opaque + , emptyDoxygen + -- * Lookup keys + , DoxygenKey(..) + , lookupComment + -- * Group sections + , lookupGroupMembership + , lookupGroupInfo + -- * Errors + , DoxygenException(..) + -- * Comment types (from "Doxygen.Parser.Types") + , Comment(..) + , Block(..) + , Inline(..) + , Param(..) + , DoxyRef(..) + , RefKind(..) + , ParamListKind(..) + , ParamDirection(..) + , SimpleSectKind(..) + -- * Warnings (from "Doxygen.Parser.Warning") + , Warning(..) + , Context(..) + , Degradation(..) + ) where + +import Doxygen.Parser.Internal +import Doxygen.Parser.Types +import Doxygen.Parser.Warning diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,35 @@ +module Main (main) where + +import Test.Tasty + +import Test.Doxygen.Parser.Block qualified as Block +import Test.Doxygen.Parser.CodeBlock qualified as CodeBlock +import Test.Doxygen.Parser.Comment qualified as Comment +import Test.Doxygen.Parser.InlineNesting qualified as InlineNesting +import Test.Doxygen.Parser.InlineParsing qualified as InlineParsing +import Test.Doxygen.Parser.List qualified as List +import Test.Doxygen.Parser.NormalizeWhitespace qualified as NormalizeWhitespace +import Test.Doxygen.Parser.Param qualified as Param +import Test.Doxygen.Parser.Properties qualified as Properties +import Test.Doxygen.Parser.SimpleSect qualified as SimpleSect +import Test.Doxygen.Parser.StructuralWarnings qualified as StructuralWarnings +import Test.Doxygen.Parser.Whitespace qualified as Whitespace +import Test.Doxygen.Parser.XMLFileResult qualified as XMLFileResult + +main :: IO () +main = + defaultMain $ testGroup "doxygen-parser" + [ testGroup "normalizeWhitespace" NormalizeWhitespace.tests + , testGroup "inline parsing" InlineParsing.tests + , testGroup "inline nesting" InlineNesting.tests + , testGroup "whitespace handling" Whitespace.tests + , testGroup "block parsing" Block.tests + , testGroup "comment parsing" Comment.tests + , testGroup "parameter parsing" Param.tests + , testGroup "simplesect kinds" SimpleSect.tests + , testGroup "list parsing" List.tests + , testGroup "code block parsing" CodeBlock.tests + , testGroup "structural warnings" StructuralWarnings.tests + , testGroup "XMLFileResult assembly" XMLFileResult.tests + , testGroup "properties" Properties.tests + ] diff --git a/test/Test/Doxygen/Parser/Block.hs b/test/Test/Doxygen/Parser/Block.hs new file mode 100644 --- /dev/null +++ b/test/Test/Doxygen/Parser/Block.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE LambdaCase #-} + +module Test.Doxygen.Parser.Block (tests) where + +import Data.Text qualified as Text +import Test.Tasty +import Test.Tasty.HUnit + +import Doxygen.Parser +import Test.Doxygen.Parser.Helpers + +tests :: [TestTree] +tests = + [ testCase "paragraph" $ + blockShouldMatch "<para>Hello</para>" $ \b -> + b @?= Paragraph [Text "Hello"] + + , testCase "empty paragraph produces nothing" $ do + let (ws, bs) = parseBlockFromXML (wrap "<para></para>") + ws @?= [] + bs @?= [] + + , testCase "whitespace-only paragraph produces nothing" $ do + let (ws, bs) = parseBlockFromXML (wrap "<para> </para>") + ws @?= [] + bs @?= [] + + , testCase "para with mixed block and inline content" $ do + let (_, bs) = parseBlockFromXML $ wrap $ Text.concat + [ "<para>" + , "Some text" + , "<simplesect kind=\"note\"><para>A note</para></simplesect>" + , "</para>" + ] + bs @?= [ Paragraph [Text "Some text"] + , SimpleSect SSNote [Paragraph [Text "A note"]] + ] + + , testCase "para with only a parameterlist produces no empty paragraph" $ do + let (_, bs) = parseBlockFromXML $ wrap $ Text.concat + [ "<para>" + , mkParamListXML "param" [(Nothing, "x", "Desc")] + , "</para>" + ] + bs @?= [ParamList ParamListParam + [Param { paramName = "x" + , paramDirection = Nothing + , paramDesc = [Paragraph [Text "Desc"]] + }]] + + , testCase "parameterlist (param kind)" $ + blockShouldMatch (mkParamListXML "param" [(Just "in", "x", "The input")]) $ + \case + ParamList ParamListParam [p] -> do + p.paramName @?= "x" + p.paramDirection @?= Just DirIn + b -> assertFailure $ "unexpected: " ++ show b + + , testCase "parameterlist (retval kind)" $ + blockShouldMatch (mkParamListXML "retval" [(Nothing, "0", "Success")]) $ + \case + ParamList ParamListRetVal _ -> pure () + b -> assertFailure $ "expected retval list, got: " ++ show b + + , testCase "simplesect return" $ + blockShouldMatch "<simplesect kind=\"return\"><para>The result</para></simplesect>" $ + \case + SimpleSect SSReturn _ -> pure () + b -> assertFailure $ "expected SSReturn: " ++ show b + + , testCase "programlisting" $ + blockShouldMatch + ("<programlisting>" + <> "<codeline><highlight class=\"normal\">int<sp/>x<sp/>=<sp/>0;</highlight></codeline>" + <> "</programlisting>") $ + \case + CodeBlock [line] -> line @?= "int x = 0;" + b -> assertFailure $ "expected code block: " ++ show b + + , testCase "xrefsect (deprecated)" $ + blockShouldMatch + ("<xrefsect id=\"deprecated\">" + <> "<xreftitle>Deprecated</xreftitle>" + <> "<xrefdescription><para>Use new_func instead</para></xrefdescription>" + <> "</xrefsect>") $ + \case + XRefSect "Deprecated" _ -> pure () + b -> assertFailure $ "expected xrefsect: " ++ show b + + , testCase "table preserves content as Tag without warning" $ do + let (ws, bs) = parseBlockFromXML (wrap "<table><row><entry><para>cell</para></entry></row></table>") + assertBool ("no table warning expected, got: " ++ show [w | w <- ws, w.element == "table"]) + (not $ any (\w -> w.element == "table") ws) + case bs of + [Tag tag _children] -> tag @?= "table" + _ -> assertFailure $ "expected Tag: " ++ show bs + + , testCase "unknown block element emits warning + Tag" $ do + let (ws, bs) = parseBlockFromXML (wrap "<sect1><title>Heading") + case ws of + (w : _) -> w.context @?= BlockLevel + _ -> assertFailure $ "expected at least 1 warning, got: " ++ show ws + case bs of + [Tag tag _children] -> tag @?= "sect1" + _ -> assertFailure $ "expected Tag: " ++ show bs + ] diff --git a/test/Test/Doxygen/Parser/CodeBlock.hs b/test/Test/Doxygen/Parser/CodeBlock.hs new file mode 100644 --- /dev/null +++ b/test/Test/Doxygen/Parser/CodeBlock.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE LambdaCase #-} + +module Test.Doxygen.Parser.CodeBlock (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Doxygen.Parser +import Test.Doxygen.Parser.Helpers + +tests :: [TestTree] +tests = + [ testCase "single code line" $ + blockShouldMatch + ("" + <> "return0;" + <> "") $ + \case + CodeBlock [line] -> line @?= "return 0;" + b -> assertFailure $ "expected code block: " ++ show b + + , testCase "multiple code lines" $ + blockShouldMatch + ("" + <> "intx;" + <> "x=0;" + <> "") $ + \case + CodeBlock codeLines -> length codeLines @?= 2 + b -> assertFailure $ "expected 2 code lines: " ++ show b + + , testCase "code line with ref" $ + blockShouldMatch + ("" + <> "" + <> "my_typex;" + <> "") $ + \case + CodeBlock [line] -> line @?= "my_type x;" + b -> assertFailure $ "expected code block: " ++ show b + + , testCase "empty code block" $ + blockShouldMatch "" $ + \case + CodeBlock [] -> pure () + b -> assertFailure $ "expected empty code block: " ++ show b + ] diff --git a/test/Test/Doxygen/Parser/Comment.hs b/test/Test/Doxygen/Parser/Comment.hs new file mode 100644 --- /dev/null +++ b/test/Test/Doxygen/Parser/Comment.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE LambdaCase #-} + +module Test.Doxygen.Parser.Comment (tests) where + +import Data.Text qualified as Text +import Test.Tasty +import Test.Tasty.HUnit + +import Doxygen.Parser +import Test.Doxygen.Parser.Helpers + +tests :: [TestTree] +tests = + [ testCase "brief and detailed" $ do + let (ws, mc) = parseCommentFromXML (mkCommentXML "Brief text" "Detailed text") + ws @?= [] + case mc of + Just c -> do + c.brief @?= [Text "Brief text"] + length c.detailed @?= 1 + Nothing -> assertFailure "expected a comment" + + , testCase "brief only" $ do + let (_, mc) = parseCommentFromXML (mkCommentXML "Brief only" "") + case mc of + Just c -> do + c.brief @?= [Text "Brief only"] + c.detailed @?= [] + Nothing -> assertFailure "expected a comment" + + , testCase "detailed only" $ do + let (_, mc) = parseCommentFromXML (mkCommentXML "" "Detailed only") + case mc of + Just c -> do + c.brief @?= [] + length c.detailed @?= 1 + Nothing -> assertFailure "expected a comment" + + , testCase "empty descriptions produce Nothing" $ do + let (_, mc) = parseCommentFromXML (mkCommentXML "" "") + mc @?= Nothing + + , testCase "brief with inline formatting" $ do + let xml = Text.concat + [ "" + , " " + , " Use foo for bar" + , " " + , " " + , "" + ] + let (_, mc) = parseCommentFromXML xml + case mc of + Just c -> + assertBool "should have mono inline" $ + any (\case Mono _ -> True; _ -> False) c.brief + Nothing -> assertFailure "expected a comment" + + , testCase "multiple paragraphs in detailed" $ do + let (_, mc) = parseCommentFromXML $ Text.concat + [ "" + , " " + , " " + , " First paragraph" + , " Second paragraph" + , " " + , "" + ] + case mc of + Just c -> length c.detailed @?= 2 + Nothing -> assertFailure "expected a comment" + ] diff --git a/test/Test/Doxygen/Parser/Helpers.hs b/test/Test/Doxygen/Parser/Helpers.hs new file mode 100644 --- /dev/null +++ b/test/Test/Doxygen/Parser/Helpers.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE LambdaCase #-} + +-- | Shared XML-builder and assertion helpers for the test suite. +module Test.Doxygen.Parser.Helpers ( + -- * XML parsing + mkCursor + , parseBlockFromXML + , parseCommentFromXML + , parseInlinesFromXML + , wrap + -- * Assertion combinators + , inlineShouldBe + , blockShouldMatch + , shouldWarnAbout + -- * XML builders for parameterlist + , mkParamListXML + , mkCommentXML + -- * XML builders for entity extraction + , mkDoxygen + , mkCompound + , mkSection + , mkMember + , mkEnumVal + , withExtractedEntity + -- * Re-exports for tests that consume entity-extraction results + , XMLFileResult (..) + ) where + +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Lazy qualified as LText +import Test.Tasty.HUnit +import Text.XML qualified as XML +import Text.XML.Cursor (Cursor) +import Text.XML.Cursor qualified as Cursor + +import Doxygen.Parser +import Doxygen.Parser.Internal (ChildAction (..), XMLFileResult (..), + extractBriefAndDetail, extractEntity, + forChildren, parseBlockElement, + parseInlineChildren) + +{------------------------------------------------------------------------------- + Test helpers: XML parsing +-------------------------------------------------------------------------------} + +-- | Parse a raw XML string into a cursor pointing at the root element +mkCursor :: Text -> Cursor +mkCursor xml = + Cursor.fromDocument $ XML.parseText_ XML.def (LText.fromStrict xml) + +-- | Parse all children of @\@ as block elements +parseBlockFromXML :: Text -> ([Warning], [Block DoxyRef]) +parseBlockFromXML xml = + let root = mkCursor xml + pairs = map parseBlockElement (Cursor.child root) + in (concatMap fst pairs, concatMap snd pairs) + +-- | Parse comment from an XML element with brief/detailed descriptions +parseCommentFromXML :: Text -> ([Warning], Maybe (Comment DoxyRef)) +parseCommentFromXML xml = + let cursor = mkCursor xml + (_warns, parts) = forChildren "root" (Cursor.child cursor) $ \n c -> + case n of + "briefdescription" -> Just (Yield (Left c)) + "detaileddescription" -> Just (Yield (Right c)) + _ -> Just Skip + briefDescs = [c | Left c <- parts] + detailDescs = [c | Right c <- parts] + in extractBriefAndDetail briefDescs detailDescs + +-- | Parse inline children of the root element +parseInlinesFromXML :: Text -> ([Warning], [Inline DoxyRef]) +parseInlinesFromXML xml = parseInlineChildren (mkCursor xml) + +-- | Wrap content in a root element +wrap :: Text -> Text +wrap content = "" <> content <> "" + +{------------------------------------------------------------------------------- + Test helpers: assertion combinators +-------------------------------------------------------------------------------} + +-- | Assert that parsing an inline XML fragment produces the expected inlines +-- with no warnings. +inlineShouldBe :: Text -> [Inline DoxyRef] -> Assertion +inlineShouldBe xml expected = do + let (ws, is) = parseInlinesFromXML (wrap xml) + ws @?= [] + is @?= expected + +-- | Assert that parsing a block XML fragment produces a single block matching +-- the predicate, with no warnings. +blockShouldMatch :: Text -> (Block DoxyRef -> Assertion) -> Assertion +blockShouldMatch xml check = do + let (ws, bs) = parseBlockFromXML (wrap xml) + ws @?= [] + case bs of + [b] -> check b + _ -> assertFailure $ "expected exactly 1 block, got: " ++ show bs + +-- | Assert that warnings contain exactly one warning with the given structural +-- context and element name. +shouldWarnAbout :: [Warning] -> Text -> Text -> Assertion +shouldWarnAbout ws parentCtx elemName = do + let filtered = filter (\w -> w.context == StructureLevel parentCtx) ws + case filtered of + [w] -> w.element @?= elemName + _ -> assertFailure $ + "expected 1 " ++ Text.unpack parentCtx + ++ " warning about " ++ Text.unpack elemName + ++ ", got: " ++ show filtered + +{------------------------------------------------------------------------------- + Test helpers: XML builders for parameterlist +-------------------------------------------------------------------------------} + +-- | Build a @\@ XML fragment. +mkParamListXML :: Text -> [(Maybe Text, Text, Text)] -> Text +mkParamListXML kind params = Text.concat $ + [""] + ++ concatMap mkItem params + ++ [""] + where + mkItem (mDir, name, desc) = + [ Text.concat + [ "" + , " " + , " ", name, "" + , " " + , " ", desc, "" + , "" + ] + ] + + dirAttr Nothing = "" + dirAttr (Just dir) = " direction=\"" <> dir <> "\"" + +-- | Build a comment XML element with brief and detailed descriptions. +mkCommentXML :: Text -> Text -> Text +mkCommentXML brief detailed = Text.concat + [ "" + , " ", wrapPara brief, "" + , " ", wrapPara detailed, "" + , "" + ] + +{------------------------------------------------------------------------------- + Test helpers: XML builders for entity extraction +-------------------------------------------------------------------------------} + +-- | Wrap compound definitions in a @\@ root. +mkDoxygen :: Text -> Text +mkDoxygen body = "" <> body <> "" + +-- | Build a @\@ with brief description and body content. +mkCompound :: Text -> Text -> Text -> Text -> Text -> Text +mkCompound kind cid name brief body = Text.concat + [ "" + , "", name, "" + , "", wrapPara brief, "" + , "" + , body + , "" + ] + +-- | Build a @\@. +mkSection :: Text -> Text -> Text +mkSection kind body = Text.concat + [ "" + , body + , "" + ] + +-- | Build a @\@ with brief description and optional body content. +mkMember :: Text -> Text -> Text -> Text -> Text -> Text +mkMember kind mid name brief body = Text.concat + [ "" + , "", name, "" + , "", wrapPara brief, "" + , "" + , body + , "" + ] + +-- | Wrap text in a @\@; empty input produces empty output (so an empty +-- @\\@ is dropped by the parser, matching the real-world +-- shape of @doxygen@ XML). +wrapPara :: Text -> Text +wrapPara "" = "" +wrapPara t = "" <> t <> "" + +-- | Build an @\@. +mkEnumVal :: Text -> Text -> Text -> Text -> Text +mkEnumVal evid name brief body = Text.concat + [ "" + , "", name, "" + , "", brief, "" + , "" + , body + , "" + ] + +-- | Parse a @\@ from XML and run assertions on the result. +withExtractedEntity :: Text -> (XMLFileResult -> Assertion) -> Assertion +withExtractedEntity xml check = do + let doc = XML.parseText_ XML.def (LText.fromStrict xml) + root = Cursor.fromDocument doc + let (_warns, cds) = forChildren "doxygen" (Cursor.child root) $ \n c -> + case n of + "compounddef" -> Just (Yield c) + _ -> Just Skip + case cds of + [] -> assertFailure "no compounddef found" + (cd:_) -> check (extractEntity cd) diff --git a/test/Test/Doxygen/Parser/InlineNesting.hs b/test/Test/Doxygen/Parser/InlineNesting.hs new file mode 100644 --- /dev/null +++ b/test/Test/Doxygen/Parser/InlineNesting.hs @@ -0,0 +1,37 @@ +module Test.Doxygen.Parser.InlineNesting (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Doxygen.Parser +import Test.Doxygen.Parser.Helpers + +tests :: [TestTree] +tests = + [ testCase "bold inside emphasis" $ + "text" + `inlineShouldBe` [Emph [Bold [Text "text"]]] + , testCase "code inside bold" $ + "code" + `inlineShouldBe` [Bold [Mono [Text "code"]]] + , testCase "3-deep nesting: bold > emphasis > mono" $ + "deep" + `inlineShouldBe` [Bold [Emph [Mono [Text "deep"]]]] + , testCase "nested emphasis" $ + "outer inner outer" + `inlineShouldBe` + [Emph [Text "outer ", Emph [Text "inner"], Text " outer"]] + , testCase "ref inside emphasis" $ + "name" + `inlineShouldBe` [Emph [Ref (DoxyRef "name" Nothing) "name"]] + , testCase "link inside bold" $ + "text" + `inlineShouldBe` [Bold [Link [Text "text"] "http://x"]] + , testCase "mixed siblings: text + bold + text + emphasis" $ + "Hello world and more!" + `inlineShouldBe` + [ Text "Hello ", Bold [Text "world"] + , Text " and ", Emph [Text "more"] + , Text "!" + ] + ] diff --git a/test/Test/Doxygen/Parser/InlineParsing.hs b/test/Test/Doxygen/Parser/InlineParsing.hs new file mode 100644 --- /dev/null +++ b/test/Test/Doxygen/Parser/InlineParsing.hs @@ -0,0 +1,57 @@ +module Test.Doxygen.Parser.InlineParsing (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Doxygen.Parser +import Test.Doxygen.Parser.Helpers + +tests :: [TestTree] +tests = + [ testCase "plain text" $ + "hello" `inlineShouldBe` [Text "hello"] + , testCase "bold" $ + "text" `inlineShouldBe` [Bold [Text "text"]] + , testCase "emphasis" $ + "text" `inlineShouldBe` [Emph [Text "text"]] + , testCase "computeroutput" $ + "code" `inlineShouldBe` [Mono [Text "code"]] + , testCase "ref without kindref" $ + "my_func" `inlineShouldBe` [Ref (DoxyRef "my_func" Nothing) "my_func"] + , testCase "ref with kindref compound" $ + "foo" + `inlineShouldBe` [Ref (DoxyRef "foo" (Just RefCompound)) "foo"] + , testCase "ref with kindref member" $ + "bar" + `inlineShouldBe` [Ref (DoxyRef "bar" (Just RefMember)) "bar"] + , testCase "anchor" $ + "" `inlineShouldBe` [Anchor "foo"] + , testCase "ulink" $ + "click" + `inlineShouldBe` [Link [Text "click"] "http://example.com"] + , testCase "linebreak" $ + "" `inlineShouldBe` [Text "\n"] + , testCase "sp" $ + "" `inlineShouldBe` [Text " "] + , testCase "empty bold" $ + "" `inlineShouldBe` [Bold []] + , testCase "empty emphasis" $ + "" `inlineShouldBe` [Emph []] + + , testCase "special XML characters" $ + "a < b & c > d" `inlineShouldBe` [Text "a < b & c > d"] + + , testCase "unknown inline degrades to text" $ do + let (ws, is) = parseInlinesFromXML (wrap "x") + case ws of + [w] -> do + w.context @?= InlineLevel + w.degradation @?= DegradedToText + _ -> assertFailure $ "expected 1 warning, got: " ++ show ws + is @?= [Text "x"] + + , testCase "unknown inline with empty text" $ do + let (ws, is) = parseInlinesFromXML (wrap "") + length ws @?= 1 + is @?= [] + ] diff --git a/test/Test/Doxygen/Parser/List.hs b/test/Test/Doxygen/Parser/List.hs new file mode 100644 --- /dev/null +++ b/test/Test/Doxygen/Parser/List.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE LambdaCase #-} + +module Test.Doxygen.Parser.List (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Doxygen.Parser +import Test.Doxygen.Parser.Helpers + +tests :: [TestTree] +tests = + [ testCase "itemized list" $ + blockShouldMatch + ("" + <> "First" + <> "Second" + <> "") $ + \case + ItemizedList items -> length items @?= 2 + b -> assertFailure $ "expected itemized list: " ++ show b + + , testCase "ordered list" $ + blockShouldMatch + ("" + <> "First" + <> "Second" + <> "Third" + <> "") $ + \case + OrderedList items -> length items @?= 3 + b -> assertFailure $ "expected ordered list: " ++ show b + + , testCase "nested lists" $ + blockShouldMatch + ("" + <> "" + <> " Outer" + <> " " + <> " Inner" + <> " " + <> "" + <> "") $ + \case + ItemizedList [item] -> + assertBool "should have nested list" $ + any (\case ItemizedList _ -> True; _ -> False) item + b -> assertFailure $ "expected nested list: " ++ show b + + , testCase "list item with formatted content" $ + blockShouldMatch + ("" + <> "Use this function" + <> "") $ + \case + ItemizedList [[Paragraph is]] -> + assertBool "should have bold" $ + any (\case Bold _ -> True; _ -> False) is + b -> assertFailure $ "unexpected: " ++ show b + ] diff --git a/test/Test/Doxygen/Parser/NormalizeWhitespace.hs b/test/Test/Doxygen/Parser/NormalizeWhitespace.hs new file mode 100644 --- /dev/null +++ b/test/Test/Doxygen/Parser/NormalizeWhitespace.hs @@ -0,0 +1,18 @@ +module Test.Doxygen.Parser.NormalizeWhitespace (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Doxygen.Parser.Internal (normalizeWhitespace) + +tests :: [TestTree] +tests = + [ testCase "plain text" $ normalizeWhitespace "hello" @?= "hello" + , testCase "preserves trailing space" $ normalizeWhitespace "hello " @?= "hello " + , testCase "preserves leading space" $ normalizeWhitespace " hello" @?= " hello" + , testCase "preserves both" $ normalizeWhitespace " hello " @?= " hello " + , testCase "collapses internal whitespace" $ normalizeWhitespace "hello world" @?= "hello world" + , testCase "collapses newlines" $ normalizeWhitespace "hello\n world" @?= "hello world" + , testCase "leading newline becomes space" $ normalizeWhitespace "\n hello" @?= " hello" + , testCase "trailing newline becomes space" $ normalizeWhitespace "hello\n" @?= "hello " + ] diff --git a/test/Test/Doxygen/Parser/Param.hs b/test/Test/Doxygen/Parser/Param.hs new file mode 100644 --- /dev/null +++ b/test/Test/Doxygen/Parser/Param.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE LambdaCase #-} + +module Test.Doxygen.Parser.Param (tests) where + +import Data.Text (Text) +import Data.Text qualified as Text +import Test.Tasty +import Test.Tasty.HUnit + +import Doxygen.Parser +import Test.Doxygen.Parser.Helpers + +tests :: [TestTree] +tests = + [ mkParamTest "param with direction=in" (Just "in") "x" (Just DirIn) + , mkParamTest "param with direction=out" (Just "out") "result" (Just DirOut) + , mkParamTest "param with direction=inout" (Just "inout") "buf" (Just DirInOut) + , mkParamTest "param with no direction" Nothing "x" Nothing + + , testCase "param with empty description" $ + blockShouldMatch (mkParamListXML "param" [(Nothing, "x", "")]) $ + \case + -- Empty in description is dropped, so paramDesc is empty + -- (the mkParamListXML wraps desc in , but empty text + -- produces an empty paragraph which is dropped) + ParamList _ [_p] -> pure () + b -> assertFailure $ "unexpected: " ++ show b + + , testCase "param with missing name is skipped" $ do + let xml = wrap $ Text.concat + [ "" + , "" + , " " + , " Desc" + , "" + , "" + ] + let (_, bs) = parseBlockFromXML xml + case bs of + [ParamList _ params] -> + length params @?= 0 + _ -> assertFailure $ "unexpected: " ++ show bs + + , testCase "multiple params" $ + blockShouldMatch + (mkParamListXML "param" + [ (Nothing, "a", "First") + , (Nothing, "b", "Second") + ]) $ + \case + ParamList _ params -> length params @?= 2 + b -> assertFailure $ "unexpected: " ++ show b + ] + where + mkParamTest :: String -> Maybe Text -> Text -> Maybe ParamDirection -> TestTree + mkParamTest name mDir paramName expectedDir = + testCase name $ + blockShouldMatch (mkParamListXML "param" [(mDir, paramName, "Desc")]) $ + \case + ParamList _ [p] -> p.paramDirection @?= expectedDir + b -> assertFailure $ "unexpected: " ++ show b diff --git a/test/Test/Doxygen/Parser/Properties.hs b/test/Test/Doxygen/Parser/Properties.hs new file mode 100644 --- /dev/null +++ b/test/Test/Doxygen/Parser/Properties.hs @@ -0,0 +1,24 @@ +module Test.Doxygen.Parser.Properties (tests) where + +import Data.Text qualified as Text +import Test.QuickCheck ((===)) +import Test.QuickCheck qualified as QC +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) + +import Doxygen.Parser.Internal (normalizeWhitespace) + +tests :: [TestTree] +tests = + [ testProperty "normalizeWhitespace is idempotent" $ \(QC.PrintableString s) -> + let t = Text.pack s + in normalizeWhitespace (normalizeWhitespace t) === normalizeWhitespace t + + , testProperty "normalizeWhitespace: no internal double spaces" $ + \(QC.PrintableString s) -> + let t = Text.pack s + result = normalizeWhitespace t + -- Strip the (at most one) leading and trailing space + interior = Text.dropWhileEnd (== ' ') $ Text.dropWhile (== ' ') result + in not (Text.isInfixOf " " interior) + ] diff --git a/test/Test/Doxygen/Parser/SimpleSect.hs b/test/Test/Doxygen/Parser/SimpleSect.hs new file mode 100644 --- /dev/null +++ b/test/Test/Doxygen/Parser/SimpleSect.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE LambdaCase #-} + +module Test.Doxygen.Parser.SimpleSect (tests) where + +import Data.Text (Text) +import Data.Text qualified as Text +import Test.Tasty +import Test.Tasty.HUnit + +import Doxygen.Parser +import Test.Doxygen.Parser.Helpers + +tests :: [TestTree] +tests = + [ mkSimpleSectTest "return" SSReturn + , mkSimpleSectTest "warning" SSWarning + , mkSimpleSectTest "note" SSNote + , mkSimpleSectTest "see" SSSee + , mkSimpleSectTest "since" SSSince + , mkSimpleSectTest "version" SSVersion + , mkSimpleSectTest "pre" SSPre + , mkSimpleSectTest "post" SSPost + , mkSimpleSectTest "deprecated" SSDeprecated + , mkSimpleSectTest "remark" SSRemark + , mkSimpleSectTest "attention" SSAttention + , mkSimpleSectTest "todo" SSTodo + , mkSimpleSectTest "invariant" SSInvariant + , mkSimpleSectTest "author" SSAuthor + , mkSimpleSectTest "date" SSDate + + , testCase "par with title" $ + blockShouldMatch + ("" + <> "My Title" + <> "Content" + <> "") $ + \case + SimpleSect (SSPar title) _ -> title @?= "My Title" + b -> assertFailure $ "expected SSPar: " ++ show b + + , testCase "unknown kind defaults to SSNote with warning" $ do + let (ws, bs) = parseBlockFromXML + (wrap "X") + case ws of + [w] -> do + w.context @?= UnknownSectKind + w.degradation @?= DefaultedTo "Note" + _ -> assertFailure $ "expected 1 warning, got: " ++ show ws + case bs of + [SimpleSect SSNote _] -> pure () + _ -> assertFailure $ "expected SSNote: " ++ show bs + + , testCase "missing kind defaults to SSNote with warning" $ do + let (ws, bs) = parseBlockFromXML + (wrap "X") + case ws of + [w] -> w.context @?= UnknownSectKind + _ -> assertFailure $ "expected 1 warning, got: " ++ show ws + case bs of + [SimpleSect SSNote _] -> pure () + _ -> assertFailure $ "expected SSNote: " ++ show bs + ] + +mkSimpleSectTest :: Text -> SimpleSectKind -> TestTree +mkSimpleSectTest kindAttr expected = + testCase (Text.unpack kindAttr) $ + blockShouldMatch + (" kindAttr <> "\">Content") $ + \case + SimpleSect k _ -> k @?= expected + b -> assertFailure $ "expected simplesect: " ++ show b diff --git a/test/Test/Doxygen/Parser/StructuralWarnings.hs b/test/Test/Doxygen/Parser/StructuralWarnings.hs new file mode 100644 --- /dev/null +++ b/test/Test/Doxygen/Parser/StructuralWarnings.hs @@ -0,0 +1,62 @@ +module Test.Doxygen.Parser.StructuralWarnings (tests) where + +import Data.Text qualified as Text +import Test.Tasty +import Test.Tasty.HUnit + +import Doxygen.Parser +import Test.Doxygen.Parser.Helpers + +tests :: [TestTree] +tests = + [ testCase "unknown briefdescription child warns" $ do + let xml = Text.concat + [ "" + , " " + , " Normal para" + , " unexpected" + , " " + , " " + , "" + ] + (ws, mc) = parseCommentFromXML xml + assertBool "should still produce a comment" $ mc /= Nothing + shouldWarnAbout ws "briefdescription" "bogus" + + , testCase "unknown parameteritem child warns" $ do + let (ws, _) = parseBlockFromXML $ wrap $ Text.concat + [ "" + , " " + , " " + , " x" + , " " + , " The input." + , " " + , " " + , "" + ] + shouldWarnAbout ws "parameteritem" "alien" + + , testCase "unknown programlisting child warns" $ do + let (ws, bs) = parseBlockFromXML $ wrap $ Text.concat + [ "" + , " code" + , " " + , "" + ] + shouldWarnAbout ws "programlisting" "bogus" + case bs of + [CodeBlock lines'] -> length lines' @?= 1 + _ -> assertFailure $ "expected CodeBlock: " ++ show bs + + , testCase "unknown codeline child warns" $ do + let (ws, _) = parseBlockFromXML $ wrap $ Text.concat + [ "" + , " " + , " code" + , " " + , " " + , "" + ] + shouldWarnAbout ws "codeline" "mystery" + ] diff --git a/test/Test/Doxygen/Parser/Whitespace.hs b/test/Test/Doxygen/Parser/Whitespace.hs new file mode 100644 --- /dev/null +++ b/test/Test/Doxygen/Parser/Whitespace.hs @@ -0,0 +1,38 @@ +module Test.Doxygen.Parser.Whitespace (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Doxygen.Parser +import Test.Doxygen.Parser.Helpers + +tests :: [TestTree] +tests = + [ testCase "space between text and bold is preserved" $ + "Hello world" + `inlineShouldBe` [Text "Hello ", Bold [Text "world"]] + + , testCase "space after bold is preserved" $ + "word rest" + `inlineShouldBe` [Bold [Text "word"], Text " rest"] + + , testCase "inter-element spacing in sentence" $ + "Use foo for bar" + `inlineShouldBe` [Text "Use ", Mono [Text "foo"], Text " for bar"] + + , testCase "whitespace-only text node is normalized to space" $ + " " `inlineShouldBe` [Text " "] + , testCase "newline-only text is normalized to space" $ + "\n \n" `inlineShouldBe` [Text " "] + , testCase "unicode content preserved" $ + "caf\233 na\239ve" `inlineShouldBe` [Text "caf\233 na\239ve"] + + , testCase "whitespace between sibling inline elements in para" $ do + let (ws, bs) = parseBlockFromXML + (wrap "a b") + ws @?= [] + case bs of + [Paragraph inlines] -> + inlines @?= [Bold [Text "a"], Text " ", Emph [Text "b"]] + _ -> assertFailure $ "unexpected: " ++ show bs + ] diff --git a/test/Test/Doxygen/Parser/XMLFileResult.hs b/test/Test/Doxygen/Parser/XMLFileResult.hs new file mode 100644 --- /dev/null +++ b/test/Test/Doxygen/Parser/XMLFileResult.hs @@ -0,0 +1,118 @@ +module Test.Doxygen.Parser.XMLFileResult (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Test.Tasty +import Test.Tasty.HUnit + +import Doxygen.Parser +import Test.Doxygen.Parser.Helpers + +tests :: [TestTree] +tests = + [ testCase "struct compound extracts struct doc and field docs" $ + withExtractedEntity + (mkDoxygen $ mkCompound "struct" "structfoo" "foo_t" "A foo struct" $ + mkSection "public-attrib" $ Text.concat + [ mkMember "variable" "field_x" "x" "X coordinate" "" + , mkMember "variable" "field_y" "y" "Y coordinate" "" + ]) $ \result -> do + assertBool "should have struct doc" $ + Map.member (KeyStruct "foo_t") result.comments + assertBool "should have field x" $ + Map.member (KeyField "foo_t" "x") result.comments + assertBool "should have field y" $ + Map.member (KeyField "foo_t" "y") result.comments + + , testCase "group compound extracts title and member docs" $ + withExtractedEntity + (mkDoxygen $ mkCompound "group" "group__core" "core" "" $ + "Core Functions" + <> mkSection "func" + (mkMember "function" "func_init" "init" "Initialize" "") + ) $ \result -> do + result.groupTitles @?= [("core", "Core Functions")] + assertBool "should have init decl" $ + Map.member (KeyDecl "init") result.comments + + , testCase "enum member extracts enum value docs" $ + withExtractedEntity + (mkDoxygen $ mkCompound "file" "myfile_8h" "myfile.h" "" $ + mkSection "enum" $ + mkMember "enum" "enum_color" "color_t" "A color enum" $ Text.concat + [ mkEnumVal "ev_red" "RED" "Red color" "" + , mkEnumVal "ev_blue" "BLUE" "Blue color" "" + ] + ) $ \result -> do + assertBool "should have color_t decl" $ + Map.member (KeyDecl "color_t") result.comments + assertBool "should have RED" $ + Map.member (KeyEnumValue "color_t" "RED") result.comments + assertBool "should have BLUE" $ + Map.member (KeyEnumValue "color_t" "BLUE") result.comments + + , testCase "known-but-ignored compounddef children produce no warnings" $ + withExtractedEntity + (mkDoxygen $ mkCompound "struct" "structbar" "bar_t" "A bar struct" $ + "" + <> "test.h" + ) $ \result -> do + assertBool "should have struct doc" $ + Map.member (KeyStruct "bar_t") result.comments + result.warnings @?= [] + + , testCase "truly unknown compounddef children emit warnings" $ + withExtractedEntity + (mkDoxygen $ mkCompound "struct" "structbar" "bar_t" "A bar struct" + "unexpected content" + ) $ \result -> do + assertBool "should have struct doc" $ + Map.member (KeyStruct "bar_t") result.comments + shouldWarnAbout result.warnings "compounddef" "nonstandard" + case result.warnings of + [w] -> w.degradation @?= Omitted + _ -> assertFailure $ "expected 1 warning, got: " ++ show result.warnings + + , testCase "unknown memberdef children emit warnings" $ + withExtractedEntity + (mkDoxygen $ mkCompound "group" "group__test" "test" "" $ + mkSection "func" $ + mkMember "function" "test_1" "foo" "A function" + "voidunexpected" + ) $ \result -> do + assertBool "should have decl doc" $ + Map.member (KeyDecl "foo") result.comments + shouldWarnAbout result.warnings "memberdef" "bogus_tag" + + , testCase "unknown sectiondef children emit warnings" $ + withExtractedEntity + (mkDoxygen $ mkCompound "group" "group__test" "test" "" $ + mkSection "func" $ + mkMember "function" "test_1" "bar" "A function" "" + <> "" + ) $ \result -> + shouldWarnAbout result.warnings "sectiondef" "unexpected_child" + + , testCase "unknown enumvalue children emit warnings" $ + withExtractedEntity + (mkDoxygen $ mkCompound "group" "group__test" "test" "" $ + mkSection "enum" $ + mkMember "enum" "test_1" "color_t" "Colors" $ + mkEnumVal "ev1" "RED" "Red" + "= 0" + ) $ \result -> do + assertBool "should have enum value doc" $ + Map.member (KeyEnumValue "color_t" "RED") result.comments + shouldWarnAbout result.warnings "enumvalue" "alien_element" + + , testCase "compounddef with no compoundname produces empty result" $ + withExtractedEntity (Text.concat + [ "" + , "" + , " Orphaned doc" + , " " + , "" + , "" + ]) $ \result -> + result.comments @?= Map.empty + ]