[project @ 2004-01-05 12:11:42 by simonpj]

[ghc-hetmet.git] / ghc / compiler / deSugar / MatchCon.lhs

diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs
index 141f6a7..ed9f894 100644 (file)
--- a/ghc/compiler/deSugar/MatchCon.lhs
+++ b/ghc/compiler/deSugar/MatchCon.lhs
@@ -20,6 +20,7 @@ import Subst          ( mkSubst, mkInScopeSet, bindSubst, substExpr )
 import CoreFVs         ( exprFreeVars )
 import VarEnv          ( emptySubstEnv )
 import ListSetOps      ( equivClassesByUniq )
+import SrcLoc          ( unLoc )
 import Unique          ( Uniquable(..) )
 \end{code}
 
@@ -86,7 +87,7 @@ matchConFamily (var:vars) eqns_info
        get_uniq (EqnInfo _ _ (ConPatOut data_con _ _ _ _ : _) _) = getUnique data_con
     in
        -- Now make a case alternative out of each group
-    mapDs (match_con vars) eqn_groups  `thenDs` \ alts ->
+    mappM (match_con vars) eqn_groups  `thenDs` \ alts ->
 
     returnDs (mkCoAlgCaseMatchResult var alts)
 \end{code}
@@ -99,7 +100,7 @@ Wadler's chapter in SLPJ.
 match_con vars (eqn1@(EqnInfo _ _ (ConPatOut data_con (PrefixCon arg_pats) _ ex_tvs ex_dicts : _) _)
                : other_eqns)
   = -- Make new vars for the con arguments; avoid new locals where possible
-    mapDs selectMatchVar arg_pats      `thenDs` \ arg_vars ->
+    mappM selectMatchVarL arg_pats     `thenDs` \ arg_vars ->
 
     -- Now do the business to make the alt for _this_ ConPat ...
     match (arg_vars ++ vars) 
@@ -118,7 +119,7 @@ match_con vars (eqn1@(EqnInfo _ _ (ConPatOut data_con (PrefixCon arg_pats) _ ex_
   where
     shift_con_pat :: EquationInfo -> EquationInfo
     shift_con_pat (EqnInfo n ctx (ConPatOut _ (PrefixCon arg_pats) _ _ _ : pats) match_result)
-      = EqnInfo n ctx (arg_pats ++ pats) match_result
+      = EqnInfo n ctx (map unLoc arg_pats ++ pats) match_result
 
     other_pats = [p | EqnInfo _ _ (p:_) _ <- other_eqns]