Fix Trac #4371: matching of view patterns

1 files changed, 94 insertions, 83 deletions

diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 4bc0c4b792..0544d9bb18 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -6,13 +6,6 @@
 The @match@ function
 
 \begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- 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 Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
 
 #include "HsVersions.h"
@@ -303,11 +296,11 @@ match vars@(v:_) ty eqns
     dropGroup = map snd
 
     match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
+    match_group [] = panic "match_group"
     match_group eqns@((group,_) : _)
         = case group of
             PgCon _    -> matchConFamily  vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns])
             PgLit _    -> matchLiterals   vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns])
-
             PgAny      -> matchVariables  vars ty (dropGroup eqns)
             PgN _      -> matchNPats      vars ty (dropGroup eqns)
             PgNpK _    -> matchNPlusKPats vars ty (dropGroup eqns)
@@ -334,11 +327,13 @@ matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Real true variables, just like in matchVar, SLPJ p 94
 -- No binding to do: they'll all be wildcards by now (done in tidy)
 matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
+matchVariables [] _ _ = panic "matchVariables"
 
 matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 matchBangs (var:vars) ty eqns
   = do	{ match_result <- match (var:vars) ty (map decomposeFirst_Bang eqns)
 	; return (mkEvalMatchResult var ty match_result) }
+matchBangs [] _ _ = panic "matchBangs"
 
 matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Apply the coercion to the match variable and then match that
@@ -349,6 +344,7 @@ matchCoercion (var:vars) ty (eqns@(eqn1:_))
 	; co' <- dsHsWrapper co
         ; let rhs' = co' (Var var)
 	; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
+matchCoercion _ _ _ = panic "matchCoercion"
 
 matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Apply the view function to the match variable and then match that
@@ -361,13 +357,15 @@ matchView (var:vars) ty (eqns@(eqn1:_))
 	; var' <- newUniqueId var (hsPatType pat)
 	; match_result <- match (var':vars) ty (map decomposeFirst_View eqns)
          -- compile the view expressions
-       ; viewExpr' <- dsLExpr viewExpr
+        ; viewExpr' <- dsLExpr viewExpr
 	; return (mkViewMatchResult var' viewExpr' var match_result) }
+matchView _ _ _ = panic "matchView"
 
 -- decompose the first pattern and leave the rest alone
 decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo
 decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
 	= eqn { eqn_pats = extractpat pat : pats}
+decomposeFirstPat _ _ = panic "decomposeFirstPat"
 
 decomposeFirst_Coercion, decomposeFirst_Bang, decomposeFirst_View :: EquationInfo -> EquationInfo
 
@@ -434,9 +432,12 @@ tidyEqnInfo :: Id -> EquationInfo
 	--	NPlusKPat
 	-- but no other
 
-tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats }) = do
-    (wrap, pat') <- tidy1 v pat
-    return (wrap, eqn { eqn_pats = do pat' : pats })
+tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) 
+  = panic "tidyEqnInfo"
+
+tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })
+  = do { (wrap, pat') <- tidy1 v pat
+       ; return (wrap, eqn { eqn_pats = do pat' : pats }) }
 
 tidy1 :: Id 			-- The Id being scrutinised
       -> Pat Id 		-- The pattern against which it is to be matched
@@ -843,77 +844,87 @@ sameGroup _          _          = False
 --   f (e1 -> True) = ...
 --   f (e2 -> "hi") = ...
 viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool
-viewLExprEq (e1,_) (e2,_) =
-    let 
-        -- short name for recursive call on unLoc
-        lexp e e' = exp (unLoc e) (unLoc e')
-
-	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
-        --
-        -- coarser notions of equality are possible
-        -- (e.g., reassociating compositions,
-        --        equating different ways of writing a coercion)
-        wrap WpHole WpHole = True
-        wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
-        wrap (WpCast c)  (WpCast c')  = tcEqType c c'
-        wrap (WpEvApp _) (WpEvApp _) = panic "ToDo: Match.viewLExprEq"
-        wrap (WpTyApp t) (WpTyApp t') = tcEqType t t'
-        -- Enhancement: could implement equality for more wrappers
-        --   if it seems useful (lams and lets)
-        wrap _ _ = False
-
-        -- real comparison is on HsExpr's
-        -- strip parens 
-        exp (HsPar (L _ e)) e'   = exp e e'
-        exp e (HsPar (L _ e'))   = exp e e'
-        -- because the expressions do not necessarily have the same type,
-        -- we have to compare the wrappers
-        exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
-        exp (HsVar i) (HsVar i') =  i == i' 
-        -- the instance for IPName derives using the id, so this works if the
-        -- above does
-        exp (HsIPVar i) (HsIPVar i') = i == i' 
-        exp (HsOverLit l) (HsOverLit l') = 
-            -- 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'
-        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?
-        exp (OpApp l o _ ri) (OpApp l' o' _ ri') = 
-            lexp l l' && lexp o o' && lexp ri ri'
-        exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n'
-        exp (SectionL e1 e2) (SectionL 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'
-
-        -- 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
+viewLExprEq (e1,_) (e2,_) = lexp e1 e2
+  where
+    lexp :: LHsExpr Id -> LHsExpr Id -> Bool
+    lexp e e' = exp (unLoc e) (unLoc e')
+
+    ---------
+    exp :: HsExpr Id -> HsExpr Id -> Bool
+    -- real comparison is on HsExpr's
+    -- strip parens 
+    exp (HsPar (L _ e)) e'   = exp e e'
+    exp e (HsPar (L _ e'))   = exp e e'
+    -- because the expressions do not necessarily have the same type,
+    -- we have to compare the wrappers
+    exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
+    exp (HsVar i) (HsVar i') =  i == i' 
+    -- the instance for IPName derives using the id, so this works if the
+    -- above does
+    exp (HsIPVar i) (HsIPVar i') = i == i' 
+    exp (HsOverLit l) (HsOverLit l') = 
+        -- 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'
+    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?
+    exp (OpApp l o _ ri) (OpApp l' o' _ ri') = 
+        lexp l l' && lexp o o' && lexp ri ri'
+    exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n'
+    exp (SectionL e1 e2) (SectionL 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'
+
+    -- 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
+
+    ---------
+    wrap :: HsWrapper -> HsWrapper -> Bool
+    -- Conservative, in that it demands that wrappers be
+    -- syntactically identical and doesn't look under binders
+    --
+    -- Coarser notions of equality are possible
+    -- (e.g., reassociating compositions,
+    --        equating different ways of writing a coercion)
+    wrap WpHole WpHole = True
+    wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
+    wrap (WpCast c)  (WpCast c')     = tcEqType c c'
+    wrap (WpEvApp et1) (WpEvApp et2) = ev_term et1 et2
+    wrap (WpTyApp t) (WpTyApp t')    = tcEqType t t'
+    -- Enhancement: could implement equality for more wrappers
+    --   if it seems useful (lams and lets)
+    wrap _ _ = False
+
+    ---------
+    ev_term :: EvTerm -> EvTerm -> Bool
+    ev_term (EvId a)       (EvId b)       = a==b
+    ev_term (EvCoercion a) (EvCoercion b) = tcEqType a b
+    ev_term _ _ = False	
+
+    ---------
+    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
 
 patGroup :: Pat Id -> PatGroup
 patGroup (WildPat {})       	      = PgAny