diff --git a/utils/haddock/haddock-test/src/Test/Haddock/Xhtml.hs b/utils/haddock/haddock-test/src/Test/Haddock/Xhtml.hs
index 24ac2dad9692453f6443679cbd53a7852621ee1c..1a105a392e5f3a491f68ea79e8823fea581d17c1 100644
--- a/utils/haddock/haddock-test/src/Test/Haddock/Xhtml.hs
+++ b/utils/haddock/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -8,6 +8,7 @@ module Test.Haddock.Xhtml
, stripIdsWhen
, stripFooter
, fixAttrValueWhen
+ , stripVersions
) where
{-
@@ -22,7 +23,7 @@ and since the `xhtml` library already handles the pretty-printing aspect,
this would appear to be a reasonable compromise for now.
-}
-import Data.Char (isSpace)
+import Data.Char (isSpace, isAlphaNum)
import Data.List (isPrefixOf, stripPrefix)
-- | Simple wrapper around the pretty-printed HTML source
@@ -142,3 +143,18 @@ stripFooter (Xml body) = Xml (findDiv body)
Just valRest''
| otherwise =
dropToDiv cs
+
+-- | Strip strings of the form <pkg>-<version>-<hash>
+-- to just <pkg>
+stripVersions :: [String] -> Xml -> Xml
+stripVersions xs (Xml body) = Xml $ foldr id body $ map go xs
+ where
+ go pkg "" = ""
+ go pkg body@(x:body') = case stripPrefix pkg body of
+ Just ('-':rest)
+ | (version,'-':rest') <- span (/= '-') rest
+ , all (`elem` ('.':['0'..'9'])) version
+ , let (hash, rest'') = span isAlphaNum rest'
+ -> pkg ++ go pkg rest''
+ _ -> x:go pkg body'
+
diff --git a/utils/haddock/html-test/Main.hs b/utils/haddock/html-test/Main.hs
index 9262c0f3b9d165039449e06ba6fc192050563e4c..732d19bc77ab9fbd48cc4a8a6d51b8c1091048c8 100755
--- a/utils/haddock/html-test/Main.hs
+++ b/utils/haddock/html-test/Main.hs
@@ -42,7 +42,7 @@ main = do
stripIfRequired :: String -> Xml -> Xml
stripIfRequired mdl =
- stripLinks' . stripFooter
+ stripLinks' . stripFooter . stripVersions ["base"]
where
stripLinks'
| mdl `elem` preserveLinksModules = id
diff --git a/utils/haddock/html-test/ref/Bug1004.html b/utils/haddock/html-test/ref/Bug1004.html
index 5d75ef84f3f0a91166e41f25c5016029f34c1089..819aa55199178c20eaaf64e2ee8caa8410596779 100644
--- a/utils/haddock/html-test/ref/Bug1004.html
+++ b/utils/haddock/html-test/ref/Bug1004.html
@@ -210,7 +210,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "Product" "Data.Functor.Product" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "Product" "Data.Functor.Product" "base" '<a href="#" title="Data.Bool"
>False</a
>) (<a href="#" title="GHC.Generics"
>C1</a
@@ -2037,7 +2037,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "Product" "Data.Functor.Product" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "Product" "Data.Functor.Product" "base" '<a href="#" title="Data.Bool"
>False</a
>) (<a href="#" title="GHC.Generics"
>C1</a
@@ -2510,7 +2510,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "Product" "Data.Functor.Product" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "Product" "Data.Functor.Product" "base" '<a href="#" title="Data.Bool"
>False</a
>) (<a href="#" title="GHC.Generics"
>C1</a
@@ -2604,7 +2604,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "Product" "Data.Functor.Product" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "Product" "Data.Functor.Product" "base" '<a href="#" title="Data.Bool"
>False</a
>) (<a href="#" title="GHC.Generics"
>C1</a
diff --git a/utils/haddock/html-test/ref/Bug548.html b/utils/haddock/html-test/ref/Bug548.html
index 5dc51aa8a7fabb85d60cfde9b39541e74a63ea84..5102d97211966742e8280cdceef5319172384d76 100644
--- a/utils/haddock/html-test/ref/Bug548.html
+++ b/utils/haddock/html-test/ref/Bug548.html
@@ -186,7 +186,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "WrappedArrow" "Control.Applicative" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "WrappedArrow" "Control.Applicative" "base" '<a href="#" title="Data.Bool"
>True</a
>) (<a href="#" title="GHC.Generics"
>C1</a
@@ -792,7 +792,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "WrappedArrow" "Control.Applicative" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "WrappedArrow" "Control.Applicative" "base" '<a href="#" title="Data.Bool"
>True</a
>) (<a href="#" title="GHC.Generics"
>C1</a
@@ -903,7 +903,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "WrappedArrow" "Control.Applicative" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "WrappedArrow" "Control.Applicative" "base" '<a href="#" title="Data.Bool"
>True</a
>) (<a href="#" title="GHC.Generics"
>C1</a
@@ -973,7 +973,7 @@
>D1</a
> ('<a href="#" title="GHC.Generics"
>MetaData</a
- > "WrappedArrow" "Control.Applicative" "base-4.20.0.0-inplace" '<a href="#" title="Data.Bool"
+ > "WrappedArrow" "Control.Applicative" "base" '<a href="#" title="Data.Bool"
>True</a
>) (<a href="#" title="GHC.Generics"
>C1</a