Add flags for the markdown and html backend: --strip-prefix and --ext. (#2681)

This PR adds some flags to tune the (html/md) output. For Markdown subcommand: ``` --strip-prefix ARG Strip the given prefix from the input file path for HTML hyperlinks --folder-structure Generate HTML following the module's folder structure ``` For HTML subcommand, we have the ones above plus the following: ``` --ext ARG File extension in hyperlinks for the input file (default: ".html") ```
2025-01-05 22:46:08 +03:00 · 2024-03-09 18:42:09 +01:00 · 2024-03-09 18:42:09 +01:00 · ff853b51ba
commit ff853b51ba
parent a866742872
10 changed files with 133 additions and 18 deletions
--- a/app/Commands/Html.hs
+++ b/app/Commands/Html.hs
@ -29,6 +29,9 @@ runGenOnlySourceHtml HtmlOptions {..} = do
          _genSourceHtmlArgsUrlPrefix = _htmlUrlPrefix,
          _genSourceHtmlArgsIdPrefix = _htmlIdPrefix,
          _genSourceHtmlArgsNoPath = _htmlNoPath,
+          _genSourceHtmlArgsFolderStructure = _htmlFolderStructure,
+          _genSourceHtmlArgsExt = _htmlExt,
+          _genSourceHtmlArgsStripPrefix = _htmlStripPrefix,
          _genSourceHtmlArgsConcreteOpts = Concrete.defaultOptions,
          _genSourceHtmlArgsModule = m,
          _genSourceHtmlArgsComments = Scoper.getScoperResultComments res,
@ -69,7 +72,10 @@ runCommand HtmlOptions {..}
            _judocArgsTheme = _htmlTheme,
            _judocArgsNonRecursive = _htmlNonRecursive,
            _judocArgsNoFooter = _htmlNoFooter,
-            _judocArgsNoPath = _htmlNoPath
+            _judocArgsNoPath = _htmlNoPath,
+            _judocArgsExt = _htmlExt,
+            _judocArgsStripPrefix = _htmlStripPrefix,
+            _judocArgsFolderStructure = _htmlFolderStructure
          }
      when _htmlOpen $ case openCmd of
        Nothing -> say "Could not recognize the 'open' command for your OS"
--- a/app/Commands/Html/Options.hs
+++ b/app/Commands/Html/Options.hs
@ -12,7 +12,10 @@ data HtmlOptions = HtmlOptions
    _htmlOutputDir :: AppPath Dir,
    _htmlInputFile :: AppPath File,
    _htmlNoFooter :: Bool,
+    _htmlFolderStructure :: Bool,
    _htmlNoPath :: Bool,
+    _htmlExt :: Text,
+    _htmlStripPrefix :: Text,
    _htmlAssetsPrefix :: Text,
    _htmlUrlPrefix :: Text,
    _htmlIdPrefix :: Text,
@ -66,6 +69,25 @@ parseHtml = do
      ( long "no-path"
          <> help "Remove the path from all hyperlinks"
      )
+  _htmlExt <-
+    strOption
+      ( value ".html"
+          <> long "ext"
+          <> showDefault
+          <> help "File extension for the generated HTML files"
+      )
+  _htmlStripPrefix <-
+    strOption
+      ( value ""
+          <> long "strip-prefix"
+          <> showDefault
+          <> help "Strip the given prefix from the hyperlinks. This has no effect if --no-path is enabled. It has precedence over --prefix-url"
+      )
+  _htmlFolderStructure <-
+    switch
+      ( long "folder-structure"
+          <> help "Generate HTML following the module's folder structure"
+      )
  _htmlAssetsPrefix <-
    strOption
      ( value ""
--- a/app/Commands/Markdown.hs
+++ b/app/Commands/Markdown.hs
@ -29,9 +29,15 @@ runCommand opts = do
                opts ^. markdownIdPrefix,
              _processJuvixBlocksArgsNoPath =
                opts ^. markdownNoPath,
+              _processJuvixBlocksArgsExt =
+                opts ^. markdownExt,
+              _processJuvixBlocksArgsStripPrefix =
+                opts ^. markdownStripPrefix,
              _processJuvixBlocksArgsComments = Scoper.getScoperResultComments scopedM,
              _processJuvixBlocksArgsModule = m,
-              _processJuvixBlocksArgsOutputDir = outputDir
+              _processJuvixBlocksArgsOutputDir = outputDir,
+              _processJuvixBlocksArgsFolderStructure =
+                opts ^. markdownFolderStructure
            }
  case res of
    Left err -> exitJuvixError (JuvixError err)
