X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=d0052d8936e2ff42730bc8062d78e2e2e84e16ff;hp=567f2dc49d6be994397ffadfa538b324329f8d80;hb=f16dbbbe59cf3aa19c5fd384560a1b89076d7bc8;hpb=dd99b6f8c61f393087d03cd697c06051a43ca4e9 diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 567f2dc..d0052d8 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, tcInferRhoNC, tcSyntaxOp ) where #include "HsVersions.h" @@ -79,20 +79,20 @@ tcPolyExpr, tcPolyExprNC -- to do so himself. tcPolyExpr expr res_ty - = addErrCtxt (exprCtxt (unLoc expr)) $ + = addErrCtxt (exprCtxt expr) $ (do {traceTc (text "tcPolyExpr") ; tcPolyExprNC expr res_ty }) tcPolyExprNC expr res_ty | isSigmaTy res_ty = do { traceTc (text "tcPolyExprNC" <+> ppr res_ty) - ; (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr) + ; (gen_fn, expr') <- tcGen res_ty emptyVarSet Nothing (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 - = tcMonoExpr expr res_ty + = tcMonoExprNC expr res_ty --------------- tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId] @@ -104,21 +104,27 @@ tcPolyExprs (expr:exprs) (ty:tys) tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys) --------------- -tcMonoExpr :: LHsExpr Name -- Expression to type check - -> BoxyRhoType -- Expected type (could be a type variable) - -- Definitely no foralls at the top - -- Can contain boxes, which will be filled in - -> TcM (LHsExpr TcId) - -tcMonoExpr (L loc expr) res_ty +tcMonoExpr, tcMonoExprNC + :: LHsExpr Name -- Expression to type check + -> BoxyRhoType -- Expected type (could be a type variable) + -- Definitely no foralls at the top + -- Can contain boxes, which will be filled in + -> TcM (LHsExpr TcId) + +tcMonoExpr expr res_ty + = addErrCtxt (exprCtxt expr) $ + tcMonoExprNC expr res_ty + +tcMonoExprNC (L loc expr) res_ty = ASSERT( not (isSigmaTy res_ty) ) setSrcSpan loc $ do { expr' <- tcExpr expr res_ty ; return (L loc expr') } --------------- -tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) -tcInferRho expr = tcInfer (tcMonoExpr expr) +tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) +tcInferRho expr = tcInfer (tcMonoExpr expr) +tcInferRhoNC expr = tcInfer (tcMonoExprNC expr) \end{code} @@ -130,6 +136,9 @@ tcInferRho expr = tcInfer (tcMonoExpr expr) \begin{code} tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId) +tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check + = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e) + tcExpr (HsVar name) res_ty = tcId (OccurrenceOf name) name res_ty tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit @@ -137,7 +146,7 @@ tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit ; return $ mkHsWrapCoI coi (HsLit lit) } -tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr res_ty +tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty ; return (HsPar expr') } tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty @@ -191,9 +200,8 @@ tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty -- Remember to extend the lexical type-variable environment - ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (\ skol_tvs res_ty -> - tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $ - tcPolyExprNC expr res_ty) + ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $ + tcMonoExprNC expr ; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) } @@ -223,29 +231,45 @@ tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_ty -- \ x -> e op x, -- or -- \ x -> op e x, --- or just +-- or, if PostfixOperators is enabled, just -- op e -- --- We treat it as similar to the latter, so we don't +-- With PostfixOperators we don't -- actually require the function to take two arguments -- at all. For example, (x `not`) means (not x); --- you get postfix operators! Not really Haskell 98 --- I suppose, but it's less work and kind of useful. +-- you get postfix operators! Not Haskell 98, +-- but it's less work and kind of useful. tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty - = do { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty - ; return (SectionL arg1' (L loc op')) } + = do dflags <- getDOpts + if dopt Opt_PostfixOperators dflags + then do (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty + return (SectionL arg1' (L loc op')) + else do (co_fn, (op', arg1')) + <- subFunTys doc 1 res_ty Nothing + $ \ [arg2_ty'] res_ty' -> + tcApp op 2 (tc_args arg2_ty') res_ty' + return (mkHsWrap co_fn (SectionL arg1' (L loc op'))) + where + doc = ptext (sLit "The section") <+> quotes (ppr in_expr) + <+> ptext (sLit "takes one argument") + tc_args arg2_ty' qtvs qtys [arg1_ty, arg2_ty] + = do { boxyUnify arg2_ty' (substTyWith qtvs qtys arg2_ty) + ; arg1' <- tcArg lop 2 arg1 qtvs qtys arg1_ty + ; qtys' <- mapM refineBox qtys -- c.f. tcArgs + ; return (qtys', arg1') } + tc_args _ _ _ _ = panic "tcExpr SectionL" -- Right sections, equivalent to \ x -> x `op` expr, or -- \ x -> op x expr tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty - = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' -> + = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] 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 @@ -270,8 +294,7 @@ tcExpr (HsCase scrut matches) exp_ty -- -- But now, in the GADT world, we need to typecheck the scrutinee -- first, to get type info that may be refined in the case alternatives - (scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut) - (tcInferRho scrut) + (scrut', scrut_ty) <- tcInferRho scrut ; traceTc (text "HsCase" <+> ppr scrut_ty) ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty @@ -281,8 +304,7 @@ tcExpr (HsCase scrut matches) exp_ty mc_body = tcBody } tcExpr (HsIf pred b1 b2) res_ty - = do { pred' <- addErrCtxt (predCtxt pred) $ - tcMonoExpr pred boolTy + = do { pred' <- tcMonoExpr pred boolTy ; b1' <- tcMonoExpr b1 res_ty ; b2' <- tcMonoExpr b2 res_ty ; return (HsIf pred' b1' b2') } @@ -314,7 +336,9 @@ tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty -- 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 { tvs <- newBoxyTyVars [argTypeKind | e <- exprs] + = do { let kind = case boxity of { Boxed -> liftedTypeKind + ; Unboxed -> argTypeKind } + ; tvs <- newBoxyTyVars [kind | e <- exprs] ; let tup_tc = tupleTyCon boxity (length exprs) tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs) ; checkWiredInTyCon tup_tc -- Ensure instances are available @@ -329,12 +353,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} %************************************************************************ @@ -785,7 +809,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 } @@ -793,24 +818,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] @@ -947,12 +972,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} %************************************************************************ @@ -982,10 +1007,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 */ @@ -1150,39 +1175,33 @@ checkMissingFields data_con rbinds Boring and alphabetical: \begin{code} -caseScrutCtxt 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) +exprCtxt (L _ 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) - 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 @@ -1192,19 +1211,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}