Refactor HsExpr.RecordCon, RecordUpd

This follows Matthew's patch making pattern synoyms work
with records.

This patch
 - replaces the (PostTc id [FieldLabel]) field of
   RecordCon with (PostTc id ConLike)

 - record-ises both RecordCon and RecordUpd, which
   both have quite a lot of fields.

No change in behaviour

10 files changed, 96 insertions, 78 deletions

diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index e1b45a721f..95c70aa212 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -536,18 +536,14 @@ addTickHsExpr (ExplicitPArr ty es) =
 
 addTickHsExpr (HsStatic e) = HsStatic <$> addTickLHsExpr e
 
-addTickHsExpr (RecordCon id ty rec_binds labels) =
-        liftM4 RecordCon
-                (return id)
-                (return ty)
-                (addTickHsRecordBinds rec_binds)
-                (return labels)
-addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2 req_wrap) =
-        return RecordUpd `ap`
-                (addTickLHsExpr e) `ap`
-                (mapM addTickHsRecField rec_binds) `ap`
-                (return cons) `ap` (return tys1) `ap` (return tys2) `ap`
-                (return req_wrap)
+addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })
+  = do { rec_binds' <- addTickHsRecordBinds rec_binds
+       ; return (expr { rcon_flds = rec_binds' }) }
+
+addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
+  = do { e' <- addTickLHsExpr e
+       ; flds' <- mapM addTickHsRecField flds
+       ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
 
 addTickHsExpr (ExprWithTySigOut e ty) =
         liftM2 ExprWithTySigOut
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index dbe3bc69de..44e0aa0977 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -497,26 +497,28 @@ We also handle @C{}@ as valid construction syntax for an unlabelled
 constructor @C@, setting all of @C@'s fields to bottom.
 -}
 
-dsExpr (RecordCon _ con_expr rbinds labels) = do
-    con_expr' <- dsExpr con_expr
-    let
-        (arg_tys, _) = tcSplitFunTys (exprType con_expr')
-        -- A newtype in the corner should be opaque;
-        -- hence TcType.tcSplitFunTys
+dsExpr (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds
+                  , rcon_con_like = con_like })
+  = do { con_expr' <- dsExpr con_expr
+       ; let
+             (arg_tys, _) = tcSplitFunTys (exprType con_expr')
+             -- A newtype in the corner should be opaque;
+             -- hence TcType.tcSplitFunTys
 
-        mk_arg (arg_ty, fl)
-          = case findField (rec_flds rbinds) (flSelector fl) of
-              (rhs:rhss) -> ASSERT( null rhss )
-                            dsLExpr rhs
-              []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
-        unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
+             mk_arg (arg_ty, fl)
+               = case findField (rec_flds rbinds) (flSelector fl) of
+                   (rhs:rhss) -> ASSERT( null rhss )
+                                 dsLExpr rhs
+                   []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
+             unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
 
+             labels = conLikeFieldLabels con_like
 
-    con_args <- if null labels
-                then mapM unlabelled_bottom arg_tys
-                else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
+       ; con_args <- if null labels
+                     then mapM unlabelled_bottom arg_tys
+                     else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
 
-    return (mkCoreApps con_expr' con_args)
+       ; return (mkCoreApps con_expr' con_args) }
 
 {-
 Record update is a little harder. Suppose we have the decl:
@@ -553,8 +555,10 @@ But if x::T a b, then
 So we need to cast (T a Int) to (T a b).  Sigh.
 -}
 
-dsExpr expr@(RecordUpd record_expr fields
-                        cons_to_upd in_inst_tys out_inst_tys dict_req_wrap )
+dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
+                       , rupd_cons = cons_to_upd
+                       , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys
+                       , rupd_wrap = dict_req_wrap } )
   | null fields
   = dsLExpr record_expr
   | otherwise
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index b61d670cc5..0b9906f7f1 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1143,11 +1143,11 @@ repE e@(ExplicitTuple es boxed)
   | otherwise      = do { xs <- repLEs [e | L _ (Present e) <- es]
                         ; repUnboxedTup xs }
 
-repE (RecordCon c _ flds _)
+repE (RecordCon { rcon_con_name = c, rcon_flds = flds })
  = do { x <- lookupLOcc c;
         fs <- repFields flds;
         repRecCon x fs }
-repE (RecordUpd e flds _ _ _ _)
+repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
  = do { x <- repLE e;
         fs <- repUpdFields flds;
         repRecUpd x fs }
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 0b8ede6087..c4ad7feaf0 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -712,15 +712,10 @@ cvtl e = wrapL (cvt e)
                               ; return $ ExprWithTySig e' t' PlaceHolder }
     cvt (RecConE c flds) = do { c' <- cNameL c
                               ; flds' <- mapM (cvtFld mkFieldOcc) flds
-                              ; return $ RecordCon c' noPostTcExpr
-                                          (HsRecFields flds' Nothing)
-                                          PlaceHolder }
+                              ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
     cvt (RecUpdE e flds) = do { e' <- cvtl e
                               ; flds'<- mapM (cvtFld mkAmbiguousFieldOcc) flds
-                              ; return $ RecordUpd e'
-                                          flds'
-                                          PlaceHolder PlaceHolder
-                                          PlaceHolder PlaceHolder }
+                              ; return $ mkRdrRecordUpd e' flds' }
     cvt (StaticE e)      = fmap HsStatic $ cvtl e
     cvt (UnboundVarE s)  = do { s' <- vName s; return $ HsVar s' }
 
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 09717b768a..d02f2d57d0 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -36,7 +36,6 @@ import StaticFlags( opt_PprStyle_Debug )
 import Outputable
 import FastString
 import Type
-import FieldLabel
 
 -- libraries:
 import Data.Data hiding (Fixity)
@@ -283,11 +282,12 @@ data HsExpr id
   --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | RecordCon   (Located id)       -- The constructor.  After type checking
-                                   -- it's the dataConWrapId of the constructor
-                PostTcExpr         -- Data con Id applied to type args
-                (HsRecordBinds id)
-                (PostTc id [FieldLabel])
+  | RecordCon
+      { rcon_con_name :: Located id         -- The constructor name;
+                                            --  not used after type checking
+      , rcon_con_like :: PostTc id ConLike  -- The data constructor or pattern synonym
+      , rcon_con_expr :: PostTcExpr         -- Instantiated constructor function
+      , rcon_flds     :: HsRecordBinds id } -- The fields
 
   -- | Record update
   --
@@ -295,19 +295,20 @@ data HsExpr id
   --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | RecordUpd   (LHsExpr id)
-                [LHsRecUpdField id]
---              (HsMatchGroup Id)  -- Filled in by the type checker to be
---                                 -- a match that does the job
-                (PostTc id [ConLike])
+  | RecordUpd
+      { rupd_expr :: LHsExpr id
+      , rupd_flds :: [LHsRecUpdField id]
+      , rupd_cons :: PostTc id [ConLike]
                 -- Filled in by the type checker to the
                 -- _non-empty_ list of DataCons that have
                 -- all the upd'd fields
-                (PostTc id [Type])  -- Argument types of *input* record type
-                (PostTc id [Type])  --              and  *output* record type
-                                   -- The original type can be reconstructed
-                                   -- with conLikeResTy
-                (PostTc id HsWrapper) -- See note [Record Update HsWrapper]
+
+      , rupd_in_tys  :: PostTc id [Type]  -- Argument types of *input* record type
+      , rupd_out_tys :: PostTc id [Type]  --              and  *output* record type
+                                          -- The original type can be reconstructed
+                                          -- with conLikeResTy
+      , rupd_wrap :: PostTc id HsWrapper  -- See note [Record Update HsWrapper]
+      }
   -- For a type family, the arg types are of the *instance* tycon,
   -- not the family tycon
 
@@ -732,10 +733,10 @@ ppr_expr (ExplicitList _ _ exprs)
 ppr_expr (ExplicitPArr _ exprs)
   = paBrackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
 
-ppr_expr (RecordCon con_id _ rbinds _)
+ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
   = hang (ppr con_id) 2 (ppr rbinds)
 
-ppr_expr (RecordUpd aexp rbinds _ _ _ _)
+ppr_expr (RecordUpd { rupd_expr = aexp, rupd_flds = rbinds })
   = hang (pprLExpr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
 
 ppr_expr (ExprWithTySig expr sig _)
diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs
index b37cd357d2..d9ec5b2912 100644
--- a/compiler/hsSyn/PlaceHolder.hs
+++ b/compiler/hsSyn/PlaceHolder.hs
@@ -110,6 +110,7 @@ type DataId id =
   , Data (PostTc id Coercion)
   , Data (PostTc id id)
   , Data (PostTc id [Type])
+  , Data (PostTc id ConLike)
   , Data (PostTc id [ConLike])
   , Data (PostTc id HsWrapper)
   , Data (PostTc id [FieldLabel])
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 384913a1a0..ed45c4b05d 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -21,6 +21,7 @@ module RdrHsSyn (
         mkPatSynMatchGroup,
         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
         mkTyClD, mkInstD,
+        mkRdrRecordCon, mkRdrRecordUpd,
         setRdrNameSpace,
 
         cvBindGroup,
@@ -849,7 +850,7 @@ checkAPat msg loc e0 = do
                                    return (TuplePat ps b [])
      | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
 
-   RecordCon c _ (HsRecFields fs dd) _
+   RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
                         -> do fs <- mapM (checkPatField msg) fs
                               return (ConPatIn c (RecCon (HsRecFields fs dd)))
    HsSpliceE s | not (isTypedSplice s)
@@ -1191,11 +1192,22 @@ mkRecConstrOrUpdate
 
 mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd)
   | isRdrDataCon c
-  = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd) PlaceHolder)
+  = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
 mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
   | dd        = parseErrorSDoc l (text "You cannot use `..' in a record update")
-  | otherwise = return (RecordUpd exp (map (fmap mk_rec_upd_field) fs)
-                      PlaceHolder PlaceHolder PlaceHolder PlaceHolder)
+  | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))
+
+mkRdrRecordUpd :: LHsExpr RdrName -> [LHsRecUpdField RdrName] -> HsExpr RdrName
+mkRdrRecordUpd exp flds
+  = RecordUpd { rupd_expr = exp
+              , rupd_flds = flds
+              , rupd_cons    = PlaceHolder, rupd_in_tys  = PlaceHolder
+              , rupd_out_tys = PlaceHolder, rupd_wrap    = PlaceHolder }
+
+mkRdrRecordCon :: Located RdrName -> HsRecordBinds RdrName -> HsExpr RdrName
+mkRdrRecordCon con flds
+  = RecordCon { rcon_con_name = con, rcon_flds = flds
+              , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
 
 mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index a8b1d2e7c8..ba48830465 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -255,18 +255,19 @@ rnExpr (ExplicitTuple tup_args boxity)
     rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)
                                         , emptyFVs)
 
