Add minijuvix version info and date to HTML output (#186)

* Add minijuvix version info and date to HTML output

* Fix pre-commit

app/Commands/Html.hs

@@ -7,7 +7,8 @@ import Options.Applicative
 data HtmlOptions = HtmlOptions
   { _htmlRecursive :: Bool,
     _htmlTheme :: Theme,
-    _htmlOutputDir :: FilePath
+    _htmlOutputDir :: FilePath,
+    _htmlPrintMetadata :: Bool
   }
 
 makeLenses ''HtmlOptions
@@ -38,6 +39,11 @@ parseHtml = do
           <> help "html output directory"
           <> action "directory"
       )
+  _htmlPrintMetadata <-
+    switch
+      ( long "print-metadata"
+          <> help "Add HTML footer with metadata"
+      )
   pure HtmlOptions {..}
   where
     parseTheme :: String -> Either String Theme

app/Main.hs

@@ -123,7 +123,7 @@ runCommand cmdWithOpts = do
             Html HtmlOptions {..} -> do
               res <- runPipeline (upToScoping entryPoint)
               let m = head (res ^. Scoper.resultModules)
-              embed (genHtml Scoper.defaultOptions _htmlRecursive _htmlTheme _htmlOutputDir m)
+              embed (genHtml Scoper.defaultOptions _htmlRecursive _htmlTheme _htmlOutputDir _htmlPrintMetadata m)
             MicroJuvix Pretty -> do
               micro <-
                 head . (^. Micro.resultModules)

assets/source-ayu-light.css

