#include "HsVersions.h"
-import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
-
-import CmdLineOpts ( opt_WarnIncompletePatterns, opt_WarnOverlappingPatterns,
- opt_WarnSimplePatterns
- )
+import {-# SOURCE #-} DsExpr( dsExpr )
+import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn
-import TcHsSyn ( TypecheckedPat, TypecheckedMatch )
-import DsHsSyn ( outPatType )
+import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, outPatType )
import Check ( check, ExhaustivePat )
import CoreSyn
-import CoreUtils ( coreExprType )
+import CoreUtils ( bindNonRec )
import DsMonad
import DsGRHSs ( dsGRHSs )
import DsUtils
import Id ( idType, recordSelectorFieldLabel, Id )
-import DataCon ( dataConFieldLabels, dataConArgTys )
+import DataCon ( dataConFieldLabels, dataConInstOrigArgTys )
import MatchCon ( matchConFamily )
import MatchLit ( matchLiterals )
-import PrelVals ( pAT_ERROR_ID )
-import Type ( isUnLiftedType, splitAlgTyConApp,
- Type
- )
-import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
- addrPrimTy, wordPrimTy
- )
+import PrelInfo ( pAT_ERROR_ID )
+import TcType ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType )
import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
- charTy, charDataCon, intTy, intDataCon,
- floatTy, floatDataCon, doubleTy, tupleCon,
- doubleDataCon, addrTy,
- addrDataCon, wordTy, wordDataCon,
- mkUnboxedTupleTy, unboxedTupleCon
- )
+ tupleCon, parrFakeCon, mkPArrTy )
+import BasicTypes ( Boxity(..) )
import UniqSet
-import ErrUtils ( addErrLocHdrLine, dontAddErrLoc )
+import ErrUtils ( addWarnLocHdrLine, dontAddErrLoc )
+import Util ( lengthExceeds, notNull )
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
+ && (notNull pats)
+ 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 maximun number of lines of output generated for warnings.
-It will limit the number of patterns/equations displayed to maximum_output.
+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?)
maximum_output = 4
\end{code}
-The next two functions creates the warning message.
+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
+ 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("..."))
(take maximum_output pats))
$$ dots))
- dots | length pats > maximum_output = ptext SLIT("...")
- | otherwise = empty
+ dots | pats `lengthExceeds` 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))
+ = 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 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 (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) =
sep (map ppr_constraint constraints)]
-ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`not_elem`"), ppr pats]
+ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats]
ppr_eqn prefixF kind (EqnInfo _ _ pats _) = prefixF (ppr_shadow_pats kind pats)
\end{code}
\begin{code}
match [] eqns_info
- = complete_matches eqns_info
+ = returnDs (foldr1 combineMatchResults match_results)
where
- complete_matches [eqn]
- = complete_match eqn
-
- complete_matches (eqn:eqns)
- = complete_match eqn `thenDs` \ match_result1 ->
- complete_matches eqns `thenDs` \ match_result2 ->
- returnDs (combineMatchResults match_result1 match_result2)
-
- complete_match (EqnInfo _ _ pats match_result)
- = ASSERT( null pats )
- returnDs match_result
+ match_results = [ ASSERT( null pats) mr
+ | EqnInfo _ _ pats mr <- eqns_info ]
\end{code}
+
%************************************************************************
%* *
%* match: non-empty rule *
\item
Removing lazy (irrefutable) patterns (you don't want to know...).
\item
-Converting explicit tuple- and list-pats into ordinary @ConPats@.
+Converting explicit tuple-, list-, and parallel-array-pats into ordinary
+@ConPats@.
\item
Convert the literal pat "" to [].
\end{itemize}
match_result' | v == var = match_result
| otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
+tidy1 v (SigPat pat ty fn) match_result
+ = selectMatchVar pat `thenDs` \ v' ->
+ tidy1 v' pat match_result `thenDs` \ (WildPat _, match_result') ->
+ -- The ice is a little thin here
+ -- We only expect a SigPat (with a non-trivial coercion) wrapping
+ -- a variable pattern. If it was a constructor or literal pattern
+ -- there would be no interesting polymorphism, and hence no coercion.
+ dsExpr (HsApp fn (HsVar v)) `thenDs` \ e ->
+ returnDs (WildPat ty, adjustMatchResult (bindNonRec v' e) match_result')
+
tidy1 v (WildPat ty) match_result
= returnDs (WildPat ty, match_result)
-- re-express <con-something> as (ConPat ...) [directly]
-tidy1 v (RecPat data_con pat_ty tvs dicts rpats) match_result
- = returnDs (ConPat data_con pat_ty tvs dicts pats, match_result)
+tidy1 v (RecPat data_con pat_ty ex_tvs dicts rpats) match_result
+ | null rpats
+ = -- Special case for C {}, which can be used for
+ -- a constructor that isn't declared to have
+ -- fields at all
+ returnDs (ConPat data_con pat_ty ex_tvs dicts (map WildPat con_arg_tys'), match_result)
+
+ | otherwise
+ = returnDs (ConPat data_con pat_ty ex_tvs dicts pats, match_result)
where
- {-
- Special case to handle C{}, where C is a constructor
- that hasn't got any labelled fields - the Haskell98 report
- doesn't seem to make that constraint (not that I think it
- should).
- -- sof 5/99
- -}
- pats
- | null con_flabels = map (WildPat) con_arg_tys'
- | otherwise = map mk_pat tagged_arg_tys
+ pats = map mk_pat tagged_arg_tys
-- Boring stuff to find the arg-tys of the constructor
- (_, inst_tys, _) = splitAlgTyConApp pat_ty
- con_arg_tys' = dataConArgTys data_con inst_tys
- con_flabels = dataConFieldLabels data_con
- tagged_arg_tys = con_arg_tys' `zip` con_flabels
+ inst_tys = tcTyConAppArgs pat_ty -- Newtypes must be opaque
+ con_arg_tys' = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs)
+ tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con)
-- mk_pat picks a WildPat of the appropriate type for absent fields,
-- and the specified pattern for present fields
(ConPat nilDataCon list_ty [] [] [])
pats
-tidy1 v (TuplePat pats True{-boxed-}) match_result
- = returnDs (tuple_ConPat, match_result)
+-- introduce fake parallel array constructors to be able to handle parallel
+-- arrays with the existing machinery for constructor pattern
+--
+tidy1 v (PArrPat ty pats) match_result
+ = returnDs (parrConPat, match_result)
where
- arity = length pats
- tuple_ConPat
- = ConPat (tupleCon arity)
- (mkTupleTy arity (map outPatType pats)) [] []
- pats
+ arity = length pats
+ parrConPat = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] pats
-tidy1 v (TuplePat pats False{-unboxed-}) match_result
+tidy1 v (TuplePat pats boxity) match_result
= returnDs (tuple_ConPat, match_result)
where
arity = length pats
tuple_ConPat
- = ConPat (unboxedTupleCon arity)
- (mkUnboxedTupleTy arity (map outPatType pats)) [] []
+ = ConPat (tupleCon boxity arity)
+ (mkTupleTy boxity arity (map outPatType pats)) [] []
pats
tidy1 v (DictPat dicts methods) match_result
= case num_of_d_and_ms of
- 0 -> tidy1 v (TuplePat [] True) match_result
+ 0 -> tidy1 v (TuplePat [] Boxed) match_result
1 -> tidy1 v (head dict_and_method_pats) match_result
- _ -> tidy1 v (TuplePat dict_and_method_pats True) match_result
+ _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) match_result
where
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map VarPat (dicts ++ methods)
-
--- deeply ugly mangling for some (common) NPats/LitPats
-
--- LitPats: the desugarer only sees these at well-known types
-
+-- LitPats: we *might* be able to replace these w/ a simpler form
tidy1 v pat@(LitPat lit lit_ty) match_result
- | isUnLiftedType lit_ty
- = returnDs (pat, match_result)
-
- | lit_ty == charTy
- = returnDs (ConPat charDataCon charTy [] [] [LitPat (mk_char lit) charPrimTy],
- match_result)
-
- | otherwise = pprPanic "tidy1:LitPat:" (ppr pat)
- where
- mk_char (HsChar c) = HsCharPrim c
+ = returnDs (tidyLitPat lit pat, match_result)
-- NPats: we *might* be able to replace these w/ a simpler form
-
-
tidy1 v pat@(NPat lit lit_ty _) match_result
- = returnDs (better_pat, match_result)
- where
- better_pat
- | lit_ty == charTy = ConPat charDataCon lit_ty [] [] [LitPat (mk_char lit) charPrimTy]
- | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy]
- | lit_ty == wordTy = ConPat wordDataCon lit_ty [] [] [LitPat (mk_word lit) wordPrimTy]
- | lit_ty == addrTy = ConPat addrDataCon lit_ty [] [] [LitPat (mk_addr lit) addrPrimTy]
- | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy]
- | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
-
- -- Convert the literal pattern "" to the constructor pattern [].
- | null_str_lit lit = ConPat nilDataCon lit_ty [] [] []
-
- | otherwise = pat
-
- mk_int (HsInt i) = HsIntPrim i
- mk_int l@(HsLitLit s) = l
-
- mk_char (HsChar c) = HsCharPrim c
- mk_char l@(HsLitLit s) = l
-
- mk_word l@(HsLitLit s) = l
-
- mk_addr l@(HsLitLit s) = l
-
- mk_float (HsInt i) = HsFloatPrim (fromInteger i)
- mk_float (HsFrac f) = HsFloatPrim f
- mk_float l@(HsLitLit s) = l
-
- mk_double (HsInt i) = HsDoublePrim (fromInteger i)
- mk_double (HsFrac f) = HsDoublePrim f
- mk_double l@(HsLitLit s) = l
-
- null_str_lit (HsString s) = _NULL_ s
- null_str_lit other_lit = False
+ = returnDs (tidyNPat lit lit_ty pat, match_result)
-- and everything else goes through unchanged...
= returnDs (non_interesting_pat, match_result)
\end{code}
-PREVIOUS matchTwiddled STUFF:
+\noindent
+{\bf Previous @matchTwiddled@ stuff:}
Now we get to the only interesting part; note: there are choices for
translation [from Simon's notes]; translation~1:
where
first_pat = head column_1_pats
- column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info]
+ column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info]
remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info]
\end{code}
\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}
There is one small problem with the Lambda Patterns, when somebody
writes something similar to:
+\begin{verbatim}
(\ (x:xs) -> ...)
+\end{verbatim}
he/she don't want a warning about incomplete patterns, that is done with
- the flag opt_WarnSimplePatterns.
- This problem also appears in the :
- do patterns, but if the do can fail it creates another equation if the match can
- fail (see DsExpr.doDo function)
- let patterns, are treated by matchSimply
- List Comprension Patterns, are treated by matchSimply also
-
-We can't call matchSimply with Lambda patterns, due to lambda patterns can have more than
+ the flag @opt_WarnSimplePatterns@.
+ This problem also appears in the:
+\begin{itemize}
+\item @do@ patterns, but if the @do@ can fail
+ it creates another equation if the match can fail
+ (see @DsExpr.doDo@ function)
+\item @let@ patterns, are treated by @matchSimply@
+ List Comprension Patterns, are treated by @matchSimply@ also
+\end{itemize}
+
+We can't call @matchSimply@ with Lambda patterns,
+due to the fact that lambda patterns can have more than
one pattern, and match simply only accepts one pattern.
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) ->
let
result_ty = head result_tys
in
- ASSERT( all (== result_ty) result_tys )
+ ASSERT( all (tcEqType result_ty) result_tys )
returnDs (result_ty, eqn_infos)
where
- flatten_match (Match _ pats _ grhss, n)
+ flatten_match (Match pats _ grhss, n)
= dsGRHSs kind pats grhss `thenDs` \ (ty, match_result) ->
getSrcLocDs `thenDs` \ locn ->
returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats match_result)
projects / ghc-hetmet.git / blobdiff