%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Main_match]{The @match@ function}
\begin{code}
-module Match (
- match, matchWrapper, matchSimply
- ) where
+module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) where
#include "HsVersions.h"
-import AbsSyn -- the stuff being desugared
-import PlainCore -- the output of desugaring;
- -- importing this module also gets all the
- -- CoreSyn utility functions
-import DsMonad -- the monadery used in the desugarer
-
-import AbsPrel ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
- charTy, charDataCon, intTy, intDataCon, floatTy,
- floatDataCon, doubleTy, doubleDataCon,
- integerTy, intPrimTy, charPrimTy,
- floatPrimTy, doublePrimTy, mkFunTy, stringTy,
- addrTy, addrPrimTy, addrDataCon,
- wordTy, wordPrimTy, wordDataCon
-#ifdef DPH
- ,mkProcessorTy
-#endif {- Data Parallel Haskell -}
- )
-import PrimKind ( PrimKind(..) ) -- Rather ugly import; ToDo???
-
-import AbsUniType ( isPrimType )
-import DsBinds ( dsBinds )
-import DsExpr ( dsExpr )
+import CmdLineOpts ( DynFlag(..), DynFlags, dopt )
+import HsSyn
+import TcHsSyn ( TypecheckedPat, TypecheckedMatch )
+import DsHsSyn ( outPatType )
+import Check ( check, ExhaustivePat )
+import CoreSyn
+import CoreUtils ( bindNonRec )
+import DsMonad
import DsGRHSs ( dsGRHSs )
import DsUtils
-#ifdef DPH
-import Id ( eqId, getIdUniType, mkTupleCon, mkProcessorCon )
-import MatchProc ( matchProcessor)
-#else
-import Id ( eqId, getIdUniType, mkTupleCon, DataCon(..), Id )
-#endif {- Data Parallel Haskell -}
-import Maybes ( Maybe(..) )
+import Id ( idType, recordSelectorFieldLabel, Id )
+import DataCon ( dataConFieldLabels, dataConInstOrigArgTys )
import MatchCon ( matchConFamily )
import MatchLit ( matchLiterals )
-import Outputable -- all for one "panic"...
-import Pretty
-import Util
+import PrelInfo ( pAT_ERROR_ID )
+import Type ( splitAlgTyConApp, mkTyVarTys, Type )
+import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon )
+import BasicTypes ( Boxity(..) )
+import UniqSet
+import ErrUtils ( addErrLocHdrLine, dontAddErrLoc )
+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}
+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)
+\end{code}
+
+
The function @match@ is basically the same as in the Wadler chapter,
except it is monadised, to carry around the name supply, info about
annotations, etc.
\item
the $n$ patterns for that equation, and
\item
-a list of Core bindings [@(Id, PlainCoreExpr)@ pairs] to be ``stuck on
+a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
the front'' of the matching code, as in:
\begin{verbatim}
let <binds>
\item
A default expression---what to evaluate if the overall pattern-match
fails. This expression will (almost?) always be
-a measly expression @CoVar@, unless we know it will only be used once
+a measly expression @Var@, unless we know it will only be used once
(as we do in @glue_success_exprs@).
Leaving out this third argument to @match@ (and slamming in lots of
-@CoVar "fail"@s) is a positively {\em bad} idea, because it makes it
+@Var "fail"@s) is a positively {\em bad} idea, because it makes it
impossible to share the default expressions. (Also, it stands no
chance of working in our post-upheaval world of @Locals@.)
\end{enumerate}
\begin{code}
match :: [Id] -- Variables rep'ing the exprs we're matching with
-> [EquationInfo] -- Info about patterns, etc. (type synonym below)
- -> [EquationInfo] -- Potentially shadowing equations above this one
-> DsM MatchResult -- Desugared result!
\end{code}
And gluing the ``success expressions'' together isn't quite so pretty.
\begin{code}
-match [] eqns_info shadows
- = pin_eqns eqns_info `thenDs` \ match_result@(MatchResult _ _ _ cxt) ->
-
- -- If at this stage we find that at least one of the shadowing
- -- equations is guaranteed not to fail, then warn of an overlapping pattern
- if not (all shadow_can_fail shadows) then
- dsShadowError cxt `thenDs` \ _ ->
- returnDs match_result
- else
- returnDs match_result
-
+match [] eqns_info
+ = complete_matches eqns_info
where
- pin_eqns [EqnInfo [] match_result] = returnDs match_result
- -- Last eqn... can't have pats ...
-
- pin_eqns (EqnInfo [] match_result1 : more_eqns)
- = pin_eqns more_eqns `thenDs` \ match_result2 ->
- combineMatchResults match_result1 match_result2
-
- pin_eqns other_pat = panic "match: pin_eqns"
-
- shadow_can_fail :: EquationInfo -> Bool
-
- shadow_can_fail (EqnInfo [] (MatchResult CanFail _ _ _)) = True
- shadow_can_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = False
- shadow_can_fail other = panic "match:shadow_can_fail"
+ 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
\end{code}
%************************************************************************
corresponds roughly to @matchVarCon@.
\begin{code}
-match vars@(v:vs) eqns_info shadows
+match vars@(v:vs) eqns_info
= mapDs (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info ->
- mapDs (tidyEqnInfo v) shadows `thenDs` \ tidy_shadows ->
- let
+ let
tidy_eqns_blks = unmix_eqns tidy_eqns_info
in
- match_unmixed_eqn_blks vars tidy_eqns_blks tidy_shadows
+ match_unmixed_eqn_blks vars tidy_eqns_blks
where
unmix_eqns [] = []
unmix_eqns [eqn] = [ [eqn] ]
- unmix_eqns (eq1@(EqnInfo (p1:p1s) _) : eq2@(EqnInfo (p2:p2s) _) : eqs)
- = if ( (unfailablePat p1 && unfailablePat p2)
- || (isConPat p1 && isConPat p2)
- || (isLitPat p1 && isLitPat p2) ) then
+ unmix_eqns (eq1@(EqnInfo _ _ (p1:p1s) _) : eq2@(EqnInfo _ _ (p2:p2s) _) : eqs)
+ = if ( (isWildPat p1 && isWildPat p2)
+ || (isConPat p1 && isConPat p2)
+ || (isLitPat p1 && isLitPat p2) ) then
eq1 `tack_onto` unmixed_rest
else
[ eq1 ] : unmixed_rest
-- subsequent blocks create a "fail expr" for the first one...
match_unmixed_eqn_blks :: [Id]
-> [ [EquationInfo] ] -- List of eqn BLOCKS
- -> [EquationInfo] -- Shadows
-> DsM MatchResult
- match_unmixed_eqn_blks vars [] shadows = panic "match_unmixed_eqn_blks"
+ match_unmixed_eqn_blks vars [] = panic "match_unmixed_eqn_blks"
- match_unmixed_eqn_blks vars [eqn_blk] shadows = matchUnmixedEqns vars eqn_blk shadows
+ match_unmixed_eqn_blks vars [eqn_blk] = matchUnmixedEqns vars eqn_blk
- match_unmixed_eqn_blks vars (eqn_blk:eqn_blks) shadows
- = matchUnmixedEqns vars eqn_blk shadows `thenDs` \ match_result1 -> -- try to match with first blk
- match_unmixed_eqn_blks vars eqn_blks shadows' `thenDs` \ match_result2 ->
- combineMatchResults match_result1 match_result2
- where
- shadows' = eqn_blk ++ shadows
+ match_unmixed_eqn_blks vars (eqn_blk:eqn_blks)
+ = matchUnmixedEqns vars eqn_blk `thenDs` \ match_result1 -> -- try to match with first blk
+ match_unmixed_eqn_blks vars eqn_blks `thenDs` \ match_result2 ->
+ returnDs (combineMatchResults match_result1 match_result2)
\end{code}
Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
Removing lazy (irrefutable) patterns (you don't want to know...).
\item
Converting explicit tuple- and list-pats into ordinary @ConPats@.
+\item
+Convert the literal pat "" to [].
\end{itemize}
The result of this tidying is that the column of patterns will include
\item[@ConPats@:]
@ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
-\item[@LitPats@ and @NPats@ (and @NPlusKPats@):]
-@LitPats@/@NPats@/@NPlusKPats@ of ``known friendly types'' (Int, Char,
+\item[@LitPats@ and @NPats@:]
+@LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
Float, Double, at least) are converted to unboxed form; e.g.,
-\tr{(NPat (IntLit i) _ _)} is converted to:
+\tr{(NPat (HsInt i) _ _)} is converted to:
\begin{verbatim}
-(ConPat I# _ _ [LitPat (IntPrimLit i) _])
+(ConPat I# _ _ [LitPat (HsIntPrim i) _])
\end{verbatim}
\end{description}
-- DsM'd because of internal call to "match".
-- "tidy1" does the interesting stuff, looking at
-- one pattern and fiddling the list of bindings.
-tidyEqnInfo v (EqnInfo (pat : pats) match_result)
+ --
+ -- POST CONDITION: head pattern in the EqnInfo is
+ -- WildPat
+ -- ConPat
+ -- NPat
+ -- LitPat
+ -- NPlusKPat
+ -- but no other
+
+tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result)
= tidy1 v pat match_result `thenDs` \ (pat', match_result') ->
- returnDs (EqnInfo (pat' : pats) match_result')
+ returnDs (EqnInfo n ctx (pat' : pats) match_result')
tidy1 :: Id -- The Id being scrutinised
-> TypecheckedPat -- The pattern against which it is to be matched
-- of new bindings to be added to the front
tidy1 v (VarPat var) match_result
- = returnDs (WildPat (getIdUniType var),
- mkCoLetsMatchResult extra_binds match_result)
+ = returnDs (WildPat (idType var), match_result')
where
- extra_binds | v `eqId` var = []
- | otherwise = [CoNonRec var (CoVar v)]
+ match_result' | v == var = match_result
+ | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
tidy1 v (AsPat var pat) match_result
- = tidy1 v pat (mkCoLetsMatchResult extra_binds match_result)
+ = tidy1 v pat match_result'
where
- extra_binds | v `eqId` var = []
- | otherwise = [CoNonRec var (CoVar v)]
+ match_result' | v == var = match_result
+ | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
tidy1 v (WildPat ty) match_result
= returnDs (WildPat ty, match_result)
ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
- The case expr for v_i is just: match [v] [(p, [], \ x -> CoVar v_i)] any_expr
+ The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
-}
tidy1 v (LazyPat pat) match_result
- = mkSelectorBinds [] pat l_to_l (CoVar v) `thenDs` \ sel_binds ->
- returnDs (WildPat (getIdUniType v),
- mkCoLetsMatchResult [CoNonRec b rhs | (b,rhs) <- sel_binds] match_result)
- where
- l_to_l = binders `zip` binders -- Boring
- binders = collectTypedPatBinders pat
+ = mkSelectorBinds pat (Var v) `thenDs` \ sel_binds ->
+ returnDs (WildPat (idType v),
+ mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
-- re-express <con-something> as (ConPat ...) [directly]
-tidy1 v (ConOpPat pat1 id pat2 ty) match_result
- = returnDs (ConPat id ty [pat1, pat2], 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
+ 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' = 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
+ mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat,_) <- rpats,
+ recordSelectorFieldLabel sel_id == lbl
+ ] of
+ (pat:pats) -> ASSERT( null pats )
+ pat
+ [] -> WildPat arg_ty
tidy1 v (ListPat ty pats) match_result
= returnDs (list_ConPat, match_result)
where
list_ty = mkListTy ty
list_ConPat
- = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
- (ConPat nilDataCon list_ty [])
+ = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
+ (ConPat nilDataCon list_ty [] [] [])
pats
-tidy1 v (TuplePat pats) match_result
+tidy1 v (TuplePat pats boxity) match_result
= returnDs (tuple_ConPat, match_result)
where
arity = length pats
tuple_ConPat
- = ConPat (mkTupleCon arity)
- (mkTupleTy arity (map typeOfPat pats))
+ = ConPat (tupleCon boxity arity)
+ (mkTupleTy boxity arity (map outPatType pats)) [] []
pats
-#ifdef DPH
-tidy1 v (ProcessorPat pats convs pat) match_result
- = returnDs ((ProcessorPat pats convs pat), match_result)
-{-
-tidy1 v (ProcessorPat pats _ _ pat) match_result
- = returnDs (processor_ConPat, match_result)
+tidy1 v (DictPat dicts methods) match_result
+ = case num_of_d_and_ms of
+ 0 -> tidy1 v (TuplePat [] Boxed) match_result
+ 1 -> tidy1 v (head dict_and_method_pats) match_result
+ _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) match_result
where
- processor_ConPat
- = ConPat (mkProcessorCon (length pats))
- (mkProcessorTy (map typeOfPat pats) (typeOfPat pat))
- (pats++[pat])
--}
-#endif {- Data Parallel Haskell -}
-
--- deeply ugly mangling for some (common) NPats/LitPats
-
--- LitPats: the desugarer only sees these at well-known types
+ num_of_d_and_ms = length dicts + length methods
+ dict_and_method_pats = map VarPat (dicts ++ methods)
+-- LitPats: we *might* be able to replace these w/ a simpler form
tidy1 v pat@(LitPat lit lit_ty) match_result
- | isPrimType 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 PprDebug pat)
- where
- mk_char (CharLit c) = CharPrimLit 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]
- | otherwise = pat
-
- mk_int (IntLit i) = IntPrimLit i
- mk_int l@(LitLitLit s _) = l
-
- mk_char (CharLit c)= CharPrimLit c
- mk_char l@(LitLitLit s _) = l
-
- mk_word l@(LitLitLit s _) = l
-
- mk_addr l@(LitLitLit s _) = l
-
- mk_float (IntLit i) = FloatPrimLit (fromInteger i)
-#if __GLASGOW_HASKELL__ <= 22
- mk_float (FracLit f)= FloatPrimLit (fromRational f) -- ToDo???
-#else
- mk_float (FracLit f)= FloatPrimLit f
-#endif
- mk_float l@(LitLitLit s _) = l
-
- mk_double (IntLit i) = DoublePrimLit (fromInteger i)
-#if __GLASGOW_HASKELL__ <= 22
- mk_double (FracLit f)= DoublePrimLit (fromRational f) -- ToDo???
-#else
- mk_double (FracLit f)= DoublePrimLit f
-#endif
- mk_double l@(LitLitLit s _) = l
-
-{- OLD: and wrong! I don't think we can do anything
- useful with n+k patterns, so drop through to default case
-
-tidy1 v pat@(NPlusKPat n k lit_ty and so on) match_result
- = returnDs (NPlusKPat v k lit_ty and so on,
- (if v `eqId` n then id else (mkCoLet (CoNonRec n (CoVar v)))) . match_result)
--}
+ = 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:
\begin{code}
matchUnmixedEqns :: [Id]
-> [EquationInfo]
- -> [EquationInfo] -- Shadows
-> DsM MatchResult
-matchUnmixedEqns [] _ _ = panic "matchUnmixedEqns: no names"
-
-matchUnmixedEqns all_vars@(var:vars) eqns_info shadows
- | unfailablePats column_1_pats -- Could check just one; we know they've been tidied, unmixed;
- -- this way is (arguably) a sanity-check
- = -- Real true variables, just like in matchVar, SLPJ p 94
- match vars remaining_eqns_info remaining_shadows
+matchUnmixedEqns [] _ = panic "matchUnmixedEqns: no names"
-#ifdef DPH
- | patsAreAllProcessor column_1_pats
- = -- ToDo: maybe check just one...
- matchProcessor all_vars eqns_info
-#endif {- Data Parallel Haskell -}
+matchUnmixedEqns all_vars@(var:vars) eqns_info
+ | isWildPat first_pat
+ = ASSERT( all isWildPat column_1_pats ) -- Sanity check
+ -- Real true variables, just like in matchVar, SLPJ p 94
+ -- No binding to do: they'll all be wildcards by now (done in tidy)
+ match vars remaining_eqns_info
- | patsAreAllCons column_1_pats -- ToDo: maybe check just one...
- = matchConFamily all_vars eqns_info shadows
+ | isConPat first_pat
+ = ASSERT( patsAreAllCons column_1_pats )
+ matchConFamily all_vars eqns_info
- | patsAreAllLits column_1_pats -- ToDo: maybe check just one...
- = -- see notes in MatchLiteral
+ | isLitPat first_pat
+ = ASSERT( patsAreAllLits column_1_pats )
+ -- see notes in MatchLiteral
-- not worried about the same literal more than once in a column
-- (ToDo: sort this out later)
- matchLiterals all_vars eqns_info shadows
+ matchLiterals all_vars eqns_info
where
- column_1_pats = [pat | EqnInfo (pat:_) _ <- eqns_info]
- remaining_eqns_info = [EqnInfo pats match_result | EqnInfo (_:pats) match_result <- eqns_info]
- remaining_shadows = [EqnInfo pats match_result | EqnInfo (pat:pats) match_result <- shadows,
- irrefutablePat pat ]
- -- Discard shadows which can be refuted, since they don't shadow
- -- a variable
+ first_pat = head column_1_pats
+ 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}
%************************************************************************
A list of variables (@Locals@) that the caller must ``promise'' to
bind to appropriate values; and
\item
-a @PlainCoreExpr@, the desugared output (main result).
+a @CoreExpr@, the desugared output (main result).
\end{itemize}
The main actions of @matchWrapper@ include:
matchWrapper :: DsMatchKind -- For shadowing warning messages
-> [TypecheckedMatch] -- Matches being desugared
-> String -- Error message if the match fails
- -> DsM ([Id], PlainCoreExpr) -- Results
-
--- a special case for the common ...:
--- just one Match
--- lots of (all?) unfailable pats
--- e.g.,
--- f x y z = ....
-
-matchWrapper kind [(PatMatch (VarPat var) match)] error_string
- = matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
- returnDs (var:vars, core_expr)
+ -> DsM ([Id], CoreExpr) -- Results
+\end{code}
-matchWrapper kind [(PatMatch (WildPat ty) match)] error_string
- = newSysLocalDs ty `thenDs` \ var ->
- matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
- returnDs (var:vars, core_expr)
+ 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:
+\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}
-matchWrapper kind [(GRHSMatch
- (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string
- = dsBinds binds `thenDs` \ core_binds ->
- dsExpr expr `thenDs` \ core_expr ->
- returnDs ([], mkCoLetsAny core_binds core_expr)
+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.
-----------------------------------------------------------------------------
--- and all the rest... (general case)
+JJQC 30-Nov-1997
+\begin{code}
matchWrapper kind matches error_string
- = flattenMatches kind matches `thenDs` \ eqns_info@(EqnInfo arg_pats (MatchResult _ result_ty _ _) : _) ->
-
- selectMatchVars arg_pats `thenDs` \ new_vars ->
- match new_vars eqns_info [] `thenDs` \ match_result ->
-
- getSrcLocDs `thenDs` \ (src_file, src_line) ->
- newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the String
+ = getDOptsDs `thenDs` \ dflags ->
+ flattenMatches kind matches `thenDs` \ (result_ty, eqns_info) ->
let
- src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line
- fail_expr = mkErrorCoApp result_ty str_var (src_loc_str++": "++error_string)
+ EqnInfo _ _ arg_pats _ : _ = eqns_info
in
- extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
+ 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 dflags
+ = case kind of
+ LambdaMatch | dopt Opt_WarnSimplePatterns dflags -> matchExport
+ | otherwise -> match
+ _ -> matchExport
\end{code}
%************************************************************************
pattern. It returns an expression.
\begin{code}
-matchSimply :: PlainCoreExpr -- Scrutinee
- -> TypecheckedPat -- Pattern it should match
- -> UniType -- Type of result
- -> PlainCoreExpr -- Return this if it matches
- -> PlainCoreExpr -- Return this if it does
- -> DsM PlainCoreExpr
-
-matchSimply (CoVar var) pat result_ty result_expr fail_expr
- = match [var] [eqn_info] [] `thenDs` \ match_result ->
- extractMatchResult match_result fail_expr
- where
- eqn_info = EqnInfo [pat] initial_match_result
- initial_match_result = MatchResult CantFail
- result_ty
- (\ ignore -> result_expr)
- NoMatchContext
-
-matchSimply scrut_expr pat result_ty result_expr msg
- = newSysLocalDs (typeOfPat pat) `thenDs` \ scrut_var ->
- matchSimply (CoVar scrut_var) pat result_ty result_expr msg `thenDs` \ expr ->
- returnDs (CoLet (CoNonRec scrut_var scrut_expr) expr)
+matchSimply :: CoreExpr -- Scrutinee
+ -> DsMatchKind -- Match kind
+ -> TypecheckedPat -- Pattern it should match
+ -> CoreExpr -- Return this if it matches
+ -> CoreExpr -- Return this if it doesn't
+ -> DsM CoreExpr
+
+matchSimply scrut kind pat result_expr fail_expr
+ = getSrcLocDs `thenDs` \ locn ->
+ let
+ ctx = DsMatchContext kind [pat] locn
+ match_result = cantFailMatchResult result_expr
+ in
+ matchSinglePat scrut ctx pat match_result `thenDs` \ match_result' ->
+ extractMatchResult match_result' fail_expr
-extractMatchResult (MatchResult CantFail _ match_fn _) fail_expr
- = returnDs (match_fn (error "It can't fail!"))
+matchSinglePat :: CoreExpr -> DsMatchContext -> TypecheckedPat
+ -> MatchResult -> DsM MatchResult
-extractMatchResult (MatchResult CanFail result_ty match_fn _) fail_expr
- = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) ->
- returnDs (CoLet (fail_bind_fn fail_expr) (match_fn if_it_fails))
+matchSinglePat (Var var) ctx pat match_result
+ = getDOptsDs `thenDs` \ dflags ->
+ match_fn dflags [var] [EqnInfo 1 ctx [pat] match_result]
+ where
+ match_fn dflags
+ | dopt Opt_WarnSimplePatterns dflags = matchExport
+ | otherwise = match
+
+matchSinglePat scrut ctx pat match_result
+ = selectMatchVar pat `thenDs` \ var ->
+ matchSinglePat (Var var) ctx pat match_result `thenDs` \ match_result' ->
+ returnDs (adjustMatchResult (bindNonRec var scrut) match_result')
\end{code}
%************************************************************************
%* flattenMatches : create a list of EquationInfo *
%* *
%************************************************************************
+
\subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@}
This is actually local to @matchWrapper@.
flattenMatches
:: DsMatchKind
-> [TypecheckedMatch]
- -> DsM [EquationInfo]
-
-flattenMatches kind [] = returnDs []
+ -> DsM (Type, [EquationInfo])
-flattenMatches kind (match : matches)
- = flatten_match [] match `thenDs` \ eqn_info ->
- flattenMatches kind matches `thenDs` \ eqn_infos ->
- returnDs (eqn_info : eqn_infos)
+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 )
+ returnDs (result_ty, eqn_infos)
where
- flatten_match :: [TypecheckedPat] -- Reversed list of patterns encountered so far
- -> TypecheckedMatch
- -> DsM EquationInfo
-
- flatten_match pats_so_far (PatMatch pat match)
- = flatten_match (pat:pats_so_far) match
-
- flatten_match pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
- = dsBinds binds `thenDs` \ core_binds ->
- dsGRHSs ty kind pats grhss `thenDs` \ match_result ->
- returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result))
- where
- pats = reverse pats_so_far -- They've accumulated in reverse order
+ 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)
\end{code}
projects / ghc-hetmet.git / blobdiff