Bifoldable and Bitraversable for DocH and MetaDoc

2 files changed, 62 insertions, 1 deletions

diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md
index c52908e1..53d17f5e 100644
--- a/haddock-library/CHANGES.md
+++ b/haddock-library/CHANGES.md
@@ -2,7 +2,7 @@
 
  * to be released
 
- * Bifunctor instance for DocH
+ * Bifunctor, Bifoldable and Bitraversable instances for DocH and MetaDoc
 
 ## Changes in version 1.4.5
 
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index 22cab425..48b29075 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -24,6 +24,11 @@ import Control.Arrow ((***))
 import Data.Bifunctor
 #endif
 
+#if MIN_VERSION_base(4,10,0)
+import Data.Bifoldable
+import Data.Bitraversable
+#endif
+
 -- | With the advent of 'Version', we may want to start attaching more
 -- meta-data to comments. We make a structure for this ahead of time
 -- so we don't have to gut half the core each time we want to add such
@@ -35,6 +40,19 @@ data MetaDoc mod id =
           , _doc :: DocH mod id
           } deriving (Eq, Show, Functor, Foldable, Traversable)
 
+#if MIN_VERSION_base(4,8,0)
+instance Bifunctor MetaDoc where
+  bimap f g (MetaDoc m d) = MetaDoc m (bimap f g d)
+#endif
+
+#if MIN_VERSION_base(4,10,0)
+instance Bifoldable MetaDoc where
+  bifoldr f g z d = bifoldr f g z (_doc d)
+
+instance Bitraversable MetaDoc where
+  bitraverse f g (MetaDoc m d) = MetaDoc m <$> bitraverse f g d
+#endif
+
 overDoc :: (DocH a b -> DocH c d) -> MetaDoc a b -> MetaDoc c d
 overDoc f d = d { _doc = f $ _doc d }
 
@@ -113,6 +131,49 @@ instance Bifunctor DocH where
   bimap f g (DocHeader (Header level title)) = DocHeader (Header level (bimap f g title))
 #endif
 
+#if MIN_VERSION_base(4,10,0)
+instance Bifoldable DocH where
+  bifoldr f g z (DocAppend docA docB) = bifoldr f g (bifoldr f g z docA) docB
+  bifoldr f g z (DocParagraph doc) = bifoldr f g z doc
+  bifoldr _ g z (DocIdentifier i) = g i z
+  bifoldr f _ z (DocIdentifierUnchecked m) = f m z
+  bifoldr f g z (DocWarning doc) = bifoldr f g z doc
+  bifoldr f g z (DocEmphasis doc) = bifoldr f g z doc
+  bifoldr f g z (DocMonospaced doc) = bifoldr f g z doc
+  bifoldr f g z (DocBold doc) = bifoldr f g z doc
+  bifoldr f g z (DocUnorderedList docs) = foldr (flip (bifoldr f g)) z docs
+  bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z docs
+  bifoldr f g z (DocDefList docs) = foldr (\(l, r) acc -> bifoldr f g (bifoldr f g acc l) r) z docs
+  bifoldr f g z (DocCodeBlock doc) = bifoldr f g z doc
+  bifoldr f g z (DocHeader (Header _ title)) = bifoldr f g z title
+  bifoldr _ _ z _ = z
+
+instance Bitraversable DocH where
+  bitraverse _ _ DocEmpty = pure DocEmpty
+  bitraverse f g (DocAppend docA docB) = DocAppend <$> bitraverse f g docA <*> bitraverse f g docB
+  bitraverse _ _ (DocString s) = pure (DocString s)
+  bitraverse f g (DocParagraph doc) = DocParagraph <$> bitraverse f g doc
+  bitraverse _ g (DocIdentifier i) = DocIdentifier <$> g i
+  bitraverse f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked <$> f m
+  bitraverse _ _ (DocModule s) = pure (DocModule s)
+  bitraverse f g (DocWarning doc) = DocWarning <$> bitraverse f g doc
+  bitraverse f g (DocEmphasis doc) = DocEmphasis <$> bitraverse f g doc
+  bitraverse f g (DocMonospaced doc) = DocMonospaced <$> bitraverse f g doc
+  bitraverse f g (DocBold doc) = DocBold <$> bitraverse f g doc
+  bitraverse f g (DocUnorderedList docs) = DocUnorderedList <$> traverse (bitraverse f g) docs
+  bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverse (bitraverse f g) docs
+  bitraverse f g (DocDefList docs) = DocDefList <$> traverse (bitraverse (bitraverse f g) (bitraverse f g)) docs
+  bitraverse f g (DocCodeBlock doc) = DocCodeBlock <$> bitraverse f g doc
+  bitraverse _ _ (DocHyperlink hyperlink) = pure (DocHyperlink hyperlink)
+  bitraverse _ _ (DocPic picture) = pure (DocPic picture)
+  bitraverse _ _ (DocMathInline s) = pure (DocMathInline s)
+  bitraverse _ _ (DocMathDisplay s) = pure (DocMathDisplay s)
+  bitraverse _ _ (DocAName s) = pure (DocAName s)
+  bitraverse _ _ (DocProperty s) = pure (DocProperty s)
+  bitraverse _ _ (DocExamples examples) = pure (DocExamples examples)
+  bitraverse f g (DocHeader (Header level title)) = (DocHeader . Header level) <$> bitraverse f g title
+#endif
+
 -- | 'DocMarkupH' is a set of instructions for marking up documentation.
 -- In fact, it's really just a mapping from 'Doc' to some other
 -- type [a], where [a] is usually the type of the output (HTML, say).