summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLogan McGrath <81108848+ThisFieldWasGreen@users.noreply.github.com>2021-06-06 10:50:44 -0700
committerGitHub <noreply@github.com>2021-06-06 20:50:44 +0300
commit6d9bc845d5233c67e5eba3f54dcc7772ca1d79e2 (patch)
tree5f1529b2f002b18e27335bd08d42e84d09a0009e
parent591fbe693d87b84c73b1839acdd424cbc12da3b3 (diff)
downloadhakyll-6d9bc845d5233c67e5eba3f54dcc7772ca1d79e2.tar.gz
Allow demotion of headers by a given amount (#855)
-rw-r--r--lib/Hakyll/Web/Html.hs12
-rw-r--r--tests/Hakyll/Web/Html/Tests.hs13
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"