Ugly JS desperate fix

hablo.cabal

@@ -56,7 +56,8 @@ library
                      , containers >= 0.5.11 && < 0.7
                      , directory >= 1.3.1 && < 1.4
                      , filepath >= 1.4.2 && < 1.5
-                     , lucid >= 2.8.0 && < 2.10
+                     , blaze-html
+                     , blaze-markup
                      , mtl >= 2.2.2 && < 2.3
                      , optparse-applicative >= 0.14.0 && < 0.17
                      , parsec >= 3.1.13 && < 3.2

src/DOM.hs

@@ -18,22 +18,28 @@ import Data.Map as Map (Map, toList)
 import Data.Text (Text, pack, empty)
 import DOM.Card (HasCard)
 import qualified DOM.Card as Card (make)
-import Lucid (
-      Attribute, HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_
-    , h1_, h2_, head_, header_, href_, li_, link_, id_, meta_, pre_, rel_
-    , script_, src_, title_, toHtml, toHtmlRaw, type_, ul_
-  )
+--import Lucid (
+--      Attribute, HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_
+--    , h1_, h2_, head_, header_, href_, li_, link_, id_, meta_, pre_, rel_
+--    , script_, src_, title_, toHtml, toHtmlRaw, type_, ul_
+--  )
 import Markdown (Markdown(..), MarkdownContent(..))
 import Network.URL (URL)
 import Page (Page)
-import Prelude hiding (head, lookup)
+import Prelude hiding (div, head, id, lookup)
 import Pretty ((.$))
 import System.FilePath.Posix ((</>), (<.>))
+import Text.Blaze.Html5 as H (
+    (!), Html, ToValue(..), body, div, docTypeHtml, h2, head, li, meta, preEscapedText, script, text, title, ul
+  )
+import Text.Blaze.Html5.Attributes (
+    charset, class_, id, src
+  )
 
-type HtmlGenerator = HtmlT (ReaderT Blog IO)
+type HtmlGenerator = ReaderT Blog IO Html
 
 class HasCard a => PageType a where
-  content :: a -> HtmlGenerator ()
+  content :: a -> HtmlGenerator
   pathToRoot :: a -> FilePath
 
 instance PageType Article where
@@ -47,17 +53,17 @@ instance PageType Page where
 instance PageType ArticlesList where
   content al@(ArticlesList {full}) = do
     preview <- Article.preview <$> (asks $skin.$previewLinesCount)
-    h2_ . toHtml =<< description al
+    h2_ . text =<< description al
     ul_ $ do
       asks hasRSS >>= rssLink
       li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink
