import {-# SOURCE #-} DsExpr( dsExpr )
import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn
-import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, outPatType )
+import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, hsPatType )
import Check ( check, ExhaustivePat )
import CoreSyn
import CoreUtils ( bindNonRec )
import MatchLit ( matchLiterals )
import PrelInfo ( pAT_ERROR_ID )
import TcType ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType )
-import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
+import TysWiredIn ( consDataCon, mkTupleTy, mkListTy,
tupleCon, parrFakeCon, mkPArrTy )
import BasicTypes ( Boxity(..) )
import UniqSet
-import ErrUtils ( addWarnLocHdrLine, dontAddErrLoc )
+import SrcLoc ( noSrcLoc )
import Util ( lengthExceeds, isSingleton, notNull )
import Outputable
\end{code}
| otherwise = empty
pp_context NoMatchContext msg rest_of_msg_fun
- = dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
+ = (noSrcLoc, ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun
- = addWarnLocHdrLine loc
- (ptext SLIT("Pattern match(es)") <+> msg)
- (sep [ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)])
+ = (loc, vcat [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)
+ FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
+ other -> (pprMatchContext kind, \ pp -> pp)
ppr_pats pats = sep (map ppr pats)
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}
let
tidy_eqns_blks = unmix_eqns tidy_eqns_info
in
- match_unmixed_eqn_blks vars tidy_eqns_blks
+ mapDs (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@
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}
= 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
+ -> 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
+
+-------------------------------------------------------
+-- (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 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
+ -- case v of { x@p -> mr[] }
+ -- = case v of { p -> let x=v in mr[] }
tidy1 v (AsPat var pat) match_result
= tidy1 v pat match_result'
where
-- 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
-
- -- 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)
+ tidy_ps = PrefixCon (tidy_con con pat_ty ex_tvs ps)
- -- 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
+tidy1 v (ListPat pats ty) 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 [] [] [])
- 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 ty pats) match_result
+tidy1 v (PArrPat pats ty) match_result
= returnDs (parrConPat, match_result)
where
arity = length pats
- parrConPat = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] pats
+ parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
tidy1 v (TuplePat pats boxity) match_result
= returnDs (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
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
+tidy1 v pat@(LitPat lit) match_result
= 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
+tidy1 v pat@(NPatOut lit lit_ty _) match_result
= returnDs (tidyNPat lit lit_ty 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 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 sel_id == lbl
+ ] of
+ (pat:pats) -> ASSERT( null pats )
+ pat
+ [] -> 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
\begin{code}
matchSigPat :: [Id] -> EquationInfo -> DsM MatchResult
-matchSigPat (var:vars) (EqnInfo n ctx (SigPat pat ty co_fn : pats) result)
+matchSigPat (var:vars) (EqnInfo n ctx (SigPatOut pat ty co_fn : pats) result)
= selectMatchVar pat `thenDs` \ new_var ->
dsExpr (HsApp co_fn (HsVar var)) `thenDs` \ rhs ->
match (new_var:vars) [EqnInfo n ctx (pat:pats) result] `thenDs` \ result' ->