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.

8 files changed, 53 insertions, 14 deletions

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, [''])