tcLookupValue, tcLookupClassByKey,
tcLookupValueByKey,
tcExtendGlobalTyVars, tcLookupValueMaybe,
- tcLookupTyCon, tcLookupDataCon
+ tcLookupTyConByKey, tcLookupDataCon
)
import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt )
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,
boxedTypeKind, mkArrowKind,
tidyOpenType
)
-import Subst ( mkTopTyVarSubst, substClasses )
+import TyCon ( TyCon, tyConTyVars )
+import Subst ( mkTopTyVarSubst, substClasses, substTy )
import UsageSPUtils ( unannotTy )
import VarSet ( emptyVarSet, unionVarSet, elemVarSet, mkVarSet )
import TyCon ( tyConDataCons )
floatPrimTy, addrPrimTy
)
import TysWiredIn ( boolTy, charTy, stringTy )
-import PrelInfo ( ioTyCon_NAME )
-import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy,
- unifyUnboxedTupleTy )
+import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
import Unique ( cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
- thenMClassOpKey, failMClassOpKey, returnMClassOpKey
+ thenMClassOpKey, failMClassOpKey, returnMClassOpKey, ioTyConKey
)
import Outputable
import Maybes ( maybeToBool, mapMaybe )
= -- Get the callable and returnable classes.
tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
- tcLookupTyCon ioTyCon_NAME `thenNF_Tc` \ ioTyCon ->
+ tcLookupTyConByKey ioTyConKey `thenNF_Tc` \ ioTyCon ->
let
new_arg_dict (arg, arg_ty)
= newClassDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
= tcAddErrCtxt (listCtxt expr) $
tcMonoExpr expr elt_ty
-tcMonoExpr (ExplicitTuple exprs boxed) res_ty
- = (if boxed
- then unifyTupleTy (length exprs) res_ty
- else unifyUnboxedTupleTy (length exprs) res_ty
- ) `thenTc` \ arg_tys ->
+tcMonoExpr (ExplicitTuple exprs boxity) res_ty
+ = unifyTupleTy boxity (length exprs) res_ty `thenTc` \ arg_tys ->
mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty)
(exprs `zip` arg_tys) -- we know they're of equal length.
`thenTc` \ (exprs', lies) ->
- returnTc (ExplicitTuple exprs' boxed, plusLIEs lies)
+ returnTc (ExplicitTuple exprs' boxity, plusLIEs lies)
tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
= tcAddErrCtxt (recordConCtxt expr) $
tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
let
(_, record_ty) = splitFunTys con_tau
+ (tycon, ty_args, _) = splitAlgTyConApp record_ty
in
ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
unifyTauTy res_ty record_ty `thenTc_`
else
-- Typecheck the record bindings
- tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
+ tcRecordBinds tycon ty_args rbinds `thenTc` \ (rbinds', rbinds_lie) ->
let
missing_s_fields = missingStrictFields rbinds data_con
result_record_ty = mkTyConApp tycon result_inst_tys
in
unifyTauTy res_ty result_record_ty `thenTc_`
- tcRecordBinds result_record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
+ tcRecordBinds tycon result_inst_tys rbinds `thenTc` \ (rbinds', rbinds_lie) ->
-- STEP 4
-- Use the un-updated fields to find a vector of booleans saying
tcLookupValueMaybe name `thenNF_Tc` \ maybe_local ->
case maybe_local of
- Just tc_id -> instantiate_it (OccurrenceOf tc_id) (HsVar tc_id) (unannotTy (idType tc_id))
+ Just tc_id -> instantiate_it (OccurrenceOf tc_id) tc_id (unannotTy (idType tc_id))
Nothing -> tcLookupValue name `thenNF_Tc` \ id ->
tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) ->
- instantiate_it2 (OccurrenceOf id) (HsVar id) tyvars theta tau
+ instantiate_it2 (OccurrenceOf id) id tyvars theta tau
where
-- The instantiate_it loop runs round instantiating the Id.
instantiate_it2 orig fun tyvars theta tau
= if null theta then -- Is it overloaded?
- returnNF_Tc (mkHsTyApp fun arg_tys, emptyLIE, tau)
+ returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
else
-- Yes, it's overloaded
instOverloadedFun orig fun arg_tys theta tau `thenNF_Tc` \ (fun', lie1) ->
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
- :: TcType -- Expected type of whole record
+ :: TyCon -- Type constructor for the record
+ -> [TcType] -- Args of this type constructor
-> RenamedRecordBinds
-> TcM s (TcRecordBinds, LIE)
-tcRecordBinds expected_record_ty rbinds
+tcRecordBinds tycon ty_args rbinds
= mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
returnTc (rbinds', plusLIEs lies)
where
- do_bind (field_label, rhs, pun_flag)
- = tcLookupValue field_label `thenNF_Tc` \ sel_id ->
+ tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args
+
+ do_bind (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
projects / ghc-hetmet.git / blobdiff