From a1895147d4d0480f65535c99488ba25873e97bff Mon Sep 17 00:00:00 2001
From: Ian Lynagh <igloo@earth.li>
Date: Sun, 9 Aug 2009 15:42:58 +0000
Subject: [PATCH] Minor refactoring

---
 compiler/deSugar/Check.lhs |    4 ++--
 compiler/hsSyn/HsPat.lhs   |   53 +++++++++++++++++++++-----------------------
 2 files changed, 27 insertions(+), 30 deletions(-)

diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index ec72287..63ce765 100644
--- a/compiler/deSugar/Check.lhs
+++ b/compiler/deSugar/Check.lhs
@@ -113,8 +113,8 @@ check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo])
 check qs | has_view_pattern = ([],[])
          | otherwise = (untidy_warns, shadowed_eqns)
       where
-        is_view x = hasViewPat x
-        has_view_pattern = any (\(EqnInfo p _) -> any is_view p) qs
+        eqnInfo_has_view_pattern (EqnInfo ps _) = any (hasViewPat . noLoc) ps
+        has_view_pattern = any eqnInfo_has_view_pattern qs
 	(warns, used_nos) = check' ([1..] `zip` map simplify_eqn qs)
 	untidy_warns = map untidy_exhaustive warns 
 	shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..], 
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index 3df0160..e87a6a2 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -369,36 +369,33 @@ patterns are treated specially, of course.
 
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 \begin{code}
-hasViewPat :: Pat id -> Bool
-hasViewPat p = hasViewPat' (L undefined p)
-
-hasViewPat' :: LPat id -> Bool
-hasViewPat' (L _ p) = go p where
-  go (WildPat _) = False
-  go (VarPat _) = False
-  go (VarPatOut _ _) = False
-  go (LazyPat p) = hasViewPat' p
-  go (AsPat _ p) = hasViewPat' p
-  go (ParPat p) = hasViewPat' p
-  go (BangPat p) = hasViewPat' p
-  go (ListPat p _) = any hasViewPat' p
-  go (TuplePat p _ _) = any hasViewPat' p
-  go (PArrPat p _) = any hasViewPat' p
-  go (ConPatIn _ p) = go' p
+hasViewPat :: LPat id -> Bool
+hasViewPat (L _ p) = go p where
+  go (WildPat _)             = False
+  go (VarPat _)              = False
+  go (VarPatOut _ _)         = False
+  go (LazyPat p)             = hasViewPat p
+  go (AsPat _ p)             = hasViewPat p
+  go (ParPat p)              = hasViewPat p
+  go (BangPat p)             = hasViewPat p
+  go (ListPat p _)           = any hasViewPat p
+  go (TuplePat p _ _)        = any hasViewPat p
+  go (PArrPat p _)           = any hasViewPat p
+  go (ConPatIn _ p)          = go' p
   go (ConPatOut _ _ _ _ p _) = go' p
-  go (ViewPat _ _ _) = True
-  go (QuasiQuotePat _) = False
-  go (LitPat _) = False
-  go (NPat _ _ _) = False
-  go (NPlusKPat _ _ _ _) = False
-  go (TypePat _) = False
-  go (SigPatIn p _) = hasViewPat' p
-  go (SigPatOut p _) = hasViewPat' p
-  go (CoPat _ _ _) = False
+  go (ViewPat _ _ _)         = True
+  go (QuasiQuotePat _)       = False
+  go (LitPat _)              = False
+  go (NPat _ _ _)            = False
+  go (NPlusKPat _ _ _ _)     = False
+  go (TypePat _)             = False
+  go (SigPatIn p _)          = hasViewPat p
+  go (SigPatOut p _)         = hasViewPat p
+  go (CoPat _ _ _)           = False
   go' p = case p of
-    PrefixCon ps -> any hasViewPat' ps
-    RecCon (HsRecFields fs _) -> any (hasViewPat' . hsRecFieldArg) fs
-    InfixCon p1 p2 -> hasViewPat' p1 || hasViewPat' p2
+    PrefixCon ps              -> any hasViewPat ps
+    RecCon (HsRecFields fs _) -> any (hasViewPat . hsRecFieldArg) fs
+    InfixCon p1 p2            -> hasViewPat p1 || hasViewPat p2
 
 isWildPat :: Pat id -> Bool
 isWildPat (WildPat _) = True
-- 
1.7.10.4