From 133e9c2c168db19c1135479f7ab144c4e33af2a4 Mon Sep 17 00:00:00 2001
From: Alec Theriault <alec.theriault@gmail.com>
Date: Fri, 20 Jul 2018 03:01:49 -0700
Subject: Preserve docs on type family instances (#867)

* Preserve docs on type family instances

The only problem was that the instance location was slightly off
for type family instances.

* Accept output
---
 haddock-api/src/Haddock/Interface/Create.hs |  7 +++++--
 haddock-api/src/Haddock/Types.hs            |  3 +++
 html-test/ref/TypeFamilies.html             | 30 +++++++++++++++++++----------
 html-test/ref/TypeFamilies2.html            | 18 +++++++++++------
 4 files changed, 40 insertions(+), 18 deletions(-)

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index a35e2053..ced7cae5 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -419,9 +419,12 @@ mkMaps dflags pkgName gre instances decls = do
     instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
 
     names :: SrcSpan -> HsDecl GhcRn -> [Name]
-    names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
+    names _ (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
       where loc = case d of
-              TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs
+              -- The CoAx's loc is the whole line, but only for TFs. The
+              -- workaround is to dig into the family instance declaration and
+              -- get the identifier with the right location.
+              TyFamInstD (TyFamInstDecl d') -> getLoc (feqn_tycon (hsib_body d'))
               _ -> getInstLoc d
     names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].
     names _ decl = getMainDeclBinder decl
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 36ed7baf..5ef5a7b9 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -28,6 +28,7 @@ module Haddock.Types (
 import Control.Exception
 import Control.Arrow hiding ((<+>))
 import Control.DeepSeq
+import Control.Monad.IO.Class (MonadIO(..))
 import Data.Typeable
 import Data.Map (Map)
 import Data.Data (Data)
@@ -661,6 +662,8 @@ instance Monad ErrMsgGhc where
   m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->
                fmap (second (msgs1 ++)) (runWriterGhc (k a))
 
+instance MonadIO ErrMsgGhc where
+  liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m))
 
 -----------------------------------------------------------------------------
 -- * Pass sensitive types
diff --git a/html-test/ref/TypeFamilies.html b/html-test/ref/TypeFamilies.html
index 190f376e..1fe20c4b 100644
--- a/html-test/ref/TypeFamilies.html
+++ b/html-test/ref/TypeFamilies.html
@@ -352,8 +352,10 @@
 		    > <a href="#" class="selflink"
 		    >#</a
 		    ></td
-		  ><td class="doc empty"
-		  ></td
+		  ><td class="doc"
+		  ><p
+		    >External instance</p
+		    ></td
 		  ></tr
 		><tr
 		><td colspan="2"
@@ -586,8 +588,10 @@
 		    > <a href="#" class="selflink"
 		    >#</a
 		    ></td
-		  ><td class="doc empty"
-		  ></td
+		  ><td class="doc"
+		  ><p
+		    >Doc for: type instance Foo X = Y</p
+		    ></td
 		  ></tr
 		><tr
 		><td colspan="2"
@@ -944,8 +948,10 @@
 		    > <a href="#" class="selflink"
 		    >#</a
 		    ></td
-		  ><td class="doc empty"
-		  ></td
+		  ><td class="doc"
+		  ><p
+		    >Doc for: type instance Foo Y = X</p
+		    ></td
 		  ></tr
 		><tr
 		><td colspan="2"
@@ -1234,8 +1240,10 @@
 		    > <a href="#" class="selflink"
 		    >#</a
 		    ></td
-		  ><td class="doc empty"
-		  ></td
+		  ><td class="doc"
+		  ><p
+		    >Doc for: type instance Foo Y = X</p
+		    ></td
 		  ></tr
 		><tr
 		><td colspan="2"
@@ -1274,8 +1282,10 @@
 		    > <a href="#" class="selflink"
 		    >#</a
 		    ></td
-		  ><td class="doc empty"
-		  ></td
+		  ><td class="doc"
+		  ><p
+		    >Doc for: type instance Foo X = Y</p
+		    ></td
 		  ></tr
 		><tr
 		><td colspan="2"
diff --git a/html-test/ref/TypeFamilies2.html b/html-test/ref/TypeFamilies2.html
index a5d0d9a9..1b4eed8c 100644
--- a/html-test/ref/TypeFamilies2.html
+++ b/html-test/ref/TypeFamilies2.html
@@ -142,8 +142,10 @@
 		    > <a href="#" class="selflink"
 		    >#</a
 		    ></td
-		  ><td class="doc empty"
-		  ></td
+		  ><td class="doc"
+		  ><p
+		    >Should be visible, but with a hidden right hand side</p
+		    ></td
 		  ></tr
 		><tr
 		><td colspan="2"
@@ -202,8 +204,10 @@
 		    > <a href="#" class="selflink"
 		    >#</a
 		    ></td
-		  ><td class="doc empty"
-		  ></td
+		  ><td class="doc"
+		  ><p
+		    >Should be visible, but with a hidden right hand side</p
+		    ></td
 		  ></tr
 		><tr
 		><td colspan="2"
@@ -240,8 +244,10 @@
 		    > <a href="#" class="selflink"
 		    >#</a
 		    ></td
-		  ><td class="doc empty"
-		  ></td
+		  ><td class="doc"
+		  ><p
+		    >External instance</p
+		    ></td
 		  ></tr
 		><tr
 		><td colspan="2"
-- 
cgit v1.2.3