diff options
Diffstat (limited to 'haddock-api/src')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 14 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 123 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 130 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 33 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 48 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 96 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 7 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Types.hs | 3 |
8 files changed, 274 insertions, 180 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 257a8d6d..885c608b 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -46,13 +46,15 @@ prefix = ["-- Hoogle documentation, generated by Haddock" ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () ppHoogle dflags package version synopsis prologue ifaces odir = do - let filename = package ++ ".txt" + let -- Since Hoogle is line based, we want to avoid breaking long lines. + dflags' = dflags{ pprCols = maxBound } + filename = package ++ ".txt" contents = prefix ++ - docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ + docWith dflags' (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ ["@package " ++ package] ++ ["@version " ++ showVersion version | not (null (versionBranch version)) ] ++ - concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i] + concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i] createDirectoryIfMissing True odir h <- openFile (odir </> filename) WriteMode hSetEncoding h utf8 @@ -89,7 +91,7 @@ dropHsDocTy = f outHsType :: (a ~ GhcPass p, OutputableBndrId a) => DynFlags -> HsType a -> String -outHsType dflags = out dflags . dropHsDocTy +outHsType dflags = out dflags . reparenType . dropHsDocTy dropComment :: String -> String @@ -123,7 +125,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemMbDoc = (dc, _) , expItemSubDocs = subdocs , expItemFixities = fixities - } = ppDocumentation dflags dc ++ f decl + } = ppDocumentation dflags dc ++ f decl ++ ppFixities where f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs f (TyClD _ d@SynDecl{}) = ppSynonym dflags d @@ -131,7 +133,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl 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 ++ ppFixities + f (SigD _ sig) = ppSig dflags sig f _ = [] ppFixities = concatMap (ppFixity dflags) fixities diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index c0da1f0c..4a3e9d03 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -906,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) @@ -931,72 +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 _ (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 {}) _ = 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 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 (HsParTy _ ty) unicode + = parens (ppr_mono_lty ty unicode) +-- = ppr_mono_lty ty unicode -ppr_mono_ty ctxt_prec (HsDocTy _ ty _) unicode - = ppr_mono_lty ctxt_prec ty unicode +ppr_mono_ty (HsDocTy _ ty _) unicode + = ppr_mono_lty ty unicode -ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' +ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsTyLit _ t) u = ppr_tylit t u -ppr_mono_ty _ (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) +ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u +ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) ppr_tylit :: HsTyLit -> Bool -> LaTeX @@ -1006,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 ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index fdb80141..cc271fef 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -620,9 +620,9 @@ ppInstances links origin instances splice unicode pkg qual -- force Splice = True to use line URLs where instName = getOccString origin - instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName) + instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName) instDecl no (inst, mdoc, loc, mdl) = - ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), loc) + ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), mdl, loc) ppOrphanInstances :: LinksInfo @@ -635,9 +635,9 @@ ppOrphanInstances links instances splice unicode pkg qual instOrigin :: InstHead name -> InstOrigin (IdP name) instOrigin inst = OriginClass (ihdClsName inst) - instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName) + instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName) instDecl no (inst, mdoc, loc, mdl) = - ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst mdl), loc) + ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing), mdl, loc) ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification @@ -1101,38 +1101,18 @@ 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)) = @@ -1146,7 +1126,7 @@ 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 patSigContext :: LHsType name -> HideEmptyContexts patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts @@ -1177,57 +1157,56 @@ ppPatSigType unicode qual 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 _ _ +ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _ | getOccString (getName name) == "(->)" = toHtml "(→)" -ppr_mono_ty _ (HsBangTy _ b ty) u q _ = +ppr_mono_ty (HsBangTy _ b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty -ppr_mono_ty _ (HsTyVar _ _ (L _ name)) _ q _ = +ppr_mono_ty (HsTyVar _ _ (L _ name)) _ q _ = ppDocName q Prefix True name -ppr_mono_ty _ (HsStarTy _ isUni) u _ _ = +ppr_mono_ty (HsStarTy _ isUni) u _ _ = toHtml (if u || isUni then "★" else "*") -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 _ = +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 _ = +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 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 (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 _ (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 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. @@ -1236,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/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 501caa4b..1c44ffda 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -40,7 +40,6 @@ module Haddock.Backends.Xhtml.Layout ( topDeclElem, declElem, ) where - import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils @@ -48,6 +47,7 @@ import Haddock.Types import Haddock.Utils (makeAnchorId, nameAnchorId) import qualified Data.Map as Map import Text.XHtml hiding ( name, title, quote ) +import Data.Maybe (fromMaybe) import FastString ( unpackFS ) import GHC @@ -151,20 +151,22 @@ subTable pkg qual decls = Just $ table << aboves (concatMap subRow decls) -- | Sub table with source information (optional). subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool - -> [(SubDecl,Located DocName)] -> Maybe Html + -> [(SubDecl, Maybe Module, Located DocName)] -> Maybe Html subTableSrc _ _ _ _ [] = Nothing subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) where - subRow ((decl, mdoc, subs),L loc dn) = + subRow ((decl, mdoc, subs), mdl, L loc dn) = (td ! [theclass "src clearfix"] << (thespan ! [theclass "inst-left"] << decl) - <+> linkHtml loc dn + <+> linkHtml loc mdl dn <-> docElement td << fmap (docToHtml Nothing pkg qual) mdoc ) : map (cell . (td <<)) subs - linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn - linkHtml _ _ = noHtml + + linkHtml :: SrcSpan -> Maybe Module -> DocName -> Html + linkHtml loc@(RealSrcSpan _) mdl dn = links lnks loc splice mdl dn + linkHtml _ _ _ = noHtml subBlock :: [Html] -> Maybe Html subBlock [] = Nothing @@ -197,7 +199,7 @@ subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual subInstances :: Maybe Package -> Qualification -> String -- ^ Class name, used for anchor generation -> LinksInfo -> Bool - -> [(SubDecl,Located DocName)] -> Html + -> [(SubDecl, Maybe Module, Located DocName)] -> Html subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable where wrap contents = subSection (collapseDetails id_ DetailsOpen (summary +++ contents)) @@ -209,7 +211,7 @@ subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable subOrphanInstances :: Maybe Package -> Qualification -> LinksInfo -> Bool - -> [(SubDecl,Located DocName)] -> Html + -> [(SubDecl, Maybe Module, Located DocName)] -> Html subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable where wrap = ((h1 << "Orphan instances") +++) @@ -268,13 +270,13 @@ declElem = paragraph ! [theclass "src"] -- it adds a source and wiki link at the right hand side of the box topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html topDeclElem lnks loc splice names html = - declElem << (html <+> (links lnks loc splice $ head names)) + declElem << (html <+> (links lnks loc splice Nothing $ head names)) -- FIXME: is it ok to simply take the first name? -- | Adds a source and wiki link at the right hand side of the box. -- Name must be documented, otherwise we wouldn't get here. -links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html -links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice docName@(Documented n mdl) = +links :: LinksInfo -> SrcSpan -> Bool -> Maybe Module -> DocName -> Html +links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice mdl' docName@(Documented n mdl) = srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << "#") where selfLink = linkedAnchor (nameAnchorId (nameOccName (getName docName))) @@ -298,12 +300,13 @@ links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice docName@(Docume -- For source links, we want to point to the original module, -- because only that will have the source. - -- TODO: do something about type instances. They will point to - -- the module defining the type family, which is wrong. - origMod = nameModule n + -- + -- 'mdl'' is a way of "overriding" the module. Without it, instances + -- will point to the module defining the class/family, which is wrong. + origMod = fromMaybe (nameModule n) mdl' origPkg = moduleUnitId origMod fname = case loc of RealSrcSpan l -> unpackFS (srcSpanFile l) UnhelpfulSpan _ -> error "links: UnhelpfulSpan" -links _ _ _ _ = noHtml +links _ _ _ _ _ = noHtml diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index bf6fbab0..6eee353b 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -31,7 +31,7 @@ import NameSet ( emptyNameSet ) import RdrName ( mkVarUnqual ) import PatSyn import SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan ) -import TcType ( tcSplitSigmaTy ) +import TcType import TyCon import Type import TyCoRep @@ -527,7 +527,7 @@ synifyType _ (FunTy t1 t2) = let s2 = synifyType WithinType t2 in noLoc $ HsFunTy noExt s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = - let (tvs, ctx, tau) = tcSplitSigmaTy forallty + let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms forallty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx , hst_xqual = noExt , hst_body = synifyType WithinType tau } @@ -626,3 +626,47 @@ synifyFamInst fi opaque = do ts' = synifyTypes ts annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc) + +{- +Note [Invariant: Never expand type synonyms] + +In haddock, we never want to expand a type synonym that may be presented to the +user, as we want to keep the link to the abstraction captured in the synonym. + +All code in Haddock.Convert must make sure that this invariant holds. + +See https://github.com/haskell/haddock/issues/879 for a bug where this +invariant didn't hold. +-} + +-- | A version of 'TcType.tcSplitSigmaTy' that preserves type synonyms. +-- +-- See Note [Invariant: Never expand type synonyms] +tcSplitSigmaTyPreserveSynonyms :: Type -> ([TyVar], ThetaType, Type) +tcSplitSigmaTyPreserveSynonyms ty = + case tcSplitForAllTysPreserveSynonyms ty of + (tvs, rho) -> case tcSplitPhiTyPreserveSynonyms rho of + (theta, tau) -> (tvs, theta, tau) + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitForAllTysPreserveSynonyms :: Type -> ([TyVar], Type) +tcSplitForAllTysPreserveSynonyms ty = split ty ty [] + where + split _ (ForAllTy (TvBndr tv _) ty') tvs = split ty' ty' (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type) +tcSplitPhiTyPreserveSynonyms ty0 = split ty0 [] + where + split ty ts + = case tcSplitPredFunTyPreserveSynonyms_maybe ty of + Just (pred_, ty') -> split ty' (pred_:ts) + Nothing -> (reverse ts, ty) + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitPredFunTyPreserveSynonyms_maybe :: Type -> Maybe (PredType, Type) +tcSplitPredFunTyPreserveSynonyms_maybe (FunTy arg res) + | isPredTy arg = Just (arg, res) +tcSplitPredFunTyPreserveSynonyms_maybe _ + = Nothing diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index b2c34bb4..e7d80969 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -31,6 +31,8 @@ import GHC import Class import DynFlags +import HsTypes (HsType(..)) + moduleString :: Module -> String moduleString = moduleNameString . moduleName @@ -226,6 +228,100 @@ getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" -- Should only be called on ConDeclGADT getGADTConTypeG (XConDecl {}) = panic "getGADTConTypeG" + +------------------------------------------------------------------------------- +-- * Parenthesization +------------------------------------------------------------------------------- + +-- | Precedence level (inside the 'HsType' AST). +data Precedence + = PREC_TOP -- ^ precedence of 'type' production in GHC's parser + + | PREC_CTX -- ^ Used for single contexts, eg. ctx => type + -- (as opposed to (ctx1, ctx2) => type) + + | PREC_FUN -- ^ precedence of 'btype' production in GHC's parser + -- (used for LH arg of (->)) + + | PREC_OP -- ^ arg of any infix operator + -- (we don't keep have fixity info) + + | PREC_CON -- ^ arg of type application: always parenthesize unless atomic + deriving (Eq, Ord) + +-- | Add in extra 'HsParTy' where needed to ensure that what would be printed +-- out using 'ppr' has enough parentheses to be re-parsed properly. +-- +-- We cannot add parens that may be required by fixities because we do not have +-- any fixity information to work with in the first place :(. +reparenTypePrec :: (XParTy a ~ NoExt) => Precedence -> HsType a -> HsType a +reparenTypePrec = go + where + + -- Shorter name for 'reparenType' + go :: (XParTy a ~ NoExt) => Precedence -> HsType a -> HsType a + go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty) + go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys) + go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys) + go _ (HsKindSig x ty kind) = HsKindSig x (reparenLType ty) (reparenLType kind) + go _ (HsListTy x ty) = HsListTy x (reparenLType ty) + go _ (HsRecTy x flds) = HsRecTy x (map (fmap reparenConDeclField) flds) + go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d + go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys) + go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys) + go p (HsIParamTy x n ty) + = paren p PREC_CTX $ HsIParamTy x n (reparenLType ty) + go p (HsForAllTy x tvs ty) + = paren p PREC_CTX $ HsForAllTy x (map (fmap reparenTyVar) tvs) (reparenLType ty) + go p (HsQualTy x ctxt ty) + = paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty) + go p (HsFunTy x ty1 ty2) + = paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2) + go p (HsAppTy x fun_ty arg_ty) + = paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty) + go p (HsOpTy x ty1 op ty2) + = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2) + go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed + go _ t@HsTyVar{} = t + go _ t@HsStarTy{} = t + go _ t@HsSpliceTy{} = t + go _ t@HsTyLit{} = t + go _ t@HsWildCardTy{} = t + go _ t@XHsType{} = t + + -- Located variant of 'go' + goL :: (XParTy a ~ NoExt) => Precedence -> LHsType a -> LHsType a + goL ctxt_prec = fmap (go ctxt_prec) + + -- Optionally wrap a type in parens + paren :: (XParTy a ~ NoExt) + => Precedence -- Precedence of context + -> Precedence -- Precedence of top-level operator + -> HsType a -> HsType a -- Wrap in parens if (ctxt >= op) + paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy NoExt . noLoc + | otherwise = id + + +-- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec') +reparenType :: (XParTy a ~ NoExt) => HsType a -> HsType a +reparenType = reparenTypePrec PREC_TOP + +-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec') +reparenLType :: (XParTy a ~ NoExt) => LHsType a -> LHsType a +reparenLType = fmap reparenType + +-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') +reparenTyVar :: (XParTy a ~ NoExt) => HsTyVarBndr a -> HsTyVarBndr a +reparenTyVar (UserTyVar x n) = UserTyVar x n +reparenTyVar (KindedTyVar x n kind) = KindedTyVar x n (reparenLType kind) +reparenTyVar v@XTyVarBndr{} = v + +-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec') +reparenConDeclField :: (XParTy a ~ NoExt) => ConDeclField a -> ConDeclField a +reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d +reparenConDeclField c@XConDeclField{} = c + + ------------------------------------------------------------------------------- -- * Located ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 78242990..c4df2090 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -419,9 +419,12 @@ mkMaps dflags pkgName gre instances decls = do instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] names :: SrcSpan -> HsDecl GhcRn -> [Name] - names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. + names _ (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. where loc = case d of - TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only for TFs + -- The CoAx's loc is the whole line, but only for TFs. The + -- workaround is to dig into the family instance declaration and + -- get the identifier with the right location. + TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon (hsib_body d')) _ -> getInstLoc d names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. names _ decl = getMainDeclBinder decl diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index da422562..ea74043d 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -28,6 +28,7 @@ module Haddock.Types ( import Control.Exception import Control.Arrow hiding ((<+>)) import Control.DeepSeq +import Control.Monad.IO.Class (MonadIO(..)) import Data.Typeable import Data.Map (Map) import Data.Data (Data) @@ -661,6 +662,8 @@ instance Monad ErrMsgGhc where m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> fmap (second (msgs1 ++)) (runWriterGhc (k a)) +instance MonadIO ErrMsgGhc where + liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m)) ----------------------------------------------------------------------------- -- * Pass sensitive types |