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 atag, @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 inwith @\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 aare 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 ' '