diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 69 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 57 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 9 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 705 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 618 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 4 |
7 files changed, 775 insertions, 689 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index a89ac2c7..885c608b 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Hoogle @@ -75,23 +76,22 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy a e) = HsForAllTy a (g e) - f (HsQualTy a e) = HsQualTy a (g e) - f (HsBangTy a b) = HsBangTy a (g b) - f (HsAppTy a b) = HsAppTy (g a) (g b) - f (HsFunTy a b) = HsFunTy (g a) (g b) - f (HsListTy a) = HsListTy (g a) - f (HsPArrTy a) = HsPArrTy (g a) - f (HsTupleTy a b) = HsTupleTy a (map g b) - f (HsOpTy a b c) = HsOpTy (g a) b (g c) - f (HsParTy a) = HsParTy (g a) - f (HsKindSig a b) = HsKindSig (g a) b - f (HsDocTy a _) = f $ unL a + f (HsForAllTy x a e) = HsForAllTy x a (g e) + f (HsQualTy x a e) = HsQualTy x a (g e) + f (HsBangTy x a b) = HsBangTy x a (g b) + f (HsAppTy x a b) = HsAppTy x (g a) (g b) + f (HsFunTy x a b) = HsFunTy x (g a) (g b) + f (HsListTy x a) = HsListTy x (g a) + f (HsTupleTy x a b) = HsTupleTy x a (map g b) + f (HsOpTy x a b c) = HsOpTy x (g a) b (g c) + f (HsParTy x a) = HsParTy x (g a) + f (HsKindSig x a b) = HsKindSig x (g a) b + f (HsDocTy _ a _) = f $ unL a f x = x -outHsType :: (SourceTextX a, OutputableBndrId a) +outHsType :: (a ~ GhcPass p, OutputableBndrId a) => DynFlags -> HsType a -> String -outHsType dflags = out dflags . dropHsDocTy +outHsType dflags = out dflags . reparenType . dropHsDocTy dropComment :: String -> String @@ -127,20 +127,20 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemFixities = fixities } = ppDocumentation dflags dc ++ f decl ++ ppFixities where - 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 + 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 f _ = [] ppFixities = concatMap (ppFixity dflags) fixities ppExport _ _ = [] ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] -ppSigWithDoc dflags (TypeSig names sig) subdocs +ppSigWithDoc dflags (TypeSig _ names sig) subdocs = concatMap mkDocSig names where mkDocSig n = mkSubdoc dflags n subdocs [pp_sig dflags [n] (hsSigWcType sig)] @@ -191,7 +191,7 @@ ppClass dflags decl subdocs = , tcdTyVars = feqn_pats tfe , tcdFixity = feqn_fixity tfe , tcdRhs = feqn_rhs tfe - , tcdFVs = emptyNameSet + , tcdSExt = emptyNameSet } ppFam :: DynFlags -> FamilyDecl GhcRn -> [String] @@ -203,6 +203,7 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info }) -- for Hoogle, so pretend it doesn't have any. ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily } _ -> decl +ppFam _ XFamilyDecl {} = panic "ppFam" ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x = @@ -242,17 +243,17 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String] ppCtor dflags dat subdocs con@ConDeclH98 {} -- AZ:TODO get rid of the concatMap - = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat - [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++ - [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] + [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++ + [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy x y) - apps = foldl1 (\x y -> reL $ HsAppTy x y) + funs = foldr1 (\x y -> reL $ HsFunTy NoExt x y) + apps = foldl1 (\x y -> reL $ HsAppTy NoExt x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) @@ -260,20 +261,20 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = apps $ map (reL . HsTyVar NotPromoted . reL) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] + resType = apps $ map (reL . HsTyVar NoExt NotPromoted . reL) $ + (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat] -ppCtor dflags _dat subdocs con@ConDeclGADT {} +ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f where - f = [typeSig name (hsib_body $ con_type con)] + f = [typeSig name (getGADTConTypeG con)] typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) name = out dflags $ map unL $ getConNames con - +ppCtor _ _ _ XConDecl {} = panic "haddock:ppCtor" ppFixity :: DynFlags -> (Name, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)] --------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index c4a9091f..0ecf7109 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -13,6 +13,7 @@ import Haddock.Backends.Hyperlinker.Types import qualified GHC import qualified SrcLoc +import qualified Outputable as GHC import Control.Applicative import Control.Monad (guard) @@ -79,9 +80,9 @@ variables = everythingInRenamedSource (var `Syb.combine` rec) where var term = case cast term of - (Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.HsVar _ name)) :: GHC.LHsExpr GHC.GhcRn)) -> pure (sspan, RtkVar (GHC.unLoc name)) - (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) -> + (Just (GHC.L _ (GHC.RecordCon _ (GHC.L sspan name) _))) -> pure (sspan, RtkVar name) _ -> empty rec term = case cast term of @@ -95,9 +96,9 @@ types = everythingInRenamedSource ty where ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)] ty term = case cast term of - (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.HsTyVar _ _ name)) :: GHC.LHsType GHC.GhcRn)) -> pure (sspan, RtkType (GHC.unLoc name)) - (Just ((GHC.L sspan (GHC.HsOpTy l name r)) :: GHC.LHsType GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.HsOpTy _ l name r)) :: GHC.LHsType GHC.GhcRn)) -> (sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r) _ -> empty @@ -112,20 +113,20 @@ binds = everythingInRenamedSource (fun `Syb.combine` pat `Syb.combine` tvar) where fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) -> + (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) -> pure (sspan, RtkBind name) - (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ args _ _))) -> + (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) args _ _))) -> pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args _ -> empty patsyn_binds term = case cast term of (Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name) _ -> empty pat term = case cast term of - (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.VarPat _ name)) :: GHC.LPat GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs - (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) -> + (Just (GHC.L _ (GHC.AsPat _ (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty rec term = case cast term of @@ -133,9 +134,9 @@ binds = everythingInRenamedSource pure (sspan, RtkVar name) _ -> empty tvar term = case cast term of - (Just ((GHC.L sspan (GHC.UserTyVar name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.UserTyVar _ name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) - (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) -> + (Just (GHC.L _ (GHC.KindedTyVar _ (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty @@ -150,16 +151,17 @@ decls (group, _, _, _) = concatMap ($ group) where typ (GHC.L _ t) = case t of GHC.DataDecl { tcdLName = name } -> pure . decl $ name - GHC.SynDecl name _ _ _ _ -> pure . decl $ name - GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam + GHC.SynDecl _ name _ _ _ -> pure . decl $ name + GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs ++ concatMap tyfam tcdATs + GHC.XTyClDecl {} -> GHC.panic "haddock:decls" fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) + (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) - (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ _ _ _))) + (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) _ _ _))) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty con term = case cast term of @@ -168,24 +170,27 @@ decls (group, _, _, _) = concatMap ($ group) ++ everythingInRenamedSource fld cdcl Nothing -> empty ins term = case cast term of - (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn)) + (Just ((GHC.DataFamInstD _ (GHC.DataFamInstDecl eqn)) :: GHC.InstDecl GHC.GhcRn)) -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn - (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) -> + (Just (GHC.TyFamInstD _ (GHC.TyFamInstDecl eqn))) -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn _ -> empty fld term = case cast term of Just (field :: GHC.ConDeclField GHC.GhcRn) - -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field + -> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field Nothing -> empty fix term = case cast term of - Just ((GHC.FixitySig names _) :: GHC.FixitySig GHC.GhcRn) + Just ((GHC.FixitySig _ names _) :: GHC.FixitySig GHC.GhcRn) -> map (\(GHC.L sspan x) -> (sspan, RtkVar x)) names + Just ((GHC.XFixitySig {}) :: GHC.FixitySig GHC.GhcRn) + -> GHC.panic "haddock:decls" Nothing -> empty tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName] - sig (GHC.L _ (GHC.TypeSig names _)) = map decl names - sig (GHC.L _ (GHC.PatSynSig names _)) = map decl names - sig (GHC.L _ (GHC.ClassOpSig _ names _)) = map decl names + tyfam (GHC.L _ (GHC.XFamilyDecl {})) = GHC.panic "haddock:dels" + sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names + sig (GHC.L _ (GHC.PatSynSig _ names _)) = map decl names + sig (GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names sig _ = [] decl (GHC.L sspan name) = (sspan, RtkDecl name) tyref (GHC.L sspan name) = (sspan, RtkType name) @@ -199,12 +204,12 @@ imports src@(_, imps, _, _) = everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of - (Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v - (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t - (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t - (Just (GHC.IEThingWith t _ vs _fls)) -> + (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v + (Just (GHC.IEThingAbs _ t)) -> pure $ typ $ GHC.ieLWrappedName t + (Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t + (Just (GHC.IEThingWith _ t _ vs _fls)) -> [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs - (Just (GHC.IEModuleContents m)) -> pure $ modu m + (Just (GHC.IEModuleContents _ m)) -> pure $ modu m _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) var (GHC.L sspan name) = (sspan, RtkVar name) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 456050d1..acb2c892 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -234,6 +234,7 @@ classify tok = ITqualified -> TkKeyword ITthen -> TkKeyword ITtype -> TkKeyword + ITvia -> TkKeyword ITwhere -> TkKeyword ITforall {} -> TkKeyword @@ -284,9 +285,6 @@ classify tok = IToptions_prag {} -> TkPragma ITinclude_prag {} -> TkPragma ITlanguage_prag -> TkPragma - ITvect_prag {} -> TkPragma - ITvect_scalar_prag {} -> TkPragma - ITnovect_prag {} -> TkPragma ITminimal_prag {} -> TkPragma IToverlappable_prag {} -> TkPragma IToverlapping_prag {} -> TkPragma @@ -305,11 +303,11 @@ classify tok = ITrarrow {} -> TkGlyph ITat -> TkGlyph ITtilde -> TkGlyph - ITtildehsh -> TkGlyph ITdarrow {} -> TkGlyph ITminus -> TkGlyph ITbang -> TkGlyph ITdot -> TkOperator + ITstar {} -> TkOperator ITtypeApp -> TkGlyph ITbiglam -> TkGlyph @@ -431,9 +429,6 @@ inPragma False tok = IToptions_prag {} -> True ITinclude_prag {} -> True ITlanguage_prag -> True - ITvect_prag {} -> True - ITvect_scalar_prag {} -> True - ITnovect_prag {} -> True ITminimal_prag {} -> True IToverlappable_prag {} -> True IToverlapping_prag {} -> True diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 38fccf0c..4a3e9d03 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -27,7 +27,7 @@ import GHC import OccName import Name ( nameOccName ) import RdrName ( rdrNameOcc ) -import FastString ( unpackFS, unpackLitString, zString ) +import FastString ( unpackFS ) import Outputable ( panic) import qualified Data.Map as Map @@ -169,23 +169,16 @@ ppLaTeXModule _title odir iface = do body = processExports exports -- - writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex) - - -string_txt :: TextDetails -> String -> String -string_txt (Chr c) s = c:s -string_txt (Str s1) s2 = s1 ++ s2 -string_txt (PStr s1) s2 = unpackFS s1 ++ s2 -string_txt (ZStr s1) s2 = zString s1 ++ s2 -string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 - + writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex) +-- | 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) @@ -215,7 +208,7 @@ processExports (e : es) = isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t)) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing @@ -249,13 +242,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 +275,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 + 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 +322,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 +341,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 +514,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,15 +539,15 @@ ppClassDecl instances loc doc subdocs methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig loc doc [name] (hsSigWcType typ) unicode - | L _ (TypeSig lnames typ) <- lsigs + vcat [ ppFunSig doc [name] (hsSigWcType typ) unicode + | L _ (TypeSig _ lnames typ) <- lsigs , name <- map unLoc lnames , let doc = lookupAnySubdoc name 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 @@ -565,15 +596,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 @@ -585,28 +618,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 + | 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" @@ -625,62 +656,102 @@ 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_details 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) + ] + XConDecl{} -> panic "haddock:ppSideBySideConstr" + + 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)) - - - 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 = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)) - context = unLoc (fromMaybe (noLoc []) (con_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. - mbDoc = case getConNames con of - [] -> panic "empty con_names" - (cn:_) -> lookup (unLoc cn) subdocs >>= - fmap _doc . combineDocumentation . fst - -ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) = - leader <-> - doGADTCon (hsib_body $ con_type con) + vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl + | (begin, L _ field) <- zip ("\\qquad \\{" : repeat "\\qquad ,") fields + ] + $$ + empty <-> tt (text "\\qquad \\}") <+> nl - where - doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+> - ppLType unicode resTy - ) <-> rDoc mbDoc + 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) + ] + XConDecl{} -> panic "haddock:doConstrArgsWithDocs" - 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. @@ -688,127 +759,50 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) = [] -> panic "empty con_names" (cn:_) -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst -{- old - -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX - -> LConDecl DocName -> LaTeX -ppSideBySideConstr subdocs unicode leader (L loc con) = - leader <-> - case con_res con of - ResTyH98 -> case con_details 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 - - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could also use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> doGADTCon args resTy - cd@(RecCon (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ - doRecordFields fields - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy - - where - doRecordFields fields = - vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - - doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> - ppLType unicode (mk_forall $ mk_phi $ - foldr mkFunTy resTy args) - ) <-> rDoc mbDoc - header_ = ppConstrHdr (con_explicit con) tyVars context - occ = map (nameOccName . getName . unLoc) $ con_names con - ppOcc = case occ of - [one] -> ppBinder one - _ -> cat (punctuate comma (map ppBinder occ)) - ltvs = con_qvars con - tyVars = tyvarNames (con_qvars con) - context = unLoc (con_cxt con) - - mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty) - | otherwise = ty - mk_phi ty | null context = ty - | otherwise = L loc (HsQualTy (con_cxt con) ty) - - -- 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 con_names con of - [] -> panic "empty con_names" - (cn:_) -> lookup (unLoc cn) subdocs >>= - fmap _doc . combineDocumentation . fst - mkFunTy a b = noLoc (HsFunTy a b) --} - +-- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX -ppSideBySideField subdocs unicode (ConDeclField names ltype _) = +ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) = decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above -- 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 ] --- -} + mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst +ppSideBySideField _ _ (XConDeclField _) = panic "haddock:ppSideBySideField" + + +-- | 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. @@ -824,6 +818,7 @@ ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars ppAppDocNameNames False name (tyvarNames tyvars) ppDataHeader _ _ = error "ppDataHeader: illegal argument" + -------------------------------------------------------------------------------- -- * Type applications -------------------------------------------------------------------------------- @@ -911,24 +906,6 @@ sumParens = ubxparens . hsep . punctuate (text " | ") -- Stolen from Html and tweaked for LaTeX generation ------------------------------------------------------------------------------- - -pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int - -pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC -pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC - -- Used for LH arg of (->) -pREC_OP = (2 :: Int) -- Used for arg of any infix operator - -- (we don't keep their fixities around) -pREC_CON = (3 :: Int) -- Used for arg of type applicn: - -- always parenthesise unless atomic - -maybeParen :: Int -- Precedence of context - -> Int -- Precedence of top-level operator - -> LaTeX -> LaTeX -- Wrap in parens if (ctxt >= op) -maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p - | otherwise = p - - ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> LaTeX ppLType unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) @@ -936,78 +913,70 @@ ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) ppType, ppParendType, ppFunLhType :: Bool -> HsType DocNameI -> LaTeX -ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode -ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode -ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode +ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode +ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode +ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode ppLKind :: Bool -> LHsKind DocNameI -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y) ppKind :: Bool -> HsKind DocNameI -> LaTeX -ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode +ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppr_mono_lty :: Int -> LHsType DocNameI -> Bool -> LaTeX -ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode - - -ppr_mono_ty :: Int -> HsType DocNameI -> Bool -> LaTeX -ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode - = maybeParen ctxt_prec pREC_FUN $ - sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot - , ppr_mono_lty pREC_TOP ty unicode ] -ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode - = maybeParen ctxt_prec pREC_FUN $ - sep [ ppLContext ctxt unicode - , ppr_mono_lty pREC_TOP ty unicode ] - -ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty -ppr_mono_ty _ (HsTyVar NotPromoted (L _ name)) _ = ppDocName name -ppr_mono_ty _ (HsTyVar Promoted (L _ name)) _ = char '\'' <> ppDocName name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u -ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) -ppr_mono_ty _ (HsSumTy tys) u = sumParens (map (ppLType u) tys) -ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) -ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) -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 _ (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 -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys - -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode - = maybeParen ctxt_prec pREC_OP $ - ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode - -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode - = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] - -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode - = maybeParen ctxt_prec pREC_FUN $ - ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode +ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX +ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode + + +ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX +ppr_mono_ty (HsForAllTy _ tvs ty) unicode + = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot + , ppr_mono_lty ty unicode ] +ppr_mono_ty (HsQualTy _ ctxt ty) unicode + = sep [ ppLContext ctxt unicode + , ppr_mono_lty ty unicode ] +ppr_mono_ty (HsFunTy _ ty1 ty2) u + = sep [ ppr_mono_lty ty1 u + , arrow u <+> ppr_mono_lty ty2 u ] + +ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty +ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name +ppr_mono_ty (HsTyVar _ Promoted (L _ name)) _ = char '\'' <> ppDocName name +ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys) +ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) +ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind) +ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) +ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty ty u) +ppr_mono_ty (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty (HsRecTy {}) _ = text "{..}" +ppr_mono_ty (XHsType (NHsCoreTy {})) _ = 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 +ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys + +ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode + = hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode] + +ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode + = ppr_mono_lty ty1 unicode <+> ppr_op <+> ppr_mono_lty ty2 unicode where ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op occName = nameOccName . getName . unLoc $ op -ppr_mono_ty ctxt_prec (HsParTy ty) unicode --- = parens (ppr_mono_lty pREC_TOP ty) - = ppr_mono_lty ctxt_prec ty unicode - -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode - = ppr_mono_lty ctxt_prec ty unicode +ppr_mono_ty (HsParTy _ ty) unicode + = parens (ppr_mono_lty ty unicode) +-- = ppr_mono_lty ty unicode -ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' +ppr_mono_ty (HsDocTy _ ty _) unicode + = ppr_mono_lty ty unicode -ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u +ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy" +ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u +ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) ppr_tylit :: HsTyLit -> Bool -> LaTeX @@ -1017,15 +986,6 @@ ppr_tylit (HsStrTy _ s) _ = text (show s) -- XXX: Do something with Unicode parameter? -ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Bool -> LaTeX -ppr_fun_ty ctxt_prec ty1 ty2 unicode - = let p1 = ppr_mono_lty pREC_FUN ty1 unicode - p2 = ppr_mono_lty pREC_TOP ty2 unicode - in - maybeParen ctxt_prec pREC_FUN $ - sep [p1, arrow unicode <+> p2] - - ------------------------------------------------------------------------------- -- * Names ------------------------------------------------------------------------------- @@ -1036,6 +996,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 @@ -1267,12 +1232,12 @@ quote :: LaTeX -> LaTeX quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" -dcolon, arrow, darrow, forallSymbol :: Bool -> LaTeX +dcolon, arrow, darrow, forallSymbol, starSymbol :: Bool -> LaTeX dcolon unicode = text (if unicode then "∷" else "::") arrow unicode = text (if unicode then "→" else "->") darrow unicode = text (if unicode then "⇒" else "=>") forallSymbol unicode = text (if unicode then "∀" else "forall") - +starSymbol unicode = text (if unicode then "★" else "*") dot :: LaTeX dot = char '.' @@ -1290,10 +1255,6 @@ ubxparens :: LaTeX -> LaTeX ubxparens h = text "(#" <> h <> text "#)" -pabrackets :: LaTeX -> LaTeX -pabrackets h = text "[:" <> h <> text ":]" - - nl :: LaTeX nl = text "\\\\" diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index c9a262a4..6da6a2e8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -667,7 +667,7 @@ numberSectionHeadings = go 1 processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification -> ExportItem DocNameI -> Maybe Html -processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances +processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances processExport summary _ _ pkg qual (ExportGroup lev id0 doc) = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) pkg qual (mkMeta doc) processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 01380c94..cc271fef 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -39,24 +39,34 @@ import GHC.Exts 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 - -> Maybe Package -> Qualification -> Html +import Outputable ( panic ) + +-- | 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 + -> Maybe Package + -> Qualification + -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of - TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual - TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual - TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual - SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames + TyClD _ (FamDecl _ d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual + TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual + TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual + TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual + SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigWcType lty) fixities splice unicode pkg qual - SigD (PatSynSig lnames ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames - ty fixities splice unicode pkg qual - ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual - InstD _ -> noHtml - DerivD _ -> noHtml + SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames + (hsSigType lty) fixities splice unicode pkg qual + ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual + InstD _ _ -> noHtml + DerivD _ _ -> noHtml _ -> error "declaration not supported by ppDecl" @@ -76,21 +86,18 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual = where pp_typ = ppLType unicode qual HideEmptyContexts typ -ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [Located DocName] -> LHsSigType DocNameI -> - [(DocName, Fixity)] -> - Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice - unicode pkg qual - | summary = pref1 - | otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual) - +++ docSection Nothing pkg 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 -> Maybe Package -> Qualification -> Html +ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual = + ppSigLike summary links loc (keyword "pattern") doc (map unLoc lnames) fixities + (unLoc typ, pp_typ) splice unicode pkg 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) -> @@ -99,7 +106,7 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) splice unicode pkg 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 pkg qual emptyCtxts @@ -118,36 +125,72 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode pkg qual emptyCtxts | summary = pref1 | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName pkg qual doc - | otherwise = topDeclElem links loc splice docnames pref2 +++ - subArguments pkg qual (do_args 0 sep typ) +++ docSection curName pkg qual doc + | otherwise = topDeclElem links loc splice docnames pref2 + +++ subArguments pkg qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts) + +++ docSection curName pkg 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 do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] - do_args n leader (HsForAllTy tvs ltype) + do_args n leader (HsForAllTy _ tvs ltype) = do_largs n leader' ltype where leader' = leader <+> ppForAll tvs unicode qual - do_args n leader (HsQualTy lctxt ltype) + do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt) = do_largs n leader ltype | otherwise = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) : do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy lt r) + 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 + case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of [] -> noHtml ts -> forallSymbol unicode <+> hsep ts +++ dot where ppKTv n k = parens $ @@ -186,7 +229,7 @@ tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities +ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -279,12 +322,14 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info ClosedTypeFamily _ -> keyword "where ..." _ -> mempty ) +ppTyFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppTyFamHeader" ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html ppResultSig result unicode qual = case result of - NoSig -> noHtml - KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind - TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + NoSig _ -> noHtml + KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind + TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + XFamilyResultSig _ -> panic "haddock:ppResultSig" ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI -> Html @@ -330,6 +375,8 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing, [] ) + ppTyFamEqn (XHsImplicitBndrs _) = panic "haddock:ppTyFam" + ppTyFamEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppTyFam" @@ -363,6 +410,7 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual = ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs) +ppFamDeclBinderWithVars _ _ _ (XFamilyDecl _) = panic "haddock:ppFamDeclBinderWithVars" -- | Print a newtype / data binder and its variables ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html @@ -477,7 +525,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t [ ppFunSig summary links loc doc names (hsSigType typ) [] splice unicode pkg qual - | L _ (ClassOpSig False lnames typ) <- sigs + | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -525,7 +573,7 @@ ppClassDecl summary links instances fixities loc d subdocs methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ) subfixs splice unicode pkg qual - | L _ (ClassOpSig _ lnames typ) <- lsigs + | L _ (ClassOpSig _ _ lnames typ) <- lsigs , name <- map unLoc lnames , let doc = lookupAnySubdoc name subdocs subfixs = [ f | f@(n',_) <- fixities @@ -534,15 +582,15 @@ ppClassDecl summary links instances fixities loc d subdocs -- N.B. taking just the first name is ok. Signatures with multiple names -- are expanded so that each name gets its own signature. - minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of + minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == - sort [getName n | ClassOpSig _ ns _ <- sigs, L _ n <- ns] + sort [getName n | ClassOpSig _ _ ns _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (ClassOpSig _ ns _) <- lsigs, L _ n' <- ns] + [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -645,7 +693,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification -> [Sig DocNameI] -> [Html] ppInstanceSigs links splice unicode qual sigs = do - TypeSig lnames typ <- sigs + TypeSig _ lnames typ <- sigs let names = map unLoc lnames L _ rtyp = hsSigWcType typ -- Instance methods signatures are synified and thus don't have a useful @@ -706,21 +754,27 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False + XConDecl{} -> False pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode , ppPatSigType unicode qual (hsSigType typ) ] - | (SigD (PatSynSig lnames typ),_) <- pats + | (SigD _ (PatSynSig _ lnames typ),_) <- pats ] -ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> - [(DocName, DocForDecl DocName)] -> - SrcSpan -> Documentation DocName -> TyClDecl DocNameI -> - [(HsDecl DocNameI, DocForDecl DocName)] -> - Splice -> Unicode -> Maybe Package -> 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 -> Maybe Package -> Qualification -> Html ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats splice unicode pkg qual @@ -733,6 +787,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False + XConDecl{} -> False header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix @@ -749,25 +804,20 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats [ ppSideBySideConstr subdocs subfixs unicode pkg 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 pkg 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 pkg qual - ppShortConstr :: Bool -> ConDecl DocNameI -> Unicode -> Qualification -> Html ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot where @@ -777,121 +827,183 @@ 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_details 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 resTy,noHtml,noHtml) - - where - resTy = hsib_body (con_type con) - - 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 '}' + ) - ltvs = fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con) - tyVars = tyvarNames ltvs - lcontext = fromMaybe (noLoc []) (con_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 + ) + XConDecl {} -> panic "haddock:ppShortConstrParts" --- 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 -> Maybe Package -> Qualification -> LConDecl DocNameI -> SubDecl + -> Unicode -> Maybe Package -> Qualification + -> LConDecl DocNameI -- ^ constructor declaration to print + -> SubDecl ppSideBySideConstr subdocs fixities unicode pkg 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_details 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 - ConDeclGADT{} -> doGADTCon resTy + 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 - resTy = hsib_body (con_type 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 + ] + XConDecl{} -> panic "haddock:ppSideBySideConstr" + + 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 getConDetails con of - RecCon (L _ fields) -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields pkg 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 - - 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)) + doConstrArgsWithDocs args = subFields pkg 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 + XConDecl{} -> panic "haddock:doConstrArgsWithDocs" - ppOccInfix = case occ of - [one] -> ppBinderInfix False one - _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) - - tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)) - context = unLoc (fromMaybe (noLoc []) (con_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)) +ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) = + ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field) + | L _ name <- names + , let field = (unLoc . rdrNameFieldOcc) name + ]) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype , mbDoc @@ -900,13 +1012,49 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation - mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst + mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst +ppSideBySideField _ _ _ (XConDeclField _) = panic "haddock:ppSideBySideField" ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html -ppShortField summary unicode qual (ConDeclField names ltype _) +ppShortField summary unicode qual (ConDeclField _ names ltype _) = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype +ppShortField _ _ _ (XConDeclField _) = panic "haddock:ppShortField" + + +-- | 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 Nothing qual (ppSubSigLike unicode qual (unLoc patTy) + argDocs [] (dcolon unicode) + emptyCtxt) ] + + patTy = hsSigType typ + emptyCtxt = patSigContext patTy -- | Print the LHS of a data\/newtype declaration. @@ -953,129 +1101,112 @@ sumParens = ubxSumList -- * Rendering of HsType -------------------------------------------------------------------------------- - -pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int - -pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC -pREC_CTX = 1 :: Int -- Used for single contexts, eg. ctx => type - -- (as opposed to (ctx1, ctx2) => type) -pREC_FUN = 2 :: Int -- btype in ParseIface.y in GHC - -- Used for LH arg of (->) -pREC_OP = 3 :: Int -- Used for arg of any infix operator - -- (we don't keep their fixities around) -pREC_CON = 4 :: Int -- Used for arg of type applicn: - -- always parenthesise unless atomic - -maybeParen :: Int -- Precedence of context - -> Int -- Precedence of top-level operator - -> Html -> Html -- Wrap in parens if (ctxt >= op) -maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p - | otherwise = p - - ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y) ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html -ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual HideEmptyContexts +ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocNameI -> Html -ppType unicode qual emptyCtxts ty = ppr_mono_ty pREC_TOP ty unicode qual emptyCtxts -ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual emptyCtxts -ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts +ppType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode qual emptyCtxts +ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts +ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html -ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = +ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) = ppDocName qual Raw False name -ppHsTyVarBndr unicode qual (KindedTyVar name kind) = +ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) = parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> ppLKind unicode qual kind) +ppHsTyVarBndr _ _ (XTyVarBndr _) = error "haddock:ppHsTyVarBndr" ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html 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 +ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec 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 = case unLoc t of - HsForAllTy _ s -> hasNonEmptyContext s - HsQualTy cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True - HsFunTy _ s -> hasNonEmptyContext s + HsForAllTy _ _ s -> hasNonEmptyContext s + HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True + HsFunTy _ _ s -> hasNonEmptyContext s _ -> False isFirstContextEmpty :: LHsType name -> Bool isFirstContextEmpty t = case unLoc t of - HsForAllTy _ s -> isFirstContextEmpty s - HsQualTy cxt _ -> null (unLoc cxt) - HsFunTy _ s -> isFirstContextEmpty s + HsForAllTy _ _ s -> isFirstContextEmpty s + HsQualTy _ cxt _ -> null (unLoc cxt) + 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 -ppr_mono_lty :: Int -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html -ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) +ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_mono_lty ty = ppr_mono_ty (unLoc ty) -ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html -ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts - = maybeParen ctxt_prec pREC_FUN $ - ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts +ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_mono_ty (HsForAllTy _ tvs ty) unicode qual emptyCtxts + = ppForAllPart unicode qual tvs <+> ppr_mono_lty ty unicode qual emptyCtxts -ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts - = maybeParen ctxt_prec pREC_FUN $ - ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts +ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts + = ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ _ - | getOccString (getName name) == "*" = toHtml "★" +ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _ | getOccString (getName name) == "(->)" = toHtml "(→)" -ppr_mono_ty _ (HsBangTy b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty -ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e -ppr_mono_ty _ (HsTupleTy con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) -ppr_mono_ty _ (HsSumTy tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys) -ppr_mono_ty _ (HsKindSig ty kind) u q e = - parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind) -ppr_mono_ty _ (HsListTy ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) -ppr_mono_ty _ (HsPArrTy ty) u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) -ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q _ = - maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts -ppr_mono_ty _ (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ _ _ = toHtml "{..}" +ppr_mono_ty (HsBangTy _ b ty) u q _ = + ppBang b +++ ppLParendType u q HideEmptyContexts ty +ppr_mono_ty (HsTyVar _ _ (L _ name)) _ q _ = + ppDocName q Prefix True name +ppr_mono_ty (HsStarTy _ isUni) u _ _ = + toHtml (if u || isUni then "★" else "*") +ppr_mono_ty (HsFunTy _ ty1 ty2) u q e = + hsep [ ppr_mono_lty ty1 u q HideEmptyContexts + , arrow u <+> ppr_mono_lty ty2 u q e + ] +ppr_mono_ty (HsTupleTy _ con tys) u q _ = + tupleParens con (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty (HsSumTy _ tys) u q _ = + sumParens (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty (HsKindSig _ ty kind) u q e = + parens (ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind) +ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts) +ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = + ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts +ppr_mono_ty (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field -- declarations. -ppr_mono_ty _ (HsCoreTy {}) _ _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys -ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys -ppr_mono_ty _ (HsAppsTy {}) _ _ _ = error "ppr_mono_ty HsAppsTy" - -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual _ - = maybeParen ctxt_prec pREC_CTX $ - ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts - -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual _ - = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts] - -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _ - = maybeParen ctxt_prec pREC_FUN $ - ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts +ppr_mono_ty (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty (HsExplicitListTy _ Promoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys + +ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode qual _ + = hsep [ ppr_mono_lty fun_ty unicode qual HideEmptyContexts + , ppr_mono_lty arg_ty unicode qual HideEmptyContexts ] + +ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _ + = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts where -- `(:)` is valid in type signature only as constructor to promoted list -- and needs to be quoted in code so we explicitly quote it here too. @@ -1084,24 +1215,17 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _ | otherwise = ppr_op' ppr_op' = ppLDocName qual Infix op -ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts --- = parens (ppr_mono_lty pREC_TOP ty) - = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts +ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts + = parens (ppr_mono_lty ty unicode qual emptyCtxts) +-- = parens (ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts) -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts - = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts +ppr_mono_ty (HsDocTy _ ty _) unicode qual emptyCtxts + = ppr_mono_lty ty unicode qual emptyCtxts -ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_' -ppr_mono_ty _ (HsTyLit n) _ _ _ = ppr_tylit n +ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_' +ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s) -ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html -ppr_fun_ty ctxt_prec ty1 ty2 unicode qual emptyCtxts - = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual HideEmptyContexts - p2 = ppr_mono_lty pREC_TOP ty2 unicode qual emptyCtxts - in - maybeParen ctxt_prec pREC_FUN $ - hsep [p1, arrow unicode <+> p2] 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"]) |