Add demoteHeaders, refactor a bit

hakyll.cabal

@@ -126,6 +126,8 @@ Library
     Hakyll.Main
     Hakyll.Web.CompressCss
     Hakyll.Web.Feed
+    Hakyll.Web.Html
+    Hakyll.Web.Html.RelativizeUrls
     Hakyll.Web.Pandoc
     Hakyll.Web.Pandoc.Biblio
     Hakyll.Web.Pandoc.FileType
@@ -134,9 +136,6 @@ Library
     Hakyll.Web.Template.Context
     Hakyll.Web.Template.List
     Hakyll.Web.Template.Read
-    Hakyll.Web.Urls
-    Hakyll.Web.Urls.Relativize
-    Hakyll.Web.Util.Html
 
   Other-Modules:
     Hakyll.Core.Compiler.Internal
@@ -223,9 +222,8 @@ Test-suite hakyll-tests
     Hakyll.Core.Util.String.Tests
     Hakyll.Web.Template.Context.Tests
     Hakyll.Web.Template.Tests
-    Hakyll.Web.Urls.Tests
-    Hakyll.Web.Urls.Relativize.Tests
-    Hakyll.Web.Util.Html.Tests
+    Hakyll.Web.Html.Tests
+    Hakyll.Web.Html.RelativizeUrls.Tests
     TestSuite.Util
 
 Executable hakyll-init

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

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

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
 
 
 --------------------------------------------------------------------------------

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
 
 
 --------------------------------------------------------------------------------

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
 
 
 --------------------------------------------------------------------------------

src/Hakyll/Web/Urls.hs

@@ -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://"]

src/Hakyll/Web/Util/Html.hs

@@ -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

tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs

@@ -1,22 +1,22 @@
 --------------------------------------------------------------------------------
 {-# LANGUAGE OverloadedStrings #-}
-module Hakyll.Web.Urls.Relativize.Tests
+module Hakyll.Web.Html.RelativizeUrls.Tests
     ( tests
     ) where
 
 
 --------------------------------------------------------------------------------
-import           Test.Framework             (Test, testGroup)
-import           Test.HUnit                 ((@=?))
+import           Test.Framework                 (Test, testGroup)
+import           Test.HUnit                     ((@=?))
 
 --------------------------------------------------------------------------------
-import           Hakyll.Web.Urls.Relativize
+import           Hakyll.Web.Html.RelativizeUrls
 import           TestSuite.Util
 
 
 --------------------------------------------------------------------------------
 tests :: Test
-tests = testGroup "Hakyll.Web.Urls.Relativize.Tests" $
+tests = testGroup "Hakyll.Web.Html.RelativizeUrls.Tests" $
     fromAssertions "relativizeUrls"
         [ "<a href=\"../foo\">bar</a>" @=?
             relativizeUrlsWith ".." "<a href=\"/foo\">bar</a>"

tests/Hakyll/Web/Html/Tests.hs

@@ -1,5 +1,5 @@
 --------------------------------------------------------------------------------
-module Hakyll.Web.Urls.Tests
+module Hakyll.Web.Html.Tests
     ( tests
     ) where
 
@@ -11,14 +11,19 @@ import           Test.HUnit      (assert, (@=?))
 
 
 --------------------------------------------------------------------------------
-import           Hakyll.Web.Urls
+import           Hakyll.Web.Html
 import           TestSuite.Util
 
 
 --------------------------------------------------------------------------------
 tests :: Test
-tests = testGroup "Hakyll.Web.Urls.Tests" $ concat
-    [ fromAssertions "withUrls"
+tests = testGroup "Hakyll.Web.Html.Tests" $ concat
+    [ fromAssertions "demoteHeaders"
+        [ "<h2>A h1 title</h2>" @=?
+            demoteHeaders "<h1>A h1 title</h1>"
+        ]
+
+    , fromAssertions "withUrls"
         [ "<a href=\"FOO\">bar</a>" @=?
             withUrls (map toUpper) "<a href=\"foo\">bar</a>"
         , "<img src=\"OH BAR\" />" @=?
@@ -52,4 +57,15 @@ tests = testGroup "Hakyll.Web.Urls.Tests" $ concat
         , assert (not (isExternal "../header.png"))
         , assert (not (isExternal "/foo/index.html"))
         ]
+
+    , fromAssertions "stripTags"
+        [ "foo"     @=? stripTags "<p>foo</p>"
+        , "foo bar" @=? stripTags "<p>foo</p> bar"
+        , "foo"     @=? stripTags "<p>foo</p"
+        ]
+
+    , fromAssertions "escapeHtml"
+        [ "Me &amp; Dean" @=? escapeHtml "Me & Dean"
+        , "&lt;img&gt;"   @=? escapeHtml "<img>"
+        ]
     ]

tests/Hakyll/Web/Util/Html/Tests.hs

@@ -1,29 +0,0 @@
---------------------------------------------------------------------------------
-module Hakyll.Web.Util.Html.Tests
-    ( tests
-    ) where
-
-
---------------------------------------------------------------------------------
-import           Test.Framework       (Test, testGroup)
-import           Test.HUnit           ((@=?))
-
-
---------------------------------------------------------------------------------
-import           Hakyll.Web.Util.Html
-import           TestSuite.Util
-
-
---------------------------------------------------------------------------------
-tests :: Test
-tests = testGroup "Hakyll.Web.Util.Html" $ concat
-    [ fromAssertions "stripTags"
-        [ "foo"     @=? stripTags "<p>foo</p>"
-        , "foo bar" @=? stripTags "<p>foo</p> bar"
-        , "foo"     @=? stripTags "<p>foo</p"
-        ]
-    , fromAssertions "escapeHtml"
-        [ "Me &amp; Dean" @=? escapeHtml "Me & Dean"
-        , "&lt;img&gt;"   @=? escapeHtml "<img>"
-        ]
-    ]

tests/TestSuite.hs

@@ -5,7 +5,7 @@ module Main
 
 
 --------------------------------------------------------------------------------
-import           Test.Framework                    (defaultMain)
+import           Test.Framework                       (defaultMain)
 
 
 --------------------------------------------------------------------------------
@@ -18,11 +18,10 @@ import qualified Hakyll.Core.Runtime.Tests
 import qualified Hakyll.Core.Store.Tests
 import qualified Hakyll.Core.UnixFilter.Tests
 import qualified Hakyll.Core.Util.String.Tests
+import qualified Hakyll.Web.Html.RelativizeUrls.Tests
+import qualified Hakyll.Web.Html.Tests
 import qualified Hakyll.Web.Template.Context.Tests
 import qualified Hakyll.Web.Template.Tests
-import qualified Hakyll.Web.Urls.Relativize.Tests
-import qualified Hakyll.Web.Urls.Tests
-import qualified Hakyll.Web.Util.Html.Tests
 
 
 --------------------------------------------------------------------------------
@@ -37,9 +36,8 @@ main = defaultMain
     , Hakyll.Core.Store.Tests.tests
     , Hakyll.Core.UnixFilter.Tests.tests
     , Hakyll.Core.Util.String.Tests.tests
+    , Hakyll.Web.Html.RelativizeUrls.Tests.tests
+    , Hakyll.Web.Html.Tests.tests
     , Hakyll.Web.Template.Context.Tests.tests
     , Hakyll.Web.Template.Tests.tests
-    , Hakyll.Web.Urls.Relativize.Tests.tests
-    , Hakyll.Web.Urls.Tests.tests
-    , Hakyll.Web.Util.Html.Tests.tests
     ]