Add demoteHeaders, refactor a bit

7 files changed, 182 insertions, 148 deletions

diff --git a/src/Hakyll.hs b/src/Hakyll.hs
index 12f14bb..1131772 100644
--- a/src/Hakyll.hs
+++ b/src/Hakyll.hs
@@ -1,5 +1,5 @@
+--------------------------------------------------------------------------------
 -- | Top-level module exporting all modules that are interesting for the user
---
 {-# LANGUAGE CPP #-}
 module Hakyll
     ( module Hakyll.Core.Compiler
@@ -20,45 +20,45 @@ module Hakyll
     , module Hakyll.Main
     , module Hakyll.Web.CompressCss
     , module Hakyll.Web.Feed
+    , module Hakyll.Web.Html
+    , module Hakyll.Web.Html.RelativizeUrls
     , module Hakyll.Web.Pandoc
     , module Hakyll.Web.Pandoc.Biblio
     , module Hakyll.Web.Pandoc.FileType
-    , module Hakyll.Web.Urls
-    , module Hakyll.Web.Urls.Relativize
     , module Hakyll.Web.Tags
     , module Hakyll.Web.Template
     , module Hakyll.Web.Template.Context
     , module Hakyll.Web.Template.List
     , module Hakyll.Web.Template.Read
-    , module Hakyll.Web.Util.Html
     ) where
 
-import Hakyll.Core.Compiler
-import Hakyll.Core.Configuration
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.Item
-import Hakyll.Core.Metadata
-import Hakyll.Core.Routes
-import Hakyll.Core.Rules
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.Compiler
+import           Hakyll.Core.Configuration
+import           Hakyll.Core.Identifier
+import           Hakyll.Core.Identifier.Pattern
+import           Hakyll.Core.Item
+import           Hakyll.Core.Metadata
+import           Hakyll.Core.Routes
+import           Hakyll.Core.Rules
 #ifdef UNIX_FILTER
-import Hakyll.Core.UnixFilter
+import           Hakyll.Core.UnixFilter
 #endif
-import Hakyll.Core.Util.File
-import Hakyll.Core.Util.String
-import Hakyll.Core.Writable
-import Hakyll.Core.Writable.CopyFile
-import Hakyll.Main
-import Hakyll.Web.CompressCss
-import Hakyll.Web.Feed
-import Hakyll.Web.Pandoc
-import Hakyll.Web.Pandoc.Biblio
-import Hakyll.Web.Pandoc.FileType
-import Hakyll.Web.Urls
-import Hakyll.Web.Urls.Relativize
-import Hakyll.Web.Tags
-import Hakyll.Web.Template
-import Hakyll.Web.Template.Context
-import Hakyll.Web.Template.List
-import Hakyll.Web.Template.Read
-import Hakyll.Web.Util.Html
+import           Hakyll.Core.Util.File
+import           Hakyll.Core.Util.String
+import           Hakyll.Core.Writable
+import           Hakyll.Core.Writable.CopyFile
+import           Hakyll.Main
+import           Hakyll.Web.CompressCss
+import           Hakyll.Web.Feed
+import           Hakyll.Web.Html
+import           Hakyll.Web.Html.RelativizeUrls
+import           Hakyll.Web.Pandoc
+import           Hakyll.Web.Pandoc.Biblio
+import           Hakyll.Web.Pandoc.FileType
+import           Hakyll.Web.Tags
+import           Hakyll.Web.Template
+import           Hakyll.Web.Template.Context
+import           Hakyll.Web.Template.List
+import           Hakyll.Web.Template.Read
diff --git a/src/Hakyll/Web/Html.hs b/src/Hakyll/Web/Html.hs
new file mode 100644
index 0000000..3c94b2f
--- /dev/null
+++ b/src/Hakyll/Web/Html.hs
@@ -0,0 +1,147 @@
+--------------------------------------------------------------------------------
+-- | Provides utilities to manipulate HTML pages
+module Hakyll.Web.Html
+    ( -- * Generic
+      withTags
+
+      -- * Headers
+    , demoteHeaders
+
+      -- * Url manipulation
+    , withUrls
+    , toUrl
+    , toSiteRoot
+    , isExternal
+
+      -- * Stripping/escaping
+    , stripTags
+    , escapeHtml
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Data.Char         (digitToInt, intToDigit, isDigit, toLower)
+import           Data.List         (isPrefixOf)
+import qualified Data.Set          as S
+import           System.FilePath   (joinPath, splitPath, takeDirectory)
+import Text.Blaze.Html (toHtml)
+import Text.Blaze.Html.Renderer.String (renderHtml)
+
+
+--------------------------------------------------------------------------------
+import qualified Text.HTML.TagSoup as TS
+
+
+--------------------------------------------------------------------------------
+-- | Map over all tags in the document
+withTags :: (TS.Tag String -> TS.Tag String) -> String -> String
+withTags f = renderTags' . map f . TS.parseTags
+
+
+--------------------------------------------------------------------------------
+-- | Map every @h1@ to an @h2@, @h2@ to @h3@, etc.
+demoteHeaders :: String -> String
+demoteHeaders = withTags $ \tag -> case tag of
+    TS.TagOpen t a -> TS.TagOpen (demote t) a
+    TS.TagClose t  -> TS.TagClose (demote t)
+    t              -> t
+  where
+    demote t@['h', n]
+        | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + 1)]
+        | otherwise = t
+    demote t        = t
+
+
+--------------------------------------------------------------------------------
+-- | Apply a function to each URL on a webpage
+withUrls :: (String -> String) -> String -> String
+withUrls f = withTags tag
+  where
+    tag (TS.TagOpen s a) = TS.TagOpen s $ map attr a
+    tag x                = x
+    attr (k, v)          = (k, if k `S.member` refs then f v else v)
+    refs                 = S.fromList ["src", "href"]
+
+
+-- | Customized TagSoup renderer. (The default TagSoup renderer escape CSS
+-- within style tags.)
+renderTags' :: [TS.Tag String] -> String
+renderTags' = TS.renderTagsOptions TS.renderOptions
+    { TS.optRawTag   = (`elem` ["script", "style"]) . map toLower
+    , TS.optMinimize = (`elem` ["br", "img"])
+    }
+
+
+--------------------------------------------------------------------------------
+-- | Convert a filepath to an URL starting from the site root
+--
+-- Example:
+--
+-- > toUrl "foo/bar.html"
+--
+-- Result:
+--
+-- > "/foo/bar.html"
+toUrl :: FilePath -> String
+toUrl ('/' : xs) = '/' : xs
+toUrl url        = '/' : url
+
+
+--------------------------------------------------------------------------------
+-- | Get the relative url to the site root, for a given (absolute) url
+toSiteRoot :: String -> String
+toSiteRoot = emptyException . joinPath . map parent
+           . filter relevant . splitPath . takeDirectory
+  where
+    parent            = const ".."
+    emptyException [] = "."
+    emptyException x  = x
+    relevant "."      = False
+    relevant "/"      = False
+    relevant _        = True
+
+
+--------------------------------------------------------------------------------
+-- | Check if an URL links to an external HTTP(S) source
+isExternal :: String -> Bool
+isExternal url = any (flip isPrefixOf url) ["http://", "https://"]
+
+
+--------------------------------------------------------------------------------
+-- | Strip all HTML tags from a string
+--
+-- Example:
+--
+-- > stripTags "<p>foo</p>"
+--
+-- Result:
+--
+-- > "foo"
+--
+-- This also works for incomplete tags
+--
+-- Example:
+--
+-- > stripTags "<p>foo</p"
+--
+-- Result:
+--
+-- > "foo"
+stripTags :: String -> String
+stripTags []         = []
+stripTags ('<' : xs) = stripTags $ drop 1 $ dropWhile (/= '>') xs
+stripTags (x : xs)   = x : stripTags xs
+
+
+--------------------------------------------------------------------------------
+-- | HTML-escape a string
+--
+-- Example:
+--
+-- > escapeHtml "Me & Dean"
+--
+-- Result:
+--
+-- > "Me &amp; Dean"
+escapeHtml :: String -> String
+escapeHtml = renderHtml . toHtml
diff --git a/src/Hakyll/Web/Urls/Relativize.hs b/src/Hakyll/Web/Html/RelativizeUrls.hs
index 321bbe3..33b0c2c 100644
--- a/src/Hakyll/Web/Urls/Relativize.hs
+++ b/src/Hakyll/Web/Html/RelativizeUrls.hs
@@ -14,7 +14,7 @@
 -- will result in (suppose your blogpost is located at @\/posts\/foo.html@:
 --
 -- > <img src="../images/lolcat.png" alt="Funny zomgroflcopter" />
-module Hakyll.Web.Urls.Relativize
+module Hakyll.Web.Html.RelativizeUrls
     ( relativizeUrls
     , relativizeUrlsWith
     ) where
@@ -27,7 +27,7 @@ import           Data.List            (isPrefixOf)
 --------------------------------------------------------------------------------
 import           Hakyll.Core.Compiler
 import           Hakyll.Core.Item
-import           Hakyll.Web.Urls
+import           Hakyll.Web.Html
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs
index a2e4544..bf2b9d7 100644
--- a/src/Hakyll/Web/Tags.hs
+++ b/src/Hakyll/Web/Tags.hs
@@ -83,7 +83,7 @@ import           Hakyll.Core.Metadata
 import           Hakyll.Core.Rules
 import           Hakyll.Core.Util.String
 import           Hakyll.Web.Template.Context
-import           Hakyll.Web.Urls
+import           Hakyll.Web.Html
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Hakyll/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs
index c2ec6bc..7d359b4 100644
--- a/src/Hakyll/Web/Template/Context.hs
+++ b/src/Hakyll/Web/Template/Context.hs
@@ -40,7 +40,7 @@ import           Hakyll.Core.Item
 import           Hakyll.Core.Metadata
 import           Hakyll.Core.Provider
 import           Hakyll.Core.Util.String       (splitAll)
-import           Hakyll.Web.Urls
+import           Hakyll.Web.Html
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Hakyll/Web/Urls.hs b/src/Hakyll/Web/Urls.hs
deleted file mode 100644
index 1cd0816..0000000
--- a/src/Hakyll/Web/Urls.hs
+++ /dev/null
@@ -1,66 +0,0 @@
--- | Provides utilities to manipulate URL's
---
-module Hakyll.Web.Urls
-    ( withUrls
-    , toUrl
-    , toSiteRoot
-    , isExternal
-    ) where
-
-import Data.List (isPrefixOf)
-import Data.Char (toLower)
-import System.FilePath (splitPath, takeDirectory, joinPath)
-import qualified Data.Set as S
-
-import qualified Text.HTML.TagSoup as TS
-
--- | Apply a function to each URL on a webpage
---
-withUrls :: (String -> String) -> String -> String
-withUrls f = renderTags' . map tag . TS.parseTags
-  where
-    tag (TS.TagOpen s a) = TS.TagOpen s $ map attr a
-    tag x                = x
-    attr (k, v)          = (k, if k `S.member` refs then f v else v)
-    refs                 = S.fromList ["src", "href"]
-
--- | Customized TagSoup renderer. (The default TagSoup renderer escape CSS
--- within style tags.)
---
-renderTags' :: [TS.Tag String] -> String
-renderTags' = TS.renderTagsOptions TS.renderOptions
-    { TS.optRawTag   = (`elem` ["script", "style"]) . map toLower
-    , TS.optMinimize = (`elem` ["br", "img"])
-    }
-
--- | Convert a filepath to an URL starting from the site root
---
--- Example:
---
--- > toUrl "foo/bar.html"
---
--- Result:
---
--- > "/foo/bar.html"
---
-toUrl :: FilePath -> String
-toUrl ('/' : xs) = '/' : xs
-toUrl url        = '/' : url
-
--- | Get the relative url to the site root, for a given (absolute) url
---
-toSiteRoot :: String -> String
-toSiteRoot = emptyException . joinPath . map parent
-           . filter relevant . splitPath . takeDirectory
-  where
-    parent            = const ".."
-    emptyException [] = "."
-    emptyException x  = x
-    relevant "."      = False
-    relevant "/"      = False
-    relevant _        = True
-
--- | Check if an URL links to an external HTTP(S) source
---
-isExternal :: String -> Bool
-isExternal url = any (flip isPrefixOf url) ["http://", "https://"]
diff --git a/src/Hakyll/Web/Util/Html.hs b/src/Hakyll/Web/Util/Html.hs
deleted file mode 100644
index a413f84..0000000
--- a/src/Hakyll/Web/Util/Html.hs
+++ /dev/null
@@ -1,47 +0,0 @@
--- | Miscellaneous HTML manipulation functions
---
-module Hakyll.Web.Util.Html
-    ( stripTags
-    , escapeHtml
-    ) where
-
-import Text.Blaze.Html (toHtml)
-import Text.Blaze.Html.Renderer.String (renderHtml)
-
--- | Strip all HTML tags from a string
---
--- Example:
---
--- > stripTags "<p>foo</p>"
---
--- Result:
---
--- > "foo"
---
--- This also works for incomplete tags
---
--- Example:
---
--- > stripTags "<p>foo</p"
---
--- Result:
---
--- > "foo"
---
-stripTags :: String -> String
-stripTags []         = []
-stripTags ('<' : xs) = stripTags $ drop 1 $ dropWhile (/= '>') xs
-stripTags (x : xs)   = x : stripTags xs
-
--- | HTML-escape a string
---
--- Example:
---
--- > escapeHtml "Me & Dean"
---
--- Result:
---
--- > "Me &amp; Dean"
---
-escapeHtml :: String -> String
-escapeHtml = renderHtml . toHtml