summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/hsSyn/HsExpr.hs1
-rw-r--r--compiler/hsSyn/HsTypes.hs4
-rw-r--r--compiler/main/HscTypes.hs12
-rw-r--r--compiler/rename/RnEnv.hs59
-rw-r--r--compiler/rename/RnExpr.hs7
-rw-r--r--compiler/rename/RnNames.hs11
-rw-r--r--compiler/rename/RnSource.hs4
-rw-r--r--compiler/typecheck/TcExpr.hs16
8 files changed, 88 insertions, 26 deletions
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index b15e4304f4..c5afa7410f 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -650,6 +650,7 @@ ppr_expr (HsApp e1 e2)
ppr_expr (OpApp e1 op _ e2)
= case unLoc op of
HsVar (L _ v) -> pp_infixly v
+ HsRecFld f -> pp_infixly f
_ -> pp_prefixly
where
pp_e1 = pprDebugParendExpr e1 -- In debug mode, add parens
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 5546a91843..8bcdc6aac1 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -723,6 +723,10 @@ deriving instance ( Data name
instance Outputable (AmbiguousFieldOcc name) where
ppr = ppr . rdrNameAmbiguousFieldOcc
+instance OutputableBndr (AmbiguousFieldOcc name) where
+ pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc
+ pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc
+
mkAmbiguousFieldOcc :: RdrName -> AmbiguousFieldOcc RdrName
mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index b5abdf4374..3ffffa1f3b 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -807,8 +807,10 @@ data ModIface
-- Cached environments for easy lookup
-- These are computed (lazily) from other fields
-- and are not put into the interface file
- mi_warn_fn :: Name -> Maybe WarningTxt, -- ^ Cached lookup for 'mi_warns'
- mi_fix_fn :: OccName -> Fixity, -- ^ Cached lookup for 'mi_fixities'
+ mi_warn_fn :: OccName -> Maybe WarningTxt,
+ -- ^ Cached lookup for 'mi_warns'
+ mi_fix_fn :: OccName -> Fixity,
+ -- ^ Cached lookup for 'mi_fixities'
mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint),
-- ^ Cached lookup for 'mi_decls'.
-- The @Nothing@ in 'mi_hash_fn' means that the thing
@@ -2008,12 +2010,12 @@ instance Binary Warnings where
return (WarnSome aa)
-- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'
-mkIfaceWarnCache :: Warnings -> Name -> Maybe WarningTxt
+mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt
mkIfaceWarnCache NoWarnings = \_ -> Nothing
mkIfaceWarnCache (WarnAll t) = \_ -> Just t
-mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName
+mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs)
-emptyIfaceWarnCache :: Name -> Maybe WarningTxt
+emptyIfaceWarnCache :: OccName -> Maybe WarningTxt
emptyIfaceWarnCache _ = Nothing
plusWarns :: Warnings -> Warnings -> Warnings
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 42a159f3d4..7466381cd5 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -21,7 +21,7 @@ module RnEnv (
HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
lookupSigCtxtOccRn,
- lookupFixityRn, lookupTyFixityRn,
+ lookupFixityRn, lookupFieldFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName,
lookupConstructorFields,
lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse,
@@ -1043,10 +1043,10 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })
lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt
lookupImpDeprec iface gre
- = mi_warn_fn iface (gre_name gre) `mplus` -- Bleat if the thing,
+ = mi_warn_fn iface (greOccName gre) `mplus` -- Bleat if the thing,
case gre_par gre of -- or its parent, is warn'd
- ParentIs p -> mi_warn_fn iface p
- FldParent { par_is = p } -> mi_warn_fn iface p
+ ParentIs p -> mi_warn_fn iface (nameOccName p)
+ FldParent { par_is = p } -> mi_warn_fn iface (nameOccName p)
NoParent -> Nothing
PatternSynonym -> Nothing
@@ -1259,7 +1259,7 @@ lookupBindGroupOcc ctxt what rdr_name
---------------
-lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [Name]
+lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)]
-- GHC extension: look up both the tycon and data con or variable.
-- Used for top-level fixity signatures and deprecations.
-- Complain if neither is in scope.
@@ -1270,7 +1270,8 @@ lookupLocalTcNames ctxt what rdr_name
; when (null names) $ addErr (head errs) -- Bleat about one only
; return names }
where
- lookup = lookupBindGroupOcc ctxt what
+ lookup rdr = do { name <- lookupBindGroupOcc ctxt what rdr
+ ; return (fmap ((,) rdr) name) }
dataTcOccs :: RdrName -> [RdrName]
-- Return both the given name and the same name promoted to the TcClsName
@@ -1373,7 +1374,10 @@ lookupFixity is a bit strange.
-}
lookupFixityRn :: Name -> RnM Fixity
-lookupFixityRn name
+lookupFixityRn name = lookupFixityRn' name (nameOccName name)
+
+lookupFixityRn' :: Name -> OccName -> RnM Fixity
+lookupFixityRn' name occ
| isUnboundName name
= return (Fixity minPrecedence InfixL)
-- Minimise errors from ubound names; eg
@@ -1412,8 +1416,8 @@ lookupFixityRn name
-- and that's what we want.
= do { iface <- loadInterfaceForName doc name
; traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+>
- vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)])
- ; return (mi_fix_fn iface (nameOccName name)) }
+ vcat [ppr name, ppr $ mi_fix_fn iface occ])
+ ; return (mi_fix_fn iface occ) }
doc = ptext (sLit "Checking fixity for") <+> ppr name
@@ -1421,6 +1425,43 @@ lookupFixityRn name
lookupTyFixityRn :: Located Name -> RnM Fixity
lookupTyFixityRn (L _ n) = lookupFixityRn n
+-- | Look up the fixity of a (possibly ambiguous) occurrence of a record field
+-- selector. We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as
+-- the field label, which might be different to the 'OccName' of the selector
+-- '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
+ where
+ get_ambiguous_fixity :: RdrName -> RnM Fixity
+ get_ambiguous_fixity rdr_name = do
+ traceRn $ text "get_ambiguous_fixity" <+> ppr rdr_name
+ rdr_env <- getGlobalRdrEnv
+ let elts = lookupGRE_RdrName rdr_name rdr_env
+
+ fixities <- groupBy ((==) `on` snd) . zip elts
+ <$> mapM lookup_gre_fixity elts
+
+ case fixities of
+ -- There should always be at least one fixity.
+ -- Something's very wrong if there are no fixity candidates, so panic
+ [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"
+ [ (_, fix):_ ] -> return fix
+ ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)
+ >> return (Fixity minPrecedence InfixL)
+
+ lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre)
+
+ ambiguous_fixity_err rn ambigs
+ = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)
+ , hang (text "Conflicts: ") 2 . vcat .
+ map format_ambig $ concat ambigs ]
+
+ format_ambig (elt, fix) = hang (ppr fix)
+ 2 (pprNameProvenance elt)
+
+
{-
************************************************************************
* *
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 5df96cf042..11d03f4d6a 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -150,9 +150,10 @@ 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 (L _ n)) -> lookupFixityRn n
- _ -> return (Fixity minPrecedence InfixL)
- -- c.f. lookupFixity for unbound
+ L _ (HsVar (L _ n)) -> lookupFixityRn n
+ L _ (HsRecFld f) -> lookupFieldFixityRn f
+ _ -> return (Fixity minPrecedence InfixL)
+ -- c.f. lookupFixity for unbound
; final_e <- mkOpAppRn e1' op' fixity e2'
; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 0024304b3a..cfe5fc5c27 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -477,7 +477,7 @@ extendGlobalRdrEnvRn avails new_fixities
; rdr_env2 <- foldlM add_gre rdr_env1 new_gres
- ; let fix_env' = foldl extend_fix_env fix_env new_names
+ ; let fix_env' = foldl extend_fix_env fix_env new_gres
gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }
; traceRn (text "extendGlobalRdrEnvRn 2" <+> (pprGlobalRdrEnv True rdr_env2))
@@ -487,13 +487,14 @@ extendGlobalRdrEnvRn avails new_fixities
new_occs = map nameOccName new_names
-- If there is a fixity decl for the gre, add it to the fixity env
- extend_fix_env fix_env name
+ extend_fix_env fix_env gre
| Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ)
= extendNameEnv fix_env name (FixItem occ fi)
| otherwise
= fix_env
where
- occ = nameOccName name
+ name = gre_name gre
+ occ = greOccName gre
new_gres :: [GlobalRdrElt] -- New LocalDef GREs, derived from avails
new_gres = concatMap localGREsFromAvail avails
@@ -564,8 +565,8 @@ getLocalNonValBinders fixity_env
; val_avails <- mapM new_simple val_bndrs
; let avails = concat nti_availss ++ val_avails
- new_bndrs = availsToNameSet avails `unionNameSet`
- availsToNameSet tc_avails
+ new_bndrs = availsToNameSetWithSelectors avails `unionNameSet`
+ availsToNameSetWithSelectors tc_avails
flds = concat nti_fldss ++ concat tc_fldss
; traceRn (text "getLocalNonValBinders 2" <+> ppr avails)
; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 1579400fc2..b284ec8d88 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -287,7 +287,7 @@ rnSrcFixityDecls bndr_set fix_decls
= setSrcSpan name_loc $
-- this lookup will fail if the definition isn't local
do names <- lookupLocalTcNames sig_ctxt what rdr_name
- return [ L name_loc name | name <- names ]
+ return [ L name_loc name | (_, name) <- names ]
what = ptext (sLit "fixity signature")
{-
@@ -325,7 +325,7 @@ rnSrcWarnDecls bndr_set decls'
-- ensures that the names are defined locally
= do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
rdr_names
- ; return [(nameOccName name, txt) | name <- names] }
+ ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
what = ptext (sLit "deprecation")
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 26e920ead9..853ef54c8a 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -379,6 +379,15 @@ tcExpr (OpApp arg1 op fix arg2) res_ty
op' fix
(mkLHsWrapCo co_a arg2') }
+ | (L loc (HsRecFld (Ambiguous lbl _))) <- op
+ , Just sig_ty <- obviousSig (unLoc arg1)
+ -- See Note [Disambiguating record fields]
+ = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
+ ; sel_name <- disambiguateSelector lbl sig_tc_ty
+ ; let op' = L loc (HsRecFld (Unambiguous lbl sel_name))
+ ; tcExpr (OpApp arg1 op' fix arg2) res_ty
+ }
+
| otherwise
= do { traceTc "Non Application rule" (ppr op)
; (op', op_ty) <- tcInferFun op
@@ -1739,11 +1748,14 @@ disambiguateRecordBinds record_expr record_tau rbnds res_ty
-- Extract the outermost TyCon of a type, if there is one; for
-- data families this is the representation tycon (because that's
--- where the fields live).
+-- where the fields live). Look inside sigma-types, so that
+-- tyConOf _ (forall a. Q => T a) = T
tyConOf :: FamInstEnvs -> Type -> Maybe TyCon
-tyConOf fam_inst_envs ty = case tcSplitTyConApp_maybe ty of
+tyConOf fam_inst_envs ty0 = case tcSplitTyConApp_maybe ty of
Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
Nothing -> Nothing
+ where
+ (_, _, ty) = tcSplitSigmaTy ty0
-- For an ambiguous record field, find all the candidate record
-- selectors (as GlobalRdrElts) and their parents.
View Lorry Controller Status