diff options
Diffstat (limited to 'haddock-api/src/Haddock')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 483 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 401 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 4 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 4 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 121 |
5 files changed, 630 insertions, 383 deletions
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 793e40d8..51e183c7 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -179,13 +179,14 @@ string_txt (PStr s1) s2 = unpackFS s1 ++ s2 string_txt (ZStr s1) s2 = zString s1 ++ s2 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 - +-- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs } - = sep (punctuate comma . map ppDocBinder $ declNames decl) <> - case subdocs of - [] -> empty - _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs))) + = let (leader, names) = declNames decl + in sep (punctuate comma [ leader <+> ppDocBinder name | name <- names ]) <> + case subdocs of + [] -> empty + _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs))) exportListItem (ExportNoDecl y []) = ppDocBinder y exportListItem (ExportNoDecl y subs) @@ -249,13 +250,17 @@ ppDocGroup lev doc = sec lev <> braces doc sec _ = text "\\paragraph" -declNames :: LHsDecl DocNameI -> [DocName] +-- | Given a declaration, extract out the names being declared +declNames :: LHsDecl DocNameI + -> ( LaTeX -- ^ to print before each name in an export list + , [DocName] -- ^ names being declared + ) declNames (L _ decl) = case decl of - TyClD d -> [tcdName d] - SigD (TypeSig lnames _ ) -> map unLoc lnames - SigD (PatSynSig lnames _) -> map unLoc lnames - ForD (ForeignImport (L _ n) _ _ _) -> [n] - ForD (ForeignExport (L _ n) _ _ _) -> [n] + TyClD d -> (empty, [tcdName d]) + SigD (TypeSig lnames _ ) -> (empty, map unLoc lnames) + SigD (PatSynSig lnames _) -> (text "pattern", map unLoc lnames) + ForD (ForeignImport (L _ n) _ _ _) -> (empty, [n]) + ForD (ForeignExport (L _ n) _ _ _) -> (empty, [n]) _ -> error "declaration not supported by declNames" @@ -278,47 +283,44 @@ moduleBasename mdl = map (\c -> if c == '.' then '-' else c) -- * Decls ------------------------------------------------------------------------------- - -ppDecl :: LHsDecl DocNameI - -> [(HsDecl DocNameI, DocForDecl DocName)] - -> DocForDecl DocName - -> [DocInstance DocNameI] - -> [(DocName, DocForDecl DocName)] - -> [(DocName, Fixity)] +-- | Pretty print a declaration +ppDecl :: LHsDecl DocNameI -- ^ decl to print + -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ all pattern decls + -> DocForDecl DocName -- ^ documentation for decl + -> [DocInstance DocNameI] -- ^ all instances + -> [(DocName, DocForDecl DocName)] -- ^ all subdocs + -> [(DocName, Fixity)] -- ^ all fixities -> LaTeX -ppDecl (L loc decl) pats (doc, fnArgsDoc) instances subdocs _fixities = case decl of - TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode - TyClD d@(DataDecl {}) - -> ppDataDecl pats instances subdocs loc (Just doc) d unicode - TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode +ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of + TyClD d@FamDecl {} -> ppTyFam False doc d unicode + TyClD d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode + TyClD d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now --- TyClD d@(TySynonym {}) +-- TyClD d@TySynonym{} -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now - TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode - SigD (TypeSig lnames t) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) - (hsSigWcType t) unicode - SigD (PatSynSig lnames ty) -> - ppLPatSig loc (doc, fnArgsDoc) (map unLoc lnames) ty unicode - ForD d -> ppFor loc (doc, fnArgsDoc) d unicode - InstD _ -> empty - DerivD _ -> empty - _ -> error "declaration not supported by ppDecl" + TyClD d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode + SigD (TypeSig lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD (PatSynSig lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode + ForD d -> ppFor (doc, fnArgsDoc) d unicode + InstD _ -> empty + DerivD _ -> empty + _ -> error "declaration not supported by ppDecl" where unicode = False -ppTyFam :: Bool -> SrcSpan -> Documentation DocName -> +ppTyFam :: Bool -> Documentation DocName -> TyClDecl DocNameI -> Bool -> LaTeX -ppTyFam _ _ _ _ _ = +ppTyFam _ _ _ _ = error "type family declarations are currently not supported by --latex" -ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX -ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode = - ppFunSig loc doc [name] (hsSigType typ) unicode -ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" +ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX +ppFor doc (ForeignImport (L _ name) typ _ _) unicode = + ppFunSig doc [name] (hsSigType typ) unicode +ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -328,18 +330,18 @@ ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- we skip type patterns for now -ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX +ppTySyn :: DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX -ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars +ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode - = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode + = ppTypeOrFunSig (unLoc ltype) doc (full, hdr, char '=') unicode where hdr = hsep (keyword "type" : ppDocBinder name : map ppSymName (tyvarNames ltyvars)) full = hdr <+> char '=' <+> ppLType unicode ltype -ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" +ppTySyn _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- @@ -347,61 +349,98 @@ ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocNameI +ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI -> Bool -> LaTeX -ppFunSig loc doc docnames (L _ typ) unicode = - ppTypeOrFunSig loc docnames typ doc +ppFunSig doc docnames (L _ typ) unicode = + ppTypeOrFunSig typ doc ( ppTypeSig names typ False , hsep . punctuate comma $ map ppSymName names - , dcolon unicode) + , dcolon unicode + ) unicode where names = map getName docnames -ppLPatSig :: SrcSpan -> DocForDecl DocName -> [DocName] - -> LHsSigType DocNameI - -> Bool -> LaTeX -ppLPatSig _loc (doc, _argDocs) docnames ty unicode - = declWithDoc pref1 (documentationToLaTeX doc) +-- | Pretty-print a pattern synonym +ppLPatSig :: DocForDecl DocName -- ^ documentation + -> [DocName] -- ^ pattern names in the pattern signature + -> LHsSigType DocNameI -- ^ type of the pattern synonym + -> Bool -- ^ unicode + -> LaTeX +ppLPatSig doc docnames ty unicode + = ppTypeOrFunSig typ doc + ( keyword "pattern" <+> ppTypeSig names typ False + , keyword "pattern" <+> (hsep . punctuate comma $ map ppSymName names) + , dcolon unicode + ) + unicode where - pref1 = hsep [ keyword "pattern" - , hsep $ punctuate comma $ map ppDocBinder docnames - , dcolon unicode - , ppLType unicode (hsSigType ty) - ] - -ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocNameI - -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) - -> Bool -> LaTeX -ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) - unicode - | Map.null argDocs = - declWithDoc pref1 (documentationToLaTeX doc) - | otherwise = - declWithDoc pref2 $ Just $ + typ = unLoc (hsSigType ty) + names = map getName docnames + +-- | Pretty-print a type, adding documentation to the whole type and its +-- arguments as needed. +ppTypeOrFunSig :: HsType DocNameI + -> DocForDecl DocName -- ^ documentation + -> ( LaTeX -- ^ first-line (no-argument docs only) + , LaTeX -- ^ first-line (argument docs only) + , LaTeX -- ^ type prefix (argument docs only) + ) + -> Bool -- ^ unicode + -> LaTeX +ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode + | Map.null argDocs = declWithDoc pref1 (documentationToLaTeX doc) + | otherwise = declWithDoc pref2 $ Just $ text "\\haddockbeginargs" $$ - do_args 0 sep0 typ $$ + vcat (map (uncurry (<->)) (ppSubSigLike unicode typ argDocs [] sep0)) $$ text "\\end{tabulary}\\par" $$ fromMaybe empty (documentationToLaTeX doc) + +-- This splits up a type signature along `->` and adds docs (when they exist) +-- to the arguments. The output is a list of (leader/seperator, argument and +-- its doc) +ppSubSigLike :: Bool -- ^ unicode + -> HsType DocNameI -- ^ type signature + -> FnArgsDoc DocName -- ^ docs to add + -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`) + -> LaTeX -- ^ seperator (beginning of first line) + -> [(LaTeX, LaTeX)] -- ^ arguments (leader/sep, type) +ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ where - do_largs n leader (L _ t) = do_args n leader t - - arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs - - do_args :: Int -> LaTeX -> HsType DocNameI -> LaTeX - do_args _n leader (HsForAllTy tvs ltype) - = decltt leader - <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) - <+> ppLType unicode ltype - do_args n leader (HsQualTy lctxt ltype) - = decltt leader - <-> ppLContextNoArrow lctxt unicode <+> nl $$ - do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy lt r) - = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$ - do_largs (n+1) (arrow unicode) r - do_args n leader t - = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl + do_largs n leader (L _ t) = do_args n leader t + + arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs + + do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] + do_args _n leader (HsForAllTy tvs ltype) + = [ ( decltt leader + , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) + <+> ppLType unicode ltype + ) ] + do_args n leader (HsQualTy lctxt ltype) + = (decltt leader, ppLContextNoArrow lctxt unicode <+> nl) + : do_largs n (darrow unicode) ltype + + do_args n leader (HsFunTy (L _ (HsRecTy fields)) r) + = [ (decltt ldr, latex <+> nl) + | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) + , let latex = ppSideBySideField subdocs unicode field + ] + ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r + do_args n leader (HsFunTy lt r) + = (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl) + : do_largs (n+1) (arrow unicode) r + do_args n leader t + = [ (decltt leader, decltt (ppType unicode t) <-> arg_doc n <+> nl) ] + + -- FIXME: this should be done more elegantly + -- + -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from + -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode + -- mode since `->` and `::` are rendered as single characters. + gadtComma = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "," + gadtEnd = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "\\}" + gadtOpen = text "\\{" ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX @@ -483,10 +522,10 @@ ppFds fds unicode = hsep (map (ppDocName . unLoc) vars2) -ppClassDecl :: [DocInstance DocNameI] -> SrcSpan +ppClassDecl :: [DocInstance DocNameI] -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Bool -> LaTeX -ppClassDecl instances loc doc subdocs +ppClassDecl instances doc subdocs (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ @@ -508,7 +547,7 @@ ppClassDecl instances loc doc subdocs methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig loc doc names (hsSigWcType typ) unicode + vcat [ ppFunSig doc names (hsSigWcType typ) unicode | L _ (TypeSig lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] @@ -518,7 +557,7 @@ ppClassDecl instances loc doc subdocs instancesBit = ppDocInstances unicode instances -ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" +ppClassDecl _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppDocInstances :: Bool -> [DocInstance DocNameI] -> LaTeX ppDocInstances _unicode [] = empty @@ -567,15 +606,17 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of -- * Data & newtype declarations ------------------------------------------------------------------------------- - -ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -> [DocInstance DocNameI] -> - [(DocName, DocForDecl DocName)] -> SrcSpan -> - Maybe (Documentation DocName) -> TyClDecl DocNameI -> Bool -> - LaTeX -ppDataDecl pats instances subdocs _loc doc dataDecl unicode - - = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) - (if null body then Nothing else Just (vcat body)) +-- | Pretty-print a data declaration +ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns + -> [DocInstance DocNameI] -- ^ relevant instances + -> [(DocName, DocForDecl DocName)] -- ^ relevant decl docs + -> Maybe (Documentation DocName) -- ^ this decl's docs + -> TyClDecl DocNameI -- ^ data decl to print + -> Bool -- ^ unicode + -> LaTeX +ppDataDecl pats instances subdocs doc dataDecl unicode = + declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) + (if null body then Nothing else Just (vcat body)) $$ instancesBit where @@ -587,28 +628,26 @@ ppDataDecl pats instances subdocs _loc doc dataDecl unicode (whereBit, leaders) | null cons , null pats = (empty,[]) - | null cons = (decltt (keyword "where"), repeat empty) + | null cons = (text "where", repeat empty) | otherwise = case resTy of - ConDeclGADT{} -> (decltt (keyword "where"), repeat empty) + ConDeclGADT{} -> (text "where", repeat empty) _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit | null cons = Nothing | otherwise = Just $ + text "\\enspace" <+> emph (text "Constructors") <> text "\\par" $$ text "\\haddockbeginconstrs" $$ vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$ text "\\end{tabulary}\\par" patternBit - | null cons = Nothing - | otherwise = Just $ + | null pats = Nothing + | otherwise = Just $ + text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$ text "\\haddockbeginconstrs" $$ - vcat [ hsep [ keyword "pattern" - , hsep $ punctuate comma $ map (ppDocBinder . unLoc) lnames - , dcolon unicode - , ppLType unicode (hsSigType ty) - ] <-> rDoc (fmap _doc . combineDocumentation . fst $ d) - | (SigD (PatSynSig lnames ty),d) <- pats + vcat [ empty <-> ppSideBySidePat lnames typ d unicode + | (SigD (PatSynSig lnames typ), d) <- pats ] $$ text "\\end{tabulary}\\par" @@ -627,41 +666,100 @@ ppConstrHdr forall tvs ctxt unicode False -> empty -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX - -> LConDecl DocNameI -> LaTeX -ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = - leader <-> - case con_args con of - - PrefixCon args -> - decltt (hsep ((header_ unicode <+> ppOcc) : - map (ppLParendType unicode) args)) - <-> rDoc mbDoc <+> nl - - RecCon (L _ fields) -> - (decltt (header_ unicode <+> ppOcc) - <-> rDoc mbDoc <+> nl) - $$ - doRecordFields fields - - InfixCon arg1 arg2 -> - decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, - ppOcc, - ppLParendType unicode arg2 ]) - <-> rDoc mbDoc <+> nl +-- | Pretty-print a constructor +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -- ^ all decl docs + -> Bool -- ^ unicode + -> LaTeX -- ^ prefix to decl + -> LConDecl DocNameI -- ^ constructor decl + -> LaTeX +ppSideBySideConstr subdocs unicode leader (L _ con) = + leader <-> decltt decl <-> rDoc mbDoc <+> nl + $$ fieldPart + where + -- Find the name of a constructors in the decl (`getConName` always returns + -- a non-empty list) + aConName = unLoc (head (getConNames con)) + + occ = map (nameOccName . getName . unLoc) $ getConNames con + + ppOcc = cat (punctuate comma (map ppBinder occ)) + ppOccInfix = cat (punctuate comma (map ppBinderInfix occ)) + + -- Extract out the map of of docs corresponding to the constructors arguments + argDocs = maybe Map.empty snd (lookup aConName subdocs) + hasArgDocs = not $ Map.null argDocs + + -- First line of the constructor (no doc, no fields, single-line) + decl = case con of + ConDeclH98{ con_args = det + , con_ex_tvs = vars + , con_mb_cxt = cxt + } -> let tyVars = map (getName . hsLTyVarName) vars + context = unLoc (fromMaybe (noLoc []) cxt) + forall_ = False + header_ = ppConstrHdr forall_ tyVars context unicode + in case det of + -- Prefix constructor, e.g. 'Just a' + PrefixCon args + | hasArgDocs -> header_ <+> ppOcc + | otherwise -> hsep [ header_ + , ppOcc + , hsep (map (ppLParendType unicode) args) + ] + + -- Record constructor, e.g. 'Identity { runIdentity :: a }' + RecCon _ -> header_ <+> ppOcc + + -- Infix constructor, e.g. 'a :| [a]' + InfixCon arg1 arg2 + | hasArgDocs -> header_ <+> ppOcc + | otherwise -> hsep [ header_ + , ppLParendType unicode arg1 + , ppOccInfix + , ppLParendType unicode arg2 + ] + + ConDeclGADT{} + | hasArgDocs || not (isEmpty fieldPart) -> ppOcc + | otherwise -> hsep [ ppOcc + , dcolon unicode + -- ++AZ++ make this prepend "{..}" when it is a record style GADT + , ppLType unicode (getGADTConType con) + ] + + fieldPart = case (con, getConArgs con) of + -- Record style GADTs + (ConDeclGADT{}, RecCon _) -> doConstrArgsWithDocs [] + + -- Regular record declarations + (_, RecCon (L _ fields)) -> doRecordFields fields + + -- Any GADT or a regular H98 prefix data constructor + (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs args + + -- An infix H98 data constructor + (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs [arg1,arg2] + + _ -> empty - where doRecordFields fields = - vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) + vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl + | (begin, L _ field) <- zip ("\\qquad \\{" : repeat "\\qquad ,") fields + ] + $$ + empty <-> tt (text "\\qquad \\}") <+> nl + doConstrArgsWithDocs args = vcat $ map (\l -> empty <-> text "\\qquad" <+> l) $ case con of + ConDeclH98{} -> + [ decltt (ppLParendType unicode arg) <-> rDoc (fmap _doc mdoc) <+> nl + | (i, arg) <- zip [0..] args + , let mdoc = Map.lookup i argDocs + ] + ConDeclGADT{} -> + [ l <+> text "\\enspace" <+> r + | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) + ] - header_ = ppConstrHdr False tyVars context - occ = map (nameOccName . getName . unLoc) $ getConNames con - ppOcc = case occ of - [one] -> ppBinder one - _ -> cat (punctuate comma (map ppBinder occ)) - tyVars = map (getName . hsLTyVarName) (con_ex_tvs con) - context = unLoc (fromMaybe (noLoc []) (con_mb_cxt con)) -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. @@ -670,27 +768,8 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = (cn:_) -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst -ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) = - leader <-> - doGADTCon (getGADTConType con) - - where - doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+> - ppLType unicode resTy - ) <-> rDoc mbDoc - - occ = map (nameOccName . getName . unLoc) $ getConNames con - ppOcc = case occ of - [one] -> ppBinder one - _ -> cat (punctuate comma (map ppBinder occ)) - - -- don't use "con_doc con", in case it's reconstructed from a .hi file, - -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = case getConNames con of - [] -> panic "empty con_names" - (cn:_) -> lookup (unLoc cn) subdocs >>= - fmap _doc . combineDocumentation . fst +-- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) = decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) @@ -700,51 +779,37 @@ ppSideBySideField subdocs unicode (ConDeclField names ltype _) = -- Where there is more than one name, they all have the same documentation mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst --- {- --- ppHsFullConstr :: HsConDecl -> LaTeX --- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) = --- declWithDoc False doc ( --- hsep ((ppHsConstrHdr tvs ctxt +++ --- ppHsBinder False nm) : map ppHsBangType typeList) --- ) --- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = --- td << vanillaTable << ( --- case doc of --- Nothing -> aboves [hdr, fields_html] --- Just _ -> aboves [hdr, constr_doc, fields_html] --- ) --- --- where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) --- --- constr_doc --- | isJust doc = docBox (docToLaTeX (fromJust doc)) --- | otherwise = LaTeX.emptyTable --- --- fields_html = --- td << --- table ! [width "100%", cellpadding 0, cellspacing 8] << ( --- aboves (map ppFullField (concat (map expandField fields))) --- ) --- -} --- --- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX --- ppShortField summary unicode (ConDeclField (L _ name) ltype _) --- = tda [theclass "recfield"] << ( --- ppBinder summary (docNameOcc name) --- <+> dcolon unicode <+> ppLType unicode ltype --- ) --- --- {- --- ppFullField :: HsFieldDecl -> LaTeX --- ppFullField (HsFieldDecl [n] ty doc) --- = declWithDoc False doc ( --- ppHsBinder False n <+> dcolon <+> ppHsBangType ty --- ) --- ppFullField _ = error "ppFullField" --- --- expandField :: HsFieldDecl -> [HsFieldDecl] --- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] --- -} + +-- | Pretty-print a bundled pattern synonym +ppSideBySidePat :: [Located DocName] -- ^ pattern name(s) + -> LHsSigType DocNameI -- ^ type of pattern(s) + -> DocForDecl DocName -- ^ doc map + -> Bool -- ^ unicode + -> LaTeX +ppSideBySidePat lnames typ (doc, argDocs) unicode = + decltt decl <-> rDoc mDoc <+> nl + $$ fieldPart + where + hasArgDocs = not $ Map.null argDocs + ppOcc = hsep (punctuate comma (map (ppDocBinder . unLoc) lnames)) + + decl | hasArgDocs = keyword "pattern" <+> ppOcc + | otherwise = hsep [ keyword "pattern" + , ppOcc + , dcolon unicode + , ppLType unicode (hsSigType typ) + ] + + fieldPart + | not hasArgDocs = empty + | otherwise = vcat + [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r + | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode) + ] + + patTy = hsSigType typ + + mDoc = fmap _doc $ combineDocumentation doc -- | Print the LHS of a data\/newtype declaration. @@ -760,6 +825,7 @@ ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars ppAppDocNameNames False name (tyvarNames tyvars) ppDataHeader _ _ = error "ppDataHeader: illegal argument" + -------------------------------------------------------------------------------- -- * Type applications -------------------------------------------------------------------------------- @@ -911,7 +977,7 @@ ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsIParamTy (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" +ppr_mono_ty _ (HsRecTy {}) _ = text "{..}" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys @@ -972,6 +1038,11 @@ ppBinder n | isInfixName n = parens $ ppOccName n | otherwise = ppOccName n +ppBinderInfix :: OccName -> LaTeX +ppBinderInfix n + | isInfixName n = ppOccName n + | otherwise = cat [ char '`', ppOccName n, char '`' ] + isInfixName :: OccName -> Bool isInfixName n = isVarSym n || isConSym n diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index bf71fec4..fcc52a99 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -40,10 +40,19 @@ import Name import BooleanFormula import RdrName ( rdrNameOcc ) -ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI - -> [(HsDecl DocNameI, DocForDecl DocName)] - -> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)] - -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html +-- | Pretty print a declaration +ppDecl :: Bool -- ^ print summary info only + -> LinksInfo -- ^ link information + -> LHsDecl DocNameI -- ^ declaration to print + -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant pattern synonyms + -> DocForDecl DocName -- ^ documentation for this decl + -> [DocInstance DocNameI] -- ^ relevant instances + -> [(DocName, Fixity)] -- ^ relevant fixities + -> [(DocName, DocForDecl DocName)] -- ^ documentation for all decls + -> Splice + -> Unicode -- ^ unicode output + -> Qualification + -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual @@ -51,8 +60,8 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigWcType lty) fixities splice unicode qual - SigD (PatSynSig lnames ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames - ty fixities splice unicode qual + SigD (PatSynSig lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames + (hsSigType lty) fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml DerivD _ -> noHtml @@ -75,20 +84,18 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual = where pp_typ = ppLType unicode qual HideEmptyContexts typ -ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [Located DocName] -> LHsSigType DocNameI -> - [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode qual - | summary = pref1 - | otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual) - +++ docSection Nothing qual doc +-- | Pretty print a pattern synonym +ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName + -> [Located DocName] -- ^ names of patterns in declaration + -> LHsType DocNameI -- ^ type of patterns in declaration + -> [(DocName, Fixity)] + -> Splice -> Unicode -> Qualification -> Html +ppLPatSig summary links loc doc lnames typ fixities splice unicode qual = + ppSigLike summary links loc (keyword "pattern") doc (map unLoc lnames) fixities + (unLoc typ, pp_typ) splice unicode qual (patSigContext typ) where - pref1 = hsep [ keyword "pattern" - , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames - , dcolon unicode - , ppPatSigType unicode qual (hsSigType typ) - ] + pp_typ = ppPatSigType unicode qual typ + ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) -> @@ -97,7 +104,7 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) splice unicode qual emptyCtxts = ppTypeOrFunSig summary links loc docnames typ doc ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode - , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames + , (leader <+>) . addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames , dcolon unicode ) splice unicode qual emptyCtxts @@ -114,10 +121,26 @@ ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual emptyCtxts | summary = pref1 | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc - | otherwise = topDeclElem links loc splice docnames pref2 +++ - subArguments qual (do_args 0 sep typ) +++ docSection curName qual doc + | otherwise = topDeclElem links loc splice docnames pref2 + +++ subArguments qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts) + +++ docSection curName qual doc where curName = getName <$> listToMaybe docnames + + +-- This splits up a type signature along `->` and adds docs (when they exist) to +-- the arguments. +-- +-- If one passes in a list of the available subdocs, any top-level `HsRecTy` +-- found will be expanded out into their fields. +ppSubSigLike :: Unicode -> Qualification + -> HsType DocNameI -- ^ type signature + -> FnArgsDoc DocName -- ^ docs to add + -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when + -- we expand an `HsRecTy`) + -> Html -> HideEmptyContexts -> [SubDecl] +ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ + where argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t @@ -135,12 +158,32 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) : do_largs n (darrow unicode) ltype + do_args n leader (HsFunTy (L _ (HsRecTy fields)) r) + = [ (ldr <+> html, mdoc, subs) + | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) + , let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field + ] + ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r + do_args n leader (HsFunTy lt r) = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r + do_args n leader t = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])] + + -- FIXME: this should be done more elegantly + -- + -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from + -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode + -- mode since `->` and `::` are rendered as single characters. + gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "," + gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "}" + gadtOpen = toHtml "{" + + + ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of @@ -707,11 +750,16 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual ] -ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> - [(DocName, DocForDecl DocName)] -> - SrcSpan -> Documentation DocName -> TyClDecl DocNameI -> - [(HsDecl DocNameI, DocForDecl DocName)] -> - Splice -> Unicode -> Qualification -> Html +-- | Pretty-print a data declaration +ppDataDecl :: Bool -> LinksInfo + -> [DocInstance DocNameI] -- ^ relevant instances + -> [(DocName, Fixity)] -- ^ relevant fixities + -> [(DocName, DocForDecl DocName)] -- ^ all decl documentation + -> SrcSpan + -> Documentation DocName -- ^ this decl's documentation + -> TyClDecl DocNameI -- ^ this decl + -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns + -> Splice -> Unicode -> Qualification -> Html ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats splice unicode qual @@ -740,25 +788,20 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats [ ppSideBySideConstr subdocs subfixs unicode qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) - (map unLoc (getConNames (unLoc c)))) fixities + (map unLoc (getConNames (unLoc c)))) fixities ] patternBit = subPatterns qual - [ (hsep [ keyword "pattern" - , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames - , dcolon unicode - , ppPatSigType unicode qual (hsSigType typ) - ] <+> ppFixities subfixs qual - ,combineDocumentation (fst d), []) - | (SigD (PatSynSig lnames typ),d) <- pats - , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities + [ ppSideBySidePat subfixs unicode qual lnames typ d + | (SigD (PatSynSig lnames typ), d) <- pats + , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) + (map unLoc lnames)) fixities ] instancesBit = ppInstances links (OriginData docname) instances splice unicode qual - ppShortConstr :: Bool -> ConDecl DocNameI -> Unicode -> Qualification -> Html ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot where @@ -768,121 +811,180 @@ ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot -- returns three pieces: header, body, footer so that header & footer can be -- incorporated into the declaration ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualification -> (Html, Html, Html) -ppShortConstrParts summary dataInst con unicode qual = case con of - ConDeclH98{} -> case con_args con of - PrefixCon args -> - (header_ unicode qual +++ hsep (ppOcc - : map (ppLParendType unicode qual HideEmptyContexts) args), noHtml, noHtml) - RecCon (L _ fields) -> - (header_ unicode qual +++ ppOcc <+> char '{', - doRecordFields fields, - char '}') - InfixCon arg1 arg2 -> - (header_ unicode qual +++ hsep [ppLParendType unicode qual HideEmptyContexts arg1, - ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2], - noHtml, noHtml) - - ConDeclGADT {} -> (ppOcc <+> dcolon unicode - <+> ppLType unicode qual HideEmptyContexts (getGADTConType con) - , noHtml, noHtml) - - where - doRecordFields fields = shortSubDecls dataInst $ - map (ppShortField summary unicode qual) (map unLoc fields) - - header_ = ppConstrHdr forall_ tyVars context - occ = map (nameOccName . getName . unLoc) $ getConNames con - - ppOcc = case occ of - [one] -> ppBinder summary one - _ -> hsep (punctuate comma (map (ppBinder summary) occ)) +ppShortConstrParts summary dataInst con unicode qual + = case con of + ConDeclH98{ con_args = det + , con_ex_tvs = vars + , con_mb_cxt = cxt + } -> let tyVars = map (getName . hsLTyVarName) vars + context = unLoc (fromMaybe (noLoc []) cxt) + forall_ = False + header_ = ppConstrHdr forall_ tyVars context unicode qual + in case det of + + -- Prefix constructor, e.g. 'Just a' + PrefixCon args -> + ( header_ +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args) + , noHtml + , noHtml + ) - ppOccInfix = case occ of - [one] -> ppBinderInfix summary one - _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) + -- Record constructor, e.g. 'Identity { runIdentity :: a }' + RecCon (L _ fields) -> + ( header_ +++ ppOcc <+> char '{' + , shortSubDecls dataInst [ ppShortField summary unicode qual field + | L _ field <- fields + ] + , char '}' + ) - -- Used for H98 syntax only - tyVars = map (getName . hsLTyVarName) (con_ex_tvs con) - lcontext = fromMaybe (noLoc []) (con_mb_cxt con) - context = unLoc lcontext - forall_ = False + -- Infix constructor, e.g. 'a :| [a]' + InfixCon arg1 arg2 -> + ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts arg1 + , ppOccInfix + , ppLParendType unicode qual HideEmptyContexts arg2 + ] + , noHtml + , noHtml + ) + -- GADT constructor, e.g. 'Foo :: Int -> Foo' + ConDeclGADT {} -> + ( hsep [ ppOcc, dcolon unicode, ppLType unicode qual HideEmptyContexts (getGADTConType con) ] + , noHtml + , noHtml + ) --- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Unicode - -> Qualification -> Html -ppConstrHdr forall_ tvs ctxt unicode qual - = (if null tvs then noHtml else ppForall) - +++ - (if null ctxt then noHtml - else ppContextNoArrow ctxt unicode qual HideEmptyContexts - <+> darrow unicode +++ toHtml " ") where - ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) - <+> toHtml ". " - | otherwise = noHtml + occ = map (nameOccName . getName . unLoc) $ getConNames con + ppOcc = hsep (punctuate comma (map (ppBinder summary) occ)) + ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) + +-- | Pretty print an expanded constructor ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] - -> Unicode -> Qualification -> LConDecl DocNameI -> SubDecl + -> Unicode -> Qualification + -> LConDecl DocNameI -- ^ constructor declaration to print + -> SubDecl ppSideBySideConstr subdocs fixities unicode qual (L _ con) - = (decl, mbDoc, fieldPart) + = ( decl -- Constructor header (name, fixity) + , mbDoc -- Docs on the whole constructor + , fieldPart -- Information on the fields (or arguments, if they have docs) + ) where - decl = case con of - ConDeclH98{} -> case con_args con of - PrefixCon args -> - hsep ((header_ +++ ppOcc) - : map (ppLParendType unicode qual HideEmptyContexts) args) - <+> fixity + -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list) + aConName = unLoc (head (getConNames con)) - RecCon _ -> header_ +++ ppOcc <+> fixity + fixity = ppFixities fixities qual + occ = map (nameOccName . getName . unLoc) $ getConNames con - InfixCon arg1 arg2 -> - hsep [header_ +++ ppLParendType unicode qual HideEmptyContexts arg1, - ppOccInfix, - ppLParendType unicode qual HideEmptyContexts arg2] - <+> fixity + ppOcc = hsep (punctuate comma (map (ppBinder False) occ)) + ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ)) + + -- Extract out the map of of docs corresponding to the constructors arguments + argDocs = maybe Map.empty snd (lookup aConName subdocs) + hasArgDocs = not $ Map.null argDocs + + decl = case con of + ConDeclH98{ con_args = det + , con_ex_tvs = vars + , con_mb_cxt = cxt + } -> let tyVars = map (getName . hsLTyVarName) vars + context = unLoc (fromMaybe (noLoc []) cxt) + forall_ = False + header_ = ppConstrHdr forall_ tyVars context unicode qual + in case det of + -- Prefix constructor, e.g. 'Just a' + PrefixCon args + | hasArgDocs -> header_ +++ ppOcc <+> fixity + | otherwise -> hsep [ header_ +++ ppOcc + , hsep (map (ppLParendType unicode qual HideEmptyContexts) args) + , fixity + ] + + -- Record constructor, e.g. 'Identity { runIdentity :: a }' + RecCon _ -> header_ +++ ppOcc <+> fixity - ConDeclGADT{} -> doGADTCon (getGADTConType con) + -- Infix constructor, e.g. 'a :| [a]' + InfixCon arg1 arg2 + | hasArgDocs -> header_ +++ ppOcc <+> fixity + | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1 + , ppOccInfix + , ppLParendType unicode qual HideEmptyContexts arg2 + , fixity + ] + + -- GADT constructor, e.g. 'Foo :: Int -> Foo' + ConDeclGADT{} + | hasArgDocs || not (null fieldPart) -> ppOcc <+> fixity + | otherwise -> hsep [ ppOcc + , dcolon unicode + -- ++AZ++ make this prepend "{..}" when it is a record style GADT + , ppLType unicode qual HideEmptyContexts (getGADTConType con) + , fixity + ] + + fieldPart = case (con, getConArgs con) of + -- Record style GADTs + (ConDeclGADT{}, RecCon _) -> [ doConstrArgsWithDocs [] ] + + -- Regular record declarations + (_, RecCon (L _ fields)) -> [ doRecordFields fields ] + + -- Any GADT or a regular H98 prefix data constructor + (_, PrefixCon args) | hasArgDocs -> [ doConstrArgsWithDocs args ] + + -- An infix H98 data constructor + (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] - fieldPart = case getConArgs con of - RecCon (L _ fields) -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) - doGADTCon :: Located (HsType DocNameI) -> Html - doGADTCon ty = ppOcc <+> dcolon unicode - -- ++AZ++ make this prepend "{..}" when it is a record style GADT - <+> ppLType unicode qual HideEmptyContexts ty - <+> fixity + doConstrArgsWithDocs args = subFields qual $ case con of + ConDeclH98{} -> + [ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, []) + | (i, arg) <- zip [0..] args + , let mdoc = Map.lookup i argDocs + ] + ConDeclGADT{} -> + ppSubSigLike unicode qual (unLoc (getGADTConType con)) + argDocs subdocs (dcolon unicode) HideEmptyContexts - fixity = ppFixities fixities qual - header_ = ppConstrHdr forall_ tyVars context unicode qual - occ = map (nameOccName . getName . unLoc) $ getConNames con - - ppOcc = case occ of - [one] -> ppBinder False one - _ -> hsep (punctuate comma (map (ppBinder False) occ)) - - ppOccInfix = case occ of - [one] -> ppBinderInfix False one - _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) - - -- Used for H98 syntax only - tyVars = map (getName . hsLTyVarName) (con_ex_tvs con) - context = unLoc (fromMaybe (noLoc []) (con_mb_cxt con)) - forall_ = False -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>= combineDocumentation . fst +-- ppConstrHdr is for (non-GADT) existentials constructors' syntax +ppConstrHdr :: Bool -- ^ print explicit foralls + -> [Name] -- ^ type variables + -> HsContext DocNameI -- ^ context + -> Unicode -> Qualification -> Html +ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt + where + ppForall + | null tvs || not forall_ = noHtml + | otherwise = forallSymbol unicode + <+> hsep (map (ppName Prefix) tvs) + <+> toHtml ". " + + ppCtxt + | null ctxt = noHtml + | otherwise = ppContextNoArrow ctxt unicode qual HideEmptyContexts + <+> darrow unicode +++ toHtml " " + + +-- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocNameI -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = - ( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) + ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field) + | L _ name <- names + , let field = (unLoc . rdrNameFieldOcc) name + ]) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype , mbDoc @@ -900,6 +1002,40 @@ ppShortField summary unicode qual (ConDeclField names ltype _) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype +-- | Pretty print an expanded pattern (for bundled patterns) +ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification + -> [Located DocName] -- ^ pattern name(s) + -> LHsSigType DocNameI -- ^ type of pattern(s) + -> DocForDecl DocName -- ^ doc map + -> SubDecl +ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) = + ( decl + , combineDocumentation doc + , fieldPart + ) + where + hasArgDocs = not $ Map.null argDocs + fixity = ppFixities fixities qual + ppOcc = hsep (punctuate comma (map (ppBinder False . getOccName) lnames)) + + decl | hasArgDocs = keyword "pattern" <+> ppOcc <+> fixity + | otherwise = hsep [ keyword "pattern" + , ppOcc + , dcolon unicode + , ppPatSigType unicode qual (hsSigType typ) + , fixity + ] + + fieldPart + | not hasArgDocs = [] + | otherwise = [ subFields qual (ppSubSigLike unicode qual (unLoc patTy) + argDocs [] (dcolon unicode) + emptyCtxt) ] + + patTy = hsSigType typ + emptyCtxt = patSigContext patTy + + -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html @@ -990,13 +1126,9 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts -ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html -ppPatSigType unicode qual typ = - let emptyCtxts = - if hasNonEmptyContext typ && isFirstContextEmpty typ - then ShowEmptyToplevelContexts - else HideEmptyContexts - in ppLType unicode qual emptyCtxts typ +patSigContext :: LHsType name -> HideEmptyContexts +patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts + | otherwise = HideEmptyContexts where hasNonEmptyContext :: LHsType name -> Bool hasNonEmptyContext t = @@ -1013,6 +1145,13 @@ ppPatSigType unicode qual typ = HsFunTy _ s -> isFirstContextEmpty s _ -> False + +-- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in +-- the right 'HideEmptyContext' value) +ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html +ppPatSigType unicode qual typ = + let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ + ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index a75c4b9a..7fbaec6d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -110,7 +110,7 @@ renderToString debug html hsep :: [Html] -> Html hsep [] = noHtml -hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls +hsep htmls = foldr1 (<+>) htmls -- | Concatenate a series of 'Html' values vertically, with linebreaks in between. vcat :: [Html] -> Html @@ -232,4 +232,4 @@ collapseToggle id_ classes = [ theclass cs, strAttr "data-details-id" id_ ] -- and displays a control. collapseControl :: String -> String -> [HtmlAttr] collapseControl id_ classes = collapseToggle id_ cs - where cs = unwords (words classes ++ ["details-toggle-control"])
\ No newline at end of file + where cs = unwords (words classes ++ ["details-toggle-control"]) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 4963d2f8..17c92688 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -169,8 +169,8 @@ getGADTConType (ConDeclGADT { con_forall = has_forall tau_ty = case args of RecCon flds -> noLoc (HsFunTy (noLoc (HsRecTy (unLoc flds))) res_ty) - PrefixCon pos_args -> foldr (\ a b -> noLoc (HsFunTy a b)) res_ty pos_args - InfixCon {} -> panic "InfixCon for GADT" + PrefixCon pos_args -> foldr nlHsFunTy res_ty pos_args + InfixCon arg1 arg2 -> arg1 `nlHsFunTy` (arg2 `nlHsFunTy` res_ty) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 52a983a8..4866f76b 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -115,7 +115,7 @@ createInterface tm flags modMap instIfaceMap = do unrestrictedImportedMods -- module re-exports are only possible with -- explicit export list - | Just _ <- exports + | Just{} <- exports = unrestrictedModuleImports (map unLoc imports) | otherwise = M.empty @@ -380,7 +380,7 @@ mkMaps dflags gre instances decls = do m' <- traverse (processDocStringParas dflags gre) m pure (doc', m') - (doc, args) <- declDoc docStrs (typeDocs decl) + (doc, args) <- declDoc docStrs (declTypeDocs decl) let subs :: [(Name, [HsDocString], Map Int HsDocString)] @@ -445,14 +445,14 @@ subordinates instMap decl = case decl of | isDataDecl d -> dataSubs (tcdDataDefn d) _ -> [] where - classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd + classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields ++ derivs where cons = map unL $ (dd_cons dd) - constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) + constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, conArgDocs c) | c <- cons, cname <- getConNames c ] fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map getConArgs cons @@ -464,17 +464,33 @@ subordinates instMap decl = case decl of unLoc $ dd_derivs dd , Just instName <- [M.lookup l instMap] ] +-- | Extract constructor argument docs from inside constructor decls. +conArgDocs :: ConDecl GhcRn -> Map Int HsDocString +conArgDocs con = case getConArgs con of + PrefixCon args -> go 0 (map unLoc args ++ ret) + InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret) + RecCon _ -> go 1 ret + where + go n (HsDocTy _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys + go n (_ : tys) = go (n+1) tys + go _ [] = M.empty + + ret = case con of + ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ] + _ -> [] + +-- | Extract function argument docs from inside top-level decls. +declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString +declTypeDocs (SigD (TypeSig _ ty)) = typeDocs (unLoc (hsSigWcType ty)) +declTypeDocs (SigD (ClassOpSig _ _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (SigD (PatSynSig _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (ForD (ForeignImport _ ty _ _)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (TyClD (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty) +declTypeDocs _ = M.empty + -- | Extract function argument docs from inside types. -typeDocs :: HsDecl GhcRn -> Map Int HsDocString -typeDocs d = - let docs = go 0 in - case d of - SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty)) - SigD (ClassOpSig _ _ ty) -> docs (unLoc (hsSigType ty)) - SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty)) - ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty)) - TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) - _ -> M.empty +typeDocs :: HsType GhcRn -> Map Int HsDocString +typeDocs = go 0 where go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty) go n (HsQualTy { hst_body = ty }) = go n (unLoc ty) @@ -483,7 +499,6 @@ typeDocs d = go n (HsDocTy _ (L _ doc)) = M.singleton n doc go _ _ = M.empty - -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] @@ -689,11 +704,6 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames let declNames = getMainDeclBinder (unL decl) in case () of _ - -- TODO: temp hack: we filter out separately exported ATs, since we haven't decided how - -- to handle them yet. We should really give an warning message also, and filter the - -- name out in mkVisibleNames... - | t `elem` declATs (unL decl) -> return [] - -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. | t `notElem` declNames, @@ -767,7 +777,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames return [ ExportDecl { expItemDecl = restrictTo (fmap fst subs) - (extractDecl (availName avail) decl) + (extractDecl declMap (availName avail) decl) , expItemPats = bundledPatSyns , expItemMbDoc = doc , expItemSubDocs = subs @@ -779,7 +789,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames | otherwise = return [ ExportDecl { - expItemDecl = extractDecl sub decl + expItemDecl = extractDecl declMap sub decl , expItemPats = [] , expItemMbDoc = sub_doc , expItemSubDocs = [] @@ -978,47 +988,74 @@ fullModuleContents :: Bool -- is it a signature -> Avails -> ErrMsgGhc [ExportItem GhcRn] fullModuleContents is_sig modMap thisMod semMod warnings exportedNames - decls maps fixMap splices instIfaceMap dflags avails = do - let availEnv = availsToNameEnv avails + decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do + let availEnv = availsToNameEnv (nubAvails avails) (concat . concat) `fmap` (for decls $ \decl -> do for (getMainDeclBinder (unLoc decl)) $ \nm -> do case lookupNameEnv availEnv nm of - Just avail -> availExportItem is_sig modMap thisMod - semMod warnings exportedNames maps fixMap - splices instIfaceMap dflags avail + Just avail + | L _ (ValD valDecl) <- decl + , (name:_) <- collectHsBindBinders valDecl + , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap + -> pure [] + + | otherwise + -> availExportItem is_sig modMap thisMod + semMod warnings exportedNames maps fixMap + splices instIfaceMap dflags avail Nothing -> pure []) - + where + isSigD (L _ SigD{}) = True + isSigD _ = False -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...). -extractDecl :: Name -> LHsDecl GhcRn -> LHsDecl GhcRn -extractDecl name decl +extractDecl :: DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn +extractDecl declMap name decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = case unLoc decl of TyClD d@ClassDecl {} -> - let matches = [ lsig - | lsig <- tcdSigs d - , ClassOpSig False _ _ <- pure $ unLoc lsig - -- Note: exclude `default` declarations (see #505) - , name `elem` sigName lsig - ] + let + matchesMethod = + [ lsig + | lsig <- tcdSigs d + , ClassOpSig False _ _ <- pure $ unLoc lsig + -- Note: exclude `default` declarations (see #505) + , name `elem` sigName lsig + ] + + matchesAssociatedType = + [ lfam_decl + | lfam_decl <- tcdATs d + , name == unLoc (fdLName (unLoc lfam_decl)) + ] + -- TODO: document fixity - in case matches of - [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) - L pos sig = addClassContext n tyvar_names s0 - in L pos (SigD sig) + in case (matchesMethod, matchesAssociatedType) of + ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) + L pos sig = addClassContext n tyvar_names s0 + in L pos (SigD sig) + (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl)) + + ([], []) + | Just (famInstDecl:_) <- M.lookup name declMap + -> extractDecl declMap name famInstDecl _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:" O.$$ O.nest 4 (O.ppr d) O.$$ O.text "Matches:" - O.$$ O.nest 4 (O.ppr matches)) + O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType)) TyClD d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) in if isDataConName name then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) + TyClD FamDecl {} + | isValName name + , Just (famInst:_) <- M.lookup name declMap + -> extractDecl declMap name famInst InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n , feqn_pats = tys @@ -1034,7 +1071,7 @@ extractDecl name decl , selectorFieldOcc n == name ] in case matches of - [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0) + [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" |