blob: d8c2624977f2aff50154a8c5114d778e2e3681cf (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
module Test.Haddock.Xhtml
( Xhtml(..)
, parseXhtml, dumpXhtml
, stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter
) where
import Data.Generics.Aliases
import Data.Generics.Schemes
import Text.XML.Light
newtype Xhtml = Xhtml
{ xhtmlElement :: Element
} deriving Eq
-- TODO: Find a way to avoid warning about orphan instances.
deriving instance Eq Element
deriving instance Eq Content
deriving instance Eq CData
parseXhtml :: String -> Maybe Xhtml
parseXhtml = fmap Xhtml . parseXMLDoc
dumpXhtml :: Xhtml -> String
dumpXhtml = ppElement . xhtmlElement
stripLinks :: Xhtml -> Xhtml
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
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
where
defoot el
| isFooter el = el { elContent = [] }
| otherwise = el
isFooter el = any isFooterAttr $ elAttribs el
isFooterAttr (Attr { .. }) = and
[ qName attrKey == "id"
, attrVal == "footer"
]
|
