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")
```

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"

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

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)

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"

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

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

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

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

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

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: