X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=b844a2a0d371526bdb87217da6b64194540c5b7f;hp=804fb478907be2e4cb00d90d34a9fd5707153773;hb=bfd0c33d39619b580520e2d6e43d306380393ea6;hpb=1d1c3c727617630beacacaf33022e1daba06a0bb diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 804fb47..b844a2a 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 @@ -242,8 +244,8 @@ tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty tcApp op 2 (tc_args arg1_ty') res_ty' ; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) } where - doc = ptext SLIT("The section") <+> quotes (ppr in_expr) - <+> ptext SLIT("takes one argument") + doc = ptext (sLit "The section") <+> quotes (ppr in_expr) + <+> ptext (sLit "takes one argument") 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 @@ -290,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 @@ -327,12 +329,12 @@ tcExpr (HsProc pat cmd) res_ty ; return $ mkHsWrapCoI coi (HsProc pat' cmd') } tcExpr e@(HsArrApp _ _ _ _ _) _ - = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e), - ptext SLIT("was found where an expression was expected")]) + = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e), + ptext (sLit "was found where an expression was expected")]) tcExpr e@(HsArrForm _ _ _) _ - = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e), - ptext SLIT("was found where an expression was expected")]) + = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e), + ptext (sLit "was found where an expression was expected")]) \end{code} %************************************************************************ @@ -361,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: @@ -396,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 @@ -412,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 @@ -426,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 @@ -457,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 @@ -471,9 +472,9 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty result_ty = substTy result_inst_env con1_res_ty con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys origin = RecordUpdOrigin - in - tcSubExp origin result_ty res_ty `thenM` \ co_fn -> - tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' -> + + co_fn <- tcSubExp origin result_ty res_ty + rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds -- STEP 5: Typecheck the expression to be updated let @@ -481,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, @@ -491,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 origin 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 + = WpCast $ 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} @@ -588,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} @@ -782,7 +785,8 @@ instFun orig fun subst tv_theta_prs ; doStupidChecks fun ty_theta_prs' -- Now do normal instantiation - ; result <- go True fun ty_theta_prs' + ; method_sharing <- doptM Opt_MethodSharing + ; result <- go method_sharing True fun ty_theta_prs' ; traceTc (text "instFun result" <+> ppr result) ; return result } @@ -790,24 +794,24 @@ instFun orig fun subst tv_theta_prs subst_pr (tvs, theta) = (substTyVars subst tvs, substTheta subst theta) - go _ fun [] = do {traceTc (text "go _ fun [] returns" <+> ppr fun) ; return fun } + go _ _ fun [] = do {traceTc (text "go _ _ fun [] returns" <+> ppr fun) ; return fun } - go True (HsVar fun_id) ((tys,theta) : prs) - | want_method_inst theta + go method_sharing True (HsVar fun_id) ((tys,theta) : prs) + | want_method_inst method_sharing theta = do { traceTc (text "go (HsVar fun_id) ((tys,theta) : prs) | want_method_inst theta") ; meth_id <- newMethodWithGivenTy orig fun_id tys - ; go False (HsVar meth_id) prs } + ; go method_sharing False (HsVar meth_id) prs } -- Go round with 'False' to prevent further use -- of newMethod: see Note [Multiple instantiation] - go _ fun ((tys, theta) : prs) + go method_sharing _ fun ((tys, theta) : prs) = do { co_fn <- instCall orig tys theta ; traceTc (text "go yields co_fn" <+> ppr co_fn) - ; go False (HsWrap co_fn fun) prs } + ; go method_sharing False (HsWrap co_fn fun) prs } -- See Note [No method sharing] - want_method_inst theta = not (null theta) -- Overloaded - && not opt_NoMethodSharing + want_method_inst method_sharing theta = not (null theta) -- Overloaded + && method_sharing \end{code} Note [Multiple instantiation] @@ -944,12 +948,12 @@ doStupidChecks fun tv_theta_prs tagToEnumError tys - = hang (ptext SLIT("Bad call to tagToEnum#") <+> at_type) - 2 (vcat [ptext SLIT("Specify the type by giving a type signature"), - ptext SLIT("e.g. (tagToEnum# x) :: Bool")]) + = hang (ptext (sLit "Bad call to tagToEnum#") <+> at_type) + 2 (vcat [ptext (sLit "Specify the type by giving a type signature"), + ptext (sLit "e.g. (tagToEnum# x) :: Bool")]) where at_type | null tys = empty -- Probably never happens - | otherwise = ptext SLIT("at type") <+> ppr (head tys) + | otherwise = ptext (sLit "at type") <+> ppr (head tys) \end{code} %************************************************************************ @@ -979,10 +983,10 @@ lookupFun orig id_name Unrefineable -> return (HsVar id, ty) Rigid co -> return (mkHsWrap co (HsVar id), ty) Wobbly -> traceTc (text "lookupFun" <+> ppr id) >> return (HsVar id, ty) -- Wobbly, or no free vars - WobblyInvisible -> failWithTc (ppr id_name <+> ptext SLIT(" not in scope because it has a wobbly type (solution: add a type annotation)")) + WobblyInvisible -> failWithTc (ppr id_name <+> ptext (sLit " not in scope because it has a wobbly type (solution: add a type annotation)")) } - other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected")) + other -> failWithTc (ppr other <+> ptext (sLit "used where a value identifer was expected")) } #ifndef GHCI /* GHCI and TH is off */ @@ -1084,7 +1088,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 +1111,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 @@ -1148,38 +1152,38 @@ checkMissingFields data_con rbinds Boring and alphabetical: \begin{code} caseScrutCtxt expr - = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr) + = hang (ptext (sLit "In the scrutinee of a case expression:")) 4 (ppr expr) exprCtxt expr - = hang (ptext SLIT("In the expression:")) 4 (ppr expr) + = hang (ptext (sLit "In the expression:")) 4 (ppr expr) fieldCtxt field_name - = ptext SLIT("In the") <+> quotes (ppr field_name) <+> ptext SLIT("field of a record") + = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") funAppCtxt fun arg arg_no - = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"), + = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"), quotes (ppr fun) <> text ", namely"]) 4 (quotes (ppr arg)) predCtxt expr - = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr) + = hang (ptext (sLit "In the predicate expression:")) 4 (ppr expr) nonVanillaUpd tycon - = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") + = 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")] + <+> ptext (sLit "is not (yet) supported"), + ptext (sLit "Use pattern-matching instead")] badFieldsUpd rbinds - = hang (ptext SLIT("No constructor has all these fields:")) + = hang (ptext (sLit "No constructor has all these fields:")) 4 (pprQuotedList (hsRecFields rbinds)) naughtyRecordSel sel_id - = ptext SLIT("Cannot use record selector") <+> quotes (ppr sel_id) <+> - ptext SLIT("as a function due to escaped type variables") $$ - ptext SLIT("Probably fix: use pattern-matching syntax instead") + = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+> + ptext (sLit "as a function due to escaped type variables") $$ + ptext (sLit "Probably fix: use pattern-matching syntax instead") notSelector field - = hsep [quotes (ppr field), ptext SLIT("is not a record selector")] + = hsep [quotes (ppr field), ptext (sLit "is not a record selector")] missingStrictFields :: DataCon -> [FieldLabel] -> SDoc missingStrictFields con fields @@ -1189,19 +1193,19 @@ missingStrictFields con fields -- with strict fields | otherwise = colon <+> pprWithCommas ppr fields - header = ptext SLIT("Constructor") <+> quotes (ppr con) <+> - ptext SLIT("does not have the required strict field(s)") + header = ptext (sLit "Constructor") <+> quotes (ppr con) <+> + ptext (sLit "does not have the required strict field(s)") missingFields :: DataCon -> [FieldLabel] -> SDoc missingFields con fields - = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:") + = 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 polySpliceErr id - = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id) + = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id) #endif \end{code}