From: simonpj@microsoft.com Date: Wed, 6 Oct 2010 11:53:16 +0000 (+0000) Subject: Fix Trac #4371: matching of view patterns X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=e6e40cc112504af5062afed162993aa9352c1d2c Fix Trac #4371: matching of view patterns --- diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 4bc0c4b..0544d9b 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