tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
; returnM (HsSCC lbl expr') }
+tcExpr (HsTickPragma info expr) res_ty
+ = do { expr' <- tcMonoExpr expr res_ty
+ ; returnM (HsTickPragma info expr') }
tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation
= do { expr' <- tcMonoExpr expr res_ty
where
tc_elt elt_ty expr = tcPolyExpr expr elt_ty
+-- For tuples, take care to preserve rigidity
+-- E.g. case (x,y) of ....
+-- The scrutinee should have a rigid type if x,y do
+-- The general scheme is the same as in tcIdApp
tcExpr (ExplicitTuple exprs boxity) res_ty
- = do { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length exprs)) res_ty
- ; exprs' <- tcPolyExprs exprs arg_tys
- ; return (ExplicitTuple exprs' boxity) }
+ = do { tvs <- newBoxyTyVars [argTypeKind | e <- exprs]
+ ; let tup_tc = tupleTyCon boxity (length exprs)
+ tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs)
+ ; arg_tys <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty
+ ; exprs' <- tcPolyExprs exprs arg_tys
+ ; arg_tys' <- mapM refineBox arg_tys
+ ; co_fn <- tcFunResTy (tyConName tup_tc) (mkTyConApp tup_tc arg_tys') res_ty
+ ; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) }
tcExpr (HsProc pat cmd) res_ty
= do { (pat', cmd') <- tcProc pat cmd res_ty
-- don't know how to do the update otherwise.
-tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
+tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _ _) res_ty
= -- STEP 0
-- Check that the field names are really field names
ASSERT( notNull rbinds )
-- Figure out the tycon and data cons from the first field name
let
-- It's OK to use the non-tc splitters here (for a selector)
- upd_field_lbls = recBindFields rbinds
+ upd_field_lbls = recBindFields hrbinds
sel_id : _ = sel_ids
(tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
- data_cons = tyConDataCons tycon -- it's not a field label
+ data_cons = tyConDataCons tycon -- it's not a field label
+ -- NB: for a data type family, the tycon is the instance tycon
+
relevant_cons = filter is_relevant data_cons
is_relevant con = all (`elem` dataConFieldLabels con) upd_field_lbls
in
-- Check that at least one constructor has all the named fields
-- i.e. has an empty set of bad fields returned by badFields
checkTc (not (null relevant_cons))
- (badFieldsUpd rbinds) `thenM_`
+ (badFieldsUpd hrbinds) `thenM_`
-- Check that all relevant data cons are vanilla. Doing record updates on
-- GADTs and/or existentials is more than my tiny brain can cope with today
let
-- A constructor is only relevant to this process if
-- it contains *all* the fields that are being updated
- con1 = head relevant_cons -- A representative constructor
- con1_tyvars = dataConUnivTyVars con1
- con1_flds = dataConFieldLabels con1
- con1_arg_tys = dataConOrigArgTys con1
- common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
- , not (fld `elem` upd_field_lbls) ]
+ con1 = ASSERT( not (null relevant_cons) ) head relevant_cons -- A representative constructor
+ (con1_tyvars, theta, con1_arg_tys, con1_res_ty) = dataConSig con1
+ con1_flds = dataConFieldLabels con1
+ common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
+ , not (fld `elem` upd_field_lbls) ]
is_common_tv tv = tv `elemVarSet` common_tyvars
| is_common_tv tv = returnM result_inst_ty -- Same as result type
| otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind
in
- tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, inst_env) ->
- zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ inst_tys ->
+ ASSERT( null theta ) -- Vanilla datacon
+ tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, result_inst_env) ->
+ zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ scrut_inst_tys ->
- -- STEP 3
- -- Typecheck the update bindings.
- -- (Do this after checking for bad fields in case there's a field that
- -- doesn't match the constructor.)
+ -- STEP 3: Typecheck the update bindings.
+ -- Do this after checking for bad fields in case
+ -- there's a field that doesn't match the constructor.
let
- result_record_ty = mkTyConApp tycon result_inst_tys
- con1_arg_tys' = map (substTy inst_env) con1_arg_tys
+ result_ty = substTy result_inst_env con1_res_ty
+ con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
in
- tcSubExp result_record_ty res_ty `thenM` \ co_fn ->
- tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' ->
+ tcSubExp result_ty res_ty `thenM` \ co_fn ->
+ tcRecordBinds con1 con1_arg_tys' hrbinds `thenM` \ rbinds' ->
- -- STEP 5
- -- Typecheck the expression to be updated
+ -- STEP 5: Typecheck the expression to be updated
let
- record_ty = ASSERT( length inst_tys == tyConArity tycon )
- mkTyConApp tycon inst_tys
+ scrut_inst_env = zipTopTvSubst con1_tyvars scrut_inst_tys
+ scrut_ty = substTy scrut_inst_env con1_res_ty
-- This is one place where the isVanilla check is important
- -- So that inst_tys matches the tycon
+ -- So that inst_tys matches the con1_tyvars
in
- tcMonoExpr record_expr record_ty `thenM` \ record_expr' ->
+ tcMonoExpr record_expr scrut_ty `thenM` \ record_expr' ->
- -- STEP 6
- -- Figure out the LIE we need. We have to generate some
- -- dictionaries for the data type context, since we are going to
- -- do pattern matching over the data cons.
+ -- STEP 6: Figure out the LIE we need.
+ -- We have to generate some dictionaries for the data type context,
+ -- since we are going to do pattern matching over the data cons.
--
- -- What dictionaries do we need? The tyConStupidTheta tells us.
+ -- What dictionaries do we need? The dataConStupidTheta tells us.
let
- theta' = substTheta inst_env (tyConStupidTheta tycon)
+ theta' = substTheta scrut_inst_env (dataConStupidTheta con1)
in
instStupidTheta RecordUpdOrigin theta' `thenM_`
+ -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
+ let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
+ = WpCo $ mkTyConApp co_con scrut_inst_tys
+ | otherwise
+ = idHsWrapper
+ scrut_ty = mkTyConApp tycon scrut_inst_tys -- Type of pattern, the result of the cast
+ in
-- Phew!
- returnM (mkHsWrap co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
+ returnM (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
+ relevant_cons scrut_inst_tys result_inst_tys))
\end{code}
; go True fun ty_theta_prs' }
where
subst_pr (tvs, theta)
- = (map (substTyVar subst) tvs, substTheta subst theta)
+ = (substTyVars subst tvs, substTheta subst theta)
go _ fun [] = return fun
; qtys' <- mapM refineBox qtys -- Exploit new info
; (qtys'', args') <- go (n+1) qtys' args arg_tys
; return (qtys'', arg':args') }
+ go n qtys args arg_tys = panic "tcArgs"
tcArg :: LHsExpr Name -- The function
-> Int -- and arg number (for error messages)
%************************************************************************
%* *
-\subsection{@tcId@ typchecks an identifier occurrence}
+\subsection{@tcId@ typechecks an identifier occurrence}
%* *
%************************************************************************
-> HsRecordBinds Name
-> TcM (HsRecordBinds TcId)
-tcRecordBinds data_con arg_tys rbinds
+tcRecordBinds data_con arg_tys (HsRecordBinds rbinds)
= do { mb_binds <- mappM do_bind rbinds
- ; return (catMaybes mb_binds) }
+ ; return (HsRecordBinds (catMaybes mb_binds)) }
where
flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
do_bind (L loc field_lbl, rhs)
= hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
nonVanillaUpd tycon
- = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") <+> quotes (ppr tycon)
+ = vcat [ptext SLIT("Record update for the non-Haskell-98 data type")
+ <+> quotes (pprSourceTyCon tycon)
<+> ptext SLIT("is not (yet) supported"),
ptext SLIT("Use pattern-matching instead")]
badFieldsUpd rbinds
= ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
<+> pprWithCommas ppr fields
-callCtxt fun args
- = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
+-- callCtxt fun args = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
#ifdef GHCI
polySpliceErr :: Id -> SDoc