X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FMatch.lhs;h=d90f9048c3212c275831ce85ebd5519995443e5f;hb=8a9eb3cd35117c62ac9758d118c6f4109b7330cb;hp=100a2b564310f0ce5c84b790feea1658126d607c;hpb=4da93ad236882128b7b446e83a2c159ef17d7ffa;p=ghc-hetmet.git

diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 100a2b5..d90f904 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -519,6 +519,21 @@ tidy1 _ (LitPat lit)
 tidy1 _ (NPat lit mb_neg eq)
   = return (idDsWrapper, tidyNPat lit mb_neg eq)
 
+-- BangPatterns: Pattern matching is already strict in constructors,
+-- tuples etc, so the last case strips off the bang for thoses patterns.
+tidy1 v (BangPat (L _ (LazyPat p)))       = tidy1 v (BangPat p)
+tidy1 v (BangPat (L _ (ParPat p)))        = tidy1 v (BangPat p)
+tidy1 _ p@(BangPat (L _(VarPat _)))       = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _(VarPatOut _ _)))  = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _ (WildPat _)))     = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _ (CoPat _ _ _)))   = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _ (SigPatIn _ _)))  = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _ (SigPatOut _ _))) = return (idDsWrapper, p)
+tidy1 v (BangPat (L _ (AsPat (L _ var) pat)))
+  = do	{ (wrap, pat') <- tidy1 v (BangPat pat)
+        ; return (wrapBind var v . wrap, pat') }
+tidy1 v (BangPat (L _ p))                   = tidy1 v p
+
 -- Everything else goes through unchanged...
 
 tidy1 _ non_interesting_pat
@@ -687,11 +702,11 @@ matchEquations ctxt vars eqns_info rhs_ty
   = do	{ dflags <- getDOptsDs
 	; locn   <- getSrcSpanDs
 	; let   ds_ctxt      = DsMatchContext ctxt locn
-		error_string = matchContextErrString ctxt
+		error_doc = matchContextErrString ctxt
 
 	; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
 
-	; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
+	; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
 	; extractMatchResult match_result fail_expr }
   where 
     match_fun dflags ds_ctxt
@@ -826,12 +841,12 @@ sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
        -- are "equal"---conservatively, we use syntactic equality
 sameGroup _          _          = False
 
--- an approximation of syntactic equality used for determining when view
+-- An approximation of syntactic equality used for determining when view
 -- exprs are in the same group.
--- this function can always safely return false;
+-- This function can always safely return false;
 -- but doing so will result in the application of the view function being repeated.
 --
--- currently: compare applications of literals and variables
+-- Currently: compare applications of literals and variables
 --            and anything else that we can do without involving other
 --            HsSyn types in the recursion
 --
@@ -844,12 +859,11 @@ viewLExprEq (e1,_) (e2,_) =
         -- short name for recursive call on unLoc
         lexp e e' = exp (unLoc e) (unLoc e')
 
-        -- check that two lists have the same length
-        -- and that they match up pairwise
-        lexps [] [] = True
-        lexps [] (_:_) = False
-        lexps (_:_) [] = False
-        lexps (x:xs) (y:ys) = lexp x y && lexps xs ys
+	eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
+        eq_list _  []     []     = True
+        eq_list _  []     (_:_)  = False
+        eq_list _  (_:_)  []     = False
+        eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
 
         -- conservative, in that it demands that wrappers be
         -- syntactically identical and doesn't look under binders
@@ -878,15 +892,13 @@ viewLExprEq (e1,_) (e2,_) =
         -- above does
         exp (HsIPVar i) (HsIPVar i') = i == i' 
         exp (HsOverLit l) (HsOverLit l') = 
-            -- overloaded lits are equal if they have the same type
+            -- Overloaded lits are equal if they have the same type
             -- and the data is the same.
             -- this is coarser than comparing the SyntaxExpr's in l and l',
             -- which resolve the overloading (e.g., fromInteger 1),
             -- because these expressions get written as a bunch of different variables
             -- (presumably to improve sharing)
             tcEqType (overLitType l) (overLitType l') && l == l'
-        -- comparing the constants seems right
-        exp (HsLit l) (HsLit l') = l == l'
         exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
         -- the fixities have been straightened out by now, so it's safe
         -- to ignore them?
@@ -897,14 +909,20 @@ viewLExprEq (e1,_) (e2,_) =
             lexp e1 e1' && lexp e2 e2'
         exp (SectionR e1 e2) (SectionR e1' e2') = 
             lexp e1 e1' && lexp e2 e2'
+        exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
+            eq_list tup_arg es1 es2
         exp (HsIf e e1 e2) (HsIf e' e1' e2') =
             lexp e e' && lexp e1 e1' && lexp e2 e2'
-        exp (ExplicitList _ ls) (ExplicitList _ ls') = lexps ls ls'
-        exp (ExplicitPArr _ ls) (ExplicitPArr _ ls') = lexps ls ls'
-        exp (ExplicitTuple ls _) (ExplicitTuple ls' _) = lexps ls ls'
+
         -- Enhancement: could implement equality for more expressions
         --   if it seems useful
+	-- But no need for HsLit, ExplicitList, ExplicitTuple, 
+	-- because they cannot be functions
         exp _ _  = False
+
+        tup_arg (Present e1) (Present e2) = lexp e1 e2
+        tup_arg (Missing t1) (Missing t2) = tcEqType t1 t2
+        tup_arg _ _ = False
     in
       lexp e1 e2