diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2015-11-22 23:41:57 +0100 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2015-11-23 00:07:43 +0100 |
| commit | 3df9563e590bbfbfe1bc9171a0e8fc93ceef690d (patch) | |
| tree | 5e63328de5de41c66f089284d75e7251c4085db1 /compiler | |
| parent | 64737f2dfa0ff9ca4f4c056143b3591cedd32652 (diff) | |
| download | haskell-3df9563e590bbfbfe1bc9171a0e8fc93ceef690d.tar.gz | |
ApiAnnotations: Make all RdrName occurences Located
At the moment the API Annotations can only be used on the ParsedSource,
as there are changes made to the RenamedSource that prevent it from
being used to round trip source code.
It is possible to build a map from every Located Name in the
RenamedSource from its location to the Name, which can then be used when
resolved names are required when changing the ParsedSource.
However, there are instances where the identifier is not located,
specifically
(GHC.VarPat name)
(GHC.HsVar name)
(GHC.UserTyVar name)
(GHC.HsTyVar name)
Replace each of the name types above with (Located name)
Updates the haddock submodule.
Test Plan: ./validate
Reviewers: austin, goldfire, bgamari
Reviewed By: bgamari
Subscribers: goldfire, thomie, mpickering
Differential Revision: https://phabricator.haskell.org/D1512
GHC Trac Issues: #11019
Diffstat (limited to 'compiler')
35 files changed, 284 insertions, 250 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 0417bdd79c..54a934d3e6 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -688,7 +688,7 @@ tidy_lpat p = fmap tidy_pat p -------------- tidy_pat :: Pat Id -> Pat Id tidy_pat pat@(WildPat _) = pat -tidy_pat (VarPat id) = WildPat (idType id) +tidy_pat (VarPat id) = WildPat (idType (unLoc id)) tidy_pat (ParPat p) = tidy_pat (unLoc p) tidy_pat (LazyPat p) = WildPat (hsLPatType p) -- For overlap and exhaustiveness checking -- purposes, a ~pat is like a wildcard diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 95c70aa212..18de4c4d9d 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -461,7 +461,7 @@ addBinTickLHsExpr boxLabel (L pos e0) -- Decoarate an HsExpr with ticks addTickHsExpr :: HsExpr Id -> TM (HsExpr Id) -addTickHsExpr e@(HsVar id) = do freeVar id; return e +addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" addTickHsExpr e@(HsIPVar _) = return e addTickHsExpr e@(HsOverLit _) = return e diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 14c38b0e9a..3d592b1c0c 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -527,8 +527,8 @@ dsCmd ids local_vars stack_ty res_ty left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName let - left_id = HsVar (dataConWrapId left_con) - right_id = HsVar (dataConWrapId right_con) + left_id = HsVar (noLoc (dataConWrapId left_con)) + right_id = HsVar (noLoc (dataConWrapId right_con)) left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e @@ -1129,7 +1129,7 @@ collectl :: LPat Id -> [Id] -> [Id] collectl (L _ pat) bndrs = go pat where - go (VarPat var) = var : bndrs + go (VarPat (L _ var)) = var : bndrs go (WildPat _) = bndrs go (LazyPat pat) = collectl pat bndrs go (BangPat pat) = collectl pat bndrs diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 13e7e11431..7100e0b219 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -196,7 +196,8 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e dsExpr :: HsExpr Id -> DsM CoreExpr dsExpr (HsPar e) = dsLExpr e dsExpr (ExprWithTySigOut e _) = dsLExpr e -dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars] +dsExpr (HsVar (L _ var)) = return (varToCoreExpr var) + -- See Note [Desugaring vars] dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar" dsExpr (HsOverLabel _) = panic "dsExpr: HsOverLabel" @@ -624,7 +625,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields -- SAFE: the typechecker will complain if the synonym is -- not bidirectional wrap_id = expectJust "dsExpr:mk_alt" (conLikeWrapId_maybe con) - inst_con = noLoc $ HsWrap wrap (HsVar wrap_id) + inst_con = noLoc $ HsWrap wrap (HsVar (noLoc wrap_id)) -- Reconstruct with the WrapId so that unpacking happens -- The order here is because of the order in `TcPatSyn`. wrap = diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index 3eafd12c73..c5217f1113 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -134,9 +134,9 @@ isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr) -- * Trivial wappings of these -- The arguments to Just are any HsTicks that we have found, -- because we still want to tick then, even it they are aways evaluted. -isTrueLHsExpr (L _ (HsVar v)) | v `hasKey` otherwiseIdKey - || v `hasKey` getUnique trueDataConId - = Just return +isTrueLHsExpr (L _ (HsVar (L _ v))) | v `hasKey` otherwiseIdKey + || v `hasKey` getUnique trueDataConId + = Just return -- trueDataConId doesn't have the same unique as trueDataCon isTrueLHsExpr (L _ (HsTick tickish e)) | Just ticks <- isTrueLHsExpr e diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 0b9906f7f1..df452ea7d0 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -410,7 +410,7 @@ mk_extra_tvs tc tvs defn ; hs_tvs <- go rest ; return (hs_tv : hs_tvs) } - go (L _ (HsTyVar n)) + go (L _ (HsTyVar (L _ n))) | n == liftedTypeKindTyConName = return [] @@ -456,7 +456,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds -- the selector Ids, not to fresh names (Trac #5410) -- do { cxt1 <- repContext cxt - ; cls_tcon <- repTy (HsTyVar (unLoc cls)) + ; cls_tcon <- repTy (HsTyVar cls) ; cls_tys <- repLTys tys ; inst_ty1 <- repTapps cls_tcon cls_tys ; binds1 <- rep_binds binds @@ -472,7 +472,7 @@ repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ) repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty })) = do { dec <- addTyVarBinds tvs $ \_ -> do { cxt' <- repContext cxt - ; cls_tcon <- repTy (HsTyVar (unLoc cls)) + ; cls_tcon <- repTy (HsTyVar cls) ; cls_tys <- repLTys tys ; inst_ty <- repTapps cls_tcon cls_tys ; repDeriv cxt' inst_ty } @@ -677,11 +677,11 @@ mkGadtCtxt data_tvs (ResTyGADT _ res_ty) = go (eq_pred : cxt) subst rest where loc = getLoc ty - eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty) + eq_pred = L loc (HsEqTy (L loc (HsTyVar (L loc data_tv))) ty) - is_hs_tyvar (L _ (HsTyVar n)) = Just n -- Type variables *and* tycons - is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty - is_hs_tyvar _ = Nothing + is_hs_tyvar (L _ (HsTyVar (L _ n))) = Just n -- Type variables *and* tycons + is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty + is_hs_tyvar _ = Nothing repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ)) @@ -870,8 +870,8 @@ repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm -- | Represent a type variable binder repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr) -repTyVarBndr (L _ (UserTyVar nm)) = do { nm' <- lookupBinder nm - ; repPlainTV nm' } +repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm + ; repPlainTV nm' } repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm ; ki' <- repLKind ki ; repKindedTV nm' ki' } @@ -911,13 +911,13 @@ repTy (HsForAllTy _ extra tvs ctxt ty) = -- This unique will be discarded by repLContext, but is required -- to make a Name name = mkInternalName uniq (mkTyVarOcc "_") loc - in (++ [L loc (HsWildCardTy (AnonWildCard name))]) `fmap` ctxt + in (++ [L loc (HsWildCardTy (AnonWildCard (L loc name)))]) `fmap` ctxt | otherwise = ctxt -repTy (HsTyVar n) +repTy (HsTyVar (L _ n)) | isTvOcc occ = do tv1 <- lookupOcc n repTvar tv1 | isDataOcc occ = do tc1 <- lookupOcc n @@ -940,10 +940,10 @@ repTy (HsListTy t) = do t1 <- repLTy t tcon <- repListTyCon repTapp tcon t1 -repTy (HsPArrTy t) = do - t1 <- repLTy t - tcon <- repTy (HsTyVar (tyConName parrTyCon)) - repTapp tcon t1 +repTy (HsPArrTy t) = do + t1 <- repLTy t + tcon <- repTy (HsTyVar (noLoc (tyConName parrTyCon))) + repTapp tcon t1 repTy (HsTupleTy HsUnboxedTuple tys) = do tys1 <- repLTys tys tcon <- repUnboxedTupleTyCon (length tys) @@ -975,7 +975,7 @@ repTy (HsTyLit lit) = do lit' <- repTyLit lit repTLit lit' repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard -repTy (HsWildCardTy (NamedWildCard n)) = do +repTy (HsWildCardTy (NamedWildCard (L _ n))) = do nwc <- lookupOcc n repTNamedWildCard nwc @@ -1004,7 +1004,7 @@ repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind) repNonArrowLKind (L _ ki) = repNonArrowKind ki repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind) -repNonArrowKind (HsTyVar name) +repNonArrowKind (HsTyVar (L _ name)) | name == liftedTypeKindTyConName = repKStar | name == constraintKindTyConName = repKConstraint | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar @@ -1063,7 +1063,7 @@ repLE :: LHsExpr Name -> DsM (Core TH.ExpQ) repLE (L loc e) = putSrcSpanDs loc (repE e) repE :: HsExpr Name -> DsM (Core TH.ExpQ) -repE (HsVar x) = +repE (HsVar (L _ x)) = do { mb_val <- dsLookupMetaEnv x ; case mb_val of Nothing -> do { str <- globalVar x @@ -1075,7 +1075,7 @@ repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) repE e@(HsOverLabel _) = notHandled "Overloaded labels" (ppr e) repE e@(HsRecFld f) = case f of - Unambiguous _ x -> repE (HsVar x) + Unambiguous _ x -> repE (HsVar (noLoc x)) Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e) -- Remember, we're desugaring renamer output here, so @@ -1456,7 +1456,7 @@ repLP (L _ p) = repP p repP :: Pat Name -> DsM (Core TH.PatQ) repP (WildPat _) = repPwild repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } -repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' } +repP (VarPat (L _ x)) = do { x' <- lookupBinder x; repPvar x' } repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } repP (BangPat p) = do { p1 <- repLP p; repPbang p1 } repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index 98f7f0f051..6bc750e97c 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -116,7 +116,8 @@ selectMatchVar :: Pat Id -> DsM Id selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat) selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat) selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat) -selectMatchVar (VarPat var) = return (localiseId var) -- Note [Localise pattern binders] +selectMatchVar (VarPat var) = return (localiseId (unLoc var)) + -- Note [Localise pattern binders] selectMatchVar (AsPat var _) = return (unLoc var) selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat) -- OK, better make up one... @@ -621,7 +622,7 @@ mkSelectorBinds :: Bool -- ^ is strict -- binds (see Note [Desugar Strict binds] in DsBinds) -- and all the desugared binds -mkSelectorBinds _ ticks (L _ (VarPat v)) val_expr +mkSelectorBinds _ ticks (L _ (VarPat (L _ v))) val_expr = return (Just v ,[(v, case ticks of [t] -> mkOptTickBox t val_expr diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 40b50331e8..28b30c4d5b 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -524,7 +524,7 @@ tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } -tidy1 v (VarPat var) +tidy1 v (VarPat (L _ var)) = return (wrapBind var v, WildPat (idType var)) -- case v of { x@p -> mr[] } diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index c4ad7feaf0..29dd48c86a 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -465,7 +465,7 @@ cvtDerivs cs = do { cs' <- mapM cvt_one cs ; return (Just (noLoc cs')) } where cvt_one c = do { c' <- tconName c - ; returnL $ HsTyVar c' } + ; returnL $ HsTyVar (noLoc c') } cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName))) cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs @@ -641,8 +641,8 @@ cvtClause (Clause ps body wheres) cvtl :: TH.Exp -> CvtM (LHsExpr RdrName) cvtl e = wrapL (cvt e) where - cvt (VarE s) = do { s' <- vName s; return $ HsVar s' } - cvt (ConE s) = do { s' <- cName s; return $ HsVar s' } + cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } + cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') } cvt (LitE l) | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' } | otherwise = do { l' <- cvtLit l; return $ HsLit l' } @@ -717,7 +717,7 @@ cvtl e = wrapL (cvt e) ; flds'<- mapM (cvtFld mkAmbiguousFieldOcc) flds ; return $ mkRdrRecordUpd e' flds' } cvt (StaticE e) = fmap HsStatic $ cvtl e - cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar s' } + cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } {- Note [Dropping constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -930,7 +930,7 @@ cvtp (TH.LitP l) -- Not right for negative patterns; -- need to think about that! | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' } -cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' } +cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat (noLoc s') } cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors] cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] } cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] } @@ -986,7 +986,7 @@ 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 nm' } + ; returnL $ UserTyVar (noLoc nm') } cvt_tv (TH.KindedTV nm ki) = do { nm' <- tName nm ; ki' <- cvtKind ki @@ -1019,22 +1019,26 @@ cvtTypeKind ty_str ty | n == 1 -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) | otherwise - -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys' + -> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Boxed n)))) tys' UnboxedTupleT n | length tys' == n -- Saturated -> if n==1 then return (head tys') -- Singleton tuples treated -- like nothing (ie just parens) else returnL (HsTupleTy HsUnboxedTuple tys') | otherwise - -> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys' + -> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Unboxed n)))) + tys' ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y') - | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys' + | otherwise -> mk_apps (HsTyVar (noLoc (getRdrName funTyCon))) tys' ListT | [x'] <- tys' -> returnL (HsListTy x') - | otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys' - VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' } - ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' } + | otherwise + -> mk_apps (HsTyVar (noLoc (getRdrName listTyCon))) tys' + VarT nm -> do { nm' <- tName nm + ; mk_apps (HsTyVar (noLoc nm')) tys' } + ConT nm -> do { nm' <- tconName nm + ; mk_apps (HsTyVar (noLoc nm')) tys' } ForallT tvs cxt ty | null tys' @@ -1057,13 +1061,14 @@ cvtTypeKind ty_str ty -> mk_apps mkAnonWildCardTy tys' WildCardT (Just nm) - -> do { nm' <- tName nm; mk_apps (mkNamedWildCardTy nm') tys' } + -> do { nm' <- tName nm + ; mk_apps (mkNamedWildCardTy (noLoc nm')) tys' } InfixT t1 s t2 -> do { s' <- tconName s ; t1' <- cvtType t1 ; t2' <- cvtType t2 - ; mk_apps (HsTyVar s') [t1', t2'] + ; mk_apps (HsTyVar (noLoc s')) [t1', t2'] } UInfixT t1 s t2 @@ -1076,7 +1081,8 @@ cvtTypeKind ty_str ty ; returnL $ HsParTy t' } - PromotedT nm -> do { nm' <- cName nm; mk_apps (HsTyVar nm') tys' } + PromotedT nm -> do { nm' <- cName nm + ; mk_apps (HsTyVar (noLoc nm')) tys' } -- Promoted data constructor; hence cName PromotedTupleT n @@ -1097,17 +1103,18 @@ cvtTypeKind ty_str ty | [ty1, L _ (HsExplicitListTy _ tys2)] <- tys' -> returnL (HsExplicitListTy placeHolderKind (ty1:tys2)) | otherwise - -> mk_apps (HsTyVar (getRdrName consDataCon)) tys' + -> mk_apps (HsTyVar (noLoc (getRdrName consDataCon))) tys' StarT - -> returnL (HsTyVar (getRdrName liftedTypeKindTyCon)) + -> returnL (HsTyVar (noLoc (getRdrName liftedTypeKindTyCon))) ConstraintT - -> returnL (HsTyVar (getRdrName constraintKindTyCon)) + -> returnL (HsTyVar (noLoc (getRdrName constraintKindTyCon))) EqualityT | [x',y'] <- tys' -> returnL (HsEqTy x' y') - | otherwise -> mk_apps (HsTyVar (getRdrName eqPrimTyCon)) tys' + | otherwise + -> mk_apps (HsTyVar (noLoc (getRdrName eqPrimTyCon))) tys' _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) } diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index e688d18a08..af38f4b8fb 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -127,7 +127,7 @@ is Less Cool because -- | A Haskell expression. data HsExpr id - = HsVar id -- ^ Variable + = HsVar (Located id) -- ^ Variable | HsUnboundVar OccName -- ^ Unbound variable; also used for "holes" _, or _x. -- Turned from HsVar to HsUnboundVar by the renamer, when @@ -626,7 +626,7 @@ ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc ppr_lexpr e = ppr_expr (unLoc e) ppr_expr :: forall id. OutputableBndr id => HsExpr id -> SDoc -ppr_expr (HsVar v) = pprPrefixOcc v +ppr_expr (HsVar (L _ v)) = pprPrefixOcc v ppr_expr (HsUnboundVar v) = pprPrefixOcc v ppr_expr (HsIPVar v) = ppr v ppr_expr (HsOverLabel l) = char '#' <> ppr l @@ -646,8 +646,8 @@ ppr_expr (HsApp e1 e2) ppr_expr (OpApp e1 op _ e2) = case unLoc op of - HsVar v -> pp_infixly v - _ -> pp_prefixly + HsVar (L _ v) -> pp_infixly v + _ -> pp_prefixly where pp_e1 = pprDebugParendExpr e1 -- In debug mode, add parens pp_e2 = pprDebugParendExpr e2 -- to make precedence clear @@ -662,8 +662,8 @@ ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e ppr_expr (SectionL expr op) = case unLoc op of - HsVar v -> pp_infixly v - _ -> pp_prefixly + HsVar (L _ v) -> pp_infixly v + _ -> pp_prefixly where pp_expr = pprDebugParendExpr expr @@ -673,8 +673,8 @@ ppr_expr (SectionL expr op) ppr_expr (SectionR op expr) = case unLoc op of - HsVar v -> pp_infixly v - _ -> pp_prefixly + HsVar (L _ v) -> pp_infixly v + _ -> pp_prefixly where pp_expr = pprDebugParendExpr expr @@ -802,7 +802,7 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True) ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] -ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) +ppr_expr (HsArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2]) = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] ppr_expr (HsArrForm op _ args) = hang (ptext (sLit "(|") <+> ppr_lexpr op) @@ -1064,7 +1064,7 @@ ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True) ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False) = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] -ppr_cmd (HsCmdArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) +ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2]) = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] ppr_cmd (HsCmdArrForm op _ args) = hang (ptext (sLit "(|") <> ppr_lexpr op) diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 0f47cf6145..6d29ddf84b 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -74,7 +74,7 @@ data Pat id -- The sole reason for a type on a WildPat is to -- support hsPatType :: Pat Id -> Type - | VarPat id -- Variable + | VarPat (Located id) -- Variable | LazyPat (LPat id) -- Lazy pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' @@ -384,7 +384,7 @@ pprParendPat p = getPprStyle $ \ sty -> -- is the pattern inside that matters. Sigh. pprPat :: (OutputableBndr name) => Pat name -> SDoc -pprPat (VarPat var) = pprPatBndr var +pprPat (VarPat (L _ var)) = pprPatBndr var pprPat (WildPat _) = char '_' pprPat (LazyPat pat) = char '~' <> pprParendLPat pat pprPat (BangPat pat) = char '!' <> pprParendLPat pat diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 73f961c84b..e1ea86b3d5 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -225,7 +225,7 @@ instance OutputableBndr HsIPName where -------------------------------------------------- data HsTyVarBndr name = UserTyVar -- no explicit kinding - name + (Located name) | KindedTyVar (Located name) @@ -265,8 +265,9 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation - | HsTyVar name -- Type variable, type constructor, or data constructor - -- see Note [Promotions (HsTyVar)] + | HsTyVar (Located name) + -- Type variable, type constructor, or data constructor + -- see Note [Promotions (HsTyVar)] -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation @@ -426,9 +427,9 @@ mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2 data HsWildCardInfo name - = AnonWildCard (PostRn name Name) + = AnonWildCard (PostRn name (Located Name)) -- A anonymous wild card ('_'). A name is generated during renaming. - | NamedWildCard name + | NamedWildCard (Located name) -- A named wild card ('_a'). deriving (Typeable) deriving instance (DataId name) => Data (HsWildCardInfo name) @@ -726,7 +727,7 @@ hsExplicitTvs _ = [] --------------------- hsTyVarName :: HsTyVarBndr name -> name -hsTyVarName (UserTyVar n) = n +hsTyVarName (UserTyVar (L _ n)) = n hsTyVarName (KindedTyVar (L _ n) _) = n hsLTyVarName :: LHsTyVarBndr name -> name @@ -752,8 +753,8 @@ hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs) 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 n)) - kind + 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 @@ -765,7 +766,7 @@ hsLTyVarBndrsToTypes (HsQTvs { hsq_tvs = tvbs }) = map hsLTyVarBndrToType tvbs mkAnonWildCardTy :: HsType RdrName mkAnonWildCardTy = HsWildCardTy (AnonWildCard PlaceHolder) -mkNamedWildCardTy :: n -> HsType n +mkNamedWildCardTy :: Located n -> HsType n mkNamedWildCardTy = HsWildCardTy . NamedWildCard isAnonWildCard :: HsWildCardInfo name -> Bool @@ -776,8 +777,8 @@ isNamedWildCard :: HsWildCardInfo name -> Bool isNamedWildCard = not . isAnonWildCard wildCardName :: HsWildCardInfo Name -> Name -wildCardName (NamedWildCard n) = n -wildCardName (AnonWildCard n) = n +wildCardName (NamedWildCard (L _ n)) = n +wildCardName (AnonWildCard (L _ n)) = n -- Two wild cards are the same when: they're both named and have the same -- name, or they're both anonymous and have the same location. @@ -785,13 +786,15 @@ sameWildCard :: Eq name => Located (HsWildCardInfo name) -> Located (HsWildCardInfo name) -> Bool sameWildCard (L l1 (AnonWildCard _)) (L l2 (AnonWildCard _)) = l1 == l2 -sameWildCard (L _ (NamedWildCard n1)) (L _ (NamedWildCard n2)) = n1 == n2 +sameWildCard (L _ (NamedWildCard (L _ n1))) + (L _ (NamedWildCard (L _ n2))) = n1 == n2 sameWildCard _ _ = False sameNamedWildCard :: Eq name => Located (HsWildCardInfo name) -> Located (HsWildCardInfo name) -> Bool -sameNamedWildCard (L _ (NamedWildCard n1)) (L _ (NamedWildCard n2)) = n1 == n2 +sameNamedWildCard (L _ (NamedWildCard (L _ n1))) + (L _ (NamedWildCard (L _ n2))) = n1 == n2 sameNamedWildCard _ _ = False splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n]) @@ -806,7 +809,7 @@ splitHsAppTys f as = (f,as) hsTyGetAppHead_maybe :: LHsType n -> Maybe (n, [LHsType n]) hsTyGetAppHead_maybe = go [] where - go tys (L _ (HsTyVar n)) = Just (n, tys) + 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 @@ -854,13 +857,13 @@ splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) splitLHsClassTy_maybe ty = checkl ty [] where - checkl (L l ty) args = case ty of - HsTyVar t -> Just (L l t, args) - HsAppTy l r -> checkl l (r:args) - HsOpTy l (_, tc) r -> checkl (fmap HsTyVar tc) (l:r:args) - HsParTy t -> checkl t args - HsKindSig ty _ -> checkl ty args - _ -> Nothing + 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: @@ -878,7 +881,7 @@ splitHsFunType (L _ (HsFunTy x y)) splitHsFunType orig_ty@(L _ (HsAppTy t1 t2)) = go t1 [t2] where -- Look for (->) t1 t2, possibly with parenthesisation - go (L _ (HsTyVar fn)) tys | fn == funTyConName + go (L _ (HsTyVar (L _ fn))) tys | fn == funTyConName , [t1,t2] <- tys , (args, res) <- splitHsFunType t2 = (t1:args, res) @@ -1010,7 +1013,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp extra tvs ctxt ty) ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty TyConPrec ty ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds -ppr_mono_ty _ (HsTyVar name) = pprPrefixOcc name +ppr_mono_ty _ (HsTyVar (L _ name))= pprPrefixOcc name ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2 ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys) where std_con = case con of diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 259edcaab9..62aabe34fa 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -194,7 +194,7 @@ mkSimpleHsAlt pat expr = mkSimpleMatch [pat] expr nlHsTyApp :: name -> [Type] -> LHsExpr name -nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id)) +nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id))) nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs @@ -299,7 +299,8 @@ mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } --- A useful function for building @OpApps@. The operator is always a -- variable, and we don't know the fixity yet. mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id -mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2 +mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op))) + (error "mkOpApp:fixity") e2 unqualSplice :: RdrName unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) @@ -334,7 +335,7 @@ mkHsStringPrimLit fs ------------- userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)] -- Caller sets location -userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ] +userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ] {- ************************************************************************ @@ -345,13 +346,13 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ] -} nlHsVar :: id -> LHsExpr id -nlHsVar n = noLoc (HsVar n) +nlHsVar n = noLoc (HsVar (noLoc n)) nlHsLit :: HsLit -> LHsExpr id nlHsLit n = noLoc (HsLit n) nlVarPat :: id -> LPat id -nlVarPat n = noLoc (VarPat n) +nlVarPat n = noLoc (VarPat (noLoc n)) nlLitPat :: HsLit -> LPat id nlLitPat l = noLoc (LitPat l) @@ -366,7 +367,7 @@ nlHsApps :: id -> [LHsExpr id] -> LHsExpr id nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs nlHsVarApps :: id -> [id] -> LHsExpr id -nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs)) +nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs)) where mk f a = HsApp (noLoc f) (noLoc a) @@ -427,7 +428,7 @@ nlHsTyVar :: name -> LHsType name nlHsFunTy :: LHsType name -> LHsType name -> LHsType name nlHsAppTy f t = noLoc (HsAppTy f t) -nlHsTyVar x = noLoc (HsTyVar x) +nlHsTyVar x = noLoc (HsTyVar (noLoc x)) nlHsFunTy a b = noLoc (HsFunTy a b) nlHsTyConApp :: name -> [LHsType name] -> LHsType name @@ -781,7 +782,7 @@ collect_lpat :: LPat name -> [name] -> [name] collect_lpat (L _ pat) bndrs = go pat where - go (VarPat var) = var : bndrs + go (VarPat (L _ var)) = var : bndrs go (WildPat _) = bndrs go (LazyPat pat) = collect_lpat pat bndrs go (BangPat pat) = collect_lpat pat bndrs diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs index d9ec5b2912..97a4d7c620 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -17,6 +17,7 @@ import Coercion import {-# SOURCE #-} ConLike (ConLike) import TcEvidence (HsWrapper) import FieldLabel +import SrcLoc (Located) import Data.Data hiding ( Fixity ) import BasicTypes (Fixity) @@ -103,6 +104,7 @@ type DataId id = , Data (PostRn id Fixity) , Data (PostRn id Bool) , Data (PostRn id Name) + , Data (PostRn id (Located Name)) , Data (PostRn id [Name]) -- , Data (PostRn id [id]) , Data (PostRn id id) diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 1ef3ceb8b1..a6c4b397ba 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -1045,7 +1045,8 @@ dynCompileExpr expr = do parsed_expr <- parseExpr expr -- > Data.Dynamic.toDyn expr let loc = getLoc parsed_expr - to_dyn_expr = mkHsApp (L loc . HsVar $ getRdrName toDynName) parsed_expr + to_dyn_expr = mkHsApp (L loc . HsVar . L loc $ getRdrName toDynName) + parsed_expr hval <- compileParsedExpr to_dyn_expr return (unsafeCoerce# hval :: Dynamic) diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index e7618289ee..dac78dfcae 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1658,9 +1658,9 @@ btype :: { LHsType RdrName } | atype { $1 } atype :: { LHsType RdrName } - : ntgtycon { sL1 $1 (HsTyVar (unLoc $1)) } -- Not including unit tuples + : ntgtycon { sL1 $1 (HsTyVar $1) } -- Not including unit tuples | tyvar {% do { nwc <- namedWildCardsEnabled -- (See Note [Unit tuples]) - ; let tv@(Unqual name) = unLoc $1 + ; let tv@(L _ (Unqual name)) = $1 ; return $ if (startsWithUnderscore name && nwc) then (sL1 $1 (mkNamedWildCardTy tv)) else (sL1 $1 (HsTyVar tv)) } } @@ -1692,10 +1692,10 @@ atype :: { LHsType RdrName } | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy $2) [mj AnnOpenPE $1,mj AnnCloseP $3] } | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy $ sL1 $1 $ HsVar $ - mkUnqual varName (getTH_ID_SPLICE $1)) + (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1)))) [mj AnnThIdSplice $1] } -- see Note [Promotion] for the followings - | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar $ unLoc $2) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar $2) [mj AnnSimpleQuote $1,mj AnnName $2] } | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $3) AnnComma (gl $4) >> ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5)) @@ -1703,7 +1703,7 @@ atype :: { LHsType RdrName } | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy placeHolderKind $3) [mj AnnSimpleQuote $1,mos $2,mcs $4] } - | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar $ unLoc $2) + | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar $2) [mj AnnSimpleQuote $1,mj AnnName $2] } -- Two or more [ty, ty, ty] must be a promoted list type, just as @@ -1748,7 +1748,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } | {- empty -} { [] } tv_bndr :: { LHsTyVarBndr RdrName } - : tyvar { sL1 $1 (UserTyVar (unLoc $1)) } + : tyvar { sL1 $1 (UserTyVar $1) } | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar $2 $4)) [mop $1,mu AnnDcolon $3 ,mcp $5] } @@ -1802,16 +1802,16 @@ bkind :: { LHsKind RdrName } | bkind akind { sLL $1 $> $ HsAppTy $1 $2 } akind :: { LHsKind RdrName } - : '*' {% ams (sL1 $1 $ HsTyVar (nameRdrName liftedTypeKindTyConName)) + : '*' {% ams (sL1 $1 $ HsTyVar (sL1 $1 (nameRdrName liftedTypeKindTyConName))) [mu AnnStar $1] } | '(' kind ')' {% ams (sLL $1 $> $ HsParTy $2) [mop $1,mcp $3] } | pkind { $1 } - | tyvar { sL1 $1 $ HsTyVar (unLoc $1) } + | tyvar { sL1 $1 $ HsTyVar $1 } pkind :: { LHsKind RdrName } -- promoted type, see Note [Promotion] - : qtycon { sL1 $1 $ HsTyVar $ unLoc $1 } - | '(' ')' {% ams (sLL $1 $> $ HsTyVar $ getRdrName unitTyCon) + : qtycon { sL1 $1 $ HsTyVar $1 } + | '(' ')' {% ams (sLL $1 $> $ HsTyVar $ (sLL $1 $> $ getRdrName unitTyCon)) [mop $1,mcp $2] } | '(' kind ',' comma_kinds1 ')' {% addAnnotation (gl $2) AnnComma (gl $3) >> @@ -1977,7 +1977,7 @@ deriving :: { Located (Maybe (Located [LHsType RdrName])) } : {- empty -} { noLoc Nothing } | 'deriving' qtycon {% aljs ( let { L loc tv = $2 } in (sLL $1 $> (Just (sLL $1 $> - [L loc (HsTyVar tv)])))) + [L loc (HsTyVar $2)])))) [mj AnnDeriving $1] } | 'deriving' '(' ')' {% aljs (sLL $1 $> (Just (sLL $1 $> []))) [mj AnnDeriving $1,mop $2,mcp $3] } @@ -2024,7 +2024,7 @@ docdecld :: { LDocDecl } decl_no_th :: { LHsDecl RdrName } : sigdecl { $1 } - | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar bang_RDR)) $2) }; + | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) }; pat <- checkPattern empty e; _ <- ams (sLL $1 $> ()) (fst $ unLoc $3); @@ -2281,8 +2281,8 @@ aexp1 :: { LHsExpr RdrName } | aexp2 { $1 } aexp2 :: { LHsExpr RdrName } - : qvar { sL1 $1 (HsVar $! unLoc $1) } - | qcon { sL1 $1 (HsVar $! unLoc $1) } + : qvar { sL1 $1 (HsVar $! $1) } + | qcon { sL1 $1 (HsVar $! $1) } | ipvar { sL1 $1 (HsIPVar $! unLoc $1) } | overloaded_label { sL1 $1 (HsOverLabel $! unLoc $1) } | literal { sL1 $1 (HsLit $! unLoc $1) } @@ -2339,14 +2339,14 @@ aexp2 :: { LHsExpr RdrName } splice_exp :: { LHsExpr RdrName } : TH_ID_SPLICE {% ams (sL1 $1 $ mkHsSpliceE - (sL1 $1 $ HsVar (mkUnqual varName - (getTH_ID_SPLICE $1)))) + (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName + (getTH_ID_SPLICE $1))))) [mj AnnThIdSplice $1] } | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceE $2) [mj AnnOpenPE $1,mj AnnCloseP $3] } | TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkHsSpliceTE - (sL1 $1 $ HsVar (mkUnqual varName - (getTH_ID_TY_SPLICE $1)))) + (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName + (getTH_ID_TY_SPLICE $1))))) [mj AnnThIdTySplice $1] } | '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE $2) [mj AnnOpenPTE $1,mj AnnCloseP $3] } @@ -2621,7 +2621,7 @@ gdpat :: { LGRHS RdrName (LHsExpr RdrName) } pat :: { LPat RdrName } pat : exp {% checkPattern empty $1 } | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR - (sL1 $1 (HsVar bang_RDR)) $2))) + (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) [mj AnnBang $1] } bindpat :: { LPat RdrName } @@ -2629,14 +2629,14 @@ bindpat : exp {% checkPattern (text "Possibly caused by a missing 'do'?") $1 } | '!' aexp {% amms (checkPattern (text "Possibly caused by a missing 'do'?") - (sLL $1 $> (SectionR (sL1 $1 (HsVar bang_RDR)) $2))) + (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) [mj AnnBang $1] } apat :: { LPat RdrName } apat : aexp {% checkPattern empty $1 } | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR - (sL1 $1 (HsVar bang_RDR)) $2))) + (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) [mj AnnBang $1] } apats :: { [LPat RdrName] } @@ -2938,12 +2938,12 @@ varop :: { Located RdrName } ,mj AnnBackquote $3] } qop :: { LHsExpr RdrName } -- used in sections - : qvarop { sL1 $1 $ HsVar (unLoc $1) } - | qconop { sL1 $1 $ HsVar (unLoc $1) } + : qvarop { sL1 $1 $ HsVar $1 } + | qconop { sL1 $1 $ HsVar $1 } qopm :: { LHsExpr RdrName } -- used in sections - : qvaropm { sL1 $1 $ HsVar (unLoc $1) } - | qconop { sL1 $1 $ HsVar (unLoc $1) } + : qvaropm { sL1 $1 $ HsVar $1 } + | qconop { sL1 $1 $ HsVar $1 } qvarop :: { Located RdrName } : qvarsym { $1 } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index ed45c4b05d..7d14f6568d 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -442,9 +442,9 @@ splitCon :: LHsType RdrName splitCon ty = split ty [] where - split (L _ (HsAppTy t u)) ts = split t (u : ts) - split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc - return (data_con, mk_rest ts) + split (L _ (HsAppTy t u)) ts = split t (u : ts) + split (L l (HsTyVar (L _ tc))) ts = do data_con <- tyConToDataCon l tc + return (data_con, mk_rest ts) split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) [] = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts) split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty) @@ -668,10 +668,10 @@ checkTyVars pp_what equals_or_where tc tparms where -- Check that the name space is correct! - chk (L l (HsKindSig (L lv (HsTyVar tv)) k)) + chk (L l (HsKindSig (L lv (HsTyVar (L _ tv))) k)) | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k)) - chk (L l (HsTyVar tv)) - | isRdrTyVar tv = return (L l (UserTyVar tv)) + chk (L l (HsTyVar (L ltv tv))) + | isRdrTyVar tv = return (L l (UserTyVar (L ltv tv))) chk t@(L loc _) = Left (loc, vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t) @@ -719,7 +719,7 @@ checkTyClHdr is_cls ty where goL (L l ty) acc ann = go l ty acc ann - go l (HsTyVar tc) acc ann + go l (HsTyVar (L _ tc)) acc ann | isRdrTc tc = return (L l tc, acc, ann) go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc ann | isRdrTc tc = return (ltc, t1:t2:acc, ann) @@ -769,7 +769,7 @@ checkLPat msg e@(L l _) = checkPat msg l e [] checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName) -checkPat _ loc (L l (HsVar c)) args +checkPat _ loc (L l (HsVar (L _ c))) args | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args))) checkPat msg loc e args -- OK to let this happen even if bang-patterns -- are not enabled, because there is no valid @@ -802,7 +802,7 @@ checkAPat msg loc e0 = do NegApp (L l (HsOverLit pos_lit)) _ -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr)) - SectionR (L lb (HsVar bang)) e -- (! x) + SectionR (L lb (HsVar (L _ bang))) e -- (! x) | bang == bang_RDR -> do { bang_on <- extension bangPatEnabled ; if bang_on then do { e' <- checkLPat msg e @@ -826,7 +826,7 @@ checkAPat msg loc e0 = do return (SigPatIn e (mkHsWithBndrs t')) -- n+k patterns - OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ + OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _ (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}}))) | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR) -> return (mkNPlusKPat (L nloc n) (L lloc lit)) @@ -834,7 +834,7 @@ checkAPat msg loc e0 = do OpApp l op _fix r -> do l <- checkLPat msg l r <- checkLPat msg r case op of - L cl (HsVar c) | isDataOcc (rdrNameOcc c) + L cl (HsVar (L _ c)) | isDataOcc (rdrNameOcc c) -> return (ConPatIn (L cl c) (InfixCon l r)) _ -> patFail msg loc e0 @@ -860,7 +860,7 @@ checkAPat msg loc e0 = do placeHolderPunRhs :: LHsExpr RdrName -- The RHS of a punned record field will be filled in by the renamer -- It's better not to make it an error, in case we want to print it when debugging -placeHolderPunRhs = noLoc (HsVar pun_RDR) +placeHolderPunRhs = noLoc (HsVar (noLoc pun_RDR)) plus_RDR, bang_RDR, pun_RDR :: RdrName plus_RDR = mkUnqual varName (fsLit "+") -- Hack @@ -943,7 +943,7 @@ checkValSig :: LHsExpr RdrName -> LHsType RdrName -> P (Sig RdrName) -checkValSig (L l (HsVar v)) ty +checkValSig (L l (HsVar (L _ v))) ty | isUnqual v && not (isDataOcc (rdrNameOcc v)) = return (TypeSig [L l v] ty PlaceHolder) checkValSig lhs@(L l _) ty @@ -962,9 +962,9 @@ checkValSig lhs@(L l _) ty -- A common error is to forget the ForeignFunctionInterface flag -- so check for that, and suggest. cf Trac #3805 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword - looks_like s (L _ (HsVar v)) = v == s - looks_like s (L _ (HsApp lhs _)) = looks_like s lhs - looks_like _ _ = False + looks_like s (L _ (HsVar (L _ v))) = v == s + looks_like s (L _ (HsApp lhs _)) = looks_like s lhs + looks_like _ _ = False foreign_RDR = mkUnqual varName (fsLit "foreign") default_RDR = mkUnqual varName (fsLit "default") @@ -997,7 +997,7 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr -- not be any OpApps inside the e's splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName]) -- Splits (f ! g a b) into (f, [(! g), a, b]) -splitBang (L _ (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg)) +splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg)) | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns) where l' = combineLocs bang arg1 @@ -1022,7 +1022,7 @@ isFunLhs :: LHsExpr RdrName isFunLhs e = go e [] [] where - go (L loc (HsVar f)) es ann + go (L loc (HsVar (L _ f))) es ann | not (isRdrDataCon f) = return (Just (L loc f, False, es, ann)) go (L _ (HsApp f e)) es ann = go f (e:es) ann go (L l (HsPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) @@ -1040,7 +1040,7 @@ isFunLhs e = go e [] [] -- ToDo: what about this? -- x + 1 `op` y = ... - go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es ann + go e@(L loc (OpApp l (L loc' (HsVar (L _ op))) fix r)) es ann | Just (e',es') <- splitBang e = do { bang_on <- extension bangPatEnabled ; if bang_on then go e' (es' ++ es) ann @@ -1052,9 +1052,9 @@ isFunLhs e = go e [] [] = do { mb_l <- go l es ann ; case mb_l of Just (op', True, j : k : es', ann') - -> return (Just (op', True, j : op_app : es', ann')) - where - op_app = L loc (OpApp k (L loc' (HsVar op)) fix r) + -> return (Just (op', True, j : op_app : es', ann')) + where + op_app = L loc (OpApp k (L loc' (HsVar (L loc' op))) fix r) _ -> return Nothing } go _ _ _ = return Nothing @@ -1190,7 +1190,7 @@ mkRecConstrOrUpdate -> ([LHsRecField RdrName (LHsExpr RdrName)], Bool) -> P (HsExpr RdrName) -mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) +mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd) | isRdrDataCon c = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) mkRecConstrOrUpdate exp@(L l _) _ (fs,dd) diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 13d5b7f41a..0ce8e41039 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -1445,28 +1445,28 @@ lookupIfThenElse ; if not rebindable_on then return (Nothing, emptyFVs) else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse")) - ; return (Just (HsVar ite), unitFV ite) } } + ; return (Just (HsVar (noLoc ite)), unitFV ite) } } lookupSyntaxName :: Name -- The standard name -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name = do { rebindable_on <- xoptM Opt_RebindableSyntax ; if not rebindable_on then - return (HsVar std_name, emptyFVs) + return (HsVar (noLoc std_name), emptyFVs) else -- Get the similarly named thing from the local environment do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name)) - ; return (HsVar usr_name, unitFV usr_name) } } + ; return (HsVar (noLoc usr_name), unitFV usr_name) } } lookupSyntaxNames :: [Name] -- Standard names -> RnM ([HsExpr Name], FreeVars) -- See comments with HsExpr.ReboundNames lookupSyntaxNames std_names = do { rebindable_on <- xoptM Opt_RebindableSyntax ; if not rebindable_on then - return (map HsVar std_names, emptyFVs) + return (map (HsVar . noLoc) std_names, emptyFVs) else do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names - ; return (map HsVar usr_names, mkFVs usr_names) } } + ; return (map (HsVar . noLoc) usr_names, mkFVs usr_names) } } {- ********************************************************* diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index ba48830465..31ef55cbb5 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -73,14 +73,14 @@ rnLExpr = wrapLocFstM rnExpr rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) -finishHsVar :: Name -> RnM (HsExpr Name, FreeVars) +finishHsVar :: Located Name -> RnM (HsExpr Name, FreeVars) -- Separated from rnExpr because it's also used -- when renaming infix expressions -finishHsVar name +finishHsVar (L l name) = do { this_mod <- getModule ; when (nameIsLocalOrFrom this_mod name) $ checkThLocalName name - ; return (HsVar name, unitFV name) } + ; return (HsVar (L l name), unitFV name) } rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars) rnUnboundVar v @@ -92,9 +92,9 @@ rnUnboundVar v else -- Fail immediately (qualified name) do { n <- reportUnboundName v - ; return (HsVar n, emptyFVs) } } + ; return (HsVar (noLoc n), emptyFVs) } } -rnExpr (HsVar v) +rnExpr (HsVar (L l v)) = do { opt_DuplicateRecordFields <- xoptM Opt_DuplicateRecordFields ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v ; case mb_name of { @@ -105,7 +105,7 @@ rnExpr (HsVar v) -> rnExpr (ExplicitList placeHolderType Nothing []) | otherwise - -> finishHsVar name ; + -> finishHsVar (L l name) ; Just (Right [f]) -> return (HsRecFld (ambiguousFieldOcc f) , unitFV (selectorFieldOcc f)) ; Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous v PlaceHolder) @@ -150,8 +150,8 @@ rnExpr (OpApp e1 op _ e2) -- more, so I've removed the test. Adding HsPars in TcGenDeriv -- should prevent bad things happening. ; fixity <- case op' of - L _ (HsVar n) -> lookupFixityRn n - _ -> return (Fixity minPrecedence InfixL) + L _ (HsVar (L _ n)) -> lookupFixityRn n + _ -> return (Fixity minPrecedence InfixL) -- c.f. lookupFixity for unbound ; final_e <- mkOpAppRn e1' op' fixity e2' @@ -425,11 +425,12 @@ rnSection other = pprPanic "rnSection" (ppr other) rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName -> RnM (HsRecordBinds Name, FreeVars) rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd }) - = do { (flds, fvs) <- rnHsRecFields ctxt HsVar rec_binds + = do { (flds, fvs) <- rnHsRecFields ctxt mkHsVar rec_binds ; (flds', fvss) <- mapAndUnzipM rn_field flds ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }, fvs `plusFV` plusFVs fvss) } where + mkHsVar l n = HsVar (L l n) rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } @@ -485,7 +486,7 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl) -- infix form rnCmd (HsCmdArrForm op (Just _) [arg1, arg2]) = do { (op',fv_op) <- escapeArrowScope (rnLExpr op) - ; let L _ (HsVar op_name) = op' + ; let L _ (HsVar (L _ op_name)) = op' ; (arg1',fv_arg1) <- rnCmdTop arg1 ; (arg2',fv_arg2) <- rnCmdTop arg2 -- Deal with fixity @@ -934,7 +935,7 @@ lookupStmtName ctxt n TransStmtCtxt c -> lookupStmtName c n -- the parent context where rebindable = lookupSyntaxName n - not_rebindable = return (HsVar n, emptyFVs) + not_rebindable = return (HsVar (noLoc n), emptyFVs) {- Note [Renaming parallel Stmts] @@ -1645,7 +1646,7 @@ isReturnApp (L _ (HsApp f arg)) | otherwise = Nothing where is_return (L _ (HsPar e)) = is_return e - is_return (L _ (HsVar r)) = r == returnMName + is_return (L _ (HsVar (L _ r))) = r == returnMName -- TODO: I don't know how to get this right for rebindable syntax is_return _ = False isReturnApp _ = Nothing diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 483ea9915e..9aee561a43 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -356,9 +356,9 @@ rnPatAndThen _ (WildPat _) = return (WildPat placeHolderType) rnPatAndThen mk (ParPat pat) = do { pat' <- rnLPatAndThen mk pat; return (ParPat pat') } rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') } rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') } -rnPatAndThen mk (VarPat rdr) = do { loc <- liftCps getSrcSpanM - ; name <- newPatName mk (L loc rdr) - ; return (VarPat name) } +rnPatAndThen mk (VarPat (L l rdr)) = do { loc <- liftCps getSrcSpanM + ; name <- newPatName mk (L loc rdr) + ; return (VarPat (L l name)) } -- we need to bind pattern variables for view pattern expressions -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) @@ -487,10 +487,12 @@ rnHsRecPatsAndThen :: NameMaker -> HsRecFields RdrName (LPat RdrName) -> CpsRn (HsRecFields Name (LPat Name)) rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) - = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) VarPat hs_rec_fields + = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat + hs_rec_fields ; flds' <- mapM rn_field (flds `zip` [1..]) ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } where + mkVarPat l n = VarPat (L l n) rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld) ; return (L l (fld { hsRecFieldArg = arg' })) } @@ -516,7 +518,8 @@ data HsRecFieldContext rnHsRecFields :: forall arg. HsRecFieldContext - -> (RdrName -> arg) -- When punning, use this to build a new field + -> (SrcSpan -> RdrName -> arg) + -- When punning, use this to build a new field -> HsRecFields RdrName (Located arg) -> RnM ([LHsRecField Name (Located arg)], FreeVars) @@ -560,7 +563,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) = do { sel <- setSrcSpan loc $ lookupSubBndrOcc True parent doc lbl ; arg' <- if pun then do { checkErr pun_ok (badPun (L loc lbl)) - ; return (L loc (mk_arg lbl)) } + ; return (L loc (mk_arg loc lbl)) } else return arg ; return (L l (HsRecField { hsRecFieldLbl = L loc (FieldOcc lbl sel) , hsRecFieldArg = arg' @@ -616,7 +619,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) ; addUsedGREs (map thirdOf3 dot_dot_gres) ; return [ L loc (HsRecField { hsRecFieldLbl = L loc (FieldOcc arg_rdr sel) - , hsRecFieldArg = L loc (mk_arg arg_rdr) + , hsRecFieldArg = L loc (mk_arg loc arg_rdr) , hsRecPun = False }) | (lbl, sel, _) <- dot_dot_gres , let arg_rdr = mkVarUnqual lbl ] } @@ -683,7 +686,7 @@ rnHsRecUpdFields flds else fmap Left $ lookupSubBndrOcc True Nothing doc lbl ; arg' <- if pun then do { checkErr pun_ok (badPun (L loc lbl)) - ; return (L loc (HsVar lbl)) } + ; return (L loc (HsVar (L loc lbl))) } else return arg ; (arg'', fvs) <- rnLExpr arg' @@ -777,8 +780,8 @@ rnOverLit origLit ; let std_name = hsOverLitName val ; (from_thing_name, fvs) <- lookupSyntaxName std_name ; let rebindable = case from_thing_name of - HsVar v -> v /= std_name - _ -> panic "rnOverLit" + HsVar (L _ v) -> v /= std_name + _ -> panic "rnOverLit" ; return (lit { ol_witness = from_thing_name , ol_rebindable = rebindable , ol_type = placeHolderType }, fvs) } diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 0bd96ec7d6..61c07ca11d 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -768,7 +768,7 @@ validRuleLhs foralls lhs check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2 check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2 - check (HsVar v) | v `notElem` foralls = Nothing + check (HsVar (L _ v)) | v `notElem` foralls = Nothing check other = Just other -- Failure -- Check an argument diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index b78d4c7aa9..8d570ea3b7 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -338,10 +338,11 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHs -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter q_span quote = L q_span $ HsApp (L q_span $ - HsApp (L q_span (HsVar quote_selector)) quoterExpr) + HsApp (L q_span (HsVar (L q_span quote_selector))) + quoterExpr) quoteExpr where - quoterExpr = L q_span $! HsVar $! quoter + quoterExpr = L q_span $! HsVar $! (L q_span quoter) quoteExpr = L q_span $! HsLit $! HsString "" quote quote_selector = case flavour of UntypedExpSplice -> quoteExpName diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 7fff70312d..27c9fc8e7d 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -144,9 +144,9 @@ rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars rnHsTyKi isType doc ty@HsForAllTy{} = rnHsTyKiForAll isType doc (flattenTopLevelHsForAllTy ty) -rnHsTyKi isType _ (HsTyVar rdr_name) +rnHsTyKi isType _ (HsTyVar (L l rdr_name)) = do { name <- rnTyVar isType rdr_name - ; return (HsTyVar name, unitFV name) } + ; return (HsTyVar (L l name), unitFV name) } -- If we see (forall a . ty), without foralls on, the forall will give -- a sensible error message, but we don't want to complain about the dot too @@ -286,11 +286,11 @@ rnHsTyKi isType _doc (HsWildCardTy (AnonWildCard PlaceHolder)) do { loc <- getSrcSpanM ; uniq <- newUnique ; let name = mkInternalName uniq (mkTyVarOcc "_") loc - ; return (HsWildCardTy (AnonWildCard name), emptyFVs) } + ; return (HsWildCardTy (AnonWildCard (L loc name)), emptyFVs) } -- emptyFVs: this occurrence does not refer to a -- binding, so don't treat it as a free variable -rnHsTyKi isType doc (HsWildCardTy (NamedWildCard rdr_name)) +rnHsTyKi isType doc (HsWildCardTy (NamedWildCard (L l rdr_name))) = ASSERT( isType ) do { not_in_scope <- isNothing `fmap` lookupOccRn_maybe rdr_name ; when not_in_scope $ @@ -300,7 +300,7 @@ rnHsTyKi isType doc (HsWildCardTy (NamedWildCard rdr_name)) failWith $ text "Unexpected wild card:" <+> quotes (ppr rdr_name) $$ docOfHsDocContext doc ; name <- rnTyVar isType rdr_name - ; return (HsWildCardTy (NamedWildCard name), emptyFVs) } + ; return (HsWildCardTy (NamedWildCard (L l name)), emptyFVs) } -- emptyFVs: this occurrence does not refer to a -- binding, so don't treat it as a free variable @@ -469,9 +469,9 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside rnLHsTyVarBndr :: HsDocContext -> Maybe a -> LocalRdrEnv -> LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars) -rnLHsTyVarBndr _ mb_assoc rdr_env (L loc (UserTyVar rdr)) +rnLHsTyVarBndr _ mb_assoc rdr_env (L loc (UserTyVar (L l rdr))) = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr - ; return (L loc (UserTyVar nm), emptyFVs) } + ; return (L loc (UserTyVar (L l nm)), emptyFVs) } rnLHsTyVarBndr doc mb_assoc rdr_env (L loc (KindedTyVar (L lv rdr) kind)) = do { sig_ok <- xoptM Opt_KindSignatures ; unless sig_ok (badSigErr False doc kind) @@ -572,7 +572,7 @@ rnLHsTypeWithWildCards doc ty ; rdr_env <- getLocalRdrEnv -- Filter out named wildcards that are already in scope ; let (_, wcs) = collectWildCards ty - nwcs = [L loc n | L loc (NamedWildCard n) <- wcs + nwcs = [L loc n | L _ (NamedWildCard (L loc n)) <- wcs , not (elemLocalRdrEnv n rdr_env) ] ; bindLocatedLocalsRn nwcs $ \nwcs' -> do { (ty', fvs) <- rnLHsType doc ty @@ -870,7 +870,7 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment get_op :: LHsExpr Name -> Name -- An unbound name could be either HsVar or HsUnboundVar -- See RnExpr.rnUnboundVar -get_op (L _ (HsVar n)) = n +get_op (L _ (HsVar (L _ n))) = n get_op (L _ (HsUnboundVar occ)) = mkUnboundName (mkRdrUnqual occ) get_op other = pprPanic "get_op" (ppr other) @@ -1081,9 +1081,9 @@ opTyErr op ty@(HsOpTy ty1 _ _) | otherwise = ptext (sLit "Use TypeOperators to allow operators in types") - forall_head (L _ (HsTyVar tv)) = tv == forall_tv_RDR - forall_head (L _ (HsAppTy ty _)) = forall_head ty - forall_head _other = False + forall_head (L _ (HsTyVar (L _ tv))) = tv == forall_tv_RDR + forall_head (L _ (HsAppTy ty _)) = forall_head ty + forall_head _other = False opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty) {- @@ -1192,7 +1192,7 @@ extract_lkind kind (acc_kvs, acc_tvs) = case extract_lty kind ([], acc_kvs) of extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars extract_lty (L _ ty) acc = case ty of - HsTyVar tv -> extract_tv tv acc + HsTyVar (L _ tv) -> extract_tv tv acc HsBangTy _ ty -> extract_lty ty acc HsRecTy flds -> foldr (extract_lty . cd_fld_type . unLoc) acc flds diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 84dd3a5da1..05a9208d92 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -111,7 +111,7 @@ newMethodFromName origin name inst_ty ; wrap <- ASSERT( null rest && isSingleton theta ) instCall origin [inst_ty] (substTheta subst theta) - ; return (mkHsWrap wrap (HsVar id)) } + ; return (mkHsWrap wrap (HsVar (noLoc id))) } {- ************************************************************************ @@ -365,7 +365,7 @@ tcSyntaxName :: CtOrigin -- USED ONLY FOR CmdTop (sigh) *** -- See Note [CmdSyntaxTable] in HsExpr -tcSyntaxName orig ty (std_nm, HsVar user_nm) +tcSyntaxName orig ty (std_nm, HsVar (L _ user_nm)) | std_nm == user_nm = do rhs <- newMethodFromName orig std_nm ty return (std_nm, rhs) diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index ccf8202847..f55e643be3 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -1206,9 +1206,9 @@ tcVect :: VectDecl Name -> TcM (VectDecl TcId) tcVect (HsVect s name rhs) = addErrCtxt (vectCtxt name) $ do { var <- wrapLocM tcLookupId name - ; let L rhs_loc (HsVar rhs_var_name) = rhs + ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs ; rhs_id <- tcLookupId rhs_var_name - ; return $ HsVect s var (L rhs_loc (HsVar rhs_id)) + ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id))) } {- OLD CODE: diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 6b0511a465..2f26c646a1 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -151,7 +151,7 @@ tcUnboundId occ res_ty ; let can = CHoleCan { cc_ev = CtWanted ty ev loc, cc_occ = occ , cc_hole = ExprHole } ; emitInsoluble can - ; tcWrapResult (HsVar ev) ty res_ty } + ; tcWrapResult (HsVar (noLoc ev)) ty res_ty } {- ************************************************************************ @@ -165,8 +165,8 @@ tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId) tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e) -tcExpr (HsVar name) res_ty = tcCheckId name res_ty -tcExpr (HsUnboundVar v) res_ty = tcUnboundId v res_ty +tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty +tcExpr (HsUnboundVar v) res_ty = tcUnboundId v res_ty tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty @@ -207,7 +207,8 @@ tcExpr (HsIPVar x) res_ty ; ip_ty <- newFlexiTyVarTy openTypeKind ; let ip_name = mkStrLitTy (hsIPNameFS x) ; ip_var <- emitWanted origin (mkClassPred ipClass [ip_name, ip_ty]) - ; tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar ip_var)) ip_ty res_ty } + ; tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar (noLoc ip_var))) + ip_ty res_ty } where -- Coerces a dictionary for `IP "x" t` into `t`. fromDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $ @@ -222,8 +223,8 @@ tcExpr (HsOverLabel l) res_ty -- See Note [Type-checking overloaded labels] ; loc <- getSrcSpanM ; var <- emitWanted origin pred ; let proxy_arg = L loc (mkHsWrap (mkWpTyApps [typeSymbolKind, lbl]) - (HsVar proxyHashId)) - tm = L loc (fromDict pred (HsVar var)) `HsApp` proxy_arg + (HsVar (L loc proxyHashId))) + tm = L loc (fromDict pred (HsVar (L loc var))) `HsApp` proxy_arg ; tcWrapResult tm alpha res_ty } where -- Coerces a dictionary for `IsLabel "x" t` into `Proxy# x -> t`. @@ -339,17 +340,18 @@ See Note [seqId magic] in MkId, and -} tcExpr (OpApp arg1 op fix arg2) res_ty - | (L loc (HsVar op_name)) <- op + | (L loc (HsVar (L lv op_name))) <- op , op_name `hasKey` seqIdKey -- Note [Typing rule for seq] = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind ; let arg2_ty = res_ty ; arg1' <- tcArg op (arg1, arg1_ty, 1) ; arg2' <- tcArg op (arg2, arg2_ty, 2) ; op_id <- tcLookupId op_name - ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) (HsVar op_id)) + ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) + (HsVar (L lv op_id))) ; return $ OpApp arg1' op' fix arg2' } - | (L loc (HsVar op_name)) <- op + | (L loc (HsVar (L lv op_name))) <- op , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] = do { traceTc "Application rule" (ppr op) ; (arg1', arg1_ty) <- tcInferRho arg1 @@ -378,7 +380,8 @@ tcExpr (OpApp arg1 op fix arg2) res_ty ; co_a <- unifyType arg2_ty a2_ty -- arg2 ~ a2 ; op_id <- tcLookupId op_name - ; let op' = L loc (HsWrap (mkWpTyApps [a2_ty, res_ty]) (HsVar op_id)) + ; let op' = L loc (HsWrap (mkWpTyApps [a2_ty, res_ty]) + (HsVar (L lv op_id))) ; return $ OpApp (mkLHsWrapCo (mkTcFunCo Nominal co_a co_b) $ mkLHsWrapCo co_arg1 arg1') @@ -1008,7 +1011,7 @@ tcApp (L _ (HsPar e)) args res_ty tcApp (L _ (HsApp e1 e2)) args res_ty = tcApp e1 (e2:args) res_ty -- Accumulate the arguments -tcApp (L loc (HsVar fun)) args res_ty +tcApp (L loc (HsVar (L _ fun))) args res_ty | fun `hasKey` tagToEnumKey , [arg] <- args = tcTagToEnum loc fun arg res_ty @@ -1058,7 +1061,7 @@ mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun) ---------------- tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) -- Infer and instantiate the type of a function -tcInferFun (L loc (HsVar name)) +tcInferFun (L loc (HsVar (L _ name))) = do { (fun, ty) <- setSrcSpan loc (tcInferId name) -- Don't wrap a context around a plain Id ; return (L loc fun, ty) } @@ -1116,9 +1119,10 @@ tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId) -- Typecheck a syntax operator, checking that it has the specified type -- The operator is always a variable at this stage (i.e. renamer output) -- This version assumes res_ty is a monotype -tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig (nameRdrName op) op - ; tcWrapResult expr rho res_ty } -tcSyntaxOp _ other _ = pprPanic "tcSyntaxOp" (ppr other) +tcSyntaxOp orig (HsVar (L _ op)) res_ty + = do { (expr, rho) <- tcInferIdWithOrig orig (nameRdrName op) op + ; tcWrapResult expr rho res_ty } +tcSyntaxOp _ other _ = pprPanic "tcSyntaxOp" (ppr other) {- Note [Push result type in] @@ -1157,7 +1161,8 @@ tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId) tcCheckId name res_ty = do { (expr, actual_res_ty) <- tcInferId name ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) - ; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $ + ; addErrCtxtM (funResCtxt False (HsVar (noLoc name)) + actual_res_ty res_ty) $ tcWrapResult expr actual_res_ty res_ty } tcCheckRecSelId :: AmbiguousFieldOcc Name -> TcRhoType -> TcM (HsExpr TcId) @@ -1206,7 +1211,7 @@ tc_infer_assert :: CtOrigin -> TcM (HsExpr TcId, TcRhoType) tc_infer_assert orig = do { assert_error_id <- tcLookupId assertErrorName ; (wrap, id_rho) <- deeplyInstantiate orig (idType assert_error_id) - ; return (mkHsWrap wrap (HsVar assert_error_id), id_rho) + ; return (mkHsWrap wrap (HsVar (noLoc assert_error_id)), id_rho) } tc_infer_id :: CtOrigin -> RdrName -> Name -> TcM (HsExpr TcId, TcRhoType) @@ -1235,7 +1240,7 @@ tc_infer_id orig lbl id_name where inst_normal_id id = do { (wrap, rho) <- deeplyInstantiate orig (idType id) - ; return (mkHsWrap wrap (HsVar id), rho) } + ; return (mkHsWrap wrap (HsVar (noLoc id)), rho) } inst_data_con con -- For data constructors, @@ -1249,7 +1254,7 @@ tc_infer_id orig lbl id_name rho' = substTy subst rho ; wrap <- instCall orig tys' theta' ; addDataConStupidTheta con tys' - ; return (mkHsWrap wrap (HsVar wrap_id), rho') } + ; return (mkHsWrap wrap (HsVar (noLoc wrap_id)), rho') } check_naughty id | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) @@ -1301,7 +1306,7 @@ tcSeq loc fun_name arg1 arg2 res_ty = do { fun <- tcLookupId fun_name ; (arg1', arg1_ty) <- tcInfer (tcMonoExpr arg1) ; arg2' <- tcMonoExpr arg2 res_ty - ; let fun' = L loc (HsWrap ty_args (HsVar fun)) + ; let fun' = L loc (HsWrap ty_args (HsVar (L loc fun))) ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty ; return (HsApp (L loc (HsApp fun' arg1')) arg2') } @@ -1327,7 +1332,7 @@ tcTagToEnum loc fun_name arg res_ty (mk_error ty' doc2) ; arg' <- tcMonoExpr arg intPrimTy - ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun)) + ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc fun))) rep_ty = mkTyConApp rep_tc rep_args ; return (mkHsWrapCoR (mkTcSymCo $ TcCoercion coi) $ HsApp fun' arg') } @@ -1395,7 +1400,7 @@ checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var)) ; lift <- if isStringTy id_ty then do { sid <- tcLookupId THNames.liftStringName -- See Note [Lifting strings] - ; return (HsVar sid) } + ; return (HsVar (noLoc sid)) } else setConstraintVar lie_var $ -- Put the 'lift' constraint into the right LIE diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 00326801f7..0a6ed8c5e5 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -80,7 +80,7 @@ hsLPatType (L _ pat) = hsPatType pat hsPatType :: Pat Id -> Type hsPatType (ParPat pat) = hsLPatType pat hsPatType (WildPat ty) = ty -hsPatType (VarPat var) = idType var +hsPatType (VarPat (L _ var)) = idType var hsPatType (BangPat pat) = hsLPatType pat hsPatType (LazyPat pat) = hsLPatType pat hsPatType (LitPat lit) = hsLitType lit @@ -583,8 +583,8 @@ zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id) zonkLExprs env exprs = mapM (zonkLExpr env) exprs zonkLExpr env expr = wrapLocM (zonkExpr env) expr -zonkExpr env (HsVar id) - = return (HsVar (zonkIdOcc env id)) +zonkExpr env (HsVar (L l id)) + = return (HsVar (L l (zonkIdOcc env id))) zonkExpr _ (HsIPVar id) = return (HsIPVar id) @@ -1073,9 +1073,9 @@ zonk_pat env (WildPat ty) = do { ty' <- zonkTcTypeToType env ty ; return (env, WildPat ty') } -zonk_pat env (VarPat v) +zonk_pat env (VarPat (L l v)) = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv1 env v', VarPat v') } + ; return (extendIdZonkEnv1 env v', VarPat (L l v')) } zonk_pat env (LazyPat pat) = do { (env', pat') <- zonkPat env pat diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 318d7d89b8..46a5fd7518 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -359,7 +359,7 @@ tc_hs_type (HsRecTy _) _ = panic "tc_hs_type: record" -- Unwrapped by co -- signatures) should have been removed by now ---------- Functions and applications -tc_hs_type hs_ty@(HsTyVar name) exp_kind +tc_hs_type hs_ty@(HsTyVar (L _ name)) exp_kind = do { (ty, k) <- tcTyVar name ; checkExpectedKind hs_ty k exp_kind ; return ty } @@ -979,7 +979,7 @@ kcHsTyVarBndrs cusk (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside ; return (gen_kind, stuff) } } where kc_hs_tv :: HsTyVarBndr Name -> TcM (Name, TcKind) - kc_hs_tv (UserTyVar n) + kc_hs_tv (UserTyVar (L _ n)) = do { mb_thing <- tcLookupLcl_maybe n ; kind <- case mb_thing of Just (AThing k) -> return k @@ -1129,7 +1129,7 @@ kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside -- to match the kind variables they mention against the ones -- we've freshly brought into scope kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind) - kc_tv (L _ (UserTyVar n)) exp_k + kc_tv (L _ (UserTyVar (L _ n))) exp_k = return (n, exp_k) kc_tv (L _ (KindedTyVar (L _ n) hs_k)) exp_k = do { k <- tcLHsKind hs_k @@ -1172,7 +1172,7 @@ tcTyClTyVars tycon (HsQTvs { hsq_kvs = hs_kvs, hsq_tvs = hs_tvs }) thing_inside -- e.g. class C a_29 where -- type T b_30 a_29 :: * -- Here the a_29 is shared - tc_hs_tv (L _ (UserTyVar n)) kind + tc_hs_tv (L _ (UserTyVar (L _ n))) kind = return (mkTyVar n kind) tc_hs_tv (L _ (KindedTyVar (L _ n) hs_k)) kind = do { tc_kind <- tcLHsKind hs_k @@ -1565,8 +1565,8 @@ tc_lhs_kind (L span ki) = setSrcSpan span (tc_hs_kind ki) -- The main worker tc_hs_kind :: HsKind Name -> TcM Kind -tc_hs_kind (HsTyVar tc) = tc_kind_var_app tc [] -tc_hs_kind k@(HsAppTy _ _) = tc_kind_app k [] +tc_hs_kind (HsTyVar (L _ tc)) = tc_kind_var_app tc [] +tc_hs_kind k@(HsAppTy _ _) = tc_kind_app k [] tc_hs_kind (HsParTy ki) = tc_lhs_kind ki @@ -1592,11 +1592,11 @@ tc_hs_kind k = pprPanic "tc_hs_kind" (ppr k) -- Special case for kind application tc_kind_app :: HsKind Name -> [LHsKind Name] -> TcM Kind -tc_kind_app (HsAppTy ki1 ki2) kis = tc_kind_app (unLoc ki1) (ki2:kis) -tc_kind_app (HsTyVar tc) kis = do { arg_kis <- mapM tc_lhs_kind kis +tc_kind_app (HsAppTy ki1 ki2) kis = tc_kind_app (unLoc ki1) (ki2:kis) +tc_kind_app (HsTyVar (L _ tc)) kis = do { arg_kis <- mapM tc_lhs_kind kis ; tc_kind_var_app tc arg_kis } -tc_kind_app ki _ = failWithTc (quotes (ppr ki) <+> - ptext (sLit "is not a kind constructor")) +tc_kind_app ki _ = failWithTc (quotes (ppr ki) <+> + ptext (sLit "is not a kind constructor")) tc_kind_var_app :: Name -> [Kind] -> TcM Kind -- Special case for * and Constraint kinds diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 51e00159b1..f810027fab 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -895,7 +895,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) loc = getSrcSpan dfun_id wrapId :: HsWrapper -> id -> HsExpr id -wrapId wrapper id = mkHsWrap wrapper (HsVar id) +wrapId wrapper id = mkHsWrap wrapper (HsVar (noLoc id)) {- Note [Typechecking plan for instance declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1310,7 +1310,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; dm_id <- tcLookupId dm_name ; let dm_inline_prag = idInlinePragma dm_id rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $ - HsVar dm_id + HsVar (noLoc dm_id) -- A method always has a complete type signature, -- hence it is safe to call completeIdSigPolyId diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index c73bf6dda2..bffcfb8596 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -504,10 +504,10 @@ tc_pat :: PatEnv -> TcM (Pat TcId, -- Translated pattern a) -- Result of thing inside -tc_pat penv (VarPat name) pat_ty thing_inside +tc_pat penv (VarPat (L l name)) pat_ty thing_inside = do { (co, id) <- tcPatBndr penv name pat_ty ; res <- tcExtendIdEnv1 name id thing_inside - ; return (mkHsWrapPatCo co (VarPat id) pat_ty, res) } + ; return (mkHsWrapPatCo co (VarPat (L l id)) pat_ty, res) } tc_pat penv (ParPat pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index b27c9e38ff..172fae60b6 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -448,7 +448,7 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name) mk_mg body = mkMatchGroupName Generated [builder_match] where - builder_args = [L loc (VarPat n) | L loc n <- args] + builder_args = [L loc (VarPat (L loc n)) | L loc n <- args] builder_match = mkMatch builder_args body (noLoc EmptyLocalBinds) args = case details of @@ -469,7 +469,7 @@ tcPatSynBuilderOcc :: CtOrigin -> PatSyn -> TcM (HsExpr TcId, TcRhoType) tcPatSynBuilderOcc orig ps | Just (builder_id, add_void_arg) <- builder = do { (wrap, rho) <- deeplyInstantiate orig (idType builder_id) - ; let inst_fun = mkHsWrap wrap (HsVar builder_id) + ; let inst_fun = mkHsWrap wrap (HsVar (noLoc builder_id)) ; if add_void_arg then return ( HsApp (noLoc inst_fun) (nlHsVar voidPrimId) , tcFunResultTy rho ) @@ -601,7 +601,7 @@ tcPatToExpr args = go go (L loc (ConPatIn (L _ con) info)) = do { exprs <- mapM go (hsConPatArgs info) ; return $ L loc $ - foldl (\x y -> HsApp (L loc x) y) (HsVar con) exprs } + foldl (\x y -> HsApp (L loc x) y) (HsVar (L loc con)) exprs } go (L _ (SigPatIn pat _)) = go pat -- See Note [Type signatures and the builder expression] @@ -609,8 +609,8 @@ tcPatToExpr args = go go (L loc p) = fmap (L loc) $ go1 p go1 :: Pat Name -> Maybe (HsExpr Name) - go1 (VarPat var) - | var `elemNameSet` lhsVars = return $ HsVar var + go1 (VarPat (L l var)) + | var `elemNameSet` lhsVars = return $ HsVar (L l var) | otherwise = Nothing go1 (LazyPat pat) = fmap HsPar $ go pat go1 (ParPat pat) = fmap HsPar $ go pat diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index a15fa7c923..e9c351515c 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1304,7 +1304,8 @@ check_main dflags tcg_env explicit_mod_hdr ; res_ty <- newFlexiTyVarTy liftedTypeKind ; main_expr <- addErrCtxt mainCtxt $ - tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty]) + tcMonoExpr (L loc (HsVar (L loc main_name))) + (mkTyConApp ioTyCon [res_ty]) -- See Note [Root-main Id] -- Construct the binding @@ -1617,13 +1618,15 @@ tcUserStmt (L loc (BodyStmt expr _ _ _)) ValBindsOut [(NonRecursive,unitBag the_bind)] [] -- [it <- e] - bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) + bind_stmt = L loc $ BindStmt (L loc (VarPat (L loc fresh_it))) (nlHsApp ghciStep rn_expr) - (HsVar bindIOName) noSyntaxExpr + (HsVar (L loc bindIOName)) + noSyntaxExpr -- [; print it] print_it = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) - (HsVar thenIOName) noSyntaxExpr placeHolderType + (HsVar (L loc thenIOName)) + noSyntaxExpr placeHolderType -- The plans are: -- A. [it <- e; print it] but not if it::() @@ -1691,7 +1694,7 @@ tcUserStmt rdr_stmt@(L loc _) ; return stuff } where print_v = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) - (HsVar thenIOName) noSyntaxExpr + (HsVar (L loc thenIOName)) noSyntaxExpr placeHolderType -- | Typecheck the statements given and then return the results of the @@ -1757,7 +1760,7 @@ getGhciStepIO = do stepTy :: LHsType Name -- Renamed, so needs all binders in place stepTy = noLoc $ HsForAllTy Implicit Nothing - (HsQTvs { hsq_tvs = [noLoc (UserTyVar a_tv)] + (HsQTvs { hsq_tvs = [noLoc (UserTyVar (noLoc a_tv))] , hsq_kvs = [] }) (noLoc []) (nlHsFunTy ghciM ioM) diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 5c85e7d662..e8ad9cc4b7 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -545,7 +545,8 @@ runAnnotation target expr = do -- and hence ensures the appropriate dictionary is bound by const_binds ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] ; let specialised_to_annotation_wrapper_expr - = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id)) + = L loc (HsWrap wrapper + (HsVar (L loc to_annotation_wrapper_id))) ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) } -- Run the appropriately wrapped expression to get the value of diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index c21baf04bd..c773588429 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -1084,7 +1084,8 @@ tc_fam_ty_pats (name, arity, kind) mb_clsinfo substKiWith fam_kvs fam_arg_kinds fam_body -- Treat (anonymous) wild cards as type variables without a name. -- See Note [Wild cards in family instances] - anon_tvs = [L (nameSrcSpan wc) (UserTyVar wc) | wc <- wcs] + anon_tvs = [L (nameSrcSpan wc) + (UserTyVar (L (nameSrcSpan wc) wc)) | wc <- wcs] hs_tvs = HsQTvs { hsq_kvs = kvars , hsq_tvs = anon_tvs ++ userHsTyVarBndrs loc tvars } diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 0d4ec3dc1d..42387dea8b 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -915,12 +915,14 @@ mkOneRecordSelector all_cons idDetails fl alts | is_naughty = [mkSimpleMatch [] unit_rhs] | otherwise = map mk_match cons_w_field ++ deflt mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)] - (L loc (HsVar field_var)) + (L loc (HsVar (L loc field_var))) mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } - rec_field = noLoc (HsRecField { hsRecFieldLbl = L loc (FieldOcc (mkVarUnqual lbl) sel_name) - , hsRecFieldArg = L loc (VarPat field_var) - , hsRecPun = False }) + rec_field = noLoc (HsRecField + { hsRecFieldLbl = L loc (FieldOcc (mkVarUnqual lbl) + sel_name) + , hsRecFieldArg = L loc (VarPat (L loc field_var)) + , hsRecPun = False }) sel_lname = L loc sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc @@ -929,7 +931,8 @@ mkOneRecordSelector all_cons idDetails fl -- mentions this particular record selector deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch [L loc (WildPat placeHolderType)] - (mkHsApp (L loc (HsVar (getName rEC_SEL_ERROR_ID))) + (mkHsApp (L loc (HsVar + (L loc (getName rEC_SEL_ERROR_ID)))) (L loc (HsLit msg_lit)))] -- Do not add a default case unless there are unmatched |