From 08db4c81ffac672a4a5a90291be70279e9a1f098 Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Mon, 28 Jul 2014 14:31:03 +0200
Subject: Fix #313 by doing some list munging.

I get rid of the Monoid instance because we weren't satisfying the laws.
Convenience of having <> didn't outweigh the shock-factor of having it
behave badly.
---
 src/Haddock/Doc.hs                  | 3 +--
 src/Haddock/Interface/Create.hs     | 7 +++++--
 src/Haddock/Interface/LexParseRn.hs | 4 ++--
 3 files changed, 8 insertions(+), 6 deletions(-)

(limited to 'src/Haddock')

diff --git a/src/Haddock/Doc.hs b/src/Haddock/Doc.hs
index 79a59ac2..91ad709f 100644
--- a/src/Haddock/Doc.hs
+++ b/src/Haddock/Doc.hs
@@ -5,14 +5,13 @@ module Haddock.Doc ( module Documentation.Haddock.Doc
                    ) where
 
 import Data.Maybe
-import Data.Monoid
 import Documentation.Haddock.Doc
 import Haddock.Types
 
 combineDocumentation :: Documentation name -> Maybe (Doc name)
 combineDocumentation (Documentation Nothing Nothing) = Nothing
 combineDocumentation (Documentation mDoc mWarning)   =
-  Just (fromMaybe mempty mWarning <> fromMaybe mempty mDoc)
+  Just (fromMaybe DocEmpty mWarning `docAppend` fromMaybe DocEmpty mDoc)
 
 -- Drop trailing whitespace from @..@ code blocks.  Otherwise this:
 --
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index bc615cde..cf7ed841 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -14,7 +14,7 @@
 -----------------------------------------------------------------------------
 module Haddock.Interface.Create (createInterface) where
 
-
+import Documentation.Haddock.Doc (docAppend)
 import Haddock.Types
 import Haddock.Options
 import Haddock.GhcUtils
@@ -251,11 +251,14 @@ mkMaps :: DynFlags
        -> Maps
 mkMaps dflags gre instances decls =
   let (a, b, c, d) = unzip4 $ map mappings decls
-  in (f $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)
+  in (f' $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)
   where
     f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
     f = M.fromListWith (<>) . concat
 
+    f' :: [[(Name, Doc Name)]] -> Map Name (Doc Name)
+    f' = M.fromListWith docAppend . concat
+
     mappings :: (LHsDecl Name, [HsDocString])
              -> ( [(Name, Doc Name)]
                 , [(Name, Map Int (Doc Name))]
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index 54c7351d..f1021436 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -21,7 +21,7 @@ module Haddock.Interface.LexParseRn
 import Control.Applicative
 import Data.IntSet (toList)
 import Data.List
-import Data.Monoid (mconcat)
+import Documentation.Haddock.Doc (docConcat)
 import DynFlags (ExtensionFlag(..), languageExtensions)
 import FastString
 import GHC
@@ -34,7 +34,7 @@ import RdrName
 
 processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (Doc Name)
 processDocStrings dflags gre strs =
-  case mconcat $ map (processDocStringParas dflags gre) strs of
+  case docConcat $ map (processDocStringParas dflags gre) strs of
     DocEmpty -> Nothing
     x -> Just x
 
-- 
cgit v1.2.3