X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=99d0c5449df222cf9dd75b546c8c46d21e69f5d9;hp=a3ed96ceb2e6e91b6191610e4886696f9aaa8cb9;hb=67cb409159fa9136dff942b8baaec25909416022;hpb=2eb04ca0f8d0ec72b417cddc60672c696b4a3daa diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index a3ed96c..99d0c54 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -5,8 +5,14 @@ \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" @@ -35,6 +41,8 @@ import DataCon import Name import TyCon import Type +import TypeRep +import Coercion import Var import VarSet import TysWiredIn @@ -70,11 +78,12 @@ tcPolyExpr, tcPolyExprNC tcPolyExpr expr res_ty = addErrCtxt (exprCtxt (unLoc expr)) $ - tcPolyExprNC expr res_ty + (do {traceTc (text "tcPolyExpr") ; tcPolyExprNC expr res_ty }) tcPolyExprNC expr res_ty | isSigmaTy res_ty - = do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr) + = do { traceTc (text "tcPolyExprNC" <+> ppr res_ty) + ; (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 => .... @@ -111,7 +120,6 @@ tcInferRho expr = tcInfer (tcMonoExpr expr) \end{code} - %************************************************************************ %* * tcExpr: the main expression typechecker @@ -122,8 +130,10 @@ tcInferRho expr = tcInfer (tcMonoExpr expr) tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId) tcExpr (HsVar name) res_ty = tcId (OccurrenceOf name) name res_ty -tcExpr (HsLit lit) res_ty = do { boxyUnify (hsLitType lit) res_ty - ; return (HsLit lit) } +tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit + ; coi <- boxyUnify lit_ty res_ty + ; return $ mkHsWrapCoI coi (HsLit lit) + } tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr res_ty ; return (HsPar expr') } @@ -143,19 +153,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')) } @@ -167,6 +178,7 @@ tcExpr (HsApp e1 e2) res_ty go lfun@(L loc fun) args = do { (fun', args') <- -- addErrCtxt (callCtxt lfun args) $ tcApp fun (length args) (tcArgs lfun args) res_ty + ; traceTc (text "tcExpr args': " <+> ppr args') ; return (unLoc (foldl mkHsApp (L loc fun') args')) } tcExpr (HsLam match) res_ty @@ -181,7 +193,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 @@ -277,21 +289,21 @@ tcExpr (HsDo do_or_lc stmts body _) 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 + = do { (elt_ty, coi) <- boxySplitListTy res_ty ; exprs' <- mappM (tc_elt elt_ty) exprs - ; return (ExplicitList 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 + = do { (elt_ty, coi) <- boxySplitPArrTy res_ty ; exprs' <- mappM (tc_elt elt_ty) exprs ; ifM (null exprs) (zapToMonotype elt_ty) -- 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 @@ -307,12 +319,12 @@ 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 - = 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), @@ -458,8 +470,9 @@ 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 + origin = RecordUpdOrigin in - tcSubExp result_ty res_ty `thenM` \ co_fn -> + tcSubExp origin result_ty res_ty `thenM` \ co_fn -> tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' -> -- STEP 5: Typecheck the expression to be updated @@ -479,7 +492,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty let theta' = substTheta scrut_inst_env (dataConStupidTheta con1) in - instStupidTheta RecordUpdOrigin theta' `thenM_` + instStupidTheta origin 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 @@ -503,54 +516,58 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty \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!" @@ -664,13 +681,14 @@ 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 -- tcFun work nicely for OpApp and Sections too ; fun' <- instFun orig fun res_subst tv_theta_prs ; co_fn' <- wrapFunResCoercion (substTys res_subst fun_arg_tys) co_fn + ; traceTc (text "tcIdApp: " <+> ppr (mkHsWrap co_fn' fun') <+> ppr tv_theta_prs <+> ppr co_fn' <+> ppr fun') ; return (mkHsWrap co_fn' fun', args') } \end{code} @@ -710,10 +728,11 @@ 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 + ; traceTc (text "tcId yields" <+> ppr (mkHsWrap co_fn fun')) ; return (mkHsWrap co_fn fun') } -- Note [Push result type in] @@ -758,27 +777,32 @@ instFun orig fun subst [] instFun orig fun subst tv_theta_prs = do { let ty_theta_prs' = map subst_pr tv_theta_prs - + ; traceTc (text "instFun" <+> ppr ty_theta_prs') -- Make two ad-hoc checks ; doStupidChecks fun ty_theta_prs' -- Now do normal instantiation - ; go True fun ty_theta_prs' } + ; result <- go True fun ty_theta_prs' + ; traceTc (text "instFun result" <+> ppr result) + ; return result + } where subst_pr (tvs, theta) = (substTyVars subst tvs, substTheta subst theta) - go _ 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 - = do { meth_id <- newMethodWithGivenTy orig fun_id tys + = 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 round with 'False' to prevent further use -- of newMethod: see Note [Multiple instantiation] go _ 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 } -- See Note [No method sharing] @@ -952,8 +976,11 @@ lookupFun orig id_name ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl } -> do { thLocalId orig id ty lvl ; case mb_co of - Nothing -> return (HsVar id, ty) -- Wobbly, or no free vars - Just co -> return (mkHsWrap co (HsVar id), ty) } + 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)")) + } other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected")) } @@ -976,7 +1003,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: @@ -987,7 +1014,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 @@ -1019,11 +1046,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}