From 5b1a675b94deef7741d2fa3f4c619ce3634bfa4d Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <m@jaspervdj.be>
Date: Sat, 29 Dec 2012 10:41:05 +0100
Subject: Draft tool to check internal links

---
 src/Hakyll/Web/Html.hs | 32 ++++++++++++++++++++------------
 1 file changed, 20 insertions(+), 12 deletions(-)

(limited to 'src/Hakyll/Web')

diff --git a/src/Hakyll/Web/Html.hs b/src/Hakyll/Web/Html.hs
index 3c94b2f..48482e6 100644
--- a/src/Hakyll/Web/Html.hs
+++ b/src/Hakyll/Web/Html.hs
@@ -8,6 +8,7 @@ module Hakyll.Web.Html
     , demoteHeaders
 
       -- * Url manipulation
+    , getUrls
     , withUrls
     , toUrl
     , toSiteRoot
@@ -20,16 +21,14 @@ module Hakyll.Web.Html
 
 
 --------------------------------------------------------------------------------
-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
+import           Data.Char                       (digitToInt, intToDigit,
+                                                  isDigit, toLower)
+import           Data.List                       (isPrefixOf)
+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
 
 
 --------------------------------------------------------------------------------
@@ -52,6 +51,16 @@ demoteHeaders = withTags $ \tag -> case tag of
     demote t        = t
 
 
+--------------------------------------------------------------------------------
+isUrlAttribute :: String -> Bool
+isUrlAttribute = (`elem` ["src", "href"])
+
+
+--------------------------------------------------------------------------------
+getUrls :: [TS.Tag String] -> [String]
+getUrls tags = [v | TS.TagOpen _ as <- tags, (k, v) <- as, isUrlAttribute k]
+
+
 --------------------------------------------------------------------------------
 -- | Apply a function to each URL on a webpage
 withUrls :: (String -> String) -> String -> String
@@ -59,8 +68,7 @@ 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"]
+    attr (k, v)          = (k, if isUrlAttribute k then f v else v)
 
 
 -- | Customized TagSoup renderer. (The default TagSoup renderer escape CSS
-- 
cgit v1.2.3