Allow demotion of headers by a given amount (#855)

2 files changed, 22 insertions, 3 deletions

diff --git a/lib/Hakyll/Web/Html.hs b/lib/Hakyll/Web/Html.hs
index 8cbfaa3..7aa3804 100644
--- a/lib/Hakyll/Web/Html.hs
+++ b/lib/Hakyll/Web/Html.hs
@@ -7,6 +7,7 @@ module Hakyll.Web.Html
 
       -- * Headers
     , demoteHeaders
+    , demoteHeadersBy
 
       -- * Url manipulation
     , getUrls
@@ -50,13 +51,20 @@ withTagList f = renderTags' . f . parseTags'
 --------------------------------------------------------------------------------
 -- | Map every @h1@ to an @h2@, @h2@ to @h3@, etc.
 demoteHeaders :: String -> String
-demoteHeaders = withTags $ \tag -> case tag of
+demoteHeaders = demoteHeadersBy 1
+
+--------------------------------------------------------------------------------
+-- | Maps any @hN@ to an @hN+amount@ for any @amount > 0 && 1 <= N+amount <= 6@.
+demoteHeadersBy :: Int -> String -> String
+demoteHeadersBy amount
+  | amount < 1 = id
+  | otherwise = 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)]
+        | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + amount)]
         | otherwise = t
     demote t        = t
 
diff --git a/tests/Hakyll/Web/Html/Tests.hs b/tests/Hakyll/Web/Html/Tests.hs
index cd362f4..9ab10bc 100644
--- a/tests/Hakyll/Web/Html/Tests.hs
+++ b/tests/Hakyll/Web/Html/Tests.hs
@@ -20,7 +20,18 @@ tests :: TestTree
 tests = testGroup "Hakyll.Web.Html.Tests" $ concat
     [ fromAssertions "demoteHeaders"
         [ "<h2>A h1 title</h2>" @=?
-            demoteHeaders "<h1>A h1 title</h1>"
+            demoteHeaders "<h1>A h1 title</h1>" -- Assert single-step demotion
+        , "<h6>A h6 title</h6>" @=?
+            demoteHeaders "<h6>A h6 title</h6>" -- Assert maximum demotion is h6
+        ]
+
+    , fromAssertions "demoteHeadersBy"
+        [ "<h3>A h1 title</h3>" @=?
+            demoteHeadersBy 2 "<h1>A h1 title</h1>"
+        , "<h6>A h5 title</h6>" @=?
+            demoteHeadersBy 2 "<h5>A h5 title</h5>" -- Assert that h6 is the lowest possible demoted header.
+        , "<h4>A h4 title</h4>" @=?
+            demoteHeadersBy 0 "<h4>A h4 title</h4>" -- Assert that a demotion of @N < 1@ is a no-op.
         ]
 
     , fromAssertions "withUrls"