-    div_ [class_ "articles"] (
+    div [class_ "articles"] (
         mapM_ (mDContent False (pathToRoot al) . preview) =<< getArticles al
       )
     where
       otherLink =
         toHtml <$> template (if full then "latestLink" else "allLink") []
-      rssLink :: Bool -> HtmlGenerator ()
+      rssLink :: Bool -> HtmlGenerator
       rssLink True = do
         (text, title) <- rssLinkTexts al
         li_ . a_ [href_ "rss.xml", class_ "RSS", title_ title] $ toHtml text
@@ -65,70 +71,68 @@ instance PageType ArticlesList where
 
   pathToRoot = maybe "." (\_ -> "..") . Collection.tag . collection
 
-mDContent :: Bool -> FilePath -> Markdown -> HtmlGenerator ()
-mDContent raw base markdown@(Markdown {key, body}) =
-  article_ [id_ $ pack key] (do
+mDContent :: Bool -> FilePath -> Markdown -> HtmlGenerator
+mDContent raw base markdown@(Markdown {key, Markdown.body}) =
+  article_ ! id (toValue key) (do
       header_ . h1_ $ mDLink raw base markdown
       pre_ . toHtml $ unlines body
     )
 
-mDLink :: Bool -> FilePath -> Markdown -> HtmlGenerator ()
-mDLink raw base (Markdown {Markdown.path, title}) = link $ toHtml title
+mDLink :: Bool -> FilePath -> Markdown -> HtmlGenerator
+mDLink raw base (Markdown {Markdown.path, Markdown.title}) = link $ toHtml title
   where
     link = a_ [href_ . prefix base $ path <.> (if raw then "md" else "html")]
 
 prefix :: FilePath -> FilePath -> Text
 prefix base = pack . (base </>)
 
-tag :: FilePath -> String -> HtmlGenerator ()
+tag :: FilePath -> String -> HtmlGenerator
 tag base name =
   a_ [href_ . prefix base $ name ++ "/", class_ "tag"] $ toHtml name
 
-defaultBanner :: FilePath -> HtmlGenerator ()
+defaultBanner :: FilePath -> HtmlGenerator
 defaultBanner base =
-  div_ [id_ "header"] (
+  div ! id "header" $
     a_ [href_ $ pack base] (
         h1_ . toHtml =<< asks name
       )
-    )
 
-faviconLink :: FilePath -> URL -> HtmlGenerator ()
+faviconLink :: FilePath -> URL -> HtmlGenerator
 faviconLink base url = link_ [
     rel_ "shortcut icon", href_ $ localPrefix base url, type_ "image/x-icon"
   ]
 
-optional :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator ()
-optional = maybe (return ()) 
+optional :: (a -> HtmlGenerator) -> Maybe a -> HtmlGenerator
+optional = maybe (return mempty) 
 
 navigationSection ::
-  Text -> String -> ((String, a) -> HtmlGenerator ()) -> Map String a -> HtmlGenerator ()
+  Text -> String -> ((String, a) -> HtmlGenerator) -> Map String a -> HtmlGenerator
 navigationSection sectionId templateKey generator collection
   | null collection = return ()
   | otherwise =
-      div_ [id_ sectionId, class_ "navigator"] (do
-          h2_ . toHtml =<< template templateKey []
-          ul_ . mapM_  (li_ . generator) $ Map.toList collection
-        )
+      div ! id sectionId ! class_ "navigator" $ do
+        h2 . toHtml =<< template templateKey []
+        ul $ (li . generator) <$> Map.toList collection
 
-htmlDocument :: PageType a => a -> HtmlGenerator ()
+htmlDocument :: PageType a => a -> HtmlGenerator
 htmlDocument someContent =
   let base = pathToRoot someContent in
-  doctypehtml_ (do
-      head_ (do
-          meta_ [charset_ "utf-8"]
-          title_ . toHtml =<< asks name
-          script_ [src_ $ prefix base "js/remarkable.min.js"] empty
-          script_ [src_ $ prefix base "js/hablo.js"] empty
+  docTypeHtml (do
+      H.head (do
+          meta ! charset "utf-8"
+          H.title . text =<< asks name
+          script ! src (prefix base "js/remarkable.min.js") mempty
+          script ! src (prefix base "js/hablo.js") mempty
           optional (faviconLink base) =<< (asks $skin.$favicon)
           optional (Card.make someContent) =<< (asks $urls.$cards)
-          optional toHtmlRaw =<< (asks $skin.$head)
+          optional preEscapedText =<< (asks $skin.$Blog.head)
         )
-      body_ (do
-          maybe (defaultBanner base) toHtmlRaw =<< (asks $skin.$banner)
+      H.body (do
+          maybe (defaultBanner base) preEscapedText =<< (asks $skin.$banner)
           asks tags >>= navigationSection "tags" "tagsList"
                           (\(key, _) -> tag base key)
           asks pages >>= navigationSection "pages" "pagesList"
                           (\(_, page) -> mDLink False base $ getMarkdown page)
-          div_ [id_ "contents"] $ content someContent
+          div ! id "contents" $ content someContent
         )
     )

src/DOM/Card.hs

@@ -17,14 +17,16 @@ import Control.Applicative ((<|>))
 import Control.Monad.Reader (asks)
 import qualified Data.Map as Map (lookup)
 import Data.Text (Text, pack)
-import Lucid (HtmlT, content_, meta_)
-import Lucid.Base (makeAttribute)
+--import Lucid (HtmlT, content_, meta_)
+--import Lucid.Base (makeAttribute)
 import Markdown (MarkdownContent(..), metadata)
 import Network.URL (URL)
 import qualified Markdown (Markdown(..))
 import Page (Page(..))
 import Pretty ((.$))
 import System.FilePath.Posix ((</>), (<.>))
+import Text.Blaze.Html5 ((!), AttributeValue, Html, ToValue(..), meta, customAttribute)
+import Text.Blaze.Html5.Attributes as A (content)
 
 class HasCard a where
   cardType :: Renderer m => a -> m Text
@@ -33,14 +35,13 @@ class HasCard a where
   title :: Renderer m => a -> m String
   urlPath :: Renderer m => a -> m String
 
-og :: Applicative m => Text -> Text -> HtmlT m ()
-og attribute value =
-  meta_ [
-        makeAttribute "property" $ "og:" <> attribute
-      , content_ value
-    ]
+og :: Applicative m => AttributeValue -> Text -> m Html
+og attribute t =
+  pure $ meta
+    ! (customAttribute "property" $ "og:" <> attribute)
+    ! content (toValue t)
 
-make :: (HasCard a, Renderer m) => a -> AbsoluteURL -> HtmlT m ()
+make :: (HasCard a, Renderer m) => a -> AbsoluteURL -> m Html
 make element siteURL = do
   og "url" . (pathOn siteURL) =<< urlPath element
   og "type" =<< cardType element
@@ -49,7 +50,7 @@ make element siteURL = do
   maybeImage =<< ((<|>) <$> image element <*> (asks $skin.$cardImage))
   og "site_name" =<< (asks $name.$pack)
   where
-    maybeImage = maybe (return ()) (og "image" . defaultOn siteURL)
+    maybeImage = maybe (return mempty) (og "image" . defaultOn siteURL)
 
 mDImage :: (Renderer m, MarkdownContent a) => a -> m (Maybe URL)
 mDImage = mapM checkURL . Map.lookup "featuredImage" . metadata . getMarkdown

src/RSS.hs

@@ -19,13 +19,14 @@ import Data.Map ((!))
 import qualified Data.Text.Lazy.IO as TextIO (writeFile)
 import Data.Time (defaultTimeLocale, formatTime, rfc822DateFormat)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
-import Lucid (Attribute, HtmlT, Term, ToHtml(..), term, renderTextT)
+--import Lucid (Attribute, HtmlT, Term, ToHtml(..), term, renderTextT)
 import Lucid.Base (makeAttribute)
 import Markdown (Markdown(..))
 import Pretty ((.$))
 import System.FilePath.Posix ((</>), (<.>))
+import Text.Blaze.Html (Html)
 
-prolog :: Monad m => HtmlT m ()
+prolog :: Monad m => m Html
 prolog = toHtmlRaw ("<?xml  version=\"1.0\" encoding=\"UTF-8\" ?>" :: String)
 
 version_ :: Text -> Attribute
@@ -58,7 +59,7 @@ item_ = term "item"
 pubDate_ :: Term arg result => arg -> result
 pubDate_ = term "pubDate"
 
-articleItem :: Monad m => AbsoluteURL -> Article -> HtmlT m ()
+articleItem :: Monad m => AbsoluteURL -> Article -> m Html
 articleItem siteURL (Article (Markdown {path, metadata, title})) =
   item_ $ do
     title_ $ toHtml title
@@ -69,7 +70,7 @@ articleItem siteURL (Article (Markdown {path, metadata, title})) =
         formatTime defaultTimeLocale rfc822DateFormat
       . posixSecondsToUTCTime . fromIntegral . (read :: String -> Int)
 
-feed :: Renderer m => AbsoluteURL -> ArticlesList -> HtmlT m ()
+feed :: Renderer m => AbsoluteURL -> ArticlesList -> m Html
 feed siteURL al@(ArticlesList {collection}) = do
   prolog
   rss_ [version, content, atom] $ do