Commit 9630111a authored by Ross Paterson's avatar Ross Paterson

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.
parent b8c0cca3
......@@ -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}
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment