diff options
Diffstat (limited to 'haddock-api/src/Haddock')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 7 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 23 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 31 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 3 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Specialize.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Types.hs | 2 |
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 |