-import FieldLabel ( allFieldLabelTags, fieldLabelTag )
-import Id ( idType, mkTupleCon, dataConSig,
- dataConArgTys, recordSelectorFieldLabel,
- GenId{-instance-}
- )
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance-}, GenTyVar{-ditto-} )
-import PrelInfo ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
- charTy, charDataCon, intTy, intDataCon,
- floatTy, floatDataCon, doubleTy, doubleDataCon,
- integerTy, intPrimTy, charPrimTy,
- floatPrimTy, doublePrimTy, stringTy,
- addrTy, addrPrimTy, addrDataCon,
- wordTy, wordPrimTy, wordDataCon,
- pAT_ERROR_ID
- )
-import Type ( isPrimType, eqTy, getAppDataTyCon,
- instantiateTauTy
- )
-import TyVar ( GenTyVar{-instance Eq-} )
-import Unique ( Unique{-instance Eq-} )
-import Util ( panic, pprPanic, assertPanic )
+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}
+matchExport :: [Id] -- Vars rep'ing the exprs we're matching with
+ -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
+ -> DsM MatchResult -- Desugared result!
+
+
+matchExport vars qs
+ = getDOptsDs `thenDs` \ dflags ->
+ matchExport_really dflags vars qs
+
+matchExport_really dflags vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _)
+ | incomplete && shadow =
+ dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
+ dsIncompleteWarn ctx pats `thenDs` \ () ->
+ match vars qs
+ | incomplete =
+ dsIncompleteWarn ctx pats `thenDs` \ () ->
+ match vars qs
+ | shadow =
+ dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
+ match vars qs
+ | otherwise =
+ match vars qs
+ where (pats,indexs) = check qs
+ incomplete = dopt Opt_WarnIncompletePatterns dflags
+ && (length pats /= 0)
+ shadow = dopt Opt_WarnOverlappingPatterns dflags
+ && sizeUniqSet indexs < no_eqns
+ no_eqns = length qs
+ unused_eqns = uniqSetToList (mkUniqSet [1..no_eqns] `minusUniqSet` indexs)
+ eqns_shadow = map (\n -> qs!!(n - 1)) unused_eqns
+\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 | length qs > 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 | length pats > maximum_output = ptext SLIT("...")
+ | otherwise = empty
+
+pp_context NoMatchContext msg rest_of_msg_fun
+ = dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
+
+pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun
+ = case pp_match kind pats of
+ (ppr_match, pref) ->
+ addErrLocHdrLine loc message (nest 8 (rest_of_msg_fun pref))
+ where
+ message = ptext SLIT("Pattern match(es)") <+> msg <+> ppr_match <> char ':'
+ where
+ pp_match (FunMatch fun) pats
+ = let ppr_fun = ppr fun in
+ ( hsep [ptext SLIT("in the definition of function"), quotes ppr_fun]
+ , (\ x -> ppr_fun <+> x)
+ )
+
+ pp_match CaseMatch pats
+ = (hang (ptext SLIT("in a group of case alternatives beginning"))
+ 4 (ppr_pats pats)
+ , id
+ )
+
+ pp_match RecUpdMatch pats
+ = (hang (ptext SLIT("in a record-update construct"))
+ 4 (ppr_pats pats)
+ , id
+ )
+
+ pp_match PatBindMatch pats
+ = ( hang (ptext SLIT("in a pattern binding"))
+ 4 (ppr_pats pats)
+ , id
+ )
+
+ pp_match LambdaMatch pats
+ = ( hang (ptext SLIT("in a lambda abstraction"))
+ 4 (ppr_pats pats)
+ , id
+ )
+
+ pp_match DoBindMatch pats
+ = ( hang (ptext SLIT("in a `do' pattern binding"))
+ 4 (ppr_pats pats)
+ , id
+ )
+
+ pp_match ListCompMatch pats
+ = ( hang (ptext SLIT("in a `list comprension' pattern binding"))
+ 4 (ppr_pats pats)
+ , id
+ )
+
+ pp_match LetMatch pats
+ = ( hang (ptext SLIT("in a `let' pattern binding"))
+ 4 (ppr_pats pats)
+ , id
+ )
+
+ppr_pats pats = sep (map ppr pats)
+
+separator (FunMatch _) = SLIT("=")
+separator (CaseMatch) = SLIT("->")
+separator (LambdaMatch) = SLIT("->")
+separator (PatBindMatch) = panic "When is this used?"
+separator (RecUpdMatch) = panic "When is this used?"
+separator (DoBindMatch) = SLIT("<-")
+separator (ListCompMatch) = SLIT("<-")
+separator (LetMatch) = SLIT("=")
+
+ppr_shadow_pats kind pats
+ = sep [ppr_pats pats, ptext (separator 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 (map ppr_constraint constraints)]
+
+
+ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats]
+
+ppr_eqn prefixF kind (EqnInfo _ _ pats _) = prefixF (ppr_shadow_pats kind pats)