import DataCon
import MatchCon
import MatchLit
-import PrelInfo
import Type
import TysWiredIn
import ListSetOps
-- 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
-- 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
= 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[] }
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
-- 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
--
-- 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
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)
-- 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?
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
projects / ghc-hetmet.git / blobdiff