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