From 133e9c2c168db19c1135479f7ab144c4e33af2a4 Mon Sep 17 00:00:00 2001 From: Alec Theriault 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 +++ 2 files changed, 8 insertions(+), 2 deletions(-) (limited to 'haddock-api/src') 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 -- cgit v1.2.3