damldocs: Backend for rendering docs to multiple pages. (digital-asse…

…t#2259) * Begin multi-page rendering * Fixed multi-file output rendering for HTML * Remove renderSimpleHtml * Remove unnecessary imports * Remove unused lang extensions * Address reviewer comments
TuranDev · Jul 23, 2019 · d0dd201 · d0dd201
1 parent d306814
commit d0dd201
Show file tree

Hide file tree

Showing 9 changed files with 227 additions and 59 deletions.
diff --git a/compiler/damlc/BUILD.bazel b/compiler/damlc/BUILD.bazel
@@ -266,6 +266,26 @@ genrule(
     visibility = ["//visibility:public"],
 )
 
+genrule(
+    name = "daml-base-html-docs",
+    srcs = [
+        ":daml-prim.json",
+        ":daml-stdlib.json",
+        ":daml-base-md-prefix",
+    ],
+    outs = ["daml-base-html.tar.gz"],
+    cmd = """
+        $(location //compiler/damlc) -- docs \
+            --output=daml-base-html \
+            --input-format=json \
+            --format=Html \
+            $(location :daml-stdlib.json) $(location :daml-prim.json)
+        tar czf $(OUTS) daml-base-html
+    """,
+    tools = ["//compiler/damlc"],
+    visibility = ["//visibility:public"],
+)
+
 daml_doc_test(
     name = "daml-stdlib-doctest",
     srcs = ["//compiler/damlc/daml-stdlib-src"],

diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Driver.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Driver.hs
@@ -72,11 +72,14 @@ damlDocDriver cInputFormat ideOpts output cFormat prefixFile options files = do
 
     case cFormat of
             Json -> write output $ T.decodeUtf8 . BS.toStrict $ AP.encodePretty' jsonConf docData
-            Rst  -> write output . renderFinish . mconcat $ map renderSimpleRst docData
+            Rst  -> write output . renderPage . mconcat $ map renderSimpleRst docData
             Hoogle   -> write output . T.concat $ map renderSimpleHoogle docData
-            Markdown -> write output . renderFinish . mconcat $ map renderSimpleMD docData
-            Html -> sequence_
-                [ write (output </> hyphenated (unModulename md_name) <> ".html") $ renderSimpleHtml m
-                | m@ModuleDoc{..} <- docData ]
-                    where hyphenated = T.unpack . T.replace "." "-"
-    putStrLn "Done"
+            Markdown -> write output . renderPage . mconcat $ map renderSimpleMD docData
+            Html -> do
+                let renderOptions = RenderOptions
+                        { ro_mode = RenderToFolder output
+                        , ro_format = Html
+                        , ro_title = Nothing
+                        , ro_template = Nothing
+                        }
+                renderDocs renderOptions docData
diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Render.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Render.hs
@@ -5,49 +5,108 @@
 
 module DA.Daml.Doc.Render
   ( DocFormat(..)
-  , renderFinish
+  , RenderOptions(..)
+  , RenderMode(..)
+  , renderDocs
+  , renderPage
   , renderSimpleRst
   , renderSimpleMD
-  , renderSimpleHtml
   , renderSimpleHoogle
   , jsonConf
   ) where
 
+import DA.Daml.Doc.Render.Types
 import DA.Daml.Doc.Render.Monoid
 import DA.Daml.Doc.Render.Rst
 import DA.Daml.Doc.Render.Markdown
 import DA.Daml.Doc.Render.Hoogle
 import DA.Daml.Doc.Types
 
+import Data.Maybe
+import Data.List.Extra
+import Data.Foldable
+import System.Directory
+import System.FilePath
+
 import qualified CMarkGFM as GFM
 import qualified Data.Aeson.Encode.Pretty as AP
 import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
-import qualified Text.Blaze.Html5 as H
-import qualified Text.Blaze.Html.Renderer.Text as H
+import qualified Data.Text.Encoding as T
+import qualified Data.ByteString as BS
+import qualified Data.Map.Strict as Map
 
 
 -- | centralised JSON configuration for pretty-printing
 jsonConf :: AP.Config
 jsonConf = AP.Config (AP.Spaces 2) (AP.keyOrder ["id"]) AP.Generic True
 
+renderDocs :: RenderOptions -> [ModuleDoc] -> IO ()
+renderDocs RenderOptions{..} mods = do
+    let (renderModule, postProcessing) =
+            case ro_format of
+                Json -> (const (renderLine ""), id) -- not implemented (yet?)
+                Hoogle -> (const (renderLine ""), id) -- not implemented (yet?)
+                Rst -> (renderSimpleRst, id)
+                Markdown -> (renderSimpleMD, id)
+                Html -> (renderSimpleMD, GFM.commonmarkToHtml [GFM.optUnsafe] [GFM.extTable])
+        template = fromMaybe (defaultTemplate ro_format) ro_template
+
+    case ro_mode of
+        RenderToFile path -> do
+            BS.writeFile path
+                . T.encodeUtf8
+                . renderTemplate template
+                    (fromMaybe "Package Docs" ro_title)
+                . postProcessing
+                . renderPage
+                $ mconcatMap renderModule mods
+
+        RenderToFolder path -> do
+            let renderMap = Map.fromList
+                    [(md_name mod, renderModule mod) | mod <- mods]
+                outputMap = renderFolder renderMap
+                extension =
+                    case ro_format of
+                        Json -> "json"
+                        Hoogle -> "txt"
+                        Markdown -> "md"
+                        Rst -> "rst"
+                        Html -> "html"
+
+                outputPath mod = path </> moduleNameToFileName mod <.> extension
+                pageTitle mod = T.concat
+                    [ maybe "" (<> " - ") ro_title
+                    , "Module "
+                    , unModulename mod ]
 
--- TODO rendering structures closely resembles each other. Could share code and
--- use a common typeclass if need be (unsure about ROI so far).
+            createDirectoryIfMissing True path
+            for_ (Map.toList outputMap) $ \ (mod, renderedOutput) -> do
+                BS.writeFile (outputPath mod)
+                    . T.encodeUtf8
+                    . renderTemplate template (pageTitle mod)
+                    . postProcessing
+                    $ renderedOutput
 
-data DocFormat = Json | Rst | Markdown | Html | Hoogle
-  deriving (Eq, Show, Read, Enum, Bounded)
 
+renderTemplate ::
+    T.Text -- ^ template
+    -> T.Text -- ^ page title
+    -> T.Text -- ^ page body
+    -> T.Text
+renderTemplate template pageTitle pageBody
+    = T.replace "__BODY__" pageBody
+    . T.replace "__TITLE__" pageTitle
+    $ template
 
--- | Html renderer, using cmark-gfm
-renderSimpleHtml :: ModuleDoc -> T.Text
-renderSimpleHtml m@ModuleDoc{..} =
-  wrapHtml t $ GFM.commonmarkToHtml [] [GFM.extTable] $ renderFinish $ renderSimpleMD m
-  where t = "Module " <> unModulename md_name
+defaultTemplate :: DocFormat -> T.Text
+defaultTemplate = \case
+    Html -> defaultTemplateHtml
+    _ -> "__BODY__"
 
-wrapHtml :: T.Text -> T.Text -> T.Text
-wrapHtml pageTitle body =
-  let html = do
-        H.head (H.title $ H.toHtml pageTitle)
-        H.body $ H.preEscapedToHtml body
-  in TL.toStrict $ H.renderHtml html
+defaultTemplateHtml :: T.Text
+defaultTemplateHtml = T.unlines
+    [ "<html>"
+    , "<head><title>__TITLE__</title><meta charset=\"utf-8\"></head>"
+    , "<body>__BODY__</body>"
+    , "</html>"
+    ]
diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Render/Markdown.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Render/Markdown.hs
@@ -197,9 +197,15 @@ type2md env = f 0
     link :: Maybe Anchor -> Typename -> T.Text
     link Nothing n = escapeMd $ unTypename n
     link (Just anchor) n =
-        if renderAnchorAvailable env anchor
-            then T.concat ["[", escapeMd $ unTypename n, "](#", unAnchor anchor, ")"]
-            else escapeMd $ unTypename n
+        case lookupAnchor env anchor of
+            Nothing -> escapeMd $ unTypename n
+            Just anchorLoc -> T.concat
+                [ "["
+                , escapeMd $ unTypename n
+                , "]("
+                , anchorRelativeHyperlink anchorLoc anchor
+                , ")"
+                ]
 
 fct2md :: FunctionDoc -> RenderOut
 fct2md FunctionDoc{..} = mconcat

diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Render/Monoid.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Render/Monoid.hs
@@ -5,56 +5,103 @@
 
 -- | Monoid with which to render documentation.
 module DA.Daml.Doc.Render.Monoid
-  ( module DA.Daml.Doc.Render.Monoid
-  ) where
+    ( module DA.Daml.Doc.Render.Monoid
+    ) where
 
 import DA.Daml.Doc.Types
+import Control.Monad
+import Data.Foldable
+import System.FilePath
+import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.Text as T
 
 -- | Environment in which to generate final documentation.
-newtype RenderEnv = RenderEnv (Set.Set Anchor)
-    deriving newtype (Semigroup, Monoid)
+data RenderEnv = RenderEnv
+    { lookupAnchor :: Anchor -> Maybe AnchorLocation
+        -- ^ get location of anchor relative to render output, if available
+    }
 
--- | Is the anchor available in the rendering environment? Renderers should avoid
--- generating links to anchors that don't actually exist.
---
--- One reason an anchor may be unavailable is because of a @-- | HIDE@ directive.
--- Another possibly reason is that the anchor refers to a definition in another
--- package (and at the moment it's not possible to link accross packages).
-renderAnchorAvailable :: RenderEnv -> Anchor -> Bool
-renderAnchorAvailable (RenderEnv anchors) anchor = Set.member anchor anchors
+-- | Location of an anchor relative to the output being rendered. An anchor
+-- that lives on the same page may be rendered differently from an anchor
+-- that lives in the same folder but a different page, and that may be
+-- rendered differently from an anchor that is external. Thus we can
+-- handle every case correctly.
+data AnchorLocation
+    = SameFile -- ^ anchor is in same file
+    | SameFolder FilePath -- ^ anchor is in a file within same folder
+    -- TODO: | External URL -- ^ anchor is in on a page at the given URL
+
+-- | Build relative hyperlink from anchor and anchor location.
+anchorRelativeHyperlink :: AnchorLocation -> Anchor -> T.Text
+anchorRelativeHyperlink anchorLoc (Anchor anchor) =
+    case anchorLoc of
+        SameFile -> "#" <> anchor
+        SameFolder fileName -> T.concat [T.pack fileName, "#", anchor]
 
 -- | Renderer output. This is the set of anchors that were generated, and a
--- list of output functions that depend on that set. The goal is to prevent
+-- list of output functions that depend on RenderEnv. The goal is to prevent
 -- the creation of spurious anchors links (i.e. links to anchors that don't
--- exist).
---
--- (In theory this could be done in two steps, but that seems more error prone
--- than building up both steps at the same time, and combining them at the
--- end, as is done here.)
+-- exist), and link correctly any anchors that do appear.
 --
 -- Using a newtype here so we can derive the semigroup / monoid instances we
 -- want automatically. :-)
-newtype RenderOut = RenderOut (RenderEnv, [RenderEnv -> [T.Text]])
+newtype RenderOut = RenderOut (Set.Set Anchor, [RenderEnv -> [T.Text]])
     deriving newtype (Semigroup, Monoid)
 
-renderFinish :: RenderOut -> T.Text
-renderFinish (RenderOut (xs, fs)) = T.unlines (concatMap ($ xs) fs)
+-- | Render a single page doc. Any links to anchors not appearing on the
+-- single page will be dropped.
+renderPage :: RenderOut -> T.Text
+renderPage (RenderOut (localAnchors, renderFns)) =
+    T.unlines (concatMap ($ renderEnv) renderFns)
+  where
+    lookupAnchor :: Anchor -> Maybe AnchorLocation
+    lookupAnchor anchor
+        | Set.member anchor localAnchors = Just SameFile
+        | otherwise = Nothing
+    renderEnv = RenderEnv {..}
+
+-- | Render a folder of modules.
+renderFolder :: Map.Map Modulename RenderOut -> Map.Map Modulename T.Text
+renderFolder fileMap =
+    let globalAnchors = Map.fromList
+            [ (anchor, moduleNameToFileName moduleName <.> "html")
+            | (moduleName, RenderOut (anchors, _)) <- Map.toList fileMap
+            , anchor <- Set.toList anchors
+            ]
+    in flip Map.map fileMap $ \(RenderOut (localAnchors, renderFns)) ->
+        let lookupAnchor anchor = asum
+                [ SameFile <$ guard (Set.member anchor localAnchors)
+                , SameFolder <$> Map.lookup anchor globalAnchors
+                ]
+            renderEnv = RenderEnv {..}
+        in T.unlines (concatMap ($ renderEnv) renderFns)
+
+moduleNameToFileName :: Modulename -> FilePath
+moduleNameToFileName = T.unpack . T.replace "." "-" . unModulename
 
 -- | Declare an anchor for the purposes of rendering output.
 renderDeclareAnchor :: Anchor -> RenderOut
-renderDeclareAnchor anchor = RenderOut (RenderEnv $ Set.singleton anchor, [])
+renderDeclareAnchor anchor = RenderOut (Set.singleton anchor, [])
 
+-- | Render a single line of text. A newline is automatically
+-- added at the end of the line.
 renderLine :: T.Text -> RenderOut
 renderLine l = renderLines [l]
 
+-- | Render multiple lines of text. A newline is automatically
+-- added at the end of every line, including the last one.
 renderLines :: [T.Text] -> RenderOut
 renderLines ls = renderLinesDep (const ls)
 
+-- | Render a single line of text that depends on the rendering environment.
+-- A newline is automatically added at the end of the line.
 renderLineDep :: (RenderEnv -> T.Text) -> RenderOut
 renderLineDep f = renderLinesDep (pure . f)
 
+-- | Render multiple lines of text that depend on the rendering environment.
+-- A newline is automatically added at the end of every line, including the
+-- last one.
 renderLinesDep :: (RenderEnv -> [T.Text]) -> RenderOut
 renderLinesDep f = RenderOut (mempty, [f])
 

diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Render/Rst.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Render/Rst.hs
@@ -209,9 +209,16 @@ type2rst env = f 0
     link :: Maybe Anchor -> Typename -> T.Text
     link Nothing n = unTypename n
     link (Just anchor) n =
-        if renderAnchorAvailable env anchor
-            then T.concat ["`", unTypename n, " <", unAnchor anchor, "_>`_"]
-            else unTypename n
+        case lookupAnchor env anchor of
+            Nothing -> unTypename n
+            Just SameFile ->
+                T.concat ["`", unTypename n, " <", unAnchor anchor, "_>`_"]
+                -- local indirect link
+            Just (SameFolder _) ->
+                T.concat ["`", unTypename n, " <", unAnchor anchor, "_>`_"]
+                -- surprisingly this still works in Rst, and has the advantage of
+                -- letting Sphinx be a second line of defense against spurious
+                -- links, over generating an external link here.
 
 fct2rst :: FunctionDoc -> RenderOut
 fct2rst FunctionDoc{..} = mconcat

diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Render/Types.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Render/Types.hs
@@ -0,0 +1,26 @@
+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+-- | Types common to DA.Daml.Doc.Render
+module DA.Daml.Doc.Render.Types
+    ( module DA.Daml.Doc.Render.Types
+    ) where
+
+import qualified Data.Text as T
+
+data DocFormat = Json | Rst | Markdown | Html | Hoogle
+    deriving (Eq, Show, Read, Enum, Bounded)
+
+-- | Control whether to render docs as a single file, or as
+-- an interlinked folder of many files, one per DAML module.
+data RenderMode
+    = RenderToFile FilePath -- ^ render to single file
+    | RenderToFolder FilePath -- ^ render to folder, one file per module
+
+-- | Options that affect rendering.
+data RenderOptions = RenderOptions
+    { ro_mode :: RenderMode -- ^ control single file / multi file rendering
+    , ro_format :: DocFormat -- ^ renderer output format
+    , ro_title :: Maybe T.Text -- ^ title of rendered documentation
+    , ro_template :: Maybe T.Text -- ^ renderer template
+    }
diff --git a/compiler/damlc/daml-doc/test/DA/Daml/GHC/Damldoc/Render/Tests.hs b/compiler/damlc/daml-doc/test/DA/Daml/GHC/Damldoc/Render/Tests.hs
@@ -258,8 +258,8 @@ renderTest format (name, input) expected =
   let
     renderer = case format of
                  Json -> error "Json encoder testing not done here"
-                 Rst -> renderFinish . renderSimpleRst
-                 Markdown -> renderFinish . renderSimpleMD
+                 Rst -> renderPage . renderSimpleRst
+                 Markdown -> renderPage . renderSimpleMD
                  Html -> error "HTML testing not supported (use Markdown)"
                  Hoogle -> error "Hoogle doc testing not yet supported."
     output = T.strip $ renderer input

diff --git a/compiler/damlc/daml-doc/test/DA/Daml/GHC/Damldoc/Tests.hs b/compiler/damlc/daml-doc/test/DA/Daml/GHC/Damldoc/Tests.hs
@@ -284,8 +284,8 @@ fileTest damlFile = do
                 let extension = takeExtension expectation
                 ref <- T.readFileUtf8 expectation
                 case extension of
-                  ".rst"  -> expectEqual extension ref $ renderFinish $ renderSimpleRst docs
-                  ".md"   -> expectEqual extension ref $ renderFinish $ renderSimpleMD docs
+                  ".rst"  -> expectEqual extension ref $ renderPage $ renderSimpleRst docs
+                  ".md"   -> expectEqual extension ref $ renderPage $ renderSimpleMD docs
                   ".json" -> expectEqual extension ref
                              (T.decodeUtf8 . BS.toStrict $
                                AP.encodePretty' jsonConf docs)