--- a/app/Commands/Markdown/Options.hs
+++ b/app/Commands/Markdown/Options.hs
@ -8,6 +8,9 @@ data MarkdownOptions = MarkdownOptions
    _markdownUrlPrefix :: Text,
    _markdownIdPrefix :: Text,
    _markdownNoPath :: Bool,
+    _markdownExt :: Text,
+    _markdownStripPrefix :: Text,
+    _markdownFolderStructure :: Bool,
    _markdownStdout :: Bool,
    _markdownWriteAssets :: Bool
  }
@ -43,6 +46,26 @@ parseJuvixMarkdown = do
      ( long "no-path"
          <> help "Do not include the path to the input file in the HTML id hyperlinks"
      )
+  _markdownExt <-
+    strOption
+      ( value ".html"
+          <> long
+            "suffix-path"
+          <> showDefault
+          <> help "File extension for the generated HTML files. Also used for the suffix of the path to the input file in the HTML id hyperlinks"
+      )
+  _markdownFolderStructure <-
+    switch
+      ( long "folder-structure"
+          <> help "Generate HTML following the module's folder structure"
+      )
+  _markdownStripPrefix <-
+    strOption
+      ( value ""
+          <> long "strip-prefix"
+          <> showDefault
+          <> help "Strip the given prefix from the hyperlinks. This has no effect if --no-path is enabled. It has precedence over --prefix-url"
+      )
  _markdownWriteAssets <-
    switch
      ( long "write-assets"
--- a/src/Juvix/Compiler/Backend/Html/Data/Options.hs
+++ b/src/Juvix/Compiler/Backend/Html/Data/Options.hs
@ -10,10 +10,13 @@ data HtmlOptions = HtmlOptions
    _htmlOptionsIdPrefix :: Text,
    _htmlOptionsOnlyCode :: Bool,
    _htmlOptionsNoPath :: Bool,
+    _htmlOptionsExt :: Text,
+    _htmlOptionsStripPrefix :: Text,
    _htmlOptionsOutputDir :: Path Abs Dir,
    _htmlOptionsParamBase :: Text,
    _htmlOptionsTheme :: Theme,
-    _htmlOptionsNoFooter :: Bool
+    _htmlOptionsNoFooter :: Bool,
+    _htmlOptionsFolderStructure :: Bool
  }

 defaultHtmlOptions :: HtmlOptions
@ -24,11 +27,14 @@ defaultHtmlOptions =
      _htmlOptionsUrlPrefix = "",
      _htmlOptionsIdPrefix = "",
      _htmlOptionsOnlyCode = False,
+      _htmlOptionsExt = ".html",
+      _htmlOptionsStripPrefix = "",
      _htmlOptionsNoPath = False,
      _htmlOptionsOutputDir = $(mkAbsDir "/tmp"),
      _htmlOptionsParamBase = "",
      _htmlOptionsTheme = Nord,
-      _htmlOptionsNoFooter = False
+      _htmlOptionsNoFooter = False,
+      _htmlOptionsFolderStructure = False
    }

 data Theme
--- a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs
+++ b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs
@ -44,7 +44,10 @@ data JudocArgs = JudocArgs
    _judocArgsNonRecursive :: Bool,
    _judocArgsNoFooter :: Bool,
    _judocArgsIdPrefix :: Text,
-    _judocArgsNoPath :: Bool
+    _judocArgsNoPath :: Bool,
+    _judocArgsExt :: Text,
+    _judocArgsStripPrefix :: Text,
+    _judocArgsFolderStructure :: Bool
  }

 makeLenses ''JudocCtx
@ -204,7 +207,10 @@ genJudocHtml entry JudocArgs {..} =
          _htmlOptionsTheme = _judocArgsTheme,
          _htmlOptionsNoFooter = _judocArgsNoFooter,
          _htmlOptionsOnlyCode = False,
-          _htmlOptionsNoPath = _judocArgsNoPath
+          _htmlOptionsNoPath = _judocArgsNoPath,
+          _htmlOptionsExt = _judocArgsExt,
+          _htmlOptionsStripPrefix = _judocArgsStripPrefix,
+          _htmlOptionsFolderStructure = _judocArgsFolderStructure
        }

    allModules
