\section[TcExpr]{Typecheck an expression}
\begin{code}
-module TcExpr ( tcExpr, tcPolyExpr, tcId ) where
+module TcExpr ( tcApp, tcExpr, tcPolyExpr, tcId ) where
#include "HsVersions.h"
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
import TcHsSyn ( TcExpr, TcRecordBinds,
- mkHsTyApp, maybeBoxedPrimType
+ 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,
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}
%************************************************************************
\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
-- Figure out the tycon and data cons from the first field name
let
(Just sel_id : _) = maybe_sel_ids
- (_, tau) = splitForAllTys (idType sel_id)
+ (_, 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)
-- 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 (mkArrowKind boxedTypeKind boxedTypeKind) `thenNF_Tc` \ m ->
newTyVarTy boxedTypeKind `thenNF_Tc` \ elt_ty ->
unifyTauTy res_ty (mkAppTy m elt_ty) `thenTc_`
+
-- 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.)
ListComp -> unifyListTy res_ty `thenTc_` returnTc ()
_ -> returnTc ()) `thenTc_`
- tcStmts do_or_lc (mkAppTy m) stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
+ 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,
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
projects / ghc-hetmet.git / blobdiff