X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FMatch.lhs;h=d64a649b3717215fe2ee94381a5f33ea4bec0e5a;hp=24c4680f7dddfe45696ebadf56dff5e802bcaf39;hb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade;hpb=79b22beb4d2eca1877d99d55838ba6ce69658405 diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 24c4680..d64a649 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -35,7 +35,6 @@ import Id import DataCon import MatchCon import MatchLit -import PrelInfo import Type import TysWiredIn import ListSetOps @@ -344,10 +343,11 @@ matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the coercion to the match variable and then match that matchCoercion (var:vars) ty (eqns@(eqn1:_)) = do { let CoPat co pat _ = firstPat eqn1 - ; var' <- newUniqueId (idName var) (hsPatType pat) + ; var' <- newUniqueId var (hsPatType pat) ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns) - ; rhs <- dsCoercion co (return (Var var)) - ; return (mkCoLetMatchResult (NonRec var' rhs) match_result) } + ; co' <- dsHsWrapper co + ; let rhs' = co' (Var var) + ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) } matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the view function to the match variable and then match that @@ -357,7 +357,7 @@ matchView (var:vars) ty (eqns@(eqn1:_)) -- to figure out the type of the fresh variable let ViewPat viewExpr (L _ pat) _ = firstPat eqn1 -- do the rest of the compilation - ; var' <- newUniqueId (idName var) (hsPatType pat) + ; var' <- newUniqueId var (hsPatType pat) ; match_result <- match (var':vars) ty (map decomposeFirst_View eqns) -- compile the view expressions ; viewExpr' <- dsLExpr viewExpr @@ -463,8 +463,8 @@ tidy1 v (VarPat var) = return (wrapBind var v, WildPat (idType var)) tidy1 v (VarPatOut var binds) - = do { prs <- dsLHsBinds binds - ; return (wrapBind var v . mkCoreLet (Rec prs), + = do { ds_ev_binds <- dsTcEvBinds binds + ; return (wrapBind var v . wrapDsEvBinds ds_ev_binds, WildPat (idType var)) } -- case v of { x@p -> mr[] } @@ -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 @@ -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 @@ -860,7 +874,7 @@ viewLExprEq (e1,_) (e2,_) = 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 (WpApp d) (WpApp d') = d == d' + 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) @@ -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