Commit e6e40cc1 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Fix Trac #4371: matching of view patterns

parent 1dbeddfa
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment