-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Main_match]{The @match@ function}
\begin{code}
-#include "HsVersions.h"
+module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) where
-module Match ( matchExport, match, matchWrapper, matchSimply ) where
+#include "HsVersions.h"
-IMP_Ubiq()
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons
- -- and to break dsExpr/dsBinds-ish loop
-#else
-import {-# SOURCE #-} DsExpr ( dsExpr )
-import {-# SOURCE #-} DsBinds ( dsBinds )
-#endif
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
import CmdLineOpts ( opt_WarnIncompletePatterns, opt_WarnOverlappingPatterns,
- opt_PprUserLength,opt_WarnSimplePatterns
+ opt_WarnSimplePatterns
)
import HsSyn
-import TcHsSyn ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedMatch),
- SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) )
-import DsHsSyn ( outPatType, collectTypedPatBinders )
-import Check ( check, SYN_IE(ExhaustivePat), SYN_IE(WarningPat), BoxedString )
+import TcHsSyn ( TypecheckedPat, TypecheckedMatch )
+import DsHsSyn ( outPatType )
+import Check ( check, ExhaustivePat )
import CoreSyn
import CoreUtils ( coreExprType )
import DsMonad
import DsGRHSs ( dsGRHSs )
import DsUtils
-import ErrUtils ( SYN_IE(Warning) )
-import FieldLabel ( FieldLabel {- Eq instance -} )
-import Id ( idType, dataConFieldLabels,
- dataConArgTys, recordSelectorFieldLabel,
- GenId{-instance-}, SYN_IE(Id)
- )
+import Id ( idType, recordSelectorFieldLabel, Id )
+import DataCon ( dataConFieldLabels, dataConArgTys )
import MatchCon ( matchConFamily )
import MatchLit ( matchLiterals )
-import Name ( Name {--O only-} )
-import Outputable ( PprStyle(..), Outputable(..), pprQuote )
-import PprType ( GenType{-instance-}, GenTyVar{-ditto-} )
-import Pretty
import PrelVals ( pAT_ERROR_ID )
-import SrcLoc ( noSrcLoc, SrcLoc )
-import Type ( isPrimType, eqTy, getAppDataTyConExpandingDicts,
- instantiateTauTy, SYN_IE(Type)
+import Type ( isUnLiftedType, splitAlgTyConApp,
+ Type
)
-import TyVar ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
addrPrimTy, wordPrimTy
)
import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
charTy, charDataCon, intTy, intDataCon,
floatTy, floatDataCon, doubleTy, tupleCon,
- doubleDataCon, stringTy, addrTy,
- addrDataCon, wordTy, wordDataCon
+ doubleDataCon, addrTy,
+ addrDataCon, wordTy, wordDataCon,
+ mkUnboxedTupleTy, unboxedTupleCon
)
-import Unique ( Unique{-instance Eq-} )
import UniqSet
-import Util ( panic, pprPanic, assertPanic )
+import ErrUtils ( addErrLocHdrLine, dontAddErrLoc )
+import Outputable
\end{code}
This function is a wrapper of @match@, it must be called from all the parts where
-> [EquationInfo] -- Info about patterns, etc. (type synonym below)
-> DsM MatchResult -- Desugared result!
-matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _ _)) : _)
+matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _)
| incomplete && shadow =
dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
dsIncompleteWarn ctx pats `thenDs` \ () ->
dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn
where
- warn sty | length qs > maximum_output =
- hang (pp_context sty ctx (ptext SLIT("are overlapped")))
- 12 ((vcat $ map (ppr_eqn kind sty) (take maximum_output qs))
- $$ ptext SLIT("..."))
- warn sty =
- hang (pp_context sty ctx (ptext SLIT("are overlapped")))
- 12 (vcat $ map (ppr_eqn kind sty) qs)
+ warn | length qs > maximum_output
+ = pp_context ctx (ptext SLIT("are overlapped"))
+ 8 (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
+ ptext SLIT("..."))
+ | otherwise
+ = pp_context ctx (ptext SLIT("are overlapped"))
+ 8 (\ f -> vcat $ map (ppr_eqn f kind) qs)
+
dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
where
- warn sty | length pats > maximum_output =
- hang (pp_context sty ctx (ptext SLIT("are non-exhaustive")))
- 12 (hang (ptext SLIT("Patterns not recognized:"))
- 4 ((vcat $ map (ppr_incomplete_pats kind sty) (take maximum_output pats))
- $$ ptext SLIT("...")))
- warn sty =
- hang (pp_context sty ctx (ptext SLIT("are non-exhaustive")))
- 12 (hang (ptext SLIT("Patterns not recognized:"))
- 4 (vcat $ map (ppr_incomplete_pats kind sty) pats))
-
-pp_context sty NoMatchContext msg = ptext SLIT("Warning: Some match(es)") <+> msg
-
-pp_context sty (DsMatchContext kind pats loc) msg
- = hang (hcat [ppr (PprForUser opt_PprUserLength) loc, ptext SLIT(": ")])
- 4 (hang message
- 4 (pp_match kind pats))
+ warn | length pats > maximum_output
+ = pp_context ctx (ptext SLIT("are non-exhaustive"))
+ 8 (\ f -> hang (ptext SLIT("Patterns not recognized:"))
+ 4 (vcat (map (ppr_incomplete_pats kind)
+ (take maximum_output pats))
+ $$ ptext SLIT("...")))
+ | otherwise
+ = pp_context ctx (ptext SLIT("are non-exhaustive"))
+ 8 (\ f -> hang (ptext SLIT("Patterns not recognized:"))
+ 4 (vcat $ map (ppr_incomplete_pats kind) pats))
+
+pp_context NoMatchContext msg ind rest_of_msg_fun
+ = dontAddErrLoc "" (ptext SLIT("Some match(es)") <+> hang msg ind (rest_of_msg_fun id))
+
+pp_context (DsMatchContext kind pats loc) msg ind rest_of_msg_fun
+ = case pp_match kind pats of
+ (ppr_match, pref) ->
+ addErrLocHdrLine loc message (nest ind (rest_of_msg_fun pref))
+ where
+ message = ptext SLIT("Pattern match(es)") <+> msg <+> ppr_match <> char ':'
where
- message = ptext SLIT("Warning: Pattern match(es)") <+> msg
-
pp_match (FunMatch fun) pats
- = hsep [ptext SLIT("in the definition of function"), ppr sty fun]
+ = 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 sty 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 sty 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 sty 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 sty 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 sty 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 sty pats)
+ = ( hang (ptext SLIT("in a `let' pattern binding"))
+ 4 (ppr_pats pats)
+ , id
+ )
-ppr_pats sty pats = pprQuote sty $ \ sty -> sep (map (ppr sty) pats)
+ppr_pats pats = sep (map ppr pats)
separator (FunMatch _) = SLIT("=")
separator (CaseMatch) = SLIT("->")
separator (ListCompMatch) = SLIT("<-")
separator (LetMatch) = SLIT("=")
-ppr_shadow_pats kind sty pats = pprQuote sty $ \ sty ->
- sep [sep (map (ppr sty) pats), ptext (separator kind), ptext SLIT("...")]
+ppr_shadow_pats kind pats
+ = sep [ppr_pats pats, ptext (separator kind), ptext SLIT("...")]
-ppr_incomplete_pats kind sty (pats,[]) = pprQuote sty $ \ sty ->
- sep [sep (map (ppr sty) pats)]
-ppr_incomplete_pats kind sty (pats,constraints) = pprQuote sty $ \ sty ->
- sep [sep (map (ppr sty) pats), ptext SLIT("with"),
- sep (map (ppr_constraint sty) constraints)]
+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 sty (var,pats) = sep [ppr sty var, ptext SLIT("`not_elem`"),ppr sty pats]
-
-ppr_eqn kind sty (EqnInfo _ _ pats _) = ppr_shadow_pats kind sty pats
+ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`not_elem`"), ppr pats]
+ppr_eqn prefixF kind (EqnInfo _ _ pats _) = prefixF (ppr_shadow_pats kind pats)
\end{code}
complete_matches (eqn:eqns)
= complete_match eqn `thenDs` \ match_result1 ->
complete_matches eqns `thenDs` \ match_result2 ->
- combineMatchResults match_result1 match_result2
+ returnDs (combineMatchResults match_result1 match_result2)
- complete_match (EqnInfo _ _ [] match_result@(MatchResult _ _ _))
- = returnDs match_result
+ complete_match (EqnInfo _ _ pats match_result)
+ = ASSERT( null pats )
+ returnDs match_result
\end{code}
%************************************************************************
unmix_eqns [] = []
unmix_eqns [eqn] = [ [eqn] ]
unmix_eqns (eq1@(EqnInfo _ _ (p1:p1s) _) : eq2@(EqnInfo _ _ (p2:p2s) _) : eqs)
- = if ( (irrefutablePat p1 && irrefutablePat p2)
- || (isConPat p1 && isConPat p2)
- || (isLitPat p1 && isLitPat p2) ) then
+ = if ( (isWildPat p1 && isWildPat p2)
+ || (isConPat p1 && isConPat p2)
+ || (isLitPat p1 && isLitPat p2) ) then
eq1 `tack_onto` unmixed_rest
else
[ eq1 ] : unmixed_rest
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 ->
- combineMatchResults match_result1 match_result2
+ returnDs (combineMatchResults match_result1 match_result2)
\end{code}
Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
-- DsM'd because of internal call to "match".
-- "tidy1" does the interesting stuff, looking at
-- one pattern and fiddling the list of bindings.
+ --
+ -- 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 n ctx (pat' : pats) match_result')
-- of new bindings to be added to the front
tidy1 v (VarPat var) match_result
- = returnDs (WildPat (idType var),
- mkCoLetsMatchResult extra_binds match_result)
+ = returnDs (WildPat (idType var), match_result')
where
- extra_binds | v == var = []
- | otherwise = [NonRec var (Var 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 == var = []
- | otherwise = [NonRec var (Var 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)
-- 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 con_id pat_ty rpats) match_result
- = returnDs (ConPat con_id pat_ty pats, match_result)
+tidy1 v (RecPat data_con pat_ty tvs dicts rpats) match_result
+ = returnDs (ConPat data_con pat_ty 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, _) = getAppDataTyConExpandingDicts pat_ty
- con_arg_tys' = dataConArgTys con_id inst_tys
- tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels con_id)
+ (_, inst_tys, _) = splitAlgTyConApp pat_ty
+ con_arg_tys' = dataConArgTys data_con inst_tys
+ 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
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 True{-boxed-}) match_result
= returnDs (tuple_ConPat, match_result)
where
arity = length pats
tuple_ConPat
= ConPat (tupleCon arity)
- (mkTupleTy arity (map outPatType pats))
+ (mkTupleTy arity (map outPatType pats)) [] []
+ pats
+
+tidy1 v (TuplePat pats False{-unboxed-}) match_result
+ = returnDs (tuple_ConPat, match_result)
+ where
+ arity = length pats
+ tuple_ConPat
+ = ConPat (unboxedTupleCon arity)
+ (mkUnboxedTupleTy arity (map outPatType pats)) [] []
pats
tidy1 v (DictPat dicts methods) match_result
= case num_of_d_and_ms of
- 0 -> tidy1 v (TuplePat []) match_result
+ 0 -> tidy1 v (TuplePat [] True) match_result
1 -> tidy1 v (head dict_and_method_pats) match_result
- _ -> tidy1 v (TuplePat dict_and_method_pats) match_result
+ _ -> tidy1 v (TuplePat dict_and_method_pats True) match_result
where
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map VarPat (dicts ++ methods)
-- LitPats: the desugarer only sees these at well-known types
tidy1 v pat@(LitPat lit lit_ty) match_result
- | isPrimType lit_ty
+ | isUnLiftedType lit_ty
= returnDs (pat, match_result)
- | lit_ty `eqTy` charTy
- = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy],
+ | lit_ty == charTy
+ = returnDs (ConPat charDataCon charTy [] [] [LitPat (mk_char lit) charPrimTy],
match_result)
- | otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug pat)
+ | otherwise = pprPanic "tidy1:LitPat:" (ppr pat)
where
mk_char (HsChar c) = HsCharPrim c
= returnDs (better_pat, match_result)
where
better_pat
- | lit_ty `eqTy` charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy]
- | lit_ty `eqTy` intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy]
- | lit_ty `eqTy` wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy]
- | lit_ty `eqTy` addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy]
- | lit_ty `eqTy` floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy]
- | lit_ty `eqTy` doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
+ | 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 []
+ | null_str_lit lit = ConPat nilDataCon lit_ty [] [] []
| otherwise = pat
matchUnmixedEqns [] _ = panic "matchUnmixedEqns: no names"
matchUnmixedEqns all_vars@(var:vars) eqns_info
- | irrefutablePat first_pat
- = ASSERT( irrefutablePats column_1_pats ) -- Sanity check
+ | 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
| isConPat first_pat
-> DsM ([Id], CoreExpr) -- Results
\end{code}
- a special case for the common ...:
- just one Match
- lots of (all?) unfailable pats
- e.g.,
- f x y z = ....
-
- This special case have been ``undone'' due to problems with the new warnings
- messages (Check.lhs.check). We need there the name of the variables to be able to
- print later the equation. JJQC 30-11-97
-
-\begin{old_code}
-matchWrapper kind [(PatMatch (VarPat var) match)] error_string
- = matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
- returnDs (var:vars, core_expr)
-
-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)
-
-matchWrapper kind [(GRHSMatch
- (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string
- = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds ->
- dsExpr expr `thenDs` \ core_expr ->
- returnDs ([], mkCoLetsAny core_binds core_expr)
-\end{old_code}
-
- And all the rest... (general case)
-
-
There is one small problem with the Lambda Patterns, when somebody
writes something similar to:
(\ (x:xs) -> ...)
JJQC 30-Nov-1997
\begin{code}
-
matchWrapper kind matches error_string
- = flattenMatches kind 1 matches `thenDs` \ eqns_info@(EqnInfo _ _ arg_pats (MatchResult _ result_ty _) : _) ->
-
- selectMatchVars arg_pats `thenDs` \ new_vars ->
+ = flattenMatches kind matches `thenDs` \ (result_ty, eqns_info) ->
+ let
+ EqnInfo _ _ arg_pats _ : _ = eqns_info
+ in
+ mapDs selectMatchVar arg_pats `thenDs` \ new_vars ->
match_fun 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
matchSimply :: CoreExpr -- Scrutinee
-> DsMatchKind -- Match kind
-> TypecheckedPat -- Pattern it should match
- -> Type -- Type of result
-> CoreExpr -- Return this if it matches
- -> CoreExpr -- Return this if it does
+ -> CoreExpr -- Return this if it doesn't
-> DsM CoreExpr
-matchSimply (Var var) kind pat result_ty result_expr fail_expr
+matchSimply scrut kind pat result_expr fail_expr
= getSrcLocDs `thenDs` \ locn ->
let
- ctx = DsMatchContext kind [pat] locn
- eqn_info = EqnInfo 1 ctx [pat] initial_match_result
+ ctx = DsMatchContext kind [pat] locn
+ match_result = cantFailMatchResult result_expr
in
- match_fun [var] [eqn_info] `thenDs` \ match_result ->
- extractMatchResult match_result fail_expr
- where
- initial_match_result = MatchResult CantFail result_ty (\ ignore -> result_expr)
- match_fun = if opt_WarnSimplePatterns
- then matchExport
- else match
+ matchSinglePat scrut ctx pat match_result `thenDs` \ match_result' ->
+ extractMatchResult match_result' fail_expr
-matchSimply scrut_expr kind pat result_ty result_expr msg
- = newSysLocalDs (outPatType pat) `thenDs` \ scrut_var ->
- matchSimply (Var scrut_var) kind pat result_ty result_expr msg `thenDs` \ expr ->
- returnDs (Let (NonRec scrut_var scrut_expr) expr)
+matchSinglePat :: CoreExpr -> DsMatchContext -> TypecheckedPat
+ -> MatchResult -> DsM MatchResult
-extractMatchResult (MatchResult CantFail _ match_fn) fail_expr
- = returnDs (match_fn (error "It can't fail!"))
+matchSinglePat (Var var) ctx pat match_result
+ = match_fn [var] [EqnInfo 1 ctx [pat] match_result]
+ where
+ match_fn | opt_WarnSimplePatterns = matchExport
+ | otherwise = match
-extractMatchResult (MatchResult CanFail result_ty match_fn) fail_expr
- = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) ->
- returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails))
+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@.
\begin{code}
flattenMatches
:: DsMatchKind
- -> EqnNo
-> [TypecheckedMatch]
- -> DsM [EquationInfo]
+ -> DsM (Type, [EquationInfo])
-flattenMatches kind n [] = returnDs []
-
-flattenMatches kind n (match : matches)
- = flatten_match [] n match `thenDs` \ eqn_info ->
- flattenMatches kind (n+1) 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
- -> EqnNo
- -> TypecheckedMatch
- -> DsM EquationInfo
-
- flatten_match pats_so_far n (PatMatch pat match)
- = flatten_match (pat:pats_so_far) n match
-
- flatten_match pats_so_far n (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
- = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds ->
- dsGRHSs ty kind pats grhss `thenDs` \ match_result ->
+ flatten_match (Match _ pats _ grhss, n)
+ = dsGRHSs kind pats grhss `thenDs` \ (ty, match_result) ->
getSrcLocDs `thenDs` \ locn ->
- returnDs (EqnInfo n (DsMatchContext kind pats locn) pats
- (mkCoLetsMatchResult core_binds match_result))
- where
- pats = reverse pats_so_far -- They've accumulated in reverse order
-
- flatten_match pats_so_far n (SimpleMatch expr)
- = dsExpr expr `thenDs` \ core_expr ->
- getSrcLocDs `thenDs` \ locn ->
- returnDs (EqnInfo n (DsMatchContext kind pats locn) pats
- (MatchResult CantFail (coreExprType core_expr)
- (\ ignore -> core_expr)))
-
- -- the matching can't fail, so we won't generate an error message.
- where
- pats = reverse pats_so_far -- They've accumulated in reverse order
-
+ returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats match_result)
\end{code}
-
projects / ghc-hetmet.git / blobdiff