#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 ( hsPatType )
import Check ( check, ExhaustivePat )
import CoreSyn
import CoreUtils ( bindNonRec )
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 PrelInfo ( pAT_ERROR_ID )
-import Type ( isUnLiftedType, splitAlgTyConApp,
- mkTyVarTys, Type
- )
-import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
- addrPrimTy, wordPrimTy
- )
-import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
- charTy, charDataCon, intTy, intDataCon,
- floatTy, floatDataCon, doubleTy, tupleCon,
- doubleDataCon, addrTy,
- addrDataCon, wordTy, wordDataCon
- )
+import TcType ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType )
+import TysWiredIn ( consDataCon, mkTupleTy, mkListTy,
+ tupleCon, parrFakeCon, mkPArrTy )
import BasicTypes ( Boxity(..) )
import UniqSet
-import ErrUtils ( addErrLocHdrLine, dontAddErrLoc )
+import SrcLoc ( noSrcSpan, noLoc, unLoc, Located(..) )
+import Util ( lengthExceeds, isSingleton, notNull )
+import Name ( Name )
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
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))
+ = (noSrcSpan, 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
- )
+ = (loc, 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)
+ other -> (pprMatchContext kind, \ 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, matchSeparator kind, ptext SLIT("...")]
ppr_incomplete_pats kind (pats,[]) = ppr_pats pats
ppr_incomplete_pats kind (pats,constraints) =
patterns in column~1, or they all have constructor patterns in ...
(see ``the mixture rule'' in SLPJ).
\item
-Call @matchUnmixedEqns@ on each block of equations; it will do the
+Call @matchEqnBlock@ on each block of equations; it will do the
appropriate thing for each kind of column-1 pattern, usually ending up
in a recursive call to @match@.
\end{enumerate}
\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 *
\begin{code}
match vars@(v:vs) eqns_info
- = mapDs (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info ->
+ = mappM (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info ->
let
tidy_eqns_blks = unmix_eqns tidy_eqns_info
in
- match_unmixed_eqn_blks vars tidy_eqns_blks
+ mappM (matchEqnBlock vars) tidy_eqns_blks `thenDs` \ match_results ->
+ returnDs (foldr1 combineMatchResults match_results)
where
unmix_eqns [] = []
unmix_eqns [eqn] = [ [eqn] ]
unmixed_rest = unmix_eqns (eq2:eqs)
x `tack_onto` xss = ( x : head xss) : tail xss
-
- -----------------------------------------------------------------------
- -- loop through the blocks:
- -- subsequent blocks create a "fail expr" for the first one...
- match_unmixed_eqn_blks :: [Id]
- -> [ [EquationInfo] ] -- List of eqn BLOCKS
- -> DsM MatchResult
-
- match_unmixed_eqn_blks vars [] = panic "match_unmixed_eqn_blks"
-
- match_unmixed_eqn_blks vars [eqn_blk] = matchUnmixedEqns vars eqn_blk
-
- 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@
\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}
Float, Double, at least) are converted to unboxed form; e.g.,
\tr{(NPat (HsInt i) _ _)} is converted to:
\begin{verbatim}
-(ConPat I# _ _ [LitPat (HsIntPrim i) _])
+(ConPat I# _ _ [LitPat (HsIntPrim i)])
\end{verbatim}
\end{description}
-- NPat
-- LitPat
-- NPlusKPat
+ -- SigPat
-- 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')
-tidy1 :: Id -- The Id being scrutinised
- -> TypecheckedPat -- The pattern against which it is to be matched
- -> MatchResult -- Current thing do do after matching
- -> DsM (TypecheckedPat, -- Equivalent pattern
- MatchResult) -- Augmented thing to do afterwards
- -- The augmentation usually takes the form
- -- of new bindings to be added to the front
+tidy1 :: Id -- The Id being scrutinised
+ -> Pat Id -- The pattern against which it is to be matched
+ -> MatchResult -- Current thing do do after matching
+ -> DsM (Pat Id, -- Equivalent pattern
+ MatchResult) -- Augmented thing to do afterwards
+ -- The augmentation usually takes the form
+ -- of new bindings to be added to the front
+
+-------------------------------------------------------
+-- (pat', mr') = tidy1 v pat mr
+-- tidies the *outer level only* of pat, giving pat'
+-- It eliminates many pattern forms (as-patterns, variable patterns,
+-- list patterns, etc) yielding one of:
+-- WildPat
+-- ConPat
+-- LitPat
+-- NPat
+-- NPlusKPat
+--
+
+tidy1 v (ParPat pat) match_result
+ = tidy1 v (unLoc pat) match_result
+
+ -- case v of { x -> mr[] }
+ -- = case v of { _ -> let x=v in mr[] }
tidy1 v (VarPat var) match_result
= returnDs (WildPat (idType var), match_result')
where
match_result' | v == var = match_result
| otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
-tidy1 v (AsPat var pat) match_result
- = tidy1 v pat match_result'
+ -- case v of { x@p -> mr[] }
+ -- = case v of { p -> let x=v in mr[] }
+tidy1 v (AsPat (L _ var) pat) match_result
+ = tidy1 v (unLoc pat) match_result'
where
match_result' | v == var = match_result
| otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
-- re-express <con-something> as (ConPat ...) [directly]
-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)
+tidy1 v (ConPatOut con ps pat_ty ex_tvs dicts) match_result
+ = returnDs (ConPatOut con tidy_ps pat_ty ex_tvs dicts, match_result)
where
- pats = map mk_pat tagged_arg_tys
+ tidy_ps = PrefixCon (tidy_con con pat_ty ex_tvs ps)
- -- Boring stuff to find the arg-tys of the constructor
- (_, inst_tys, _) = splitAlgTyConApp pat_ty
- con_arg_tys' = dataConArgTys 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)
+tidy1 v (ListPat pats ty) match_result
+ = returnDs (unLoc list_ConPat, match_result)
where
- list_ty = mkListTy ty
- list_ConPat
- = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
- (ConPat nilDataCon list_ty [] [] [])
- pats
+ list_ty = mkListTy ty
+ list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
+ (mkNilPat list_ty)
+ pats
+
+-- introduce fake parallel array constructors to be able to handle parallel
+-- arrays with the existing machinery for constructor pattern
+--
+tidy1 v (PArrPat pats ty) match_result
+ = returnDs (unLoc parrConPat, match_result)
+ where
+ arity = length pats
+ parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
tidy1 v (TuplePat pats boxity) match_result
- = returnDs (tuple_ConPat, match_result)
+ = returnDs (unLoc tuple_ConPat, match_result)
where
arity = length pats
- tuple_ConPat
- = ConPat (tupleCon boxity arity)
- (mkTupleTy boxity arity (map outPatType pats)) [] []
- pats
+ tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats
+ (mkTupleTy boxity arity (map hsPatType pats))
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
+ 1 -> tidy1 v (unLoc (head dict_and_method_pats)) 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
+ dict_and_method_pats = map nlVarPat (dicts ++ methods)
--- LitPats: the desugarer only sees these at well-known types
-
-tidy1 v pat@(LitPat lit lit_ty) match_result
- = returnDs (tidyLitPat lit lit_ty pat, match_result)
+-- LitPats: we *might* be able to replace these w/ a simpler form
+tidy1 v pat@(LitPat lit) match_result
+ = returnDs (unLoc (tidyLitPat lit (noLoc 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 (tidyLitPat lit lit_ty pat, match_result)
+tidy1 v pat@(NPatOut lit lit_ty _) match_result
+ = returnDs (unLoc (tidyNPat lit lit_ty (noLoc pat)), match_result)
-- and everything else goes through unchanged...
tidy1 v non_interesting_pat match_result
= returnDs (non_interesting_pat, match_result)
+
+
+tidy_con data_con pat_ty ex_tvs (PrefixCon ps) = ps
+tidy_con data_con pat_ty ex_tvs (InfixCon p1 p2) = [p1,p2]
+tidy_con data_con pat_ty ex_tvs (RecCon rpats)
+ | null rpats
+ = -- Special case for C {}, which can be used for
+ -- a constructor that isn't declared to have
+ -- fields at all
+ map (noLoc.WildPat) con_arg_tys'
+
+ | otherwise
+ = map mk_pat tagged_arg_tys
+ where
+ -- Boring stuff to find the arg-tys of the constructor
+ 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
+ mk_pat (arg_ty, lbl) =
+ case [ pat | (sel_id,pat) <- rpats,
+ recordSelectorFieldLabel (unLoc sel_id) == lbl
+ ] of
+ (pat:pats) -> ASSERT( null pats )
+ pat
+ [] -> noLoc (WildPat arg_ty)
\end{code}
\noindent
%* match on an unmixed block: the real business *
%* *
%************************************************************************
-\subsection[matchUnmixedEqns]{@matchUnmixedEqns@: getting down to business}
+\subsection[matchEqnBlock]{@matchEqnBlock@: getting down to business}
-The function @matchUnmixedEqns@ is where the matching stuff sets to
+The function @matchEqnBlock@ is where the matching stuff sets to
work a block of equations, to which the mixture rule has been applied.
Its arguments and results are the same as for the ``top-level'' @match@.
\begin{code}
-matchUnmixedEqns :: [Id]
- -> [EquationInfo]
- -> DsM MatchResult
+matchEqnBlock :: [Id]
+ -> [EquationInfo]
+ -> DsM MatchResult
-matchUnmixedEqns [] _ = panic "matchUnmixedEqns: no names"
+matchEqnBlock [] _ = panic "matchEqnBlock: no names"
-matchUnmixedEqns all_vars@(var:vars) eqns_info
+matchEqnBlock 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
-- (ToDo: sort this out later)
matchLiterals all_vars eqns_info
+ | isSigPat first_pat
+ = ASSERT( isSingleton eqns_info )
+ matchSigPat all_vars (head eqns_info)
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}
+A SigPat is a type coercion and must be handled one at at time. We can't
+combine them unless the type of the pattern inside is identical, and we don't
+bother to check for that. For example:
+
+ data T = T1 Int | T2 Bool
+ f :: (forall a. a -> a) -> T -> t
+ f (g::Int->Int) (T1 i) = T1 (g i)
+ f (g::Bool->Bool) (T2 b) = T2 (g b)
+
+We desugar this as follows:
+
+ f = \ g::(forall a. a->a) t::T ->
+ let gi = g Int
+ in case t of { T1 i -> T1 (gi i)
+ other ->
+ let gb = g Bool
+ in case t of { T2 b -> T2 (gb b)
+ other -> fail }}
+
+Note that we do not treat the first column of patterns as a
+column of variables, because the coerced variables (gi, gb)
+would be of different types. So we get rather grotty code.
+But I don't think this is a common case, and if it was we could
+doubtless improve it.
+
+Meanwhile, the strategy is:
+ * treat each SigPat coercion (always non-identity coercions)
+ as a separate block
+ * deal with the stuff inside, and then wrap a binding round
+ the result to bind the new variable (gi, gb, etc)
+
+\begin{code}
+matchSigPat :: [Id] -> EquationInfo -> DsM MatchResult
+matchSigPat (var:vars) (EqnInfo n ctx (SigPatOut pat ty co_fn : pats) result)
+ = selectMatchVarL pat `thenDs` \ new_var ->
+ dsExpr (HsApp (noLoc co_fn) (nlHsVar var)) `thenDs` \ rhs ->
+ match (new_var:vars) [EqnInfo n ctx (unLoc pat:pats) result] `thenDs` \ result' ->
+ returnDs (adjustMatchResult (bindNonRec new_var rhs) result')
+\end{code}
+
%************************************************************************
%* *
%* matchWrapper: a convenient way to call @match@ *
\end{enumerate}
\begin{code}
-matchWrapper :: DsMatchKind -- For shadowing warning messages
- -> [TypecheckedMatch] -- Matches being desugared
- -> String -- Error message if the match fails
+matchWrapper :: HsMatchContext Name -- For shadowing warning messages
+ -> [LMatch Id] -- 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 ->
+ mappM 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
- -> TypecheckedPat -- Pattern it should match
+ -> HsMatchContext Name -- Match kind
+ -> LPat Id -- 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 ->
+ = getSrcSpanDs `thenDs` \ locn ->
let
- ctx = DsMatchContext kind [pat] locn
+ ctx = DsMatchContext kind [unLoc pat] locn
match_result = cantFailMatchResult result_expr
in
matchSinglePat scrut ctx pat match_result `thenDs` \ match_result' ->
extractMatchResult match_result' fail_expr
-matchSinglePat :: CoreExpr -> DsMatchContext -> TypecheckedPat
+matchSinglePat :: CoreExpr -> DsMatchContext -> LPat Id
-> 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 [unLoc 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 ->
+ = selectMatchVarL pat `thenDs` \ var ->
matchSinglePat (Var var) ctx pat match_result `thenDs` \ match_result' ->
returnDs (adjustMatchResult (bindNonRec var scrut) match_result')
\end{code}
This is actually local to @matchWrapper@.
\begin{code}
-flattenMatches
- :: DsMatchKind
- -> [TypecheckedMatch]
- -> DsM (Type, [EquationInfo])
+flattenMatches :: HsMatchContext Name
+ -> [LMatch Id]
+ -> 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)
- = dsGRHSs kind pats grhss `thenDs` \ (ty, match_result) ->
- getSrcLocDs `thenDs` \ locn ->
- returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats match_result)
+ flatten_match (L _ (Match pats _ grhss), n)
+ = dsGRHSs kind upats grhss `thenDs` \ (ty, match_result) ->
+ getSrcSpanDs `thenDs` \ locn ->
+ returnDs (ty, EqnInfo n (DsMatchContext kind upats locn) upats match_result)
+ where upats = map unLoc pats
\end{code}
projects / ghc-hetmet.git / blobdiff