X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=b4abd3d0296a07398f180ba6b1a90d19d9df507d;hb=4c6a3f787abcaed009a574196d82237d9ae64fc8;hp=206629cebf9005ad8b83ed3dc7aedeb439e0687e;hpb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 206629c..b4abd3d 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -12,7 +12,7 @@ -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcSyntaxOp) where +module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcSyntaxOp ) where #include "HsVersions.h" @@ -57,6 +57,8 @@ import ListSetOps import Maybes import Outputable import FastString + +import Control.Monad \end{code} %************************************************************************ @@ -94,11 +96,11 @@ tcPolyExprNC expr res_ty --------------- 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) --------------- @@ -139,10 +141,10 @@ 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 @@ -153,19 +155,20 @@ tcExpr (HsOverLit lit) 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')) } @@ -192,7 +195,7 @@ tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty 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 @@ -289,15 +292,15 @@ tcExpr (HsDo do_or_lc stmts body _) res_ty tcExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list = do { (elt_ty, coi) <- boxySplitListTy res_ty - ; exprs' <- mappM (tc_elt elt_ty) exprs + ; 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, coi) <- boxySplitPArrTy res_ty - ; exprs' <- mappM (tc_elt elt_ty) exprs - ; ifM (null exprs) (zapToMonotype elt_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 @@ -318,7 +321,7 @@ tcExpr (ExplicitTuple exprs boxity) res_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 @@ -360,7 +363,7 @@ tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty ; (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: @@ -395,14 +398,14 @@ tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty -- 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 @@ -411,8 +414,8 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty 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 @@ -425,18 +428,17 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty 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 @@ -456,12 +458,12 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty 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 @@ -469,9 +471,10 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty 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 @@ -479,8 +482,8 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty 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, @@ -489,17 +492,17 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty -- 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} @@ -586,6 +589,8 @@ tcExpr (PArrSeq _ _) _ 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} @@ -679,7 +684,7 @@ tcIdApp fun_name n_args arg_checker res_ty ; 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 @@ -726,7 +731,7 @@ tcId orig fun_name res_ty ; 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 @@ -1001,7 +1006,7 @@ thLocalId orig id id_ty th_bind_lvl -------------------------------------- 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: @@ -1012,7 +1017,7 @@ thBrackId orig id ps_var lie_var -- 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 @@ -1044,11 +1049,9 @@ thBrackId orig id ps_var lie_var -- 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} @@ -1084,7 +1087,7 @@ tcRecordBinds -> 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 @@ -1107,14 +1110,14 @@ checkMissingFields data_con rbinds -- 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