Commit 6e56ac58 authored by Adam Gundry's avatar Adam Gundry Committed by Ben Gamari

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
parent ceaf0f46
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
{-
************************************************************************
* *
......
......@@ -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) }
......
......@@ -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
......
......@@ -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")
......
......@@ -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.
......
{-# LANGUAGE DuplicateRecordFields #-}
module T11173 where
import T11173a (A(..))
-- Check that the fixity declaration applied to the field 'foo' is used
x b = b `foo` b `foo` 0
{-# LANGUAGE DuplicateRecordFields #-}
module T11173a where
data A = A { foo :: Int -> Int, bar :: Int -> Int }
newtype B = B { foo :: Int -> Int }
infixr 5 `foo`
infixr 5 `bar`
-- This is well-typed only if the fixity is correctly applied
y b = b `bar` b `bar` 0
test('T11173', extra_clean(['T11173a.hi', 'T11173a.o']), multimod_compile, ['T11173', '-v0'])
{-# LANGUAGE DuplicateRecordFields #-}
module OverloadedRecFldsFail11_A where
{-# WARNING foo "Warning on a record field" #-}
data S = MkS { foo :: Bool }
data T = MkT { foo :: Int }
{-# LANGUAGE DuplicateRecordFields #-}
module T11167_ambiguous_fixity where
import T11167_ambiguous_fixity_A
import T11167_ambiguous_fixity_B
x a = (a :: A) `foo` 0
[1 of 3] Compiling T11167_ambiguous_fixity_B ( T11167_ambiguous_fixity_B.hs, T11167_ambiguous_fixity_B.o )
[2 of 3] Compiling T11167_ambiguous_fixity_A ( T11167_ambiguous_fixity_A.hs, T11167_ambiguous_fixity_A.o )
[3 of 3] Compiling T11167_ambiguous_fixity ( T11167_ambiguous_fixity.hs, T11167_ambiguous_fixity.o )
T11167_ambiguous_fixity.hs:6:7: error:
Ambiguous fixity for record field ‘foo’
Conflicts:
infixr 3
imported from ‘T11167_ambiguous_fixity_A’ at T11167_ambiguous_fixity.hs:3:1-32
(and originally defined at T11167_ambiguous_fixity_A.hs:4:16-18)
infixr 3
imported from ‘T11167_ambiguous_fixity_A’ at T11167_ambiguous_fixity.hs:3:1-32
(and originally defined at T11167_ambiguous_fixity_A.hs:3:16-18)
infixl 5
imported from ‘T11167_ambiguous_fixity_B’ at T11167_ambiguous_fixity.hs:4:1-32
(and originally defined at T11167_ambiguous_fixity_B.hs:2:16-18)
{-# LANGUAGE DuplicateRecordFields #-}
module T11167_ambiguous_fixity_A where
data A = MkA { foo :: Int -> Int }
data C = MkC { foo :: Int -> Int }
infixr 3 `foo`
module T11167_ambiguous_fixity_B where
data B = MkB { foo :: Int -> Int }
infixl 5 `foo`
......@@ -16,10 +16,16 @@ test('overloadedrecfldsfail10',
, 'OverloadedRecFldsFail10_B.hi', 'OverloadedRecFldsFail10_B.o'
, 'OverloadedRecFldsFail10_C.hi', 'OverloadedRecFldsFail10_C.o']),
multimod_compile_fail, ['overloadedrecfldsfail10', ''])
test('overloadedrecfldsfail11', normal, compile_fail, [''])
test('overloadedrecfldsfail11',
extra_clean(['OverloadedRecFldsFail11_A.hi', 'OverloadedRecFldsFail11_A.o']),
multimod_compile_fail, ['overloadedrecfldsfail11', ''])
test('overloadedrecfldsfail12',
extra_clean(['OverloadedRecFldsFail12_A.hi', 'OverloadedRecFldsFail12_A.o']),
multimod_compile_fail, ['overloadedrecfldsfail12', ''])
test('overloadedrecfldsfail13', normal, compile_fail, [''])
test('overloadedrecfldsfail14', normal, compile_fail, [''])
test('overloadedlabelsfail01', normal, compile_fail, [''])
test('T11167_ambiguous_fixity',
extra_clean([ 'T11167_ambiguous_fixity_A.hi', 'T11167_ambiguous_fixity_A.o'
, 'T11167_ambiguous_fixity_B.hi', 'T11167_ambiguous_fixity_B.o' ]),
multimod_compile_fail, ['T11167_ambiguous_fixity', ''])
{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Werror #-}
import OverloadedRecFldsFail11_A
{-# WARNING foo "No warnings for DRFs" #-}
data S = MkS { foo :: Bool }
data T = MkT { foo :: Int }
main = print (foo (MkS True :: S))
[1 of 2] Compiling OverloadedRecFldsFail11_A ( OverloadedRecFldsFail11_A.hs, OverloadedRecFldsFail11_A.o )
[2 of 2] Compiling Main ( overloadedrecfldsfail11.hs, overloadedrecfldsfail11.o )
overloadedrecfldsfail11.hs:3:13: error:
The deprecation for ‘foo’ lacks an accompanying binding
(The deprecation must be given where ‘foo’ is declared)
overloadedrecfldsfail11.hs:5:15: warning:
In the use of ‘foo’ (imported from OverloadedRecFldsFail11_A):
"Warning on a record field"
<no location info>: error:
Failing due to -Werror.
module T11167 where
data SomeException
newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r}
runContT' :: ContT r m a -> (a -> m r) -> m r
runContT' = runContT
catch_ :: IO a -> (SomeException -> IO a) -> IO a
catch_ = undefined
foo :: IO ()
foo = (undefined :: ContT () IO a)
`runContT` (undefined :: a -> IO ())
`catch_` (undefined :: SomeException -> IO ())
foo' :: IO ()
foo' = (undefined :: ContT () IO a)
`runContT'` (undefined :: a -> IO ())
`catch_` (undefined :: SomeException -> IO ())
{-# LANGUAGE DuplicateRecordFields #-}
module T11167_ambig where
data SomeException
newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r}
newtype ContT' r m a = ContT' {runContT :: (a -> m r) -> m r}
runContT' :: ContT r m a -> (a -> m r) -> m r
runContT' = runContT
catch_ :: IO a -> (SomeException -> IO a) -> IO a
catch_ = undefined
foo :: IO ()
foo = (undefined :: ContT () IO a)
`runContT` (undefined :: a -> IO ())
`catch_` (undefined :: SomeException -> IO ())
foo' :: IO ()
foo' = (undefined :: ContT () IO a)
`runContT'` (undefined :: a -> IO ())
`catch_` (undefined :: SomeException -> IO ())
......@@ -230,3 +230,5 @@ test('T11164',
extra_clean(['T11164a.hi', 'T11164a.o',
'T11164b.hi', 'T11164b.o']),
multimod_compile, ['T11164', '-v0'])
test('T11167', normal, compile, [''])
test('T11167_ambig', normal, compile, [''])
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