diff options
Diffstat (limited to 'compiler/hsSyn')
| -rw-r--r-- | compiler/hsSyn/Convert.hs | 37 | ||||
| -rw-r--r-- | compiler/hsSyn/HsDecls.hs | 9 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExtension.hs | 16 | ||||
| -rw-r--r-- | compiler/hsSyn/HsInstances.hs | 5 | ||||
| -rw-r--r-- | compiler/hsSyn/HsTypes.hs | 117 |
5 files changed, 43 insertions, 141 deletions
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 |