module Site.Page where
import Data.Default (def)
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Time qualified as Time
import Ema qualified
import Graphics.ThumbnailPlus qualified as Thumb
import Network.URI.Slug (Slug)
import PyF
import Relude
import Text.Blaze.Html5 ((!))
import Text.Blaze.Html5 qualified as H
import Text.Blaze.Html5.Attributes qualified as A
import Text.Blaze.Internal qualified as Blaze
import Text.Pandoc.Options qualified as Pandoc
import Text.Pandoc.Writers.Shared qualified as Pandoc
import Prelude ()
import Data.Text qualified as Text
import Site.Lang
import Site.Model
import Site.Tag
import Text.Pandoc.Builder qualified as Pandoc
import Text.Pandoc.Shared qualified as Pandoc
import Text.Pandoc.Walk qualified as Pandoc
import Utils.Html
import Utils.Pandoc as Pandoc
import Utils.Pandoc.Html (htmlOfPandoc)
renderPage :: Model -> ([Slug], Page) -> Content
renderPage
model@Model{..}
( pagePath
, page@Page
{ pageMeta = meta@Meta{metaLang}
, pageDoc = Pandoc.Pandoc pandocMeta pandocBlocks
}
) =
Content
{ contentTitle = Nothing -- Just metaTitle
, contentHtml = do
H.div ! classes ["flex", "flex-row", "flex-wrap"] $ do
H.div
! A.style "flex-grow: 2;"
! classes
[ "page"
, --, "flex-grow"
"w-96"
, "max-w-xl"
, "mx-auto"
, "fg-black"
, "bg-white"
, "px-4"
, "text-justify"
--, "float-left"
--, "flow-root"
--, "w-full"
--, "lg:w-3/4"
]
$ do
renderPageTitle
renderPageTags
renderPageSummary
-- H.hr ! classes ["min-w-full"]
H.article
! classes
[ "article"
--, "clear-left"
]
$ pageHtml
H.div
-- ! A.style "width: 20em"
-- TODO: use column-gap: https://www.w3.org/TR/css-align-3/
-- once implemented in Web engines.
! A.style "min-width:20rem; flex-grow: 1;"
! classes
[ "w-80"
, "max-w-xl"
, "mx-auto"
, "flex"
, "flex-col"
-- , "flex-grow"
--, "w-full"
--, "lg:w-80"
]
$ do
forM_
( catMaybes
[ renderPageHeaders
, renderPageToC
, renderPageBackLinks
, renderTags model
, similarPages model (pagePath, pageMeta page)
]
)
$ \aside ->
H.aside ! classes ["mb-3"] $ aside
H.aside $ recentPages metaLang model (Just (metaTitle meta))
{-
H.aside
! classes [
--"float-left"
--, "w-full"
--, "lg:pr-0"
--, "lg:w-1/4"
]
$ do
renderPageDiscussion
-}
}
where
doc = Pandoc.makeSections True Nothing pandocBlocks
tocHtmlMaybe =
case Pandoc.toTableOfContents writerOpts $
Pandoc.walk walkToC doc of
Pandoc.BulletList [] -> Nothing
ul -> Just $ htmlOfPandoc writerOpts $ Pandoc.Pandoc pandocMeta [ul]
walkToC = \case
-- Hyper-link section numbers.
Pandoc.Div
(divId, "section" : divCls, divDict)
(Pandoc.Header level ("", headerCls, headerDict) headerInlines : divBlocks) ->
Pandoc.Div
(divId, "section" : divCls, divDict)
$
-- level + 1 to only have the title in a
Pandoc.Header
(level + 1)
(divId, headerCls, ("number", number) : headerDict)
(Pandoc.Space : Pandoc.Span ("", ["font-bold" | level == 1], []) headerInlines : []) :
divBlocks
where
sectionNum = fromMaybe mempty $ List.lookup "number" headerDict
sectionNums = Text.split ('.' ==) sectionNum
number
| List.length sectionNums == 1 = sectionNum <> "."
| otherwise = sectionNum
x -> x
writerOpts =
def
{ Pandoc.writerExtensions = Pandoc.enableExtension Pandoc.Ext_smart Pandoc.pandocExtensions
, -- makeSections is called here and customized
Pandoc.writerNumberSections = False
, -- toTableOfContents is called here and customized
Pandoc.writerTableOfContents = False
, Pandoc.writerSectionDivs = True
, Pandoc.writerTOCDepth = maxBound
}
pageHtml = htmlOfPandoc writerOpts $
Pandoc.walk
( \case
Pandoc.Link (linkId, linkCls, linkKVs) label (uri, title)
| not (Text.isInfixOf ":" uri) -> do
-- keep only local URIs
Pandoc.Link
(linkId, ["text-red-800"] <> linkCls, linkKVs)
label
(uri <> ".html", title)
inl -> inl
)
$ (`Pandoc.walk` Pandoc.Pandoc pandocMeta doc) $ \case
Pandoc.BulletList items
| all
( \case
Pandoc.Plain (Pandoc.Str "pictures:" : Pandoc.Space : Pandoc.Str _ : _) : [] -> True
_ -> False
)
items ->
walkPictures items
blk -> blk
renderPageTitle =
H.header $
H.h1
! classes
[ "bg-black"
, "font-bold"
, "leading-relaxed"
, "mb-1"
, "mt-4"
, "text-center"
, "text-lg"
, "text-white"
]
$ H.text (metaTitle meta)
renderPageTags =
unless (null (metaTags meta)) do
H.aside
! classes
[ "flex"
, "flex-row"
, "flex-wrap"
, "mb-2"
--, "max-w-screen-md"
]
$ forM_ (metaTags meta) $
renderTag model False
renderPageSummary =
whenJust (metaSummary meta) $ \Markdown{..} -> do
H.div
! classes
[ "summary"
, --, "border-1"
--, "border-black"
"bg-gray-100"
, "mb-2"
]
$ do
H.span
! classes
[ "bg-black"
, "font-bold"
, "px-4"
, --, "mb-1"
--, "text-left"
"text-xs"
, "text-white"
, "display-inline"
, "float-left"
]
$ H.text "Résumé"
H.div ! classes ["px-2"] $
H.span
! classes
[ "inline"
, "italic"
, "ml-2"
]
$ htmlOfPandoc def markdownPandoc
-- H.span
-- ! classes [ "bg-gray-500"
-- , "float-right"
-- , "px-4"
-- , "mt-1"
-- , "text-white"
-- , "font-bold"
-- ]
-- ! A.style "font-size: 0.55rem"
-- $ [fmt|{signsCount pageDoc} signes|]
renderPageHeaders = Just $
H.table
! classes
[ "document-headers"
, "border-collapse"
, "border-white"
]
$ forM_ (zip [0 :: Int ..] headers) $ \(headerRank, (headerName, headerValue)) -> do
H.tr
! classes
[ if headerRank `mod` 2 == 0
then "bg-gray-300"
else "bg-gray-200"
]
$ do
H.th
! classes
[ "font-bold"
, "bg-black"
, "text-white"
, "px-3"
, "whitespace-nowrap"
, if headerRank /= 0 then "border-t" else ""
]
$ do
H.text (headerName metaLang)
H.td
! classes
[ "px-3"
, "w-full"
, if headerRank /= 0 then "border-t" else ""
]
$ do
headerValue
where
dateHtml = Time.formatTime (timeLocale metaLang) "%-e %B %Y"
headers :: [(Lang -> Text, H.Html)]
headers =
catMaybes
[ metaAuthors meta >>= \authors ->
Just
( i18nAuthors
, H.ul $
forM_ authors $ \Entity{..} ->
H.li $
case entityMail of
Nothing -> H.text entityName
Just mail ->
H.a
! A.href ("mailto:" <> H.textValue mail)
$ H.text entityName
)
, metaUpdated meta >>= \date ->
Just (i18nUpdated, H.string $ dateHtml date)
, metaPublished meta >>= \date ->
Just (i18nPublished, H.string $ dateHtml date)
, let lisense = fromMaybe "CC-BY-SA-4.0" (metaLisense meta)
in Just (i18nLisense, H.a ! A.href [fmt|https://spdx.org/licenses/{lisense}.html|] $ H.text lisense)
, metaDiscussion meta >>= \Discussion{..} ->
Just
( i18nDiscussion
, H.a ! A.href (H.textValue [fmt|mailto:{discussionMail}|]) $
H.text discussionMail
)
, Just (i18nLanguage, H.text $ langText metaLang)
]
renderPageToC =
tocHtmlMaybe <&> \tocHtml ->
H.nav
! classes
[ "toc"
]
$ do
H.details ! A.open "" $ do
H.summary
! classes
[ "bg-black"
, "border-l-8"
, "border-black"
, "text-white"
]
$ H.h2
! classes
[ "font-bold"
, "pl-1"
, "text-left"
, "text-xs"
, "inline-block"
]
$ i18nTableOfContent metaLang
H.div
! classes
[ "p-2"
, "bg-yellow-50"
, "border-1"
, "border-black"
]
$ tocHtml
renderPageBackLinks =
let bls = backLinks (LocalLink pagePath) modelLocalLinks
in if null bls
then Nothing
else Just do
H.nav
! classes
[ "backlinks"
]
$ do
H.details ! A.open "" $ do
H.summary
! classes
[ "bg-black"
, "border-l-8"
, "border-black"
, "text-white"
]
$ H.h2
! classes
[ "font-bold"
, "pl-1"
, "text-left"
, "text-xs"
, "inline-block"
]
$ i18nBacklinks metaLang
H.ul $
forM_ (modelLocalLinks Map.! pagePath) $ \(LocalLink lnk) ->
H.li $ H.string $ show lnk
H.ul
! classes
[ "p-2"
, "bg-yellow-50"
, "border-1"
, "border-black"
]
$ do
forM_ bls $ \bl ->
H.li do
"— "
H.a
! A.href (H.stringValue (Ema.encodeRoute model (Right @FilePath (RoutePage bl))))
$ H.text (metaTitle (pageMeta (modelPosts Map.! bl)))
renderPageDiscussion =
whenJust (metaDiscussion meta) $ \Discussion{..} -> do
H.aside
! A.id "discussion"
! classes
[ "discussion"
, "bg-gray-100"
, --, "float-left"
--, "clear-both"
"w-full"
, --, "h-screen"
"p-0"
, "mt-4"
]
$ do
H.h2
! classes
[ "bg-gray-500"
, "font-bold"
, "px-4"
, "text-left"
, "text-sm"
, "text-white"
]
$ do
H.a
! A.href "#discussion"
! classes ["text-white"]
$ H.text (i18nDiscussion metaLang)
H.span
! classes ["font-normal", "text-sm"]
$ do
" ("
H.a ! A.href ("mailto:" <> H.textValue discussionMail) $
H.text discussionMail
")"
H.iframe
! classes
[ "block"
, "border-1"
, --, "float-left", "clear-left"
"w-full"
]
! A.style "height:100vh"
! A.src (H.textValue discussionUrl)
! A.src "http://oignon.wg:8000"
! Blaze.attribute "loading" " loading=\"" "lazy"
$ ""
walkPictures items =
Pandoc.Div
("", ["pictures", "mb-2"], [])
[ Pandoc.BulletList $
mconcat $
items <&> \case
Pandoc.Plain (Pandoc.Str "pictures:" : Pandoc.Space : Pandoc.Str (decodeSlugs -> prefix) : plainInlines) : [] ->
[ let alt = Pandoc.trimWhiteInlines plainInlines
in let (maxThumbSize, maxThumbPath) = List.last thumbs
in let (minThumbSize, _minThumbPath) = List.head $ traceShowId thumbs
in pure $
Pandoc.Plain
[ Pandoc.Link
("", [], [])
[ {-
Pandoc.RawInline "html5" [fmt|
-}
Pandoc.Image
( ""
, []
,
[
( "srcset"
, Text.intercalate ", " $
thumbs <&> \(size, name) ->
[fmt|/{name} {Thumb.width size}w|]
)
,
( "sizes"
, Text.intercalate
", "
[ [fmt|(min-width: 640px) {Thumb.width maxThumbSize}px|]
, [fmt|{Thumb.width minThumbSize}px|]
]
)
]
)
alt
( toText $ '/' : maxThumbPath
, Pandoc.stringify alt -- title
)
]
(encodeSlugs slugs, "")
, Pandoc.Span
("", [], [])
[ Pandoc.Str [fmt|{Thumb.width maxThumbSize}x{Thumb.height maxThumbSize}|]
]
]
| (slugs, thumbs) <- Map.toList modelPictures
, prefix `List.isPrefixOf` slugs
]
_ -> []
]
i18nAuthors = \case
LangEn -> "Author(s)"
LangFr -> "Auteur.rice(s)"
_ -> i18nUpdated LangEn
i18nBacklinks = \case
LangEn -> "Backlinks"
LangFr -> "Rétroliens"
_ -> i18nBacklinks LangEn
i18nLanguage = \case
LangEn -> "Language"
LangFr -> "Langage"
_ -> i18nLanguage LangEn
i18nLisense = \case
LangEn -> "Lisense"
LangFr -> "License"
_ -> i18nLisense LangEn
i18nDiscussion = \case
LangEn -> "Discussion"
LangFr -> "Discussion"
_ -> i18nDiscussion LangEn
i18nUpdated = \case
LangEn -> "Updated"
LangFr -> "Mise-à-jour"
_ -> i18nUpdated LangEn
i18nPublished = \case
LangEn -> "Published"
LangFr -> "Publication"
_ -> i18nPublished LangEn
i18nLatestPosts = \case
LangEn -> "Latest Posts"
LangFr -> "Derniers Billets"
_ -> i18nLatestPosts LangEn
i18nTableOfContent = \case
LangEn -> "Table of Content"
LangFr -> "Sommaire"
_ -> i18nTableOfContent LangEn
similarPages :: Model -> ([Slug], Meta) -> Maybe H.Html
similarPages model (pagePath, meta) =
if null posts
then Nothing
else Just do
H.nav
! classes
[ "similars"
, "bg-gray-100"
, "border-1"
, "border-black"
, "p-0"
]
$ do
H.h2
! classes
[ "bg-black"
, "font-bold"
, "px-4"
, "text-left"
, "text-xs"
, "text-white"
]
$ do
H.text "Similar Posts"
H.span ! classes ["font-normal"] $
H.text [fmt| ({List.length simPosts})|]
renderPagesListing model posts
where
simPosts =
List.filter (\(path, Page{..}) -> not (null (commonTags meta pageMeta)) && path /= pagePath) $
filterPosts model noFilter
posts = take 5 $ List.sortOn (negate . List.length . commonTags meta . pageMeta . snd) simPosts
commonTags x y = tagSet x `Set.intersection` tagSet y
where
tagSet = fromList . metaTags
renderPagesListing :: Model -> [([Slug], Page)] -> H.Html
renderPagesListing model pages =
H.ul do
forM_ pages $ \(pagePath, Page{..}) ->
H.li
! classes
[ "border-t-2"
, "flex"
, "flex-col"
, "p-2"
]
$ do
H.h6 ! classes ["text-sm"] $ do
H.a ! classes ["hover:bg-blue-50", "rounded"]
! hrefRoute model (RoutePage pagePath)
$ H.text $ metaTitle pageMeta
unless (null (metaTags pageMeta)) do
H.div
! classes ["flex", "flex-row", "flex-wrap"]
$ forM_ (metaTags pageMeta) $
renderTag model False
whenJust (metaSummary pageMeta) $ \Markdown{..} -> do
H.span
! classes ["italic", "text-gray-700"]
$ htmlOfPandoc def markdownPandoc
timeLocale :: Lang -> Time.TimeLocale
timeLocale = \case
LangFr ->
Time.defaultTimeLocale
{ Time.months =
[ ("janvier", "Jan")
, ("février", "Févr")
, ("mars", "Mar")
, ("avril", "Apr")
, ("mai", "May")
, ("juin", "Juin")
, ("juillet", "Juil")
, ("août", "Aoû")
, ("septembre", "Sep")
, ("octobre", "Oct")
, ("novembre", "Nov")
, ("décembre", "Déc")
]
}
_ -> Time.defaultTimeLocale
renderSpecial :: Model -> Page -> Content
renderSpecial model Page{..} =
Content
{ contentTitle = Just $ metaTitle pageMeta
, contentHtml = do
H.header $
H.h1
! classes
[ "bg-black"
, "font-bold"
, "leading-relaxed"
, "mb-1"
, "mt-4"
, "text-center"
, "text-lg"
, "text-white"
]
$ H.text $ metaTitle pageMeta
htmlOfPandoc def pageDoc
recentPages (metaLang pageMeta) model Nothing
}
recentPages :: Lang -> Model -> Maybe Text -> H.Html
recentPages lang model here =
H.nav
! classes
[ "recents"
, "bg-gray-100"
, "border-1"
, "border-black"
, "p-0"
]
$ do
H.h2
! classes
[ "bg-black"
, "font-bold"
, "px-4"
, "text-left"
, "text-xs"
, "text-white"
]
$ i18nLatestPosts lang
renderPagesListing model posts
where
posts =
List.take 5 $
List.filter (\(_, Page{..}) -> isJust (metaUpdated pageMeta) && maybe True (/= metaTitle pageMeta) here) $
filterPosts model noFilter
filterPosts :: Model -> Filter -> [([Slug], Page)]
filterPosts Model{..} (Filter lang tag) =
reverse $
List.sortOn (metaUpdated . pageMeta . snd) $
maybe id (\t -> List.filter (\(_, Page{..}) -> t `elem` metaTags pageMeta)) tag $
maybe id (\l -> List.filter (\(_, Page{..}) -> l == metaLang pageMeta)) lang $
Map.toList modelPosts