From ff8464058e226f3f2cdf7df4b0f395ba826d5190 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 10 Aug 2015 14:05:23 +0200 Subject: Improve class type family declarations output in Hoogle backend. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index cd015c03..0a174fd6 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -159,10 +159,17 @@ ppSig dflags x = ppSigWithDoc dflags x [] -- note: does not yet output documentation for class methods ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] -ppClass dflags x subdocs = out dflags decl' : - concatMap (flip (ppSigWithDoc dflags) subdocs . addContext . unL) (tcdSigs x) +ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods where - decl' = x { tcdSigs = [], tcdMeths = emptyBag } + decl' = decl + { tcdSigs = [], tcdMeths = emptyBag + , tcdATs = [], tcdATDefs = [] + } + + ppMethods = concat . map (ppSig' . unLoc) $ tcdSigs decl + ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext + + ppTyFams = showSDocUnqual dflags . whereWrapper . map ppr $ tcdATs decl addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs addContext (MinimalSig src sig) = MinimalSig src sig @@ -171,8 +178,8 @@ ppClass dflags x subdocs = out dflags decl' : f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t) - context = nlHsTyConApp (tcdName x) - (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) + context = nlHsTyConApp (tcdName decl) + (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars decl))) ppInstance :: DynFlags -> ClsInst -> [String] @@ -369,3 +376,11 @@ escape = concatMap f f '>' = ">" f '&' = "&" f x = [x] + + +semiSeparate :: [SDoc] -> SDoc +semiSeparate = sep . punctuate semi + + +whereWrapper :: [SDoc] -> SDoc +whereWrapper xs = text "where" <+> braces (space <> semiSeparate xs <> space) -- cgit v1.2.3