\section[TcExpr]{Typecheck an expression}
\begin{code}
-module TcExpr ( tcPolyExpr, tcPolyExprNC,
- tcMonoExpr, tcInferRho, tcSyntaxOp ) where
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
+module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcSyntaxOp ) where
#include "HsVersions.h"
import Maybes
import Outputable
import FastString
+
+import Control.Monad
\end{code}
%************************************************************************
---------------
tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
-tcPolyExprs [] [] = returnM []
+tcPolyExprs [] [] = return []
tcPolyExprs (expr:exprs) (ty:tys)
= do { expr' <- tcPolyExpr expr ty
; exprs' <- tcPolyExprs exprs tys
- ; returnM (expr':exprs') }
+ ; return (expr':exprs') }
tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
---------------
tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
; coi <- boxyUnify lit_ty res_ty
- ; return $ wrapExprCoI (HsLit lit) coi
+ ; return $ mkHsWrapCoI coi (HsLit lit)
}
tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
; return (HsPar expr') }
tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
- ; returnM (HsSCC lbl expr') }
+ ; return (HsSCC lbl expr') }
tcExpr (HsTickPragma info expr) res_ty
= do { expr' <- tcMonoExpr expr res_ty
- ; returnM (HsTickPragma info expr') }
+ ; return (HsTickPragma info expr') }
tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation
= do { expr' <- tcMonoExpr expr res_ty
; return (HsOverLit lit') }
tcExpr (NegApp expr neg_expr) res_ty
- = do { neg_expr' <- tcSyntaxOp (OccurrenceOf negateName) neg_expr
+ = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
(mkFunTy res_ty res_ty)
; expr' <- tcMonoExpr expr res_ty
; return (NegApp expr' neg_expr') }
tcExpr (HsIPVar ip) res_ty
- = do { -- Implicit parameters must have a *tau-type* not a
+ = do { let origin = IPOccOrigin ip
+ -- Implicit parameters must have a *tau-type* not a
-- type scheme. We enforce this by creating a fresh
-- type variable as its type. (Because res_ty may not
-- be a tau-type.)
- ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple
- ; co_fn <- tcSubExp ip_ty res_ty
- ; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty
+ ; ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple
+ ; co_fn <- tcSubExp origin ip_ty res_ty
+ ; (ip', inst) <- newIPDict origin ip ip_ty
; extendLIE inst
; return (mkHsWrap co_fn (HsIPVar ip')) }
tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
tcPolyExprNC expr res_ty)
- ; co_fn <- tcSubExp sig_tc_ty res_ty
+ ; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty
; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
tcExpr (HsType ty) res_ty
= tcDoStmts do_or_lc stmts body res_ty
tcExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list
- = do { elt_ty <- boxySplitListTy res_ty
- ; exprs' <- mappM (tc_elt elt_ty) exprs
- ; return (ExplicitList elt_ty exprs') }
- where
- tc_elt elt_ty expr = tcPolyExpr expr elt_ty
-{- TODO: Version from Tom's original patch. Unfortunately, we cannot do it this
- way, but need to teach boxy splitters about match deferral and coercions.
- = do { elt_tv <- newBoxyTyVar argTypeKind
- ; let elt_ty = TyVarTy elt_tv
- ; coi <- boxyUnify (mkTyConApp listTyCon [elt_ty]) res_ty
- -- ; elt_ty <- boxySplitListTy res_ty
- ; exprs' <- mappM (tc_elt elt_ty) exprs
- ; return $ wrapExprCoI (ExplicitList elt_ty exprs') coi }
- -- ; return (ExplicitList elt_ty exprs') }
+ = do { (elt_ty, coi) <- boxySplitListTy res_ty
+ ; exprs' <- mapM (tc_elt elt_ty) exprs
+ ; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') }
where
tc_elt elt_ty expr = tcPolyExpr expr elt_ty
- -}
tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty
- = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
- ; exprs' <- mappM (tc_elt elt_ty) exprs
- ; ifM (null exprs) (zapToMonotype elt_ty)
+ = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
+ ; exprs' <- mapM (tc_elt elt_ty) exprs
+ ; when (null exprs) (zapToMonotype elt_ty >> return ())
-- If there are no expressions in the comprehension
-- we must still fill in the box
-- (Not needed for [] and () becuase they happen
-- to parse as data constructors.)
- ; return (ExplicitPArr elt_ty exprs') }
+ ; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') }
where
tc_elt elt_ty expr = tcPolyExpr expr elt_ty
; 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
+ ; co_fn <- tcSubExp TupleOrigin (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
- ; return (HsProc pat' cmd') }
+ = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
+ ; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
tcExpr e@(HsArrApp _ _ _ _ _) _
= failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty
- ; returnM (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
+ ; return (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
-- The main complication with RecordUpd is that we need to explicitly
-- handle the *non-updated* fields. Consider:
-- don't know how to do the update otherwise.
-tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
- = -- STEP 0
+tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty = do
+ -- STEP 0
-- Check that the field names are really field names
let
field_names = hsRecFields rbinds
- in
- ASSERT( notNull field_names )
- mappM tcLookupField field_names `thenM` \ sel_ids ->
+
+ MASSERT( notNull field_names )
+ sel_ids <- mapM tcLookupField field_names
-- The renamer has already checked that they
-- are all in scope
let
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_`
+
+ unless (null bad_guys) (sequence bad_guys >> failM)
-- STEP 1
-- Figure out the tycon and data cons from the first field name
relevant_cons = filter is_relevant data_cons
is_relevant con = all (`elem` dataConFieldLabels con) field_names
- in
-- STEP 2
-- Check that at least one constructor has all the named fields
-- i.e. has an empty set of bad fields returned by badFields
checkTc (not (null relevant_cons))
- (badFieldsUpd rbinds) `thenM_`
+ (badFieldsUpd rbinds)
-- Check that all relevant data cons are vanilla. Doing record updates on
-- GADTs and/or existentials is more than my tiny brain can cope with today
checkTc (all isVanillaDataCon relevant_cons)
- (nonVanillaUpd tycon) `thenM_`
+ (nonVanillaUpd tycon)
-- STEP 4
-- Use the un-updated fields to find a vector of booleans saying
is_common_tv tv = tv `elemVarSet` common_tyvars
mk_inst_ty tv result_inst_ty
- | is_common_tv tv = returnM result_inst_ty -- Same as result type
+ | is_common_tv tv = return result_inst_ty -- Same as result type
| otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind
- in
- 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 ->
+
+ MASSERT( null theta ) -- Vanilla datacon
+ (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tyvars
+ scrut_inst_tys <- zipWithM mk_inst_ty con1_tyvars result_inst_tys
-- STEP 3: Typecheck the update bindings.
-- Do this after checking for bad fields in case
let
result_ty = substTy result_inst_env con1_res_ty
con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
- in
- tcSubExp result_ty res_ty `thenM` \ co_fn ->
- tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' ->
+ origin = RecordUpdOrigin
+
+ co_fn <- tcSubExp origin result_ty res_ty
+ rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds
-- STEP 5: Typecheck the expression to be updated
let
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 con1_tyvars
- in
- tcMonoExpr record_expr scrut_ty `thenM` \ record_expr' ->
+
+ record_expr' <- tcMonoExpr record_expr scrut_ty
-- STEP 6: Figure out the LIE we need.
-- We have to generate some dictionaries for the data type context,
-- What dictionaries do we need? The dataConStupidTheta tells us.
let
theta' = substTheta scrut_inst_env (dataConStupidTheta con1)
- in
- instStupidTheta RecordUpdOrigin theta' `thenM_`
+
+ instStupidTheta origin theta'
-- 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 (mkLHsWrap scrut_co record_expr') rbinds'
+ return (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
relevant_cons scrut_inst_tys result_inst_tys))
\end{code}
\begin{code}
tcExpr (ArithSeq _ seq@(From expr)) res_ty
- = do { elt_ty <- boxySplitListTy res_ty
+ = do { (elt_ty, coi) <- boxySplitListTy res_ty
; expr' <- tcPolyExpr expr elt_ty
; enum_from <- newMethodFromName (ArithSeqOrigin seq)
elt_ty enumFromName
- ; return (ArithSeq (HsVar enum_from) (From expr')) }
+ ; return $ mkHsWrapCoI coi (ArithSeq (HsVar enum_from) (From expr')) }
tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
- = do { elt_ty <- boxySplitListTy res_ty
+ = do { (elt_ty, coi) <- boxySplitListTy res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
elt_ty enumFromThenName
- ; return (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) }
-
+ ; return $ mkHsWrapCoI coi
+ (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) }
tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
- = do { elt_ty <- boxySplitListTy res_ty
+ = do { (elt_ty, coi) <- boxySplitListTy res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
elt_ty enumFromToName
- ; return (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
+ ; return $ mkHsWrapCoI coi
+ (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
- = do { elt_ty <- boxySplitListTy res_ty
+ = do { (elt_ty, coi) <- boxySplitListTy res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; expr3' <- tcPolyExpr expr3 elt_ty
; eft <- newMethodFromName (ArithSeqOrigin seq)
elt_ty enumFromThenToName
- ; return (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
+ ; return $ mkHsWrapCoI coi
+ (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
- = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
+ = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
elt_ty enumFromToPName
- ; return (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
+ ; return $ mkHsWrapCoI coi
+ (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
- = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
+ = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; expr3' <- tcPolyExpr expr3 elt_ty
; eft <- newMethodFromName (PArrSeqOrigin seq)
elt_ty enumFromThenToPName
- ; return (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
+ ; return $ mkHsWrapCoI coi
+ (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
tcExpr (PArrSeq _ _) _
= panic "TcExpr.tcMonoExpr: Infinite parallel array!"
tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
tcExpr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty
; return (unLoc e) }
+tcExpr e@(HsQuasiQuoteE _) res_ty =
+ pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e)
#endif /* GHCI */
\end{code}
; let res_subst = zipOpenTvSubst qtvs qtys''
fun_res_ty'' = substTy res_subst fun_res_ty
res_ty'' = mkFunTys extra_arg_tys'' res_ty
- ; co_fn <- tcFunResTy fun_name fun_res_ty'' res_ty''
+ ; co_fn <- tcSubExp orig fun_res_ty'' res_ty''
-- And pack up the results
-- By applying the coercion just to the *function* we can make
; let res_subst = zipTopTvSubst qtvs qtv_tys
fun_tau' = substTy res_subst fun_tau
- ; co_fn <- tcFunResTy fun_name fun_tau' res_ty
+ ; co_fn <- tcSubExp orig fun_tau' res_ty
-- And pack up the results
; fun' <- instFun orig fun res_subst tv_theta_prs
--------------------------------------
thBrackId orig id ps_var lie_var
- | isExternalName id_name
+ | thTopLevelId id
= -- Top-level identifiers in this module,
-- (which have External Names)
-- are just like the imported case:
-- But we do need to put f into the keep-alive
-- set, because after desugaring the code will
-- only mention f's *name*, not f itself.
- do { keepAliveTc id_name; return id }
+ do { keepAliveTc id; return id }
| otherwise
= -- Nested identifiers, such as 'x' in
-- Update the pending splices
; ps <- readMutVar ps_var
- ; writeMutVar ps_var ((id_name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
+ ; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
; return id } }
- where
- id_name = idName id
#endif /* GHCI */
\end{code}
-> TcM (HsRecordBinds TcId)
tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
- = do { mb_binds <- mappM do_bind rbinds
+ = do { mb_binds <- mapM do_bind rbinds
; return (HsRecFields (catMaybes mb_binds) dd) }
where
flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
-- Illegal if any arg is strict
addErrTc (missingStrictFields data_con [])
else
- returnM ()
+ return ()
- | otherwise -- A record
- = checkM (null missing_s_fields)
- (addErrTc (missingStrictFields data_con missing_s_fields)) `thenM_`
+ | otherwise = do -- A record
+ unless (null missing_s_fields)
+ (addErrTc (missingStrictFields data_con missing_s_fields))
- doptM Opt_WarnMissingFields `thenM` \ warn ->
- checkM (not (warn && notNull missing_ns_fields))
+ warn <- doptM Opt_WarnMissingFields
+ unless (not (warn && notNull missing_ns_fields))
(warnTc True (missingFields data_con missing_ns_fields))
where
= ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id)
#endif
\end{code}
-
-\begin{code}
-wrapExprCoI :: HsExpr a -> CoercionI -> HsExpr a
-wrapExprCoI expr IdCo = expr
-wrapExprCoI expr (ACo co) = mkHsWrap (WpCo co) expr
-\end{code}