diff --git a/hakyll.cabal b/hakyll.cabal index 53a8005d0..7a0f43786 100644 --- a/hakyll.cabal +++ b/hakyll.cabal @@ -150,6 +150,7 @@ Library Hakyll.Web.CompressCss Hakyll.Web.Feed Hakyll.Web.Html + Hakyll.Web.Html.Compress Hakyll.Web.Html.RelativizeUrls Hakyll.Web.Meta.JSONLD Hakyll.Web.Meta.OpenGraph diff --git a/lib/Hakyll.hs b/lib/Hakyll.hs index c0098c049..48e11a909 100644 --- a/lib/Hakyll.hs +++ b/lib/Hakyll.hs @@ -19,6 +19,7 @@ module Hakyll , module Hakyll.Web.CompressCss , module Hakyll.Web.Feed , module Hakyll.Web.Html + , module Hakyll.Web.Html.Compress , module Hakyll.Web.Html.RelativizeUrls , module Hakyll.Web.Meta.JSONLD , module Hakyll.Web.Meta.OpenGraph @@ -55,6 +56,7 @@ import Hakyll.Main import Hakyll.Web.CompressCss import Hakyll.Web.Feed import Hakyll.Web.Html +import Hakyll.Web.Html.Compress import Hakyll.Web.Html.RelativizeUrls import Hakyll.Web.Meta.JSONLD import Hakyll.Web.Meta.OpenGraph diff --git a/lib/Hakyll/Web/Html/Compress.hs b/lib/Hakyll/Web/Html/Compress.hs new file mode 100644 index 000000000..85f31be76 --- /dev/null +++ b/lib/Hakyll/Web/Html/Compress.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +-------------------------------------------------------------------------------- +-- | This module exposes a function to compress the HTML output. +-- +-- The compression is very basic, shaving off about 1-3% of a typical HTML output, +-- and it works as follows: +-- +-- * Comments are removed. +-- * Several consecutive whitespaces are replaced by a single one, unless within a
 tag.
+-- * Within a 
 tag, @n@ consecutive whitespaces are replaced by a single @\t@ character.
+--   This is useful if a page is heavy on code listings.
+--   Don't forget to add @tab-size: n@ to your CSS!
+--
+-- Any of these steps can be disabled, see 'CompressHtmlOpts'.
+
+module Hakyll.Web.Html.Compress
+  ( CompressHtmlOpts(..)
+  , def
+  , compressHtml
+  , compressHtmlCompiler
+  ) where
+
+import           Data.Char
+import           Data.Default
+import qualified Data.Set as S
+import           Hakyll.Core.Compiler
+import           Hakyll.Core.Item
+import           Hakyll.Web.Html
+import           Text.HTML.TagSoup
+
+-- | The configuration for the HTML compression.
+data CompressHtmlOpts = CompressHtmlOpts
+  { choRemoveComments :: Bool          -- ^ Whether to remove comments.
+  , choCompressWhitespace :: Bool      -- ^ Whether to remove excessive whitespaces.
+  , choTabSize :: Maybe Int            -- ^ Replace this many spaces in 
 with @\t@ (if 'choCompressWhitespace' is set).
+  }
+
+instance Default CompressHtmlOpts where
+  def = CompressHtmlOpts
+          { choRemoveComments = True
+          , choCompressWhitespace = True
+          , choTabSize = Nothing
+          }
+
+-- | Compiler form of 'compressHtml'.
+compressHtmlCompiler :: CompressHtmlOpts -> Item String -> Compiler (Item String)
+compressHtmlCompiler opts item = pure $ compressHtml opts <$> item
+
+-- | Compresses an HTML string according to the given configuration.
+compressHtml :: CompressHtmlOpts -> String -> String
+compressHtml CompressHtmlOpts{ .. } = withTagList go
+  where
+    go = foldr (.) id
+        $ [ f
+          | (True, f) <- [ (choRemoveComments, removeComments)
+                         , (choCompressWhitespace, compressWS choTabSize)
+                         ]
+          ]
+
+removeComments :: [Tag String] -> [Tag String]
+removeComments = filter (not . isTagComment)
+
+compressWS :: Maybe Int -> [Tag String] -> [Tag String]
+compressWS maybeTabSize = go mempty
+  where
+    go stack =
+      \case [] -> []
+            (tag@(TagClose n) : rest) -> tag : go (S.delete n stack) rest
+            (tag@(TagOpen n _) : rest) -> tag : go (S.insert n stack) rest
+            (tag@(TagText text) : rest)
+              -- all spaces within a 
 are important, but we can replace them with tabs
+              | "pre" `S.member` stack -> case maybeTabSize of
+                                               Nothing -> tag : go stack rest
+                                               Just tabSize -> TagText (collapseIntoTabs (tabSize - 1) text) : go stack rest
+              | otherwise -> let text' = collapseSpaces text
+                              in case text' of
+                                      [] -> go stack rest
+                                      _  -> TagText text' : go stack rest
+            (tag : rest) -> tag : go stack rest
+
+collapseSpaces :: String -> String
+collapseSpaces = go
+  where
+    go [] = []
+    go [c] = [c]
+    go (c1 : c2 : rest)
+      | isSpace c1 && isSpace c2 = go (c2 : rest)
+      | otherwise = c1 : go (c2 : rest)
+
+collapseIntoTabs :: Int -> String -> String
+collapseIntoTabs n = go
+  where
+    go [] = []
+    go (' ':cs)
+      | (pref, rest) <- splitAt n cs
+      , pref == pat = '\t' : go rest
+    go (c:cs) = c : go cs
+
+    pat = replicate n ' '