blob: b694149643194c98fea23c7837c0acf3852fa15d (
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
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
module Test.Haddock.Xhtml
( Xhtml(..)
, parseXhtml, dumpXhtml
, stripLinks, 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 =
Xhtml . everywhere (mkT unlink) . xhtmlElement
where
unlink attr@(Attr { attrKey = key })
| qName key == "href" = attr { attrVal = "#" }
| otherwise = attr
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"
]
|
