tcLookupValue, tcLookupClassByKey,
tcLookupValueByKey,
tcExtendGlobalTyVars, tcLookupValueMaybe,
- tcLookupTyCon, tcLookupDataCon
+ tcLookupTyConByKey, tcLookupDataCon
)
import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt )
import TcType ( TcType, TcTauType,
tcInstTyVars,
tcInstTcType, tcSplitRhoTy,
- newTyVarTy, newTyVarTy_OpenKind, zonkTcType )
+ newTyVarTy, newTyVarTys, zonkTcType )
-import Class ( Class )
import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
import Id ( idType, recordSelectorFieldLabel, isRecordSelector,
Id, mkVanillaId
splitRhoTy,
isTauTy, tyVarsOfType, tyVarsOfTypes,
isSigmaTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
- boxedTypeKind, mkArrowKind,
+ boxedTypeKind, openTypeKind, mkArrowKind,
tidyOpenType
)
-import TyCon ( tyConTyVars )
+import TyCon ( TyCon, tyConTyVars )
import Subst ( mkTopTyVarSubst, substClasses, substTy )
import UsageSPUtils ( unannotTy )
import VarSet ( emptyVarSet, unionVarSet, elemVarSet, mkVarSet )
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))
tv_idxs | n_args == 0 = []
| otherwise = [1..n_args]
in
- mapNF_Tc (\ _ -> newTyVarTy_OpenKind) tv_idxs `thenNF_Tc` \ arg_tys ->
+ newTyVarTys (length tv_idxs) openTypeKind `thenNF_Tc` \ arg_tys ->
tcMonoExprs args arg_tys `thenTc` \ (args', args_lie) ->
-- The argument types can be unboxed or boxed; the result
= 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
revBinds b = b
tcIPBinds ((name, expr) : binds)
- = newTyVarTy_OpenKind `thenTc` \ ty ->
+ = newTyVarTy openTypeKind `thenTc` \ ty ->
tcGetSrcLoc `thenTc` \ loc ->
let id = ipToId name ty loc in
tcMonoExpr expr ty `thenTc` \ (expr', lie) ->
= case id_expr of
HsVar name -> tcId name `thenNF_Tc` \ stuff ->
returnTc stuff
- other -> newTyVarTy_OpenKind `thenNF_Tc` \ id_ty ->
+ other -> newTyVarTy openTypeKind `thenNF_Tc` \ id_ty ->
tcMonoExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) ->
returnTc (id_expr', lie_id, id_ty)
\end{code}
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) ->
\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
- = 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) ->
+tcRecordBinds tycon ty_args rbinds
+ = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
returnTc (rbinds', plusLIEs lies)
where
- (first_field_lbl_name, _, _) = head rbinds
+ tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args
- do_bind tycon tenv (field_lbl_name, rhs, pun_flag)
+ do_bind (field_lbl_name, rhs, pun_flag)
= tcLookupValue field_lbl_name `thenNF_Tc` \ sel_id ->
let
field_lbl = recordSelectorFieldLabel sel_id
projects / ghc-hetmet.git / blobdiff