From 979c7338cfcdc59f0b0dda562a53558c416cc362 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Tue, 24 Apr 2018 16:51:06 -0400
Subject: Improve the Hoogle backend's treatment of type families (#808)

Fixes parts 1 and 2 of #806.
---
 haddock-api/src/Haddock/Backends/Hoogle.hs | 26 ++++++++++++++++++++------
 1 file changed, 20 insertions(+), 6 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index e002b602..e7ce9d30 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -128,6 +128,7 @@ ppExport dflags ExportDecl { expItemDecl    = L _ decl
         f (TyClD d@DataDecl{})  = ppData dflags d subdocs
         f (TyClD d@SynDecl{})   = ppSynonym dflags d
         f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs
+        f (TyClD (FamDecl d))   = ppFam dflags d
         f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]
         f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]
         f (SigD sig) = ppSig dflags sig ++ ppFixities
@@ -140,11 +141,7 @@ ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
 ppSigWithDoc dflags (TypeSig names sig) subdocs
     = concatMap mkDocSig names
     where
-        mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n)
-                     ++ [pp_sig dflags [n] (hsSigWcType sig)]
-
-        getDoc :: Located Name -> [Documentation Name]
-        getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs)
+        mkDocSig n = mkSubdoc dflags n subdocs [pp_sig dflags [n] (hsSigWcType sig)]
 
 ppSigWithDoc _ _ _ = []
 
@@ -172,10 +169,14 @@ ppClass dflags decl subdocs =
         ppTyFams
             | null $ tcdATs decl = ""
             | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat
-                [ map ppr (tcdATs decl)
+                [ map pprTyFam (tcdATs decl)
                 , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl)
                 ]
 
+        pprTyFam :: LFamilyDecl GhcRn -> SDoc
+        pprTyFam (L _ at) = vcat' $ map text $
+            mkSubdoc dflags (fdLName at) subdocs (ppFam dflags at)
+
         whereWrapper elems = vcat'
             [ text "where" <+> lbrace
             , nest 4 . vcat . map (Outputable.<> semi) $ elems
@@ -191,6 +192,15 @@ ppClass dflags decl subdocs =
             , tcdFVs    = emptyNameSet
             }
 
+ppFam :: DynFlags -> FamilyDecl GhcRn -> [String]
+ppFam dflags decl@(FamilyDecl { fdInfo = info })
+  = [out dflags decl']
+  where
+    decl' = case info of
+              -- We don't need to print out a closed type family's equations
+              -- for Hoogle, so pretend it doesn't have any.
+              ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily }
+              _                  -> decl
 
 ppInstance :: DynFlags -> ClsInst -> [String]
 ppInstance dflags x =
@@ -285,6 +295,10 @@ docWith dflags header d
     lines header ++ ["" | header /= "" && isJust d] ++
     maybe [] (showTags . markup (markupTag dflags)) d
 
+mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String]
+mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s
+ where
+   getDoc = maybe [] (return . fst) (lookup (unL n) subdocs)
 
 data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String
            deriving Show
-- 
cgit v1.2.3