diff options
39 files changed, 292 insertions, 258 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 diff --git a/testsuite/tests/ghc-api/landmines/landmines.stdout b/testsuite/tests/ghc-api/landmines/landmines.stdout index bddb1be992..63070b28e5 100644 --- a/testsuite/tests/ghc-api/landmines/landmines.stdout +++ b/testsuite/tests/ghc-api/landmines/landmines.stdout @@ -1,4 +1,4 @@ -(11,11,7) -(49,45,0) -(13,12,7) -(9,9,7) +(12,12,7) +(66,62,0) +(14,13,7) +(10,10,7) diff --git a/testsuite/tests/quasiquotation/T7918.hs b/testsuite/tests/quasiquotation/T7918.hs index d549671b31..2d4577c963 100644 --- a/testsuite/tests/quasiquotation/T7918.hs +++ b/testsuite/tests/quasiquotation/T7918.hs @@ -29,19 +29,19 @@ traverse a = gmapM traverse a where showVar :: Maybe (HsExpr Id) -> Traverse () - showVar (Just (HsVar v)) = + showVar (Just (HsVar (L _ v))) = modify $ \(loc, ids) -> (loc, (varName v, loc) : ids) showVar _ = return () showTyVar :: Maybe (HsType Name) -> Traverse () - showTyVar (Just (HsTyVar v)) = + showTyVar (Just (HsTyVar (L _ v))) = modify $ \(loc, ids) -> (loc, (v, loc) : ids) showTyVar _ = return () showPatVar :: Maybe (Pat Id) -> Traverse () - showPatVar (Just (VarPat v)) = + showPatVar (Just (VarPat (L _ v))) = modify $ \(loc, ids) -> (loc, (varName v, loc) : ids) showPatVar _ = return () diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index cfc795601d..7bbec3065d 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -289,7 +289,7 @@ boundThings modname lbinding = lid id = FoundThing modname (getOccString id) loc in case unLoc lpat of WildPat _ -> tl - VarPat name -> lid name : tl + VarPat (L _ name) -> lid name : tl LazyPat p -> patThings p tl AsPat id p -> patThings p (thing id : tl) ParPat p -> patThings p tl diff --git a/utils/haddock b/utils/haddock -Subproject e763c004c8eb067ed0ef510fda9cb4ab102ea6a +Subproject fcd1bb7177a800f6f56a623c2468fc46a59c527 |