Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : tc-untouchables
http://hackage.haskell.org/trac/ghc/changeset/d37deb7b36c452294dd943022a34c429a8b8ff24 >--------------------------------------------------------------- commit d37deb7b36c452294dd943022a34c429a8b8ff24 Author: Simon Peyton Jones <[email protected]> Date: Mon Sep 3 18:33:00 2012 +0100 Some comments and false starts to do with ArrForm There's a very very wrong piece of code in TcArrows; and it is even triggering an ASERT failure now. I need to talk to Ross to figure out what is going on. >--------------------------------------------------------------- compiler/rename/RnExpr.lhs | 5 ++++ compiler/typecheck/TcArrows.lhs | 40 ++++++++++++++++++++++++++++++-------- 2 files changed, 36 insertions(+), 9 deletions(-) diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 78a6434..cbc57dc 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -331,6 +331,11 @@ rnExpr (HsArrApp arrow arg _ ho rtl) return (HsArrApp arrow' arg' placeHolderType ho rtl, fvArrow `plusFV` fvArg) where + -- See Note [Escaping the arrow scope] in TcRnTypes + -- Before renaming 'arrow', use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside 'arrow'. In the higher-order case (-<<), they are. select_arrow_scope tc = case ho of HsHigherOrderApp -> tc HsFirstOrderApp -> escapeArrowScope tc diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index e15b2ad..9d3d433 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -18,6 +18,7 @@ import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId ) import HsSyn import TcMatches +-- import TcSimplify( solveWantedsTcM ) import TcType import TcMType import TcBinds @@ -160,18 +161,20 @@ tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) ; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty) + -- ToDo: There should be no need for the escapeArrowScope stuff + -- See Note [Escaping the arrow scope] in TcRnTypes ; arg' <- tcMonoExpr arg arg_ty ; return (HsArrApp fun' arg' fun_ty ho_app lr) } where - -- Before type-checking f, use the environment of the enclosing - -- proc for the (-<) case. - -- Local bindings, inside the enclosing proc, are not in scope - -- inside f. In the higher-order case (-<<), they are. + -- Before type-checking f, use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside f. In the higher-order case (-<<), they are. select_arrow_scope tc = case ho_app of - HsHigherOrderApp -> tc - HsFirstOrderApp -> escapeArrowScope tc + HsHigherOrderApp -> tc + HsFirstOrderApp -> escapeArrowScope tc ------------------------------------------- -- Command application @@ -256,15 +259,34 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) ; let e_ty = mkFunTys [mkAppTys b [tup,s] | (_,_,b,tup,s) <- cmds_w_tys] e_res_ty + -- ToDo: SLPJ: something is badly wrong here. + -- The escapeArrowScope pops the Untouchables.. but that + -- risks screwing up the skolem-escape check + -- Moreover, arrowfail001 fails with an ASSERT failure + -- because a variable gets the wrong level -- Check expr - ; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $ - escapeArrowScope (tcMonoExpr expr e_ty) + ; (inner_binds, expr') + <- checkConstraints ArrowSkol [w_tv] [] $ + escapeArrowScope (tcMonoExpr expr e_ty) + +{- + ; ((inner_binds, expr'), lie) + <- captureConstraints $ + checkConstraints ArrowSkol [w_tv] [] $ + tcMonoExpr expr e_ty + -- No need for escapeArrowScope in the + -- type checker. + -- Note [Escaping the arrow scope] in TcRnTypes + ; (lie, outer_binds) <- solveWantedsTcM lie + ; emitConstraints lie +-} -- OK, now we are in a position to unscramble -- the s1..sm and check each cmd ; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys - ; let wrap = WpTyLam w_tv <.> mkWpLet inst_binds + ; let wrap = {- mkWpLet (EvBinds outer_binds) <.> -} + WpTyLam w_tv <.> mkWpLet inner_binds ; return (HsArrForm (mkLHsWrap wrap expr') fixity cmds') } where -- Make the types _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
