diff options
Diffstat (limited to 'compiler')
37 files changed, 512 insertions, 738 deletions
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 6f0cf411b2..0e1bb01221 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -53,7 +53,7 @@ module DataCon ( isVanillaDataCon, classDataCon, dataConCannotMatch, dataConUserTyVarsArePermuted, isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked, - specialPromotedDc, isLegacyPromotableDataCon, isLegacyPromotableTyCon, + specialPromotedDc, -- ** Promotion related functions promoteDataCon @@ -1324,26 +1324,6 @@ isVanillaDataCon dc = dcVanilla dc specialPromotedDc :: DataCon -> Bool specialPromotedDc = isKindTyCon . dataConTyCon --- | Was this datacon promotable before GHC 8.0? That is, is it promotable --- without -XTypeInType -isLegacyPromotableDataCon :: DataCon -> Bool -isLegacyPromotableDataCon dc - = null (dataConEqSpec dc) -- no GADTs - && null (dataConTheta dc) -- no context - && not (isFamInstTyCon (dataConTyCon dc)) -- no data instance constructors - && uniqSetAll isLegacyPromotableTyCon (tyConsOfType (dataConUserType dc)) - --- | Was this tycon promotable before GHC 8.0? That is, is it promotable --- without -XTypeInType -isLegacyPromotableTyCon :: TyCon -> Bool -isLegacyPromotableTyCon tc - = isVanillaAlgTyCon tc || - -- This returns True more often than it should, but it's quite painful - -- to make this fully accurate. And no harm is caused; we just don't - -- require -XTypeInType every time we need to. (We'll always require - -- -XDataKinds, though, so there's no standards-compliance issue.) - isFunTyCon tc || isKindTyCon tc - classDataCon :: Class -> DataCon classDataCon clas = case tyConDataCons (classTyCon clas) of (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index 8fa60a8f64..564e0e3db5 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -79,7 +79,6 @@ module Name ( import GhcPrelude import {-# SOURCE #-} TyCoRep( TyThing ) -import {-# SOURCE #-} PrelNames( starKindTyConKey, unicodeStarKindTyConKey ) import OccName import Module @@ -687,24 +686,6 @@ pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) pprPrefixName :: NamedThing a => a -> SDoc -pprPrefixName thing - | name `hasKey` starKindTyConKey || name `hasKey` unicodeStarKindTyConKey - = ppr name -- See Note [Special treatment for kind *] - | otherwise - = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) +pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) where name = getName thing - -{- -Note [Special treatment for kind *] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do not put parens around the kind '*'. Even though it looks like -an operator, it is really a special case. - -This pprPrefixName stuff is really only used when printing HsSyn, -which has to be polymorphic in the name type, and hence has to go via -the overloaded function pprPrefixOcc. It's easier where we know the -type being pretty printed; eg the pretty-printing code in TyCoRep. - -See Trac #7645, which led to this. --} diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs index bc90dafa98..6dfc6babe8 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs @@ -34,8 +34,7 @@ module RdrName ( -- ** Destruction rdrNameOcc, rdrNameSpace, demoteRdrName, isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, - isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, isStar, - isUniStar, + isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, -- * Local mapping of 'RdrName' to 'Name.Name' LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, @@ -63,7 +62,10 @@ module RdrName ( pprNameProvenance, Parent(..), ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - importSpecLoc, importSpecModule, isExplicitItem, bestImport + importSpecLoc, importSpecModule, isExplicitItem, bestImport, + + -- * Utils for StarIsType + starInfo ) where #include "HsVersions.h" @@ -262,10 +264,6 @@ isExact_maybe :: RdrName -> Maybe Name isExact_maybe (Exact n) = Just n isExact_maybe _ = Nothing -isStar, isUniStar :: RdrName -> Bool -isStar = (fsLit "*" ==) . occNameFS . rdrNameOcc -isUniStar = (fsLit "★" ==) . occNameFS . rdrNameOcc - {- ************************************************************************ * * @@ -1277,3 +1275,87 @@ instance Outputable ImportSpec where pprLoc :: SrcSpan -> SDoc pprLoc (RealSrcSpan s) = text "at" <+> ppr s pprLoc (UnhelpfulSpan {}) = empty + +-- | Display info about the treatment of '*' under NoStarIsType. +-- +-- With StarIsType, three properties of '*' hold: +-- +-- (a) it is not an infix operator +-- (b) it is always in scope +-- (c) it is a synonym for Data.Kind.Type +-- +-- However, the user might not know that he's working on a module with +-- NoStarIsType and write code that still assumes (a), (b), and (c), which +-- actually do not hold in that module. +-- +-- Violation of (a) shows up in the parser. For instance, in the following +-- examples, we have '*' not applied to enough arguments: +-- +-- data A :: * +-- data F :: * -> * +-- +-- Violation of (b) or (c) show up in the renamer and the typechecker +-- respectively. For instance: +-- +-- type K = Either * Bool +-- +-- This will parse differently depending on whether StarIsType is enabled, +-- but it will parse nonetheless. With NoStarIsType it is parsed as a type +-- operator, thus we have ((*) Either Bool). Now there are two cases to +-- consider: +-- +-- 1. There is no definition of (*) in scope. In this case the renamer will +-- fail to look it up. This is a violation of assumption (b). +-- +-- 2. There is a definition of the (*) type operator in scope (for example +-- coming from GHC.TypeNats). In this case the user will get a kind +-- mismatch error. This is a violation of assumption (c). +-- +-- Since NoStarIsType is implied by a fairly common extension TypeOperators, +-- the user might be working on a module with NoStarIsType unbeknownst to him. +-- Even if the user switched off StarIsType manually, he might have forgotten +-- about it and use '*' as 'Data.Kind.Type' out of habit. +-- +-- Thus it is very important to give a hint whenever an assumption about '*' is +-- violated. Unfortunately, it is somewhat difficult to deal with (c), so we +-- limit ourselves to (a) and (b). +-- +-- 'starInfo' generates an appropriate hint to the user depending on the +-- extensions enabled in the module and the name that triggered the error. +-- That is, if we have NoStarIsType and the error is related to '*' or its +-- Unicode variant, the resulting SDoc will contain a helpful suggestion. +-- Otherwise it is empty. +-- +starInfo :: (Bool, Bool) -> RdrName -> SDoc +starInfo (type_operators, star_is_type) rdr_name = + -- One might ask: if can use sdocWithDynFlags here, why bother to take + -- (type_operators, star_is_type) as input? Why not refactor? + -- + -- The reason is that sdocWithDynFlags would provide DynFlags that are active + -- in the module that tries to load the problematic definition, not + -- in the module that is being loaded. + -- + -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint + -- must be displayed even if we load this definition from a module (or GHCi) + -- with StarIsType enabled! + -- + if isUnqualStar && not star_is_type + then text "With NoStarIsType" <> + (if type_operators + then text " (implied by TypeOperators), " + else text ", ") <> + quotes (ppr rdr_name) <> + text " is treated as a regular type operator. " + $$ + text "Did you mean to use " <> quotes (text "Type") <> + text " from Data.Kind instead?" + else empty + where + -- Does rdr_name look like the user might have meant the '*' kind by it? + -- We focus on unqualified stars specifically, because qualified stars are + -- treated as type operators even under StarIsType. + isUnqualStar + | Unqual occName <- rdr_name + = let fs = occNameFS occName + in fs == fsLit "*" || fs == fsLit "★" + | otherwise = False diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs index 5a0159e95f..eeba3d7be8 100644 --- a/compiler/basicTypes/SrcLoc.hs +++ b/compiler/basicTypes/SrcLoc.hs @@ -333,6 +333,7 @@ srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2 where loc1@(SrcLoc f l c) = realSrcSpanStart span loc2 = SrcLoc f l (c+1) + {- ************************************************************************ * * @@ -511,8 +512,8 @@ pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol) data GenLocated l e = L l e deriving (Eq, Ord, Data, Functor, Foldable, Traversable) -type Located e = GenLocated SrcSpan e -type RealLocated e = GenLocated RealSrcSpan e +type Located = GenLocated SrcSpan +type RealLocated = GenLocated RealSrcSpan unLoc :: GenLocated l e -> e unLoc (L _ e) = e diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 8ec181c430..1e85ea133e 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -288,10 +288,8 @@ and have Template Haskell turn it into this: idProxy :: forall k proxy (b :: k). proxy b -> proxy b idProxy x = x -Notice that we explicitly quantified the variable `k`! This is quite bad, as the -latter declaration requires -XTypeInType, while the former does not. Not to -mention that the latter declaration isn't even what the user wrote in the -first place. +Notice that we explicitly quantified the variable `k`! The latter declaration +isn't what the user wrote in the first place. Usually, the culprit behind these bugs is taking implicitly quantified type variables (often from the hsib_vars field of HsImplicitBinders) and putting @@ -1128,6 +1126,7 @@ repTy (HsEqTy _ t1 t2) = do t2' <- repLTy t2 eq <- repTequality repTapps eq [t1', t2'] +repTy (HsStarTy _ _) = repTStar repTy (HsKindSig _ t k) = do t1 <- repLTy t k1 <- repLTy k diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 7487983419..7b721ed1f2 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -963,7 +963,7 @@ the trees to reflect the fixities of the underlying operators: This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and @mkHsOpTyRn@ in RnTypes), which expects that the input will be completely right-biased for types and left-biased for everything else. So we left-bias the -trees of @UInfixP@ and @UInfixE@ and use HsAppsTy for UInfixT. +trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@. Sample input: @@ -1332,10 +1332,8 @@ cvtTypeKind ty_str ty } UInfixT t1 s t2 - -> do { t1' <- cvtType t1 - ; t2' <- cvtType t2 - ; s' <- tconName s - ; return $ cvtOpAppT t1' s' t2' + -> do { t2' <- cvtType t2 + ; cvtOpAppT t1 s t2' } -- Note [Converting UInfix] ParensT t @@ -1445,23 +1443,20 @@ cvtTyLit :: TH.TyLit -> HsTyLit cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) -{- | @cvtOpAppT x op y@ takes converted arguments and flattens any HsAppsTy - structure in them. +{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator +application @x `op` y@. The produced tree of infix types will be right-biased, +provided @y@ is. + +See the @cvtOpApp@ documentation for how this function works. -} -cvtOpAppT :: LHsType GhcPs -> RdrName -> LHsType GhcPs -> LHsType GhcPs -cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _) - = L (combineSrcSpans loc1 loc2) $ - HsAppsTy noExt (t1' ++ [noLoc $ HsAppInfix noExt (noLoc op)] ++ t2') - where - t1' | L _ (HsAppsTy _ t1s) <- t1 - = t1s - | otherwise - = [noLoc $ HsAppPrefix noExt t1] - - t2' | L _ (HsAppsTy _ t2s) <- t2 - = t2s - | otherwise - = [noLoc $ HsAppPrefix noExt t2] +cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs) +cvtOpAppT (UInfixT x op2 y) op1 z + = do { l <- cvtOpAppT y op1 z + ; cvtOpAppT x op2 l } +cvtOpAppT x op y + = do { op' <- tconNameL op + ; x' <- cvtType x + ; returnL (mkHsOpTy x' op' y) } cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) cvtKind = cvtTypeKind "kind" diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 076c590f0b..c7a0ea0716 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -784,11 +784,10 @@ variables and its return type are annotated. - An open type family always has a CUSK -- unannotated type variables (and return type) default to *. - - Additionally, if -XTypeInType is on, then a data definition with a top-level - :: must explicitly bind all kind variables to the right of the ::. - See test dependent/should_compile/KindLevels, which requires this case. - (Naturally, any kind variable mentioned before the :: should not be bound - after it.) + - A data definition with a top-level :: must explicitly bind all kind variables +to the right of the ::. See test dependent/should_compile/KindLevels, which +requires this case. (Naturally, any kind variable mentioned before the :: should +not be bound after it.) -} diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index eb56d3b24e..7243a6514e 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -902,7 +902,6 @@ type ForallXHsWildCardBndrs(c :: * -> Constraint) (x :: *) (b :: *) = type family XForAllTy x type family XQualTy x type family XTyVar x -type family XAppsTy x type family XAppTy x type family XFunTy x type family XListTy x @@ -912,6 +911,7 @@ type family XOpTy x type family XParTy x type family XIParamTy x type family XEqTy x +type family XStarTy x type family XKindSig x type family XSpliceTy x type family XDocTy x @@ -929,7 +929,6 @@ type ForallXType (c :: * -> Constraint) (x :: *) = ( c (XForAllTy x) , c (XQualTy x) , c (XTyVar x) - , c (XAppsTy x) , c (XAppTy x) , c (XFunTy x) , c (XListTy x) @@ -939,6 +938,7 @@ type ForallXType (c :: * -> Constraint) (x :: *) = , c (XParTy x) , c (XIParamTy x) , c (XEqTy x) + , c (XStarTy x) , c (XKindSig x) , c (XSpliceTy x) , c (XDocTy x) @@ -965,18 +965,6 @@ type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) = -- --------------------------------------------------------------------- -type family XAppInfix x -type family XAppPrefix x -type family XXAppType x - -type ForallXAppType (c :: * -> Constraint) (x :: *) = - ( c (XAppInfix x) - , c (XAppPrefix x) - , c (XXAppType x) - ) - --- --------------------------------------------------------------------- - type family XConDeclField x type family XXConDeclField x diff --git a/compiler/hsSyn/HsInstances.hs b/compiler/hsSyn/HsInstances.hs index 70336d87e5..9a9f21d046 100644 --- a/compiler/hsSyn/HsInstances.hs +++ b/compiler/hsSyn/HsInstances.hs @@ -382,11 +382,6 @@ deriving instance Data (HsType GhcPs) deriving instance Data (HsType GhcRn) deriving instance Data (HsType GhcTc) --- deriving instance (DataIdLR p p) => Data (HsAppType p) -deriving instance Data (HsAppType GhcPs) -deriving instance Data (HsAppType GhcRn) -deriving instance Data (HsAppType GhcTc) - -- deriving instance (DataIdLR p p) => Data (ConDeclField p) deriving instance Data (ConDeclField GhcPs) deriving instance Data (ConDeclField GhcRn) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 11d301d816..8e959f7586 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -28,7 +28,6 @@ module HsTypes ( HsContext, LHsContext, HsTyLit(..), HsIPName(..), hsIPNameFS, - HsAppType(..),LHsAppType, LBangType, BangType, HsSrcBang(..), HsImplBang(..), @@ -57,9 +56,9 @@ module HsTypes ( splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, splitLHsPatSynTy, splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy, - splitHsFunType, splitHsAppsTy, - splitHsAppTys, getAppsTyHead_maybe, hsTyGetAppHead_maybe, - mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppsTy, + splitHsFunType, + splitHsAppTys, hsTyGetAppHead_maybe, + mkHsOpTy, mkHsAppTy, mkHsAppTys, ignoreParens, hsSigType, hsSigWcType, hsLTyVarBndrToType, hsLTyVarBndrsToTypes, @@ -487,11 +486,6 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsAppsTy (XAppsTy pass) - [LHsAppType pass] -- Used only before renaming, - -- Note [HsAppsTy] - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - | HsAppTy (XAppTy pass) (LHsType pass) (LHsType pass) @@ -566,6 +560,11 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation + | HsStarTy (XStarTy pass) + Bool -- Is this the Unicode variant? + -- Note [HsStarTy] + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + | HsKindSig (XKindSig pass) (LHsType pass) -- (ty :: kind) (LHsKind pass) -- A type with a kind signature @@ -658,7 +657,6 @@ instance Outputable NewHsTypeX where type instance XForAllTy (GhcPass _) = NoExt type instance XQualTy (GhcPass _) = NoExt type instance XTyVar (GhcPass _) = NoExt -type instance XAppsTy (GhcPass _) = NoExt type instance XAppTy (GhcPass _) = NoExt type instance XFunTy (GhcPass _) = NoExt type instance XListTy (GhcPass _) = NoExt @@ -668,6 +666,7 @@ type instance XOpTy (GhcPass _) = NoExt type instance XParTy (GhcPass _) = NoExt type instance XIParamTy (GhcPass _) = NoExt type instance XEqTy (GhcPass _) = NoExt +type instance XStarTy (GhcPass _) = NoExt type instance XKindSig (GhcPass _) = NoExt type instance XSpliceTy GhcPs = NoExt @@ -709,27 +708,6 @@ newtype HsWildCardInfo -- See Note [The wildcard story for types] -- A anonymous wild card ('_'). A fresh Name is generated for -- each individual anonymous wildcard during renaming --- | Located Haskell Application Type -type LHsAppType pass = Located (HsAppType pass) - -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSimpleQuote' - --- | Haskell Application Type -data HsAppType pass - = HsAppInfix (XAppInfix pass) - (Located (IdP pass)) -- either a symbol or an id in backticks - | HsAppPrefix (XAppPrefix pass) - (LHsType pass) -- anything else, including things like (+) - | XAppType - (XXAppType pass) - -type instance XAppInfix (GhcPass _) = NoExt -type instance XAppPrefix (GhcPass _) = NoExt -type instance XXAppType (GhcPass _) = NoExt - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (HsAppType p) where - ppr = ppr_app_ty - {- Note [HsForAllTy tyvar binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -785,16 +763,18 @@ HsTyVar: A name in a type or kind. The 'Promoted' field in an HsTyVar captures whether the type was promoted in the source code by prefixing an apostrophe. -Note [HsAppsTy] +Note [HsStarTy] ~~~~~~~~~~~~~~~ -How to parse +When the StarIsType extension is enabled, we want to treat '*' and its Unicode +variant identically to 'Data.Kind.Type'. Unfortunately, doing so in the parser +would mean that when we pretty-print it back, we don't know whether the user +wrote '*' or 'Type', and lose the parse/ppr roundtrip property. - Foo * Int +As a workaround, we parse '*' as HsStarTy (if it stands for 'Data.Kind.Type') +and then desugar it to 'Data.Kind.Type' in the typechecker (see tc_hs_type). +When '*' is a regular type operator (StarIsType is disabled), HsStarTy is not +involved. -? Is it `(*) Foo Int` or `Foo GHC.Types.* Int`? There's no way to know until renaming. -So we just take type expressions like this and put each component in a list, so be -sorted out in the renamer. The sorting out is done by RnTypes.mkHsOpTyRn. This means -that the parser should never produce HsAppTy or HsOpTy. Note [Promoted lists and tuples] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1042,12 +1022,6 @@ mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) mkHsAppTys = foldl mkHsAppTy -mkHsAppsTy :: [LHsAppType GhcPs] -> HsType GhcPs --- In the common case of a singleton non-operator, --- avoid the clutter of wrapping in a HsAppsTy -mkHsAppsTy [L _ (HsAppPrefix _ (L _ ty))] = ty -mkHsAppsTy app_tys = HsAppsTy NoExt app_tys - {- ************************************************************************ * * @@ -1083,38 +1057,7 @@ splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2)) splitHsFunType other = ([], other) --------------------------------- --- | Retrieves the head of an HsAppsTy, if this can be done unambiguously, --- without consulting fixities. -getAppsTyHead_maybe :: [LHsAppType (GhcPass p)] - -> Maybe ( LHsType (GhcPass p) - , [LHsType (GhcPass p)], LexicalFixity) -getAppsTyHead_maybe tys = case splitHsAppsTy tys of - ([app1:apps], []) -> -- no symbols, some normal types - Just (mkHsAppTys app1 apps, [], Prefix) - ([app1l:appsl, app1r:appsr], [L loc op]) -> -- one operator - Just ( L loc (HsTyVar noExt NotPromoted (L loc op)) - , [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr], Infix) - _ -> -- can't figure it out - Nothing - --- | Splits a [HsAppType pass] (the payload of an HsAppsTy) into regions of --- prefix types (normal types) and infix operators. --- If @splitHsAppsTy tys = (non_syms, syms)@, then @tys@ starts with the first --- element of @non_syms@ followed by the first element of @syms@ followed by --- the next element of @non_syms@, etc. It is guaranteed that the non_syms list --- has one more element than the syms list. -splitHsAppsTy :: [LHsAppType pass] -> ([[LHsType pass]], [Located (IdP pass)]) -splitHsAppsTy = go [] [] [] - where - go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym) - go acc acc_non acc_sym (L _ (HsAppPrefix _ ty) : rest) - = go (ty : acc) acc_non acc_sym rest - go acc acc_non acc_sym (L _ (HsAppInfix _ op) : rest) - = go [] (reverse acc : acc_non) (op : acc_sym) rest - go _ _ _ (L _ (XAppType _):_) = panic "splitHsAppsTy" - --- Retrieve the name of the "head" of a nested type application +-- retrieve the name of the "head" of a nested type application -- somewhat like splitHsAppTys, but a little more thorough -- used to examine the result of a GADT-like datacon, so it doesn't handle -- *all* cases (like lists, tuples, (~), etc.) @@ -1123,9 +1066,6 @@ hsTyGetAppHead_maybe :: LHsType (GhcPass p) hsTyGetAppHead_maybe = go [] where go tys (L _ (HsTyVar _ _ ln)) = Just (ln, tys) - go tys (L _ (HsAppsTy _ apps)) - | Just (head, args, _) <- getAppsTyHead_maybe apps - = go (args ++ tys) head go tys (L _ (HsAppTy _ l r)) = go (r : tys) l go tys (L _ (HsOpTy _ l (L loc n) r)) = Just (L loc n, l : r : tys) go tys (L _ (HsParTy _ t)) = go tys t @@ -1134,7 +1074,6 @@ hsTyGetAppHead_maybe = go [] splitHsAppTys :: LHsType GhcRn -> [LHsType GhcRn] -> (LHsType GhcRn, [LHsType GhcRn]) - -- no need to worry about HsAppsTy here splitHsAppTys (L _ (HsAppTy _ f a)) as = splitHsAppTys f (a:as) splitHsAppTys (L _ (HsParTy _ f)) as = splitHsAppTys f as splitHsAppTys f as = (f,as) @@ -1459,8 +1398,7 @@ ppr_mono_ty (HsWildCardTy {}) = char '_' ppr_mono_ty (HsEqTy _ ty1 ty2) = ppr_mono_lty ty1 <+> char '~' <+> ppr_mono_lty ty2 -ppr_mono_ty (HsAppsTy _ tys) - = hsep (map (ppr_app_ty . unLoc) tys) +ppr_mono_ty (HsStarTy _ isUni) = char (if isUni then '★' else '*') ppr_mono_ty (HsAppTy _ fun_ty arg_ty) = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] @@ -1493,19 +1431,6 @@ ppr_fun_ty ty1 ty2 sep [p1, text "->" <+> p2] -------------------------- -ppr_app_ty :: (OutputableBndrId (GhcPass p)) => HsAppType (GhcPass p) -> SDoc -ppr_app_ty (HsAppInfix _ (L _ n)) = pprInfixOcc n -ppr_app_ty (HsAppPrefix _ (L _ (HsTyVar _ NotPromoted (L _ n)))) - = pprPrefixOcc n -ppr_app_ty (HsAppPrefix _ (L _ (HsTyVar _ Promoted (L _ n)))) - = space <> quote (pprPrefixOcc n) -- We need a space before the ' above, so - -- the parser does not attach it to the - -- previous symbol -ppr_app_ty (HsAppPrefix _ ty) = ppr_mono_lty ty - -ppr_app_ty (XAppType ty) = ppr ty - --------------------------- ppr_tylit :: HsTyLit -> SDoc ppr_tylit (HsNumTy _ i) = integer i ppr_tylit (HsStrTy _ s) = text (show s) @@ -1533,7 +1458,7 @@ hsTypeNeedsParens p = go go (HsTyLit{}) = False go (HsWildCardTy{}) = False go (HsEqTy{}) = p >= opPrec - go (HsAppsTy _ args) = p >= appPrec && not (null args) + go (HsStarTy{}) = False go (HsAppTy{}) = p >= appPrec go (HsOpTy{}) = p >= opPrec go (HsParTy{}) = False diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index 9426a30d95..537f419cc4 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -1020,7 +1020,7 @@ pprTyTcApp' ctxt_prec tc tys dflags style | tc `ifaceTyConHasKey` tYPETyConKey , ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys , rep `ifaceTyConHasKey` liftedRepDataConKey - = kindStar + = kindType | otherwise = getPprDebug $ \dbg -> @@ -1130,10 +1130,8 @@ ppr_iface_tc_app pp _ tc [ty] | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty) ppr_iface_tc_app pp ctxt_prec tc tys - | tc `ifaceTyConHasKey` starKindTyConKey - || tc `ifaceTyConHasKey` liftedTypeKindTyConKey - || tc `ifaceTyConHasKey` unicodeStarKindTyConKey - = kindStar -- Handle unicode; do not wrap * in parens + | tc `ifaceTyConHasKey` liftedTypeKindTyConKey + = kindType | not (isSymOcc (nameOccName (ifaceTyConName tc))) = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 09481591ce..13570dbfee 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -36,6 +36,7 @@ module DynFlags ( xopt, xopt_set, xopt_unset, lang_set, useUnicodeSyntax, + useStarIsType, whenGeneratingDynamicToo, ifGeneratingDynamicToo, whenCannotGenerateDynamicToo, dynamicTooMkDynamicDynFlags, @@ -804,6 +805,7 @@ data WarningFlag = | Opt_WarnPartialFields -- Since 8.4 | Opt_WarnMissingExportList | Opt_WarnInaccessibleCode + | Opt_WarnStarIsType -- Since 8.6 deriving (Eq, Show, Enum) data Language = Haskell98 | Haskell2010 @@ -2102,6 +2104,8 @@ languageExtensions Nothing languageExtensions (Just Haskell98) = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, LangExt.MonomorphismRestriction, LangExt.NPlusKPatterns, LangExt.DatatypeContexts, @@ -2116,6 +2120,8 @@ languageExtensions (Just Haskell98) languageExtensions (Just Haskell2010) = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, LangExt.MonomorphismRestriction, LangExt.DatatypeContexts, LangExt.TraditionalRecordSyntax, @@ -2250,6 +2256,9 @@ lang_set dflags lang = useUnicodeSyntax :: DynFlags -> Bool useUnicodeSyntax = gopt Opt_PrintUnicodeSyntax +useStarIsType :: DynFlags -> Bool +useStarIsType = xopt LangExt.StarIsType + -- | Set the Haskell language standard to use setLanguage :: Language -> DynP () setLanguage l = upd (`lang_set` Just l) @@ -3835,6 +3844,7 @@ wWarningFlagsDeps = [ flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints, flagSpec "missing-home-modules" Opt_WarnMissingHomeModules, flagSpec "unrecognised-warning-flags" Opt_WarnUnrecognisedWarningFlags, + flagSpec "star-is-type" Opt_WarnStarIsType, flagSpec "partial-fields" Opt_WarnPartialFields ] -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@ @@ -4204,6 +4214,7 @@ xFlagsDeps = [ flagSpec "RoleAnnotations" LangExt.RoleAnnotations, flagSpec "ScopedTypeVariables" LangExt.ScopedTypeVariables, flagSpec "StandaloneDeriving" LangExt.StandaloneDeriving, + flagSpec "StarIsType" LangExt.StarIsType, flagSpec "StaticPointers" LangExt.StaticPointers, flagSpec "Strict" LangExt.Strict, flagSpec "StrictData" LangExt.StrictData, @@ -4330,9 +4341,12 @@ impliedXFlags , (LangExt.TypeFamilies, turnOn, LangExt.KindSignatures) -- Type families use kind signatures , (LangExt.PolyKinds, turnOn, LangExt.KindSignatures) -- Ditto polymorphic kinds + + -- TypeInType is now just a synonym for a couple of other extensions. , (LangExt.TypeInType, turnOn, LangExt.DataKinds) , (LangExt.TypeInType, turnOn, LangExt.PolyKinds) , (LangExt.TypeInType, turnOn, LangExt.KindSignatures) + , (LangExt.TypeInType, turnOff, LangExt.StarIsType) -- AutoDeriveTypeable is not very useful without DeriveDataTypeable , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable) @@ -4344,6 +4358,9 @@ impliedXFlags , (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes) + -- See Note [When is StarIsType enabled] + , (LangExt.TypeOperators, turnOff, LangExt.StarIsType) + -- Record wild-cards implies field disambiguation -- Otherwise if you write (C {..}) you may well get -- stuff like " 'a' not in scope ", which is a bit silly @@ -4364,6 +4381,20 @@ impliedXFlags , (LangExt.Strict, turnOn, LangExt.StrictData) ] +-- Note [When is StarIsType enabled] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The StarIsType extension determines whether to treat '*' as a regular type +-- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType +-- programs expect '*' to be synonymous with 'Type', so by default StarIsType is +-- enabled. +-- +-- However, programs that use TypeOperators might expect to repurpose '*' for +-- multiplication or another binary operation, so we make TypeOperators imply +-- NoStarIsType. +-- +-- It is still possible to have TypeOperators and StarIsType enabled at the same +-- time, although it's not recommended. + -- Note [Documenting optimisation flags] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot index 7440e5db00..823fd22854 100644 --- a/compiler/main/DynFlags.hs-boot +++ b/compiler/main/DynFlags.hs-boot @@ -13,6 +13,7 @@ pprCols :: DynFlags -> Int unsafeGlobalDynFlags :: DynFlags useUnicode :: DynFlags -> Bool useUnicodeSyntax :: DynFlags -> Bool +useStarIsType :: DynFlags -> Bool shouldUseColor :: DynFlags -> Bool shouldUseHexWordLiterals :: DynFlags -> Bool hasPprDebug :: DynFlags -> Bool diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 9823c60f70..8949799198 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -1834,8 +1834,7 @@ mkPrintUnqualified dflags env = QueryQualify qual_name forceUnqualNames :: [Name] forceUnqualNames = - map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon - , starKindTyCon, unicodeStarKindTyCon ] + map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ] ++ [ eqTyConName ] right_name gre = nameModule_maybe (gre_name gre) == Just mod diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 69dc0992c8..2887edff04 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -68,6 +68,8 @@ module Lexer ( explicitNamespacesEnabled, patternSynonymsEnabled, sccProfilingOn, hpcEnabled, + typeOperatorsEnabled, + starIsTypeEnabled, addWarning, lexTokenStream, addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn, @@ -682,6 +684,7 @@ data Token | ITdarrow IsUnicodeSyntax | ITminus | ITbang + | ITstar IsUnicodeSyntax | ITdot | ITbiglam -- GHC-extension symbols @@ -893,6 +896,8 @@ reservedSymsFM = listToUFM $ ,("-", ITminus, always) ,("!", ITbang, always) + ,("*", ITstar NormalSyntax, starIsTypeEnabled) + -- For 'forall a . t' ,(".", ITdot, always) -- \i -> explicitForallEnabled i || inRulePrag i) @@ -915,6 +920,8 @@ reservedSymsFM = listToUFM $ \i -> unicodeSyntaxEnabled i && arrowsEnabled i) ,("⤜", ITRarrowtail UnicodeSyntax, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("★", ITstar UnicodeSyntax, + \i -> unicodeSyntaxEnabled i && starIsTypeEnabled i) -- ToDo: ideally, → and ∷ should be "specials", so that they cannot -- form part of a large operator. This would let us have a better @@ -2257,6 +2264,8 @@ data ExtBits | TypeApplicationsBit | StaticPointersBit | NumericUnderscoresBit + | TypeOperatorsBit + | StarIsTypeBit deriving Enum @@ -2325,6 +2334,10 @@ staticPointersEnabled :: ExtsBitmap -> Bool staticPointersEnabled = xtest StaticPointersBit numericUnderscoresEnabled :: ExtsBitmap -> Bool numericUnderscoresEnabled = xtest NumericUnderscoresBit +typeOperatorsEnabled :: ExtsBitmap -> Bool +typeOperatorsEnabled = xtest TypeOperatorsBit +starIsTypeEnabled :: ExtsBitmap -> Bool +starIsTypeEnabled = xtest StarIsTypeBit -- PState for parsing options pragmas -- @@ -2343,47 +2356,56 @@ mkParserFlags flags = , pExtsBitmap = bitmap } where - bitmap = FfiBit `setBitIf` xopt LangExt.ForeignFunctionInterface flags - .|. InterruptibleFfiBit `setBitIf` xopt LangExt.InterruptibleFFI flags - .|. CApiFfiBit `setBitIf` xopt LangExt.CApiFFI flags - .|. ArrowsBit `setBitIf` xopt LangExt.Arrows flags - .|. ThBit `setBitIf` xopt LangExt.TemplateHaskell flags - .|. ThQuotesBit `setBitIf` xopt LangExt.TemplateHaskellQuotes flags - .|. QqBit `setBitIf` xopt LangExt.QuasiQuotes flags - .|. IpBit `setBitIf` xopt LangExt.ImplicitParams flags - .|. OverloadedLabelsBit `setBitIf` xopt LangExt.OverloadedLabels flags - .|. ExplicitForallBit `setBitIf` xopt LangExt.ExplicitForAll flags - .|. BangPatBit `setBitIf` xopt LangExt.BangPatterns flags - .|. HaddockBit `setBitIf` gopt Opt_Haddock flags - .|. MagicHashBit `setBitIf` xopt LangExt.MagicHash flags - .|. RecursiveDoBit `setBitIf` xopt LangExt.RecursiveDo flags - .|. UnicodeSyntaxBit `setBitIf` xopt LangExt.UnicodeSyntax flags - .|. UnboxedTuplesBit `setBitIf` xopt LangExt.UnboxedTuples flags - .|. UnboxedSumsBit `setBitIf` xopt LangExt.UnboxedSums flags - .|. DatatypeContextsBit `setBitIf` xopt LangExt.DatatypeContexts flags - .|. TransformComprehensionsBit `setBitIf` xopt LangExt.TransformListComp flags - .|. TransformComprehensionsBit `setBitIf` xopt LangExt.MonadComprehensions flags - .|. RawTokenStreamBit `setBitIf` gopt Opt_KeepRawTokenStream flags - .|. HpcBit `setBitIf` gopt Opt_Hpc flags - .|. AlternativeLayoutRuleBit `setBitIf` xopt LangExt.AlternativeLayoutRule flags - .|. RelaxedLayoutBit `setBitIf` xopt LangExt.RelaxedLayout flags - .|. SccProfilingOnBit `setBitIf` gopt Opt_SccProfilingOn flags - .|. NondecreasingIndentationBit `setBitIf` xopt LangExt.NondecreasingIndentation flags - .|. SafeHaskellBit `setBitIf` safeImportsOn flags - .|. TraditionalRecordSyntaxBit `setBitIf` xopt LangExt.TraditionalRecordSyntax flags - .|. ExplicitNamespacesBit `setBitIf` xopt LangExt.ExplicitNamespaces flags - .|. LambdaCaseBit `setBitIf` xopt LangExt.LambdaCase flags - .|. BinaryLiteralsBit `setBitIf` xopt LangExt.BinaryLiterals flags - .|. NegativeLiteralsBit `setBitIf` xopt LangExt.NegativeLiterals flags - .|. HexFloatLiteralsBit `setBitIf` xopt LangExt.HexFloatLiterals flags - .|. PatternSynonymsBit `setBitIf` xopt LangExt.PatternSynonyms flags - .|. TypeApplicationsBit `setBitIf` xopt LangExt.TypeApplications flags - .|. StaticPointersBit `setBitIf` xopt LangExt.StaticPointers flags - .|. NumericUnderscoresBit `setBitIf` xopt LangExt.NumericUnderscores flags - - setBitIf :: ExtBits -> Bool -> ExtsBitmap - b `setBitIf` cond | cond = xbit b - | otherwise = 0 + bitmap = safeHaskellBit .|. langExtBits .|. optBits + safeHaskellBit = + SafeHaskellBit `setBitIf` safeImportsOn flags + langExtBits = + FfiBit `xoptBit` LangExt.ForeignFunctionInterface + .|. InterruptibleFfiBit `xoptBit` LangExt.InterruptibleFFI + .|. CApiFfiBit `xoptBit` LangExt.CApiFFI + .|. ArrowsBit `xoptBit` LangExt.Arrows + .|. ThBit `xoptBit` LangExt.TemplateHaskell + .|. ThQuotesBit `xoptBit` LangExt.TemplateHaskellQuotes + .|. QqBit `xoptBit` LangExt.QuasiQuotes + .|. IpBit `xoptBit` LangExt.ImplicitParams + .|. OverloadedLabelsBit `xoptBit` LangExt.OverloadedLabels + .|. ExplicitForallBit `xoptBit` LangExt.ExplicitForAll + .|. BangPatBit `xoptBit` LangExt.BangPatterns + .|. MagicHashBit `xoptBit` LangExt.MagicHash + .|. RecursiveDoBit `xoptBit` LangExt.RecursiveDo + .|. UnicodeSyntaxBit `xoptBit` LangExt.UnicodeSyntax + .|. UnboxedTuplesBit `xoptBit` LangExt.UnboxedTuples + .|. UnboxedSumsBit `xoptBit` LangExt.UnboxedSums + .|. DatatypeContextsBit `xoptBit` LangExt.DatatypeContexts + .|. TransformComprehensionsBit `xoptBit` LangExt.TransformListComp + .|. TransformComprehensionsBit `xoptBit` LangExt.MonadComprehensions + .|. AlternativeLayoutRuleBit `xoptBit` LangExt.AlternativeLayoutRule + .|. RelaxedLayoutBit `xoptBit` LangExt.RelaxedLayout + .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation + .|. TraditionalRecordSyntaxBit `xoptBit` LangExt.TraditionalRecordSyntax + .|. ExplicitNamespacesBit `xoptBit` LangExt.ExplicitNamespaces + .|. LambdaCaseBit `xoptBit` LangExt.LambdaCase + .|. BinaryLiteralsBit `xoptBit` LangExt.BinaryLiterals + .|. NegativeLiteralsBit `xoptBit` LangExt.NegativeLiterals + .|. HexFloatLiteralsBit `xoptBit` LangExt.HexFloatLiterals + .|. PatternSynonymsBit `xoptBit` LangExt.PatternSynonyms + .|. TypeApplicationsBit `xoptBit` LangExt.TypeApplications + .|. StaticPointersBit `xoptBit` LangExt.StaticPointers + .|. NumericUnderscoresBit `xoptBit` LangExt.NumericUnderscores + .|. TypeOperatorsBit `xoptBit` LangExt.TypeOperators + .|. StarIsTypeBit `xoptBit` LangExt.StarIsType + optBits = + HaddockBit `goptBit` Opt_Haddock + .|. RawTokenStreamBit `goptBit` Opt_KeepRawTokenStream + .|. HpcBit `goptBit` Opt_Hpc + .|. SccProfilingOnBit `goptBit` Opt_SccProfilingOn + + xoptBit bit ext = bit `setBitIf` xopt ext flags + goptBit bit opt = bit `setBitIf` gopt opt flags + + setBitIf :: ExtBits -> Bool -> ExtsBitmap + b `setBitIf` cond | cond = xbit b + | otherwise = 0 -- | Creates a parse state from a 'DynFlags' value mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 25edb3e591..c1ee8a4855 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -88,7 +88,7 @@ import GhcPrelude import qualified GHC.LanguageExtensions as LangExt } -%expect 233 -- shift/reduce conflicts +%expect 235 -- shift/reduce conflicts {- Last updated: 04 June 2018 @@ -158,7 +158,7 @@ Shift parses as (per longest-parse rule): ------------------------------------------------------------------------------- -state 143 contains 14 shift/reduce conflicts. +state 144 contains 15 shift/reduce conflicts. exp -> infixexp . '::' sigtype exp -> infixexp . '-<' exp @@ -169,7 +169,7 @@ state 143 contains 14 shift/reduce conflicts. infixexp -> infixexp . qop exp10 Conflicts: ':' '::' '-' '!' '-<' '>-' '-<<' '>>-' - '.' '`' VARSYM CONSYM QVARSYM QCONSYM + '.' '`' '*' VARSYM CONSYM QVARSYM QCONSYM Examples of ambiguity: 'if x then y else z -< e' @@ -183,7 +183,7 @@ Shift parses as (per longest-parse rule): ------------------------------------------------------------------------------- -state 148 contains 68 shift/reduce conflicts. +state 149 contains 67 shift/reduce conflicts. *** exp10 -> fexp . fexp -> fexp . aexp @@ -201,7 +201,7 @@ Shift parses as (per longest-parse rule): ------------------------------------------------------------------------------- -state 204 contains 28 shift/reduce conflicts. +state 204 contains 27 shift/reduce conflicts. aexp2 -> TH_TY_QUOTE . tyvar aexp2 -> TH_TY_QUOTE . gtycon @@ -220,7 +220,7 @@ Shift parses as (per longest-parse rule): ------------------------------------------------------------------------------- -state 308 contains 1 shift/reduce conflicts. +state 300 contains 1 shift/reduce conflicts. rule -> STRING . rule_activation rule_forall infixexp '=' exp @@ -238,7 +238,7 @@ a rule instructing how to rewrite the expression '[0] f'. ------------------------------------------------------------------------------- -state 318 contains 1 shift/reduce conflict. +state 310 contains 1 shift/reduce conflict. *** type -> btype . type -> btype . '->' ctype @@ -249,7 +249,7 @@ Same as state 61 but without contexts. ------------------------------------------------------------------------------- -state 362 contains 1 shift/reduce conflicts. +state 354 contains 1 shift/reduce conflicts. tup_exprs -> commas . tup_tail sysdcon_nolist -> '(' commas . ')' @@ -264,7 +264,7 @@ if -XTupleSections is not specified. ------------------------------------------------------------------------------- -state 418 contains 1 shift/reduce conflicts. +state 409 contains 1 shift/reduce conflicts. tup_exprs -> commas . tup_tail sysdcon_nolist -> '(#' commas . '#)' @@ -272,21 +272,21 @@ state 418 contains 1 shift/reduce conflicts. Conflict: '#)' (empty tup_tail reduces) -Same as State 362 for unboxed tuples. +Same as State 354 for unboxed tuples. ------------------------------------------------------------------------------- -state 429 contains 68 shift/reduce conflicts. +state 417 contains 67 shift/reduce conflicts. *** exp10 -> '-' fexp . fexp -> fexp . aexp fexp -> fexp . TYPEAPP atype -Same as 148 but with a unary minus. +Same as 149 but with a unary minus. ------------------------------------------------------------------------------- -state 493 contains 1 shift/reduce conflict. +state 481 contains 1 shift/reduce conflict. oqtycon -> '(' qtyconsym . ')' *** qtyconop -> qtyconsym . @@ -300,7 +300,7 @@ parenthesized infix type expression of length 1. ------------------------------------------------------------------------------- -state 694 contains 1 shift/reduce conflicts. +state 675 contains 1 shift/reduce conflicts. *** aexp2 -> ipvar . dbind -> ipvar . '=' exp @@ -315,7 +315,7 @@ sensible meaning, namely the lhs of an implicit binding. ------------------------------------------------------------------------------- -state 771 contains 1 shift/reduce conflicts. +state 752 contains 1 shift/reduce conflicts. rule -> STRING rule_activation . rule_forall infixexp '=' exp @@ -332,7 +332,7 @@ doesn't include 'forall'. ------------------------------------------------------------------------------- -state 1019 contains 1 shift/reduce conflicts. +state 986 contains 1 shift/reduce conflicts. transformqual -> 'then' 'group' . 'using' exp transformqual -> 'then' 'group' . 'by' exp 'using' exp @@ -342,7 +342,7 @@ state 1019 contains 1 shift/reduce conflicts. ------------------------------------------------------------------------------- -state 1404 contains 1 shift/reduce conflict. +state 1367 contains 1 shift/reduce conflict. *** atype -> tyvar . tv_bndr -> '(' tyvar . '::' kind ')' @@ -526,6 +526,7 @@ are the most common patterns, rewritten as regular expressions for clarity: '=>' { L _ (ITdarrow _) } '-' { L _ ITminus } '!' { L _ ITbang } + '*' { L _ (ITstar _) } '-<' { L _ (ITlarrowtail _) } -- for arrow notation '>-' { L _ (ITrarrowtail _) } -- for arrow notation '-<<' { L _ (ITLarrowtail _) } -- for arrow notation @@ -1160,11 +1161,7 @@ deriv_strategy_no_via :: { LDerivStrategy GhcPs } [mj AnnNewtype $1] } deriv_strategy_via :: { LDerivStrategy GhcPs } - : 'via' tyapp {% splitTildeApps [$2] >>= \tys -> let - ty :: LHsType GhcPs - ty = sL1 $1 $ mkHsAppsTy tys - - in ams (sLL $1 $> (ViaStrategy (mkLHsSigType ty))) + : 'via' type {% ams (sLL $1 $> (ViaStrategy (mkLHsSigType $2))) [mj AnnVia $1] } deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) } @@ -1856,7 +1853,7 @@ context :: { LHsContext GhcPs } } } context_no_ops :: { LHsContext GhcPs } - : btype_no_ops {% do { ty <- splitTilde $1 + : btype_no_ops {% do { ty <- splitTilde (reverse (unLoc $1)) ; (anns,ctx) <- checkContext ty ; if null (unLoc ctx) then addAnnotation (gl ty) AnnUnit (gl ty) @@ -1911,29 +1908,27 @@ typedoc :: { LHsType GhcPs } -- See Note [Parsing ~] btype :: { LHsType GhcPs } - : tyapps {% splitTildeApps (reverse (unLoc $1)) >>= - \ts -> return $ sL1 $1 $ mkHsAppsTy ts } + : tyapps {% mergeOps (unLoc $1) } -- Used for parsing Haskell98-style data constructors, -- in order to forbid the blasphemous -- > data Foo = Int :+ Char :* Bool -- See also Note [Parsing data constructors is hard] in RdrHsSyn -btype_no_ops :: { LHsType GhcPs } - : btype_no_ops atype_docs { sLL $1 $> $ HsAppTy noExt $1 $2 } - | atype_docs { $1 } +btype_no_ops :: { Located [LHsType GhcPs] } -- NB: This list is reversed + : atype_docs { sL1 $1 [$1] } + | btype_no_ops atype_docs { sLL $1 $> $ $2 : (unLoc $1) } -tyapps :: { Located [LHsAppType GhcPs] } -- NB: This list is reversed +tyapps :: { Located [Located TyEl] } -- NB: This list is reversed : tyapp { sL1 $1 [$1] } | tyapps tyapp { sLL $1 $> $ $2 : (unLoc $1) } --- See Note [HsAppsTy] in HsTypes -tyapp :: { LHsAppType GhcPs } - : atype { sL1 $1 $ HsAppPrefix noExt $1 } - | qtyconop { sL1 $1 $ HsAppInfix noExt $1 } - | tyvarop { sL1 $1 $ HsAppInfix noExt $1 } - | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ HsAppInfix noExt $2) +tyapp :: { Located TyEl } + : atype { sL1 $1 $ TyElOpd (unLoc $1) } + | qtyconop { sL1 $1 $ TyElOpr (unLoc $1) } + | tyvarop { sL1 $1 $ TyElOpr (unLoc $1) } + | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ TyElOpr (unLoc $2)) [mj AnnSimpleQuote $1] } - | SIMPLEQUOTE varop {% ams (sLL $1 $> $ HsAppInfix noExt $2) + | SIMPLEQUOTE varop {% ams (sLL $1 $> $ TyElOpr (unLoc $2)) [mj AnnSimpleQuote $1] } atype_docs :: { LHsType GhcPs } @@ -1943,6 +1938,8 @@ atype_docs :: { LHsType GhcPs } atype :: { LHsType GhcPs } : ntgtycon { sL1 $1 (HsTyVar noExt NotPromoted $1) } -- Not including unit tuples | tyvar { sL1 $1 (HsTyVar noExt NotPromoted $1) } -- (See Note [Unit tuples]) + | '*' {% do { warnStarIsType (getLoc $1) + ; return $ sL1 $1 (HsStarTy noExt (isUnicode $1)) } } | strict_mark atype {% ams (sLL $1 $> (HsBangTy noExt (snd $ unLoc $1) $2)) (fst $ unLoc $1) } -- Constructor sigs only | '{' fielddecls '}' {% amms (checkRecordSyntax @@ -2061,13 +2058,13 @@ Note [Parsing ~] Due to parsing conflicts between laziness annotations in data type declarations (see strict_mark) and equality types ~'s are always -parsed as laziness annotations, and turned into HsEqTy's in the +parsed as laziness annotations, and turned into HsOpTy's in the correct places using RdrHsSyn.splitTilde. Since strict_mark is parsed as part of atype which is part of type, typedoc and context (where HsEqTy previously appeared) it made most sense and was simplest to parse ~ as part of strict_mark and later -turn them into HsEqTy's. +turn them into HsOpTy's. -} @@ -2191,14 +2188,15 @@ forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr GhcPs]) } constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString) } -- See Note [Parsing data constructors is hard] in RdrHsSyn - : btype_no_ops {% do { c <- splitCon $1 - ; return $ sLL $1 $> c } } + : btype_no_ops {% do { c <- splitCon (unLoc $1) + ; return $ sL1 $1 c } } | btype_no_ops conop maybe_docprev btype_no_ops - {% do { lhs <- splitTilde $1 - ; (_, ds_l) <- checkInfixConstr lhs - ; (rhs, ds_r) <- checkInfixConstr $4 + {% do { lhs <- splitTilde (reverse (unLoc $1)) + ; (_, ds_l) <- checkInfixConstr lhs + ; let rhs1 = foldl1 mkHsAppTy (reverse (unLoc $4)) + ; (rhs, ds_r) <- checkInfixConstr rhs1 ; return $ if isJust (ds_l `mplus` $3) - then sLL $1 $> ($2, InfixCon lhs $4, $3) + then sLL $1 $> ($2, InfixCon lhs rhs1, $3) else sLL $1 $> ($2, InfixCon lhs rhs, ds_r) } } fielddecls :: { [LConDeclField GhcPs] } @@ -3370,6 +3368,7 @@ special_id special_sym :: { Located FastString } special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] } | '.' { sL1 $1 (fsLit ".") } + | '*' { sL1 $1 (fsLit (if isUnicode $1 then "★" else "*")) } ----------------------------------------------------------------------------- -- Data constructors @@ -3552,6 +3551,7 @@ isUnicode (L _ (IToparenbar iu)) = iu == UnicodeSyntax isUnicode (L _ (ITcparenbar iu)) = iu == UnicodeSyntax isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax isUnicode (L _ (ITcloseQuote iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITstar iu)) = iu == UnicodeSyntax isUnicode _ = False hasE :: Located Token -> Bool diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 35371af9c8..64b74d3317 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -57,7 +57,8 @@ module RdrHsSyn ( checkRecordSyntax, checkEmptyGADTs, parseErrorSDoc, hintBangPat, - splitTilde, splitTildeApps, + splitTilde, + TyEl(..), mergeOps, -- Help with processing exports ImpExpSubSpec(..), @@ -67,6 +68,10 @@ module RdrHsSyn ( mkImpExpSubSpec, checkImportSpec, + -- Warnings and errors + warnStarIsType, + failOpFewArgs, + SumOrTuple (..), mkSumOrTuple ) where @@ -87,8 +92,7 @@ import Lexeme ( isLexCon ) import Type ( TyThing(..) ) import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon, nilDataConName, nilDataConKey, - listTyConName, listTyConKey, - starKindTyConName, unicodeStarKindTyConName ) + listTyConName, listTyConKey ) import ForeignCall import PrelNames ( forall_tv_RDR, eqTyCon_RDR, allNameStrings ) import SrcLoc @@ -103,7 +107,7 @@ import ApiAnnotation import HsExtension ( noExt ) import Data.List import qualified GHC.LanguageExtensions as LangExt -import MonadUtils +import DynFlags ( WarningFlag(..) ) import Control.Monad import Text.ParserCombinators.ReadP as ReadP @@ -479,9 +483,15 @@ So the plan is: data T = (+++) will parse ok (since tycons can be operators), but we should reject it (Trac #12051). + +'splitCon' takes a reversed list @apps@ of types as input, such that +@foldl1 mkHsAppTy (reverse apps)@ yields the original type. This is because +this is easy for the parser to produce and we avoid the overhead of unrolling +'HsAppTy'. + -} -splitCon :: LHsType GhcPs +splitCon :: [LHsType GhcPs] -> P ( Located RdrName -- constructor name , HsConDeclDetails GhcPs -- constructor field information , Maybe LHsDocString -- docstring to go on the constructor @@ -491,15 +501,11 @@ splitCon :: LHsType GhcPs -- C Int Bool -- or C { x::Int, y::Bool } -- and returns the pieces -splitCon ty +splitCon apps = split apps' [] where - -- This is used somewhere where HsAppsTy is not used - unrollApps (L _ (HsAppTy _ t u)) = u : unrollApps t - unrollApps t = [t] - - apps = unrollApps ty oneDoc = [ () | L _ (HsDocTy{}) <- apps ] `lengthIs` 1 + ty = foldl1 mkHsAppTy (reverse apps) -- the trailing doc, if any, can be extracted first (apps', trailing_doc) @@ -865,15 +871,6 @@ checkTyClHdr is_cls ty | isRdrTc tc = return (ltc, t1:t2:acc, Infix, ann) go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix - go _ (HsAppsTy _ ts) acc ann _fix - | Just (head, args, fixity) <- getAppsTyHead_maybe ts - = goL head (args ++ acc) ann fixity - - go _ (HsAppsTy _ [L _ (HsAppInfix _ (L loc star))]) [] ann fix - | isStar star - = return (L loc (nameRdrName starKindTyConName), [], fix, ann) - | isUniStar star - = return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann) go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix = return (L l (nameRdrName tup_name), ts, fix, ann) @@ -927,10 +924,6 @@ checkContext (L l orig_t) -- be used as context constraints. = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto () - -- don't let HsAppsTy get in the way - check anns (L _ (HsAppsTy _ [L _ (HsAppPrefix _ ty)])) - = check anns ty - check anns (L lp1 (HsParTy _ ty)) -- to be sure HsParTy doesn't get into the way = check anns' ty @@ -1276,56 +1269,78 @@ isFunLhs e = go e [] [] _ -> return Nothing } go _ _ _ = return Nothing - --- | Transform btype_no_ops with strict_mark's into HsEqTy's --- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d -splitTilde :: LHsType GhcPs -> P (LHsType GhcPs) -splitTilde t = go t - where go (L loc (HsAppTy _ t1 t2)) - | L lo (HsBangTy _ (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2') - <- t2 - = do - moveAnnotations lo loc - t1' <- go t1 - return (L loc (HsEqTy noExt t1' t2')) - | otherwise - = do - t1' <- go t1 - case t1' of - (L lo (HsEqTy _ tl tr)) -> do - let lr = combineLocs tr t2 - moveAnnotations lo loc - return (L loc (HsEqTy noExt tl - (L lr (HsAppTy noExt tr t2)))) - t -> do - return (L loc (HsAppTy noExt t t2)) - - go t = return t - - --- | Transform tyapps with strict_marks into uses of twiddle --- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d -splitTildeApps :: [LHsAppType GhcPs] -> P [LHsAppType GhcPs] -splitTildeApps [] = return [] -splitTildeApps (t : rest) = do - rest' <- concatMapM go rest - return (t : rest') - where go (L l (HsAppPrefix _ - (L loc (HsBangTy noExt - (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) - ty)))) - = addAnnotation l AnnTilde tilde_loc >> - return - [L tilde_loc (HsAppInfix noExt (L tilde_loc eqTyCon_RDR)), - L l (HsAppPrefix noExt ty)] - -- NOTE: no annotation is attached to an HsAppPrefix, so the - -- surrounding SrcSpan is not critical - where - tilde_loc = srcSpanFirstCharacter loc - - go t = return [t] - - +-- | Transform a list of 'atype' with 'strict_mark' into +-- HsOpTy's of 'eqTyCon_RDR': +-- +-- [~a, ~b, c, ~d] ==> (~a) ~ ((b c) ~ d) +-- +-- See Note [Parsing ~] +splitTilde :: [LHsType GhcPs] -> P (LHsType GhcPs) +splitTilde [] = panic "splitTilde" +splitTilde (x:xs) = go x xs + where + -- We accumulate applications in the LHS until we encounter a laziness + -- annotation. For example, if we have [Foo, x, y, ~Bar, z], the 'lhs' + -- accumulator will become '(Foo x) y'. Then we strip the laziness + -- annotation off 'Bar' and process the tail [Bar, z] recursively. + -- + -- This leaves us with 'lhs = (Foo x) y' and 'rhs = Bar z'. + -- In case the tail contained more laziness annotations, they would be + -- processed similarly. This makes '~' right-associative. + go lhs [] = return lhs + go lhs (x:xs) + | L loc (HsBangTy _ (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t) <- x + = do { rhs <- splitTilde (t:xs) + ; let r = mkLHsOpTy lhs (tildeOp loc) rhs + ; moveAnnotations loc (getLoc r) + ; return r } + | otherwise + = go (mkHsAppTy lhs x) xs + + tildeOp loc = L (srcSpanFirstCharacter loc) eqTyCon_RDR + +-- | Either an operator or an operand. +data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs) + +-- | Merge a /reversed/ and /non-empty/ soup of operators and operands +-- into a type. +-- +-- User input: @F x y + G a b * X@ +-- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F] +-- Output corresponds to what the user wrote assuming all operators are of the +-- same fixity and right-associative. +-- +-- It's a bit silly that we're doing it at all, as the renamer will have to +-- rearrange this, and it'd be easier to keep things separate. +mergeOps :: [Located TyEl] -> P (LHsType GhcPs) +mergeOps = go [] id + where + -- clause (a): + -- when we encounter an operator, we must have accumulated + -- something for its rhs, and there must be something left + -- to build its lhs. + go acc ops_acc (L l (TyElOpr op):xs) = + if null acc || null xs + then failOpFewArgs (L l op) + else do { a <- splitTilde acc + ; go [] (\c -> mkLHsOpTy c (L l op) (ops_acc a)) xs } + + -- clause (b): + -- whenever an operand is encountered, it is added to the accumulator + go acc ops_acc (L l (TyElOpd a):xs) = go (L l a:acc) ops_acc xs + + -- clause (c): + -- at this point we know that 'acc' is non-empty because + -- there are three options when 'acc' can be empty: + -- 1. 'mergeOps' was called with an empty list, and this + -- should never happen + -- 2. 'mergeOps' was called with a list where the head is an + -- operator, this is handled by clause (a) + -- 3. 'mergeOps' was called with a list where the head is an + -- operand, this is handled by clause (b) + go acc ops_acc [] = + do { a <- splitTilde acc + ; return (ops_acc a) } --------------------------------------------------------------------------- -- Check for monad comprehensions @@ -1715,6 +1730,28 @@ isImpExpQcWildcard ImpExpQcWildcard = True isImpExpQcWildcard _ = False ----------------------------------------------------------------------------- +-- Warnings and failures + +warnStarIsType :: SrcSpan -> P () +warnStarIsType span = addWarning Opt_WarnStarIsType span msg + where + msg = text "Using" <+> quotes (text "*") + <+> text "(or its Unicode variant) to mean" + <+> quotes (text "Data.Kind.Type") + $$ text "relies on the StarIsType extension." + $$ text "Suggested fix: use" <+> quotes (text "Type") + <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead." + +failOpFewArgs :: Located RdrName -> P a +failOpFewArgs (L loc op) = + do { type_operators <- extension typeOperatorsEnabled + ; star_is_type <- extension starIsTypeEnabled + ; let msg = too_few $$ starInfo (type_operators, star_is_type) op + ; parseErrorSDoc loc msg } + where + too_few = text "Operator applied to too few arguments:" <+> ppr op + +----------------------------------------------------------------------------- -- Misc utils parseErrorSDoc :: SrcSpan -> SDoc -> P a @@ -1748,3 +1785,8 @@ mkSumOrTuple Boxed l (Sum alt arity (L _ e)) = text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")" ppr_bars n = hsep (replicate n (Outputable.char '|')) + +mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs +mkLHsOpTy x op y = + let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y + in L loc (mkHsOpTy x op y) diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 88541120ca..5ed67d591f 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -1750,14 +1750,11 @@ eitherTyConKey = mkPreludeTyConUnique 84 -- Kind constructors liftedTypeKindTyConKey, tYPETyConKey, - constraintKindTyConKey, - starKindTyConKey, unicodeStarKindTyConKey, runtimeRepTyConKey, + constraintKindTyConKey, runtimeRepTyConKey, vecCountTyConKey, vecElemTyConKey :: Unique liftedTypeKindTyConKey = mkPreludeTyConUnique 87 tYPETyConKey = mkPreludeTyConUnique 88 constraintKindTyConKey = mkPreludeTyConUnique 92 -starKindTyConKey = mkPreludeTyConUnique 93 -unicodeStarKindTyConKey = mkPreludeTyConUnique 94 runtimeRepTyConKey = mkPreludeTyConUnique 95 vecCountTyConKey = mkPreludeTyConUnique 96 vecElemTyConKey = mkPreludeTyConUnique 97 @@ -2471,5 +2468,5 @@ The following names should be considered by GHCi to be in scope always. pretendNameIsInScope :: Name -> Bool pretendNameIsInScope n = any (n `hasKey`) - [ starKindTyConKey, liftedTypeKindTyConKey, tYPETyConKey + [ liftedTypeKindTyConKey, tYPETyConKey , runtimeRepTyConKey, liftedRepDataConKey ] diff --git a/compiler/prelude/PrelNames.hs-boot b/compiler/prelude/PrelNames.hs-boot index e25c83618f..0bd74d5577 100644 --- a/compiler/prelude/PrelNames.hs-boot +++ b/compiler/prelude/PrelNames.hs-boot @@ -4,5 +4,4 @@ import Module import Unique mAIN :: Module -starKindTyConKey :: Unique -unicodeStarKindTyConKey :: Unique +liftedTypeKindTyConKey :: Unique diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 9ba2f1f45a..1156d810b9 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -91,9 +91,8 @@ module TysWiredIn ( -- * Kinds typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind, isLiftedTypeKindTyConName, liftedTypeKind, constraintKind, - starKindTyCon, starKindTyConName, - unicodeStarKindTyCon, unicodeStarKindTyConName, liftedTypeKindTyCon, constraintKindTyCon, + liftedTypeKindTyConName, -- * Equality predicates heqTyCon, heqClass, heqDataCon, @@ -224,8 +223,6 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because then , vecElemTyCon , constraintKindTyCon , liftedTypeKindTyCon - , starKindTyCon - , unicodeStarKindTyCon ] mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name @@ -389,11 +386,8 @@ typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") constraintKindTyConName :: Name constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon -liftedTypeKindTyConName, starKindTyConName, unicodeStarKindTyConName - :: Name +liftedTypeKindTyConName :: Name liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon -starKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "*") starKindTyConKey starKindTyCon -unicodeStarKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "★") unicodeStarKindTyConKey unicodeStarKindTyCon runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName :: Name runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon @@ -1063,25 +1057,13 @@ mk_class tycon sc_pred sc_sel_id runtimeRepTy :: Type runtimeRepTy = mkTyConTy runtimeRepTyCon -liftedTypeKindTyCon, starKindTyCon, unicodeStarKindTyCon :: TyCon - -- Type synonyms; see Note [TYPE and RuntimeRep] in TysPrim -- type Type = tYPE 'LiftedRep --- type * = tYPE 'LiftedRep --- type * = tYPE 'LiftedRep -- Unicode variant - +liftedTypeKindTyCon :: TyCon liftedTypeKindTyCon = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] (tYPE liftedRepTy) -starKindTyCon = buildSynTyCon starKindTyConName - [] liftedTypeKind [] - (tYPE liftedRepTy) - -unicodeStarKindTyCon = buildSynTyCon unicodeStarKindTyConName - [] liftedTypeKind [] - (tYPE liftedRepTy) - runtimeRepTyCon :: TyCon runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing [] (vecRepDataCon : tupleRepDataCon : diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 6d940299e4..3c0d8f5327 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -13,7 +13,7 @@ module RnEnv ( lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe, lookupLocalOccRn_maybe, lookupInfoOccRn, lookupLocalOccThLvl_maybe, lookupLocalOccRn, - lookupTypeOccRn, lookupKindOccRn, + lookupTypeOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc, @@ -824,20 +824,6 @@ lookupLocalOccRn rdr_name Just name -> return name Nothing -> unboundName WL_LocalOnly rdr_name } -lookupKindOccRn :: RdrName -> RnM Name --- Looking up a name occurring in a kind -lookupKindOccRn rdr_name - | isVarOcc (rdrNameOcc rdr_name) -- See Note [Promoted variables in types] - = badVarInType rdr_name - | otherwise - = do { typeintype <- xoptM LangExt.TypeInType - ; if | typeintype -> lookupTypeOccRn rdr_name - -- With -XNoTypeInType, treat any usage of * in kinds as in scope - -- this is a dirty hack, but then again so was the old * kind. - | isStar rdr_name -> return starKindTyConName - | isUniStar rdr_name -> return unicodeStarKindTyConName - | otherwise -> lookupOccRn rdr_name } - -- lookupPromotedOccRn looks up an optionally promoted RdrName. lookupTypeOccRn :: RdrName -> RnM Name -- see Note [Demotion] @@ -846,16 +832,18 @@ lookupTypeOccRn rdr_name = badVarInType rdr_name | otherwise = do { mb_name <- lookupOccRn_maybe rdr_name - ; case mb_name of { - Just name -> return name ; - Nothing -> do { dflags <- getDynFlags - ; lookup_demoted rdr_name dflags } } } + ; case mb_name of + Just name -> return name + Nothing -> lookup_demoted rdr_name } -lookup_demoted :: RdrName -> DynFlags -> RnM Name -lookup_demoted rdr_name dflags +lookup_demoted :: RdrName -> RnM Name +lookup_demoted rdr_name | Just demoted_rdr <- demoteRdrName rdr_name -- Maybe it's the name of a *data* constructor = do { data_kinds <- xoptM LangExt.DataKinds + ; type_operators <- xoptM LangExt.TypeOperators + ; star_is_type <- xoptM LangExt.StarIsType + ; let star_info = starInfo (type_operators, star_is_type) rdr_name ; if data_kinds then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr ; case mb_demoted_name of @@ -873,7 +861,7 @@ lookup_demoted rdr_name dflags mb_demoted_name <- discardErrs $ lookupOccRn_maybe demoted_rdr ; let suggestion | isJust mb_demoted_name = suggest_dk - | otherwise = star_info + | otherwise = star_info ; unboundNameX WL_Any rdr_name suggestion } } | otherwise @@ -889,17 +877,6 @@ lookup_demoted rdr_name dflags , text "instead of" , quotes (ppr name) <> dot ] - star_info - | isStar rdr_name || isUniStar rdr_name - = if xopt LangExt.TypeInType dflags - then text "NB: With TypeInType, you must import" <+> - ppr rdr_name <+> text "from Data.Kind" - else empty - - | otherwise - = empty - - badVarInType :: RdrName -> RnM Name badVarInType rdr_name = do { addErr (text "Illegal promoted term variable in a type:" diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index a53adf2cba..50841af818 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -1509,9 +1509,7 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs -> do { (defn', fvs) <- rnDataDefn doc defn -- See Note [Complete user-supplied kind signatures] in HsDecls - ; typeintype <- xoptM LangExt.TypeInType - ; let cusk = hsTvbAllKinded tyvars' && - (not typeintype || no_rhs_kvs) + ; let cusk = hsTvbAllKinded tyvars' && no_rhs_kvs rn_info = DataDeclRn { tcdDataCusk = cusk , tcdFVs = fvs } ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs) diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 1f08856142..3d60a9f6c3 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -53,7 +53,6 @@ import TcRnMonad import RdrName import PrelNames import TysPrim ( funTyConName ) -import TysWiredIn ( starKindTyConName, unicodeStarKindTyConName ) import Name import SrcLoc import NameSet @@ -341,9 +340,6 @@ rnImplicitBndrs bind_free_tvs ; traceRn "checkMixedVars2" $ vcat [ text "kvs_with_dups" <+> ppr kvs_with_dups , text "tvs_with_dups" <+> ppr tvs_with_dups ] - ; checkMixedVars kvs_with_dups tvs_with_dups - -- E.g. Either (Proxy (a :: k)) k - -- Here 'k' is used at kind level and type level ; bindLocalNamesFV vars $ thing_inside vars } @@ -395,35 +391,6 @@ f :: forall a. a -> (() => b) binds "a" and "b" This situation is now considered to be an error. See rnHsTyKi for case HsForAllTy Qualified. -Note [Dealing with *] -~~~~~~~~~~~~~~~~~~~~~ -As a legacy from the days when types and kinds were different, we use -the type * to mean what we now call GHC.Types.Type. The problem is that -* should associate just like an identifier, *not* a symbol. -Running example: the user has written - - T (Int, Bool) b + c * d - -At this point, we have a bunch of stretches of types - - [[T, (Int, Bool), b], [c], [d]] - -these are the [[LHsType Name]] and a bunch of operators - - [GHC.TypeLits.+, GHC.Types.*] - -Note that the * is GHC.Types.*. So, we want to rearrange to have - - [[T, (Int, Bool), b], [c, *, d]] - -and - - [GHC.TypeLits.+] - -as our lists. We can then do normal fixity resolution on these. The fixities -must come along for the ride just so that the list stays in sync with the -operators. - Note [QualTy in kinds] ~~~~~~~~~~~~~~~~~~~~~~ I was wondering whether QualTy could occur only at TypeLevel. But no, @@ -525,7 +492,7 @@ rnLHsTyKi env (L loc ty) rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau }) - = do { checkTypeInType env ty + = do { checkPolyKinds env ty ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty) Nothing tyvars $ \ tyvars' -> do { (tau', fvs) <- rnLHsTyKi env tau @@ -534,7 +501,7 @@ rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau }) , fvs) } } rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) - = do { checkTypeInType env ty -- See Note [QualTy in kinds] + = do { checkPolyKinds env ty -- See Note [QualTy in kinds] ; (ctxt', fvs1) <- rnTyKiContext env lctxt ; (tau', fvs2) <- rnLHsTyKi env tau ; return (HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt' @@ -569,6 +536,7 @@ rnHsTyKi env (HsParTy _ ty) rnHsTyKi env (HsBangTy _ b ty) = do { (ty', fvs) <- rnLHsTyKi env ty ; return (HsBangTy noExt b ty', fvs) } + rnHsTyKi env ty@(HsRecTy _ flds) = do { let ctxt = rtke_ctxt env ; fls <- get_fields ctxt @@ -601,7 +569,7 @@ rnHsTyKi env listTy@(HsListTy _ ty) ; return (HsListTy noExt ty', fvs) } rnHsTyKi env t@(HsKindSig _ ty k) - = do { checkTypeInType env t + = do { checkPolyKinds env t ; kind_sigs_ok <- xoptM LangExt.KindSignatures ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty) ; (ty', fvs1) <- rnLHsTyKi env ty @@ -629,70 +597,13 @@ rnHsTyKi env tyLit@(HsTyLit _ t) = do { data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env tyLit)) ; when (negLit t) (addErr negLitErr) - ; checkTypeInType env tyLit + ; checkPolyKinds env tyLit ; return (HsTyLit noExt t, emptyFVs) } where negLit (HsStrTy _ _) = False negLit (HsNumTy _ i) = i < 0 negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit -rnHsTyKi env overall_ty@(HsAppsTy _ tys) - = do { -- Step 1: Break up the HsAppsTy into symbols and non-symbol regions - let (non_syms, syms) = splitHsAppsTy tys - - -- Step 2: rename the pieces - ; (syms1, fvs1) <- mapFvRn (rnHsTyOp env overall_ty) syms - ; (non_syms1, fvs2) <- (mapFvRn . mapFvRn) (rnLHsTyKi env) non_syms - - -- Step 3: deal with *. See Note [Dealing with *] - ; let (non_syms2, syms2) = deal_with_star [] [] non_syms1 syms1 - - -- Step 4: collapse the non-symbol regions with HsAppTy - ; non_syms3 <- mapM deal_with_non_syms non_syms2 - - -- Step 5: assemble the pieces, using mkHsOpTyRn - ; L _ res_ty <- build_res_ty non_syms3 syms2 - - -- all done. Phew. - ; return (res_ty, fvs1 `plusFV` fvs2) } - where - -- See Note [Dealing with *] - deal_with_star :: [[LHsType GhcRn]] -> [Located Name] - -> [[LHsType GhcRn]] -> [Located Name] - -> ([[LHsType GhcRn]], [Located Name]) - deal_with_star acc1 acc2 - (non_syms1 : non_syms2 : non_syms) (L loc star : ops) - | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey - = deal_with_star acc1 acc2 - ((non_syms1 ++ L loc (HsTyVar noExt NotPromoted (L loc star)) - : non_syms2) : non_syms) - ops - deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops) - = deal_with_star (non_syms1 : acc1) (op1 : acc2) non_syms ops - deal_with_star acc1 acc2 [non_syms] [] - = (reverse (non_syms : acc1), reverse acc2) - deal_with_star _ _ _ _ - = pprPanic "deal_with_star" (ppr overall_ty) - - -- collapse [LHsType GhcRn] to LHsType GhcRn by making applications - -- monadic only for failure - deal_with_non_syms :: [LHsType GhcRn] -> RnM (LHsType GhcRn) - deal_with_non_syms (non_sym : non_syms) = return $ mkHsAppTys non_sym non_syms - deal_with_non_syms [] = failWith (emptyNonSymsErr overall_ty) - - -- assemble a right-biased OpTy for use in mkHsOpTyRn - build_res_ty :: [LHsType GhcRn] -> [Located Name] -> RnM (LHsType GhcRn) - build_res_ty (arg1 : args) (op1 : ops) - = do { rhs <- build_res_ty args ops - ; fix <- lookupTyFixityRn op1 - ; res <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 op1 t2) (unLoc op1) - fix arg1 rhs - ; let loc = combineSrcSpans (getLoc arg1) (getLoc rhs) - ; return (L loc res) - } - build_res_ty [arg] [] = return arg - build_res_ty _ _ = pprPanic "build_op_ty" (ppr overall_ty) - rnHsTyKi env (HsAppTy _ ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi env ty1 ; (ty2', fvs2) <- rnLHsTyKi env ty2 @@ -704,11 +615,14 @@ rnHsTyKi env t@(HsIParamTy _ n ty) ; return (HsIParamTy noExt n ty', fvs) } rnHsTyKi env t@(HsEqTy _ ty1 ty2) - = do { checkTypeInType env t + = do { checkPolyKinds env t ; (ty1', fvs1) <- rnLHsTyKi env ty1 ; (ty2', fvs2) <- rnLHsTyKi env ty2 ; return (HsEqTy noExt ty1' ty2', fvs1 `plusFV` fvs2) } +rnHsTyKi _ (HsStarTy _ isUni) + = return (HsStarTy noExt isUni, emptyFVs) + rnHsTyKi _ (HsSpliceTy _ sp) = rnSpliceType sp @@ -723,14 +637,14 @@ rnHsTyKi _ (XHsType (NHsCoreTy ty)) -- but I don't think it matters rnHsTyKi env ty@(HsExplicitListTy _ ip tys) - = do { checkTypeInType env ty + = do { checkPolyKinds env ty ; data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env ty)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys ; return (HsExplicitListTy noExt ip tys', fvs) } rnHsTyKi env ty@(HsExplicitTupleTy _ tys) - = do { checkTypeInType env ty + = do { checkPolyKinds env ty ; data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env ty)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys @@ -747,9 +661,7 @@ rnHsTyKi env (HsWildCardTy _) -------------- rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name rnTyVar env rdr_name - = do { name <- if isRnKindLevel env - then lookupKindOccRn rdr_name - else lookupTypeOccRn rdr_name + = do { name <- lookupTypeOccRn rdr_name ; checkNamedWildCard env name ; return name } @@ -766,10 +678,7 @@ rnHsTyOp :: Outputable a rnHsTyOp env overall_ty (L loc op) = do { ops_ok <- xoptM LangExt.TypeOperators ; op' <- rnTyVar env op - ; unless (ops_ok - || op' == starKindTyConName - || op' == unicodeStarKindTyConName - || op' `hasKey` eqTyConKey) $ + ; unless (ops_ok || op' `hasKey` eqTyConKey) $ addErr (opTyErr op overall_ty) ; let l_op' = L loc op' ; return (l_op', unitFV op') } @@ -844,18 +753,18 @@ rnAnonWildCard ; return (AnonWildCard (L loc name)) } --------------- --- | Ensures either that we're in a type or that -XTypeInType is set -checkTypeInType :: Outputable ty +-- | Ensures either that we're in a type or that -XPolyKinds is set +checkPolyKinds :: Outputable ty => RnTyKiEnv -> ty -- ^ type -> RnM () -checkTypeInType env ty +checkPolyKinds env ty | isRnKindLevel env - = do { type_in_type <- xoptM LangExt.TypeInType - ; unless type_in_type $ + = do { polykinds <- xoptM LangExt.PolyKinds + ; unless polykinds $ addErr (text "Illegal kind:" <+> ppr ty $$ - text "Did you mean to enable TypeInType?") } -checkTypeInType _ _ = return () + text "Did you mean to enable PolyKinds?") } +checkPolyKinds _ _ = return () notInKinds :: Outputable ty => RnTyKiEnv @@ -863,7 +772,7 @@ notInKinds :: Outputable ty -> RnM () notInKinds env ty | isRnKindLevel env - = addErr (text "Illegal kind (even with TypeInType enabled):" <+> ppr ty) + = addErr (text "Illegal kind:" <+> ppr ty) notInKinds _ _ = return () {- ***************************************************** @@ -942,7 +851,6 @@ bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside , text "bndr_kv_occs" <+> ppr bndr_kv_occs , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs) ] - ; checkMixedVars kv_occs bndrs ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs @@ -1050,20 +958,14 @@ In implementation terms Note [Variables used as both types and kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In (checkMixedVars kvs tvs), we bind the type variables tvs, and kvs is the -set of free variables of the kinds in the scope of the binding. Here is one -typical example: +We bind the type variables tvs, and kvs is the set of free variables of the +kinds in the scope of the binding. Here is one typical example: forall a b. a -> (b::k) -> (c::a) Here, tvs will be {a,b}, and kvs {k,a}. -Without -XTypeInType we want to complain that `a` is used both -as a type and a kind. - -Specifically, check that there is no overlap between kvs and tvs -See typecheck/should_fail/T11963 for examples. -We must also make sure that kvs includes all of variables in the kinds of type +We must make sure that kvs includes all of variables in the kinds of type variable bindings. For instance: forall k (a :: k). Proxy a @@ -1071,8 +973,7 @@ variable bindings. For instance: If we only look in the body of the `forall` type, we will mistakenly conclude that kvs is {}. But in fact, the type variable `k` is also used as a kind variable in (a :: k), later in the binding. (This mistake lead to #14710.) -So tvs is {k,a} and kvs is {k}, so we must also reject this without the use -of -XTypeInType. +So tvs is {k,a} and kvs is {k}. NB: we do this only at the binding site of 'tvs'. -} @@ -1140,7 +1041,6 @@ collectAnonWildCards lty = go lty where go (L _ ty) = case ty of HsWildCardTy (AnonWildCard (L _ wc)) -> [wc] - HsAppsTy _ tys -> gos (mapMaybe (prefix_types_only . unLoc) tys) HsAppTy _ ty1 ty2 -> go ty1 `mappend` go ty2 HsFunTy _ ty1 ty2 -> go ty1 `mappend` go ty2 HsListTy _ ty -> go ty @@ -1165,14 +1065,11 @@ collectAnonWildCards lty = go lty HsSpliceTy{} -> mempty HsTyLit{} -> mempty HsTyVar{} -> mempty + HsStarTy{} -> mempty XHsType{} -> mempty gos = mconcat . map go - prefix_types_only (HsAppPrefix _ ty) = Just ty - prefix_types_only (HsAppInfix _ _) = Nothing - prefix_types_only (XAppType _) = Nothing - collectAnonWildCardsBndrs :: [LHsTyVarBndr GhcRn] -> [Name] collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs where @@ -1587,10 +1484,6 @@ opTyErr op overall_ty | otherwise = text "Use TypeOperators to allow operators in types" -emptyNonSymsErr :: HsType GhcPs -> SDoc -emptyNonSymsErr overall_ty - = text "Operator applied to too few arguments:" <+> ppr overall_ty - {- ************************************************************************ * * @@ -1829,7 +1722,6 @@ extract_lty t_or_k (L _ ty) acc HsRecTy _ flds -> foldrM (extract_lty t_or_k . cd_fld_type . unLoc) acc flds - HsAppsTy _ tys -> extract_apps t_or_k tys acc HsAppTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<< extract_lty t_or_k ty2 acc HsListTy _ ty -> extract_lty t_or_k ty acc @@ -1849,6 +1741,7 @@ extract_lty t_or_k (L _ ty) acc HsExplicitListTy _ _ tys -> extract_ltys t_or_k tys acc HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc HsTyLit _ _ -> return acc + HsStarTy _ _ -> return acc HsKindSig _ ty ki -> extract_lty t_or_k ty =<< extract_lkind ki acc HsForAllTy { hst_bndrs = tvs, hst_body = ty } @@ -1861,16 +1754,6 @@ extract_lty t_or_k (L _ ty) acc -- We deal with these separately in rnLHsTypeWithWildCards HsWildCardTy {} -> return acc -extract_apps :: TypeOrKind - -> [LHsAppType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars -extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys - -extract_app :: TypeOrKind -> LHsAppType GhcPs - -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups -extract_app t_or_k (L _ (HsAppInfix _ tv)) acc = extract_tv t_or_k tv acc -extract_app t_or_k (L _ (HsAppPrefix _ ty)) acc = extract_lty t_or_k ty acc -extract_app _ (L _ (XAppType _ )) _ = panic "extract_app" - extractHsTvBndrs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsWithDups -- Free in body -> RnM FreeKiTyVarsWithDups -- Free in result @@ -1906,7 +1789,6 @@ extract_hs_tv_bndrs tv_bndrs , text "body_kvs" <+> ppr body_kvs , text "all_kv_occs" <+> ppr all_kv_occs , text "tv_bndr_rdrs" <+> ppr tv_bndr_rdrs ] - ; checkMixedVars all_kv_occs tv_bndr_rdrs ; return $ FKTV (filterOut (`elemRdr` tv_bndr_rdrs) all_kv_occs @@ -1940,17 +1822,3 @@ nubL = nubBy eqLocated elemRdr :: Located RdrName -> [Located RdrName] -> Bool elemRdr x = any (eqLocated x) - --- Check for type variables that are also used as kinds without the use of --- -XTypeInType. See Note [Variables used as both types and kinds]. -checkMixedVars :: [Located RdrName] -> [Located RdrName] -> RnM () -checkMixedVars kvs tvs - = do { type_in_type <- xoptM LangExt.TypeInType - ; unless type_in_type $ - mapM_ check kvs } - where - check kv = when (kv `elemRdr` tvs) $ - addErrAt (getLoc kv) $ - vcat [ text "Variable" <+> quotes (ppr kv) - <+> text "used as both a kind and a type" - , text "Did you intend to use TypeInType?" ] diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 327876804a..1795131c79 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -968,11 +968,11 @@ generated instance of: instance (k ~ *) => Functor (T k) where -But this does not typecheck as the result of a -XTypeInType design decision: -kind equalities are not allowed to be bound in types, only terms. But in -essence, the two instance declarations are entirely equivalent, since even -though (T k) matches any kind k, the only possibly value for k is *, since -anything else is ill-typed. As a result, we can just as comfortably use (T *). +But this does not typecheck by design: kind equalities are not allowed to be +bound in types, only terms. But in essence, the two instance declarations are +entirely equivalent, since even though (T k) matches any kind k, the only +possibly value for k is *, since anything else is ill-typed. As a result, we can +just as comfortably use (T *). Another way of thinking about is: deriving clauses often infer constraints. For example: @@ -1064,8 +1064,8 @@ mentions other type variables: data family Fam (f :: * -> *) (a :: *) newtype instance Fam f (Const a f) = Fam (f a) deriving Functor -With -XTypeInType, it is also possible to define kind synonyms, and they can -mention other types in a datatype declaration. For example, +It is also possible to define kind synonyms, and they can mention other types in +a datatype declaration. For example, type Const a b = a newtype T f (a :: Const * f) = T (f a) deriving Functor diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index fb8f62fa27..f29dce9e85 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -800,6 +800,11 @@ tc_hs_type mode rn_ty@(HsEqTy _ ty1 ty2) exp_kind ; let ty' = mkNakedTyConApp eq_tc [kind1, ty1', ty2''] ; checkExpectedKind rn_ty ty' constraintKind exp_kind } +tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind + -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to + -- handle it in 'coreView' and 'tcView'. + = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind + --------- Literals tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind = do { checkWiredInTyCon typeNatKindCon @@ -824,10 +829,6 @@ tc_hs_type _ (HsWildCardTy wc) exp_kind -- we still need it to establish Note [The tcType invariant] } --- disposed of by renamer -tc_hs_type _ ty@(HsAppsTy {}) _ - = pprPanic "tc_hs_tyep HsAppsTy" (ppr ty) - tcWildCardOcc :: HsWildCardInfo -> Kind -> TcM TcType tcWildCardOcc wc_info exp_kind = do { wc_tv <- tcLookupTyVar (wildCardName wc_info) @@ -1137,9 +1138,6 @@ tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon ; tc <- get_loopy_tc name tc_tc ; handle_tyfams tc tc_tc } -- mkNakedTyConApp: see Note [Type-checking inside the knot] - -- NB: we really should check if we're at the kind level - -- and if the tycon is promotable if -XNoTypeInType is set. - -- But this is a terribly large amount of work! Not worth it. AGlobal (ATyCon tc) -> do { check_tc tc @@ -1149,13 +1147,9 @@ tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon -> do { data_kinds <- xoptM LangExt.DataKinds ; unless (data_kinds || specialPromotedDc dc) $ promotionErr name NoDataKindsDC - ; type_in_type <- xoptM LangExt.TypeInType - ; unless ( type_in_type || - ( isTypeLevel (mode_level mode) && - isLegacyPromotableDataCon dc ) || - ( isKindLevel (mode_level mode) && - specialPromotedDc dc ) ) $ - promotionErr name NoTypeInTypeDC + ; when (isFamInstTyCon (dataConTyCon dc)) $ + -- see Trac #15245 + promotionErr name FamDataConPE ; let tc = promoteDataCon dc ; return (mkNakedTyConApp tc [], tyConKind tc) } @@ -1164,16 +1158,11 @@ tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon _ -> wrongThingErr "type" thing name } where check_tc :: TyCon -> TcM () - check_tc tc = do { type_in_type <- xoptM LangExt.TypeInType - ; data_kinds <- xoptM LangExt.DataKinds + check_tc tc = do { data_kinds <- xoptM LangExt.DataKinds ; unless (isTypeLevel (mode_level mode) || data_kinds || isKindTyCon tc) $ - promotionErr name NoDataKindsTC - ; unless (isTypeLevel (mode_level mode) || - type_in_type || - isLegacyPromotableTyCon tc) $ - promotionErr name NoTypeInTypeTC } + promotionErr name NoDataKindsTC } -- if we are type-checking a type family tycon, we must instantiate -- any invisible arguments right away. Otherwise, we get #11246 @@ -1584,15 +1573,9 @@ kcLHsQTyVars name flav cusk , hsq_dependent = dep_names } , hsq_explicit = hs_tvs }) thing_inside | cusk - = do { typeintype <- xoptM LangExt.TypeInType - ; let m_kind - | typeintype = Nothing - | otherwise = Just liftedTypeKind - -- without -XTypeInType, default all kind variables to have kind * - - ; (scoped_kvs, (tc_tvs, (res_kind, stuff))) + = do { (scoped_kvs, (tc_tvs, (res_kind, stuff))) <- solveEqualities $ - tcImplicitTKBndrsX newSkolemTyVar m_kind skol_info kv_ns $ + tcImplicitTKBndrsX newSkolemTyVar skol_info kv_ns $ kcLHsTyVarBndrs cusk open_fam skol_info hs_tvs thing_inside -- Now, because we're in a CUSK, quantify over the mentioned @@ -1649,17 +1632,10 @@ kcLHsQTyVars name flav cusk ; return (tycon, stuff) } | otherwise - = do { typeintype <- xoptM LangExt.TypeInType - - -- if -XNoTypeInType and we know all the implicits are kind vars, - -- just give the kind *. This prevents test - -- dependent/should_fail/KindLevelsB from compiling, as it should - ; let default_kind - | typeintype = Nothing - | otherwise = Just liftedTypeKind - -- Why newSigTyVar? See Note [Kind generalisation and sigTvs] - ; (scoped_kvs, (tc_tvs, (res_kind, stuff))) - <- kcImplicitTKBndrs kv_ns default_kind $ + = do { (scoped_kvs, (tc_tvs, (res_kind, stuff))) + -- Why kcImplicitTKBndrs which uses newSigTyVar? + -- See Note [Kind generalisation and sigTvs] + <- kcImplicitTKBndrs kv_ns $ kcLHsTyVarBndrs cusk open_fam skol_info hs_tvs thing_inside ; let -- NB: Don't add scoped_kvs to tyConTyVars, because they @@ -1769,17 +1745,16 @@ tcImplicitTKBndrs :: SkolemInfo -> [Name] -> TcM a -> TcM ([TcTyVar], a) -tcImplicitTKBndrs = tcImplicitTKBndrsX newSkolemTyVar Nothing +tcImplicitTKBndrs = tcImplicitTKBndrsX newSkolemTyVar -- | Like 'tcImplicitTKBndrs', but uses 'newSigTyVar' to create tyvars tcImplicitTKBndrsSig :: SkolemInfo -> [Name] -> TcM a -> TcM ([TcTyVar], a) -tcImplicitTKBndrsSig = tcImplicitTKBndrsX newSigTyVar Nothing +tcImplicitTKBndrsSig = tcImplicitTKBndrsX newSigTyVar tcImplicitTKBndrsX :: (Name -> Kind -> TcM TcTyVar) -- new_tv function - -> Maybe Kind -- Just k <=> assign all names this kind -> SkolemInfo -> [Name] -> TcM a @@ -1793,7 +1768,7 @@ tcImplicitTKBndrsX :: (Name -> Kind -> TcM TcTyVar) -- new_tv function -- -- * Returned TcTyVars have zonked kinds -- See Note [Keeping scoped variables in order: Implicit] -tcImplicitTKBndrsX new_tv m_kind skol_info tv_names thing_inside +tcImplicitTKBndrsX new_tv skol_info tv_names thing_inside | null tv_names -- Short cut for the common case where there -- are no implicit type variables to bind = do { result <- solveLocalEqualities thing_inside @@ -1803,7 +1778,7 @@ tcImplicitTKBndrsX new_tv m_kind skol_info tv_names thing_inside = do { (skol_tvs, result) <- solveLocalEqualities $ checkTvConstraints skol_info Nothing $ - do { tv_pairs <- mapM (tcHsTyVarName new_tv m_kind) tv_names + do { tv_pairs <- mapM (tcHsTyVarName new_tv Nothing) tv_names ; let must_scope_tvs = [ tv | (tv, False) <- tv_pairs ] ; result <- tcExtendTyVarEnv must_scope_tvs $ thing_inside @@ -1821,13 +1796,11 @@ tcImplicitTKBndrsX new_tv m_kind skol_info tv_names thing_inside -- kind checking. Uses SigTvs, as per Note [Use SigTvs in kind-checking pass] -- in TcTyClsDecls. kcImplicitTKBndrs :: [Name] -- of the vars - -> Maybe Kind -- Just k <=> use k as the kind for all vars - -- Nothing <=> use a meta-tyvar -> TcM a -> TcM ([TcTyVar], a) -- returns the tyvars created -- these are *not* dependency ordered -kcImplicitTKBndrs var_ns m_kind thing_inside - = do { tkvs_pairs <- mapM (tcHsTyVarName newSigTyVar m_kind) var_ns +kcImplicitTKBndrs var_ns thing_inside + = do { tkvs_pairs <- mapM (tcHsTyVarName newSigTyVar Nothing) var_ns ; let must_scope_tkvs = [ tkv | (tkv, False) <- tkvs_pairs ] ; result <- tcExtendTyVarEnv must_scope_tkvs $ thing_inside @@ -2750,8 +2723,6 @@ promotionErr name err FamDataConPE -> text "it comes from a data family instance" NoDataKindsTC -> text "perhaps you intended to use DataKinds" NoDataKindsDC -> text "perhaps you intended to use DataKinds" - NoTypeInTypeTC -> text "perhaps you intended to use TypeInType" - NoTypeInTypeDC -> text "perhaps you intended to use TypeInType" PatSynPE -> text "pattern synonyms cannot be promoted" PatSynExPE -> sep [ text "the existential variables of a pattern synonym" , text "signature do not scope over the pattern" ] @@ -2802,19 +2773,16 @@ reportFloatingKvs tycon_name flav all_tvs bad_tvs ; bad_tvs <- mapM zonkTcTyVarToTyVar bad_tvs ; let (tidy_env, tidy_all_tvs) = tidyOpenTyCoVars emptyTidyEnv all_tvs tidy_bad_tvs = map (tidyTyVarOcc tidy_env) bad_tvs - ; typeintype <- xoptM LangExt.TypeInType - ; mapM_ (report typeintype tidy_all_tvs) tidy_bad_tvs } + ; mapM_ (report tidy_all_tvs) tidy_bad_tvs } where - report typeintype tidy_all_tvs tidy_bad_tv + report tidy_all_tvs tidy_bad_tv = addErr $ vcat [ text "Kind variable" <+> quotes (ppr tidy_bad_tv) <+> text "is implicitly bound in" <+> ppr flav , quotes (ppr tycon_name) <> comma <+> text "but does not appear as the kind of any" , text "of its type variables. Perhaps you meant" - , text "to bind it" <+> ppWhen (not typeintype) - (text "(with TypeInType)") <+> - text "explicitly somewhere?" + , text "to bind it explicitly somewhere?" , ppWhen (not (null tidy_all_tvs)) $ hang (text "Type variables with inferred kinds:") 2 (ppr_tv_bndrs tidy_all_tvs) ] diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index d09675778d..13b91d51cc 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -685,7 +685,7 @@ tcDataFamInstDecl mb_clsinfo -- Deal with any kind signature. -- See also Note [Arity of data families] in FamInstEnv ; (extra_tcbs, final_res_kind) <- tcDataKindSig full_tcbs res_kind' - ; checkTc (tcIsStarKind final_res_kind) (badKindSig True res_kind') + ; checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind') ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs all_pats = pats' `chkAppend` extra_pats @@ -727,7 +727,7 @@ tcDataFamInstDecl mb_clsinfo ; checkValidFamPats mb_clsinfo fam_tc tvs' [] pats' extra_pats pp_hs_pats -- Result kind must be '*' (otherwise, we have too few patterns) - ; checkTc (tcIsStarKind final_res_kind) $ + ; checkTc (tcIsLiftedTypeKind final_res_kind) $ tooFewParmsErr (tyConArity fam_tc) ; checkValidTyCon rep_tc diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index 87a9fa395d..1f7f98845f 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -1106,7 +1106,7 @@ defaultTyVar default_kind tv -- It takes an (unconstrained) meta tyvar and defaults it. -- Works only on vars of type *; for other kinds, it issues an error. default_kind_var kv - | isStarKind (tyVarKind kv) + | isLiftedTypeKind (tyVarKind kv) = do { traceTc "Defaulting a kind var to *" (ppr kv) ; writeMetaTyVar kv liftedTypeKind } | otherwise diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index f43072f59b..fdb9ead605 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -203,7 +203,7 @@ and it not straightforward to implement, because by the time we see the problem, simplifyInfer has already skolemised 's'.) This stuff can only happen in the presence of view patterns, with -TypeInType, so it's a bit of a corner case. +PolyKinds, so it's a bit of a corner case. Note [Coercions that escape] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 73b15a5252..d13941d9ec 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -1106,8 +1106,6 @@ data PromotionErr -- See Note [Recursion and promoting data constructors] in TcTyClsDecls | NoDataKindsTC -- -XDataKinds not enabled (for a tycon) | NoDataKindsDC -- -XDataKinds not enabled (for a datacon) - | NoTypeInTypeTC -- -XTypeInType not enabled (for a tycon) - | NoTypeInTypeDC -- -XTypeInType not enabled (for a datacon) instance Outputable TcTyThing where -- Debugging only ppr (AGlobal g) = ppr g @@ -1260,8 +1258,6 @@ instance Outputable PromotionErr where ppr RecDataConPE = text "RecDataConPE" ppr NoDataKindsTC = text "NoDataKindsTC" ppr NoDataKindsDC = text "NoDataKindsDC" - ppr NoTypeInTypeTC = text "NoTypeInTypeTC" - ppr NoTypeInTypeDC = text "NoTypeInTypeDC" pprTcTyThingCategory :: TcTyThing -> SDoc pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing @@ -1279,8 +1275,6 @@ pprPECategory FamDataConPE = text "Data constructor" pprPECategory RecDataConPE = text "Data constructor" pprPECategory NoDataKindsTC = text "Type constructor" pprPECategory NoDataKindsDC = text "Data constructor" -pprPECategory NoTypeInTypeTC = text "Type constructor" -pprPECategory NoTypeInTypeDC = text "Data constructor" {- ************************************************************************ diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 5bef07f369..b4d9d46513 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -1720,8 +1720,8 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor ------------------------------ reifyType :: TyCoRep.Type -> TcM TH.Type -- Monadic only because of failure -reifyType ty | tcIsStarKind ty = return TH.StarT - -- Make sure to use tcIsStarKind here, since we don't want to confuse it +reifyType ty | tcIsLiftedTypeKind ty = return TH.StarT + -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it -- with Constraint (#14869). reifyType ty@(ForAllTy {}) = reify_for_all ty reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) } diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 7e523a7673..729be95796 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -774,7 +774,7 @@ kcConDecl (ConDeclGADT { con_names = names -- for the type constructor T addErrCtxt (dataConCtxtName names) $ discardResult $ - kcImplicitTKBndrs implicit_tkv_nms Nothing $ + kcImplicitTKBndrs implicit_tkv_nms $ kcExplicitTKBndrs explicit_tkv_nms $ do { _ <- tcHsMbContext cxt ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args) @@ -1019,7 +1019,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na -- Data families might have a variable return kind. -- See See Note [Arity of data families] in FamInstEnv. ; (extra_binders, final_res_kind) <- tcDataKindSig binders res_kind - ; checkTc (tcIsStarKind final_res_kind + ; checkTc (tcIsLiftedTypeKind final_res_kind || isJust (tcGetCastedTyVar_maybe final_res_kind)) (badKindSig False res_kind) @@ -1171,7 +1171,7 @@ tcDataDefn roles_info ; let hsc_src = tcg_src tcg_env ; (extra_bndrs, final_res_kind) <- tcDataKindSig tycon_binders res_kind ; unless (mk_permissive_kind hsc_src cons) $ - checkTc (tcIsStarKind final_res_kind) (badKindSig True res_kind) + checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind) ; let final_bndrs = tycon_binders `chkAppend` extra_bndrs roles = roles_info tc_name @@ -1563,7 +1563,7 @@ kcFamTyPats :: TcTyCon -> TcM () kcFamTyPats tc_fam_tc tv_names arg_pats kind_checker = discardResult $ - kcImplicitTKBndrs tv_names Nothing $ + kcImplicitTKBndrs tv_names $ do { let loc = nameSrcSpan name lhs_fun = L loc (HsTyVar noExt NotPromoted (L loc name)) -- lhs_fun is for error messages only @@ -2672,32 +2672,6 @@ checkValidDataCon dflags existential_ok tc con ; checkTc (existential_ok || isVanillaDataCon con) (badExistential con) - ; typeintype <- xoptM LangExt.TypeInType - ; let (_, _, eq_specs, _, _, _) = dataConFullSig con - -- dataConEqSpec retrieves both the real GADT equalities - -- plus any user-written GADT-like equalities. But we don't - -- want anything user-written. If we don't exclude user-written - -- ones, test case polykinds/T13391a fails. - - invisible_gadt_eq_specs = filter is_invisible_eq_spec eq_specs - univ_tvs = dataConUnivTyVars con - tc_bndrs = tyConBinders tc - - vis_map :: VarEnv ArgFlag - vis_map = zipVarEnv univ_tvs (map tyConBinderArgFlag tc_bndrs) - - -- See Note [Wrong visibility for GADTs] for why we have to build the map - -- above instead of just looking at the datacon tyvar binder - is_invisible_eq_spec eq_spec - = isInvisibleArgFlag arg_flag - where - eq_tv = eqSpecTyVar eq_spec - arg_flag = expectJust "checkValidDataCon" $ - lookupVarEnv vis_map eq_tv - - ; checkTc (typeintype || null invisible_gadt_eq_specs) - (badGADT con invisible_gadt_eq_specs) - -- Check that UNPACK pragmas and bangs work out -- E.g. reject data T = MkT {-# UNPACK #-} Int -- No "!" -- data T = MkT {-# UNPACK #-} !a -- Can't unpack @@ -3506,15 +3480,6 @@ badExistential con 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con) , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ]) -badGADT :: DataCon -> [EqSpec] -> SDoc -badGADT con eq_specs - = hang (text "Data constructor" <+> quotes (ppr con) <+> - text "constrains the choice of kind parameter" <> plural eq_specs <> colon) - 2 (vcat (map ppr_eq_spec eq_specs)) $$ - text "Use TypeInType to allow this" - where - ppr_eq_spec eq_spec = ppr (eqSpecTyVar eq_spec) <+> char '~' <+> ppr (eqSpecType eq_spec) - badStupidTheta :: Name -> SDoc badStupidTheta tc_name = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) diff --git a/compiler/types/Kind.hs b/compiler/types/Kind.hs index 58e38f267e..0ce6bfe7e0 100644 --- a/compiler/types/Kind.hs +++ b/compiler/types/Kind.hs @@ -13,8 +13,7 @@ module Kind ( isConstraintKindCon, classifiesTypeWithValues, - isStarKind, isStarKindSynonymTyCon, - tcIsStarKind, + tcIsLiftedTypeKind, isKindLevPoly ) where @@ -40,7 +39,7 @@ import Util * * ************************************************************************ -Note [Kind Constraint and kind *] +Note [Kind Constraint and kind Type] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The kind Constraint is the kind of classes and other type constraints. The special thing about types of kind Constraint is that @@ -51,16 +50,16 @@ The special thing about types of kind Constraint is that to f. However, once type inference is over, there is *no* distinction between -Constraint and *. Indeed we can have coercions between the two. Consider +Constraint and Type. Indeed we can have coercions between the two. Consider class C a where op :: a -> a For this single-method class we may generate a newtype, which in turn generates an axiom witnessing C a ~ (a -> a) -so on the left we have Constraint, and on the right we have *. +so on the left we have Constraint, and on the right we have Type. See Trac #7451. -Bottom line: although '*' and 'Constraint' are distinct TyCons, with +Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with distinct uniques, they are treated as equal at all times except during type inference. -} @@ -98,8 +97,8 @@ returnsConstraintKind = returnsTyCon constraintKindTyConKey -- E.g. True of TYPE k, TYPE (F Int) -- False of TYPE 'LiftedRep isKindLevPoly :: Kind -> Bool -isKindLevPoly k = ASSERT2( isStarKind k || _is_type, ppr k ) - -- the isStarKind check is necessary b/c of Constraint +isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k ) + -- the isLiftedTypeKind check is necessary b/c of Constraint go k where go ty | Just ty' <- coreView ty = go ty' @@ -135,21 +134,9 @@ classifiesTypeWithValues = isTYPE (const True) -- | Is this kind equivalent to @*@? -- -- This considers 'Constraint' to be distinct from @*@. For a version that --- treats them as the same type, see 'isStarKind'. -tcIsStarKind :: Kind -> Bool -tcIsStarKind = tcIsTYPE is_lifted +-- treats them as the same type, see 'isLiftedTypeKind'. +tcIsLiftedTypeKind :: Kind -> Bool +tcIsLiftedTypeKind = tcIsTYPE is_lifted where is_lifted (TyConApp lifted_rep []) = lifted_rep `hasKey` liftedRepDataConKey is_lifted _ = False - --- | Is this kind equivalent to @*@? --- --- This considers 'Constraint' to be the same as @*@. For a version that --- treats them as different types, see 'tcIsStarKind'. -isStarKind :: Kind -> Bool -isStarKind = isLiftedTypeKind - -- See Note [Kind Constraint and kind *] - --- | Is the tycon @Constraint@? -isStarKindSynonymTyCon :: TyCon -> Bool -isStarKindSynonymTyCon tc = tc `hasKey` constraintKindTyConKey diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index bd10ac8cf3..362be33c03 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -801,6 +801,7 @@ tcIsTYPE _ _ = False -- | This version considers Constraint to be the same as *. Returns True -- if the argument is equivalent to Type/Constraint and False otherwise. +-- See Note [Kind Constraint and kind Type] isLiftedTypeKind :: Kind -> Bool isLiftedTypeKind = isTYPE is_lifted where diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 230cec7c6c..2d9e53060f 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -2032,18 +2032,14 @@ isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys -- -XDataKinds. kindTyConKeys :: UniqSet Unique kindTyConKeys = unionManyUniqSets - ( mkUniqSet [ liftedTypeKindTyConKey, starKindTyConKey, unicodeStarKindTyConKey - , constraintKindTyConKey, tYPETyConKey ] + ( mkUniqSet [ liftedTypeKindTyConKey, constraintKindTyConKey, tYPETyConKey ] : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon , vecCountTyCon, vecElemTyCon ] ) where tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) isLiftedTypeKindTyConName :: Name -> Bool -isLiftedTypeKindTyConName - = (`hasKey` liftedTypeKindTyConKey) <||> - (`hasKey` starKindTyConKey) <||> - (`hasKey` unicodeStarKindTyConKey) +isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey) -- | Identifies implicit tycons that, in particular, do not go into interface -- files (because they are implicitly reconstructed when the interface is diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 8450cd2f84..963fad4068 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -340,7 +340,7 @@ coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc t -- partially-applied type constructor; indeed, usually will! coreView (TyConApp tc []) -- At the Core level, Constraint = Type - | isStarKindSynonymTyCon tc + | isConstraintKindCon tc = Just liftedTypeKind coreView _ = Nothing @@ -2298,13 +2298,14 @@ nonDetCmpTypesX _ [] _ = LT nonDetCmpTypesX _ _ [] = GT ------------- --- | Compare two 'TyCon's. NB: This should /never/ see the "star synonyms", --- as recognized by Kind.isStarKindSynonymTyCon. See Note --- [Kind Constraint and kind *] in Kind. +-- | Compare two 'TyCon's. NB: This should /never/ see 'Constraint' (as +-- recognized by Kind.isConstraintKindCon) which is considered a synonym for +-- 'Type' in Core. +-- See Note [Kind Constraint and kind Type] in Kind. -- See Note [nonDetCmpType nondeterminism] nonDetCmpTc :: TyCon -> TyCon -> Ordering nonDetCmpTc tc1 tc2 - = ASSERT( not (isStarKindSynonymTyCon tc1) && not (isStarKindSynonymTyCon tc2) ) + = ASSERT( not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2) ) u1 `nonDetCmpUnique` u2 where u1 = tyConUnique tc1 diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs index 220865ef89..9833f8effa 100644 --- a/compiler/types/Unify.hs +++ b/compiler/types/Unify.hs @@ -889,7 +889,7 @@ unify_ty env ty1 (TyVarTy tv2) kco unify_ty env ty1 ty2 _kco | Just (tc1, tys1) <- mb_tc_app1 , Just (tc2, tys2) <- mb_tc_app2 - , tc1 == tc2 || (tcIsStarKind ty1 && tcIsStarKind ty2) + , tc1 == tc2 || (tcIsLiftedTypeKind ty1 && tcIsLiftedTypeKind ty2) = if isInjectiveTyCon tc1 Nominal then unify_tys env tys1 tys2 else do { let inj | isTypeFamilyTyCon tc1 diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 2c96ddaba0..4df9adfe84 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -28,7 +28,7 @@ module Outputable ( semi, comma, colon, dcolon, space, equals, dot, vbar, arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, - blankLine, forAllLit, kindStar, bullet, + blankLine, forAllLit, kindType, bullet, (<>), (<+>), hcat, hsep, ($$), ($+$), vcat, sep, cat, @@ -91,7 +91,7 @@ import GhcPrelude import {-# SOURCE #-} DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput, targetPlatform, pprUserLength, pprCols, - useUnicode, useUnicodeSyntax, + useUnicode, useUnicodeSyntax, useStarIsType, shouldUseColor, unsafeGlobalDynFlags, shouldUseHexWordLiterals ) import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName ) @@ -650,8 +650,11 @@ rbrace = docToSDoc $ Pretty.rbrace forAllLit :: SDoc forAllLit = unicodeSyntax (char '∀') (text "forall") -kindStar :: SDoc -kindStar = unicodeSyntax (char '★') (char '*') +kindType :: SDoc +kindType = sdocWithDynFlags $ \dflags -> + if useStarIsType dflags + then unicodeSyntax (char '★') (char '*') + else text "Type" bullet :: SDoc bullet = unicode (char '•') (char '*') |