The @match@ function
\begin{code}
-{-# OPTIONS -w #-}
+{-# 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
import PrelInfo
import Type
import TysWiredIn
-import BasicTypes
import ListSetOps
import SrcLoc
import Maybes
import Util
import Name
import Outputable
+import FastString
\end{code}
This function is a wrapper of @match@, it must be called from all the parts where
-> [EquationInfo] -- Info about patterns, etc. (type synonym below)
-> DsM MatchResult -- Desugared result!
-matchCheck ctx vars ty qs
- = getDOptsDs `thenDs` \ dflags ->
- matchCheck_really dflags ctx vars ty qs
+matchCheck ctx vars ty qs = do
+ dflags <- getDOptsDs
+ matchCheck_really dflags ctx vars ty qs
+matchCheck_really :: DynFlags
+ -> DsMatchContext
+ -> [Id]
+ -> Type
+ -> [EquationInfo]
+ -> DsM MatchResult
matchCheck_really dflags ctx vars ty qs
- | incomplete && shadow =
- dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
- dsIncompleteWarn ctx pats `thenDs` \ () ->
+ | incomplete && shadow = do
+ dsShadowWarn ctx eqns_shadow
+ dsIncompleteWarn ctx pats
match vars ty qs
- | incomplete =
- dsIncompleteWarn ctx pats `thenDs` \ () ->
+ | incomplete = do
+ dsIncompleteWarn ctx pats
match vars ty qs
- | shadow =
- dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
+ | shadow = do
+ dsShadowWarn ctx eqns_shadow
match vars ty qs
| otherwise =
match vars ty qs
(ToDo: add command-line option?)
\begin{code}
+maximum_output :: Int
maximum_output = 4
\end{code}
= putSrcSpanDs loc (warnDs warn)
where
warn | qs `lengthExceeds` maximum_output
- = pp_context ctx (ptext SLIT("are overlapped"))
+ = pp_context ctx (ptext (sLit "are overlapped"))
(\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
- ptext SLIT("..."))
+ ptext (sLit "..."))
| otherwise
- = pp_context ctx (ptext SLIT("are overlapped"))
+ = pp_context ctx (ptext (sLit "are overlapped"))
(\ f -> vcat $ map (ppr_eqn f kind) qs)
dsIncompleteWarn ctx@(DsMatchContext kind loc) pats
= putSrcSpanDs loc (warnDs warn)
where
- warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
- (\f -> hang (ptext SLIT("Patterns not matched:"))
+ warn = pp_context ctx (ptext (sLit "are non-exhaustive"))
+ (\_ -> hang (ptext (sLit "Patterns not matched:"))
4 ((vcat $ map (ppr_incomplete_pats kind)
(take maximum_output pats))
$$ dots))
- dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
+ dots | pats `lengthExceeds` maximum_output = ptext (sLit "...")
| otherwise = empty
+pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
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)]]
+ = vcat [ptext (sLit "Pattern match(es)") <+> msg,
+ sep [ptext (sLit "In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
where
(ppr_match, pref)
= case kind of
FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
- other -> (pprMatchContext kind, \ pp -> pp)
+ _ -> (pprMatchContext kind, \ pp -> pp)
+ppr_pats :: Outputable a => [a] -> SDoc
ppr_pats pats = sep (map ppr pats)
+ppr_shadow_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
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) =
- sep [ppr_pats pats, ptext SLIT("with"),
+ = sep [ppr_pats pats, matchSeparator kind, ptext (sLit "...")]
+
+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)]
-
-ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats]
+ppr_constraint :: (Name,[HsLit]) -> SDoc
+ppr_constraint (var,pats) = sep [ppr var, ptext (sLit "`notElem`"), ppr pats]
+ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> EquationInfo -> SDoc
ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))
\end{code}
match [] ty eqns
= ASSERT2( not (null eqns), ppr ty )
- returnDs (foldr1 combineMatchResults match_results)
+ return (foldr1 combineMatchResults match_results)
where
match_results = [ ASSERT( null (eqn_pats eqn) )
eqn_rhs eqn
; let grouped = (groupEquations tidy_eqns)
-- print the view patterns that are commoned up to help debug
- ; ifOptDs Opt_D_dump_view_pattern_commoning (debug grouped)
+ ; ifOptM Opt_D_dump_view_pattern_commoning (debug grouped)
; match_results <- mapM match_group grouped
; return (adjustMatchResult (foldr1 (.) aux_binds) $
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)
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 (var:vars) ty eqns = match vars ty (shiftEqns eqns)
+matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchBangs (var:vars) ty eqns
; return (mkViewMatchResult var' viewExpr' var match_result) }
-- 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}
+decomposeFirst_Coercion, decomposeFirst_Bang, decomposeFirst_View :: EquationInfo -> EquationInfo
+
decomposeFirst_Coercion = decomposeFirstPat (\ (CoPat _ pat _) -> pat)
decomposeFirst_Bang = decomposeFirstPat (\ (BangPat pat ) -> unLoc pat)
decomposeFirst_View = decomposeFirstPat (\ (ViewPat _ pat _) -> unLoc pat)
-- NPlusKPat
-- but no other
-tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })
- = tidy1 v pat `thenDs` \ (wrap, pat') ->
- returnDs (wrap, eqn { eqn_pats = pat' : pats })
+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
tidy1 v (ParPat pat) = tidy1 v (unLoc pat)
tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)
-tidy1 v (WildPat ty) = returnDs (idDsWrapper, WildPat ty)
+tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty)
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
tidy1 v (VarPat var)
- = returnDs (wrapBind var v, WildPat (idType var))
+ = return (wrapBind var v, WildPat (idType var))
tidy1 v (VarPatOut var binds)
= do { prs <- dsLHsBinds binds
tidy1 v (LazyPat pat)
= do { sel_prs <- mkSelectorBinds pat (Var v)
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
- ; returnDs (mkDsLets sel_binds, WildPat (idType v)) }
+ ; return (mkDsLets sel_binds, WildPat (idType v)) }
-tidy1 v (ListPat pats ty)
- = returnDs (idDsWrapper, unLoc list_ConPat)
+tidy1 _ (ListPat pats ty)
+ = return (idDsWrapper, unLoc list_ConPat)
where
list_ty = mkListTy ty
list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
-- Introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
-tidy1 v (PArrPat pats ty)
- = returnDs (idDsWrapper, unLoc parrConPat)
+tidy1 _ (PArrPat pats ty)
+ = return (idDsWrapper, unLoc parrConPat)
where
arity = length pats
parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
-tidy1 v (TuplePat pats boxity ty)
- = returnDs (idDsWrapper, unLoc tuple_ConPat)
+tidy1 _ (TuplePat pats boxity 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
-tidy1 v (LitPat lit)
- = returnDs (idDsWrapper, tidyLitPat lit)
+tidy1 _ (LitPat lit)
+ = return (idDsWrapper, tidyLitPat lit)
-- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 v (NPat lit mb_neg eq)
- = returnDs (idDsWrapper, tidyNPat lit mb_neg eq)
+tidy1 _ (NPat lit mb_neg eq)
+ = return (idDsWrapper, tidyNPat lit mb_neg eq)
-- Everything else goes through unchanged...
-tidy1 v non_interesting_pat
- = returnDs (idDsWrapper, non_interesting_pat)
+tidy1 _ non_interesting_pat
+ = return (idDsWrapper, non_interesting_pat)
\end{code}
\noindent
-> CoreExpr -- Return this if it doesn't
-> DsM CoreExpr
-matchSimply scrut hs_ctx pat result_expr fail_expr
- = let
+matchSimply scrut hs_ctx pat result_expr fail_expr = do
+ let
match_result = cantFailMatchResult result_expr
- rhs_ty = exprType fail_expr
- -- Use exprType of fail_expr, because won't refine in the case of failure!
- in
- matchSinglePat scrut hs_ctx pat rhs_ty match_result `thenDs` \ match_result' ->
+ rhs_ty = exprType fail_expr
+ -- Use exprType of fail_expr, because won't refine in the case of failure!
+ match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
extractMatchResult match_result' fail_expr
matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
-> Type -> MatchResult -> DsM MatchResult
-matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result
- = getDOptsDs `thenDs` \ dflags ->
- getSrcSpanDs `thenDs` \ locn ->
+matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result = do
+ dflags <- getDOptsDs
+ locn <- getSrcSpanDs
let
- match_fn dflags
+ match_fn dflags
| dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
- | otherwise = match
- where
- ds_ctx = DsMatchContext hs_ctx locn
- in
+ | otherwise = match
+ where
+ ds_ctx = DsMatchContext hs_ctx locn
match_fn dflags [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }]
-matchSinglePat scrut hs_ctx pat ty match_result
- = selectSimpleMatchVarL pat `thenDs` \ var ->
- matchSinglePat (Var var) hs_ctx pat ty match_result `thenDs` \ match_result' ->
- returnDs (adjustMatchResult (bindNonRec var scrut) match_result')
+matchSinglePat scrut hs_ctx pat ty match_result = do
+ var <- selectSimpleMatchVarL pat
+ match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
+ return (adjustMatchResult (bindNonRec var scrut) match_result')
\end{code}
sameGroup PgBang PgBang = True
sameGroup (PgCon _) (PgCon _) = True -- One case expression
sameGroup (PgLit _) (PgLit _) = True -- One case expression
-sameGroup (PgN l1) (PgN l2) = True -- Needs conditionals
+sameGroup (PgN _) (PgN _) = True -- Needs conditionals
sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- Order is significant
-- See Note [Order of n+k]
sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2
-- f (e1 -> True) = ...
-- f (e2 -> "hi") = ...
viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool
-viewLExprEq (e1,t1) (e2,t2) =
+viewLExprEq (e1,_) (e2,_) =
let
-- short name for recursive call on unLoc
lexp e e' = exp (unLoc e) (unLoc e')
-- 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 (WpCo c) (WpCo c') = tcEqType c c'
- wrap (WpApp d) (WpApp d') = d == d'
+ wrap (WpCast c) (WpCast c') = tcEqType c c'
+ wrap (WpApp d) (WpApp d') = d == d'
wrap (WpTyApp t) (WpTyApp t') = tcEqType t t'
-- Enhancement: could implement equality for more wrappers
-- if it seems useful (lams and lets)
projects / ghc-hetmet.git / blobdiff