less big-Map-based proper extraction of constructor subdocs

2 files changed, 28 insertions, 18 deletions

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 020c4a71..b96dfc45 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -109,9 +109,9 @@ operator x = x
 -- How to print each export
 
 ppExport :: ExportItem Name -> [String]
-ppExport (ExportDecl decl dc _ _) = doc dc ++ f (unL decl)
+ppExport (ExportDecl decl dc subdocs _) = doc dc ++ f (unL decl)
     where
-        f (TyClD d@TyData{}) = ppData d
+        f (TyClD d@TyData{}) = ppData d subdocs
         f (TyClD d@ClassDecl{}) = ppClass d
         f (TyClD d@TySynonym{}) = ppSynonym d
         f (ForD (ForeignImport name typ _)) = ppSig $ TypeSig name typ
@@ -156,9 +156,9 @@ ppInstance :: Instance -> [String]
 ppInstance x = [dropComment $ out x]
 
 
-ppData :: TyClDecl Name -> [String]
-ppData x = showData x{tcdCons=[],tcdDerivs=Nothing} :
-           concatMap (ppCtor x . unL) (tcdCons x)
+ppData :: TyClDecl Name -> [(Name, Maybe (HsDoc Name))] -> [String]
+ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} :
+                   concatMap (ppCtor x subdocs . unL) (tcdCons x)
     where
         -- GHC gives out "data Bar =", we want to delete the equals
         -- also writes data : a b, when we want data (:) a b
@@ -168,14 +168,18 @@ ppData x = showData x{tcdCons=[],tcdDerivs=Nothing} :
                 nam = out $ tcdLName d
                 f w = if w == nam then operator nam else w
 
+-- | for constructors, and named-fields...
+lookupCon :: [(Name, Maybe (HsDoc Name))] -> Located Name -> Maybe (HsDoc Name)
+lookupCon subdocs (L _ name) = join{-Maybe-} $ lookup name subdocs
 
-ppCtor :: TyClDecl Name -> ConDecl Name -> [String]
-ppCtor dat con = ldoc (con_doc con) ++ f (con_details con)
+ppCtor :: TyClDecl Name -> [(Name, Maybe (HsDoc Name))] -> ConDecl Name -> [String]
+ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con))
+                         ++ f (con_details con)
     where
         f (PrefixCon args) = [typeSig name $ args ++ [resType]]
         f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
         f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat
-                          [ldoc (cd_fld_doc r) ++
+                          [doc (lookupCon subdocs (cd_fld_name r)) ++
                            [out (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]
                           | r <- recs]
 
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index 17c1c802..a420dac5 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -821,7 +821,7 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
 ppDecl summ links (L loc decl) mbDoc instances docMap subdocs unicode = case decl of
   TyClD d@(TyFamily {})          -> ppTyFam summ False links loc mbDoc d unicode
   TyClD d@(TyData {})
-    | Nothing <- tcdTyPats d     -> ppDataDecl summ links instances loc mbDoc d unicode
+    | Nothing <- tcdTyPats d     -> ppDataDecl summ links instances subdocs loc mbDoc d unicode
     | Just _  <- tcdTyPats d     -> ppDataInst summ links loc mbDoc d 
   TyClD d@(TySynonym {})
     | Nothing <- tcdTyPats d     -> ppTySyn summ links loc mbDoc d unicode
@@ -1257,9 +1257,10 @@ ppShortDataDecl summary links loc dataDecl unicode
     cons      = tcdCons dataDecl
     resTy     = (con_res . unLoc . head) cons 
 
-ppDataDecl :: Bool -> LinksInfo -> [InstHead DocName] -> 
+ppDataDecl :: Bool -> LinksInfo -> [InstHead DocName] ->
+              [(DocName, Maybe (HsDoc DocName))] ->
               SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> Bool -> HtmlTable
-ppDataDecl summary links instances loc mbDoc dataDecl unicode
+ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode
   
   | summary = declWithDoc summary links loc docname mbDoc 
               (ppShortDataDecl summary links loc dataDecl unicode)
@@ -1299,7 +1300,7 @@ ppDataDecl summary links instances loc mbDoc dataDecl unicode
       | null cons = Html.emptyTable
       | otherwise = constrHdr </> ( 
           tda [theclass "body"] << constrTable << 
-	  aboves (map (ppSideBySideConstr unicode) cons)
+	  aboves (map (ppSideBySideConstr subdocs unicode) cons)
         )
 
     instId = collapseId (getName docname)
@@ -1374,8 +1375,8 @@ ppConstrHdr forall tvs ctxt unicode
       Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". "
       Implicit -> empty
 
-ppSideBySideConstr :: Bool -> LConDecl DocName -> HtmlTable
-ppSideBySideConstr unicode (L _ con) = case con_res con of 
+ppSideBySideConstr :: [(DocName, Maybe (HsDoc DocName))] -> Bool -> LConDecl DocName -> HtmlTable
+ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of 
  
   ResTyH98 -> case con_details con of 
 
@@ -1404,7 +1405,7 @@ ppSideBySideConstr unicode (L _ con) = case con_res con of
  where 
     doRecordFields fields =
         (tda [theclass "body"] << spacedTable1 <<
-        aboves (map (ppSideBySideField unicode) fields))
+        aboves (map (ppSideBySideField subdocs unicode) fields))
     doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon unicode <+> hsep [
                                ppForAll forall ltvs (con_cxt con) unicode,
                                ppLType unicode (foldr mkFunTy resTy args) ]
@@ -1417,14 +1418,19 @@ ppSideBySideConstr unicode (L _ con) = case con_res con of
     tyVars  = tyvarNames (con_qvars con)
     context = unLoc (con_cxt con)
     forall  = con_explicit con
-    mbLDoc  = con_doc con
+    -- don't use "con_doc con", in case it's reconstructed from a .hi file,
+    -- or also because we want Haddock to do the doc-parsing, not GHC.
+    mbLDoc  = fmap noLoc $ join $ lookup (unLoc $ con_name con) subdocs
     mkFunTy a b = noLoc (HsFunTy a b)
 
-ppSideBySideField :: Bool -> ConDeclField DocName ->  HtmlTable
-ppSideBySideField unicode (ConDeclField (L _ name) ltype mbLDoc) =
+ppSideBySideField :: [(DocName, Maybe (HsDoc DocName))] -> Bool -> ConDeclField DocName ->  HtmlTable
+ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
   argBox (ppBinder False (docNameOcc name)
     <+> dcolon unicode <+> ppLType unicode ltype) <->
   maybeRDocBox mbLDoc
+  where
+    -- don't use cd_fld_doc for same reason we don't use con_doc above
+    mbLDoc = fmap noLoc $ join $ lookup name subdocs
 
 {-
 ppHsFullConstr :: HsConDecl -> Html