From 06600e74444d22caff1fa8c7eef0e4e2debd60b9 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Mon, 25 Aug 2014 15:17:39 +0100 Subject: Two buglets in record wild-cards (Trac #9436 and #9437) of named fields, whereas the code in RnPat.rnHsRecFields is much better set up to do so. Both easily fixed. --- compiler/parser/RdrHsSyn.lhs | 8 +++--- compiler/rename/RnExpr.lhs | 2 +- compiler/rename/RnPat.lhs | 33 ++++++++++++++++++------- testsuite/tests/rename/should_fail/T9436.hs | 8 ++++++ testsuite/tests/rename/should_fail/T9436.stderr | 4 +++ testsuite/tests/rename/should_fail/T9437.hs | 8 ++++++ testsuite/tests/rename/should_fail/T9437.stderr | 2 ++ testsuite/tests/rename/should_fail/all.T | 2 ++ 8 files changed, 53 insertions(+), 14 deletions(-) create mode 100644 testsuite/tests/rename/should_fail/T9436.hs create mode 100644 testsuite/tests/rename/should_fail/T9436.stderr create mode 100644 testsuite/tests/rename/should_fail/T9437.hs create mode 100644 testsuite/tests/rename/should_fail/T9437.stderr diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 84a284f0ab..2f95116d5e 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -1064,11 +1064,11 @@ mkRecConstrOrUpdate -> ([HsRecField RdrName (LHsExpr RdrName)], Bool) -> P (HsExpr RdrName) -mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c +mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) + | isRdrDataCon c = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd)) -mkRecConstrOrUpdate exp loc (fs,dd) - | null fs = parseErrorSDoc loc (text "Empty record update of:" <+> ppr exp) - | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] []) +mkRecConstrOrUpdate exp _ (fs,dd) + = return (RecordUpd exp (mk_rec_fields fs dd) [] [] []) mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 697303f276..4e5076ab1f 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -370,7 +370,7 @@ rnSection other = pprPanic "rnSection" (ppr other) rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName -> RnM (HsRecordBinds Name, FreeVars) rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd }) - = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds + = do { (flds, fvs) <- rnHsRecFields ctxt HsVar rec_binds ; (flds', fvss) <- mapAndUnzipM rn_field flds ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }, fvs `plusFV` plusFVs fvss) } diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 48fffce374..0d9668ed3b 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -20,7 +20,7 @@ module RnPat (-- main entry points -- sometimes we want to make top (qualified) names. isTopRecNameMaker, - rnHsRecFields1, HsRecFieldContext(..), + rnHsRecFields, HsRecFieldContext(..), -- CpsRn monad CpsRn, liftCps, @@ -478,7 +478,7 @@ rnHsRecPatsAndThen :: NameMaker -> HsRecFields RdrName (LPat RdrName) -> CpsRn (HsRecFields Name (LPat Name)) rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) - = do { flds <- liftCpsFV $ rnHsRecFields1 (HsRecFieldPat con) VarPat hs_rec_fields + = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) VarPat hs_rec_fields ; flds' <- mapM rn_field (flds `zip` [1..]) ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } where @@ -505,7 +505,7 @@ data HsRecFieldContext | HsRecFieldPat Name | HsRecFieldUpd -rnHsRecFields1 +rnHsRecFields :: forall arg. HsRecFieldContext -> (RdrName -> arg) -- When punning, use this to build a new field @@ -518,13 +518,22 @@ rnHsRecFields1 -- When we we've finished, we've renamed the LHS, but not the RHS, -- of each x=e binding -rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) +rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) = do { pun_ok <- xoptM Opt_RecordPuns ; disambig_ok <- xoptM Opt_DisambiguateRecordFields ; parent <- check_disambiguation disambig_ok mb_con - ; flds1 <- mapM (rn_fld pun_ok parent) flds + ; flds1 <- mapM (rn_fld pun_ok parent) flds ; mapM_ (addErr . dupFieldErr ctxt) dup_flds ; dotdot_flds <- rn_dotdot dotdot mb_con flds1 + + -- Check for an empty record update e {} + -- NB: don't complain about e { .. }, becuase rn_dotdot has done that already + ; case ctxt of + HsRecFieldUpd | Nothing <- dotdot + , null flds + -> addErr emptyUpdateErr + _ -> return () + ; let all_flds | null dotdot_flds = flds1 | otherwise = flds1 ++ dotdot_flds ; return (all_flds, mkFVs (getFieldIds all_flds)) } @@ -532,7 +541,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } mb_con = case ctxt of HsRecFieldCon con | not (isUnboundName con) -> Just con HsRecFieldPat con | not (isUnboundName con) -> Just con - _other -> Nothing + _ {- 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. @@ -562,7 +571,10 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } rn_dotdot Nothing _mb_con _flds -- No ".." at all = return [] rn_dotdot (Just {}) Nothing _flds -- ".." on record update - = do { addErr (badDotDot ctxt); return [] } + = do { case ctxt of + HsRecFieldUpd -> addErr badDotDot + _ -> return () + ; return [] } rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match = ASSERT( n == length flds ) do { loc <- getSrcSpanM -- Rather approximate @@ -639,8 +651,11 @@ needFlagDotDot :: HsRecFieldContext -> SDoc needFlagDotDot ctxt = vcat [ptext (sLit "Illegal `..' in record") <+> pprRFC ctxt, ptext (sLit "Use RecordWildCards to permit this")] -badDotDot :: HsRecFieldContext -> SDoc -badDotDot ctxt = ptext (sLit "You cannot use `..' in a record") <+> pprRFC ctxt +badDotDot :: SDoc +badDotDot = ptext (sLit "You cannot use `..' in a record update") + +emptyUpdateErr :: SDoc +emptyUpdateErr = ptext (sLit "Empty record update") badPun :: Located RdrName -> SDoc badPun fld = vcat [ptext (sLit "Illegal use of punning for field") <+> quotes (ppr fld), diff --git a/testsuite/tests/rename/should_fail/T9436.hs b/testsuite/tests/rename/should_fail/T9436.hs new file mode 100644 index 0000000000..dd2d733d73 --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9436.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RecordWildCards #-} + +module T9436 where + +data T = T { x :: Int } + +f :: T -> Int +f (T' { .. }) = x + 1 diff --git a/testsuite/tests/rename/should_fail/T9436.stderr b/testsuite/tests/rename/should_fail/T9436.stderr new file mode 100644 index 0000000000..2b9b10fb14 --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9436.stderr @@ -0,0 +1,4 @@ + +T9436.hs:8:4: + Not in scope: data constructor ‘T'’ + Perhaps you meant ‘T’ (line 5) diff --git a/testsuite/tests/rename/should_fail/T9437.hs b/testsuite/tests/rename/should_fail/T9437.hs new file mode 100644 index 0000000000..cd2ad7febd --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9437.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RecordWildCards #-} + +module T9437 where + +data Foo = Foo { x :: Int } + +test :: Foo -> Foo +test foo = foo { .. } diff --git a/testsuite/tests/rename/should_fail/T9437.stderr b/testsuite/tests/rename/should_fail/T9437.stderr new file mode 100644 index 0000000000..8c2222ef97 --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9437.stderr @@ -0,0 +1,2 @@ + +T9437.hs:8:12: You cannot use `..' in a record update diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T index d1bf2b6576..72331e7a64 100644 --- a/testsuite/tests/rename/should_fail/all.T +++ b/testsuite/tests/rename/should_fail/all.T @@ -116,3 +116,5 @@ test('T9006', multimod_compile_fail, ['T9006', '-v0']) test('T9156', normal, compile_fail, ['']) test('T9177', normal, compile_fail, ['']) +test('T9436', normal, compile_fail, ['']) +test('T9437', normal, compile_fail, ['']) -- cgit v1.2.1