%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcExpr]{Typecheck an expression}
#ifdef GHCI /* Only if bootstrapped */
import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
-import HsSyn ( nlHsVar )
-import Id ( Id, idName )
-import Name ( isExternalName )
-import TcType ( isTauTy )
-import TcEnv ( checkWellStaged )
-import HsSyn ( nlHsApp )
import qualified DsMeta
#endif
-import HsSyn ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
- HsMatchContext(..), HsRecordBinds, mkHsWrap, hsExplicitTvs,
- mkHsApp, mkLHsWrap )
-import TcHsSyn ( hsLitType )
+import HsSyn
+import TcHsSyn
import TcRnMonad
-import TcUnify ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
- boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, preSubType,
- unBox )
-import BasicTypes ( Arity, isMarkedStrict )
-import Inst ( newMethodFromName, newIPDict, instCall,
- newMethodWithGivenTy, instStupidTheta )
-import TcBinds ( tcLocalBinds )
-import TcEnv ( tcLookup, tcLookupDataCon, tcLookupField, tcExtendTyVarEnv2 )
-import TcArrows ( tcProc )
-import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcBody,
- TcMatchCtxt(..) )
-import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
-import TcPat ( tcOverloadedLit, addDataConStupidTheta, badFieldCon )
-import TcMType ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars,
- readFilledBox, zonkTcTypes )
-import TcType ( TcType, TcSigmaType, TcRhoType, TvSubst,
- BoxySigmaType, BoxyRhoType, ThetaType,
- mkTyVarTys, mkFunTys,
- tcMultiSplitSigmaTy, tcSplitFunTysN,
- tcSplitTyConApp_maybe,
- isSigmaTy, mkFunTy, mkTyConApp,
- exactTyVarsOfType, exactTyVarsOfTypes,
- zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar
- )
-import {- Kind parts of -}
- Type ( argTypeKind )
-
-import Id ( idType, recordSelectorFieldLabel,
- isRecordSelector, isNaughtyRecordSelector,
- isDataConId_maybe )
-import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks,
- dataConSourceArity,
- dataConWrapId, isVanillaDataCon, dataConUnivTyVars,
- dataConOrigArgTys )
-import Name ( Name )
-import TyCon ( FieldLabel, tyConStupidTheta, tyConDataCons,
- isEnumerationTyCon )
-import Type ( substTheta, substTy )
-import Var ( TyVar, tyVarKind )
-import VarSet ( emptyVarSet, elemVarSet, unionVarSet )
-import TysWiredIn ( boolTy, parrTyCon, tupleTyCon )
-import PrelNames ( enumFromName, enumFromThenName,
- enumFromToName, enumFromThenToName,
- enumFromToPName, enumFromThenToPName, negateName,
- hasKey
- )
-import PrimOp ( tagToEnumKey )
-
+import TcUnify
+import BasicTypes
+import Inst
+import TcBinds
+import TcEnv
+import TcArrows
+import TcMatches
+import TcHsType
+import TcPat
+import TcMType
+import TcType
+import TcIface ( checkWiredInTyCon )
+import Id
+import DataCon
+import Name
+import TyCon
+import Type
+import Var
+import VarSet
+import TysWiredIn
+import PrelNames
+import PrimOp
import DynFlags
-import StaticFlags ( opt_NoMethodSharing )
-import HscTypes ( TyThing(..) )
-import SrcLoc ( Located(..), unLoc )
+import StaticFlags
+import HscTypes
+import SrcLoc
import Util
-import ListSetOps ( assocMaybe )
-import Maybes ( catMaybes )
+import ListSetOps
+import Maybes
import Outputable
import FastString
-
-#ifdef DEBUG
-import TyCon ( tyConArity )
-#endif
\end{code}
%************************************************************************
= do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr)
-- Note the recursive call to tcPolyExpr, because the
-- type may have multiple layers of for-alls
+ -- E.g. forall a. Eq a => forall b. Ord b => ....
; return (mkLHsWrap gen_fn expr') }
| otherwise
tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
; returnM (HsSCC lbl expr') }
+tcExpr (HsTickPragma info expr) res_ty
+ = do { expr' <- tcMonoExpr expr res_ty
+ ; returnM (HsTickPragma info expr') }
tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation
= do { expr' <- tcMonoExpr expr res_ty
where
doc = ptext SLIT("The section") <+> quotes (ppr in_expr)
<+> ptext SLIT("takes one argument")
- tc_args arg1_ty' [arg1_ty, arg2_ty]
- = do { boxyUnify arg1_ty' arg1_ty
- ; tcArg lop (arg2, arg2_ty, 2) }
- tc_args arg1_ty' other = panic "tcExpr SectionR"
+ tc_args arg1_ty' qtvs qtys [arg1_ty, arg2_ty]
+ = do { boxyUnify arg1_ty' (substTyWith qtvs qtys arg1_ty)
+ ; arg2' <- tcArg lop 2 arg2 qtvs qtys arg2_ty
+ ; qtys' <- mapM refineBox qtys -- c.f. tcArgs
+ ; return (qtys', arg2') }
+ tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"
\end{code}
\begin{code}
where
tc_elt elt_ty expr = tcPolyExpr expr elt_ty
+-- For tuples, take care to preserve rigidity
+-- E.g. case (x,y) of ....
+-- The scrutinee should have a rigid type if x,y do
+-- The general scheme is the same as in tcIdApp
tcExpr (ExplicitTuple exprs boxity) res_ty
- = do { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length exprs)) res_ty
- ; exprs' <- tcPolyExprs exprs arg_tys
- ; return (ExplicitTuple exprs' boxity) }
+ = do { tvs <- newBoxyTyVars [argTypeKind | e <- exprs]
+ ; let tup_tc = tupleTyCon boxity (length exprs)
+ tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs)
+ ; checkWiredInTyCon tup_tc -- Ensure instances are available
+ ; arg_tys <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty
+ ; exprs' <- tcPolyExprs exprs arg_tys
+ ; arg_tys' <- mapM refineBox arg_tys
+ ; co_fn <- tcFunResTy (tyConName tup_tc) (mkTyConApp tup_tc arg_tys') res_ty
+ ; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) }
tcExpr (HsProc pat cmd) res_ty
= do { (pat', cmd') <- tcProc pat cmd res_ty
; checkMissingFields data_con rbinds
; let arity = dataConSourceArity data_con
- check_fields arg_tys
- = do { rbinds' <- tcRecordBinds data_con arg_tys rbinds
- ; mapM unBox arg_tys
- ; return rbinds' }
- -- The unBox ensures that all the boxes in arg_tys are indeed
+ check_fields qtvs qtys arg_tys
+ = do { let arg_tys' = substTys (zipOpenTvSubst qtvs qtys) arg_tys
+ ; rbinds' <- tcRecordBinds data_con arg_tys' rbinds
+ ; qtys' <- mapM refineBoxToTau qtys
+ ; return (qtys', rbinds') }
+ -- The refineBoxToTau ensures that all the boxes in arg_tys are indeed
-- filled, which is the invariant expected by tcIdApp
+ -- How could this not be the case? Consider a record construction
+ -- that does not mention all the fields.
; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty
-- don't know how to do the update otherwise.
-tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
+tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
= -- STEP 0
-- Check that the field names are really field names
- ASSERT( notNull rbinds )
let
- field_names = map fst rbinds
+ field_names = hsRecFields rbinds
in
- mappM (tcLookupField . unLoc) field_names `thenM` \ sel_ids ->
+ ASSERT( notNull field_names )
+ mappM tcLookupField field_names `thenM` \ sel_ids ->
-- The renamer has already checked that they
-- are all in scope
let
bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name)
- | (L loc field_name, sel_id) <- field_names `zip` sel_ids,
- not (isRecordSelector sel_id) -- Excludes class ops
+ | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
+ not (isRecordSelector sel_id), -- Excludes class ops
+ let L loc field_name = hsRecFieldId fld
]
in
checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM) `thenM_`
-- Figure out the tycon and data cons from the first field name
let
-- It's OK to use the non-tc splitters here (for a selector)
- upd_field_lbls = recBindFields rbinds
sel_id : _ = sel_ids
(tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
- data_cons = tyConDataCons tycon -- it's not a field label
+ data_cons = tyConDataCons tycon -- it's not a field label
+ -- NB: for a data type family, the tycon is the instance tycon
+
relevant_cons = filter is_relevant data_cons
- is_relevant con = all (`elem` dataConFieldLabels con) upd_field_lbls
+ is_relevant con = all (`elem` dataConFieldLabels con) field_names
in
-- STEP 2
let
-- A constructor is only relevant to this process if
-- it contains *all* the fields that are being updated
- con1 = head relevant_cons -- A representative constructor
- con1_tyvars = dataConUnivTyVars con1
- con1_flds = dataConFieldLabels con1
- con1_arg_tys = dataConOrigArgTys con1
- common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
- , not (fld `elem` upd_field_lbls) ]
+ con1 = ASSERT( not (null relevant_cons) ) head relevant_cons -- A representative constructor
+ (con1_tyvars, theta, con1_arg_tys, con1_res_ty) = dataConSig con1
+ con1_flds = dataConFieldLabels con1
+ common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
+ , not (fld `elem` field_names) ]
is_common_tv tv = tv `elemVarSet` common_tyvars
| is_common_tv tv = returnM result_inst_ty -- Same as result type
| otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind
in
- tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, inst_env) ->
- zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ inst_tys ->
+ ASSERT( null theta ) -- Vanilla datacon
+ tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, result_inst_env) ->
+ zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ scrut_inst_tys ->
- -- STEP 3
- -- Typecheck the update bindings.
- -- (Do this after checking for bad fields in case there's a field that
- -- doesn't match the constructor.)
+ -- STEP 3: Typecheck the update bindings.
+ -- Do this after checking for bad fields in case
+ -- there's a field that doesn't match the constructor.
let
- result_record_ty = mkTyConApp tycon result_inst_tys
- con1_arg_tys' = map (substTy inst_env) con1_arg_tys
+ result_ty = substTy result_inst_env con1_res_ty
+ con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
in
- tcSubExp result_record_ty res_ty `thenM` \ co_fn ->
+ tcSubExp result_ty res_ty `thenM` \ co_fn ->
tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' ->
- -- STEP 5
- -- Typecheck the expression to be updated
+ -- STEP 5: Typecheck the expression to be updated
let
- record_ty = ASSERT( length inst_tys == tyConArity tycon )
- mkTyConApp tycon inst_tys
+ scrut_inst_env = zipTopTvSubst con1_tyvars scrut_inst_tys
+ scrut_ty = substTy scrut_inst_env con1_res_ty
-- This is one place where the isVanilla check is important
- -- So that inst_tys matches the tycon
+ -- So that inst_tys matches the con1_tyvars
in
- tcMonoExpr record_expr record_ty `thenM` \ record_expr' ->
+ tcMonoExpr record_expr scrut_ty `thenM` \ record_expr' ->
- -- STEP 6
- -- Figure out the LIE we need. We have to generate some
- -- dictionaries for the data type context, since we are going to
- -- do pattern matching over the data cons.
+ -- STEP 6: Figure out the LIE we need.
+ -- We have to generate some dictionaries for the data type context,
+ -- since we are going to do pattern matching over the data cons.
--
- -- What dictionaries do we need? The tyConStupidTheta tells us.
+ -- What dictionaries do we need? The dataConStupidTheta tells us.
let
- theta' = substTheta inst_env (tyConStupidTheta tycon)
+ theta' = substTheta scrut_inst_env (dataConStupidTheta con1)
in
instStupidTheta RecordUpdOrigin theta' `thenM_`
+ -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
+ let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
+ = WpCo $ mkTyConApp co_con scrut_inst_tys
+ | otherwise
+ = idHsWrapper
+ in
-- Phew!
- returnM (mkHsWrap co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
+ returnM (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
+ relevant_cons scrut_inst_tys result_inst_tys))
\end{code}
---------------------------
tcApp :: HsExpr Name -- Function
-> Arity -- Number of args reqd
- -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker
+ -> ArgChecker results
-> BoxyRhoType -- Result type
- -> TcM (HsExpr TcId, arg_results)
+ -> TcM (HsExpr TcId, results)
-- (tcFun fun n_args arg_checker res_ty)
-- The argument type checker, arg_checker, will be passed exactly n_args types
= tcIdApp fun_name n_args arg_checker res_ty
tcApp fun n_args arg_checker res_ty -- The vanilla case (rula APP)
- = do { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind)
- ; fun' <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
- ; arg_tys' <- mapM readFilledBox arg_boxes
- ; args' <- arg_checker arg_tys'
+ = do { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind)
+ ; fun' <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
+ ; arg_tys' <- mapM readFilledBox arg_boxes
+ ; (_, args') <- arg_checker [] [] arg_tys' -- Yuk
; return (fun', args') }
---------------------------
tcIdApp :: Name -- Function
-> Arity -- Number of args reqd
- -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker
- -- The arg-checker guarantees to fill all boxes in the arg types
+ -> ArgChecker results -- The arg-checker guarantees to fill all boxes in the arg types
-> BoxyRhoType -- Result type
- -> TcM (HsExpr TcId, arg_results)
+ -> TcM (HsExpr TcId, results)
-- Call (f e1 ... en) :: res_ty
-- Type f :: forall a b c. theta => fa_1 -> ... -> fa_k -> fres
; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
res_ty' = mkFunTys extra_arg_tys' res_ty
; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty'
- ; let arg_subst = zipOpenTvSubst qtvs qtys'
- fun_arg_tys' = substTys arg_subst fun_arg_tys
-- Typecheck the arguments!
-- Doing so will fill arg_qtvs and extra_arg_tys'
- ; args' <- arg_checker (fun_arg_tys' ++ extra_arg_tys')
+ ; (qtys'', args') <- arg_checker qtvs qtys' (fun_arg_tys ++ extra_arg_tys')
-- Strip boxes from the qtvs that have been filled in by the arg checking
- -- AND any variables that are mentioned in neither arg nor result
- -- the latter are mentioned only in constraints; stripBoxyType will
- -- fill them with a monotype
- ; let strip qtv qty' | qtv `elemVarSet` arg_qtvs = stripBoxyType qty'
- | otherwise = return qty'
- ; qtys'' <- zipWithM strip qtvs qtys'
; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes
-- Result subsumption
+ -- This fills in res_qtvs
; let res_subst = zipOpenTvSubst qtvs qtys''
fun_res_ty'' = substTy res_subst fun_res_ty
res_ty'' = mkFunTys extra_arg_tys'' res_ty
-- By applying the coercion just to the *function* we can make
-- tcFun work nicely for OpApp and Sections too
; fun' <- instFun orig fun res_subst tv_theta_prs
- ; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn
+ ; co_fn' <- wrapFunResCoercion (substTys res_subst fun_arg_tys) co_fn
; return (mkHsWrap co_fn' fun', args') }
\end{code}
; go True fun ty_theta_prs' }
where
subst_pr (tvs, theta)
- = (map (substTyVar subst) tvs, substTheta subst theta)
+ = (substTyVars subst tvs, substTheta subst theta)
go _ fun [] = return fun
a) it's better for RULEs involving overloaded functions
b) perhaps fewer separated lambdas
+Note [Left to right]
+~~~~~~~~~~~~~~~~~~~~
+tcArgs implements a left-to-right order, which goes beyond what is described in the
+impredicative type inference paper. In particular, it allows
+ runST $ foo
+where runST :: (forall s. ST s a) -> a
+When typechecking the application of ($)::(a->b) -> a -> b, we first check that
+runST has type (a->b), thereby filling in a=forall s. ST s a. Then we un-box this type
+before checking foo. The left-to-right order really helps here.
+
\begin{code}
tcArgs :: LHsExpr Name -- The function (for error messages)
- -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types
- -> TcM [LHsExpr TcId] -- Resulting args
+ -> [LHsExpr Name] -- Actual args
+ -> ArgChecker [LHsExpr TcId]
-tcArgs fun args expected_arg_tys
- = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
+type ArgChecker results
+ = [TyVar] -> [TcSigmaType] -- Current instantiation
+ -> [TcSigmaType] -- Expected arg types (**before** applying the instantiation)
+ -> TcM ([TcSigmaType], results) -- Resulting instaniation and args
-tcArg :: LHsExpr Name -- The function (for error messages)
- -> (LHsExpr Name, BoxySigmaType, Int) -- Actual argument and expected arg type
- -> TcM (LHsExpr TcId) -- Resulting argument
-tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $
- tcPolyExprNC arg ty
+tcArgs fun args qtvs qtys arg_tys
+ = go 1 qtys args arg_tys
+ where
+ go n qtys [] [] = return (qtys, [])
+ go n qtys (arg:args) (arg_ty:arg_tys)
+ = do { arg' <- tcArg fun n arg qtvs qtys arg_ty
+ ; qtys' <- mapM refineBox qtys -- Exploit new info
+ ; (qtys'', args') <- go (n+1) qtys' args arg_tys
+ ; return (qtys'', arg':args') }
+ go n qtys args arg_tys = panic "tcArgs"
+
+tcArg :: LHsExpr Name -- The function
+ -> Int -- and arg number (for error messages)
+ -> LHsExpr Name
+ -> [TyVar] -> [TcSigmaType] -- Instantiate the arg type like this
+ -> BoxySigmaType
+ -> TcM (LHsExpr TcId) -- Resulting argument
+tcArg fun arg_no arg qtvs qtys ty
+ = addErrCtxt (funAppCtxt fun arg arg_no) $
+ tcPolyExprNC arg (substTyWith qtvs qtys ty)
\end{code}
%************************************************************************
%* *
-\subsection{@tcId@ typchecks an identifier occurrence}
+\subsection{@tcId@ typechecks an identifier occurrence}
%* *
%************************************************************************
-> HsRecordBinds Name
-> TcM (HsRecordBinds TcId)
-tcRecordBinds data_con arg_tys rbinds
+tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
= do { mb_binds <- mappM do_bind rbinds
- ; return (catMaybes mb_binds) }
+ ; return (HsRecFields (catMaybes mb_binds) dd) }
where
flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
- do_bind (L loc field_lbl, rhs)
+ do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
| Just field_ty <- assocMaybe flds_w_tys field_lbl
= addErrCtxt (fieldCtxt field_lbl) $
do { rhs' <- tcPolyExprNC rhs field_ty
; sel_id <- tcLookupField field_lbl
; ASSERT( isRecordSelector sel_id )
- return (Just (L loc sel_id, rhs')) }
+ return (Just (fld { hsRecFieldId = L loc sel_id, hsRecFieldArg = rhs' })) }
| otherwise
= do { addErrTc (badFieldCon data_con field_lbl)
; return Nothing }
not (fl `elem` field_names_used)
]
- field_names_used = recBindFields rbinds
+ field_names_used = hsRecFields rbinds
field_labels = dataConFieldLabels data_con
field_info = zipEqual "missingFields"
= hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
nonVanillaUpd tycon
- = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") <+> quotes (ppr tycon)
+ = vcat [ptext SLIT("Record update for the non-Haskell-98 data type")
+ <+> quotes (pprSourceTyCon tycon)
<+> ptext SLIT("is not (yet) supported"),
ptext SLIT("Use pattern-matching instead")]
badFieldsUpd rbinds
= hang (ptext SLIT("No constructor has all these fields:"))
- 4 (pprQuotedList (recBindFields rbinds))
+ 4 (pprQuotedList (hsRecFields rbinds))
naughtyRecordSel sel_id
= ptext SLIT("Cannot use record selector") <+> quotes (ppr sel_id) <+>
= ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
<+> pprWithCommas ppr fields
-callCtxt fun args
- = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
+-- callCtxt fun args = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
#ifdef GHCI
polySpliceErr :: Id -> SDoc