aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
authorƁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-08-10 14:05:23 +0200
committerMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2015-08-21 18:31:31 +0100
commitff8464058e226f3f2cdf7df4b0f395ba826d5190 (patch)
tree1867fc415ce404068c9541f1964aee035d9ff063 /haddock-api
parentd070abf3e2348d02f8698c653ca2247e913d222e (diff)
Improve class type family declarations output in Hoogle backend.
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs25
1 files changed, 20 insertions, 5 deletions
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 '>' = "&gt;"
f '&' = "&amp;"
f x = [x]
+
+
+semiSeparate :: [SDoc] -> SDoc
+semiSeparate = sep . punctuate semi
+
+
+whereWrapper :: [SDoc] -> SDoc
+whereWrapper xs = text "where" <+> braces (space <> semiSeparate xs <> space)