From ffee7f80736f91f0f18c787f093b4ca1ae315afa Mon Sep 17 00:00:00 2001
From: alexbiehl <alex.biehl@gmail.com>
Date: Tue, 6 Feb 2018 09:20:51 +0100
Subject: fullModuleContents: support named docs

---
 haddock-api/src/Haddock/Interface/Create.hs | 40 +++++++++++++++++------------
 1 file changed, 24 insertions(+), 16 deletions(-)

(limited to 'haddock-api/src/Haddock/Interface')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index f905f494..7f0594e0 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -647,8 +647,9 @@ mkExportItems
   instIfaceMap dflags =
   case exportList of
     Nothing      ->
-      fullModuleContents is_sig modMap thisMod semMod warnings exportedNames
-        decls maps fixMap splices instIfaceMap dflags allExports
+      fullModuleContents is_sig modMap thisMod semMod warnings gre
+        exportedNames decls maps fixMap splices instIfaceMap dflags
+        allExports
     Just exports -> liftM concat $ mapM lookupExport exports
   where
     lookupExport (IEGroup lev docStr, _)  = liftErrMsg $ do
@@ -985,6 +986,7 @@ fullModuleContents :: Bool               -- is it a signature
                    -> Module             -- this module
                    -> Module             -- semantic module
                    -> WarningMap
+                   -> GlobalRdrEnv      -- ^ The renaming environment
                    -> [Name]             -- exported names (orig)
                    -> [LHsDecl GhcRn]    -- renamed source declarations
                    -> Maps
@@ -994,23 +996,29 @@ fullModuleContents :: Bool               -- is it a signature
                    -> DynFlags
                    -> Avails
                    -> ErrMsgGhc [ExportItem GhcRn]
-fullModuleContents is_sig modMap thisMod semMod warnings exportedNames
+fullModuleContents is_sig modMap thisMod semMod warnings gre exportedNames
   decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do
   let availEnv = availsToNameEnv (nubAvails avails)
   (concat . concat) `fmap` (for decls $ \decl -> do
-    for (getMainDeclBinder (unLoc decl)) $ \nm -> do
-      case lookupNameEnv availEnv nm of
-        Just avail
-          | L _ (ValD valDecl) <- decl
-          , (name:_) <- collectHsBindBinders valDecl
-          , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
-          -> pure []
-
-          | otherwise
-          -> availExportItem is_sig modMap thisMod
-               semMod warnings exportedNames maps fixMap
-               splices instIfaceMap dflags avail
-        Nothing -> pure [])
+    case decl of
+      (L _ (DocD (DocGroup lev docStr))) -> do
+        doc <- liftErrMsg (processDocString dflags gre docStr)
+        return [[ExportGroup lev "" doc]]
+      (L _ (DocD (DocCommentNamed _ docStr))) -> do
+        doc <- liftErrMsg (processDocStringParas dflags gre docStr)
+        return [[ExportDoc doc]]
+      (L _ (ValD valDecl))
+        | name:_ <- collectHsBindBinders valDecl
+        , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
+        -> return []
+      _ ->
+        for (getMainDeclBinder (unLoc decl)) $ \nm -> do
+          case lookupNameEnv availEnv nm of
+            Just avail ->
+              availExportItem is_sig modMap thisMod
+                semMod warnings exportedNames maps fixMap
+                splices instIfaceMap dflags avail
+            Nothing -> pure [])
   where
     isSigD (L _ SigD{}) = True
     isSigD _            = False
-- 
cgit v1.2.3