Handle -XStarIsType

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