aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/HaddockHtml.hs104
1 files changed, 94 insertions, 10 deletions
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index b9426342..c36cec47 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -1075,26 +1075,33 @@ ppDataHeader summary newOrData name tyvars =
-- ----------------------------------------------------------------------------
-- Types and contexts
+ppVar = ppOccName . kindVarOcc
+
+ppParendKind k@(FunKind _ _) = parens (ppKind k)
+ppParendKind k = ppKind k
+
ppKind kind = case kind of
LiftedTypeKind -> char '*'
OpenTypeKind -> char '?'
UnboxedTypeKind -> char '#'
UnliftedTypeKind -> char '!'
- UbxTupleKind -> toHtml "(##)"
+ UbxTupleKind -> toHtml "(#)"
ArgTypeKind -> toHtml "??"
- FunKind k1 k2 -> hsep [ppKind k1, toHtml "->", ppKind k2]
- KindVar v -> ppOccName (kindVarOcc v)
-
-ppCtxtPart (L _ ctxt)
- | null ctxt = empty
- | otherwise = hsep [ppContext ctxt, darrow]
-
-ppForAllTy (HsForAllTy expl ltvs lctxt _) = ppForAll expl ltvs lctxt
+ FunKind k1 k2 -> hsep [ppParendKind k1, arrow <+> ppKind k2]
+ KindVar v -> ppVar v
+{-
ppForAll Implicit _ lctxt = ppCtxtPart lctxt
ppForAll Explicit ltvs lctxt =
- hsep (keyword "forall" : ppTyVars ltvs ++ [toHtml "."]) <+> ppCtxtPart lctxt
+ hsep (keyword "forall" : ppTyVars ltvs ++ [dot]) <+> ppCtxtPart lctxt
+-}
+
+ppBang HsStrict = toHtml "!"
+ppBang HsUnbox = toHtml "!!"
+tupleParens Boxed = parenList
+tupleParens Unboxed = ubxParenList
+{-
ppType :: HsType DocName -> Html
ppType t = case t of
t@(HsForAllTy expl ltvs lcontext ltype) -> ppForAllTy t <+> ppLType ltype
@@ -1114,6 +1121,81 @@ ppType t = case t of
HsKindSig t k -> hsep [ppLType t, dcolon, ppKind k]
HsSpliceTy _ -> error "ppType"
HsDocTy t _ -> ppLType t
+-}
+--------------------------------------------------------------------------------
+-- Rendering of HsType
+--------------------------------------------------------------------------------
+
+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
+ -> Html -> Html -- Wrap in parens if (ctxt >= op)
+maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
+ | otherwise = p
+
+ppType ty = ppr_mono_ty pREC_TOP (prepare ty)
+ppParendType ty = ppr_mono_ty pREC_CON ty
+
+-- Before printing a type
+-- (a) Remove outermost HsParTy parens
+-- (b) Drop top-level for-all type variables in user style
+-- since they are implicit in Haskell
+prepare (HsParTy ty) = prepare (unLoc ty)
+prepare ty = ty
+
+ppForAll exp tvs cxt
+ | show_forall = forall_part <+> ppLContext cxt
+ | otherwise = ppLContext cxt
+ where
+ show_forall = not (null tvs) && is_explicit
+ is_explicit = case exp of {Explicit -> True; Implicit -> False}
+ forall_part = hsep (keyword "forall" : ppTyVars tvs) +++ dot
+
+ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
+
+ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
+ = maybeParen ctxt_prec pREC_FUN $
+ hsep [ppForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty]
+
+-- gaw 2004
+ppr_mono_ty ctxt_prec (HsBangTy b ty) = ppBang b +++ ppLType ty
+ppr_mono_ty ctxt_prec (HsTyVar name) = ppDocName name
+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2
+ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (map ppLType tys)
+ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppKind kind)
+ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
+ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty)
+ppr_mono_ty ctxt_prec (HsPredTy pred) = parens (ppPred pred)
+ppr_mono_ty ctxt_prec (HsNumTy n) = toHtml (show n) -- generics only
+ppr_mono_ty ctxt_prec (HsSpliceTy s) = error "ppr_mono_ty-haddock"
+
+ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
+ = maybeParen ctxt_prec pREC_CON $
+ hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty]
+
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2)
+ = maybeParen ctxt_prec pREC_OP $
+ ppr_mono_lty pREC_OP ty1 <+> ppLDocName op <+> ppr_mono_lty pREC_OP ty2
+
+ppr_mono_ty ctxt_prec (HsParTy ty)
+ = parens (ppr_mono_lty pREC_TOP ty)
+
+ppr_mono_ty ctxt_prec (HsDocTy ty doc)
+ = ppLType ty
+
+ppr_fun_ty ctxt_prec ty1 ty2
+ = let p1 = ppr_mono_lty pREC_FUN ty1
+ p2 = ppr_mono_lty pREC_TOP ty2
+ in
+ maybeParen ctxt_prec pREC_FUN $
+ hsep [p1, arrow <+> p2]
-- ----------------------------------------------------------------------------
-- Names
@@ -1236,6 +1318,7 @@ empty = noHtml
parens, brackets, braces :: Html -> Html
parens h = char '(' +++ h +++ char ')'
brackets h = char '[' +++ h +++ char ']'
+pabrackets h = toHtml "[:" +++ h +++ toHtml ":]"
braces h = char '{' +++ h +++ char '}'
punctuate :: Html -> [Html] -> [Html]
@@ -1350,6 +1433,7 @@ dcolon, arrow, darrow :: Html
dcolon = toHtml "::"
arrow = toHtml "->"
darrow = toHtml "=>"
+dot = toHtml "."
s8, s15 :: HtmlTable
s8 = tda [ theclass "s8" ] << noHtml