diff options
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 123 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 122 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 96 | ||||
| -rw-r--r-- | haddock-test/src/Test/Haddock.hs | 4 | ||||
| -rw-r--r-- | hoogle-test/ref/Bug873/test.txt | 26 | ||||
| -rw-r--r-- | hoogle-test/ref/type-sigs/test.txt | 4 | ||||
| -rw-r--r-- | hoogle-test/src/Bug873/Bug873.hs | 5 | ||||
| -rw-r--r-- | html-test/ref/QuantifiedConstraints.html | 100 | ||||
| -rw-r--r-- | html-test/src/QuantifiedConstraints.hs | 11 |
10 files changed, 338 insertions, 155 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 257a8d6d..37ac431a 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -89,7 +89,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 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..2f3c1ba1 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -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/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-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index f372f773..942c0587 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -158,7 +158,9 @@ maybeAcceptFile :: Config c -> FilePath -> CheckResult -> IO CheckResult maybeAcceptFile cfg file result | cfgAccept cfg && result `elem` [NoRef, Fail] = do Just out <- readOut cfg file - writeFile (refFile dcfg file) $ ccfgDump ccfg out + let ref = refFile dcfg file + createDirectoryIfMissing True (takeDirectory ref) + writeFile ref $ ccfgDump ccfg out pure Accepted where dcfg = cfgDirConfig cfg diff --git a/hoogle-test/ref/Bug873/test.txt b/hoogle-test/ref/Bug873/test.txt new file mode 100644 index 00000000..19100212 --- /dev/null +++ b/hoogle-test/ref/Bug873/test.txt @@ -0,0 +1,26 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Bug873 + +-- | Application operator. This operator is redundant, since ordinary +-- application <tt>(f x)</tt> means the same as <tt>(f <a>$</a> x)</tt>. +-- However, <a>$</a> has low, right-associative binding precedence, so it +-- sometimes allows parentheses to be omitted; for example: +-- +-- <pre> +-- f $ g $ h x = f (g (h x)) +-- </pre> +-- +-- It is also useful in higher-order situations, such as <tt><a>map</a> +-- (<a>$</a> 0) xs</tt>, or <tt><a>zipWith</a> (<a>$</a>) fs xs</tt>. +-- +-- Note that <tt>($)</tt> is levity-polymorphic in its result type, so +-- that foo $ True where foo :: Bool -> Int# is well-typed +($) :: () => (a -> b) -> a -> b +infixr 0 $ +($$) :: (a -> b) -> a -> b +infixr 0 $$ diff --git a/hoogle-test/ref/type-sigs/test.txt b/hoogle-test/ref/type-sigs/test.txt index ec5f5043..1209279c 100644 --- a/hoogle-test/ref/type-sigs/test.txt +++ b/hoogle-test/ref/type-sigs/test.txt @@ -6,11 +6,11 @@ module ReaderT newtype ReaderT r m a -ReaderT :: r -> m a -> ReaderT r m a +ReaderT :: (r -> m a) -> ReaderT r m a [runReaderT] :: ReaderT r m a -> r -> m a module ReaderTReexport newtype ReaderT r m a -ReaderT :: r -> m a -> ReaderT r m a +ReaderT :: (r -> m a) -> ReaderT r m a [runReaderT] :: ReaderT r m a -> r -> m a runReaderT :: ReaderT r m a -> r -> m a diff --git a/hoogle-test/src/Bug873/Bug873.hs b/hoogle-test/src/Bug873/Bug873.hs new file mode 100644 index 00000000..3a9a5383 --- /dev/null +++ b/hoogle-test/src/Bug873/Bug873.hs @@ -0,0 +1,5 @@ +module Bug873 (($), ($$)) where +infixr 0 $$ + +($$) :: (a -> b) -> a -> b +f $$ x = f x diff --git a/html-test/ref/QuantifiedConstraints.html b/html-test/ref/QuantifiedConstraints.html new file mode 100644 index 00000000..fa2c18ec --- /dev/null +++ b/html-test/ref/QuantifiedConstraints.html @@ -0,0 +1,100 @@ +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >QuantifiedConstraints</title + ><link href="#" rel="stylesheet" type="text/css" title="Ocean" + /><link rel="stylesheet" type="text/css" href="#" + /><script src="haddock-bundle.min.js" async="async" type="text/javascript" + ></script + ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript" + ></script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="#" + >Contents</a + ></li + ><li + ><a href="#" + >Index</a + ></li + ></ul + ><p class="caption empty" + ></p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe</td + ></tr + ></table + ><p class="caption" + >QuantifiedConstraints</p + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a id="t:Foo" class="def" + >Foo</a + > a <span class="keyword" + >where</span + > <a href="#" class="selflink" + >#</a + ></p + ><div class="subs methods" + ><p class="caption" + >Methods</p + ><p class="src" + ><a id="v:fooed" class="def" + >fooed</a + > :: a <a href="#" class="selflink" + >#</a + ></p + ></div + ></div + ><div class="top" + ><p class="src" + ><a id="v:needsParensAroundContext" class="def" + >needsParensAroundContext</a + > :: (<span class="keyword" + >forall</span + > x. <a href="#" title="QuantifiedConstraints" + >Foo</a + > (f x)) => f <a href="#" title="Data.Int" + >Int</a + > <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a id="v:needsNoParensAroundContext" class="def" + >needsNoParensAroundContext</a + > :: <a href="#" title="QuantifiedConstraints" + >Foo</a + > (f <a href="#" title="Data.Int" + >Int</a + >) => f <a href="#" title="Data.Int" + >Int</a + > <a href="#" class="selflink" + >#</a + ></p + ></div + ></div + ></div + ><div id="footer" + ></div + ></body + ></html +>
\ No newline at end of file diff --git a/html-test/src/QuantifiedConstraints.hs b/html-test/src/QuantifiedConstraints.hs new file mode 100644 index 00000000..82dd81e5 --- /dev/null +++ b/html-test/src/QuantifiedConstraints.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE QuantifiedConstraints #-} +module QuantifiedConstraints where + +class Foo a where + fooed :: a + +needsParensAroundContext :: (forall x. Foo (f x)) => f Int +needsParensAroundContext = fooed + +needsNoParensAroundContext :: Foo (f Int) => f Int +needsNoParensAroundContext = fooed |