aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs1
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs7
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs23
-rw-r--r--haddock-api/src/Haddock/Convert.hs31
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs3
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs2
-rw-r--r--haddock-api/src/Haddock/Types.hs2
7 files changed, 27 insertions, 42 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index e7ecac73..acb2c892 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -307,6 +307,7 @@ classify tok =
ITminus -> TkGlyph
ITbang -> TkGlyph
ITdot -> TkOperator
+ ITstar {} -> TkOperator
ITtypeApp -> TkGlyph
ITbiglam -> TkGlyph
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 3cc4c278..b73a35cc 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1000,8 +1000,7 @@ ppr_mono_ty ctxt_prec (HsDocTy _ ty _) unicode
ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_'
ppr_mono_ty _ (HsTyLit _ t) u = ppr_tylit t u
-
-ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy"
+ppr_mono_ty _ (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)
ppr_tylit :: HsTyLit -> Bool -> LaTeX
@@ -1266,12 +1265,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 '.'
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 819c9aa6..224802a7 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1192,16 +1192,22 @@ ppr_mono_ty ctxt_prec (HsQualTy _ ctxt ty) unicode qual emptyCtxts
-- UnicodeSyntax alternatives
ppr_mono_ty _ (HsTyVar _ _ (L _ name)) True _ _
- | getOccString (getName name) == "*" = toHtml "★"
| 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 _ (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 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 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
@@ -1214,7 +1220,6 @@ ppr_mono_ty _ (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCore
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 $
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 4635c076..9979ebb7 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -36,7 +36,7 @@ import TyCon
import Type
import TyCoRep
import TysPrim ( alphaTyVars )
-import TysWiredIn ( listTyConName, starKindTyConName, unitTy )
+import TysWiredIn ( listTyConName, liftedTypeKindTyConName, unitTy )
import PrelNames ( hasKey, eqTyConKey, ipClassKey
, tYPETyConKey, liftedRepDataConKey )
import Unique ( getUnique )
@@ -167,7 +167,7 @@ synifyTyCon _coax tc
-- algebraic data nor newtype:
, dd_ctxt = noLoc []
, dd_cType = Nothing
- , dd_kindSig = synifyDataTyConReturnKind tc
+ , dd_kindSig = Just (synifyKindSig (tyConKind tc))
-- we have their kind accurately:
, dd_cons = [] -- No constructors
, dd_derivs = noLoc [] }
@@ -222,7 +222,7 @@ synifyTyCon coax tc
-- CoAxioms, not their TyCons
_ -> synifyName tc
tyvars = synifyTyVars (tyConVisibleTyVars tc)
- kindSig = synifyDataTyConReturnKind tc
+ kindSig = Just (tyConKind tc)
-- The data constructors.
--
-- Any data-constructors not exported from the module that *defines* the
@@ -248,7 +248,7 @@ synifyTyCon coax tc
, dd_ND = alg_nd
, dd_ctxt = alg_ctx
, dd_cType = Nothing
- , dd_kindSig = kindSig
+ , dd_kindSig = fmap synifyKindSig kindSig
, dd_cons = cons
, dd_derivs = alg_deriv }
in case lefts consRaw of
@@ -258,27 +258,6 @@ synifyTyCon coax tc
, tcdDExt = DataDeclRn False placeHolderNamesTc }
dataConErrs -> Left $ unlines dataConErrs
--- In this module, every TyCon being considered has come from an interface
--- file. This means that when considering a data type constructor such as:
---
--- data Foo (w :: *) (m :: * -> *) (a :: *)
---
--- Then its tyConKind will be (* -> (* -> *) -> * -> *). But beware! We are
--- also rendering the type variables of Foo, so if we synify the tyConKind of
--- Foo in full, we will end up displaying this in Haddock:
---
--- data Foo (w :: *) (m :: * -> *) (a :: *)
--- :: * -> (* -> *) -> * -> *
---
--- Which is entirely wrong (#548). We only want to display the *return* kind,
--- which this function obtains.
-synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn)
-synifyDataTyConReturnKind tc
- = case splitFunTys (tyConKind tc) of
- (_, ret_kind)
- | isLiftedTypeKind ret_kind -> Nothing -- Don't bother displaying :: *
- | otherwise -> Just (synifyKindSig ret_kind)
-
synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity
-> Maybe (LInjectivityAnn GhcRn)
synifyInjectivityAnn Nothing _ _ = Nothing
@@ -447,7 +426,7 @@ synifyType _ (TyConApp tc tys)
| tc `hasKey` tYPETyConKey
, [TyConApp lev []] <- tys
, lev `hasKey` liftedRepDataConKey
- = noLoc (HsTyVar noExt NotPromoted (noLoc starKindTyConName))
+ = noLoc (HsTyVar noExt NotPromoted (noLoc liftedTypeKindTyConName))
-- Use non-prefix tuple syntax where possible, because it looks nicer.
| Just sort <- tyConTuple_maybe tc
, tyConArity tc == length tys
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index c07f8300..86d9fd6a 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -233,6 +233,8 @@ renameType t = case t of
HsTyVar _ ip (L l n) -> return . HsTyVar NoExt ip . L l =<< rename n
HsBangTy _ b ltype -> return . HsBangTy NoExt b =<< renameLType ltype
+ HsStarTy _ isUni -> return (HsStarTy NoExt isUni)
+
HsAppTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
@@ -276,7 +278,6 @@ renameType t = case t of
HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
HsSpliceTy _ s -> renameHsSpliceTy s
HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
- HsAppsTy _ _ -> error "renameType: HsAppsTy"
-- | Rename splices, but _only_ those that turn out to be for types.
-- I think this is actually safe for our possible inputs:
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 2fcb495c..4419e110 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -254,6 +254,7 @@ renameType (HsQualTy x lctxt lt) =
<$> located renameContext lctxt
<*> renameLType lt
renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name
+renameType t@(HsStarTy _ _) = pure t
renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la
renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr
renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
@@ -276,7 +277,6 @@ renameType (HsExplicitTupleTy x ltys) =
HsExplicitTupleTy x <$> renameLTypes ltys
renameType t@(HsTyLit _ _) = pure t
renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
-renameType (HsAppsTy _ _) = error "HsAppsTy: Only used before renaming"
renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index a5ebfa42..ddc20d68 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -669,7 +669,7 @@ instance Monad ErrMsgGhc where
type instance XForAllTy DocNameI = NoExt
type instance XQualTy DocNameI = NoExt
type instance XTyVar DocNameI = NoExt
-type instance XAppsTy DocNameI = NoExt
+type instance XStarTy DocNameI = NoExt
type instance XAppTy DocNameI = NoExt
type instance XFunTy DocNameI = NoExt
type instance XListTy DocNameI = NoExt
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 03:43:03 +0000