scrod 1.0.0.0 → 1.1.0.0

raw patch · 8 files changed

+385/−3 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• scrod.cabal +2/−1
• source/library/Scrod/Convert/FromGhc.hs +1/−1
• source/library/Scrod/Convert/FromGhc/Doc.hs +93/−0
• source/library/Scrod/Convert/FromHaddock.hs +71/−1
• source/library/Scrod/Convert/ToHtml.hs +25/−0
• source/library/Scrod/Core/Collapsible.hs +19/−0
• source/library/Scrod/Core/Doc.hs +2/−0
• source/library/Scrod/TestSuite/Integration.hs +172/−0

@@ -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

@@ -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 ::

@@ -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. --

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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