#include "HsVersions.h"
-import CmdLineOpts ( opt_WarnIncompletePatterns, opt_WarnOverlappingPatterns,
- opt_WarnSimplePatterns
- )
+import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn
-import TcHsSyn ( TypecheckedPat, TypecheckedMatch )
+import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext )
import DsHsSyn ( outPatType )
import Check ( check, ExhaustivePat )
import CoreSyn
import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon )
import BasicTypes ( Boxity(..) )
import UniqSet
-import ErrUtils ( addErrLocHdrLine, dontAddErrLoc )
+import ErrUtils ( addWarnLocHdrLine, dontAddErrLoc )
import Outputable
\end{code}
-> [EquationInfo] -- Info about patterns, etc. (type synonym below)
-> DsM MatchResult -- Desugared result!
-matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _)
+
+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` \ () ->
| otherwise =
match vars qs
where (pats,indexs) = check qs
- incomplete = opt_WarnIncompletePatterns && (length pats /= 0)
- shadow = opt_WarnOverlappingPatterns && sizeUniqSet indexs < no_eqns
+ 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
| otherwise = empty
pp_context NoMatchContext msg rest_of_msg_fun
- = dontAddErrLoc "" (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
+ = 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
- )
+ = addWarnLocHdrLine loc
+ (ptext SLIT("Pattern match(es)") <+> msg)
+ (sep [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 <+> ppr_pats pats, \ pp -> pp)
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("...")]
+ = sep [ppr_pats pats, ptext (matchSeparator kind), ptext SLIT("...")]
ppr_incomplete_pats kind (pats,[]) = ppr_pats pats
ppr_incomplete_pats kind (pats,constraints) =
\end{enumerate}
\begin{code}
-matchWrapper :: DsMatchKind -- For shadowing warning messages
- -> [TypecheckedMatch] -- Matches being desugared
- -> String -- Error message if the match fails
+matchWrapper :: TypecheckedMatchContext -- For shadowing warning messages
+ -> [TypecheckedMatch] -- Matches being desugared
-> DsM ([Id], CoreExpr) -- Results
\end{code}
JJQC 30-Nov-1997
\begin{code}
-matchWrapper kind matches error_string
- = flattenMatches kind matches `thenDs` \ (result_ty, eqns_info) ->
+matchWrapper ctxt matches
+ = getDOptsDs `thenDs` \ dflags ->
+ flattenMatches ctxt matches `thenDs` \ (result_ty, eqns_info) ->
let
EqnInfo _ _ arg_pats _ : _ = eqns_info
+ error_string = matchContextErrString ctxt
in
- mapDs selectMatchVar arg_pats `thenDs` \ new_vars ->
- match_fun new_vars eqns_info `thenDs` \ match_result ->
+ mapDs selectMatchVar arg_pats `thenDs` \ new_vars ->
+ match_fun dflags new_vars eqns_info `thenDs` \ match_result ->
mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr ->
extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
returnDs (new_vars, result_expr)
- where match_fun = case kind of
- LambdaMatch | opt_WarnSimplePatterns -> matchExport
- | otherwise -> match
- _ -> matchExport
+ where match_fun dflags
+ = case ctxt of
+ LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport
+ | otherwise -> match
+ _ -> matchExport
\end{code}
%************************************************************************
\begin{code}
matchSimply :: CoreExpr -- Scrutinee
- -> DsMatchKind -- Match kind
+ -> TypecheckedMatchContext -- Match kind
-> TypecheckedPat -- Pattern it should match
-> CoreExpr -- Return this if it matches
-> CoreExpr -- Return this if it doesn't
-> MatchResult -> DsM MatchResult
matchSinglePat (Var var) ctx pat match_result
- = match_fn [var] [EqnInfo 1 ctx [pat] match_result]
+ = getDOptsDs `thenDs` \ dflags ->
+ match_fn dflags [var] [EqnInfo 1 ctx [pat] match_result]
where
- match_fn | opt_WarnSimplePatterns = matchExport
- | otherwise = match
+ match_fn dflags
+ | dopt Opt_WarnSimplePatterns dflags = matchExport
+ | otherwise = match
matchSinglePat scrut ctx pat match_result
= selectMatchVar pat `thenDs` \ var ->
This is actually local to @matchWrapper@.
\begin{code}
-flattenMatches
- :: DsMatchKind
- -> [TypecheckedMatch]
- -> DsM (Type, [EquationInfo])
+flattenMatches :: TypecheckedMatchContext
+ -> [TypecheckedMatch]
+ -> DsM (Type, [EquationInfo])
flattenMatches kind matches
= mapAndUnzipDs flatten_match (matches `zip` [1..]) `thenDs` \ (result_tys, eqn_infos) ->
projects / ghc-hetmet.git / blobdiff