Commit d8ed20c8 authored by Alan Zimmerman's avatar Alan Zimmerman

Add Location to RdrName in FieldOcc

Summary:
Post #11019, there have been some new instances of RdrName that are not
located, in particular

```#!hs
data FieldOcc name = FieldOcc { rdrNameFieldOcc  :: RdrName
                              , selectorFieldOcc :: PostRn name name
                              }

data AmbiguousFieldOcc name
  = Unambiguous RdrName (PostRn name name)
  | Ambiguous   RdrName (PostTc name name)
  deriving (Typeable)
```
Add locations to them

Updates haddock submodule to match

Test Plan: ./validate

Reviewers: goldfire, hvr, bgamari, austin

Reviewed By: hvr

Subscribers: hvr, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D1670

GHC Trac Issues: #11258
parent 850710ab
......@@ -475,9 +475,11 @@ cvt_arg (Unpacked, ty)
cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName)
cvt_id_arg (i, str, ty)
= do { i' <- vNameL i
= do { L li i' <- vNameL i
; ty' <- cvt_arg (str,ty)
; return $ noLoc (ConDeclField { cd_fld_names = [fmap (flip FieldOcc PlaceHolder) i']
; return $ noLoc (ConDeclField
{ cd_fld_names
= [L li $ FieldOcc (L li i') PlaceHolder]
, cd_fld_type = ty'
, cd_fld_doc = Nothing}) }
......@@ -737,10 +739,12 @@ cvtl e = wrapL (cvt e)
cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
; return $ ExprWithTySig e' (mkLHsSigWcType t') }
cvt (RecConE c flds) = do { c' <- cNameL c
; flds' <- mapM (cvtFld mkFieldOcc) flds
; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
cvt (RecUpdE e flds) = do { e' <- cvtl e
; flds'<- mapM (cvtFld mkAmbiguousFieldOcc) flds
; flds'
<- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
flds
; return $ mkRdrRecordUpd e' flds' }
cvt (StaticE e) = fmap HsStatic $ cvtl e
cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
......@@ -984,8 +988,9 @@ cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName))
cvtPatFld (s,p)
= do { s' <- vNameL s; p' <- cvtPat p
; return (noLoc $ HsRecField { hsRecFieldLbl = fmap mkFieldOcc s'
= do { L ls s' <- vNameL s; p' <- cvtPat p
; return (noLoc $ HsRecField { hsRecFieldLbl
= L ls $ mkFieldOcc (L ls s')
, hsRecFieldArg = p'
, hsRecPun = False}) }
......
......@@ -675,7 +675,8 @@ type LFieldOcc name = Located (FieldOcc name)
-- | Represents an *occurrence* of an unambiguous field. We store
-- both the 'RdrName' the user originally wrote, and after the
-- renamer, the selector function.
data FieldOcc name = FieldOcc { rdrNameFieldOcc :: RdrName
data FieldOcc name = FieldOcc { rdrNameFieldOcc :: Located RdrName
-- ^ See Note [Located RdrNames] in HsExpr
, selectorFieldOcc :: PostRn name name
}
deriving Typeable
......@@ -686,7 +687,7 @@ deriving instance (Data name, Data (PostRn name name)) => Data (FieldOcc name)
instance Outputable (FieldOcc name) where
ppr = ppr . rdrNameFieldOcc
mkFieldOcc :: RdrName -> FieldOcc RdrName
mkFieldOcc :: Located RdrName -> FieldOcc RdrName
mkFieldOcc rdr = FieldOcc rdr PlaceHolder
......@@ -699,9 +700,10 @@ mkFieldOcc rdr = FieldOcc rdr PlaceHolder
--
-- See Note [HsRecField and HsRecUpdField] in HsPat and
-- Note [Disambiguating record fields] in TcExpr.
-- See Note [Located RdrNames] in HsExpr
data AmbiguousFieldOcc name
= Unambiguous RdrName (PostRn name name)
| Ambiguous RdrName (PostTc name name)
= Unambiguous (Located RdrName) (PostRn name name)
| Ambiguous (Located RdrName) (PostTc name name)
deriving (Typeable)
deriving instance ( Data name
, Data (PostRn name name)
......@@ -715,12 +717,12 @@ instance OutputableBndr (AmbiguousFieldOcc name) where
pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc
pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc
mkAmbiguousFieldOcc :: RdrName -> AmbiguousFieldOcc RdrName
mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc RdrName
mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder
rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc name -> RdrName
rdrNameAmbiguousFieldOcc (Unambiguous rdr _) = rdr
rdrNameAmbiguousFieldOcc (Ambiguous rdr _) = rdr
rdrNameAmbiguousFieldOcc (Unambiguous (L _ rdr) _) = rdr
rdrNameAmbiguousFieldOcc (Ambiguous (L _ rdr) _) = rdr
selectorAmbiguousFieldOcc :: AmbiguousFieldOcc Id -> Id
selectorAmbiguousFieldOcc (Unambiguous _ sel) = sel
......
......@@ -981,7 +981,7 @@ hsConDeclsBinders cons = go id cons
where r' = remSeen (concatMap (cd_fld_names . unLoc) flds)
remSeen' = foldr (.) remSeen
[deleteBy ((==) `on`
rdrNameFieldOcc . unLoc) v
unLoc . rdrNameFieldOcc . unLoc) v
| v <- r']
(ns, fs) = go remSeen' rs
......@@ -990,7 +990,10 @@ hsConDeclsBinders cons = go id cons
([L loc (unLoc name)] ++ ns, r' ++ fs)
where r' = remSeen (concatMap (cd_fld_names . unLoc)
(unLoc flds))
remSeen' = foldr (.) remSeen [deleteBy ((==) `on` rdrNameFieldOcc . unLoc) v | v <- r']
remSeen'
= foldr (.) remSeen
[deleteBy ((==) `on`
unLoc . rdrNameFieldOcc . unLoc) v | v <- r']
(ns, fs) = go remSeen' rs
L loc (ConDeclH98 { con_name = name }) ->
([L loc (unLoc name)] ++ ns, fs)
......
......@@ -1948,7 +1948,7 @@ fielddecl :: { LConDeclField RdrName }
-- A list because of f,g :: Int
: maybe_docnext sig_vars '::' ctype maybe_docprev
{% ams (L (comb2 $2 $4)
(ConDeclField (reverse (map (fmap (flip FieldOcc PlaceHolder)) (unLoc $2))) $4 ($1 `mplus` $5)))
(ConDeclField (reverse (map (\ln@(L l n) -> L l $ FieldOcc ln PlaceHolder) (unLoc $2))) $4 ($1 `mplus` $5)))
[mu AnnDcolon $3] }
-- The outer Located is just to allow the caller to
......@@ -2701,13 +2701,13 @@ fbinds1 :: { ([AddAnn],([LHsRecField RdrName (LHsExpr RdrName)], Bool)) }
| '..' { ([mj AnnDotdot $1],([], True)) }
fbind :: { LHsRecField RdrName (LHsExpr RdrName) }
: qvar '=' texp {% ams (sLL $1 $> $ HsRecField (fmap mkFieldOcc $1) $3 False)
: qvar '=' texp {% ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False)
[mj AnnEqual $2] }
-- RHS is a 'texp', allowing view patterns (Trac #6038)
-- and, incidentaly, sections. Eg
-- f (R { x = show -> s }) = ...
| qvar { sLL $1 $> $ HsRecField (fmap mkFieldOcc $1) placeHolderPunRhs True }
| qvar { sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) placeHolderPunRhs True }
-- In the punning case, use a place-holder
-- The renamer fills in the final value
......
......@@ -912,8 +912,10 @@ lookupGlobalOccRn_overloaded overload_ok rdr_name
[] -> return Nothing
[gre] | isRecFldGRE gre
-> do { addUsedGRE True gre
; let fld_occ :: FieldOcc Name
fld_occ = FieldOcc rdr_name (gre_name gre)
; let
fld_occ :: FieldOcc Name
fld_occ
= FieldOcc (noLoc rdr_name) (gre_name gre)
; return (Just (Right [fld_occ])) }
| otherwise
-> do { addUsedGRE True gre
......@@ -921,7 +923,10 @@ lookupGlobalOccRn_overloaded overload_ok rdr_name
gres | all isRecFldGRE gres && overload_ok
-- Don't record usage for ambiguous selectors
-- until we know which is meant
-> return (Just (Right (map (FieldOcc rdr_name . gre_name) gres)))
-> return
(Just (Right
(map (FieldOcc (noLoc rdr_name) . gre_name)
gres)))
gres -> do { addNameClashErrRn rdr_name gres
; return (Just (Left (gre_name (head gres)))) } }
......@@ -1452,8 +1457,9 @@ lookupTyFixityRn (L _ n) = lookupFixityRn n
-- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are
-- multiple possible selectors with different fixities, generate an error.
lookupFieldFixityRn :: AmbiguousFieldOcc Name -> RnM Fixity
lookupFieldFixityRn (Unambiguous rdr n) = lookupFixityRn' n (rdrNameOcc rdr)
lookupFieldFixityRn (Ambiguous rdr _) = get_ambiguous_fixity rdr
lookupFieldFixityRn (Unambiguous (L _ rdr) n)
= lookupFixityRn' n (rdrNameOcc rdr)
lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr
where
get_ambiguous_fixity :: RdrName -> RnM Fixity
get_ambiguous_fixity rdr_name = do
......
......@@ -109,7 +109,8 @@ rnExpr (HsVar (L l v))
-> finishHsVar (L l name) ;
Just (Right [f]) -> return (HsRecFld (ambiguousFieldOcc f)
, unitFV (selectorFieldOcc f)) ;
Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous v PlaceHolder)
Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous (L l v)
PlaceHolder)
, mkFVs (map selectorFieldOcc fs));
Just (Right []) -> error "runExpr/HsVar" } }
......
......@@ -638,7 +638,7 @@ getLocalNonValBinders fixity_env
find (\ n -> nameOccName n == rdrNameOcc rdr) names
find_con_decl_flds (L _ x)
= map find_con_decl_fld (cd_fld_names x)
find_con_decl_fld (L _ (FieldOcc rdr _))
find_con_decl_fld (L _ (FieldOcc (L _ rdr) _))
= expectJust "getLocalNonValBinders/find_con_decl_fld" $
find (\ fl -> flLabel fl == lbl) flds
where lbl = occNameFS (rdrNameOcc rdr)
......@@ -680,7 +680,7 @@ getLocalNonValBinders fixity_env
newRecordSelector :: Bool -> [Name] -> LFieldOcc RdrName -> RnM FieldLabel
newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"
newRecordSelector overload_ok (dc:_) (L loc (FieldOcc fld _)) =
newRecordSelector overload_ok (dc:_) (L loc (FieldOcc (L _ fld) _)) =
do { sel_name <- newTopSrcBinder $ L loc $ mkRdrUnqual sel_occ
; return $ fl { flSelector = sel_name } }
where
......
......@@ -556,7 +556,8 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
rn_fld :: Bool -> Maybe Name -> LHsRecField RdrName (Located arg)
-> RnM (LHsRecField Name (Located arg))
rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl = L loc (FieldOcc lbl _)
rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl
= L loc (FieldOcc (L ll lbl) _)
, hsRecFieldArg = arg
, hsRecPun = pun }))
= do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl
......@@ -564,7 +565,8 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
then do { checkErr pun_ok (badPun (L loc lbl))
; return (L loc (mk_arg loc lbl)) }
else return arg
; return (L l (HsRecField { hsRecFieldLbl = L loc (FieldOcc lbl sel)
; return (L l (HsRecField { hsRecFieldLbl
= L loc (FieldOcc (L ll lbl) sel)
, hsRecFieldArg = arg'
, hsRecPun = pun })) }
......@@ -617,7 +619,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; addUsedGREs (map thdOf3 dot_dot_gres)
; return [ L loc (HsRecField
{ hsRecFieldLbl = L loc (FieldOcc arg_rdr sel)
{ hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel)
, hsRecFieldArg = L loc (mk_arg loc arg_rdr)
, hsRecPun = False })
| (lbl, sel, _) <- dot_dot_gres
......@@ -694,9 +696,11 @@ rnHsRecUpdFields flds
Right [FieldOcc _ sel_name] -> fvs `addOneFV` sel_name
Right _ -> fvs
lbl' = case sel of
Left sel_name -> L loc (Unambiguous lbl sel_name)
Right [FieldOcc lbl sel_name] -> L loc (Unambiguous lbl sel_name)
Right _ -> L loc (Ambiguous lbl PlaceHolder)
Left sel_name ->
L loc (Unambiguous (L loc lbl) sel_name)
Right [FieldOcc lbl sel_name] ->
L loc (Unambiguous lbl sel_name)
Right _ -> L loc (Ambiguous (L loc lbl) PlaceHolder)
; return (L l (HsRecField { hsRecFieldLbl = lbl'
, hsRecFieldArg = arg''
......@@ -714,7 +718,8 @@ getFieldIds :: [LHsRecField Name arg] -> [Name]
getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds
getFieldLbls :: [LHsRecField id arg] -> [RdrName]
getFieldLbls flds = map (rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
getFieldLbls flds
= map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
getFieldUpdLbls :: [LHsRecUpdField id] -> [RdrName]
getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
......
......@@ -1695,7 +1695,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
bnd_name <- newTopSrcBinder (L bind_loc n)
let rnames = map recordPatSynSelectorId as
mkFieldOcc :: Located RdrName -> LFieldOcc RdrName
mkFieldOcc (L l name) = L l (FieldOcc name PlaceHolder)
mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder)
field_occs = map mkFieldOcc rnames
flds <- mapM (newRecordSelector False [bnd_name]) field_occs
return ((bnd_name, flds): names)
......
......@@ -975,7 +975,7 @@ rnField fl_env doc (L l (ConDeclField names ty haddock_doc))
; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
where
lookupField :: FieldOcc RdrName -> FieldOcc Name
lookupField (FieldOcc rdr _) = FieldOcc rdr (flSelector fl)
lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl)
where
lbl = occNameFS $ rdrNameOcc rdr
fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
......
......@@ -1261,7 +1261,7 @@ tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType)
tcInferId n = tcInferIdWithOrig (OccurrenceOf n) (nameRdrName n) n
tcInferRecSelId :: AmbiguousFieldOcc Name -> TcM (HsExpr TcId, TcRhoType)
tcInferRecSelId (Unambiguous lbl sel)
tcInferRecSelId (Unambiguous (L _ lbl) sel)
= tcInferIdWithOrig (OccurrenceOfRecSel lbl) lbl sel
tcInferRecSelId (Ambiguous lbl _)
= ambiguousSelector lbl
......@@ -1643,11 +1643,11 @@ See also Note [HsRecField and HsRecUpdField] in HsPat.
-- Given a RdrName that refers to multiple record fields, and the type
-- of its argument, try to determine the name of the selector that is
-- meant.
disambiguateSelector :: RdrName -> Type -> RnM Name
disambiguateSelector rdr parent_type
disambiguateSelector :: Located RdrName -> Type -> RnM Name
disambiguateSelector lr@(L _ rdr) parent_type
= do { fam_inst_envs <- tcGetFamInstEnvs
; case tyConOf fam_inst_envs parent_type of
Nothing -> ambiguousSelector rdr
Nothing -> ambiguousSelector lr
Just p ->
do { xs <- lookupParents rdr
; let parent = RecSelData p
......@@ -1658,8 +1658,8 @@ disambiguateSelector rdr parent_type
-- This field name really is ambiguous, so add a suitable "ambiguous
-- occurrence" error, then give up.
ambiguousSelector :: RdrName -> RnM a
ambiguousSelector rdr
ambiguousSelector :: Located RdrName -> RnM a
ambiguousSelector (L _ rdr)
= do { env <- getGlobalRdrEnv
; let gres = lookupGRE_RdrName rdr env
; setErrCtxt [] $ addNameClashErrRn rdr gres
......@@ -1757,7 +1757,8 @@ disambiguateRecordBinds record_expr record_tau rbnds res_ty
= do { i <- tcLookupId n
; let L loc af = hsRecFieldLbl upd
lbl = rdrNameAmbiguousFieldOcc af
; return $ L l upd { hsRecFieldLbl = L loc (Unambiguous lbl i) } }
; return $ L l upd { hsRecFieldLbl
= L loc (Unambiguous (L loc lbl) i) } }
-- Extract the outermost TyCon of a type, if there is one; for
......@@ -1851,11 +1852,15 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
, hsRecFieldArg = rhs }))
= do { let lbl = rdrNameAmbiguousFieldOcc af
sel_id = selectorAmbiguousFieldOcc af
f = L loc (FieldOcc lbl (idName sel_id))
f = L loc (FieldOcc (L loc lbl) (idName sel_id))
; mb <- tcRecordField con_like flds_w_tys f rhs
; case mb of
Nothing -> return Nothing
Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = L loc (Unambiguous lbl (selectorFieldOcc (unLoc f')))
Just (f', rhs') ->
return (Just
(L l (fld { hsRecFieldLbl
= L loc (Unambiguous (L loc lbl)
(selectorFieldOcc (unLoc f')))
, hsRecFieldArg = rhs' }))) }
tcRecordField :: ConLike -> Assoc FieldLabelString Type -> LFieldOcc Name -> LHsExpr Name
......@@ -1876,7 +1881,7 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs
= do { addErrTc (badFieldCon con_like field_lbl)
; return Nothing }
where
field_lbl = occNameFS $ rdrNameOcc lbl
field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
checkMissingFields :: ConLike -> HsRecordBinds Name -> TcM ()
......
......@@ -878,11 +878,13 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
where
tc_field :: Checker (LHsRecField Name (LPat Name))
(LHsRecField TcId (LPat TcId))
tc_field (L l (HsRecField (L loc (FieldOcc rdr sel)) pat pun)) penv thing_inside
tc_field (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel)) pat pun)) penv
thing_inside
= do { sel' <- tcLookupId sel
; pat_ty <- setSrcSpan loc $ find_field_ty (occNameFS $ rdrNameOcc rdr)
; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
; return (L l (HsRecField (L loc (FieldOcc rdr sel')) pat' pun), res) }
; return (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel')) pat'
pun), res) }
find_field_ty :: FieldLabelString -> TcM TcType
find_field_ty lbl
......
......@@ -973,8 +973,8 @@ mkOneRecordSelector all_cons idDetails fl
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)
{ hsRecFieldLbl
= L loc (FieldOcc (L loc $ mkVarUnqual lbl) sel_name)
, hsRecFieldArg = L loc (VarPat (L loc field_var))
, hsRecPun = False })
sel_lname = L loc sel_name
......
Subproject commit fa03f80d76f1511a811a0209ea7a6a8b6c58704f
Subproject commit 105869f209f49721794e3ff5e35822178db72895
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment