From 87f3ebf2604d2889007ee56b18df0928518face6 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Sat, 26 Mar 2022 18:55:30 -0400 Subject: Consistently attach SrcSpans to sub-expressions in TH splices Before, `GHC.ThToHs` was very inconsistent about where various sub-expressions would get the same `SrcSpan` from the original TH splice location or just a generic `noLoc` `SrcSpan`. I have ripped out all uses of `noLoc` in favor of the former instead, and I have added a `Note [Source locations within TH splices]` to officially enshrine this design choice. Fixes #21299. --- compiler/GHC/ThToHs.hs | 312 +++++++++++++++++++++++++++---------------------- 1 file changed, 173 insertions(+), 139 deletions(-) diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index ebcaad926a..d1ab002532 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -96,9 +97,8 @@ newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either SDoc (SrcSpan, a) -- Reason: so a (head []) in TH code doesn't subsequently -- make GHC crash when it tries to walk the generated tree --- Use the loc everywhere, for lack of anything better --- In particular, we want it on binding locations, so that variables bound in --- the spliced-in declarations get a location that at least relates to the splice point +-- Use the SrcSpan everywhere, for lack of anything better. +-- See Note [Source locations within TH splices]. instance Applicative CvtM where pure x = CvtM $ \_ loc -> Right (loc,x) @@ -124,16 +124,18 @@ getOrigin = CvtM (\origin loc -> Right (loc,origin)) getL :: CvtM SrcSpan getL = CvtM (\_ loc -> Right (loc,loc)) +-- NB: This is only used in conjunction with LineP pragmas. +-- See Note [Source locations within TH splices]. setL :: SrcSpan -> CvtM () setL loc = CvtM (\_ _ -> Right (loc, ())) -returnLA :: e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e) +returnLA :: e -> CvtM (LocatedAn ann e) returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x)) returnJustLA :: a -> CvtM (Maybe (LocatedA a)) returnJustLA = fmap Just . returnLA -wrapParLA :: (LocatedA a -> a) -> a -> CvtM a +wrapParLA :: (LocatedAn ann a -> b) -> a -> CvtM b wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x))) wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b @@ -165,6 +167,41 @@ wrapLA (CvtM m) = CvtM $ \origin loc -> case m origin loc of Left err -> Left err Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v) +{- +Note [Source locations within TH splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a TH splice such as $(x), where `x` evaluates to `id True`. What +source locations should we use for subexpressions within the splice, such as +`id` and `True`? We basically have two options: + +1. Don't give anything within the splice a SrcSpan. That is, use the `noLoc` + everywhere. +2. Give everything within the splice the same `SrcSpan` as where the splice + occurs (i.e., where $(x) occurs). + +We implement option (2) for the following reasons: + +* We want SrcSpans on binding locations so that variables bound in the + spliced-in declarations get a location that at least relates to the splice + point. + +* Generally speaking, having *some* SrcSpan for each sub-expression in the AST + in better than having no SrcSpan at all. This extra information can be useful + for programs that walk over the AST directly. + +Because of our choice of option (2), we are very careful not to use the noLoc +function anywhere in GHC.ThToHs. Instead, we thread around a SrcSpan in CvtM +and allow retrieving the SrcSpan through combinators such as getL, returnLA, +wrapParLA, etc. + +Note that CvtM is actually a *state* monad vis-à-vis SrcSpan, not just a +reader monad. This is because LineP pragmas can change the source location +within a splice—see testsuite/tests/th/TH_linePragma.hs for an example. This +is a bit unusual, since it changes the source location from that of the splice +point to that of the code being spliced in. Nevertheless, LineP is *the* reason +why CvtM is a state monad. +-} + ------------------------------------------------------------------- cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] cvtDecs = fmap catMaybes . mapM cvtDec @@ -394,7 +431,7 @@ cvtDec (ClosedTypeFamilyD head eqns) cvtDec (TH.RoleAnnotD tc roles) = do { tc' <- tconNameN tc - ; let roles' = map (noLocA . cvtRole) roles + ; roles' <- traverse (returnLA . cvtRole) roles ; returnJustLA $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noAnn tc' roles') } @@ -437,7 +474,7 @@ cvtDec (TH.PatSynD nm args dir pat) cvtDir n (ExplBidir cls) = do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls ; th_origin <- getOrigin - ; return $ ExplicitBidirectional $ mkMatchGroup th_origin (noLocA ms) } + ; wrapParLA (ExplicitBidirectional . mkMatchGroup th_origin) ms } cvtDec (TH.PatSynSigD nm ty) = do { nm' <- cNameN nm @@ -599,8 +636,8 @@ cvtConstr (NormalC c strtys) cvtConstr (RecC c varstrtys) = do { c' <- cNameN c ; args' <- mapM cvt_id_arg varstrtys - ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing - (RecCon (noLocA args')) } + ; con_decl <- wrapParLA (mkConDeclH98 noAnn c' Nothing Nothing . RecCon) args' + ; returnLA con_decl } cvtConstr (InfixC st1 c st2) = do { c' <- cNameN c @@ -647,7 +684,7 @@ cvtConstr (GadtC c strtys ty) = do { c' <- mapM cNameN c ; args <- mapM cvt_arg strtys ; ty' <- cvtType ty - ; returnLA $ mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'} + ; mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'} cvtConstr (RecGadtC [] _varstrtys _ty) = failWith (text "RecGadtC must have at least one constructor name") @@ -656,18 +693,21 @@ cvtConstr (RecGadtC c varstrtys ty) = do { c' <- mapM cNameN c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys - ; returnLA $ mk_gadt_decl c' (RecConGADT (noLocA rec_flds) noHsUniTok) ty' } + ; lrec_flds <- returnLA rec_flds + ; mk_gadt_decl c' (RecConGADT lrec_flds noHsUniTok) ty' } mk_gadt_decl :: [LocatedN RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs - -> ConDecl GhcPs + -> CvtM (LConDecl GhcPs) mk_gadt_decl names args res_ty - = ConDeclGADT { con_g_ext = noAnn - , con_names = names - , con_bndrs = noLocA mkHsOuterImplicit - , con_mb_cxt = Nothing - , con_g_args = args - , con_res_ty = res_ty - , con_doc = Nothing } + = do bndrs <- returnLA mkHsOuterImplicit + returnLA $ ConDeclGADT + { con_g_ext = noAnn + , con_names = names + , con_bndrs = bndrs + , con_mb_cxt = Nothing + , con_g_args = args + , con_res_ty = res_ty + , con_doc = Nothing } cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack @@ -691,12 +731,12 @@ cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) cvt_id_arg (i, str, ty) = do { L li i' <- vNameN i ; ty' <- cvt_arg (str,ty) - ; return $ noLocA (ConDeclField + ; returnLA $ ConDeclField { cd_fld_ext = noAnn , cd_fld_names = [L (l2l li) $ FieldOcc noExtField (L li i')] , cd_fld_type = ty' - , cd_fld_doc = Nothing}) } + , cd_fld_doc = Nothing} } cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs) cvtDerivs cs = do { mapM cvtDerivClause cs } @@ -712,21 +752,22 @@ cvt_fundep (TH.FunDep xs ys) = do { xs' <- mapM tNameN xs ------------------------------------------ cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs) -cvtForD (ImportF callconv safety from nm ty) - -- the prim and javascript calling conventions do not support headers - -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess - | callconv == TH.Prim || callconv == TH.JavaScript - = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing - (CFunction (StaticTarget (SourceText from) - (mkFastString from) Nothing - True)) - (noLoc $ quotedSourceText from)) - | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety') - (mkFastString (TH.nameBase nm)) - from (noLoc $ quotedSourceText from) - = mk_imp impspec - | otherwise - = failWith $ text (show from) <+> text "is not a valid ccall impent" +cvtForD (ImportF callconv safety from nm ty) = + do { l <- getL + ; if -- the prim and javascript calling conventions do not support headers + -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess + | callconv == TH.Prim || callconv == TH.JavaScript + -> mk_imp (CImport (L l (cvt_conv callconv)) (L l safety') Nothing + (CFunction (StaticTarget (SourceText from) + (mkFastString from) Nothing + True)) + (L l $ quotedSourceText from)) + | Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety') + (mkFastString (TH.nameBase nm)) + from (L l $ quotedSourceText from) + -> mk_imp impspec + | otherwise + -> failWith $ text (show from) <+> text "is not a valid ccall impent" } where mk_imp impspec = do { nm' <- vNameN nm @@ -744,10 +785,11 @@ cvtForD (ImportF callconv safety from nm ty) cvtForD (ExportF callconv as nm ty) = do { nm' <- vNameN nm ; ty' <- cvtSigType ty - ; let e = CExport (noLoc (CExportStatic (SourceText as) - (mkFastString as) - (cvt_conv callconv))) - (noLoc (SourceText as)) + ; l <- getL + ; let e = CExport (L l (CExportStatic (SourceText as) + (mkFastString as) + (cvt_conv callconv))) + (L l (SourceText as)) ; return $ ForeignExport { fd_e_ext = noAnn , fd_name = nm' , fd_sig_ty = ty' @@ -818,22 +860,24 @@ cvtPragmaD (SpecialiseInstP ty) cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) = do { let nm' = mkFastString nm + ; rd_name' <- returnLA (quotedSourceText nm,nm') ; let act = cvtPhases phases AlwaysActive ; ty_bndrs' <- traverse cvtTvs ty_bndrs ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs ; lhs' <- cvtl lhs ; rhs' <- cvtl rhs + ; rule <- returnLA $ + HsRule { rd_ext = noAnn + , rd_name = rd_name' + , rd_act = act + , rd_tyvs = ty_bndrs' + , rd_tmvs = tm_bndrs' + , rd_lhs = lhs' + , rd_rhs = rhs' } ; returnJustLA $ Hs.RuleD noExtField $ HsRules { rds_ext = noAnn , rds_src = SourceText "{-# RULES" - , rds_rules = [noLocA $ - HsRule { rd_ext = noAnn - , rd_name = (noLocA (quotedSourceText nm,nm')) - , rd_act = act - , rd_tyvs = ty_bndrs' - , rd_tmvs = tm_bndrs' - , rd_lhs = lhs' - , rd_rhs = rhs' }] } + , rds_rules = [rule] } } @@ -843,20 +887,22 @@ cvtPragmaD (AnnP target exp) ModuleAnnotation -> return ModuleAnnProvenance TypeAnnotation n -> do n' <- tconName n - return (TypeAnnProvenance (noLocA n')) + wrapParLA TypeAnnProvenance n' ValueAnnotation n -> do n' <- vcName n - return (ValueAnnProvenance (noLocA n')) + wrapParLA ValueAnnProvenance n' ; returnJustLA $ Hs.AnnD noExtField $ HsAnnotation noAnn (SourceText "{-# ANN") target' exp' } +-- NB: This is the only place in GHC.ThToHs that makes use of the `setL` +-- function. See Note [Source locations within TH splices]. cvtPragmaD (LineP line file) = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1)) ; return Nothing } cvtPragmaD (CompleteP cls mty) - = do { cls' <- noLoc <$> mapM cNameN cls + = do { cls' <- wrapL $ mapM cNameN cls ; mty' <- traverse tconNameN mty ; returnJustLA $ Hs.SigD noExtField $ CompleteMatchSig noAnn NoSourceText cls' mty' } @@ -882,11 +928,11 @@ cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) cvtRuleBndr (RuleVar n) = do { n' <- vNameN n - ; return $ noLocA $ Hs.RuleBndr noAnn n' } + ; returnLA $ Hs.RuleBndr noAnn n' } cvtRuleBndr (TypedRuleVar n ty) = do { n' <- vNameN n ; ty' <- cvtType ty - ; return $ noLocA $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' } + ; returnLA $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' } --------------------------------------------------- -- Declarations @@ -930,8 +976,8 @@ cvtImplicitParamBind n e = do cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) cvtl e = wrapLA (cvt e) where - cvt (VarE s) = do { s' <- vName s; return $ HsVar noExtField (noLocA s') } - cvt (ConE s) = do { s' <- cName s; return $ HsVar noExtField (noLocA s') } + cvt (VarE s) = do { s' <- vName s; wrapParLA (HsVar noExtField) s' } + cvt (ConE s) = do { s' <- cName s; wrapParLA (HsVar noExtField) s' } cvt (LitE l) | overloadedLit l = go cvtOverLit (HsOverLit noComments) (hsOverLitNeedsParens appPrec) @@ -945,7 +991,7 @@ cvtl e = wrapLA (cvt e) go cvt_lit mk_expr is_compound_lit = do l' <- cvt_lit l let e' = mk_expr l' - return $ if is_compound_lit l' then gHsPar (noLocA e') else e' + if is_compound_lit l' then wrapParLA gHsPar e' else pure e' cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y ; return $ HsApp noComments (mkLHsPar x') (mkLHsPar y')} @@ -964,13 +1010,11 @@ cvtl e = wrapLA (cvt e) cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e ; let pats = map (parenthesizePat appPrec) ps' ; th_origin <- getOrigin - ; return $ HsLam noExtField (mkMatchGroup th_origin - (noLocA [mkSimpleMatch LambdaExpr - pats e']))} + ; wrapParLA (HsLam noExtField . mkMatchGroup th_origin) + [mkSimpleMatch LambdaExpr pats e']} cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch CaseAlt) ms ; th_origin <- getOrigin - ; return $ HsLamCase noAnn - (mkMatchGroup th_origin (noLocA ms')) + ; wrapParLA (HsLamCase noAnn . mkMatchGroup th_origin) ms' } cvt (TupE es) = cvt_tup es Boxed cvt (UnboxedTupE es) = cvt_tup es Unboxed @@ -988,8 +1032,7 @@ cvtl e = wrapLA (cvt e) ; e' <- cvtl e; return $ HsLet noAnn noHsTok ds' noHsTok e'} cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms ; th_origin <- getOrigin - ; return $ HsCase noAnn e' - (mkMatchGroup th_origin (noLocA ms')) } + ; wrapParLA (HsCase noAnn e' . mkMatchGroup th_origin) ms' } cvt (DoE m ss) = cvtHsDo (DoExpr (mk_mod <$> m)) ss cvt (MDoE m ss) = cvtHsDo (MDoExpr (mk_mod <$> m)) ss cvt (CompE ss) = cvtHsDo ListComp ss @@ -1044,11 +1087,11 @@ cvtl e = wrapLA (cvt e) ; let pe = parenthesizeHsExpr sigPrec e' ; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') } cvt (RecConE c flds) = do { c' <- cNameN c - ; flds' <- mapM (cvtFld (mkFieldOcc . noLocA)) flds + ; flds' <- mapM (cvtFld (wrapParLA mkFieldOcc)) flds ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) noAnn } cvt (RecUpdE e flds) = do { e' <- cvtl e ; flds' - <- mapM (cvtFld (mkAmbiguousFieldOcc . noLocA)) + <- mapM (cvtFld (wrapParLA mkAmbiguousFieldOcc)) flds ; return $ RecordUpd noAnn e' (Left flds') } cvt (StaticE e) = fmap (HsStatic noAnn) $ cvtl e @@ -1056,7 +1099,7 @@ cvtl e = wrapLA (cvt e) -- important, because UnboundVarE may contain -- constructor names - see #14627. { s' <- vcName s - ; return $ HsVar noExtField (noLocA s') } + ; wrapParLA (HsVar noExtField) s' } cvt (LabelE s) = return $ HsOverLabel noComments (fsLit s) cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' } cvt (GetFieldE exp f) = do { e' <- cvtl exp @@ -1096,14 +1139,16 @@ parentheses, the above expression would be reassociated to which we don't want. -} -cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) +cvtFld :: (RdrName -> CvtM t) -> (TH.Name, TH.Exp) -> CvtM (LHsFieldBind GhcPs (LocatedAn NoEpAnns t) (LHsExpr GhcPs)) cvtFld f (v,e) - = do { v' <- vNameL v; e' <- cvtl e - ; return (noLocA $ HsFieldBind { hfbAnn = noAnn - , hfbLHS = la2la $ fmap f v' - , hfbRHS = e' - , hfbPun = False}) } + = do { v' <- vNameL v + ; lhs' <- traverse f v' + ; e' <- cvtl e + ; returnLA $ HsFieldBind { hfbAnn = noAnn + , hfbLHS = la2la lhs' + , hfbRHS = e' + , hfbPun = False} } cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs) cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } @@ -1200,7 +1245,7 @@ cvtHsDo do_or_lc stmts -> return (L loc (mkLastStmt body)) _ -> failWith (bad_last last') - ; return $ HsDo noAnn do_or_lc (noLocA (stmts'' ++ [last''])) } + ; wrapParLA (HsDo noAnn do_or_lc) (stmts'' ++ [last'']) } where bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon , nest 2 $ Outputable.ppr stmt @@ -1219,7 +1264,9 @@ cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss where cvt_one ds = do { ds' <- cvtStmts ds ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) } -cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnLA (mkRecStmt noAnn (noLocA ss')) } +cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss + ; rec_stmt <- wrapParLA (mkRecStmt noAnn) ss' + ; returnLA rec_stmt } cvtMatch :: HsMatchContext GhcPs -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) @@ -1315,12 +1362,13 @@ cvtPat pat = wrapLA (cvtp pat) cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs) cvtp (TH.LitP l) | overloadedLit l = do { l' <- cvtOverLit l - ; return (mkNPat (noLocA l') Nothing noAnn) } + ; l'' <- returnLA l' + ; return (mkNPat l'' Nothing noAnn) } -- Not right for negative patterns; -- need to think about that! | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' } cvtp (TH.VarP s) = do { s' <- vName s - ; return $ Hs.VarPat noExtField (noLocA s') } + ; wrapParLA (Hs.VarPat noExtField) s' } cvtp (TupP ps) = do { ps' <- cvtPats ps ; return $ TuplePat noAnn ps' Boxed } cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps @@ -1379,11 +1427,11 @@ cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p) = do { L ls s' <- vNameN s ; p' <- cvtPat p - ; return (noLocA $ HsFieldBind { hfbAnn = noAnn - , hfbLHS - = L (l2l ls) $ mkFieldOcc (L (l2l ls) s') - , hfbRHS = p' - , hfbPun = False}) } + ; returnLA $ HsFieldBind { hfbAnn = noAnn + , hfbLHS + = L (l2l ls) $ mkFieldOcc (L (l2l ls) s') + , hfbRHS = p' + , hfbPun = False} } {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. The produced tree of infix patterns will be left-biased, provided @x@ is. @@ -1500,19 +1548,15 @@ cvtTypeKind ty_str ty , normals `lengthIs` n -- Saturated -> returnLA (HsTupleTy noAnn HsBoxedOrConstraintTuple normals) | otherwise - -> mk_apps - (HsTyVar noAnn NotPromoted - (noLocA (getRdrName (tupleTyCon Boxed n)))) - tys' + -> do { tuple_tc <- returnLA $ getRdrName $ tupleTyCon Boxed n + ; mk_apps (HsTyVar noAnn NotPromoted tuple_tc) tys' } UnboxedTupleT n | Just normals <- m_normals , normals `lengthIs` n -- Saturated -> returnLA (HsTupleTy noAnn HsUnboxedTuple normals) | otherwise - -> mk_apps - (HsTyVar noAnn NotPromoted - (noLocA (getRdrName (tupleTyCon Unboxed n)))) - tys' + -> do { tuple_tc <- returnLA $ getRdrName $ tupleTyCon Unboxed n + ; mk_apps (HsTyVar noAnn NotPromoted tuple_tc) tys' } UnboxedSumT n | n < 2 -> failWith $ @@ -1523,9 +1567,8 @@ cvtTypeKind ty_str ty , normals `lengthIs` n -- Saturated -> returnLA (HsSumTy noAnn normals) | otherwise - -> mk_apps - (HsTyVar noAnn NotPromoted (noLocA (getRdrName (sumTyCon n)))) - tys' + -> do { sum_tc <- returnLA $ getRdrName $ sumTyCon n + ; mk_apps (HsTyVar noAnn NotPromoted sum_tc) tys' } ArrowT | Just normals <- m_normals , [x',y'] <- normals -> do @@ -1538,9 +1581,8 @@ cvtTypeKind ty_str ty let y'' = parenthesizeHsType sigPrec y' returnLA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x'' y'') | otherwise - -> mk_apps - (HsTyVar noAnn NotPromoted (noLocA (getRdrName unrestrictedFunTyCon))) - tys' + -> do { fun_tc <- returnLA $ getRdrName unrestrictedFunTyCon + ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' } MulArrowT | Just normals <- m_normals , [w',x',y'] <- normals -> do @@ -1554,23 +1596,22 @@ cvtTypeKind ty_str ty w'' = hsTypeToArrow w' returnLA (HsFunTy noAnn w'' x'' y'') | otherwise - -> mk_apps - (HsTyVar noAnn NotPromoted (noLocA (getRdrName funTyCon))) - tys' + -> do { fun_tc <- returnLA $ getRdrName funTyCon + ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' } ListT | Just normals <- m_normals , [x'] <- normals -> returnLA (HsListTy noAnn x') | otherwise - -> mk_apps - (HsTyVar noAnn NotPromoted (noLocA (getRdrName listTyCon))) - tys' + -> do { list_tc <- returnLA $ getRdrName listTyCon + ; mk_apps (HsTyVar noAnn NotPromoted list_tc) tys' } VarT nm -> do { nm' <- tNameN nm ; mk_apps (HsTyVar noAnn NotPromoted nm') tys' } ConT nm -> do { nm' <- tconName nm ; let prom = name_promotedness nm' - ; mk_apps (HsTyVar noAnn prom (noLocA nm')) tys'} + ; lnm' <- returnLA nm' + ; mk_apps (HsTyVar noAnn prom lnm') tys'} ForallT tvs cxt ty | null tys' @@ -1611,8 +1652,9 @@ cvtTypeKind ty_str ty ; t1' <- cvtType t1 ; t2' <- cvtType t2 ; let prom = name_promotedness s' + ; ls' <- returnLA s' ; mk_apps - (HsTyVar noAnn prom (noLocA s')) + (HsTyVar noAnn prom ls') ([HsValArg t1', HsValArg t2'] ++ tys') } @@ -1624,11 +1666,11 @@ cvtTypeKind ty_str ty } -- Note [Converting UInfix] PromotedInfixT t1 s t2 - -> do { s' <- cName s + -> do { s' <- cNameN s ; t1' <- cvtType t1 ; t2' <- cvtType t2 ; mk_apps - (HsTyVar noAnn IsPromoted (noLocA s')) + (HsTyVar noAnn IsPromoted s') ([HsValArg t1', HsValArg t2'] ++ tys') } @@ -1644,9 +1686,8 @@ cvtTypeKind ty_str ty ; mk_apps (HsParTy noAnn t') tys' } - PromotedT nm -> do { nm' <- cName nm - ; mk_apps (HsTyVar noAnn IsPromoted - (noLocA nm')) + PromotedT nm -> do { nm' <- cNameN nm + ; mk_apps (HsTyVar noAnn IsPromoted nm') tys' } -- Promoted data constructor; hence cName @@ -1655,10 +1696,8 @@ cvtTypeKind ty_str ty , normals `lengthIs` n -- Saturated -> returnLA (HsExplicitTupleTy noAnn normals) | otherwise - -> mk_apps - (HsTyVar noAnn IsPromoted - (noLocA (getRdrName (tupleDataCon Boxed n)))) - tys' + -> do { tuple_tc <- returnLA $ getRdrName $ tupleDataCon Boxed n + ; mk_apps (HsTyVar noAnn IsPromoted tuple_tc) tys' } PromotedNilT -> mk_apps (HsExplicitListTy noAnn IsPromoted []) tys' @@ -1669,35 +1708,31 @@ cvtTypeKind ty_str ty , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals -> returnLA (HsExplicitListTy noAnn ip (ty1:tys2)) | otherwise - -> mk_apps - (HsTyVar noAnn IsPromoted (noLocA (getRdrName consDataCon))) - tys' + -> do { cons_tc <- returnLA $ getRdrName consDataCon + ; mk_apps (HsTyVar noAnn IsPromoted cons_tc) tys' } StarT - -> mk_apps - (HsTyVar noAnn NotPromoted - (noLocA (getRdrName liftedTypeKindTyCon))) - tys' + -> do { type_tc <- returnLA $ getRdrName liftedTypeKindTyCon + ; mk_apps (HsTyVar noAnn NotPromoted type_tc) tys' } ConstraintT - -> mk_apps - (HsTyVar noAnn NotPromoted - (noLocA (getRdrName constraintKindTyCon))) - tys' + -> do { constraint_tc <- returnLA $ getRdrName constraintKindTyCon + ; mk_apps (HsTyVar noAnn NotPromoted constraint_tc) tys' } EqualityT | Just normals <- m_normals , [x',y'] <- normals -> let px = parenthesizeHsType opPrec x' py = parenthesizeHsType opPrec y' - in returnLA (HsOpTy noExtField px (noLocA eqTyCon_RDR) py) + in do { eq_tc <- returnLA eqTyCon_RDR + ; returnLA (HsOpTy noExtField px eq_tc py) } -- The long-term goal is to remove the above case entirely and -- subsume it under the case for InfixT. See #15815, comment:6, -- for more details. | otherwise -> - mk_apps (HsTyVar noAnn NotPromoted - (noLocA eqTyCon_RDR)) tys' + do { eq_tc <- returnLA eqTyCon_RDR + ; mk_apps (HsTyVar noAnn NotPromoted eq_tc) tys' } ImplicitParamT n t -> do { n' <- wrapL $ ipName n ; t' <- cvtType t @@ -1851,22 +1886,21 @@ cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs) -- see Note [Pattern synonym type signatures and Template Haskell] cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) | null exis, null provs = cvtSigType (ForallT univs reqs ty) - | null univs, null reqs = do { l' <- getL - ; let l = noAnnSrcSpan l' - ; ty' <- cvtType (ForallT exis provs ty) - ; return $ L l $ mkHsImplicitSigType - $ L l (HsQualTy { hst_ctxt = noLocA [] - , hst_xqual = noExtField - , hst_body = ty' }) } - | null reqs = do { l' <- getL - ; let l'' = noAnnSrcSpan l' - ; univs' <- cvtTvs univs + | null univs, null reqs = do { ty' <- cvtType (ForallT exis provs ty) + ; ctxt' <- returnLA [] + ; cxtTy <- wrapParLA mkHsImplicitSigType $ + HsQualTy { hst_ctxt = ctxt' + , hst_xqual = noExtField + , hst_body = ty' } + ; returnLA cxtTy } + | null reqs = do { univs' <- cvtTvs univs ; ty' <- cvtType (ForallT exis provs ty) - ; let forTy = mkHsExplicitSigType noAnn univs' $ L l'' cxtTy - cxtTy = HsQualTy { hst_ctxt = noLocA [] + ; ctxt' <- returnLA [] + ; let cxtTy = HsQualTy { hst_ctxt = ctxt' , hst_xqual = noExtField , hst_body = ty' } - ; return $ L (noAnnSrcSpan l') forTy } + ; forTy <- wrapParLA (mkHsExplicitSigType noAnn univs') cxtTy + ; returnLA forTy } | otherwise = cvtSigType (ForallT univs reqs (ForallT exis provs ty)) cvtPatSynSigTy ty = cvtSigType ty -- cgit v1.2.1