From: Ross Paterson <ross@soi.city.ac.uk>
Date: Mon, 3 Sep 2007 14:10:44 +0000 (+0000)
Subject: FIX for #1080
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=9630111a75d550088b945b37aa5964bca9a6e663

FIX for #1080

Arrow desugaring now uses a private version of collectPatBinders and
friends, in order to include dictionary bindings from ConPatOut.

It doesn't fix arrowrun004 (#1333), though.
---

diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index e819872..86b52ed 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -21,7 +21,8 @@ import Match
 import DsUtils
 import DsMonad
 
-import HsSyn
+import HsSyn	hiding (collectPatBinders, collectLocatedPatBinders, collectl,
+			collectPatsBinders, collectLocatedPatsBinders)
 import TcHsSyn
 
 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
@@ -46,7 +47,6 @@ import BasicTypes
 import PrelNames
 import Util
 
-import HsUtils
 import VarSet
 import SrcLoc
 
@@ -1061,3 +1061,65 @@ foldb f xs = foldb f (fold_pairs xs)
     fold_pairs [x] = [x]
     fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
 \end{code}
+
+The following functions to collect value variables from patterns are
+copied from HsUtils, with one change: we also collect the dictionary
+bindings (pat_binds) from ConPatOut.  We need them for cases like
+
+h :: Arrow a => Int -> a (Int,Int) Int
+h x = proc (y,z) -> case compare x y of
+                GT -> returnA -< z+x
+
+The type checker turns the case into
+
+                case compare x y of
+                  GT { p77 = plusInt } -> returnA -< p77 z x
+
+Here p77 is a local binding for the (+) operation.
+
+See comments in HsUtils for why the other version does not include
+these bindings.
+
+\begin{code}
+collectPatBinders :: LPat a -> [a]
+collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
+
+collectLocatedPatBinders :: LPat a -> [Located a]
+collectLocatedPatBinders pat = collectl pat []
+
+collectPatsBinders :: [LPat a] -> [a]
+collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
+
+collectLocatedPatsBinders :: [LPat a] -> [Located a]
+collectLocatedPatsBinders pats = foldr collectl [] pats
+
+---------------------
+collectl (L l pat) bndrs
+  = go pat
+  where
+    go (VarPat var)               = L l var : bndrs
+    go (VarPatOut var bs)         = L l var : collectHsBindLocatedBinders bs
+                                    ++ bndrs
+    go (WildPat _)                = bndrs
+    go (LazyPat pat)              = collectl pat bndrs
+    go (BangPat pat)              = collectl pat bndrs
+    go (AsPat a pat)              = a : collectl pat bndrs
+    go (ParPat  pat)              = collectl pat bndrs
+
+    go (ListPat pats _)           = foldr collectl bndrs pats
+    go (PArrPat pats _)           = foldr collectl bndrs pats
+    go (TuplePat pats _ _)        = foldr collectl bndrs pats
+
+    go (ConPatIn c ps)            = foldr collectl bndrs (hsConPatArgs ps)
+    go (ConPatOut {pat_args=ps, pat_binds=ds}) =
+                                    collectHsBindLocatedBinders ds
+                                    ++ foldr collectl bndrs (hsConPatArgs ps)
+    go (LitPat _)                 = bndrs
+    go (NPat _ _ _ _)             = bndrs
+    go (NPlusKPat n _ _ _)        = n : bndrs
+
+    go (SigPatIn pat _)           = collectl pat bndrs
+    go (SigPatOut pat _)          = collectl pat bndrs
+    go (TypePat ty)               = bndrs
+    go (CoPat _ pat ty)           = collectl (noLoc pat) bndrs
+\end{code}
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 8cef12e..19fd902 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -413,6 +413,22 @@ collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
 we want to generate bindings for x,y but not for dictionaries bound by
 C.  (The type checker ensures they would not be used.)
 
+Desugaring of arrow case expressions needs these bindings (see DsArrows
+and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
+own pat-binder-collector:
+
+Here's the problem.  Consider
+
+data T a where
+   C :: Num a => a -> Int -> T a
+
+f ~(C (n+1) m) = (n,m)
+
+Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
+and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
+variables bound by the lazy pattern are n,m, *not* the dictionary d.
+So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
+
 \begin{code}
 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 collectSigTysFromPats pats = foldr collect_lpat [] pats