diff options
| -rw-r--r-- | compiler/rename/RnPat.hs | 32 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_fail/T14307.hs | 10 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_fail/T14307.stderr | 2 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_fail/T2901.stderr | 4 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_fail/T5372.stderr | 4 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_fail/all.T | 1 |
6 files changed, 34 insertions, 19 deletions
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index ce8f3793ad..2846754f11 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -51,6 +51,7 @@ import RnUtils ( HsDocContext(..), newLocalBndrRn, bindLocalNames , warnUnusedMatches, newLocalBndrRn , checkDupNames, checkDupAndShadowedNames , checkTupSize , unknownSubordinateErr ) +import RnUnbound ( mkUnboundName ) import RnTypes import PrelNames import TyCon ( tyConName ) @@ -58,6 +59,7 @@ import ConLike import Type ( TyThing(..) ) import Name import NameSet +import OccName ( setOccNameSpace, tcName ) import RdrName import BasicTypes import Util @@ -589,13 +591,9 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) ; return (all_flds, mkFVs (getFieldIds all_flds)) } where mb_con = case ctxt of - HsRecFieldCon con | not (isUnboundName con) -> Just con - HsRecFieldPat con | not (isUnboundName con) -> Just con - _ {- update or isUnboundName con -} -> Nothing - -- The unbound name test is because if the constructor - -- isn't in scope the constructor lookup will add an error - -- add an error, but still return an unbound name. - -- We don't want that to screw up the dot-dot fill-in stuff. + HsRecFieldCon con -> Just con + HsRecFieldPat con -> Just con + _ {- update -} -> Nothing doc = case mb_con of Nothing -> text "constructor field name" @@ -624,11 +622,11 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) -- out of scope constructor) -> [LHsRecField GhcRn (Located arg)] -- Explicit fields -> RnM [LHsRecField GhcRn (Located arg)] -- Filled in .. fields - rn_dotdot Nothing _mb_con _flds -- No ".." at all - = return [] - rn_dotdot (Just {}) Nothing _flds -- Constructor out of scope - = return [] rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match + | not (isUnboundName con) -- This test is because if the constructor + -- isn't in scope the constructor lookup will add + -- an error but still return an unbound name. We + -- don't want that to screw up the dot-dot fill-in stuff. = ASSERT( flds `lengthIs` n ) do { loc <- getSrcSpanM -- Rather approximate ; dd_flag <- xoptM LangExt.RecordWildCards @@ -665,6 +663,12 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) , let sel = flSelector fl , let arg_rdr = mkVarUnqual (flLabel fl) ] } + rn_dotdot _dotdot _mb_con _flds + = return [] + -- _dotdot = Nothing => No ".." at all + -- _mb_con = Nothing => Record update + -- _mb_con = Just unbound => Out of scope data constructor + check_disambiguation :: Bool -> Maybe Name -> RnM (Maybe Name) -- When disambiguation is on, return name of parent tycon. check_disambiguation disambig_ok mb_con @@ -679,6 +683,12 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) -- or 'Nothing' if it is a pattern synonym or not in scope. -- That's the parent to use for looking up record fields. find_tycon env con_name + | isUnboundName con_name + = Just (mkUnboundName (setOccNameSpace tcName (getOccName con_name))) + -- If the data con is not in scope, return an unboundName tycon + -- That way the calls to lookupRecFieldOcc in rn_fld won't generate + -- an error cascade; see Trac #14307 + | Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con_name = Just (tyConName (dataConTyCon dc)) -- Special case for [], which is built-in syntax diff --git a/testsuite/tests/rename/should_fail/T14307.hs b/testsuite/tests/rename/should_fail/T14307.hs new file mode 100644 index 0000000000..9bb33b7425 --- /dev/null +++ b/testsuite/tests/rename/should_fail/T14307.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} + +module T14307 where + +data A = A { field :: Int } +data B = B { field :: Int } + +f :: B -> Int +f (C { field }) = field diff --git a/testsuite/tests/rename/should_fail/T14307.stderr b/testsuite/tests/rename/should_fail/T14307.stderr new file mode 100644 index 0000000000..1470a406d4 --- /dev/null +++ b/testsuite/tests/rename/should_fail/T14307.stderr @@ -0,0 +1,2 @@ + +T14307.hs:10:4: error: Not in scope: data constructor ‘C’ diff --git a/testsuite/tests/rename/should_fail/T2901.stderr b/testsuite/tests/rename/should_fail/T2901.stderr index 2128989b4c..d5a5bbda9a 100644 --- a/testsuite/tests/rename/should_fail/T2901.stderr +++ b/testsuite/tests/rename/should_fail/T2901.stderr @@ -2,7 +2,3 @@ T2901.hs:6:5: error: Not in scope: data constructor ‘F.Foo’ No module named ‘F’ is imported. - -T2901.hs:6:13: error: - Not in scope: ‘F.field’ - No module named ‘F’ is imported. diff --git a/testsuite/tests/rename/should_fail/T5372.stderr b/testsuite/tests/rename/should_fail/T5372.stderr index f6a466eb6c..d8b8e8fa56 100644 --- a/testsuite/tests/rename/should_fail/T5372.stderr +++ b/testsuite/tests/rename/should_fail/T5372.stderr @@ -2,7 +2,3 @@ T5372.hs:4:11: error: Not in scope: data constructor ‘MkS’ Perhaps you meant ‘T5372a.MkS’ (imported from T5372a) - -T5372.hs:4:17: error: - Not in scope: ‘x’ - Perhaps you meant ‘T5372a.x’ (imported from T5372a) diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T index 9feee3d922..b0863725e9 100644 --- a/testsuite/tests/rename/should_fail/all.T +++ b/testsuite/tests/rename/should_fail/all.T @@ -129,3 +129,4 @@ test('T13644', normal, multimod_compile_fail, ['T13644','-v0']) test('T13568', normal, multimod_compile_fail, ['T13568','-v0']) test('T13947', normal, compile_fail, ['']) test('T13847', normal, multimod_compile_fail, ['T13847','-v0']) +test('T14307', normal, compile_fail, ['']) |