From d7869a7ce37b1948b747ab64b9aeb88afb1de4cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Hanuszczak?= Date: Fri, 7 Aug 2015 16:11:30 +0200 Subject: [PATCH 1/7] Remove default methods from Hoogle class output. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 914e346606..f174ebcfb5 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -20,6 +20,8 @@ import InstEnv (ClsInst(..)) import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) + +import Bag import GHC import Outputable @@ -154,9 +156,11 @@ 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 x{tcdSigs=[]} : +ppClass dflags x subdocs = out dflags decl' : concatMap (flip (ppSigWithDoc dflags) subdocs . addContext . unL) (tcdSigs x) where + decl' = x { tcdSigs = [], tcdMeths = emptyBag } + addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs addContext (MinimalSig src sig) = MinimalSig src sig addContext _ = error "expected TypeSig" From 5bbea0345ca187b9c64c83fe6c59cb0a1d5f897a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Hanuszczak?= Date: Fri, 7 Aug 2015 17:06:58 +0200 Subject: [PATCH 2/7] Add fixity declarations in Hoogle backend output. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index f174ebcfb5..04f266aff5 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -28,6 +28,7 @@ import Outputable import Data.Char import Data.List import Data.Maybe +import qualified Data.Map as Map import Data.Version import System.FilePath import System.IO @@ -57,7 +58,8 @@ ppModule dflags iface = "" : ppDocumentation dflags (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ concatMap (ppExport dflags) (ifaceExportItems iface) ++ - concatMap (ppInstance dflags) (ifaceInstances iface) + concatMap (ppInstance dflags) (ifaceInstances iface) ++ + concatMap (ppFixity dflags) (Map.toList $ ifaceFixMap iface) --------------------------------------------------------------------- @@ -234,6 +236,10 @@ ppCtor dflags dat subdocs con ResTyGADT _ x -> x +ppFixity :: DynFlags -> (Name, Fixity) -> [String] +ppFixity dflags (name, fixity) = [out dflags (FixitySig [noLoc name] fixity)] + + --------------------------------------------------------------------- -- DOCUMENTATION From a0bef250eead68b1423e968c09513b2798dce37b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Hanuszczak?= Date: Fri, 7 Aug 2015 18:29:55 +0200 Subject: [PATCH 3/7] Fix bug with incorrect fixities being generated in Hoogle backend. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 04f266aff5..cd015c038c 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -28,7 +28,6 @@ import Outputable import Data.Char import Data.List import Data.Maybe -import qualified Data.Map as Map import Data.Version import System.FilePath import System.IO @@ -58,8 +57,7 @@ ppModule dflags iface = "" : ppDocumentation dflags (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ concatMap (ppExport dflags) (ifaceExportItems iface) ++ - concatMap (ppInstance dflags) (ifaceInstances iface) ++ - concatMap (ppFixity dflags) (Map.toList $ ifaceFixMap iface) + concatMap (ppInstance dflags) (ifaceInstances iface) --------------------------------------------------------------------- @@ -124,6 +122,7 @@ ppExport :: DynFlags -> ExportItem Name -> [String] ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemMbDoc = (dc, _) , expItemSubDocs = subdocs + , expItemFixities = fixities } = ppDocumentation dflags dc ++ f decl where f (TyClD d@DataDecl{}) = ppData dflags d subdocs @@ -131,8 +130,10 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] - f (SigD sig) = ppSig dflags sig + f (SigD sig) = ppSig dflags sig ++ ppFixities f _ = [] + + ppFixities = concatMap (ppFixity dflags) fixities ppExport _ _ = [] ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String] From 2c658c1dbab6ebc60ad4a85a6ba9a1235b83eacf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Hanuszczak?= Date: Mon, 10 Aug 2015 14:05:23 +0200 Subject: [PATCH 4/7] Improve class type family declarations output in Hoogle backend. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 25 +++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index cd015c038c..0a174fd6c4 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) From a0b3a365231b98a13e5f8ee2d8a2e0088dbb6541 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Hanuszczak?= Date: Mon, 10 Aug 2015 14:38:43 +0200 Subject: [PATCH 5/7] Add missing default family equations in Hoogle output. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 0a174fd6c4..71e7cbc4c0 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -24,6 +24,7 @@ import Haddock.Utils hiding (out) import Bag import GHC import Outputable +import NameSet import Data.Char import Data.List @@ -169,7 +170,10 @@ ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods ppMethods = concat . map (ppSig' . unLoc) $ tcdSigs decl ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext - ppTyFams = showSDocUnqual dflags . whereWrapper . map ppr $ tcdATs decl + ppTyFams = showSDocUnqual dflags . whereWrapper $ concat + [ map ppr (tcdATs decl) + , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl) + ] addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs addContext (MinimalSig src sig) = MinimalSig src sig @@ -181,6 +185,14 @@ ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods context = nlHsTyConApp (tcdName decl) (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars decl))) + tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name + tyFamEqnToSyn tfe = SynDecl + { tcdLName = tfe_tycon tfe + , tcdTyVars = tfe_pats tfe + , tcdRhs = tfe_rhs tfe + , tcdFVs = emptyNameSet + } + ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x = From eadcfdd9e1a347b95202404f113c4d171c06a35c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Hanuszczak?= Date: Mon, 10 Aug 2015 16:04:08 +0200 Subject: [PATCH 6/7] Improve formatting of class details output in Hoogle backend. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 71e7cbc4c0..f4f5be90ee 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -175,6 +175,12 @@ ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl) ] + whereWrapper elems = vcat' + [ text "where" <+> lbrace + , nest 4 . vcat . map (<> semi) $ elems + , rbrace + ] + addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs addContext (MinimalSig src sig) = MinimalSig src sig addContext _ = error "expected TypeSig" @@ -390,9 +396,6 @@ escape = concatMap f f x = [x] -semiSeparate :: [SDoc] -> SDoc -semiSeparate = sep . punctuate semi - - -whereWrapper :: [SDoc] -> SDoc -whereWrapper xs = text "where" <+> braces (space <> semiSeparate xs <> space) +-- | Just like 'vcat' but uses '($+$)' instead of '($$)'. +vcat' :: [SDoc] -> SDoc +vcat' = foldr ($+$) empty From df166cf0b7e1d6b57407d1b04856baf08ec578e7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Hanuszczak?= Date: Mon, 10 Aug 2015 16:14:18 +0200 Subject: [PATCH 7/7] Fix weird-looking Hoogle output for familyless classes. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index f4f5be90ee..f6ad98088d 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -160,7 +160,7 @@ 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 decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods +ppClass dflags decl subdocs = (out dflags decl' ++ ppTyFams) : ppMethods where decl' = decl { tcdSigs = [], tcdMeths = emptyBag @@ -170,10 +170,12 @@ ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods ppMethods = concat . map (ppSig' . unLoc) $ tcdSigs decl ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext - ppTyFams = showSDocUnqual dflags . whereWrapper $ concat - [ map ppr (tcdATs decl) - , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl) - ] + ppTyFams + | null $ tcdATs decl = "" + | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat + [ map ppr (tcdATs decl) + , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl) + ] whereWrapper elems = vcat' [ text "where" <+> lbrace