diff options
author | Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com> | 2015-08-14 20:41:41 +0200 |
---|---|---|
committer | Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com> | 2015-08-22 23:40:27 +0200 |
commit | 1cb714e35337a6b17d7fc37f086914f43f7f2da3 (patch) | |
tree | f1d26a566cb198e6d7fe59f8e35ed090b78a6223 | |
parent | 554db03b637a76a01f2907d3115ef0dc290234c5 (diff) |
Implement utility functions for conditional link stripping.
-rw-r--r-- | haddock-test/src/Test/Haddock/Xhtml.hs | 27 |
1 files changed, 22 insertions, 5 deletions
diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs index b6941496..d8c26249 100644 --- a/haddock-test/src/Test/Haddock/Xhtml.hs +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -5,7 +5,7 @@ module Test.Haddock.Xhtml ( Xhtml(..) , parseXhtml, dumpXhtml - , stripLinks, stripFooter + , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter ) where @@ -35,14 +35,31 @@ dumpXhtml = ppElement . xhtmlElement stripLinks :: Xhtml -> Xhtml -stripLinks = - Xhtml . everywhere (mkT unlink) . xhtmlElement +stripLinks = stripLinksWhen (const True) + + +stripLinksWhen :: (String -> Bool) -> Xhtml -> Xhtml +stripLinksWhen p = + processAnchors unlink + where + unlink attr@(Attr { attrKey = key, attrVal = val }) + | qName key == "href" && p val = attr { attrVal = "#" } + | otherwise = attr + + +stripAnchorsWhen :: (String -> Bool) -> Xhtml -> Xhtml +stripAnchorsWhen p = + processAnchors unname where - unlink attr@(Attr { attrKey = key }) - | qName key == "href" = attr { attrVal = "#" } + unname attr@(Attr { attrKey = key, attrVal = val }) + | qName key == "name" && p val = attr { attrVal = "" } | otherwise = attr +processAnchors :: (Attr -> Attr) -> Xhtml -> Xhtml +processAnchors f = Xhtml . everywhere (mkT f) . xhtmlElement + + stripFooter :: Xhtml -> Xhtml stripFooter = Xhtml . everywhere (mkT defoot) . xhtmlElement |