\section[TcExpr]{Typecheck an expression}
\begin{code}
-module TcExpr ( tcExpr, tcPolyExpr, tcId ) where
+module TcExpr ( tcApp, tcExpr, tcPolyExpr, tcId ) where
#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- HsBinds(..), Stmt(..), StmtCtxt(..),
- failureFreePat
+ HsBinds(..), Stmt(..), StmtCtxt(..)
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
import TcHsSyn ( TcExpr, TcRecordBinds,
- mkHsTyApp
+ mkHsTyApp, mkHsLet, maybeBoxedPrimType
)
import TcMonad
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
- newMethod, newMethodWithGivenTy, newDicts, instToId )
+ newMethod, instOverloadedFun, newDicts, instToId )
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcInstId,
tcLookupValue, tcLookupClassByKey,
import DataCon ( dataConFieldLabels, dataConSig, dataConId )
import Name ( Name )
import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
- splitFunTy_maybe, splitFunTys,
+ splitFunTy_maybe, splitFunTys, isNotUsgTy,
mkTyConApp,
splitForAllTys, splitRhoTy,
isTauTy, tyVarsOfType, tyVarsOfTypes,
isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
boxedTypeKind, mkArrowKind,
- substTopTheta, tidyOpenType
+ tidyOpenType
)
-import VarEnv ( zipVarEnv )
+import Subst ( mkTopTyVarSubst, substTheta )
+import UsageSPUtils ( unannotTy )
import VarSet ( elemVarSet, mkVarSet )
import TyCon ( tyConDataCons )
import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
import Unique ( cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
- thenMClassOpKey, zeroClassOpKey, returnMClassOpKey
+ thenMClassOpKey, failMClassOpKey, returnMClassOpKey
)
import Outputable
import Maybes ( maybeToBool )
newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
-- ToDo: better origin
tcSimplifyAndCheck
- (text "tcPolyExpr")
+ (text "the type signature of an expression")
(mkVarSet zonked_sig_tyvars)
sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) ->
-- a couple of new names which seems worse.
generalised_arg = TyLam zonked_sig_tyvars $
DictLam dict_ids $
- HsLet (MonoBind inst_binds [] Recursive)
+ mkHsLet inst_binds $
arg'
in
returnTc ( generalised_arg, free_insts,
arg', sig_tau, lie_arg )
where
- sig_msg ty = ptext SLIT("In an expression with expected type:") <+> ppr ty
+ sig_msg ty = sep [ptext SLIT("In an expression with expected type:"),
+ nest 4 (ppr ty)]
\end{code}
%************************************************************************
in
-- Arguments
- mapNF_Tc (\ _ -> newTyVarTy_OpenKind) [1..(length args)] `thenNF_Tc` \ arg_tys ->
- tcMonoExprs args arg_tys `thenTc` \ (args', args_lie) ->
+ let n_args = length args
+ tv_idxs | n_args == 0 = []
+ | otherwise = [1..n_args]
+ in
+ mapNF_Tc (\ _ -> newTyVarTy_OpenKind) tv_idxs `thenNF_Tc` \ arg_tys ->
+ tcMonoExprs args arg_tys `thenTc` \ (args', args_lie) ->
-- The argument types can be unboxed or boxed; the result
-- type must, however, be boxed since it's an argument to the IO
-- 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
\end{code}
\begin{code}
-tcMonoExpr (HsSCC label expr) res_ty
+tcMonoExpr (HsSCC lbl expr) res_ty
= tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
- returnTc (HsSCC label expr', lie)
+ returnTc (HsSCC lbl expr', lie)
tcMonoExpr (HsLet binds expr) res_ty
= tcBindsAndThen
tcMonoExpr (RecordUpd record_expr rbinds) res_ty
= tcAddErrCtxt recordUpdCtxt $
- -- STEP 1
- -- Figure out the tycon and data cons from the first field name
+ -- STEP 0
+ -- Check that the field names are really field names
ASSERT( not (null rbinds) )
let
- ((first_field_name, _, _) : rest) = rbinds
+ field_names = [field_name | (field_name, _, _) <- rbinds]
in
- tcLookupValueMaybe first_field_name `thenNF_Tc` \ maybe_sel_id ->
- (case maybe_sel_id of
- Just sel_id | isRecordSelector sel_id -> returnTc sel_id
- other -> failWithTc (notSelector first_field_name)
- ) `thenTc` \ sel_id ->
+ mapNF_Tc tcLookupValueMaybe field_names `thenNF_Tc` \ maybe_sel_ids ->
+ let
+ bad_guys = [field_name | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
+ case maybe_sel_id of
+ Nothing -> True
+ Just sel_id -> not (isRecordSelector sel_id)
+ ]
+ in
+ mapNF_Tc (addErrTc . notSelector) bad_guys `thenTc_`
+ if not (null bad_guys) then
+ failTc
+ else
+
+ -- STEP 1
+ -- Figure out the tycon and data cons from the first field name
let
- (_, tau) = splitForAllTys (idType sel_id)
+ (Just sel_id : _) = maybe_sel_ids
+ (_, tau) = ASSERT( isNotUsgTy (idType sel_id) )
+ splitForAllTys (idType sel_id)
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)
tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
-- STEP 2
- -- Check for bad fields
+ -- 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
-- union the ones that could participate in the update.
let
(tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
- inst_env = zipVarEnv tyvars result_inst_tys
- theta' = substTopTheta inst_env theta
+ inst_env = mkTopTyVarSubst tyvars result_inst_tys
+ theta' = substTheta inst_env theta
in
newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
\begin{code}
-tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
- -> TcType -- Expected result type of application
- -> TcM s (TcExpr, [TcExpr], -- Translated fun and args
+tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
+ -> TcType -- Expected result type of application
+ -> TcM s (TcExpr, [TcExpr], -- Translated fun and args
LIE)
tcApp fun args res_ty
%* *
%************************************************************************
+Between the renamer and the first invocation of the UsageSP inference,
+identifiers read from interface files will have usage information in
+their types, whereas other identifiers will not. The unannotTy here
+in @tcId@ prevents this information from pointlessly propagating
+further prior to the first usage inference.
+
\begin{code}
tcId :: Name -> NF_TcM s (TcExpr, LIE, TcType)
tcLookupValueMaybe name `thenNF_Tc` \ maybe_local ->
case maybe_local of
- Just tc_id -> instantiate_it tc_id (idType tc_id)
+ Just tc_id -> instantiate_it (OccurrenceOf tc_id) (HsVar tc_id) (unannotTy (idType tc_id))
Nothing -> tcLookupValue name `thenNF_Tc` \ id ->
tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) ->
- instantiate_it2 id tyvars theta tau
+ instantiate_it2 (OccurrenceOf id) (HsVar id) tyvars theta tau
where
-- The instantiate_it loop runs round instantiating the Id.
-- f:: forall a. Eq a => forall b. Baz b => tau
-- We want to instantiate this to
-- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
- instantiate_it tc_id_occ ty
+ instantiate_it orig fun ty
= tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) ->
- instantiate_it2 tc_id_occ tyvars theta tau
+ instantiate_it2 orig fun tyvars theta tau
- instantiate_it2 tc_id_occ tyvars theta tau
+ instantiate_it2 orig fun tyvars theta tau
= if null theta then -- Is it overloaded?
- returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
+ returnNF_Tc (mkHsTyApp fun arg_tys, emptyLIE, tau)
else
-- Yes, it's overloaded
- newMethodWithGivenTy (OccurrenceOf tc_id_occ)
- tc_id_occ arg_tys theta tau `thenNF_Tc` \ inst ->
- instantiate_it (instToId inst) tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
- returnNF_Tc (expr, unitLIE inst `plusLIE` lie2, final_tau)
+ instOverloadedFun orig fun arg_tys theta tau `thenNF_Tc` \ (fun', lie1) ->
+ instantiate_it orig fun' tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
+ returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
where
- arg_tys = mkTyVarTys tyvars
+ arg_tys = mkTyVarTys tyvars
\end{code}
%************************************************************************
newTyVarTy boxedTypeKind `thenNF_Tc` \ elt_ty ->
unifyTauTy res_ty (mkAppTy m elt_ty) `thenTc_`
- tcStmts do_or_lc (mkAppTy m) stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
+ -- If it's a comprehension we're dealing with,
+ -- force it to be a list comprehension.
+ -- (as of Haskell 98, monad comprehensions are no more.)
+ (case do_or_lc of
+ ListComp -> unifyListTy res_ty `thenTc_` returnTc ()
+ _ -> returnTc ()) `thenTc_`
+
+ tcStmts do_or_lc (mkAppTy m) stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
-- Build the then and zero methods in case we need them
-- It's important that "then" and "return" appear just once in the final LIE,
--
tcLookupValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id ->
tcLookupValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
- tcLookupValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
+ tcLookupValueByKey failMClassOpKey `thenNF_Tc` \ fail_sel_id ->
newMethod DoOrigin return_sel_id [m] `thenNF_Tc` \ (return_lie, return_id) ->
newMethod DoOrigin then_sel_id [m] `thenNF_Tc` \ (then_lie, then_id) ->
- newMethod DoOrigin zero_sel_id [m] `thenNF_Tc` \ (zero_lie, zero_id) ->
+ newMethod DoOrigin fail_sel_id [m] `thenNF_Tc` \ (fail_lie, fail_id) ->
let
- monad_lie = then_lie `plusLIE` return_lie `plusLIE` perhaps_zero_lie
- perhaps_zero_lie | all failure_free stmts' = emptyLIE
- | otherwise = zero_lie
-
- failure_free (BindStmt pat _ _) = failureFreePat pat
- failure_free (GuardStmt _ _) = False
- failure_free other_stmt = True
+ monad_lie = then_lie `plusLIE` return_lie `plusLIE` fail_lie
in
- returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id res_ty src_loc,
+ returnTc (HsDoOut do_or_lc stmts' return_id then_id fail_id res_ty src_loc,
stmts_lie `plusLIE` monad_lie)
\end{code}
Mini-utils:
\begin{code}
pp_nest_hang :: String -> SDoc -> SDoc
-pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff)
+pp_nest_hang lbl stuff = nest 2 (hang (text lbl) 4 stuff)
\end{code}
Boring and alphabetical:
the_app = foldl HsApp fun args -- Used in error messages
appCtxt fun args
- = ptext SLIT("In the application") <+> (ppr the_app)
+ = ptext SLIT("In the application") <+> quotes (ppr the_app)
where
the_app = foldl HsApp fun args -- Used in error messages
notSelector field
= hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
+
+illegalCcallTyErr isArg ty
+ = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in _ccall_ or _casm_:")])
+ 4 (hsep [ppr ty])
+ where
+ arg_or_res
+ | isArg = ptext SLIT("argument")
+ | otherwise = ptext SLIT("result")
+
+
\end{code}
projects / ghc-hetmet.git / blobdiff