diff options
author | Ryan Scott <ryan.gl.scott@gmail.com> | 2018-04-24 16:51:06 -0400 |
---|---|---|
committer | Alexander Biehl <alexbiehl@gmail.com> | 2018-04-24 13:51:06 -0700 |
commit | 979c7338cfcdc59f0b0dda562a53558c416cc362 (patch) | |
tree | 073baae7f9cfa6cc3c2ed6ca0fd017092cd80c36 /haddock-api/src/Haddock | |
parent | b347a8c47edafa6bb3df7d35f0189619294831c4 (diff) |
Improve the Hoogle backend's treatment of type families (#808)
Fixes parts 1 and 2 of #806.
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 26 |
1 files changed, 20 insertions, 6 deletions
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 |