@ -322,7 +328,7 @@ goTopModule cs m = do
            $ ul
              ! Attr.id "page-menu"
              ! Attr.class_ "links"
-            $ li (a ! Attr.href sourceRef' $ "Source") -- TODO: review here
+            $ li (a ! Attr.href sourceRef' $ "Source")
              <> li (a ! Attr.href (fromString (toFilePath indexFileName)) $ "Index")

        content :: Sem s Html
--- a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs
+++ b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs
@ -55,6 +55,9 @@ data GenSourceHtmlArgs = GenSourceHtmlArgs
    _genSourceHtmlArgsNonRecursive :: Bool,
    _genSourceHtmlArgsNoFooter :: Bool,
    _genSourceHtmlArgsNoPath :: Bool,
+    _genSourceHtmlArgsExt :: Text,
+    _genSourceHtmlArgsStripPrefix :: Text,
+    _genSourceHtmlArgsFolderStructure :: Bool,
    _genSourceHtmlArgsComments :: Comments,
    _genSourceHtmlArgsTheme :: Theme
  }
@ -99,7 +102,10 @@ genSourceHtml o@GenSourceHtmlArgs {..} = do
          _htmlOptionsParamBase = o ^. genSourceHtmlArgsParamBase,
          _htmlOptionsTheme = o ^. genSourceHtmlArgsTheme,
          _htmlOptionsNoFooter = o ^. genSourceHtmlArgsNoFooter,
-          _htmlOptionsNoPath = o ^. genSourceHtmlArgsNoPath
+          _htmlOptionsNoPath = o ^. genSourceHtmlArgsNoPath,
+          _htmlOptionsExt = o ^. genSourceHtmlArgsExt,
+          _htmlOptionsStripPrefix = o ^. genSourceHtmlArgsStripPrefix,
+          _htmlOptionsFolderStructure = False
        }

    entry = o ^. genSourceHtmlArgsModule
@ -108,20 +114,20 @@ genSourceHtml o@GenSourceHtmlArgs {..} = do
      | _genSourceHtmlArgsNonRecursive = pure entry
      | otherwise = toList topModules

-    -- TODO: top modules
    topModules :: HashMap NameId (Module 'Scoped 'ModuleTop)
    topModules = HashMap.fromList [(entry ^. modulePath . S.nameId, entry)]

    outputModule :: Module 'Scoped 'ModuleTop -> IO ()
    outputModule m = do
-      ensureDir (parent htmlFile)
-      let absPath = (htmlOptions ^. htmlOptionsOutputDir) <//> htmlFile
+      ensureDir (parent outputFile)
+      let absPath = (htmlOptions ^. htmlOptionsOutputDir) <//> outputFile
      putStrLn $ "Writing " <> pack (toFilePath absPath)
      utc <- getCurrentTime
      Text.writeFile
