diff --git a/scrod.cabal b/scrod.cabal --- a/scrod.cabal +++ b/scrod.cabal @@ -1,6 +1,6 @@ cabal-version: 3.12 name: scrod -version: 1.0.0.0 +version: 1.1.0.0 synopsis: Worse Haskell documentation description: Scrod generates documentation for Haskell modules, similar to Haddock. Unlike @@ -114,6 +114,7 @@ Scrod.Convert.ToHtml Scrod.Convert.ToJsonSchema Scrod.Core.Category + Scrod.Core.Collapsible Scrod.Core.Column Scrod.Core.Definition Scrod.Core.Doc diff --git a/source/library/Scrod/Convert/FromGhc.hs b/source/library/Scrod/Convert/FromGhc.hs --- a/source/library/Scrod/Convert/FromGhc.hs +++ b/source/library/Scrod/Convert/FromGhc.hs @@ -171,7 +171,7 @@ SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> (Doc.Doc, Maybe Since.Since) extractModuleDocAndSince lHsModule = - maybe (Doc.Empty, Nothing) GhcDoc.parseDoc (extractRawDocString lHsModule) + maybe (Doc.Empty, Nothing) GhcDoc.parseModuleDoc (extractRawDocString lHsModule) -- | Extract raw documentation string from the module header. extractRawDocString :: diff --git a/source/library/Scrod/Convert/FromGhc/Doc.hs b/source/library/Scrod/Convert/FromGhc/Doc.hs --- a/source/library/Scrod/Convert/FromGhc/Doc.hs +++ b/source/library/Scrod/Convert/FromGhc/Doc.hs @@ -5,6 +5,8 @@ -- 'Doc.Doc' type via the Haddock parser. module Scrod.Convert.FromGhc.Doc where +import qualified Data.Char as Char +import qualified Data.List as List import qualified Data.Set as Set import qualified Data.Text as Text import qualified Documentation.Haddock.Parser as Haddock @@ -17,6 +19,7 @@ import qualified Language.Haskell.Syntax as Syntax import qualified Scrod.Convert.FromGhc.Internal as Internal import qualified Scrod.Convert.FromHaddock as FromHaddock +import qualified Scrod.Core.Definition as Definition import qualified Scrod.Core.Doc as Doc import qualified Scrod.Core.Since as Since @@ -44,6 +47,96 @@ doc = FromHaddock.fromHaddock $ Haddock._doc metaDoc itemSince = Haddock._metaSince (Haddock._meta metaDoc) >>= Internal.metaSinceToSince in (doc, itemSince) + +-- | Parse module documentation, extracting header fields as a definition list. +-- +-- Haddock module comments may begin with metadata fields like +-- @Description@, @Copyright@, @License@, etc. This function strips +-- those fields from the input, parses the remaining text with +-- 'parseDoc', and prepends the fields as a 'Doc.DefList'. +parseModuleDoc :: String -> (Doc.Doc, Maybe Since.Since) +parseModuleDoc input = + let (fields, rest) = parseModuleHeaderFields input + (doc, since) = parseDoc rest + fieldsDoc = case fields of + [] -> Doc.Empty + _ -> + Doc.DefList $ + fmap + ( \(name, value) -> + Definition.MkDefinition + { Definition.term = Doc.String $ Text.pack name, + Definition.definition = Doc.String . Text.pack $ trimValue value + } + ) + fields + in (Internal.appendDoc fieldsDoc doc, since) + +-- | Trim leading and trailing whitespace from a field value. +trimValue :: String -> String +trimValue = List.dropWhileEnd Char.isSpace . dropWhile Char.isSpace + +-- | Parse Haddock module header fields from a doc string. +-- +-- Returns the list of @(fieldName, fieldValue)@ pairs and the +-- remaining doc string after the fields section. +parseModuleHeaderFields :: String -> ([(String, String)], String) +parseModuleHeaderFields input = + let ls = lines input + (blanks, nonBlanks) = span (all Char.isSpace) ls + (fieldLines, restLines) = parseFieldLines nonBlanks + in case fieldLines of + [] -> ([], input) + _ -> (fieldLines, unlines (blanks <> restLines)) + +-- | Known Haddock module header field names. +moduleHeaderFieldNames :: [String] +moduleHeaderFieldNames = + [ "Module", + "Description", + "Copyright", + "License", + "Maintainer", + "Stability", + "Portability" + ] + +-- | Parse field lines from the beginning of a doc string. +-- +-- Each field is @FieldName: value@ possibly followed by indented +-- continuation lines. Parsing stops at the first line that is not +-- a known field header or a continuation of the previous field. +parseFieldLines :: [String] -> ([(String, String)], [String]) +parseFieldLines [] = ([], []) +parseFieldLines allLines@(l : rest) = + case parseFieldHeader l of + Just (name, value) -> + let (continuations, remaining) = span isContinuationLine rest + fullValue = List.intercalate "\n" (value : continuations) + (moreFields, finalRest) = parseFieldLines remaining + in ((name, fullValue) : moreFields, finalRest) + Nothing -> ([], allLines) + +-- | Try to parse a line as a field header (@FieldName: value@). +-- +-- Allows optional whitespace between the field name and the colon, +-- e.g. both @Description: foo@ and @Description : foo@. +parseFieldHeader :: String -> Maybe (String, String) +parseFieldHeader line = + let stripped = dropWhile Char.isSpace line + lowered = fmap Char.toLower stripped + in case List.find (\name -> fmap Char.toLower name `List.isPrefixOf` lowered) moduleHeaderFieldNames of + Just name -> + let afterName = dropWhile Char.isSpace $ drop (length name) stripped + in case afterName of + ':' : after -> Just (name, after) + _ -> Nothing + Nothing -> Nothing + +-- | A continuation line starts with whitespace and is not blank. +isContinuationLine :: String -> Bool +isContinuationLine [] = False +isContinuationLine (c : cs) = Char.isSpace c && not (all Char.isSpace cs) -- | Associate documentation comments with their target declarations. -- diff --git a/source/library/Scrod/Convert/FromHaddock.hs b/source/library/Scrod/Convert/FromHaddock.hs --- a/source/library/Scrod/Convert/FromHaddock.hs +++ b/source/library/Scrod/Convert/FromHaddock.hs @@ -12,6 +12,7 @@ import qualified Data.Void as Void import qualified Documentation.Haddock.Parser as Haddock import qualified Documentation.Haddock.Types as Haddock +import qualified Scrod.Core.Collapsible as Collapsible import qualified Scrod.Core.Definition as Definition import qualified Scrod.Core.Doc as Doc import qualified Scrod.Core.Example as Example @@ -29,7 +30,7 @@ import qualified Scrod.Spec as Spec fromHaddock :: Haddock.DocH Void.Void Haddock.Identifier -> Doc.Doc -fromHaddock = convertDoc . Haddock.overIdentifier convertIdentifier +fromHaddock = groupCollapsible . convertDoc . Haddock.overIdentifier convertIdentifier convertIdentifier :: Haddock.Namespace -> String -> Maybe Identifier.Identifier convertIdentifier ns str = @@ -123,6 +124,61 @@ TableCell.contents = convertDoc $ Haddock.tableCellContents cell } +-- | Post-processes a 'Doc.Doc' tree to detect collapsible headers. +-- A collapsible header is a 'Doc.Header' whose title is wrapped in +-- 'Doc.Bold'. The collapsible section extends until a header of equal +-- or higher level (smaller level number), or the end of the list. +groupCollapsible :: Doc.Doc -> Doc.Doc +groupCollapsible doc = case doc of + Doc.Append xs -> case groupHeaders $ flattenAppend xs of + [single] -> single + grouped -> Doc.Append grouped + _ -> mapDocChildren groupCollapsible doc + +-- | Apply a function to all immediate 'Doc.Doc' children of a node. +mapDocChildren :: (Doc.Doc -> Doc.Doc) -> Doc.Doc -> Doc.Doc +mapDocChildren f doc = case doc of + Doc.Paragraph x -> Doc.Paragraph $ f x + Doc.Emphasis x -> Doc.Emphasis $ f x + Doc.Monospaced x -> Doc.Monospaced $ f x + Doc.Bold x -> Doc.Bold $ f x + Doc.UnorderedList xs -> Doc.UnorderedList $ fmap f xs + Doc.OrderedList xs -> Doc.OrderedList $ fmap (\ni -> ni {NumberedItem.item = f $ NumberedItem.item ni}) xs + Doc.DefList xs -> Doc.DefList $ fmap (\d -> d {Definition.term = f $ Definition.term d, Definition.definition = f $ Definition.definition d}) xs + Doc.CodeBlock x -> Doc.CodeBlock $ f x + Doc.Header h -> Doc.Header h {Header.title = f $ Header.title h} + Doc.CollapsibleHeader c -> Doc.CollapsibleHeader c {Collapsible.header = (Collapsible.header c) {Header.title = f . Header.title $ Collapsible.header c}, Collapsible.body = f $ Collapsible.body c} + other -> other + +flattenAppend :: [Doc.Doc] -> [Doc.Doc] +flattenAppend = concatMap go + where + go (Doc.Append xs) = flattenAppend xs + go x = [groupCollapsible x] + +groupHeaders :: [Doc.Doc] -> [Doc.Doc] +groupHeaders [] = [] +groupHeaders (Doc.Header h : rest) + | Doc.Bold title <- Header.title h = + let level = Header.level h + (body, remaining) = break (isHeaderAtOrAbove level) rest + groupedBody = groupHeaders body + in Doc.CollapsibleHeader + Collapsible.MkCollapsible + { Collapsible.header = h {Header.title = title}, + Collapsible.body = case groupedBody of + [] -> Doc.Empty + [single] -> single + multiple -> Doc.Append multiple + } + : groupHeaders remaining +groupHeaders (x : rest) = x : groupHeaders rest + +isHeaderAtOrAbove :: Level.Level -> Doc.Doc -> Bool +isHeaderAtOrAbove level doc = case doc of + Doc.Header h -> Header.level h <= level + _ -> False + spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () spec s = do Spec.named s 'fromHaddock $ do @@ -257,6 +313,20 @@ let input :: Haddock.DocH Void.Void Haddock.Identifier input = Haddock.DocHeader Haddock.Header {Haddock.headerLevel = 2, Haddock.headerTitle = Haddock.DocString "Section"} let expected = Doc.Header Header.MkHeader {Header.level = Level.Two, Header.title = Doc.String $ Text.pack "Section"} + Spec.assertEq s (fromHaddock input) expected + + Spec.it s "works with collapsible header" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = + Haddock.DocAppend + (Haddock.DocHeader Haddock.Header {Haddock.headerLevel = 2, Haddock.headerTitle = Haddock.DocBold (Haddock.DocString "Examples:")}) + (Haddock.DocParagraph (Haddock.DocString "content")) + let expected = + Doc.CollapsibleHeader + Collapsible.MkCollapsible + { Collapsible.header = Header.MkHeader {Header.level = Level.Two, Header.title = Doc.String $ Text.pack "Examples:"}, + Collapsible.body = Doc.Paragraph . Doc.String $ Text.pack "content" + } Spec.assertEq s (fromHaddock input) expected Spec.it s "works with table" $ do diff --git a/source/library/Scrod/Convert/ToHtml.hs b/source/library/Scrod/Convert/ToHtml.hs --- a/source/library/Scrod/Convert/ToHtml.hs +++ b/source/library/Scrod/Convert/ToHtml.hs @@ -13,6 +13,7 @@ import qualified Data.Maybe as Maybe import qualified Data.Text as Text import qualified Scrod.Core.Category as Category +import qualified Scrod.Core.Collapsible as Collapsible import qualified Scrod.Core.Column as Column import qualified Scrod.Core.Definition as Definition import qualified Scrod.Core.Doc as Doc @@ -705,6 +706,7 @@ Doc.Property x -> [propertyContent x] Doc.Examples xs -> exampleContent <$> NonEmpty.toList xs Doc.Header x -> [headerContent x] + Doc.CollapsibleHeader x -> [collapsibleHeaderContent x] Doc.Table x -> [tableContent x] definitionContents :: Definition.Definition Doc.Doc -> [Content.Content Element.Element] @@ -857,6 +859,29 @@ headerContent :: Header.Header Doc.Doc -> Content.Content Element.Element headerContent x = element (levelToName $ Header.level x) [] . docContents $ Header.title x + +collapsibleHeaderContent :: Collapsible.Collapsible Doc.Doc -> Content.Content Element.Element +collapsibleHeaderContent x = + let header = Collapsible.header x + lvl = Header.level header + in element + "details" + [] + [ element + "summary" + [] + [element "span" [("role", "heading"), ("aria-level", levelToNumber lvl), ("class", levelToName lvl)] . docContents $ Header.title header], + element "div" [] $ docContents (Collapsible.body x) + ] + +levelToNumber :: Level.Level -> String +levelToNumber x = case x of + Level.One -> "1" + Level.Two -> "2" + Level.Three -> "3" + Level.Four -> "4" + Level.Five -> "5" + Level.Six -> "6" levelToName :: Level.Level -> String levelToName x = case x of diff --git a/source/library/Scrod/Core/Collapsible.hs b/source/library/Scrod/Core/Collapsible.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Collapsible.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Collapsible where + +import qualified GHC.Generics as Generics +import qualified Scrod.Core.Header as Header +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | A collapsible section with a header and body content. +-- Corresponds to Haddock's collapsible headers, where the header title +-- is wrapped in bold syntax (@__title__@). +data Collapsible doc = MkCollapsible + { header :: Header.Header doc, + body :: doc + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically (Collapsible doc) diff --git a/source/library/Scrod/Core/Doc.hs b/source/library/Scrod/Core/Doc.hs --- a/source/library/Scrod/Core/Doc.hs +++ b/source/library/Scrod/Core/Doc.hs @@ -6,6 +6,7 @@ import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as Text import qualified GHC.Generics as Generics +import qualified Scrod.Core.Collapsible as Collapsible import qualified Scrod.Core.Definition as Definition import qualified Scrod.Core.Example as Example import qualified Scrod.Core.Header as Header @@ -41,6 +42,7 @@ | Property Text.Text | Examples (NonEmpty.NonEmpty Example.Example) | Header (Header.Header Doc) + | CollapsibleHeader (Collapsible.Collapsible Doc) | Table (Table.Table Doc) deriving (Eq, Generics.Generic, Ord, Show) deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically Doc diff --git a/source/library/Scrod/TestSuite/Integration.hs b/source/library/Scrod/TestSuite/Integration.hs --- a/source/library/Scrod/TestSuite/Integration.hs +++ b/source/library/Scrod/TestSuite/Integration.hs @@ -555,6 +555,70 @@ ("/documentation/value/level", "3") ] + Spec.it s "works with a collapsible header" $ do + check + s + """ + -- | + -- == __Examples:__ + -- content + module M where + """ + [ ("/documentation/type", "\"CollapsibleHeader\""), + ("/documentation/value/header/level", "2"), + ("/documentation/value/header/title/type", "\"String\""), + ("/documentation/value/header/title/value", "\"Examples:\""), + ("/documentation/value/body/type", "\"Paragraph\"") + ] + + Spec.it s "works with nested collapsible headers" $ do + check + s + """ + -- | + -- = __a__ + -- + -- b + -- + -- == __c__ + -- + -- d + module M where + """ + [ ("/documentation/type", "\"CollapsibleHeader\""), + ("/documentation/value/header/level", "1"), + ("/documentation/value/header/title/type", "\"String\""), + ("/documentation/value/header/title/value", "\"a\""), + ("/documentation/value/body/type", "\"Append\""), + ("/documentation/value/body/value/1/type", "\"CollapsibleHeader\""), + ("/documentation/value/body/value/1/value/header/level", "2"), + ("/documentation/value/body/value/1/value/header/title/type", "\"String\""), + ("/documentation/value/body/value/1/value/header/title/value", "\"c\"") + ] + + Spec.it s "escapes collapsible header with a larger header" $ do + check + s + """ + -- | + -- == __a__ + -- + -- b + -- + -- = c + -- + -- d + module M where + """ + [ ("/documentation/type", "\"Append\""), + ("/documentation/value/0/type", "\"CollapsibleHeader\""), + ("/documentation/value/0/value/header/level", "2"), + ("/documentation/value/0/value/header/title/value", "\"a\""), + ("/documentation/value/0/value/body/type", "\"Paragraph\""), + ("/documentation/value/1/type", "\"Header\""), + ("/documentation/value/1/value/level", "1") + ] + Spec.it s "works with a table" $ do check s @@ -598,6 +662,114 @@ ("/documentation/value/bodyRows/1/1/rowspan", "1"), ("/documentation/value/bodyRows/1/1/contents/type", "\"String\""), ("/documentation/value/bodyRows/1/1/contents/value", "\"g\"") + ] + + Spec.describe s "module description fields" $ do + Spec.it s "works with a single field" $ do + check + s + """ + {-| + Description: some text + -} + module M where + """ + [ ("/documentation/type", "\"DefList\""), + ("/documentation/value/0/term/type", "\"String\""), + ("/documentation/value/0/term/value", "\"Description\""), + ("/documentation/value/0/definition/type", "\"String\""), + ("/documentation/value/0/definition/value", "\"some text\"") + ] + + Spec.it s "works with all fields" $ do + check + s + """ + {-| + Module: a + Description: b + Copyright: c + License: d + Maintainer: e + Stability: f + Portability: g + -} + module M where + """ + [ ("/documentation/type", "\"DefList\""), + ("/documentation/value/0/term/value", "\"Module\""), + ("/documentation/value/0/definition/value", "\"a\""), + ("/documentation/value/6/term/value", "\"Portability\""), + ("/documentation/value/6/definition/value", "\"g\"") + ] + + Spec.it s "works with fields followed by documentation" $ do + check + s + """ + {-| + Description: hello + + Some docs. + -} + module M where + """ + [ ("/documentation/type", "\"Append\""), + ("/documentation/value/0/type", "\"DefList\""), + ("/documentation/value/0/value/0/term/value", "\"Description\""), + ("/documentation/value/0/value/0/definition/value", "\"hello\""), + ("/documentation/value/1/type", "\"Paragraph\""), + ("/documentation/value/1/value/type", "\"String\""), + ("/documentation/value/1/value/value", "\"Some docs.\"") + ] + + Spec.it s "works with case-insensitive field names" $ do + check + s + """ + {-| + description: hello + LICENSE: BSD3 + -} + module M where + """ + [ ("/documentation/type", "\"DefList\""), + ("/documentation/value/0/term/value", "\"Description\""), + ("/documentation/value/0/definition/value", "\"hello\""), + ("/documentation/value/1/term/value", "\"License\""), + ("/documentation/value/1/definition/value", "\"BSD3\"") + ] + + Spec.it s "works with space before colon" $ do + check + s + """ + {-| + Description : hello + -} + module M where + """ + [ ("/documentation/type", "\"DefList\""), + ("/documentation/value/0/term/value", "\"Description\""), + ("/documentation/value/0/definition/value", "\"hello\"") + ] + + Spec.it s "works with multi-line field values" $ do + check + s + """ + {-| + Copyright: (c) Someone, 2023 + Someone Else, 2024 + License: BSD3 + -} + module M where + """ + [ ("/documentation/type", "\"DefList\""), + ("/documentation/value/0/term/value", "\"Copyright\""), + ("/documentation/value/0/definition/value", "\"(c) Someone, 2023\\n Someone Else, 2024\""), + ("/documentation/value/1/term/value", "\"License\""), + ("/documentation/value/1/definition/value", "\"BSD3\"") ] Spec.describe s "since" $ do