X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=a068e5318ed8ead5cacd5f453b6af3eff59d561d;hp=531b1b0c6477b74506e4fa08a64aafc90abfc149;hb=34c8d0312071f7d0f4d221a997d3408c653ef9e5;hpb=a6f2d598e1e7760d334d1b5ea0b7745e66835e11 diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 531b1b0..a068e53 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -42,6 +42,7 @@ import DataCon import Name import TyCon import Type +import TypeRep import Coercion import Var import VarSet @@ -82,7 +83,7 @@ tcPolyExpr expr res_ty tcPolyExprNC expr res_ty = do { traceTc "tcPolyExprNC" (ppr res_ty) - ; (gen_fn, expr') <- tcGen (GenSkol res_ty) emptyVarSet res_ty $ \ _ rho -> + ; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho -> tcMonoExprNC expr rho ; return (mkLHsWrap gen_fn expr') } @@ -136,12 +137,52 @@ tcInfExpr e = tcInfer (tcExpr e) %************************************************************************ \begin{code} + +updHetMetLevel :: ([TyVar] -> [TyVar]) -> TcM a -> TcM a +updHetMetLevel f comp = + updEnv + (\oldenv -> let oldlev = (case oldenv of Env { env_lcl = e' } -> case e' of TcLclEnv { tcl_hetMetLevel = x } -> x) + in (oldenv { env_lcl = (env_lcl oldenv) { tcl_hetMetLevel = f oldlev } })) + + comp + +addEscapes :: [TyVar] -> HsExpr Name -> HsExpr Name +addEscapes [] e = e +addEscapes (t:ts) e = HsHetMetEsc (TyVarTy t) placeHolderType (noLoc (addEscapes ts e)) + +getIdLevel :: Name -> TcM [TyVar] +getIdLevel name + = do { thing <- tcLookup name + ; case thing of + ATcId { tct_hetMetLevel = variable_hetMetLevel } -> return $ variable_hetMetLevel + _ -> return [] + } + tcExpr :: HsExpr Name -> TcRhoType -> 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 = tcCheckId name res_ty +tcExpr (HsHetMetBrak _ e) res_ty = + do { (coi, [inferred_name,elt_ty]) <- matchExpectedTyConApp hetMetCodeTypeTyCon res_ty + ; fresh_ec_name <- newFlexiTyVar liftedTypeKind + ; expr' <- updHetMetLevel (\old_lev -> (fresh_ec_name:old_lev)) + $ tcPolyExpr e elt_ty + ; unifyType (TyVarTy fresh_ec_name) inferred_name + ; return $ mkHsWrapCoI coi (HsHetMetBrak (TyVarTy fresh_ec_name) expr') } +tcExpr (HsHetMetEsc _ _ e) res_ty = + do { cur_level <- getHetMetLevel + ; expr' <- updHetMetLevel (\old_lev -> tail old_lev) + $ tcExpr (unLoc e) (mkTyConApp hetMetCodeTypeTyCon [(TyVarTy $ head cur_level),res_ty]) + ; ty' <- zonkTcType res_ty + ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetEsc (TyVarTy $ head cur_level) ty' (noLoc expr')) } +tcExpr (HsHetMetCSP _ e) res_ty = + do { cur_level <- getHetMetLevel + ; expr' <- updHetMetLevel (\old_lev -> tail old_lev) + $ tcExpr (unLoc e) res_ty + ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr')) } + tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit @@ -191,7 +232,7 @@ tcExpr (ExprWithTySig expr sig_ty) res_ty -- Remember to extend the lexical type-variable environment ; (gen_fn, expr') - <- tcGen (SigSkol ExprSigCtxt) emptyVarSet sig_tc_ty $ \ skol_tvs res_ty -> + <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty -> tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $ -- See Note [More instantiated than scoped] in TcBinds tcMonoExprNC expr res_ty @@ -392,11 +433,27 @@ tcExpr (HsCase scrut matches) exp_ty match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } -tcExpr (HsIf pred b1 b2) res_ty - = do { pred' <- tcMonoExpr pred boolTy - ; b1' <- tcMonoExpr b1 res_ty - ; b2' <- tcMonoExpr b2 res_ty - ; return (HsIf pred' b1' b2') } +tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' + = do { pred' <- tcMonoExpr pred boolTy + ; b1' <- tcMonoExpr b1 res_ty + ; b2' <- tcMonoExpr b2 res_ty + ; return (HsIf Nothing pred' b1' b2') } + +tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if] + = do { pred_ty <- newFlexiTyVarTy openTypeKind + ; b1_ty <- newFlexiTyVarTy openTypeKind + ; b2_ty <- newFlexiTyVarTy openTypeKind + ; let if_ty = mkFunTys [pred_ty, b1_ty, b2_ty] res_ty + ; fun' <- tcSyntaxOp IfOrigin fun if_ty + ; pred' <- tcMonoExpr pred pred_ty + ; b1' <- tcMonoExpr b1 b1_ty + ; b2' <- tcMonoExpr b2 b2_ty + -- Fundamentally we are just typing (ifThenElse e1 e2 e3) + -- so maybe we should use the code for function applications + -- (which would allow ifThenElse to be higher rank). + -- But it's a little awkward, so I'm leaving it alone for now + -- and it maintains uniformity with other rebindable syntax + ; return (HsIf (Just fun') pred' b1' b2') } tcExpr (HsDo do_or_lc stmts body _) res_ty = tcDoStmts do_or_lc stmts body res_ty @@ -414,6 +471,22 @@ tcExpr e@(HsArrForm _ _ _) _ ptext (sLit "was found where an expression was expected")]) \end{code} +Note [Rebindable syntax for if] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rebindable syntax for 'if' uses the most flexible possible type +for conditionals: + ifThenElse :: p -> b1 -> b2 -> res +to support expressions like this: + + ifThenElse :: Maybe a -> (a -> b) -> b -> b + ifThenElse (Just a) f _ = f a ifThenElse Nothing _ e = e + + example :: String + example = if Just 2 + then \v -> show v + else "No value" + + %************************************************************************ %* * Record construction and update @@ -787,7 +860,8 @@ tcApp fun args res_ty -- Typecheck the result, thereby propagating -- info (if any) from result into the argument types -- Both actual_res_ty and res_ty are deeply skolemised - ; co_res <- unifyType actual_res_ty res_ty + ; co_res <- addErrCtxt (funResCtxt fun) $ + unifyType actual_res_ty res_ty -- Typecheck the arguments ; args1 <- tcArgs fun args expected_arg_tys @@ -927,24 +1001,40 @@ tcInferId n = tcInferIdWithOrig (OccurrenceOf n) n tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType) -- Look up an occurrence of an Id, and instantiate it (deeply) -tcInferIdWithOrig orig id_name - = do { id <- lookup_id - ; (id_expr, id_rho) <- instantiateOuter orig id - ; (wrap, rho) <- deeplyInstantiate orig id_rho - ; return (mkHsWrap wrap id_expr, rho) } +tcInferIdWithOrig orig id_name = + do { id_level <- getIdLevel id_name + ; cur_level <- getHetMetLevel + ; if (length id_level < length cur_level) + then do { (lhexp, tcrho) <- + tcInferRho (noLoc $ addEscapes (take ((length cur_level) - (length id_level)) cur_level) (HsVar id_name)) + ; return (unLoc lhexp, tcrho) + } + else tcInferIdWithOrig' orig id_name + } + +tcInferIdWithOrig' orig id_name = + do { id <- lookup_id + ; (id_expr, id_rho) <- instantiateOuter orig id + ; (wrap, rho) <- deeplyInstantiate orig id_rho + ; return (mkHsWrap wrap id_expr, rho) } where lookup_id :: TcM TcId lookup_id = do { thing <- tcLookup id_name ; case thing of - ATcId { tct_id = id, tct_level = lvl } + ATcId { tct_id = id, tct_level = lvl, tct_hetMetLevel = variable_hetMetLevel } -> do { check_naughty id -- Note [Local record selectors] ; checkThLocalId id lvl + ; current_hetMetLevel <- getHetMetLevel + ; mapM + (\(name1,name2) -> unifyType (TyVarTy name1) (TyVarTy name2)) + (zip variable_hetMetLevel current_hetMetLevel) ; return id } AGlobal (AnId id) - -> do { check_naughty id; return id } - -- A global cannot possibly be ill-staged + -> do { check_naughty id + ; return id } + -- A global cannot possibly be ill-staged in Template Haskell -- nor does it need the 'lifting' treatment -- hence no checkTh stuff here @@ -1352,6 +1442,10 @@ funAppCtxt fun arg arg_no quotes (ppr fun) <> text ", namely"]) 2 (quotes (ppr arg)) +funResCtxt :: LHsExpr Name -> SDoc +funResCtxt fun + = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun) + badFieldTypes :: [(Name,TcType)] -> SDoc badFieldTypes prs = hang (ptext (sLit "Record update for insufficiently polymorphic field")