From 6e56ac58a6905197412d58e32792a04a63b94d7e Mon Sep 17 00:00:00 2001 From: Adam Gundry Date: Fri, 11 Dec 2015 22:43:26 +0100 Subject: Fix infix record field fixity (#11167 and #11173). This extends D1585 with proper support for infix duplicate record fields. In particular, it is now possible to declare record fields as infix in a module for which `DuplicateRecordFields` is enabled, fixity is looked up correctly and a readable (although unpleasant) error message is generated if multiple fields with different fixities are in scope. As a bonus, `DEPRECATED` and `WARNING` pragmas now work for duplicate record fields. The pragma applies to all fields with the given label. In addition, a couple of minor `DuplicateRecordFields` bugs, which were pinpointed by the `T11167_ambig` test case, are fixed by this patch: - Ambiguous infix fields can now be disambiguated by putting a type signature on the first argument - Polymorphic type constructor signatures (such as `ContT () IO a` in `T11167_ambig`) now work for disambiguation Parts of this patch are from D1585 authored by @KaneTW. Test Plan: New tests added. Reviewers: KaneTW, bgamari, austin Reviewed By: bgamari Subscribers: thomie, hvr Differential Revision: https://phabricator.haskell.org/D1600 GHC Trac Issues: #11167, #11173 --- compiler/rename/RnEnv.hs | 59 ++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 50 insertions(+), 9 deletions(-) (limited to 'compiler/rename/RnEnv.hs') 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) + + {- ************************************************************************ * * -- cgit v1.2.1