-import MatchLit ( matchLiterals )
-
-import FieldLabel ( FieldLabel {- Eq instance -} )
-import Id ( idType, dataConFieldLabels,
- dataConArgTys, recordSelectorFieldLabel,
- GenId{-instance-}, SYN_IE(Id)
- )
-import Name ( Name {--O only-} )
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance-}, GenTyVar{-ditto-} )
-import Pretty ( Doc )
-import PrelVals ( pAT_ERROR_ID )
-import Type ( isPrimType, eqTy, getAppDataTyConExpandingDicts,
- instantiateTauTy, SYN_IE(Type)
- )
-import TyVar ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
-import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
- addrPrimTy, wordPrimTy
- )
-import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
- charTy, charDataCon, intTy, intDataCon,
- floatTy, floatDataCon, doubleTy, tupleCon,
- doubleDataCon, stringTy, addrTy,
- addrDataCon, wordTy, wordDataCon
- )
-import Unique ( Unique{-instance Eq-} )
-import Util ( panic, pprPanic, assertPanic )
-#if __GLASGOW_HASKELL__ >= 202
-import Outputable ( Outputable(..) )
-#endif
+import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat )
+import PrelInfo ( pAT_ERROR_ID )
+import TcType ( Type, tcTyConAppArgs )
+import Type ( splitFunTysN )
+import TysWiredIn ( consDataCon, mkTupleTy, mkListTy,
+ tupleCon, parrFakeCon, mkPArrTy )
+import BasicTypes ( Boxity(..) )
+import ListSetOps ( runs )
+import SrcLoc ( noSrcSpan, noLoc, unLoc, Located(..) )
+import Util ( lengthExceeds, notNull )
+import Name ( Name )
+import Outputable
+\end{code}
+
+This function is a wrapper of @match@, it must be called from all the parts where
+it was called match, but only substitutes the firs call, ....
+if the associated flags are declared, warnings will be issued.
+It can not be called matchWrapper because this name already exists :-(
+
+JJCQ 30-Nov-1997
+
+\begin{code}
+matchCheck :: DsMatchContext
+ -> [Id] -- Vars rep'ing the exprs we're matching with
+ -> Type -- Type of the case expression
+ -> [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_really dflags ctx vars ty qs
+ | incomplete && shadow =
+ dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
+ dsIncompleteWarn ctx pats `thenDs` \ () ->
+ match vars ty qs
+ | incomplete =
+ dsIncompleteWarn ctx pats `thenDs` \ () ->
+ match vars ty qs
+ | shadow =
+ dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
+ match vars ty qs
+ | otherwise =
+ match vars ty qs
+ where (pats, eqns_shadow) = check qs
+ incomplete = want_incomplete && (notNull pats)
+ want_incomplete = case ctx of
+ DsMatchContext RecUpd _ _ ->
+ dopt Opt_WarnIncompletePatternsRecUpd dflags
+ _ ->
+ dopt Opt_WarnIncompletePatterns dflags
+ shadow = dopt Opt_WarnOverlappingPatterns dflags
+ && not (null eqns_shadow)
+\end{code}
+
+This variable shows the maximum number of lines of output generated for warnings.
+It will limit the number of patterns/equations displayed to@ maximum_output@.
+
+(ToDo: add command-line option?)
+
+\begin{code}
+maximum_output = 4
+\end{code}
+
+The next two functions create the warning message.
+
+\begin{code}
+dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
+dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn
+ where
+ warn | qs `lengthExceeds` maximum_output
+ = pp_context ctx (ptext SLIT("are overlapped"))
+ (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
+ ptext SLIT("..."))
+ | otherwise
+ = pp_context ctx (ptext SLIT("are overlapped"))
+ (\ f -> vcat $ map (ppr_eqn f kind) qs)
+
+
+dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
+dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
+ where
+ warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
+ (\f -> 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("...")
+ | otherwise = empty
+
+pp_context NoMatchContext msg rest_of_msg_fun
+ = (noSrcSpan, ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
+
+pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun
+ = (loc, 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)
+
+ppr_pats pats = sep (map ppr pats)