Implement record dot syntaxwip/joachim/bump-haddock

3 files changed, 45 insertions, 13 deletions

diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index dc0d244fc1..a74af6e564 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -639,7 +639,11 @@ following.
 
 -}
 
-tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
+-- Record updates via dot syntax are replaced by desugared expressions
+-- in the renamer. See Note [Overview of record dot syntax] in
+-- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here
+-- and panic otherwise.
+tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ty
   = ASSERT( notNull rbnds )
     do  { -- STEP -2: typecheck the record_expr, the record to be updated
           (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr
@@ -805,11 +809,12 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
                                    , rupd_out_tys = result_inst_tys
                                    , rupd_wrap = req_wrap }
               expr' = RecordUpd { rupd_expr = mkLHsWrap fam_co $
-                                              mkLHsWrapCo co_scrut record_expr'
-                                , rupd_flds = rbinds'
+                                                mkLHsWrapCo co_scrut record_expr'
+                                , rupd_flds = Left rbinds'
                                 , rupd_ext = upd_tc }
 
         ; tcWrapResult expr expr' rec_res_ty res_ty }
+tcExpr (RecordUpd {}) _ = panic "GHC.Tc.Gen.Expr: tcExpr: The impossible happened!"
 
 
 {-
@@ -828,6 +833,19 @@ tcExpr (ArithSeq _ witness seq) res_ty
 {-
 ************************************************************************
 *                                                                      *
+                Record dot syntax
+*                                                                      *
+************************************************************************
+-}
+
+-- These terms have been replaced by desugaring in the renamer. See
+-- Note [Overview of record dot syntax].
+tcExpr (HsGetField _ _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
+tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"
+
+{-
+************************************************************************
+*                                                                      *
                 Template Haskell
 *                                                                      *
 ************************************************************************
@@ -1274,7 +1292,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty
                , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC."
                ]
       where
-        rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds, rupd_ext = noExtField }
+        rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField }
         loc  = getLoc (head rbnds)
 
 {-
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 648bf5ce12..b1dd472d75 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -375,6 +375,7 @@ data CtOrigin
   | AssocFamPatOrigin   -- When matching the patterns of an associated
                         -- family instance with that of its parent class
   | SectionOrigin
+  | HasFieldOrigin FastString
   | TupleOrigin         -- (..,..)
   | ExprSigOrigin       -- e :: ty
   | PatSigOrigin        -- p :: ty
@@ -478,6 +479,7 @@ lexprCtOrigin (L _ e) = exprCtOrigin e
 
 exprCtOrigin :: HsExpr GhcRn -> CtOrigin
 exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name
+exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin f
 exprCtOrigin (HsUnboundVar {})    = Shouldn'tHappenOrigin "unbound variable"
 exprCtOrigin (HsConLikeOut {})    = panic "exprCtOrigin HsConLikeOut"
 exprCtOrigin (HsRecFld _ f)       = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)
@@ -493,6 +495,7 @@ exprCtOrigin (HsAppType _ e1 _)   = lexprCtOrigin e1
 exprCtOrigin (OpApp _ _ op _)     = lexprCtOrigin op
 exprCtOrigin (NegApp _ e _)       = lexprCtOrigin e
 exprCtOrigin (HsPar _ e)          = lexprCtOrigin e
+exprCtOrigin (HsProjection _ _)   = SectionOrigin
 exprCtOrigin (SectionL _ _ _)     = SectionOrigin
 exprCtOrigin (SectionR _ _ _)     = SectionOrigin
 exprCtOrigin (ExplicitTuple {})   = Shouldn'tHappenOrigin "explicit tuple"
@@ -629,6 +632,7 @@ pprCtO IfOrigin              = text "an if expression"
 pprCtO (LiteralOrigin lit)   = hsep [text "the literal", quotes (ppr lit)]
 pprCtO (ArithSeqOrigin seq)  = hsep [text "the arithmetic sequence", quotes (ppr seq)]
 pprCtO SectionOrigin         = text "an operator section"
+pprCtO (HasFieldOrigin f)    = hsep [text "selecting the field", quotes (ppr f)]
 pprCtO AssocFamPatOrigin     = text "the LHS of a family instance"
 pprCtO TupleOrigin           = text "a tuple"
 pprCtO NegateOrigin          = text "a use of syntactic negation"
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 4d4860c7e1..90717063f7 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -946,21 +946,31 @@ zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds })
         ; return (expr { rcon_ext  = new_con_expr
                        , rcon_flds = new_rbinds }) }
 
-zonkExpr env (RecordUpd { rupd_flds = rbinds
+-- Record updates via dot syntax are replaced by desugared expressions
+-- in the renamer. See Note [Rebindable Syntax and HsExpansion]. This
+-- is why we match on 'rupd_flds = Left rbinds' here and panic otherwise.
+zonkExpr env (RecordUpd { rupd_flds = Left rbinds
                         , rupd_expr = expr
-                        , rupd_ext = RecordUpdTc
-                            { rupd_cons = cons, rupd_in_tys = in_tys
-                            , rupd_out_tys = out_tys, rupd_wrap = req_wrap }})
+                        , rupd_ext = RecordUpdTc {
+                                       rupd_cons = cons
+                                     , rupd_in_tys = in_tys
+                                     , rupd_out_tys = out_tys
+                                     , rupd_wrap = req_wrap }})
   = do  { new_expr    <- zonkLExpr env expr
         ; new_in_tys  <- mapM (zonkTcTypeToTypeX env) in_tys
         ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys
         ; new_rbinds  <- zonkRecUpdFields env rbinds
         ; (_, new_recwrap) <- zonkCoFn env req_wrap
-        ; return (RecordUpd { rupd_expr = new_expr, rupd_flds =  new_rbinds
-                            , rupd_ext = RecordUpdTc
-                                { rupd_cons = cons, rupd_in_tys = new_in_tys
-                                , rupd_out_tys = new_out_tys
-                                , rupd_wrap = new_recwrap }}) }
+        ; return (
+            RecordUpd {
+                  rupd_expr = new_expr
+                , rupd_flds = Left new_rbinds
+                , rupd_ext = RecordUpdTc {
+                               rupd_cons = cons
+                             , rupd_in_tys = new_in_tys
+                             , rupd_out_tys = new_out_tys
+                             , rupd_wrap = new_recwrap }}) }
+zonkExpr _ (RecordUpd {}) = panic "GHC.Tc.Utils.Zonk: zonkExpr: The impossible happened!"
 
 zonkExpr env (ExprWithTySig _ e ty)
   = do { e' <- zonkLExpr env e