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