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 (file)
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -21,7 +21,8 @@ import Match
 import DsUtils
 import DsMonad
 
 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
 import TcHsSyn
 
 -- NB: The desugarer, which straddles the source and Core worlds, sometimes

@@ -46,7 +47,6 @@ import BasicTypes
 import PrelNames
 import Util
 
 import PrelNames
 import Util
 

-import HsUtils

 import VarSet
 import SrcLoc
 
 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}
     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 (file)
--- 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.)
 
 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
 \begin{code}
 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 collectSigTysFromPats pats = foldr collect_lpat [] pats