From dbae6b362325bc38e8a4f774c08aab1474b1b5db Mon Sep 17 00:00:00 2001 From: flupe Date: Sun, 27 Sep 2020 01:33:50 +0200 Subject: [PATCH] moved from blaze-html to lucid --- site.cabal | 10 +-- src/Common.hs | 4 +- src/Feed.hs | 34 --------- src/Main.hs | 4 +- src/Posts.hs | 22 +++--- src/Projects.hs | 4 +- src/Templates.hs | 174 +++++++++++++++++++++++++---------------------- 7 files changed, 112 insertions(+), 140 deletions(-) delete mode 100644 src/Feed.hs diff --git a/site.cabal b/site.cabal index 91f7a8b..894b48a 100644 --- a/site.cabal +++ b/site.cabal @@ -16,12 +16,11 @@ executable site , Common , Config , Visual + , Templates build-depends: base >=4.12 && <4.13 , filepath , achille , data-default - , blaze-html - , blaze-markup , pandoc , pandoc-types , text @@ -32,17 +31,18 @@ executable site , yaml , binary , containers - , dates , sort , feed , time - , xml-types + , lucid , binary-instances extensions: BlockArguments , TupleSections , OverloadedStrings , ScopedTypeVariables - other-modules: Templates + , DeriveGeneric + , DeriveAnyClass ghc-options: -threaded -j8 + -O2 default-language: Haskell2010 diff --git a/src/Common.hs b/src/Common.hs index f53c53f..0cbca6d 100644 --- a/src/Common.hs +++ b/src/Common.hs @@ -5,10 +5,10 @@ module Common , module System.FilePath , module Achille , module Achille.Recipe.Pandoc - , module Text.Blaze.Html , module Data.Text , module Control.Monad , module Data.Maybe + , module Lucid ) where import Achille @@ -21,4 +21,4 @@ import Data.String (fromString) import Data.Text (Text) import Data.Maybe (fromMaybe, mapMaybe) import System.FilePath -import Text.Blaze.Html (Html) +import Lucid (Html) diff --git a/src/Feed.hs b/src/Feed.hs deleted file mode 100644 index 6a23904..0000000 --- a/src/Feed.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Feed where - -import Data.Text hiding (map) -import Data.XML.Types as XML -import qualified Data.Text.Lazy as Lazy -import Text.Atom.Feed as Atom -import qualified Text.Atom.Feed.Export as Export (textFeed) - -import Common -import Types - -class Reifiable a where - toEntry :: a -> Atom.Entry - -instance Reifiable Project where - toEntry :: Project -> Atom.Entry - toEntry (Project {title, subtitle}) = - -toFeed :: Reifiable a => [a] -> Atom.Feed -toFeed items = - ( Atom.nullFeed - "https://acatalepsie.fr/atom.xml" - (Atom.TextString "acatalepsie") - "2017-08-01" - ) - { Atom.feedEntries = map toEntry items - } diff --git a/src/Main.hs b/src/Main.hs index 98511a4..061837c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,7 +1,7 @@ module Main where import qualified Data.Yaml as Yaml -import Text.Blaze +import Lucid import Common import Templates @@ -19,7 +19,7 @@ main = achilleWith config do -- quid page match_ "./quid.rst" $ compilePandoc - <&> preEscapedText + <&> toHtmlRaw <&> outerWith def {Config.title = "quid"} >>= saveFileAs (-<.> "html") diff --git a/src/Posts.hs b/src/Posts.hs index 2095fec..51c9bc5 100644 --- a/src/Posts.hs +++ b/src/Posts.hs @@ -2,15 +2,13 @@ module Posts (build) where -import Text.Blaze.Internal as I -import Text.Blaze.Html5 as H -import Text.Blaze.Html5.Attributes as A import Data.Aeson.Types (FromJSON) import Data.Binary (Binary, put, get) import Data.Time (UTCTime, defaultTimeLocale) import Data.Time.Clock (getCurrentTime) import Data.Time.Format (rfc822DateFormat, formatTime) import GHC.Generics +import Lucid import Text.Atom.Feed as Atom import Text.Feed.Types (Feed(..)) @@ -93,20 +91,20 @@ build = do } -renderPost :: Text -> FilePath -> Text -> Html +renderPost :: Text -> FilePath -> Text -> Html () renderPost title source content = outerWith def { Config.title = title } do - H.h1 $ toHtml title + h1_ $ toHtml title toLink source "View source" - preEscapedText content + toHtmlRaw content -renderIndex :: [Post] -> Text -> Html +renderIndex :: [Post] -> Text -> Html () renderIndex posts content = outer do - preEscapedText content - H.h2 "Latest posts" - H.ul ! A.id "pidx" $ forM_ posts \post -> - H.li do - H.span $ fromString $ showDate (postDate post) + toHtmlRaw content + h2_ "Latest posts" + ul_ [ id_ "pidx" ] $ forM_ posts \post -> + li_ do + span_ $ fromString $ showDate (postDate post) toLink (postPath post) (toHtml $ postTitle post) diff --git a/src/Projects.hs b/src/Projects.hs index a9d3d0f..9260231 100644 --- a/src/Projects.hs +++ b/src/Projects.hs @@ -2,12 +2,12 @@ module Projects (build) where import Data.Char (digitToInt) -import Text.Blaze import Common import Types import Page import Config import Templates +import Lucid getKey :: String -> (Int, String) @@ -39,7 +39,7 @@ buildProject = do let (key, file) = getKey $ takeFileName filepath (TitledPage title _, doc) <- readPandocMetadataWith ropts renderPandocWith wopts doc - <&> preEscapedText + <&> toHtmlRaw <&> outerWith (def {Config.title = fromString title}) >>= saveFileAs (const $ file -<.> "html") <&> (title,) diff --git a/src/Templates.hs b/src/Templates.hs index 5c218d7..b2f0d52 100644 --- a/src/Templates.hs +++ b/src/Templates.hs @@ -1,144 +1,152 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} module Templates where -import Text.Blaze.Internal as I -import Text.Blaze.Html5 as H -import Text.Blaze.Html5.Attributes as A import Data.Time (UTCTime) import Data.Time.Format (formatTime, defaultTimeLocale) import Data.Time.LocalTime (zonedTimeToUTC) +import qualified Data.Map.Strict as Map + +import Achille.Internal.IO (AchilleIO) +import Achille.Writable as Writable +import Lucid +import Lucid.Base (makeAttribute) import Types import Common import Config -import qualified Data.Map.Strict as Map + + +instance AchilleIO m => Writable m (Html a) where + write to = Writable.write to . renderBS showDate :: UTCTime -> String showDate = formatTime defaultTimeLocale "%b %d, %_Y" -loading :: AttributeValue -> Attribute -loading = I.customAttribute "loading" +loading_ :: Text -> Attribute +loading_ = makeAttribute "loading" -property :: AttributeValue -> Attribute -property = I.customAttribute "property" +property_ :: Text -> Attribute +property_ = makeAttribute "property" -toLink :: FilePath -> Html -> Html -toLink url = H.a ! A.href (fromString $ "/" <> url) +toLink :: FilePath -> Html () -> Html () +toLink url = a_ [ href_ (fromString $ "/" <> url) ] -renderVisual :: Text -> [Timestamped FilePath] -> Html +renderVisual :: Text -> [Timestamped FilePath] -> Html () renderVisual txt imgs = outer do - preEscapedText txt - H.hr - H.section $ forM_ imgs \ (Timestamped _ p) -> - H.figure $ H.img ! A.src (fromString p) - ! loading "lazy" + toHtmlRaw txt + hr_ [] + section_ $ forM_ imgs \ (Timestamped _ p) -> + figure_ $ img_ [ src_ (fromString p), loading_ "lazy" ] -renderProject :: Project -> [(String, FilePath)] -> Text -> Html +renderProject :: Project -> [(String, FilePath)] -> Text -> Html () renderProject (project@Project{title,..}) children content = outerWith def { Config.title = fromString title , Config.description = fromString subtitle } do - H.header ! A.class_ "project" $ do - H.div $ H.img ! A.src "logo.svg" - H.div do - H.h1 $ fromString $ title - H.p $ fromString $ subtitle - H.ul $ forM_ (Map.toList labels) \(k, v) -> H.li do + header_ [ class_ "project" ] do + div_ (img_ [ src_ "logo.svg" ]) + div_ do + h1_ (fromString title) + p_ (fromString subtitle) + ul_ $ forM_ (Map.toList labels) \(k, v) -> li_ do fromString k <> ": " if k == "repo" then - H.a ! A.href (fromString $ "https://github.com/" <> v) + a_ [ href_ (fromString $ "https://github.com/" <> v) ] $ fromString v else fromString v when (length children > 0) $ - H.ol ! A.class_ "pages" $ forM_ children \(t,l) -> - H.li $ H.a ! A.href (fromString l) $ (fromString t) - preEscapedText content + ol_ [ class_ "pages" ] $ forM_ children \(t,l) -> + li_ $ a_ [ href_ (fromString l) ] (fromString t) + toHtmlRaw content -renderReadings :: [Book] -> Html +renderReadings :: [Book] -> Html () renderReadings books = outerWith def { Config.title = "readings" , Config.description = "books I've read" } do - H.table ! A.class_ "books" $ + table_ [ class_ "books" ] $ forM_ books \ Book {title,author,rating,completed} -> - H.tr do - H.td $ toHtml title - H.td $ toHtml author - H.td $ fromString $ case rating of + tr_ do + td_ (toHtml title) + td_ (toHtml author) + td_ $ fromString $ case rating of Just r -> replicate r '★' Nothing -> "·" - H.td $ fromString $ case completed of + td_ $ fromString $ case completed of Just d -> formatTime defaultTimeLocale "%m/%0Y" $ zonedTimeToUTC d Nothing -> "·" -renderProjects :: Text -> [(Project, FilePath)] -> Html +renderProjects :: Text -> [(Project, FilePath)] -> Html () renderProjects txt paths = outer do - preEscapedText txt - H.ul ! A.class_ "projects" $ do - forM_ paths \(Project {title,..}, link) -> H.li $ H.a ! A.href (fromString link) $ do - H.div $ H.img ! A.src (fromString $ link "logo.svg") - H.div do - H.h2 $ fromString title - H.p $ fromString subtitle + toHtmlRaw txt + ul_ [ class_ "projects" ] do + forM_ paths \(Project {title,..}, link) -> li_ $ a_ [ href_ (fromString link) ] $ do + div_ $ img_ [ src_ (fromString $ link "logo.svg") ] + div_ do + h2_ (fromString title) + p_ (fromString subtitle) -- H.ul $ forM_ (Map.toList $ Types.labels project) \(k, v) -> -- H.li $ (fromString k <> ": " <> fromString v) -logo :: Html -logo = preEscapedString "" +logo :: Html () +logo = toHtmlRaw ("" :: Text) -outer :: Html -> Html +outer :: Html () -> Html () outer = outerWith def -outerWith :: SiteConfig -> Html -> Html -outerWith SiteConfig{title,..} content = H.docTypeHtml do - H.head do - H.meta ! A.name "viewport" - ! A.content "width=device-width, initial-scale=1.0, user-scalable=yes" - H.meta ! A.name "theme-color" ! A.content "#000000" - H.meta ! A.name "robots" ! A.content "index, follow" - H.meta ! charset "utf-8" - H.link ! A.rel "stylesheet" ! A.href "/assets/theme.css" - H.link ! A.rel "shortcut icon" - ! A.type_ "image/svg" - ! A.href "/assets/favicon.svg" - H.link ! A.rel "alternate" - ! A.type_ "application/atom+xml" - ! A.href "/atom.xml" - H.meta ! property "og:title" - ! A.content (textValue title) - H.meta ! property "og:type" - ! A.content "website" - H.meta ! property "og:image" - ! A.content (textValue image) - H.meta ! property "og:description" - ! A.content (textValue description) - H.title $ toHtml title +outerWith :: SiteConfig -> Html () -> Html () +outerWith SiteConfig{title,..} content = doctypehtml_ do + head_ do + meta_ [ name_ "viewport" + , content_ "width=device-width, initial-scale=1.0, user-scalable=yes" + ] + meta_ [ name_ "theme-color", content_ "#000000" ] + meta_ [ name_ "robots", content_ "index, follow" ] + meta_ [ charset_ "utf-8" ] + link_ [ rel_ "stylesheet", href_ "/assets/theme.css" ] + link_ [ rel_ "shortcut icon" + , type_ "image/svg" + , href_ "/assets/favicon.svg" + ] + link_ [ rel_ "alternate" + , type_ "application/atom+xml" + , href_ "/atom.xml" + ] + meta_ [ property_ "og:title", content_ title ] + meta_ [ property_ "og:type", content_ "website" ] + meta_ [ property_ "og:image", content_ image ] + meta_ [ property_ "og:description", content_ description ] + title_ $ toHtml title - H.body do - H.header ! A.id "hd" $ H.section do - H.a ! A.href "/" $ logo - H.section $ H.nav do - H.a ! A.href "/projects.html" $ "Projects" - H.a ! A.href "/visual.html" $ "Visual" - H.a ! A.href "/readings.html" $ "Readings" - H.a ! A.href "/quid.html" $ "Quid" - H.a ! A.href "/atom.xml" $ "Feed" + body_ do + header_ [ id_ "hd" ] $ section_ do + a_ [ href_ "/" ] $ logo + section_ $ nav_ do + a_ [ href_ "/projects.html" ] "Projects" + a_ [ href_ "/visual.html" ] "Visual" + a_ [ href_ "/readings.html" ] "Readings" + a_ [ href_ "/quid.html" ] "Quid" + a_ [ href_ "/atom.xml" ] "Feed" - H.main content + main_ content - H.footer ! A.id "ft" $ do + footer_ [ id_ "ft" ] do "flupe 2020 · " - H.a ! A.href "https://creativecommons.org/licenses/by-nc/2.0/" $ "CC BY-NC 2.0" + a_ [ href_ "https://creativecommons.org/licenses/by-nc/2.0/" ] + "CC BY-NC 2.0" " · " - H.a ! A.href "https://instagram.com/ba.bou.m/" $ "instagram" + a_ [ href_ "https://instagram.com/ba.bou.m/" ] "instagram" " · " - H.a ! A.href "/atom.xml" $ "feed" + a_ [ href_ "/atom.xml" ] "feed"