-rnExpr (RecordCon con_id _ rbinds _)
+rnExpr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
   = do  { conname <- lookupLocatedOccRn con_id
         ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
-        ; return (RecordCon conname noPostTcExpr rbinds' PlaceHolder ,
+        ; return (RecordCon { rcon_con_name = conname, rcon_flds = rbinds'
+                            , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder },
                   fvRbinds `addOneFV` unLoc conname ) }
 
-rnExpr (RecordUpd expr rbinds _ _ _ _)
+rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
   = do  { (expr', fvExpr) <- rnLExpr expr
         ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
-        ; return (RecordUpd expr' rbinds'
-                            PlaceHolder PlaceHolder
-                            PlaceHolder PlaceHolder
+        ; return (RecordUpd { rupd_expr = expr', rupd_flds = rbinds'
+                            , rupd_cons    = PlaceHolder, rupd_in_tys = PlaceHolder
+                            , rupd_out_tys = PlaceHolder, rupd_wrap   = PlaceHolder }
                  , fvExpr `plusFV` fvRbinds) }
 
 rnExpr (ExprWithTySig expr pty PlaceHolder)
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index b69b3e626f..6b0511a465 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -576,7 +576,7 @@ to support expressions like this:
 ************************************************************************
 -}
 
-tcExpr (RecordCon (L loc con_name) _ rbinds _) res_ty
+tcExpr (RecordCon { rcon_con_name = L loc con_name, rcon_flds = rbinds }) res_ty
   = do  { con_like <- tcLookupConLike con_name
 
         -- Check for missing fields
@@ -585,14 +585,16 @@ tcExpr (RecordCon (L loc con_name) _ rbinds _) res_ty
         ; (con_expr, con_tau) <- tcInferId con_name
         ; let arity = conLikeArity con_like
               (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity
-              labels = conLikeFieldLabels con_like
         ; case conLikeWrapId_maybe con_like of
                Nothing -> nonBidirectionalErr (conLikeName con_like)
                Just con_id -> do {
                   co_res <- unifyType actual_res_ty res_ty
                 ; rbinds' <- tcRecordBinds con_like arg_tys rbinds
                 ; return $ mkHsWrapCo co_res $
-                    RecordCon (L loc con_id) con_expr rbinds' labels } }
+                    RecordCon { rcon_con_name = L loc con_id
+                              , rcon_con_expr = con_expr
+                              , rcon_con_like = con_like
+                              , rcon_flds = rbinds' } } }
 
 {-
 Note [Type of a record update]
@@ -730,7 +732,7 @@ following.
 
 -}
 
-tcExpr (RecordUpd record_expr rbnds _ _ _ _ ) res_ty
+tcExpr (RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
   = ASSERT( notNull rbnds )
     do  {
         -- STEP -1  See Note [Disambiguating record fields]
@@ -863,8 +865,10 @@ tcExpr (RecordUpd record_expr rbnds _ _ _ _ ) res_ty
 
         -- Phew!
         ; return $ mkHsWrapCo co_res $
-          RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
-                    relevant_cons scrut_inst_tys result_inst_tys req_wrap }
+          RecordUpd { rupd_expr = mkLHsWrap scrut_co record_expr'
+                    , rupd_flds = rbinds'
+                    , rupd_cons = relevant_cons, rupd_in_tys = scrut_inst_tys
+                    , rupd_out_tys = result_inst_tys, rupd_wrap = req_wrap } }
 
 tcExpr (HsRecFld f) res_ty
     = tcCheckRecSelId f res_ty
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 88c4d9c7c3..00326801f7 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -709,19 +709,23 @@ zonkExpr env (ExplicitPArr ty exprs)
        new_exprs <- zonkLExprs env exprs
        return (ExplicitPArr new_ty new_exprs)
 
-zonkExpr env (RecordCon data_con con_expr rbinds labels)
+zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds })
   = do  { new_con_expr <- zonkExpr env con_expr
         ; new_rbinds   <- zonkRecFields env rbinds
-        ; return (RecordCon data_con new_con_expr new_rbinds labels) }
+        ; return (expr { rcon_con_expr = new_con_expr
+                       , rcon_flds = new_rbinds }) }
 
-zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys req_wrap)
+zonkExpr env (RecordUpd { rupd_expr = expr, rupd_flds = rbinds
+                        , 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 (zonkTcTypeToType env) in_tys
         ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
         ; new_rbinds  <- zonkRecUpdFields env rbinds
         ; (_, new_recwrap) <- zonkCoFn env req_wrap
-        ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys
-                              new_recwrap) }
+        ; return (RecordUpd { rupd_expr = new_expr, rupd_flds =  new_rbinds
+                            , rupd_cons = cons, rupd_in_tys = new_in_tys
+                            , rupd_out_tys = new_out_tys, rupd_wrap = new_recwrap }) }
 
 zonkExpr env (ExprWithTySigOut e ty)
   = do { e' <- zonkLExpr env e