-        (toFilePath htmlFile)
-        ( run . runReader htmlOptions $
-            genModuleText
+        (toFilePath outputFile)
+        ( run
+            . runReader htmlOptions
+            $ genModuleText
              GenModuleTextArgs
                { _genModuleTextArgsConcreteOpts = o ^. genSourceHtmlArgsConcreteOpts,
                  _genModuleTextArgsUTC = utc,
@ -130,8 +136,10 @@ genSourceHtml o@GenSourceHtmlArgs {..} = do
                }
        )
      where
-        htmlFile :: Path Rel File
-        htmlFile = relFile (topModulePathToDottedPath (m ^. modulePath . S.nameConcrete) <.> ".html")
+        ext = Text.unpack (htmlOptions ^. htmlOptionsExt)
+
+        outputFile :: Path Rel File
+        outputFile = relFile (topModulePathToDottedPath (m ^. modulePath . S.nameConcrete) <.> ext)

 genModuleText ::
  forall r.
@ -353,7 +361,22 @@ nameIdAttr nid = do
 moduleDocRelativePath :: (Members '[Reader HtmlOptions] r) => TopModulePath -> Sem r (Path Rel File)
 moduleDocRelativePath m = do
  suff <- kindSuffix <$> asks (^. htmlOptionsKind)
-  return (topModulePathToRelativePathDot ".html" suff m)
+  ext <- Text.unpack <$> asks (^. htmlOptionsExt)
+  fixPrefix <- Text.unpack <$> asks (^. htmlOptionsStripPrefix)
+  folderStructure <- asks (^. htmlOptionsFolderStructure)
+  let pathgen :: TopModulePath -> Path Rel File
+      pathgen
+        | folderStructure = topModulePathToRelativePath ext suff (</>)
+        | otherwise = topModulePathToRelativePathDot ext suff
+  let relpath :: Path Rel File = pathgen m
+  if
+      | null fixPrefix -> return relpath
+      | otherwise -> do
+          return $
+            maybe
+              relpath
+              id
+              (stripProperPrefix (fromJust (parseRelDir fixPrefix)) relpath)

 nameIdAttrRef :: (Members '[Reader HtmlOptions] r) => TopModulePath -> Maybe S.NameId -> Sem r AttributeValue
 nameIdAttrRef tp s = do
--- a/src/Juvix/Compiler/Backend/Markdown/Translation/FromTyped/Source.hs
+++ b/src/Juvix/Compiler/Backend/Markdown/Translation/FromTyped/Source.hs
@ -20,6 +20,9 @@ data ProcessJuvixBlocksArgs = ProcessJuvixBlocksArgs
    _processJuvixBlocksArgsUrlPrefix :: Text,
    _processJuvixBlocksArgsIdPrefix :: Text,
    _processJuvixBlocksArgsNoPath :: Bool,
+    _processJuvixBlocksArgsExt :: Text,
+    _processJuvixBlocksArgsStripPrefix :: Text,
+    _processJuvixBlocksArgsFolderStructure :: Bool,
    _processJuvixBlocksArgsComments :: Comments,
    _processJuvixBlocksArgsOutputDir :: Path Abs Dir,
    _processJuvixBlocksArgsModule :: Concrete.Module 'Concrete.Scoped 'Concrete.ModuleTop
@ -51,7 +54,10 @@ fromJuvixMarkdown opts = do
            HtmlRender._htmlOptionsUrlPrefix = opts ^. processJuvixBlocksArgsUrlPrefix,
            HtmlRender._htmlOptionsIdPrefix = opts ^. processJuvixBlocksArgsIdPrefix,
            HtmlRender._htmlOptionsNoPath = opts ^. processJuvixBlocksArgsNoPath,
-            HtmlRender._htmlOptionsOutputDir = opts ^. processJuvixBlocksArgsOutputDir
+            HtmlRender._htmlOptionsExt = opts ^. processJuvixBlocksArgsExt,
+            HtmlRender._htmlOptionsStripPrefix = opts ^. processJuvixBlocksArgsStripPrefix,
+            HtmlRender._htmlOptionsOutputDir = opts ^. processJuvixBlocksArgsOutputDir,
+            HtmlRender._htmlOptionsFolderStructure = opts ^. processJuvixBlocksArgsFolderStructure
          }

      m :: Concrete.Module 'Concrete.Scoped 'Concrete.ModuleTop
--- a/test/BackendMarkdown/Positive.hs
+++ b/test/BackendMarkdown/Positive.hs
@ -43,8 +43,11 @@ testDescr PosTest {..} =
                  _processJuvixBlocksArgsUrlPrefix = _UrlPrefix,
                  _processJuvixBlocksArgsIdPrefix = _IdPrefix,
                  _processJuvixBlocksArgsNoPath = _NoPath,
+                  _processJuvixBlocksArgsExt = ".html",
+                  _processJuvixBlocksArgsStripPrefix = "",
                  _processJuvixBlocksArgsComments =
                    Scoper.getScoperResultComments _pipelineResult,
+                  _processJuvixBlocksArgsFolderStructure = False,
                  _processJuvixBlocksArgsModule = m,
                  _processJuvixBlocksArgsOutputDir =
                    root <//> $(mkRelDir "markdown")
--- a/tests/smoke/Commands/html.smoke.yaml
+++ b/tests/smoke/Commands/html.smoke.yaml
@ -26,6 +26,20 @@ tests:
      contains:
        <!DOCTYPE HTML>
    exit-status: 0
+    
+  - name: html-ext
+    command:
+      shell:
+        - bash
+      script: |
+        cd milestone/HelloWorld
+        rm -rf html
+        juvix html HelloWorld.juvix --only-source --ext=md
+        cat html/HelloWorld.md
+    stdout:
+      contains:
+        <!DOCTYPE HTML>
+    exit-status: 0

  - name: output-dir
    command: