Commit 07eb258d authored by Simon Peyton Jones's avatar Simon Peyton Jones

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
parent 8e8d26ac
......@@ -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
......
......@@ -497,9 +497,10 @@ 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
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
......@@ -511,12 +512,13 @@ dsExpr (RecordCon _ con_expr rbinds labels) = do
[] -> 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
; 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
......
......@@ -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 }
......
......@@ -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' }
......
......@@ -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
, 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
(PostTc id HsWrapper) -- See note [Record Update HsWrapper]
, 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 _)
......
......@@ -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])
......
......@@ -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 }
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment