[commit: ghc] master: A much nicer solution for typechecking ApplicativeDo (254bc33)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/254bc3357b0de673b7873f1c4cf5dfc26d0bb5f2/ghc

>---------------------------------------------------------------

commit 254bc3357b0de673b7873f1c4cf5dfc26d0bb5f2
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Feb 22 13:45:52 2017 +0000

    A much nicer solution for typechecking ApplicativeDo
    
    This patch improves the code for TcMatches.tcApplicativeStmts;
    see the suggestion in Trac #13242 comment:9.
    
    I now use (mapM goArg args) rather than a CPS-style fold.  The
    result is less code, easier to understand, and automatically
    fixes the original problem in Trac #13242.
    
    See Note [ApplicativeDo and constraints].


>---------------------------------------------------------------

254bc3357b0de673b7873f1c4cf5dfc26d0bb5f2
 compiler/typecheck/TcMatches.hs | 67 ++++++++++++++++++++---------------------
 1 file changed, 32 insertions(+), 35 deletions(-)

diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index 68cc9a4..9a3add1 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -1024,10 +1024,17 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
       ; let (ops, args) = unzip pairs
       ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
 
-      ; lie_var <- getConstraintVar  -- See Note [ApplicativeDo and constraints]
-      ; (args', thing) <- goArgs (zip3 args pat_tys exp_tys)
-                                 lie_var (thing_inside body_ty)
-      ; return (zip ops' args', body_ty, thing) }
+      -- Typecheck each ApplicativeArg separately
+      -- See Note [ApplicativeDo and constraints]
+      ; args' <- mapM goArg (zip3 args pat_tys exp_tys)
+
+      -- Bring into scope all the things bound by the args,
+      -- and typecheck the thign_inside
+      -- See Note [ApplicativeDo and constraints]
+      ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $
+               thing_inside body_ty
+
+      ; return (zip ops' args', body_ty, res) }
   where
     goOps _ [] = return []
     goOps t_left ((op,t_i,exp_ty) : ops)
@@ -1039,40 +1046,32 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
            ; ops' <- goOps t_i ops
            ; return (op' : ops') }
 
-    goArgs :: [(ApplicativeArg Name Name, Type, Type)]
-           -> TcRef WantedConstraints  -- See Note [ApplicativeDo and constraints]
-           -> TcM t
-           -> TcM ([ApplicativeArg TcId TcId], t)
-
-    goArgs [] lie_var thing_inside
-      = do { thing <- setConstraintVar lie_var thing_inside
-           ; return ([],thing)
-           }
-    goArgs ((ApplicativeArgOne pat rhs, pat_ty, exp_ty) : rest)
-           lie_var thing_inside
+    goArg :: (ApplicativeArg Name Name, Type, Type)
+          -> TcM (ApplicativeArg TcId TcId)
+
+    goArg (ApplicativeArgOne pat rhs, pat_ty, exp_ty)
       = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
         addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs))   $
-        setConstraintVar lie_var                               $
         do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)
-           ; (pat',(pairs, thing)) <-
-               tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
-               popErrCtxt $  -- Undoes the enclosing addErrCtxt
-               goArgs rest lie_var thing_inside
-           ; return (ApplicativeArgOne pat' rhs' : pairs, thing) }
-
-    goArgs ((ApplicativeArgMany stmts ret pat, pat_ty, exp_ty) : rest)
-            lie_var thing_inside
-      = do { (stmts', (ret',pat',rest',thing))  <-
-                setConstraintVar lie_var                                  $
+           ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
+                          return ()
+           ; return (ApplicativeArgOne pat' rhs') }
+
+    goArg (ApplicativeArgMany stmts ret pat, pat_ty, exp_ty)
+      = do { (stmts', (ret',pat')) <-
                 tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $
                 \res_ty  -> do
                   { L _ ret' <- tcMonoExprNC (noLoc ret) res_ty
-                  ; (pat',(rest', thing)) <-
-                      tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
-                        goArgs rest lie_var thing_inside
-                  ; return (ret', pat', rest', thing)
+                  ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
+                                 return ()
+                  ; return (ret', pat')
                   }
-           ; return (ApplicativeArgMany stmts' ret' pat' : rest', thing) }
+           ; return (ApplicativeArgMany stmts' ret' pat') }
+
+    get_arg_bndrs :: ApplicativeArg TcId TcId -> [Id]
+    get_arg_bndrs (ApplicativeArgOne pat _)    = collectPatBinders pat
+    get_arg_bndrs (ApplicativeArgMany _ _ pat) = collectPatBinders pat
+
 
 {- Note [ApplicativeDo and constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1098,10 +1097,8 @@ Now, we say that:
 * Within the stmts of each 'argi' individually, however, constraints bound
   by earlier stmts can be used to solve later ones.
 
-To achieve this, we just reset the "LIE var" (in which new required
-constraints are collected) to the outer context just before doing each arg,
-and the thing_inside.
-
+To achieve this, we just typecheck each 'argi' separately, bring all
+the variables they bind into scope, and typecheck the thing_inside.
 
 ************************************************************************
 *                                                                      *