1 files changed, 21 insertions, 7 deletions
diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs
index 8bfc973f..6c19dbca 100644
--- a/haddock-test/src/Test/Haddock/Xhtml.hs
+++ b/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -1,17 +1,17 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GADTs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Test.Haddock.Xhtml
     ( Xml(..)
     , parseXml, dumpXml
-    , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter
+    , stripLinks, stripLinksWhen, stripAnchorsWhen, stripIdsWhen, stripFooter
     ) where
 
-
-import Data.Generics.Aliases
-import Data.Generics.Schemes
-
+import Data.Data ( Data(..), Typeable, eqT, (:~:)(..) )
 import Text.XML.Light
 import Text.XHtml (Html, HtmlAttr, (!))
 import qualified Text.XHtml as Xhtml
@@ -26,6 +26,12 @@ deriving instance Eq Element
 deriving instance Eq Content
 deriving instance Eq CData
 
+-- | Similar to @everywhere (mkT f) x@ from SYB.
+gmapEverywhere :: forall a b. (Data a, Typeable b) => (b -> b) -> a -> a
+gmapEverywhere f x = gmapT (gmapEverywhere f) $ case eqT @a @b of
+                                                  Nothing -> x
+                                                  Just Refl -> f x
+
 
 parseXml :: String -> Maybe Xml
 parseXml = fmap Xml . parseXMLDoc
@@ -56,14 +62,22 @@ stripAnchorsWhen p =
         | qName key == "name" && p val = attr { attrVal = "" }
         | otherwise = attr
 
+stripIdsWhen :: (String -> Bool) -> Xml -> Xml
+stripIdsWhen p =
+    processAnchors unname
+  where
+    unname attr@(Attr { attrKey = key, attrVal = val })
+        | qName key == "id" && p val = attr { attrVal = "" }
+        | otherwise = attr
+
 
 processAnchors :: (Attr -> Attr) -> Xml -> Xml
-processAnchors f = Xml . everywhere (mkT f) . xmlElement
+processAnchors f = Xml . gmapEverywhere f . xmlElement
 
 
 stripFooter :: Xml -> Xml
 stripFooter =
-    Xml . everywhere (mkT defoot) . xmlElement
+    Xml . gmapEverywhere defoot . xmlElement
   where
     defoot el
         | isFooter el = el { elContent = [] }