import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt )
import TcPat ( badFieldCon )
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, partitionPredsOfLIE )
+import TcImprove ( tcImprove )
import TcType ( TcType, TcTauType,
tcInstTyVars,
tcInstTcType, tcSplitRhoTy,
newTyVarTy, newTyVarTy_OpenKind, zonkTcType )
import Class ( Class )
-import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType
- )
-import Id ( idType, recordSelectorFieldLabel,
- isRecordSelector,
+import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
+import Id ( idType, recordSelectorFieldLabel, isRecordSelector,
Id, mkVanillaId
)
import DataCon ( dataConFieldLabels, dataConSig,
import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
ipName_maybe,
splitFunTy_maybe, splitFunTys, isNotUsgTy,
- mkTyConApp,
- splitForAllTys, splitRhoTy,
+ mkTyConApp, splitSigmaTy,
+ splitRhoTy,
isTauTy, tyVarsOfType, tyVarsOfTypes,
- isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
+ isSigmaTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
boxedTypeKind, mkArrowKind,
tidyOpenType
)
-import Subst ( mkTopTyVarSubst, substClasses )
+import TyCon ( tyConTyVars )
+import Subst ( mkTopTyVarSubst, substClasses, substTy )
import UsageSPUtils ( unannotTy )
import VarSet ( emptyVarSet, unionVarSet, elemVarSet, mkVarSet )
import TyCon ( tyConDataCons )
-> TcType -- Expected type (could be a polytpye)
-> TcM s (TcExpr, LIE)
-tcExpr expr ty | isForAllTy ty = -- Polymorphic case
- tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) ->
+tcExpr expr ty | isSigmaTy ty = -- Polymorphic case
+ tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) ->
returnTc (expr', lie)
- | otherwise = -- Monomorphic case
- tcMonoExpr expr ty
+ | otherwise = -- Monomorphic case
+ tcMonoExpr expr ty
\end{code}
checkSigTyVars sig_tyvars free_tyvars `thenTc` \ zonked_sig_tyvars ->
newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
+ tcImprove (sig_dicts `plusLIE` lie_arg) `thenTc_`
-- ToDo: better origin
tcSimplifyAndCheck
(text "the type signature of an expression")
newTyVarTy boxedTypeKind `thenNF_Tc` \ result_ty ->
let
io_result_ty = mkTyConApp ioTyCon [result_ty]
- [ioDataCon] = tyConDataCons ioTyCon
in
unifyTauTy res_ty io_result_ty `thenTc_`
-- Figure out the tycon and data cons from the first field name
let
(Just sel_id : _) = maybe_sel_ids
- (_, tau) = ASSERT( isNotUsgTy (idType sel_id) )
- splitForAllTys (idType sel_id)
+ (_, _, tau) = ASSERT( isNotUsgTy (idType sel_id) )
+ 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, theta, _, _, _, _) = dataConSig (head data_cons)
+ (tycon, _, data_cons) = splitAlgTyConApp data_ty
+ (con_tyvars, _, _, _, _, _) = dataConSig (head data_cons)
in
tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
= tcSetErrCtxt (exprSigCtxt in_expr) $
tcHsSigType poly_ty `thenTc` \ sig_tc_ty ->
- if not (isForAllTy sig_tc_ty) then
+ if not (isSigmaTy sig_tc_ty) then
-- Easy case
unifyTauTy sig_tc_ty res_ty `thenTc_`
tcMonoExpr expr sig_tc_ty
= tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
tcIPBinds binds `thenTc` \ (binds', types, lie2) ->
partitionPredsOfLIE isBound lie `thenTc` \ (ips, lie', dict_binds) ->
- pprTrace "tcMonoExpr With" (ppr (ips, lie', dict_binds)) $
let expr'' = if nullMonoBinds dict_binds
then expr'
else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive)
Game plan for record bindings
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For each binding
- field = value
-1. look up "field", to find its selector Id, which must have type
- forall a1..an. T a1 .. an -> tau
- where tau is the type of the field.
+1. Find the TyCon for the bindings, from the first field label.
+
+2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
-2. Instantiate this type
+For each binding field = value
-3. Unify the (T a1 .. an) part with the "expected result type", which
- is passed in. This checks that all the field labels come from the
- same type.
+3. Instantiate the field type (from the field label) using the type
+ envt from step 2.
-4. Type check the value using tcArg, passing tau as the expected
- argument type.
+4 Type check the value using tcArg, passing the field type as
+ the expected argument type.
This extends OK when the field types are universally quantified.
-Actually, to save excessive creation of fresh type variables,
-we
\begin{code}
tcRecordBinds
-> TcM s (TcRecordBinds, LIE)
tcRecordBinds expected_record_ty rbinds
- = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
+ = tcLookupValue first_field_lbl_name `thenNF_Tc` \ first_sel_id ->
+ let
+ tycon = fieldLabelTyCon (recordSelectorFieldLabel first_sel_id)
+ in
+ tcInstTyVars (tyConTyVars tycon) `thenTc` \ (_, arg_tys, tenv) ->
+ unifyTauTy expected_record_ty
+ (mkTyConApp tycon arg_tys) `thenTc_`
+ mapAndUnzipTc (do_bind tycon tenv) rbinds `thenTc` \ (rbinds', lies) ->
returnTc (rbinds', plusLIEs lies)
where
- do_bind (field_label, rhs, pun_flag)
- = tcLookupValue field_label `thenNF_Tc` \ sel_id ->
+ (first_field_lbl_name, _, _) = head rbinds
+
+ do_bind tycon tenv (field_lbl_name, rhs, pun_flag)
+ = tcLookupValue field_lbl_name `thenNF_Tc` \ sel_id ->
+ let
+ field_lbl = recordSelectorFieldLabel sel_id
+ field_ty = substTy tenv (fieldLabelType field_lbl)
+ in
ASSERT( isRecordSelector sel_id )
-- This lookup and assertion will surely succeed, because
-- we check that the fields are indeed record selectors
-- before calling tcRecordBinds
+ ASSERT2( fieldLabelTyCon field_lbl == tycon, ppr field_lbl )
+ -- The caller of tcRecordBinds has already checked
+ -- that all the fields come from the same type
- tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
+ tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie, _, _, _) ->
- -- Record selectors all have type
- -- forall a1..an. T a1 .. an -> tau
- ASSERT( maybeToBool (splitFunTy_maybe tau) )
- let
- -- Selector must have type RecordType -> FieldType
- Just (record_ty, field_ty) = splitFunTy_maybe tau
- in
- unifyTauTy expected_record_ty record_ty `thenTc_`
- tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie, _, _, _) ->
returnTc ((sel_id, rhs', pun_flag), lie)
badFields rbinds data_con