-- 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
-- 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
matchCheck_really dflags ctx vars ty qs
| incomplete && shadow = do
dsShadowWarn ctx eqns_shadow
matchCheck_really dflags ctx vars ty qs
| incomplete && shadow = do
dsShadowWarn ctx eqns_shadow
pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
= vcat [ptext SLIT("Pattern match(es)") <+> msg,
sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
= vcat [ptext SLIT("Pattern match(es)") <+> msg,
sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
ppr_shadow_pats kind pats
= sep [ppr_pats pats, matchSeparator kind, ptext SLIT("...")]
ppr_shadow_pats kind pats
= sep [ppr_pats pats, matchSeparator kind, ptext SLIT("...")]
-
-ppr_incomplete_pats kind (pats,[]) = ppr_pats pats
-ppr_incomplete_pats kind (pats,constraints) =
+
+ppr_incomplete_pats :: HsMatchContext Name -> ExhaustivePat -> SDoc
+ppr_incomplete_pats _ (pats,[]) = ppr_pats pats
+ppr_incomplete_pats _ (pats,constraints) =
sep [ppr_pats pats, ptext SLIT("with"),
sep (map ppr_constraint constraints)]
sep [ppr_pats pats, ptext SLIT("with"),
sep (map ppr_constraint constraints)]
ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats]
ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats]
PgAny -> matchVariables vars ty (dropGroup eqns)
PgCon _ -> matchConFamily vars ty (subGroups eqns)
PgLit _ -> matchLiterals vars ty (subGroups eqns)
PgAny -> matchVariables vars ty (dropGroup eqns)
PgCon _ -> matchConFamily vars ty (subGroups eqns)
PgLit _ -> matchLiterals vars ty (subGroups eqns)
- PgN lit -> matchNPats vars ty (subGroups eqns)
- PgNpK lit -> matchNPlusKPats vars ty (dropGroup eqns)
+ PgN _ -> matchNPats vars ty (subGroups eqns)
+ PgNpK _ -> matchNPlusKPats vars ty (dropGroup eqns)
PgBang -> matchBangs vars ty (dropGroup eqns)
PgCo _ -> matchCoercion vars ty (dropGroup eqns)
PgView _ _ -> matchView vars ty (dropGroup eqns)
PgBang -> matchBangs vars ty (dropGroup eqns)
PgCo _ -> matchCoercion vars ty (dropGroup eqns)
PgView _ _ -> matchView vars ty (dropGroup eqns)
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 :: [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)
; return (mkViewMatchResult var' viewExpr' var match_result) }
-- decompose the first pattern and leave the rest alone
; return (mkViewMatchResult var' viewExpr' var match_result) }
-- decompose the first pattern and leave the rest alone
decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
= eqn { eqn_pats = extractpat pat : pats}
decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
= eqn { eqn_pats = extractpat pat : pats}
decomposeFirst_Coercion = decomposeFirstPat (\ (CoPat _ pat _) -> pat)
decomposeFirst_Bang = decomposeFirstPat (\ (BangPat pat ) -> unLoc pat)
decomposeFirst_View = decomposeFirstPat (\ (ViewPat _ pat _) -> unLoc pat)
decomposeFirst_Coercion = decomposeFirstPat (\ (CoPat _ pat _) -> pat)
decomposeFirst_Bang = decomposeFirstPat (\ (BangPat pat ) -> unLoc pat)
decomposeFirst_View = decomposeFirstPat (\ (ViewPat _ pat _) -> unLoc pat)
Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
together with the binding @x = v@.
\item
Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
together with the binding @x = v@.
\item
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
; return (mkDsLets sel_binds, WildPat (idType v)) }
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
; return (mkDsLets sel_binds, WildPat (idType v)) }
-- Introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
-- Introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
= return (idDsWrapper, unLoc parrConPat)
where
arity = length pats
parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
= return (idDsWrapper, unLoc parrConPat)
where
arity = length pats
parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
= return (idDsWrapper, unLoc tuple_ConPat)
where
arity = length pats
tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
-- LitPats: we *might* be able to replace these w/ a simpler form
= return (idDsWrapper, unLoc tuple_ConPat)
where
arity = length pats
tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
-- LitPats: we *might* be able to replace these w/ a simpler form
= return (idDsWrapper, tidyLitPat lit)
-- NPats: we *might* be able to replace these w/ a simpler form
= return (idDsWrapper, tidyLitPat lit)
-- NPats: we *might* be able to replace these w/ a simpler form
= return (idDsWrapper, tidyNPat lit mb_neg eq)
-- Everything else goes through unchanged...
= return (idDsWrapper, tidyNPat lit mb_neg eq)
-- Everything else goes through unchanged...
sameGroup PgBang PgBang = True
sameGroup (PgCon _) (PgCon _) = True -- One case expression
sameGroup (PgLit _) (PgLit _) = True -- One case expression
sameGroup PgBang PgBang = True
sameGroup (PgCon _) (PgCon _) = True -- One case expression
sameGroup (PgLit _) (PgLit _) = True -- One case expression
sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- Order is significant
-- See Note [Order of n+k]
sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2
sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- Order is significant
-- See Note [Order of n+k]
sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2
-- equating different ways of writing a coercion)
wrap WpHole WpHole = True
wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
-- 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 (WpTyApp t) (WpTyApp t') = tcEqType t t'
-- Enhancement: could implement equality for more wrappers
-- if it seems useful (lams and lets)
wrap (WpTyApp t) (WpTyApp t') = tcEqType t t'
-- Enhancement: could implement equality for more wrappers
-- if it seems useful (lams and lets)