#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- HsBinds(..), Stmt(..), StmtCtxt(..),
- mkMonoBind
+ HsBinds(..), MonoBinds(..), Stmt(..), StmtCtxt(..),
+ mkMonoBind, nullMonoBinds
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
-import TcHsSyn ( TcExpr, TcRecordBinds,
- mkHsTyApp, mkHsLet, maybeBoxedPrimType
+import TcHsSyn ( TcExpr, TcRecordBinds, mkHsConApp,
+ mkHsTyApp, mkHsLet
)
import TcMonad
import BasicTypes ( RecFlag(..) )
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
- LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
- newMethod, instOverloadedFun, newDicts, instToId )
+ LIE, emptyLIE, unitLIE, consLIE, plusLIE, plusLIEs,
+ lieToList, listToLIE,
+ newOverloadedLit, newMethod, newIPDict,
+ instOverloadedFun, newDicts, newClassDicts,
+ getIPsOfLIE, instToId, ipToId
+ )
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcInstId,
tcLookupValue, tcLookupClassByKey,
tcLookupTyCon, tcLookupDataCon
)
import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
-import TcMonoType ( tcHsType, checkSigTyVars, sigCtxt )
+import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt )
import TcPat ( badFieldCon )
-import TcSimplify ( tcSimplifyAndCheck )
+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,
- Id
+import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
+import Id ( idType, recordSelectorFieldLabel, isRecordSelector,
+ Id, mkVanillaId
)
-import DataCon ( dataConFieldLabels, dataConSig, dataConId,
+import DataCon ( dataConFieldLabels, dataConSig,
dataConStrictMarks, StrictnessMark(..)
)
-import Name ( Name )
+import Name ( Name, getName )
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, substTheta )
+import TyCon ( tyConTyVars )
+import Subst ( mkTopTyVarSubst, substClasses, substTy )
import UsageSPUtils ( unannotTy )
-import VarSet ( elemVarSet, mkVarSet )
+import VarSet ( emptyVarSet, unionVarSet, elemVarSet, mkVarSet )
import TyCon ( tyConDataCons )
import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
floatPrimTy, addrPrimTy
-> 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}
tcInstTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
let
(sig_theta, sig_tau) = splitRhoTy sig_rho
+ free_tyvars = tyVarsOfType expected_arg_ty
in
-- Type-check the arg and unify with expected type
tcMonoExpr arg sig_tau `thenTc` \ (arg', lie_arg) ->
-- Conclusion: include the free vars of the expected arg type in the
-- list of "free vars" for the signature check.
- tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) $
- tcAddErrCtxtM (sigCtxt sig_msg expected_arg_ty) $
+ tcExtendGlobalTyVars free_tyvars $
+ tcAddErrCtxtM (sigCtxt sig_msg sig_tyvars sig_theta sig_tau) $
- checkSigTyVars sig_tyvars `thenTc` \ zonked_sig_tyvars ->
+ 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")
returnTc ( generalised_arg, free_insts,
arg', sig_tau, lie_arg )
where
- sig_msg ty = sep [ptext SLIT("In an expression with expected type:"),
- nest 4 (ppr ty)]
+ sig_msg = ptext SLIT("When checking an expression type signature")
\end{code}
%************************************************************************
\begin{code}
tcMonoExpr :: RenamedHsExpr -- Expession to type check
- -> TcTauType -- Expected type (could be a type variable)
+ -> TcTauType -- Expected type (could be a type variable)
-> TcM s (TcExpr, LIE)
tcMonoExpr (HsVar name) res_ty
returnTc (expr', lie)
\end{code}
+\begin{code}
+tcMonoExpr (HsIPVar name) res_ty
+ -- ZZ What's the `id' used for here...
+ = let id = mkVanillaId name res_ty in
+ tcGetInstLoc (OccurrenceOf id) `thenNF_Tc` \ loc ->
+ newIPDict name res_ty loc `thenNF_Tc` \ ip ->
+ returnNF_Tc (HsIPVar (instToId ip), unitLIE ip)
+\end{code}
+
%************************************************************************
%* *
\subsection{Literals}
tcMonoExpr (HsLit lit@(HsLitLit s)) res_ty
= tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
- newDicts (LitLitOrigin (_UNPK_ s))
- [(cCallableClass, [res_ty])] `thenNF_Tc` \ (dicts, _) ->
+ newClassDicts (LitLitOrigin (_UNPK_ s))
+ [(cCallableClass,[res_ty])] `thenNF_Tc` \ (dicts, _) ->
returnTc (HsLitOut lit res_ty, dicts)
\end{code}
later use.
\begin{code}
-tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
+tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
= -- Get the callable and returnable classes.
tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
tcLookupTyCon ioTyCon_NAME `thenNF_Tc` \ ioTyCon ->
let
new_arg_dict (arg, arg_ty)
- = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
- [(cCallableClass, [arg_ty])] `thenNF_Tc` \ (arg_dicts, _) ->
+ = newClassDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
+ [(cCallableClass, [arg_ty])] `thenNF_Tc` \ (arg_dicts, _) ->
returnNF_Tc arg_dicts -- Actually a singleton bag
result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
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_`
-- Construct the extra insts, which encode the
-- constraints on the argument and result types.
mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
- newDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
- returnTc (HsApp (HsVar (dataConId ioDataCon) `TyApp` [result_ty])
- (CCall lbl args' may_gc is_asm result_ty),
- -- do the wrapping in the newtype constructor here
+ newClassDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
+ returnTc (HsCCall lbl args' may_gc is_asm io_result_ty,
foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
\end{code}
let
(_, record_ty) = splitFunTys con_tau
in
- -- Con is syntactically constrained to be a data constructor
ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
unifyTauTy res_ty record_ty `thenTc_`
-- Check that the record bindings match the constructor
+ -- con_name is syntactically constrained to be a data constructor
tcLookupDataCon con_name `thenTc` \ (data_con, _, _) ->
let
bad_fields = badFields rbinds data_con
-- 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, _) ->
let
(tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
inst_env = mkTopTyVarSubst tyvars result_inst_tys
- theta' = substTheta inst_env theta
+ theta' = substClasses inst_env theta
in
- newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
+ newClassDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
-- Phew!
returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
\begin{code}
tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
= tcSetErrCtxt (exprSigCtxt in_expr) $
- tcHsType poly_ty `thenTc` \ sig_tc_ty ->
+ 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
returnTc (expr, lie)
\end{code}
+Implicit Parameter bindings.
+
+\begin{code}
+tcMonoExpr (HsWith expr binds) res_ty
+ = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
+ tcIPBinds binds `thenTc` \ (binds', types, lie2) ->
+ partitionPredsOfLIE isBound lie `thenTc` \ (ips, lie', dict_binds) ->
+ let expr'' = if nullMonoBinds dict_binds
+ then expr'
+ else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive)
+ expr'
+ in
+ tcCheckIPBinds binds' types ips `thenTc_`
+ returnTc (HsWith expr'' binds', lie' `plusLIE` lie2)
+ where isBound p
+ = case ipName_maybe p of
+ Just n -> n `elem` names
+ Nothing -> False
+ names = map fst binds
+ -- revBinds is used because tcSimplify outputs the bindings
+ -- out-of-order. it's not a problem elsewhere because these
+ -- bindings are normally used in a recursive let
+ -- ZZ probably need to find a better solution
+ revBinds (b1 `AndMonoBinds` b2) =
+ (revBinds b2) `AndMonoBinds` (revBinds b1)
+ revBinds b = b
+
+tcIPBinds ((name, expr) : binds)
+ = newTyVarTy_OpenKind `thenTc` \ ty ->
+ tcGetSrcLoc `thenTc` \ loc ->
+ let id = ipToId name ty loc in
+ tcMonoExpr expr ty `thenTc` \ (expr', lie) ->
+ zonkTcType ty `thenTc` \ ty' ->
+ tcIPBinds binds `thenTc` \ (binds', types, lie2) ->
+ returnTc ((id, expr') : binds', ty : types, lie `plusLIE` lie2)
+tcIPBinds [] = returnTc ([], [], emptyLIE)
+
+tcCheckIPBinds binds types ips
+ = foldrTc tcCheckIPBind (getIPsOfLIE ips) (zip binds types)
+
+-- ZZ how do we use the loc?
+tcCheckIPBind bt@((v, _), t1) ((n, t2) : ips) | getName v == n
+ = unifyTauTy t1 t2 `thenTc_`
+ tcCheckIPBind bt ips `thenTc` \ ips' ->
+ returnTc ips'
+tcCheckIPBind bt (ip : ips)
+ = tcCheckIPBind bt ips `thenTc` \ ips' ->
+ returnTc (ip : ips')
+tcCheckIPBind bt []
+ = returnTc []
+\end{code}
+
Typecheck expression which in most cases will be an Id.
\begin{code}
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