FromHaddock.hs

{-# LANGUAGE TemplateHaskellQuotes #-}

-- | Convert Haddock's documentation AST (@DocH@) into Scrod's 'Doc.Doc' type.
--
-- The Haddock parser produces @DocH Void Identifier@ nodes; this module
-- maps each node kind (paragraphs, code blocks, identifiers, hyperlinks,
-- examples, tables, etc.) to the corresponding @Scrod.Core.*@ constructors.
module Scrod.Convert.FromHaddock where

import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text as Text
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
import qualified Scrod.Core.Header as Header
import qualified Scrod.Core.Hyperlink as Hyperlink
import qualified Scrod.Core.Identifier as Identifier
import qualified Scrod.Core.Level as Level
import qualified Scrod.Core.ModLink as ModLink
import qualified Scrod.Core.ModuleName as ModuleName
import qualified Scrod.Core.Namespace as Namespace
import qualified Scrod.Core.NumberedItem as NumberedItem
import qualified Scrod.Core.Picture as Picture
import qualified Scrod.Core.Table as Table
import qualified Scrod.Core.TableCell as TableCell
import qualified Scrod.Spec as Spec

fromHaddock :: Haddock.DocH Void.Void Haddock.Identifier -> Doc.Doc
fromHaddock = groupCollapsible . convertDoc . Haddock.overIdentifier convertIdentifier

convertIdentifier :: Haddock.Namespace -> String -> Maybe Identifier.Identifier
convertIdentifier ns str =
  Just
    Identifier.MkIdentifier
      { Identifier.namespace = convertNamespace ns,
        Identifier.value = stripQualifier $ Text.pack str
      }

-- | Strips the module qualifier from an identifier. For example, @A.b@
-- becomes @b@ and @Data.List.map@ becomes @map@.
stripQualifier :: Text.Text -> Text.Text
stripQualifier t =
  let (_, name) = Text.breakOnEnd (Text.singleton '.') t
   in if Text.null name then t else name

convertNamespace :: Haddock.Namespace -> Maybe Namespace.Namespace
convertNamespace ns = case ns of
  Haddock.Value -> Just Namespace.Value
  Haddock.Type -> Just Namespace.Type
  Haddock.None -> Nothing

convertDoc :: Haddock.DocH Void.Void Identifier.Identifier -> Doc.Doc
convertDoc doc = case doc of
  Haddock.DocEmpty -> Doc.Empty
  Haddock.DocAppend a b -> Doc.Append [convertDoc a, convertDoc b]
  Haddock.DocString s -> Doc.String $ Text.pack s
  Haddock.DocParagraph d -> Doc.Paragraph $ convertDoc d
  Haddock.DocIdentifier i -> Doc.Identifier i
  Haddock.DocModule ml ->
    Doc.Module
      ModLink.MkModLink
        { ModLink.name = ModuleName.MkModuleName . Text.pack $ Haddock.modLinkName ml,
          ModLink.label = convertDoc <$> Haddock.modLinkLabel ml
        }
  Haddock.DocWarning _ -> Doc.Empty -- `DocWarning` is never found in markup.
  Haddock.DocEmphasis d -> Doc.Emphasis $ convertDoc d
  Haddock.DocMonospaced d -> Doc.Monospaced $ convertDoc d
  Haddock.DocBold d -> Doc.Bold $ convertDoc d
  Haddock.DocUnorderedList ds -> Doc.UnorderedList $ fmap convertDoc ds
  Haddock.DocOrderedList items -> Doc.OrderedList $ fmap (\(n, d) -> NumberedItem.MkNumberedItem {NumberedItem.index = n, NumberedItem.item = convertDoc d}) items
  Haddock.DocDefList defs -> Doc.DefList $ fmap (\(t, d) -> Definition.MkDefinition {Definition.term = convertDoc t, Definition.definition = convertDoc d}) defs
  Haddock.DocCodeBlock d -> Doc.CodeBlock $ convertDoc d
  Haddock.DocHyperlink h ->
    Doc.Hyperlink
      Hyperlink.MkHyperlink
        { Hyperlink.url = Text.pack $ Haddock.hyperlinkUrl h,
          Hyperlink.label = convertDoc <$> Haddock.hyperlinkLabel h
        }
  Haddock.DocPic p ->
    Doc.Pic
      Picture.MkPicture
        { Picture.uri = Text.pack $ Haddock.pictureUri p,
          Picture.title = Text.pack <$> Haddock.pictureTitle p
        }
  Haddock.DocMathInline s -> Doc.MathInline $ Text.pack s
  Haddock.DocMathDisplay s -> Doc.MathDisplay $ Text.pack s
  Haddock.DocAName s -> Doc.AName $ Text.pack s
  Haddock.DocProperty s -> Doc.Property $ Text.pack s
  Haddock.DocExamples es ->
    Doc.Examples . NonEmpty.fromList $
      fmap
        ( \e ->
            Example.MkExample
              { Example.expression = Text.pack $ Haddock.exampleExpression e,
                Example.result = Text.pack <$> Haddock.exampleResult e
              }
        )
        es
  Haddock.DocHeader h ->
    Doc.Header
      Header.MkHeader
        { Header.level = Level.fromInt $ Haddock.headerLevel h,
          Header.title = convertDoc $ Haddock.headerTitle h
        }
  Haddock.DocTable t ->
    Doc.Table
      Table.MkTable
        { Table.headerRows = convertTableRow <$> Haddock.tableHeaderRows t,
          Table.bodyRows = convertTableRow <$> Haddock.tableBodyRows t
        }

convertTableRow :: Haddock.TableRow (Haddock.DocH Void.Void Identifier.Identifier) -> [TableCell.Cell Doc.Doc]
convertTableRow = fmap convertTableCell . Haddock.tableRowCells

convertTableCell :: Haddock.TableCell (Haddock.DocH Void.Void Identifier.Identifier) -> TableCell.Cell Doc.Doc
convertTableCell cell =
  TableCell.MkCell
    { TableCell.colspan = fromIntegral $ Haddock.tableCellColspan cell,
      TableCell.rowspan = fromIntegral $ Haddock.tableCellRowspan cell,
      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
    Spec.it s "works with empty" $ do
      Spec.assertEq s (fromHaddock Haddock.DocEmpty) Doc.Empty

    Spec.it s "works with append" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocAppend (Haddock.DocString "a") (Haddock.DocString "b")
      let expected = Doc.Append [Doc.String $ Text.pack "a", Doc.String $ Text.pack "b"]
      Spec.assertEq s (fromHaddock input) expected

    Spec.it s "works with string" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocString "hello"
      Spec.assertEq s (fromHaddock input) (Doc.String $ Text.pack "hello")

    Spec.it s "works with paragraph" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocParagraph (Haddock.DocString "text")
      let expected = Doc.Paragraph (Doc.String $ Text.pack "text")
      Spec.assertEq s (fromHaddock input) expected

    Spec.it s "works with identifier" $ do
      Spec.assertEq s (fromHaddock . Haddock._doc $ Haddock.parseParas Nothing "'x'") . Doc.Paragraph . Doc.Identifier . Identifier.MkIdentifier Nothing $ Text.pack "x"

    Spec.it s "works with value identifier" $ do
      Spec.assertEq s (fromHaddock . Haddock._doc $ Haddock.parseParas Nothing "v'y'") . Doc.Paragraph . Doc.Identifier . Identifier.MkIdentifier (Just Namespace.Value) $ Text.pack "y"

    Spec.it s "works with type identifier" $ do
      Spec.assertEq s (fromHaddock . Haddock._doc $ Haddock.parseParas Nothing "t'z'") . Doc.Paragraph . Doc.Identifier . Identifier.MkIdentifier (Just Namespace.Type) $ Text.pack "z"

    Spec.it s "strips module qualifier from identifier" $ do
      Spec.assertEq s (fromHaddock . Haddock._doc $ Haddock.parseParas Nothing "'A.b'") . Doc.Paragraph . Doc.Identifier . Identifier.MkIdentifier Nothing $ Text.pack "b"

    Spec.it s "strips deep module qualifier from identifier" $ do
      Spec.assertEq s (fromHaddock . Haddock._doc $ Haddock.parseParas Nothing "'Data.List.map'") . Doc.Paragraph . Doc.Identifier . Identifier.MkIdentifier Nothing $ Text.pack "map"

    Spec.it s "works with module" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocModule Haddock.ModLink {Haddock.modLinkName = "Data.List", Haddock.modLinkLabel = Nothing}
      let expected = Doc.Module ModLink.MkModLink {ModLink.name = ModuleName.MkModuleName $ Text.pack "Data.List", ModLink.label = Nothing}
      Spec.assertEq s (fromHaddock input) expected

    Spec.it s "works with emphasis" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocEmphasis (Haddock.DocString "em")
      let expected = Doc.Emphasis (Doc.String $ Text.pack "em")
      Spec.assertEq s (fromHaddock input) expected

    Spec.it s "works with monospaced" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocMonospaced (Haddock.DocString "code")
      let expected = Doc.Monospaced (Doc.String $ Text.pack "code")
      Spec.assertEq s (fromHaddock input) expected

    Spec.it s "works with bold" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocBold (Haddock.DocString "strong")
      let expected = Doc.Bold (Doc.String $ Text.pack "strong")
      Spec.assertEq s (fromHaddock input) expected

    Spec.it s "works with unordered list" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocUnorderedList [Haddock.DocString "item1", Haddock.DocString "item2"]
      let expected = Doc.UnorderedList [Doc.String $ Text.pack "item1", Doc.String $ Text.pack "item2"]
      Spec.assertEq s (fromHaddock input) expected

    Spec.it s "works with ordered list" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocOrderedList [(1, Haddock.DocString "first"), (2, Haddock.DocString "second")]
      let expected =
            Doc.OrderedList
              [ NumberedItem.MkNumberedItem {NumberedItem.index = 1, NumberedItem.item = Doc.String $ Text.pack "first"},
                NumberedItem.MkNumberedItem {NumberedItem.index = 2, NumberedItem.item = Doc.String $ Text.pack "second"}
              ]
      Spec.assertEq s (fromHaddock input) expected

    Spec.it s "works with definition list" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocDefList [(Haddock.DocString "term", Haddock.DocString "def")]
      let expected =
            Doc.DefList
              [Definition.MkDefinition {Definition.term = Doc.String $ Text.pack "term", Definition.definition = Doc.String $ Text.pack "def"}]
      Spec.assertEq s (fromHaddock input) expected

    Spec.it s "works with code block" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocCodeBlock (Haddock.DocString "x = 1")
      let expected = Doc.CodeBlock (Doc.String $ Text.pack "x = 1")
      Spec.assertEq s (fromHaddock input) expected

    Spec.it s "works with hyperlink" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocHyperlink Haddock.Hyperlink {Haddock.hyperlinkUrl = "https://example.com", Haddock.hyperlinkLabel = Nothing}
      let expected = Doc.Hyperlink Hyperlink.MkHyperlink {Hyperlink.url = Text.pack "https://example.com", Hyperlink.label = Nothing}
      Spec.assertEq s (fromHaddock input) expected

    Spec.it s "works with picture" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocPic Haddock.Picture {Haddock.pictureUri = "image.png", Haddock.pictureTitle = Just "title"}
      let expected = Doc.Pic Picture.MkPicture {Picture.uri = Text.pack "image.png", Picture.title = Just $ Text.pack "title"}
      Spec.assertEq s (fromHaddock input) expected

    Spec.it s "works with math inline" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocMathInline "x^2"
      Spec.assertEq s (fromHaddock input) (Doc.MathInline $ Text.pack "x^2")

    Spec.it s "works with math display" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocMathDisplay "\\sum"
      Spec.assertEq s (fromHaddock input) (Doc.MathDisplay $ Text.pack "\\sum")

    Spec.it s "works with anchor name" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocAName "anchor"
      Spec.assertEq s (fromHaddock input) (Doc.AName $ Text.pack "anchor")

    Spec.it s "works with property" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocProperty "prop> x + y"
      Spec.assertEq s (fromHaddock input) (Doc.Property $ Text.pack "prop> x + y")

    Spec.it s "works with examples" $ do
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocExamples [Haddock.Example {Haddock.exampleExpression = "1 + 1", Haddock.exampleResult = ["2"]}]
      let expected = Doc.Examples (Example.MkExample {Example.expression = Text.pack "1 + 1", Example.result = [Text.pack "2"]} NonEmpty.:| [])
      Spec.assertEq s (fromHaddock input) expected

    Spec.it s "works with header" $ do
      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
      let cell :: Haddock.TableCell (Haddock.DocH Void.Void Haddock.Identifier)
          cell = Haddock.TableCell {Haddock.tableCellColspan = 1, Haddock.tableCellRowspan = 1, Haddock.tableCellContents = Haddock.DocString "data"}
      let row :: Haddock.TableRow (Haddock.DocH Void.Void Haddock.Identifier)
          row = Haddock.TableRow [cell]
      let input :: Haddock.DocH Void.Void Haddock.Identifier
          input = Haddock.DocTable Haddock.Table {Haddock.tableHeaderRows = [], Haddock.tableBodyRows = [row]}
      let expectedCell = TableCell.MkCell {TableCell.colspan = 1, TableCell.rowspan = 1, TableCell.contents = Doc.String $ Text.pack "data"}
      let expected = Doc.Table Table.MkTable {Table.headerRows = [], Table.bodyRows = [[expectedCell]]}
      Spec.assertEq s (fromHaddock input) expected