@@ -46,3 +46,13 @@ a:hover, a.hover-highlight {
 a:link, a:visited {
     text-decoration: none;
 }
+
+footer {
+    color: gray
+}
+
+footer a {
+    color: gray;
+    font-size: small;
+    font-weight: bold;
+}

assets/source-nord.css

@@ -46,3 +46,13 @@ a:link, a:visited {
 a:hover, a.hover-highlight {
   background-color: #4c566a;
 }
+
+footer {
+    color: gray
+}
+
+footer a {
+    color: gray;
+    font-size: small;
+    font-weight: bold;
+}

package.yaml

@@ -44,6 +44,7 @@ dependencies:
 - singletons == 3.0.*
 - singletons-th == 3.1.*
 - Stream == 0.4.*
+- time == 1.11.*
 - template-haskell == 2.18.*
 - text == 1.2.*
 - th-utilities == 0.2.*

src/MiniJuvix/Syntax/Concrete/Scoped/Pretty/Html.hs

@@ -4,14 +4,18 @@ import Data.ByteString qualified as BS
 import Data.Text qualified as Text
 import Data.Text.IO qualified as Text
 import Data.Text.Lazy (toStrict)
+import Data.Time.Clock
+import Data.Time.Format
 import MiniJuvix.Prelude
 import MiniJuvix.Syntax.Concrete.Language
 import MiniJuvix.Syntax.Concrete.Scoped.Name qualified as S
 import MiniJuvix.Syntax.Concrete.Scoped.Pretty.Base
 import MiniJuvix.Syntax.Concrete.Scoped.Utils
 import MiniJuvix.Utils.Paths
+import MiniJuvix.Utils.Version
 import Prettyprinter
 import Prettyprinter.Render.Util.SimpleDocTree
+import Text.Blaze.Html
 import Text.Blaze.Html.Renderer.Text qualified as Html
 import Text.Blaze.Html5 as Html hiding (map)
 import Text.Blaze.Html5.Attributes qualified as Attr
@@ -21,8 +25,8 @@ data Theme
   | Ayu
   deriving stock (Show)
 
-genHtml :: Options -> Bool -> Theme -> FilePath -> Module 'Scoped 'ModuleTop -> IO ()
-genHtml opts recursive theme outputDir entry = do
+genHtml :: Options -> Bool -> Theme -> FilePath -> Bool -> Module 'Scoped 'ModuleTop -> IO ()
+genHtml opts recursive theme outputDir printMetadata entry = do
   createDirectoryIfMissing True outputDir
   copyAssetFiles
   withCurrentDirectory outputDir $ do
@@ -39,6 +43,7 @@ genHtml opts recursive theme outputDir entry = do
       where
         assetFiles :: [(FilePath, BS.ByteString)]
         assetFiles = $(assetsDir)
+
         writeAsset :: (FilePath, BS.ByteString) -> IO ()
         writeAsset (filePath, fileContents) =
           BS.writeFile (toAssetsDir </> takeFileName filePath) fileContents
@@ -48,21 +53,26 @@ genHtml opts recursive theme outputDir entry = do
     outputModule m = do
       createDirectoryIfMissing True (takeDirectory htmlFile)
       putStrLn $ "Writing " <> pack htmlFile
-      Text.writeFile htmlFile (genModule opts theme m)
+      utc <- getCurrentTime
+      Text.writeFile htmlFile (genModule opts printMetadata utc theme m)
       where
         htmlFile = topModulePathToDottedPath (m ^. modulePath . S.nameConcrete) <.> ".html"
 
-genModule :: Options -> Theme -> Module 'Scoped 'ModuleTop -> Text
-genModule opts theme m =
+genModule :: Options -> Bool -> UTCTime -> Theme -> Module 'Scoped 'ModuleTop -> Text
+genModule opts printMetadata utc theme m =
   toStrict $
     Html.renderHtml $
       docTypeHtml ! Attr.xmlns "http://www.w3.org/1999/xhtml" $
         mhead
           <> mbody
+          <> if printMetadata then infoFooter else mempty
   where
+    themeCss :: Html
     themeCss = case theme of
       Ayu -> ayuCss
       Nord -> nordCss
+
+    prettySrc :: Html
     prettySrc =
       (pre ! Attr.id "src-content") $
         renderTree $ treeForm $ docStream' opts m
@@ -77,11 +87,26 @@ genModule opts theme m =
       metaUtf8
         <> themeCss
         <> highlightJs
+
     mbody :: Html
     mbody =
       mheader
         <> prettySrc
 
+    infoFooter :: Html
+    infoFooter =
+      footer . pre $
+        toHtml ("Powered by " :: Text)
+          <> (a ! Attr.href "https://heliaxdev.github.io/minijuvix" $ toHtml ("MiniJuvix CLI " :: Text))
+          <> (a ! Attr.href (textValue commitAddress) $ toHtml versionTag)
+          <> br
+          <> Html.span (toHtml $ ("Last modified on " :: String) <> formattedTime)
+      where
+        commitAddress :: Text
+        commitAddress = "https://github.com/heliaxdev/minijuvix/commit/" <> shortHash
+
+        formattedTime = formatTime defaultTimeLocale "%Y-%m-%d %-H:%M %Z" utc
+
 docStream' :: Options -> Module 'Scoped 'ModuleTop -> SimpleDocStream Ann
 docStream' opts m = layoutPretty defaultLayoutOptions (runPrettyCode opts m)
 

src/MiniJuvix/Utils/Version.hs

@@ -21,33 +21,33 @@ import Prettyprinter as PP
 import Prettyprinter.Render.Text (renderIO)
 import System.Environment (getProgName)
 
-versionDoc :: Doc Text
-versionDoc = PP.pretty (showVersion Paths_minijuvix.version)
+versionDoc :: Text
+versionDoc = pack (showVersion Paths_minijuvix.version)
 
-branch :: Doc Text
-branch = PP.pretty (pack $(gitBranch))
+branch :: Text
+branch = pack $(gitBranch)
 
-commit :: Doc Text
-commit = PP.pretty (pack $(gitHash))
+commit :: Text
+commit = pack $(gitHash)
 
-commitDate :: Doc Text
-commitDate = PP.pretty (pack $(gitCommitDate))
+commitDate :: Text
+commitDate = pack $(gitCommitDate)
 
-shortHash :: Doc Text
-shortHash = PP.pretty (pack (take 7 $(gitHash)))
+shortHash :: Text
+shortHash = pack (take 7 $(gitHash))
 
-versionTag :: Doc Text
+versionTag :: Text
 versionTag = versionDoc <> "-" <> shortHash
 
-progName :: IO (Doc Text)
-progName = PP.pretty . pack . toUpperFirst <$> getProgName
+progName :: IO Text
+progName = pack . toUpperFirst <$> getProgName
 
-progNameVersion :: IO (Doc Text)
+progNameVersion :: IO Text
 progNameVersion = do
   pName <- progName
-  return (pName <+> "version" <+> versionDoc)
+  return (pName <> " version " <> versionDoc)
 
-progNameVersionTag :: IO (Doc Text)
+progNameVersionTag :: IO Text
 progNameVersionTag = do
   progNameV <- progNameVersion
   return (progNameV <> "-" <> shortHash)
@@ -56,15 +56,15 @@ infoVersionRepo :: IO (Doc Text)
 infoVersionRepo = do
   pNameTag <- progNameVersionTag
   return
-    ( pNameTag <> line
+    ( PP.pretty pNameTag <> line
         <> "Branch"
-        <> colon <+> branch
+        <> colon <+> PP.pretty branch
         <> line
         <> "Commit"
-        <> colon <+> commit
+        <> colon <+> PP.pretty commit
         <> line
         <> "Date"
-        <> colon <+> commitDate
+        <> colon <+> PP.pretty commitDate
         <> line
     )