<commit_before>%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%

The @match@ function

\begin{code}
{-# 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
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details

module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where

#include "HsVersions.h"

import {-#SOURCE#-} DsExpr (dsLExpr)

import DynFlags
import HsSyn		
import TcHsSyn
import Check
import CoreSyn
import Literal
import CoreUtils
import DsMonad
import DsBinds
import DsGRHSs
import DsUtils
import Id
import DataCon
import MatchCon
import MatchLit
import PrelInfo
import Type
import TysWiredIn
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 
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 = 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  = do
      dsShadowWarn ctx eqns_shadow
      dsIncompleteWarn ctx pats
      match vars ty qs
  | incomplete            = do
      dsIncompleteWarn ctx pats
      match vars ty qs
  | shadow                = do
      dsShadowWarn ctx eqns_shadow
      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 :: Int
maximum_output = 4
\end{code}

The next two functions create the warning message.

\begin{code}
dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
dsShadowWarn ctx@(DsMatchContext kind loc) qs
  = putSrcSpanDs loc (warnDs 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 loc) pats 
  = putSrcSpanDs loc (warnDs warn)
	where
	  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("...")
	       | 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)]]
  where
    (ppr_match, pref)
	= case kind of
	     FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> 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 :: 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 :: (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}<commit_msg>(F)SLIT -> (f)sLit in Match<commit_after>%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%

The @match@ function

\begin{code}
{-# 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
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details

module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where

#include "HsVersions.h"

import {-#SOURCE#-} DsExpr (dsLExpr)

import DynFlags
import HsSyn		
import TcHsSyn
import Check
import CoreSyn
import Literal
import CoreUtils
import DsMonad
import DsBinds
import DsGRHSs
import DsUtils
import Id
import DataCon
import MatchCon
import MatchLit
import PrelInfo
import Type
import TysWiredIn
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 
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 = 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  = do
      dsShadowWarn ctx eqns_shadow
      dsIncompleteWarn ctx pats
      match vars ty qs
  | incomplete            = do
      dsIncompleteWarn ctx pats
      match vars ty qs
  | shadow                = do
      dsShadowWarn ctx eqns_shadow
      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 :: Int
maximum_output = 4
\end{code}

The next two functions create the warning message.

\begin{code}
dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
dsShadowWarn ctx@(DsMatchContext kind loc) qs
  = putSrcSpanDs loc (warnDs 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 loc) pats 
  = putSrcSpanDs loc (warnDs warn)
	where
	  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 "...")
	       | 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)]]
  where
    (ppr_match, pref)
	= case kind of
	     FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> 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 :: 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 :: (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}
{'fraction_non_alphanumeric': 0.09140733859730608, 'fraction_numerical': 0.0039015327450069672, 'mean_word_length': 2.5402828017099637, 'pattern_counts': {'":': 0, '<': 13, '<?xml version=': 0, '>': 88, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 4, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7628373', 'n_tokens_mistral': 3553, 'n_tokens_neox': 3354, 'n_words': 1088}