Desugaring arrow commands
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module DsArrows ( dsProcExpr ) where
#include "HsVersions.h"
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 PrelNames
import Util
-import HsUtils
import VarSet
import SrcLoc
+
+import Data.List
\end{code}
\begin{code}
unionVarSets fv_sets)
-dsCmd ids local_vars env_ids stack res_ty (HsTick ix expr)
+dsCmd ids local_vars env_ids stack res_ty (HsTick ix vars expr)
= dsLCmd ids local_vars env_ids stack res_ty expr `thenDs` \ (expr1,id_set) ->
- mkTickBox ix expr1 `thenDs` \ expr2 ->
+ mkTickBox ix vars expr1 `thenDs` \ expr2 ->
return (expr2,id_set)
-- A | ys |- c :: [ts] t (ys <= 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}