ssg: Update and add comments

site/default.nix

@@ -10,6 +10,6 @@ stdenv.mkDerivation {
     ${ssg}/bin/ssg build
   '';
   installPhase = ''
-    cp -av result $out
+    cp -av _site $out
   '';
 }

ssg/ssg.hs

@@ -1,70 +1,162 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+
 -- Copyright 2023 Gabriel Doriath Döhler, Délégation Générale Numérique (DGNum)
 
-{-# LANGUAGE OverloadedStrings #-}
-
 import Control.Applicative ((<|>))
-import Control.Monad ((<=<), void)
+import Control.Monad (void, (<=<))
-import Data.Monoid (First(..))
 import Data.List (intersperse)
-
+import Data.Monoid (First (..))
-import qualified Text.Blaze.Html5 as H
-import qualified Text.Blaze.Html5.Attributes as A
-import Text.Pandoc.Walk (query, walk)
-import Text.Pandoc.Definition
-  ( Pandoc(..), Block(Header, Para, Plain), Inline(..) )
-import Text.Pandoc.Options ( WriterOptions(..), HTMLMathMethod( MathML ) )
 import Hakyll
+import Text.Blaze.Html.Renderer.String (renderHtml)
+import Text.Blaze.Html5 qualified as H
+import Text.Blaze.Html5.Attributes qualified as A
+import Text.Pandoc.Definition
+  ( Block (Header, Para, Plain),
+    Inline (..),
+    Pandoc (..),
+  )
+import Text.Pandoc.Options (HTMLMathMethod (MathML), WriterOptions (..))
+import Text.Pandoc.Walk (query, walk)
 
 --------------------------------------------------------------------------------
 
 nbPostsHome :: Int
-nbPostsHome = 30
+nbPostsHome = 10
 
 patternFrom :: [String] -> [String] -> Pattern
 patternFrom basenames extensions =
   foldl1 (.||.) $ map aux basenames
   where
     aux basename =
-    foldl1 (.||.) $ map (fromGlob . (++) (basename ++ "/**.")) extensions
+      foldl1 (.||.) $ map (fromGlob . (++) "./**.") extensions
 
 postPattern :: Pattern
-postPattern = patternFrom [ "posts" ] [ "md" ]
+postPattern = fromGlob "posts/**.md"
 
-imgPattern :: Pattern
+filePattern :: Pattern
-imgPattern = patternFrom [ ".", "images" ] [ "png", "jpeg", "jpg", "gif", "svg", "ico" ]
+filePattern =
-
+  patternFrom
-docPattern :: Pattern
+    ["."]
-docPattern = patternFrom [ ".", "docs" ] [ "pdf", "ps", "djvu", "tex", "txt" ]
+    [ "djvu",
-        .||. patternFrom [ "docs" ] [ "md" ]
+      "gif",
-
+      "ico",
-miscPattern :: Pattern
+      "jpeg",
-miscPattern = foldl1 (.||.) [ "about.md", "services.md", "FAQ.md", "contact.md" ]
+      "jpg",
+      "pdf",
+      "png",
+      "ps",
+      "svg",
+      "tex",
+      "txt"
+    ]
 
 --------------------------------------------------------------------------------
 
 main :: IO ()
-main = hakyllWith config $ do
+main = hakyll $ do
-  tags <- extractTags
+  tags <- extractMeta "tags"
-  authors <- extractAuthors
+  authors <- extractMeta "authors"
-  poles <- extractPoles
+  poles <- extractMeta "poles"
 
-  tagsRules tags $ \tagStr tagsPattern -> do
+  -- Static files
-    let title = "Articles appartenant à la catégorie \"" ++ tagStr ++ "\""
+  match ("vendor/**" .||. "images/**" .||. "documents/**" .||. filePattern) $ do
+    route idRoute
+    compile copyFileCompiler
+
+  -- Minified CSS and JS
+  match ("js/*.min.js" .||. "css/*.min.css") $ do
+    route idRoute
+    compile copyFileCompiler
+
+  -- Regular CSS
+  match "css/*.css" $ do
+    route idRoute
+    compile compressCssCompiler
+
+  -- Index page
+  match "index.html" $ do
     route idRoute
     compile $ do
-      posts <- loadAll tagsPattern >>= recentFirst
+      allPosts <- recentFirst =<< loadAll ("posts/**.md" .&&. hasNoVersion)
+      let posts = take nbPostsHome allPosts
       let ctx =
-            constField "title" title
+            listField "posts" postCtx (return posts)
-              <> listField "posts" postCtx (return posts)
               <> context
 
-      makeItem ""
+      getResourceBody
-        >>= loadAndApplyTemplate "templates/tag.html"     ctx
+        >>= applyAsTemplate ctx
         >>= loadAndApplyTemplate "templates/default.html" ctx
         >>= relativizeUrls
 
+  -- Regular pages
+  match "about.html" $ do
+    route idRoute
+    compile $ do
+      getResourceBody
+        >>= applyAsTemplate context
+        >>= loadAndApplyTemplate "templates/default.html" context
+        >>= relativizeUrls
+
+  match ("faq.md" .||. "services.md" .||. "contact.md") $ do
+    route $ setExtension "html"
+    compile $
+      customPandocCompiler
+        >>= loadAndApplyTemplate "templates/default.html" (postCtxWith tags authors poles)
+        >>= relativizeUrls
+
+  -- Archives (i.e. list of all posts)
+  match "archives.html" $ do
+    route idRoute
+    compile $ do
+      allPosts <- recentFirst =<< loadAll ("posts/**.md" .&&. hasNoVersion)
+      let ctx =
+            listField "posts" postCtx (return allPosts)
+              <> context
+
+      getResourceBody
+        >>= applyAsTemplate ctx
+        >>= loadAndApplyTemplate "templates/default.html" ctx
+        >>= relativizeUrls
+
+  -- Invidual posts
+  match "posts/**.md" $ do
+    route $ setExtension "html"
+    compile $
+      customPandocCompiler
+        >>= loadAndApplyTemplate "templates/post.html" (postCtxWith tags authors poles)
+        >>= loadAndApplyTemplate "templates/default.html" (postCtxWith tags authors poles)
+        >>= relativizeUrls
+
+  -- Divisions
+  tagsRules poles $ \_ polesPattern -> do
+    route idRoute
+    compile $ do
+      posts <- loadAll polesPattern >>= recentFirst
+      let ctx =
+            listField "posts" postCtx (return posts)
+              <> context
+
+      getResourceBody
+        >>= applyAsTemplate ctx
+        >>= loadAndApplyTemplate "templates/division.html" ctx
+        >>= loadAndApplyTemplate "templates/default.html" ctx
+        >>= relativizeUrls
+
+  match "poles/*.html" $ do
+    route idRoute
+    compile $ do
+      getResourceBody
+        >>= applyAsTemplate context
+        >>= loadAndApplyTemplate "templates/division.html" context
+        >>= loadAndApplyTemplate "templates/default.html" context
+        >>= relativizeUrls
+
+  -- Authors
   tagsRules authors $ \authorStr authorsPattern -> do
-    let title = "Articles (co-)écrit par \"" ++ authorStr ++ "\""
+    let title = "Articles écrits par « " ++ authorStr ++ " »"
     route idRoute
     compile $ do
       posts <- loadAll authorsPattern >>= recentFirst
@@ -78,115 +170,120 @@ main = hakyllWith config $ do
         >>= loadAndApplyTemplate "templates/default.html" ctx
         >>= relativizeUrls
 
-  tagsRules poles $ \poleStr polesPattern -> do
+  create ["authors.html"] $ do
-    let title = "Articles du pôle \"" ++ poleStr ++ "\""
+    route idRoute
+    compile (authorPanelCompiler authors)
+
+  -- Tags
+  tagsRules tags $ \tagStr tagsPattern -> do
+    let title = "Articles relatifs à « " ++ tagStr ++ " »"
     route idRoute
     compile $ do
-      posts <- loadAll polesPattern >>= recentFirst
+      posts <- loadAll tagsPattern >>= recentFirst
       let ctx =
             constField "title" title
               <> listField "posts" postCtx (return posts)
               <> context
 
       makeItem ""
-        >>= loadAndApplyTemplate "templates/pole.html"  ctx
+        >>= loadAndApplyTemplate "templates/tag.html" ctx
         >>= loadAndApplyTemplate "templates/default.html" ctx
         >>= relativizeUrls
 
-  create [ "tags.html" ] $ do
+  create ["tags.html"] $ do
     route idRoute
-    compile $ renderTagList tags >>= tagCompiler
+    compile (tagPanelCompiler tags)
 
-  create [ "authors.html" ] $ do
+  -- Partial templates to be used elsewhere
+  match "templates/*" $ compile templateBodyCompiler
+
+  -- Markdown version of posts
+  match "posts/**.md" $ version "raw" $ do
     route idRoute
-    compile $ renderTagList authors >>= authorCompiler
-
-  match (imgPattern .||. docPattern) $ do
-    route   idRoute
-    compile copyFileCompiler
-
-  match "css/*.css" $ do
-    route   idRoute
-    compile compressCssCompiler
-
-  match miscPattern $ do
-    route   $ setExtension "html"
-    compile $ customPandocCompiler
-      >>= loadAndApplyTemplate "templates/default.html" context
-      >>= relativizeUrls
-
-  match postPattern $ do
-    route   $ setExtension "html"
-    compile $ customPandocCompiler
-      >>= loadAndApplyTemplate "templates/post.html"    (postCtxWith tags authors poles)
-      >>= loadAndApplyTemplate "templates/default.html" (postCtxWith tags authors poles)
-      >>= relativizeUrls
-
-  match (postPattern .||. miscPattern) $ version "raw" $ do
-    route   $ setExtension "md"
     compile $ getResourceBody >>= relativizeUrls
 
-  create [ "archive.html" ] $ do
+--------------------------------------------------------------------------------
-    route idRoute
+
-    compile $ do
+-- Metadata extraction
-      posts <- recentFirst =<< loadAll (postPattern .&&. hasNoVersion)
+extractMeta :: String -> Rules Tags
-      let archiveCtx =
+extractMeta name = do
-            listField "posts" postCtx (return posts)
+  tags <- buildTagsWith (getTagsByField name) postPattern (fromCapture (fromGlob (name ++ "/*.html")))
-            <> constField "title" "Archives"
+  return (sortTagsBy caseInsensitiveTags tags)
+
+-- Renderers
+makeAuthorPanelLink :: String -> String -> Int -> Int -> Int -> String
+makeAuthorPanelLink author url count _ _ =
+  renderHtml $ H.a H.! A.href (H.toValue url) H.! A.class_ "panel-block" $ do
+    H.span H.! A.class_ "tag mr-3" $ H.toHtml (pluralize count "publication")
+    H.toHtml author
+
+authorPanelCompiler :: Tags -> Compiler (Item String)
+authorPanelCompiler authors = do
+  let ctx =
+        field "authors" (\_ -> renderTags makeAuthorPanelLink (mconcat . intersperse "\n") authors)
+          <> constField "title" "Liste des auteur·e·s"
           <> context
 
   makeItem ""
-        >>= loadAndApplyTemplate "templates/archive.html" archiveCtx
+    >>= loadAndApplyTemplate "templates/authors.html" ctx
-        >>= loadAndApplyTemplate "templates/default.html" archiveCtx
+    >>= loadAndApplyTemplate "templates/default.html" ctx
     >>= relativizeUrls
 
-  match "index.html" $ do
+makeTagPanelLink :: String -> String -> Int -> Int -> Int -> String
-    route idRoute
+makeTagPanelLink tag url count _ _ =
-    compile $ do
+  renderHtml $ H.a H.! A.href (H.toValue url) H.! A.class_ "panel-block" $ do
-      allPosts <- recentFirst =<< loadAll (postPattern .&&. hasNoVersion)
+    H.span H.! A.class_ "tag mr-3" $ H.toHtml (pluralize count "publication")
-      let posts = take nbPostsHome allPosts
+    H.toHtml tag
-      let indexCtx =
+
-            listField "posts" postCtx (return posts)
+tagPanelCompiler :: Tags -> Compiler (Item String)
-            <> constField "title" "Accueil"
+tagPanelCompiler tags = do
+  let ctx =
+        field "tags" (\_ -> renderTags makeTagPanelLink (mconcat . intersperse "\n") tags)
+          <> constField "title" "Liste des catégories"
           <> context
 
-      getResourceBody
+  makeItem ""
-        >>= applyAsTemplate indexCtx
+    >>= loadAndApplyTemplate "templates/tags.html" ctx
-        >>= loadAndApplyTemplate "templates/default.html" indexCtx
+    >>= loadAndApplyTemplate "templates/default.html" ctx
     >>= relativizeUrls
 
-  match "templates/*.html" $ compile templateBodyCompiler
+-- Utility functions
-
+pluralize :: Int -> String -> String
---------------------------------------------------------------------------------
+pluralize count str = case count of
+  1 -> show count ++ " " ++ str
+  _ -> show count ++ " " ++ str ++ "s"
 
 abstract :: Pandoc -> Maybe [Inline]
 abstract (Pandoc _ blocks) =
   markedUp blocks <|> fallback blocks
   where
-  markedUp = fmap getFirst . query $ \inl -> case inl of
+    markedUp = fmap getFirst . query $ \case
       Span (_, cls, _) inls | "abstract" `elem` cls -> First (Just inls)
       _ -> mempty
-  fallback (Para inlines : Header _ _ _ : _) = Just inlines
+    fallback (Para inlines : Header {} : _) = Just inlines
     fallback (_ : t) = fallback t
     fallback [] = Nothing
 
 customPandocCompiler :: Compiler (Item String)
-customPandocCompiler = pandocCompilerWithTransformM
+customPandocCompiler =
+  pandocCompilerWithTransformM
     defaultHakyllReaderOptions
-  defaultHakyllWriterOptions { writerHTMLMathMethod = MathML }
+    defaultHakyllWriterOptions {writerHTMLMathMethod = MathML}
-  (\pandoc -> do
+    ( \pandoc -> do
         let render = fmap writePandoc . makeItem . Pandoc mempty . pure . Plain
         maybe
           (pure ())
           (void . (saveSnapshot "abstract" <=< render))
           (abstract pandoc)
         pure $ addSectionLinks pandoc
-  ) >>= relativizeUrls
+    )
+    >>= relativizeUrls
 
 addSectionLinks :: Pandoc -> Pandoc
-addSectionLinks = walk f where
+addSectionLinks = walk f
+  where
     f (Header n attr@(idAttr, _, _) inlines) =
-      let link = Link ("", ["section"], []) [Str "§"] ("#" <> idAttr, "")
+      let link = Link ("", [""], []) [Str "§"] ("#" <> idAttr, "")
        in Header n attr ([link, Space] <> inlines)
     f x = x
 
@@ -202,71 +299,23 @@ context =
 
 postCtx :: Context String
 postCtx =
-  dateField "date" "%Y-%m-%d"
+  dateField "date" "%d/%m/%Y"
     <> context
 
 postCtxWith :: Tags -> Tags -> Tags -> Context String
-postCtxWith tags authors poles
+postCtxWith tags authors poles =
-  = tagsFieldWith getPoles simpleRenderLink (mconcat . intersperse ", ") "poles" poles
+  tagsFieldWith (getTagsByField "poles") simpleRenderLink (mconcat . intersperse ", ") "poles" poles
-  <> tagsFieldWith getAuthors simpleRenderLink (mconcat . (\l -> if length l == 0 then [] else H.toHtml ("par " :: String):l) . intersperse ", ") "author" authors
+    <> tagsFieldWith (getTagsByField "authors") simpleRenderLink (mconcat . (\l -> if null l then [] else H.toHtml ("par " :: String) : l) . intersperse ", ") "author" authors
-  <> tagsFieldWith getAuthors licenseRenderLink (mconcat . intersperse ", " . (\l -> if length l == 0 then [] else l ++ [H.toHtml ("and" :: String)])) "authorLicense" authors
+    <> tagsFieldWith (getTagsByField "authors") licenseRenderLink (mconcat . intersperse ", " . (\l -> if null l then [] else l ++ [H.toHtml ("and" :: String)])) "authorLicense" authors
     <> tagsField "tags" tags
     <> postCtx
 
-tagCompiler :: String -> Compiler (Item String)
+simpleRenderLink :: String -> Maybe FilePath -> Maybe H.Html
-tagCompiler tags =
-  makeItem ""
-    >>= loadAndApplyTemplate "templates/tags.html"    ctx
-    >>= loadAndApplyTemplate "templates/default.html" ctx
-    >>= relativizeUrls
-  where
-    prettyTags = replaceAll ", " (const "</li><li>") tags
-    ctx = constField "title" "Toutes les catégories" <> constField "alltags" prettyTags <> context
-
-authorCompiler :: String -> Compiler (Item String)
-authorCompiler authors =
-  makeItem ""
-    >>= loadAndApplyTemplate "templates/authors.html" ctx
-    >>= loadAndApplyTemplate "templates/default.html" ctx
-    >>= relativizeUrls
-  where
-    prettyAuthors = replaceAll ", " (const "</li><li>") authors
-    ctx = constField "title" "Tout les (co-)auteurs" <> constField "allauthors" prettyAuthors <> context
-
-getAuthors :: MonadMetadata m => Identifier -> m [String]
-getAuthors identifier = do
-  metadata <- getMetadata identifier
-  return $ maybe [] (map trim . splitAll ",") $ lookupString "author" metadata
-
-getPoles :: MonadMetadata m => Identifier -> m [String]
-getPoles identifier = do
-  metadata <- getMetadata identifier
-  return $ maybe [] (map trim . splitAll ",") $ lookupString "poles" metadata
-
-extractTags :: Rules Tags
-extractTags = do
-  tags <- buildTags postPattern $ fromCapture "tags/*.html"
-  return $ sortTagsBy caseInsensitiveTags tags
-
-extractAuthors :: Rules Tags
-extractAuthors = do
-  authors <- buildTagsWith getAuthors postPattern $ fromCapture "authors/*.html"
-  return $ sortTagsBy caseInsensitiveTags authors
-
-extractPoles :: Rules Tags
-extractPoles = do
-  poles <- buildTagsWith getPoles postPattern $ fromCapture "poles/*.html"
-  return $ sortTagsBy caseInsensitiveTags poles
-
-simpleRenderLink :: String -> (Maybe FilePath) -> Maybe H.Html
 simpleRenderLink _ Nothing = Nothing
 simpleRenderLink tag (Just filePath) =
   Just $ H.a H.! A.href (H.toValue $ toUrl filePath) $ H.toHtml tag
 
-licenseRenderLink :: String -> (Maybe FilePath) -> Maybe H.Html
+licenseRenderLink :: String -> Maybe FilePath -> Maybe H.Html
 licenseRenderLink _ Nothing = Nothing
 licenseRenderLink tag (Just filePath) =
   Just $ H.a H.! A.href (H.toValue $ toUrl filePath) H.! A.rel "cc:attributionURL dct:creator" $ H.toHtml tag
-
-config :: Configuration
-config = defaultConfiguration { destinationDirectory = "result" }