-tcExpr in_expr@(ExplicitList exprs) -- Non-empty list
- = tcExprs exprs `thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
- tcAddErrCtxt (listCtxt in_expr) $
- unifyTauTyList tys `thenTc_`
- returnTc (ExplicitListOut elt_ty exprs', lie, mkListTy elt_ty)
-
-tcExpr (ExplicitTuple exprs)
- = tcExprs exprs `thenTc` \ (exprs', lie, tys) ->
- returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
-
-tcExpr (RecordCon con rbinds)
- = panic "tcExpr:RecordCon"
-tcExpr (RecordUpd exp rbinds)
- = panic "tcExpr:RecordUpd"
-
-tcExpr (ArithSeqIn seq@(From expr))
- = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
-
- tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
- newMethod (ArithSeqOrigin seq)
- (RealId sel_id) [ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
-
- returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
- lie1 `plusLIE` lie2,
- mkListTy ty)
+ -- Typecheck the record bindings
+ tcRecordBinds tycon ty_args rbinds `thenTc` \ (rbinds', rbinds_lie) ->
+
+ let
+ missing_s_fields = missingStrictFields rbinds data_con
+ in
+ checkTcM (null missing_s_fields)
+ (mapNF_Tc (addErrTc . missingStrictFieldCon con_name) missing_s_fields `thenNF_Tc_`
+ returnNF_Tc ()) `thenNF_Tc_`
+ let
+ missing_fields = missingFields rbinds data_con
+ in
+ doptsTc Opt_WarnMissingFields `thenNF_Tc` \ warn ->
+ checkTcM (not (warn && not (null missing_fields)))
+ (mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_`
+ returnNF_Tc ()) `thenNF_Tc_`
+
+ returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
+
+-- The main complication with RecordUpd is that we need to explicitly
+-- handle the *non-updated* fields. Consider:
+--
+-- data T a b = MkT1 { fa :: a, fb :: b }
+-- | MkT2 { fa :: a, fc :: Int -> Int }
+-- | MkT3 { fd :: a }
+--
+-- upd :: T a b -> c -> T a c
+-- upd t x = t { fb = x}
+--
+-- The type signature on upd is correct (i.e. the result should not be (T a b))
+-- because upd should be equivalent to:
+--
+-- upd t x = case t of
+-- MkT1 p q -> MkT1 p x
+-- MkT2 a b -> MkT2 p b
+-- MkT3 d -> error ...
+--
+-- So we need to give a completely fresh type to the result record,
+-- and then constrain it by the fields that are *not* updated ("p" above).
+--
+-- Note that because MkT3 doesn't contain all the fields being updated,
+-- its RHS is simply an error, so it doesn't impose any type constraints
+--
+-- All this is done in STEP 4 below.
+
+tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
+ = tcAddErrCtxt (recordUpdCtxt expr) $
+
+ -- STEP 0
+ -- Check that the field names are really field names
+ ASSERT( not (null rbinds) )
+ let
+ field_names = [field_name | (field_name, _, _) <- rbinds]
+ in
+ mapNF_Tc tcLookupGlobal_maybe field_names `thenNF_Tc` \ maybe_sel_ids ->
+ let
+ bad_guys = [ addErrTc (notSelector field_name)
+ | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
+ case maybe_sel_id of
+ Just (AnId sel_id) -> not (isRecordSelector sel_id)
+ other -> True
+ ]
+ in
+ checkTcM (null bad_guys) (listNF_Tc bad_guys `thenNF_Tc_` failTc) `thenTc_`
+
+ -- STEP 1
+ -- Figure out the tycon and data cons from the first field name
+ let
+ (Just (AnId sel_id) : _) = maybe_sel_ids
+ (_, _, tau) = splitSigmaTy (idType sel_id) -- Selectors can be overloaded
+ -- when the data type has a context
+ Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector
+ (tycon, _, data_cons) = splitAlgTyConApp data_ty
+ (con_tyvars, _, _, _, _, _) = dataConSig (head data_cons)
+ in
+ tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
+
+ -- STEP 2
+ -- Check that at least one constructor has all the named fields
+ -- i.e. has an empty set of bad fields returned by badFields
+ checkTc (any (null . badFields rbinds) data_cons)
+ (badFieldsUpd rbinds) `thenTc_`
+
+ -- 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
+ in
+ unifyTauTy res_ty result_record_ty `thenTc_`
+ tcRecordBinds tycon result_inst_tys rbinds `thenTc` \ (rbinds', rbinds_lie) ->
+
+ -- STEP 4
+ -- Use the un-updated fields to find a vector of booleans saying
+ -- which type arguments must be the same in updatee and result.
+ --
+ -- WARNING: this code assumes that all data_cons in a common tycon
+ -- have FieldLabels abstracted over the same tyvars.
+ let
+ upd_field_lbls = [recordSelectorFieldLabel sel_id | (sel_id, _, _) <- rbinds']
+ con_field_lbls_s = map dataConFieldLabels data_cons