diff options
Diffstat (limited to 'compiler/hsSyn')
| -rw-r--r-- | compiler/hsSyn/Convert.hs | 71 | ||||
| -rw-r--r-- | compiler/hsSyn/HsDecls.hs | 16 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.hs | 1 | ||||
| -rw-r--r-- | compiler/hsSyn/HsPat.hs | 9 | ||||
| -rw-r--r-- | compiler/hsSyn/HsTypes.hs | 257 | ||||
| -rw-r--r-- | compiler/hsSyn/HsUtils.hs | 123 |
6 files changed, 254 insertions, 223 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 4decbe12bb..342bc35679 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -446,9 +446,9 @@ cvtConstr (ForallC tvs ctxt con) ; let qvars = case (tvs,con_qvars con') of ([],Nothing) -> Nothing _ -> - Just $ mkHsQTvs (hsQTvBndrs tvs' ++ - hsQTvBndrs (fromMaybe (HsQTvs PlaceHolder []) - (con_qvars con'))) + Just $ mkHsQTvs (hsQTvExplicit tvs' ++ + hsQTvExplicit (fromMaybe (HsQTvs PlaceHolder []) + (con_qvars con'))) ; returnL $ con' { con_qvars = qvars , con_cxt = Just $ L loc (ctxt' ++ @@ -482,9 +482,9 @@ cvtDerivs cs = do { cs' <- mapM cvt_one cs ; return (mkLHsSigType ty) } cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName))) -cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs - ; ys' <- mapM tName ys - ; returnL (map noLoc xs', map noLoc ys') } +cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs + ; ys' <- mapM tNameL ys + ; returnL (xs', ys') } ------------------------------------------ @@ -785,7 +785,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 right-bias the trees of @UInfixT@. +trees of @UInfixP@ and @UInfixE@ and use HsAppsTy for UInfixT. Sample input: @@ -1004,12 +1004,12 @@ cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) cvt_tv (TH.PlainTV nm) - = do { nm' <- tName nm - ; returnL $ UserTyVar (noLoc nm') } + = do { nm' <- tNameL nm + ; returnL $ UserTyVar nm' } cvt_tv (TH.KindedTV nm ki) - = do { nm' <- tName nm + = do { nm' <- tNameL nm ; ki' <- cvtKind ki - ; returnL $ KindedTyVar (noLoc nm') ki' } + ; returnL $ KindedTyVar nm' ki' } cvtRole :: TH.Role -> Maybe Coercion.Role cvtRole TH.NominalR = Just Coercion.Nominal @@ -1054,8 +1054,8 @@ cvtTypeKind ty_str ty | [x'] <- tys' -> returnL (HsListTy x') | otherwise -> mk_apps (HsTyVar (noLoc (getRdrName listTyCon))) tys' - VarT nm -> do { nm' <- tName nm - ; mk_apps (HsTyVar (noLoc nm')) tys' } + VarT nm -> do { nm' <- tNameL nm + ; mk_apps (HsTyVar nm') tys' } ConT nm -> do { nm' <- tconName nm ; mk_apps (HsTyVar (noLoc nm')) tys' } @@ -1066,7 +1066,7 @@ cvtTypeKind ty_str ty ; ty' <- cvtType ty ; loc <- getL ; let hs_ty | null tvs = rho_ty - | otherwise = L loc (HsForAllTy { hst_bndrs = hsQTvBndrs tvs' + | otherwise = L loc (HsForAllTy { hst_bndrs = hsQTvExplicit tvs' , hst_body = rho_ty }) rho_ty | null cxt = ty' | otherwise = L loc (HsQualTy { hst_ctxt = cxt' @@ -1087,8 +1087,8 @@ cvtTypeKind ty_str ty -> mk_apps mkAnonWildCardTy tys' WildCardT (Just nm) - -> do { nm' <- tName nm - ; mk_apps (mkNamedWildCardTy (noLoc nm')) tys' } + -> do { nm' <- tNameL nm + ; mk_apps (mkNamedWildCardTy nm') tys' } InfixT t1 s t2 -> do { s' <- tconName s @@ -1098,8 +1098,10 @@ cvtTypeKind ty_str ty } UInfixT t1 s t2 - -> do { t2' <- cvtType t2 - ; cvtOpAppT t1 s t2' + -> do { t1' <- cvtType t1 + ; t2' <- cvtType t2 + ; s' <- tconName s + ; return $ cvtOpAppT t1' s' t2' } -- Note [Converting UInfix] ParensT t @@ -1157,23 +1159,26 @@ split_ty_app ty = go ty [] go f as = return (f,as) cvtTyLit :: TH.TyLit -> HsTyLit -cvtTyLit (NumTyLit i) = HsNumTy (show i) i -cvtTyLit (StrTyLit s) = HsStrTy s (fsLit s) - -{- | @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. +cvtTyLit (TH.NumTyLit i) = HsNumTy (show i) i +cvtTyLit (TH.StrTyLit s) = HsStrTy s (fsLit s) -See the @cvtOpApp@ documentation for how this function works. +{- | @cvtOpAppT x op y@ takes converted arguments and flattens any HsAppsTy + structure in them. -} -cvtOpAppT :: TH.Type -> TH.Name -> LHsType RdrName -> CvtM (LHsType RdrName) -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) } +cvtOpAppT :: LHsType RdrName -> RdrName -> LHsType RdrName -> LHsType RdrName +cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _) + = L (combineSrcSpans loc1 loc2) $ + HsAppsTy (t1' ++ [HsAppInfix (noLoc op)] ++ t2') + where + t1' | L _ (HsAppsTy t1s) <- t1 + = t1s + | otherwise + = [HsAppPrefix t1] + + t2' | L _ (HsAppsTy t2s) <- t2 + = t2s + | otherwise + = [HsAppPrefix t2] cvtKind :: TH.Kind -> CvtM (LHsKind RdrName) cvtKind = cvtTypeKind "kind" diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 48348cc2e1..3f49f42a0e 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -46,7 +46,7 @@ module HsDecls ( -- ** @RULE@ declarations LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr, collectRuleBndrSigTys, - flattenRuleDecls, + flattenRuleDecls, pprFullRuleName, -- ** @VECTORISE@ declarations VectDecl(..), LVectDecl, lvectDeclName, lvectInstDecl, @@ -638,7 +638,7 @@ countTyClDecls decls -- | Does this declaration have a complete, user-supplied kind signature? -- See Note [Complete user-supplied kind signatures] -hsDeclHasCusk :: TyClDecl name -> Bool +hsDeclHasCusk :: TyClDecl Name -> Bool hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk fam_decl hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) = hsTvbAllKinded tyvars && rhs_annotated rhs @@ -1060,14 +1060,19 @@ getConNames :: ConDecl name -> [Located name] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names +-- don't call with RdrNames, because it can't deal with HsAppsTy getConDetails :: ConDecl name -> HsConDeclDetails name getConDetails ConDeclH98 {con_details = details} = details getConDetails ConDeclGADT {con_type = ty } = details where (details,_,_,_) = gadtDeclDetails ty +-- don't call with RdrNames, because it can't deal with HsAppsTy gadtDeclDetails :: LHsSigType name - -> (HsConDeclDetails name,LHsType name,LHsContext name,[LHsTyVarBndr name]) + -> ( HsConDeclDetails name + , LHsType name + , LHsContext name + , [LHsTyVarBndr name] ) gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs) where (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty @@ -1635,12 +1640,15 @@ deriving instance (DataId name) => Data (RuleBndr name) collectRuleBndrSigTys :: [RuleBndr name] -> [LHsSigWcType name] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] +pprFullRuleName :: Located (SourceText, RuleName) -> SDoc +pprFullRuleName (L _ (_, n)) = doubleQuotes $ ftext n + instance OutputableBndr name => Outputable (RuleDecls name) where ppr (HsRules _ rules) = ppr rules instance OutputableBndr name => Outputable (RuleDecl name) where ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) - = sep [text "{-# RULES" <+> doubleQuotes (ftext $ snd $ unLoc name) + = sep [text "{-# RULES" <+> pprFullRuleName name <+> ppr act, nest 4 (pp_forall <+> pprExpr (unLoc lhs)), nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ] diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index c5afa7410f..6e02df7438 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -594,7 +594,6 @@ in the ParsedSource. There are unfortunately enough differences between the ParsedSource and the RenamedSource that the API Annotations cannot be used directly with RenamedSource, so this allows a simple mapping to be used based on the location. ->>>>>>> origin/master -} instance OutputableBndr id => Outputable (HsExpr id) where diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 91e5973ece..0f65e4b297 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -153,10 +153,11 @@ data Pat id -- Use (conLikeResTy pat_con pat_arg_tys) to get -- the type of the pattern - pat_tvs :: [TyVar], -- Existentially bound type variables (tyvars only) + pat_tvs :: [TyVar], -- Existentially bound type variables pat_dicts :: [EvVar], -- Ditto *coercion variables* and *dictionaries* -- One reason for putting coercion variable here, I think, -- is to ensure their kinds are zonked + pat_binds :: TcEvBinds, -- Bindings involving those dictionaries pat_args :: HsConPatDetails id, pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher @@ -236,6 +237,12 @@ hsConPatArgs (PrefixCon ps) = ps hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2] +instance (Outputable arg, Outputable rec) + => Outputable (HsConDetails arg rec) where + ppr (PrefixCon args) = text "PrefixCon" <+> ppr args + ppr (RecCon rec) = text "RecCon:" <+> ppr rec + ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] + {- However HsRecFields is used only for patterns and expressions (not data type declarations) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 8bcdc6aac1..df2f0f36f3 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -18,7 +18,6 @@ HsTypes: Abstract syntax: user-defined types module HsTypes ( HsType(..), LHsType, HsKind, LHsKind, - HsTyOp,LHsTyOp, HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsImplicitBndrs(..), @@ -26,9 +25,9 @@ module HsTypes ( LHsSigType, LHsSigWcType, LHsWcType, HsTupleSort(..), HsContext, LHsContext, - HsTyWrapper(..), HsTyLit(..), HsIPName(..), hsIPNameFS, + HsAppType(..), LBangType, BangType, HsSrcBang(..), HsImplBang(..), @@ -48,18 +47,17 @@ module HsTypes ( mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, - mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded, + mkHsQTvs, hsQTvExplicit, isHsKindedTyVar, hsTvbAllKinded, hsScopedTvs, hsWcScopedTvs, dropWildCards, - hsTyVarName, hsLKiTyVarNames, - hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, - splitLHsInstDeclTy, getLHsInstDeclClass_maybe, + hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames, + hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames, + splitLHsInstDeclTy, splitLHsPatSynTy, splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy, - splitLHsClassTy_maybe, - splitHsFunType, splitHsAppTys, hsTyGetAppHead_maybe, - mkHsAppTys, mkHsOpTy, + splitHsFunType, splitHsAppTys, + mkHsOpTy, ignoreParens, hsSigType, hsSigWcType, - hsLTyVarBndrsToTypes, + hsLTyVarBndrToType, hsLTyVarBndrsToTypes, -- Printing pprParendHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra, @@ -70,9 +68,9 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) ) -import Id( Id ) +import Id ( Id ) import Name( Name ) -import RdrName( RdrName ) +import RdrName ( RdrName ) import DataCon( HsSrcBang(..), HsImplBang(..), SrcStrictness(..), SrcUnpackedness(..) ) import TysPrim( funTyConName ) @@ -87,10 +85,6 @@ import Maybes( isJust ) import Data.Data hiding ( Fixity ) import Data.Maybe ( fromMaybe ) -#if __GLASGOW_HASKELL__ < 709 --- SPJ temp --- import Data.Monoid hiding((<>)) -#endif #if __GLASGOW_HASKELL > 710 import Data.Semigroup ( Semigroup ) import qualified Data.Semigroup as Semigroup @@ -208,8 +202,8 @@ type LHsTyVarBndr name = Located (HsTyVarBndr name) -- See Note [HsType binders] data LHsQTyVars name -- See Note [HsType binders] - = HsQTvs { hsq_kvs :: PostRn name [Name] -- Kind variables - , hsq_tvs :: [LHsTyVarBndr name] -- Type variables + = HsQTvs { hsq_implicit :: PostRn name [Name] -- implicit (dependent) variables + , hsq_explicit :: [LHsTyVarBndr name] -- explicit variables -- See Note [HsForAllTy tyvar binders] } deriving( Typeable ) @@ -217,23 +211,10 @@ data LHsQTyVars name -- See Note [HsType binders] deriving instance (DataId name) => Data (LHsQTyVars name) mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsQTyVars RdrName -mkHsQTvs tvs = HsQTvs { hsq_kvs = PlaceHolder, hsq_tvs = tvs } - -hsQTvBndrs :: LHsQTyVars name -> [LHsTyVarBndr name] -hsQTvBndrs = hsq_tvs - -{- -#if __GLASGOW_HASKELL__ > 710 -instance Semigroup (LHsTyVarBndrs name) where - HsQTvs kvs1 tvs1 <> HsQTvs kvs2 tvs2 - = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2) -#endif +mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs } -instance Monoid (LHsQTyVars name) where - mempty = mkHsQTvs [] - mappend (HsQTvs kvs1 tvs1) (HsQTvs kvs2 tvs2) - = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2) --} +hsQTvExplicit :: LHsQTyVars name -> [LHsTyVarBndr name] +hsQTvExplicit = hsq_explicit ------------------------------------------------ -- HsImplicitBndrs @@ -245,8 +226,7 @@ instance Monoid (LHsQTyVars name) where -- In the last of these, wildcards can happen, so we must accommodate them data HsImplicitBndrs name thing -- See Note [HsType binders] - = HsIB { hsib_kvs :: PostRn name [Name] -- Implicitly-bound kind vars - , hsib_tvs :: PostRn name [Name] -- Implicitly-bound type vars + = HsIB { hsib_vars :: PostRn name [Name] -- Implicitly-bound kind & type vars , hsib_body :: thing -- Main payload (type or list of types) } deriving (Typeable) @@ -305,8 +285,7 @@ A HsSigType is just a HsImplicitBndrs wrapping a LHsType. E.g. For a signature like f :: forall (a::k). blah we get - HsIB { hsib_kvs = [k] - , hsib_tvs = [] + HsIB { hsib_vars = [k] , hsib_body = HsForAllTy { hst_bndrs = [(a::*)] , hst_body = blah } The implicit kind variable 'k' is bound by the HsIB; @@ -315,8 +294,7 @@ the explictly forall'd tyvar 'a' is bounnd by the HsForAllTy mkHsImplicitBndrs :: thing -> HsImplicitBndrs RdrName thing mkHsImplicitBndrs x = HsIB { hsib_body = x - , hsib_kvs = PlaceHolder - , hsib_tvs = PlaceHolder } + , hsib_vars = PlaceHolder } mkHsWildCardBndrs :: thing -> HsWildCardBndrs RdrName thing mkHsWildCardBndrs x = HsWC { hswc_body = x @@ -327,8 +305,7 @@ mkHsWildCardBndrs x = HsWC { hswc_body = x -- the wrapped thing had free type variables? mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs Name thing mkEmptyImplicitBndrs x = HsIB { hsib_body = x - , hsib_kvs = [] - , hsib_tvs = [] } + , hsib_vars = [] } mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs Name thing mkEmptyWildCardBndrs x = HsWC { hswc_body = x @@ -374,9 +351,9 @@ isHsKindedTyVar :: HsTyVarBndr name -> Bool isHsKindedTyVar (UserTyVar {}) = False isHsKindedTyVar (KindedTyVar {}) = True --- | Do all type variables in this 'LHsTyVarBndr' come with kind annotations? +-- | Do all type variables in this 'LHsQTyVars' come with kind annotations? hsTvbAllKinded :: LHsQTyVars name -> Bool -hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvBndrs +hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit data HsType name = HsForAllTy -- See Note [HsType binders] @@ -399,6 +376,10 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation + | HsAppsTy [HsAppType name] -- Used only before renaming, + -- Note [HsAppsTy] + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + | HsAppTy (LHsType name) (LHsType name) -- ^ - 'ApiAnnotation.AnnKeywordId' : None @@ -430,7 +411,7 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation - | HsOpTy (LHsType name) (LHsTyOp name) (LHsType name) + | HsOpTy (LHsType name) (Located name) (LHsType name) -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation @@ -524,11 +505,6 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation - | HsWrapTy HsTyWrapper (HsType name) -- only in typechecker output - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsWildCardTy (HsWildCardInfo name) -- A type wildcard -- ^ - 'ApiAnnotation.AnnKeywordId' : None @@ -543,15 +519,8 @@ data HsTyLit | HsStrTy SourceText FastString deriving (Data, Typeable) -data HsTyWrapper - = WpKiApps [Kind] -- kind instantiation: [] k1 k2 .. kn - deriving (Data, Typeable) - -type LHsTyOp name = HsTyOp (Located name) -type HsTyOp name = (HsTyWrapper, name) - mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name -mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2 +mkHsOpTy ty1 op ty2 = HsOpTy ty1 op ty2 data HsWildCardInfo name = AnonWildCard (PostRn name (Located Name)) @@ -562,6 +531,15 @@ data HsWildCardInfo name deriving (Typeable) deriving instance (DataId name) => Data (HsWildCardInfo name) +data HsAppType name + = HsAppInfix (Located name) -- either a symbol or an id in backticks + | HsAppPrefix (LHsType name) -- anything else, including things like (+) + deriving (Typeable) +deriving instance (DataId name) => Data (HsAppType name) + +instance OutputableBndr name => Outputable (HsAppType name) where + ppr = ppr_app_ty TopPrec + {- Note [HsForAllTy tyvar binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -580,7 +558,7 @@ Note [Context quantification] in RnTypes, and Trac #4426. In GHC 7.12, Qualified will no longer bind variables and this will become an error. -The kind variables bound in the hsq_kvs field come both +The kind variables bound in the hsq_implicit field come both a) from the kind signatures on the kind vars (eg k1) b) from the scope of the forall (eg k2) Example: f :: forall (a::k1) b. T a (b::k2) @@ -614,6 +592,16 @@ HsTyVar: A name in a type or kind. Tv: kind variable TcCls: kind constructor or promoted type constructor +Note [HsAppsTy] +~~~~~~~~~~~~~~~ +How to parse + + Foo * Int + +? 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -777,17 +765,23 @@ hsWcScopedTvs :: LHsSigWcType Name -> [Name] -- - the named wildcars; see Note [Scoping of named wildcards] -- because they scope in the same way hsWcScopedTvs sig_ty - | HsIB { hsib_kvs = kvs, hsib_body = sig_ty1 } <- sig_ty + | HsIB { hsib_vars = vars, hsib_body = sig_ty1 } <- sig_ty , HsWC { hswc_wcs = nwcs, hswc_body = sig_ty2 } <- sig_ty1 - , (tvs, _) <- splitLHsForAllTy sig_ty2 - = kvs ++ nwcs ++ map hsLTyVarName tvs + = case sig_ty2 of + L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++ + map hsLTyVarName tvs + -- include kind variables only if the type is headed by forall + -- (this is consistent with GHC 7 behaviour) + _ -> nwcs hsScopedTvs :: LHsSigType Name -> [Name] -- Same as hsWcScopedTvs, but for a LHsSigType hsScopedTvs sig_ty - | HsIB { hsib_kvs = kvs, hsib_body = sig_ty2 } <- sig_ty - , (tvs, _) <- splitLHsForAllTy sig_ty2 - = kvs ++ map hsLTyVarName tvs + | HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty + , L _ (HsForAllTy { hst_bndrs = tvs }) <- sig_ty2 + = vars ++ map hsLTyVarName tvs + | otherwise + = [] {- Note [Scoping of named wildcards] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -810,31 +804,32 @@ hsTyVarName (KindedTyVar (L _ n) _) = n hsLTyVarName :: LHsTyVarBndr name -> name hsLTyVarName = hsTyVarName . unLoc -hsLTyVarNames :: LHsQTyVars name -> [name] --- Type variables only -hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs) +hsExplicitLTyVarNames :: LHsQTyVars name -> [name] +-- Explicit variables only +hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs) -hsLKiTyVarNames :: LHsQTyVars Name -> [Name] --- Kind and type variables -hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) +hsAllLTyVarNames :: LHsQTyVars Name -> [Name] +-- All variables +hsAllLTyVarNames (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs }) = kvs ++ map hsLTyVarName tvs hsLTyVarLocName :: LHsTyVarBndr name -> Located name hsLTyVarLocName = fmap hsTyVarName --- | Convert a LHsTyVarBndr to an equivalent LHsType. Used in Template Haskell --- quoting for type family equations. +hsLTyVarLocNames :: LHsQTyVars name -> [Located name] +hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) + +-- | Convert a LHsTyVarBndr to an equivalent LHsType. hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name hsLTyVarBndrToType = fmap cvt where cvt (UserTyVar n) = HsTyVar n cvt (KindedTyVar (L name_loc n) kind) = HsKindSig (L name_loc (HsTyVar (L name_loc n))) kind --- | Convert a LHsTyVarBndrs to a list of types. Used in Template Haskell --- quoting for type family equations. Works on *type* variable only, no kind --- vars. +-- | Convert a LHsTyVarBndrs to a list of types. +-- Works on *type* variable only, no kind vars. hsLTyVarBndrsToTypes :: LHsQTyVars name -> [LHsType name] -hsLTyVarBndrsToTypes (HsQTvs { hsq_tvs = tvbs }) = map hsLTyVarBndrToType tvbs +hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs --------------------- mkAnonWildCardTy :: HsType RdrName @@ -871,34 +866,12 @@ sameNamedWildCard (L _ (NamedWildCard (L _ n1))) (L _ (NamedWildCard (L _ n2))) = n1 == n2 sameNamedWildCard _ _ = False -splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n]) +splitHsAppTys :: LHsType Name -> [LHsType Name] -> (LHsType Name, [LHsType Name]) + -- 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) --- 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.) -hsTyGetAppHead_maybe :: LHsType n -> Maybe (n, [LHsType n]) -hsTyGetAppHead_maybe = go [] - where - go tys (L _ (HsTyVar (L _ n))) = Just (n, tys) - go tys (L _ (HsAppTy l r)) = go (r : tys) l - go tys (L _ (HsOpTy l (_, L _ n) r)) = Just (n, l : r : tys) - go tys (L _ (HsParTy t)) = go tys t - go tys (L _ (HsKindSig t _)) = go tys t - go _ _ = Nothing - -mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n -mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty) -mkHsAppTys fun_ty (arg_ty:arg_tys) - = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys - where - mk_app fun arg = HsAppTy (noLoc fun) arg - -- Add noLocs for inner nodes of the application; - -- they are never used - splitLHsPatSynTy :: LHsType name -> ( [LHsTyVarBndr name] , LHsContext name -- Required @@ -935,39 +908,14 @@ splitLHsInstDeclTy :: LHsSigType Name -> ([Name], LHsContext Name, LHsType Name) -- Split up an instance decl type, returning the pieces -splitLHsInstDeclTy (HsIB { hsib_kvs = ikvs, hsib_tvs = itvs +splitLHsInstDeclTy (HsIB { hsib_vars = itkvs , hsib_body = inst_ty }) - = (ikvs ++ itvs, cxt, body_ty) + = (itkvs, cxt, body_ty) -- Return implicitly bound type and kind vars -- For an instance decl, all of them are in scope where (cxt, body_ty) = splitLHsQualTy inst_ty -getLHsInstDeclClass_maybe :: LHsSigType name -> Maybe (Located name) --- Works on (HsSigType RdrName) -getLHsInstDeclClass_maybe inst_ty - = do { let (_, tau) = splitLHsQualTy (hsSigType inst_ty) - ; (cls, _) <- splitLHsClassTy_maybe tau - ; return cls } - -splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) --- Watch out.. in ...deriving( Show )... we use this on --- the list of partially applied predicates in the deriving, --- so there can be zero args. --- --- In TcDeriv we also use this to figure out what data type is being --- mentioned in a deriving (Generic (Foo bar baz)) declaration (i.e. "Foo"). -splitLHsClassTy_maybe ty - = checkl ty [] - where - checkl (L _ ty) args = case ty of - HsTyVar (L lt t) -> Just (L lt t, args) - HsAppTy l r -> checkl l (r:args) - HsOpTy l (_,L lt tc) r -> checkl (L lt (HsTyVar (L lt tc))) (l:r:args) - HsParTy t -> checkl t args - HsKindSig ty _ -> checkl ty args - _ -> Nothing - -- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) -- Breaks up any parens in the result type: -- splitHsFunType (a -> (b -> c)) = ([a,b], c) @@ -994,10 +942,10 @@ splitHsFunType orig_ty@(L _ (HsAppTy t1 t2)) splitHsFunType other = ([], other) - ignoreParens :: LHsType name -> LHsType name -ignoreParens (L _ (HsParTy ty)) = ignoreParens ty -ignoreParens ty = ty +ignoreParens (L _ (HsParTy ty)) = ignoreParens ty +ignoreParens (L _ (HsAppsTy [HsAppPrefix ty])) = ignoreParens ty +ignoreParens ty = ty {- ************************************************************************ @@ -1013,9 +961,8 @@ instance (OutputableBndr name) => Outputable (HsType name) where instance Outputable HsTyLit where ppr = ppr_tylit -instance (OutputableBndr name) - => Outputable (LHsQTyVars name) where - ppr (HsQTvs { hsq_tvs = tvs }) = interppSP tvs +instance (OutputableBndr name) => Outputable (LHsQTyVars name) where + ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where ppr (UserTyVar n) = ppr n @@ -1103,16 +1050,14 @@ seems like the Right Thing anyway.) pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc -pprHsType ty = getPprStyle $ \sty -> ppr_mono_ty TopPrec (prepare sty ty) +pprHsType ty = ppr_mono_ty TopPrec (prepare ty) pprParendHsType ty = ppr_mono_ty TyConPrec ty --- Before printing a type --- (a) Remove outermost HsParTy parens --- (b) Drop top-level for-all type variables in user style --- since they are implicit in Haskell -prepare :: PprStyle -> HsType name -> HsType name -prepare sty (HsParTy ty) = prepare sty (unLoc ty) -prepare _ ty = ty +-- Before printing a type, remove outermost HsParTy parens +prepare :: HsType name -> HsType name +prepare (HsParTy ty) = prepare (unLoc ty) +prepare (HsAppsTy [HsAppPrefix (L _ ty)]) = prepare ty +prepare ty = ty ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) @@ -1146,34 +1091,22 @@ ppr_mono_ty _ (HsTyLit t) = ppr_tylit t ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) = char '_' ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) = ppr name -ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty) - = ppr_mono_ty ctxt_prec ty --- We are not printing kind applications. If we wanted to do so, we should do --- something like this: -{- - = go ctxt_prec kis ty - where - go ctxt_prec [] ty = ppr_mono_ty ctxt_prec ty - go ctxt_prec (ki:kis) ty - = maybeParen ctxt_prec TyConPrec $ - hsep [ go FunPrec kis ty - , ptext (sLit "@") <> pprParendKind ki ] --} - ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) = maybeParen ctxt_prec TyOpPrec $ ppr_mono_lty TyOpPrec ty1 <+> char '~' <+> ppr_mono_lty TyOpPrec ty2 +ppr_mono_ty ctxt_prec (HsAppsTy tys) + = maybeParen ctxt_prec TyConPrec $ + hsep (map (ppr_app_ty TopPrec) tys) + ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) = maybeParen ctxt_prec TyConPrec $ hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty] -ppr_mono_ty ctxt_prec (HsOpTy ty1 (_wrapper, L _ op) ty2) +ppr_mono_ty ctxt_prec (HsOpTy ty1 (L _ op) ty2) = maybeParen ctxt_prec TyOpPrec $ sep [ ppr_mono_lty TyOpPrec ty1 , sep [pprInfixOcc op, ppr_mono_lty TyOpPrec ty2 ] ] - -- Don't print the wrapper (= kind applications) - -- c.f. HsWrapTy ppr_mono_ty _ (HsParTy ty) = parens (ppr_mono_lty TopPrec ty) @@ -1197,6 +1130,12 @@ ppr_fun_ty ctxt_prec ty1 ty2 sep [p1, ptext (sLit "->") <+> p2] -------------------------- +ppr_app_ty :: OutputableBndr name => TyPrec -> HsAppType name -> SDoc +ppr_app_ty _ (HsAppInfix (L _ n)) = pprInfixOcc n +ppr_app_ty _ (HsAppPrefix (L _ (HsTyVar (L _ n)))) = pprPrefixOcc n +ppr_app_ty ctxt (HsAppPrefix ty) = ppr_mono_lty ctxt ty + +-------------------------- ppr_tylit :: HsTyLit -> SDoc ppr_tylit (HsNumTy _ i) = integer i ppr_tylit (HsStrTy _ s) = text (show s) diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index ca3cae5260..fb969ebff1 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -51,9 +51,11 @@ module HsUtils( mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, -- Types - mkHsAppTy, userHsTyVarBndrs, + mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs, mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, + getAppsTyHead_maybe, hsTyGetAppHead_maybe, splitHsAppsTy, + getLHsInstDeclClass_maybe, -- Stmts mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkLastStmt, @@ -92,13 +94,12 @@ import HsTypes import HsLit import PlaceHolder -import TcType( tcSplitForAllTys, tcSplitPhiTy ) import TcEvidence import RdrName import Var -import Type( isPredTy ) -import Kind( isKind ) -import TypeRep +import TyCoRep +import Type ( filterOutInvisibleTypes ) +import TcType import DataCon import Name import NameSet @@ -171,6 +172,9 @@ mkMatchGroupName origin matches = MG { mg_alts = mkLocatedList matches mkHsAppTy :: LHsType name -> LHsType name -> LHsType name mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) +mkHsAppTys :: LHsType name -> [LHsType name] -> LHsType name +mkHsAppTys = foldl mkHsAppTy + mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) @@ -335,10 +339,15 @@ mkHsStringPrimLit fs = HsStringPrim (unpackFS fs) (fastStringToByteString fs) ------------- -userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)] +userHsLTyVarBndrs :: SrcSpan -> [Located name] -> [LHsTyVarBndr name] +-- Caller sets location +userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ] + +userHsTyVarBndrs :: SrcSpan -> [name] -> [LHsTyVarBndr name] -- Caller sets location userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ] + {- ************************************************************************ * * @@ -548,24 +557,27 @@ toLHsSigWcType ty = mkLHsSigWcType (go ty) where go :: Type -> LHsType RdrName - go ty@(ForAllTy {}) - | (tvs, tau) <- tcSplitForAllTys ty - = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs - , hst_body = go tau }) - go ty@(FunTy arg _) + go ty@(ForAllTy (Anon arg) _) | isPredTy arg , (theta, tau) <- tcSplitPhiTy ty = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) , hst_body = go tau }) - go (FunTy arg res) = nlHsFunTy (go arg) (go res) + go (ForAllTy (Anon arg) res) = nlHsFunTy (go arg) (go res) + go ty@(ForAllTy {}) + | (tvs, tau) <- tcSplitForAllTys ty + = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs + , hst_body = go tau }) go (TyVarTy tv) = nlHsTyVar (getRdrName tv) go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2) go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n) go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s) go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args') where - args' = filterOut isKind args - -- Source-language types have _implicit_ kind arguments, + args' = filterOutInvisibleTypes tc args + go (CastTy ty _) = go ty + go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co) + + -- Source-language types have _invisible_ kind arguments, -- so we must remove them here (Trac #8563) go_tv :: TyVar -> LHsTyVarBndr RdrName @@ -956,20 +968,23 @@ hsConDeclsBinders cons = go id cons L loc (ConDeclGADT { con_names = names , con_type = HsIB { hsib_body = res_ty}}) -> case tau of + L _ (HsFunTy (L _ (HsAppsTy [HsAppPrefix (L _ (HsRecTy flds))])) _res_ty) + -> record_gadt flds L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty) - -> (map (L loc . unLoc) names ++ ns, r' ++ fs) - where r' = remSeen (concatMap (cd_fld_names . unLoc) - flds) - remSeen' - = foldr (.) remSeen - [deleteBy ((==) `on` - rdrNameFieldOcc . unLoc) v - | v <- r'] - (ns, fs) = go remSeen' rs + -> record_gadt flds + _other -> (map (L loc . unLoc) names ++ ns, fs) where (ns, fs) = go remSeen rs - where - (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty + where + (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty + record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs) + where r' = remSeen (concatMap (cd_fld_names . unLoc) flds) + remSeen' = foldr (.) remSeen + [deleteBy ((==) `on` + rdrNameFieldOcc . unLoc) v + | v <- r'] + (ns, fs) = go remSeen' rs + L loc (ConDeclH98 { con_name = name , con_details = RecCon flds }) -> ([L loc (unLoc name)] ++ ns, r' ++ fs) @@ -1080,3 +1095,61 @@ lPatImplicits = hs_lpat (unLoc fld) pat_explicit = maybe True (i<) (rec_dotdot fs)] details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2 + +{- +************************************************************************ +* * + Dealing with HsAppsTy +* * +************************************************************************ +-} + +-- | Retrieves the head of an HsAppsTy, if this can be done unambiguously, +-- without consulting fixities. +getAppsTyHead_maybe :: [HsAppType name] -> Maybe (LHsType name, [LHsType name]) +getAppsTyHead_maybe tys = case splitHsAppsTy tys of + ([app1:apps], []) -> -- no symbols, some normal types + Just (mkHsAppTys app1 apps, []) + ([app1l:appsl, app1r:appsr], [L loc op]) -> -- one operator + Just (L loc (HsTyVar (L loc op)), [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr]) + _ -> -- can't figure it out + Nothing + +-- | Splits a [HsAppType name] (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 :: [HsAppType name] -> ([[LHsType name]], [Located name]) +splitHsAppsTy = go [] [] [] + where + go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym) + go acc acc_non acc_sym (HsAppPrefix ty : rest) + = go (ty : acc) acc_non acc_sym rest + go acc acc_non acc_sym (HsAppInfix op : rest) + = go [] (reverse acc : acc_non) (op : acc_sym) rest + +-- 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.) +hsTyGetAppHead_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) +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 + go tys (L _ (HsKindSig t _)) = go tys t + go _ _ = Nothing + +getLHsInstDeclClass_maybe :: LHsSigType name -> Maybe (Located name) +-- Works on (HsSigType RdrName) +getLHsInstDeclClass_maybe inst_ty + = do { let (_, tau) = splitLHsQualTy (hsSigType inst_ty) + ; (cls, _) <- hsTyGetAppHead_maybe tau + ; return cls } |