ApiAnnotations: Make all RdrName occurences Located
authorAlan Zimmerman <alan.zimm@gmail.com>
Sun, 22 Nov 2015 22:41:57 +0000 (23:41 +0100)
committerBen Gamari <ben@smart-cactus.org>
Sun, 22 Nov 2015 23:07:43 +0000 (00:07 +0100)
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

39 files changed:
compiler/deSugar/Check.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsGRHSs.hs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsUtils.hs
compiler/deSugar/Match.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/hsSyn/PlaceHolder.hs
compiler/main/InteractiveEval.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnEnv.hs
compiler/rename/RnExpr.hs
compiler/rename/RnPat.hs
compiler/rename/RnSource.hs
compiler/rename/RnSplice.hs
compiler/rename/RnTypes.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcTyDecls.hs
testsuite/tests/ghc-api/landmines/landmines.stdout
testsuite/tests/quasiquotation/T7918.hs
utils/ghctags/Main.hs
utils/haddock

index 0417bdd..54a934d 100644 (file)
@@ -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
index 95c70aa..18de4c4 100644 (file)
@@ -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
index 14c38b0..3d592b1 100644 (file)
@@ -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
index 13e7e11..7100e0b 100644 (file)
@@ -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 =
index 3eafd12..c5217f1 100644 (file)
@@ -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
index 0b9906f..df452ea 100644 (file)
@@ -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 }
index 98f7f0f..6bc750e 100644 (file)
@@ -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
index 40b5033..28b30c4 100644 (file)
@@ -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[] }
index c4ad7fe..29dd48c 100644 (file)
@@ -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))
     }
index e688d18..af38f4b 100644 (file)
@@ -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)
index 0f47cf6..6d29ddf 100644 (file)
@@ -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
index 73f961c..e1ea86b 100644 (file)
@@ -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
index 259edca..62aabe3 100644 (file)
@@ -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
index d9ec5b2..97a4d7c 100644 (file)
@@ -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)
index 1ef3ceb..a6c4b39 100644 (file)
@@ -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)
 
index e761828..dac78df 100644 (file)
@@ -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 }
index ed45c4b..7d14f65 100644 (file)
@@ -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)
index 13d5b7f..0ce8e41 100644 (file)
@@ -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) } }
 
 {-
 *********************************************************
index ba48830..31ef55c 100644 (file)
@@ -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
index 483ea99..9aee561 100644 (file)
@@ -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) }
index 0bd96ec..61c07ca 100644 (file)
@@ -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
index b78d4c7..8d570ea 100644 (file)
@@ -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
index 7fff703..27c9fc8 100644 (file)
@@ -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
index 84dd3a5..05a9208 100644 (file)
@@ -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)
index ccf8202..f55e643 100644 (file)
@@ -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:
index 6b0511a..2f26c64 100644 (file)
@@ -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
index 0032680..0a6ed8c 100644 (file)
@@ -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
index 318d7d8..46a5fd7 100644 (file)
@@ -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
index 51e0015..f810027 100644 (file)
@@ -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
index c73bf6d..bffcfb8 100644 (file)
@@ -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
index b27c9e3..172fae6 100644 (file)
@@ -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
index a15fa7c..e9c3515 100644 (file)
@@ -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)
index 5c85e7d..e8ad9cc 100644 (file)
@@ -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
index c21baf0..c773588 100644 (file)
@@ -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 }
 
index 0d4ec3d..42387de 100644 (file)
@@ -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
index d549671..2d4577c 100644 (file)
@@ -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 ()
index cfc7956..7bbec30 100644 (file)
@@ -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
index e763c00..fcd1bb7 160000 (submodule)
@@ -1 +1 @@
-Subproject commit e763c004c8eb067ed0ef510fda9cb4ab102ea6ae
+Subproject commit fcd1bb7177a800f6f56a623c2468fc46a59c527b