%
-% (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, matchWrapper, matchSimply ) where
+module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
-IMP_Ubiq()
-IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons
- -- and to break dsExpr/dsBinds-ish loop
+#include "HsVersions.h"
-import HsSyn hiding ( collectBinders{-also from CoreSyn-} )
-import TcHsSyn ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedMatch),
- SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) )
-import DsHsSyn ( outPatType, collectTypedPatBinders )
+import DynFlags ( DynFlag(..), dopt )
+import HsSyn
+import TcHsSyn ( mkVanillaTuplePat )
+import Check ( check, ExhaustivePat )
import CoreSyn
-
-import CoreUtils ( coreExprType )
+import CoreUtils ( bindNonRec, exprType )
import DsMonad
+import DsBinds ( dsLHsBinds )
import DsGRHSs ( dsGRHSs )
import DsUtils
+import Id ( idName, idType, Id )
+import DataCon ( dataConFieldLabels, dataConInstOrigArgTys, isVanillaDataCon )
import MatchCon ( matchConFamily )
-import MatchLit ( matchLiterals )
-
-import FieldLabel ( allFieldLabelTags, fieldLabelTag )
-import Id ( idType, mkTupleCon,
- dataConArgTys, recordSelectorFieldLabel,
- GenId{-instance-}
- )
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance-}, GenTyVar{-ditto-} )
-import PrelVals ( pAT_ERROR_ID )
-import Type ( isPrimType, eqTy, getAppDataTyConExpandingDicts,
- instantiateTauTy
- )
-import TyVar ( GenTyVar{-instance Eq-} )
-import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
- addrPrimTy, wordPrimTy
- )
-import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
- charTy, charDataCon, intTy, intDataCon,
- floatTy, floatDataCon, doubleTy,
- doubleDataCon, stringTy, addrTy,
- addrDataCon, wordTy, wordDataCon
- )
-import Unique ( Unique{-instance Eq-} )
-import Util ( panic, pprPanic, assertPanic )
+import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat )
+import PrelInfo ( pAT_ERROR_ID )
+import TcType ( Type, tcTyConAppArgs )
+import Type ( splitFunTysN, mkTyVarTys )
+import TysWiredIn ( consDataCon, mkListTy, unitTy,
+ tupleCon, parrFakeCon, mkPArrTy )
+import BasicTypes ( Boxity(..) )
+import ListSetOps ( runs )
+import SrcLoc ( noLoc, unLoc, Located(..) )
+import Util ( lengthExceeds, notNull )
+import Name ( Name )
+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}
+matchCheck :: DsMatchContext
+ -> [Id] -- Vars rep'ing the exprs we're matching with
+ -> Type -- Type of the case expression
+ -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
+ -> DsM MatchResult -- Desugared result!
+
+matchCheck ctx vars ty qs
+ = getDOptsDs `thenDs` \ dflags ->
+ matchCheck_really dflags ctx vars ty qs
+
+matchCheck_really dflags ctx vars ty qs
+ | incomplete && shadow =
+ dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
+ dsIncompleteWarn ctx pats `thenDs` \ () ->
+ match vars ty qs
+ | incomplete =
+ dsIncompleteWarn ctx pats `thenDs` \ () ->
+ match vars ty qs
+ | shadow =
+ dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
+ match vars ty qs
+ | otherwise =
+ match vars ty qs
+ where (pats, eqns_shadow) = check qs
+ incomplete = want_incomplete && (notNull pats)
+ want_incomplete = case ctx of
+ DsMatchContext RecUpd _ ->
+ dopt Opt_WarnIncompletePatternsRecUpd dflags
+ _ ->
+ dopt Opt_WarnIncompletePatterns dflags
+ shadow = dopt Opt_WarnOverlappingPatterns dflags
+ && not (null eqns_shadow)
+\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 loc) qs
+ = putSrcSpanDs loc (dsWarn warn)
+ where
+ 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("..."))
+ | otherwise
+ = pp_context ctx (ptext SLIT("are overlapped"))
+ (\ f -> vcat $ map (ppr_eqn f kind) qs)
+
+
+dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
+dsIncompleteWarn ctx@(DsMatchContext kind loc) pats
+ = putSrcSpanDs loc (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 | pats `lengthExceeds` maximum_output = ptext SLIT("...")
+ | otherwise = empty
+
+pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
+ = 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)
+
+ppr_shadow_pats kind pats
+ = sep [ppr_pats pats, matchSeparator 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 eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))
+\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.
So, the full type signature:
\begin{code}
match :: [Id] -- Variables rep'ing the exprs we're matching with
+ -> Type -- Type of the case expression
-> [EquationInfo] -- Info about patterns, etc. (type synonym below)
- -> [EquationInfo] -- Potentially shadowing equations above this one
-> DsM MatchResult -- Desugared result!
\end{code}
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}
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 [] ty eqns_info
+ = ASSERT( not (null eqns_info) )
+ returnDs (foldr1 combineMatchResults match_results)
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"
+ match_results = [ ASSERT( null (eqn_pats eqn) )
+ adjustMatchResult (eqn_wrap eqn) (eqn_rhs eqn)
+ | eqn <- eqns_info ]
\end{code}
+
%************************************************************************
%* *
%* match: non-empty rule *
corresponds roughly to @matchVarCon@.
\begin{code}
-match vars@(v:vs) eqns_info shadows
- = mapDs (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info ->
- mapDs (tidyEqnInfo v) shadows `thenDs` \ tidy_shadows ->
- let
- tidy_eqns_blks = unmix_eqns tidy_eqns_info
- in
- match_unmixed_eqn_blks vars tidy_eqns_blks tidy_shadows
+match vars@(v:_) ty eqns_info
+ = do { tidy_eqns <- mappM (tidyEqnInfo v) eqns_info
+ ; let eqns_blks = runs same_family tidy_eqns
+ ; match_results <- mappM match_block eqns_blks
+ ; ASSERT( not (null match_results) )
+ return (foldr1 combineMatchResults match_results) }
where
- 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
- eq1 `tack_onto` unmixed_rest
- else
- [ eq1 ] : unmixed_rest
- where
- 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
- -> [EquationInfo] -- Shadows
- -> DsM MatchResult
-
- match_unmixed_eqn_blks vars [] shadows = 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: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
+ same_family eqn1 eqn2
+ = samePatFamily (firstPat eqn1) (firstPat eqn2)
+
+ match_block eqns
+ = case firstPat (head eqns) of
+ WildPat {} -> matchVariables vars ty eqns
+ ConPatOut {} -> matchConFamily vars ty eqns
+ NPlusKPat {} -> matchNPlusKPats vars ty eqns
+ NPat {} -> matchNPats vars ty eqns
+ LitPat {} -> matchLiterals vars ty eqns
+
+-- After tidying, there are only five kinds of patterns
+samePatFamily (WildPat {}) (WildPat {}) = True
+samePatFamily (ConPatOut {}) (ConPatOut {}) = True
+samePatFamily (NPlusKPat {}) (NPlusKPat {}) = True
+samePatFamily (NPat {}) (NPat {}) = True
+samePatFamily (LitPat {}) (LitPat {}) = True
+samePatFamily _ _ = False
+
+matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Real true variables, just like in matchVar, SLPJ p 94
+-- No binding to do: they'll all be wildcards by now (done in tidy)
+matchVariables (var:vars) ty eqns = match vars ty (shiftEqns eqns)
+\end{code}
+
+
\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}
The result of this tidying is that the column of patterns will include
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}
\begin{code}
tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
- -- DsM'd because of internal call to "match".
+ -- DsM'd because of internal call to dsLHsBinds
+ -- and mkSelectorBinds.
-- "tidy1" does the interesting stuff, looking at
-- one pattern and fiddling the list of bindings.
-tidyEqnInfo v (EqnInfo (pat : pats) match_result)
- = tidy1 v pat match_result `thenDs` \ (pat', match_result') ->
- returnDs (EqnInfo (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 v (VarPat var) match_result
- = returnDs (WildPat (idType var),
- mkCoLetsMatchResult extra_binds match_result)
- where
- extra_binds | v == var = []
- | otherwise = [NonRec var (Var v)]
-
-tidy1 v (AsPat var pat) match_result
- = tidy1 v pat (mkCoLetsMatchResult extra_binds match_result)
- where
- extra_binds | v == var = []
- | otherwise = [NonRec var (Var v)]
-
-tidy1 v (WildPat ty) match_result
- = returnDs (WildPat ty, match_result)
+ --
+ -- POST CONDITION: head pattern in the EqnInfo is
+ -- WildPat
+ -- ConPat
+ -- NPat
+ -- LitPat
+ -- NPlusKPat
+ -- but no other
+
+tidyEqnInfo v eqn@(EqnInfo { eqn_wrap = wrap, eqn_pats = pat : pats })
+ = tidy1 v wrap pat `thenDs` \ (wrap', pat') ->
+ returnDs (eqn { eqn_wrap = wrap', eqn_pats = pat' : pats })
+
+tidy1 :: Id -- The Id being scrutinised
+ -> DsWrapper -- Previous wrapping bindings
+ -> Pat Id -- The pattern against which it is to be matched
+ -> DsM (DsWrapper, -- Extra bindings around what to do afterwards
+ Pat Id) -- Equivalent pattern
+
+-- The extra bindings etc are all wrapped around the RHS of the match
+-- so they are only available when matching is complete. But that's ok
+-- becuase, for example, in the pattern x@(...), the x can only be
+-- used in the RHS, not in the nested pattern, nor subsquent patterns
+--
+-- However this does have an awkward consequence. The bindings in
+-- a VarPatOut get wrapped around the result in right to left order,
+-- rather than left to right. This only matters if one set of
+-- bindings can mention things used in another, and that can happen
+-- if we allow equality dictionary bindings of form d1=d2.
+-- bindIInstsOfLocalFuns is now careful not to do this, but it's a wart.
+-- (Without this care in bindInstsOfLocalFuns, compiling
+-- Data.Generics.Schemes.hs fails in function everywhereBut.)
+
+-------------------------------------------------------
+-- (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
+-- ConPatOut
+-- LitPat
+-- NPat
+-- NPlusKPat
+
+tidy1 v wrap (ParPat pat) = tidy1 v wrap (unLoc pat)
+tidy1 v wrap (SigPatOut pat _) = tidy1 v wrap (unLoc pat)
+tidy1 v wrap (WildPat ty) = returnDs (wrap, WildPat ty)
+
+ -- case v of { x -> mr[] }
+ -- = case v of { _ -> let x=v in mr[] }
+tidy1 v wrap (VarPat var)
+ = returnDs (wrap . wrapBind var v, WildPat (idType var))
+
+tidy1 v wrap (VarPatOut var binds)
+ = do { prs <- dsLHsBinds binds
+ ; return (wrap . wrapBind var v . mkDsLet (Rec prs),
+ WildPat (idType var)) }
+
+ -- case v of { x@p -> mr[] }
+ -- = case v of { p -> let x=v in mr[] }
+tidy1 v wrap (AsPat (L _ var) pat)
+ = tidy1 v (wrap . wrapBind var v) (unLoc pat)
+
+tidy1 v wrap (BangPat pat)
+ = tidy1 v (wrap . seqVar v) (unLoc pat)
{- now, here we handle lazy patterns:
tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
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 (Var v) `thenDs` \ sel_binds ->
- returnDs (WildPat (idType v),
- mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
- where
- l_to_l = binders `zip` binders -- Boring
- binders = collectTypedPatBinders pat
+tidy1 v wrap (LazyPat pat)
+ = do { v' <- newSysLocalDs (idType v)
+ ; sel_prs <- mkSelectorBinds pat (Var v)
+ ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
+ ; returnDs (wrap . wrapBind v' v . mkDsLets sel_binds,
+ WildPat (idType v)) }
-- 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 wrap (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty)
+ = returnDs (wrap, ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty)
where
- pats = map mk_pat tagged_arg_tys
+ tidy_ps = PrefixCon (tidy_con con ex_tvs pat_ty ps)
- -- Boring stuff to find the arg-tys of the constructor
- (_, inst_tys, _) = {-trace "Match.getAppDataTyConExpandingDicts" $-} getAppDataTyConExpandingDicts pat_ty
- con_arg_tys' = dataConArgTys con_id inst_tys
- tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags
-
- -- mk_pat picks a WildPat of the appropriate type for absent fields,
- -- and the specified pattern for present fields
- mk_pat (arg_ty, tag) = case [pat | (sel_id,pat,_) <- rpats,
- fieldLabelTag (recordSelectorFieldLabel sel_id) == tag
- ] of
- (pat:pats) -> ASSERT( null pats )
- pat
- [] -> WildPat arg_ty
-
-tidy1 v (ListPat ty pats) match_result
- = returnDs (list_ConPat, match_result)
+tidy1 v wrap (ListPat pats ty)
+ = returnDs (wrap, unLoc list_ConPat)
+ where
+ 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 wrap (PArrPat pats ty)
+ = returnDs (wrap, unLoc parrConPat)
where
- list_ty = mkListTy ty
- list_ConPat
- = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y])
- (ConPat nilDataCon list_ty [])
- pats
-
-tidy1 v (TuplePat pats) match_result
- = returnDs (tuple_ConPat, match_result)
+ arity = length pats
+ parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
+
+tidy1 v wrap (TuplePat pats boxity ty)
+ = returnDs (wrap, unLoc tuple_ConPat)
where
arity = length pats
- tuple_ConPat
- = ConPat (mkTupleCon arity)
- (mkTupleTy arity (map outPatType pats))
- pats
+ tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
-tidy1 v (DictPat dicts methods) match_result
+tidy1 v wrap (DictPat dicts methods)
= case num_of_d_and_ms of
- 0 -> tidy1 v (TuplePat []) match_result
- 1 -> tidy1 v (head dict_and_method_pats) match_result
- _ -> tidy1 v (TuplePat dict_and_method_pats) match_result
+ 0 -> tidy1 v wrap (TuplePat [] Boxed unitTy)
+ 1 -> tidy1 v wrap (unLoc (head dict_and_method_pats))
+ _ -> tidy1 v wrap (mkVanillaTuplePat dict_and_method_pats Boxed)
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
+ dict_and_method_pats = map nlVarPat (dicts ++ methods)
-tidy1 v pat@(LitPat lit lit_ty) match_result
- | isPrimType lit_ty
- = returnDs (pat, match_result)
-
- | lit_ty `eqTy` charTy
- = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy],
- match_result)
-
- | otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug pat)
- where
- mk_char (HsChar c) = HsCharPrim c
+-- LitPats: we *might* be able to replace these w/ a simpler form
+tidy1 v wrap pat@(LitPat lit)
+ = returnDs (wrap, unLoc (tidyLitPat lit (noLoc pat)))
-- NPats: we *might* be able to replace these w/ a simpler form
+tidy1 v wrap pat@(NPat lit mb_neg _ lit_ty)
+ = returnDs (wrap, unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat)))
-tidy1 v pat@(NPat lit lit_ty _) match_result
- = 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]
- | 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
+-- and everything else goes through unchanged...
- mk_word l@(HsLitLit s) = l
+tidy1 v wrap non_interesting_pat
+ = returnDs (wrap, non_interesting_pat)
- 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
+tidy_con data_con ex_tvs pat_ty (PrefixCon ps) = ps
+tidy_con data_con ex_tvs pat_ty (InfixCon p1 p2) = [p1,p2]
+tidy_con data_con ex_tvs pat_ty (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'
- mk_double (HsInt i) = HsDoublePrim (fromInteger i)
- mk_double (HsFrac f) = HsDoublePrim f
- mk_double l@(HsLitLit s) = l
+ | otherwise
+ = map mk_pat tagged_arg_tys
+ where
+ -- Boring stuff to find the arg-tys of the constructor
+
+ inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty -- Newtypes must be opaque
+ | otherwise = mkTyVarTys ex_tvs
--- and everything else goes through unchanged...
+ con_arg_tys' = dataConInstOrigArgTys data_con inst_tys
+ tagged_arg_tys = con_arg_tys' `zip` dataConFieldLabels data_con
-tidy1 v non_interesting_pat match_result
- = returnDs (non_interesting_pat, match_result)
+ -- 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, idName (unLoc sel_id) == lbl] of
+ (pat:pats) -> ASSERT( null pats ) pat
+ [] -> noLoc (WildPat arg_ty)
\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:
%************************************************************************
%* *
-%* match on an unmixed block: the real business *
-%* *
-%************************************************************************
-\subsection[matchUnmixedEqns]{@matchUnmixedEqns@: getting down to business}
-
-The function @matchUnmixedEqns@ 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]
- -> [EquationInfo] -- Shadows
- -> DsM MatchResult
-
-matchUnmixedEqns [] _ _ = panic "matchUnmixedEqns: no names"
-
-matchUnmixedEqns all_vars@(var:vars) eqns_info shadows
- | irrefutablePat first_pat
- = ASSERT( irrefutablePats column_1_pats ) -- Sanity check
- -- Real true variables, just like in matchVar, SLPJ p 94
- match vars remaining_eqns_info remaining_shadows
-
- | isConPat first_pat
- = ASSERT( patsAreAllCons column_1_pats )
- matchConFamily all_vars eqns_info shadows
-
- | 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
-
- where
- first_pat = head column_1_pats
- 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
-\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
+ -> MatchGroup Id -- Matches being desugared
-> 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 = ....
-
-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 binds `thenDs` \ core_binds ->
- dsExpr expr `thenDs` \ core_expr ->
- returnDs ([], mkCoLetsAny core_binds core_expr)
-
-----------------------------------------------------------------------------
--- and all the rest... (general case)
-
-matchWrapper kind matches error_string
- = flattenMatches kind matches `thenDs` \ eqns_info@(EqnInfo arg_pats (MatchResult _ result_ty _ _) : _) ->
+ 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}
- selectMatchVars arg_pats `thenDs` \ new_vars ->
- match new_vars eqns_info [] `thenDs` \ match_result ->
+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.
- mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr ->
- extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
+JJQC 30-Nov-1997
- returnDs (new_vars, result_expr)
+\begin{code}
+matchWrapper ctxt (MatchGroup matches match_ty)
+ = do { eqns_info <- mapM mk_eqn_info matches
+ ; new_vars <- selectMatchVars arg_pats pat_tys
+ ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
+ ; return (new_vars, result_expr) }
+ where
+ arg_pats = map unLoc (hsLMatchPats (head matches))
+ n_pats = length arg_pats
+ (pat_tys, rhs_ty) = splitFunTysN n_pats match_ty
+
+ mk_eqn_info (L _ (Match pats _ grhss))
+ = do { let upats = map unLoc pats
+ ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
+ ; return (EqnInfo { eqn_wrap = idWrapper,
+ eqn_pats = upats,
+ eqn_rhs = match_result}) }
+
+
+matchEquations :: HsMatchContext Name
+ -> [Id] -> [EquationInfo] -> Type
+ -> DsM CoreExpr
+matchEquations ctxt vars eqns_info rhs_ty
+ = do { dflags <- getDOptsDs
+ ; locn <- getSrcSpanDs
+ ; let ds_ctxt = DsMatchContext ctxt locn
+ error_string = matchContextErrString ctxt
+
+ ; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
+
+ ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
+ ; extractMatchResult match_result fail_expr }
+ where
+ match_fun dflags ds_ctxt
+ = case ctxt of
+ LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt
+ | otherwise -> match
+ _ -> matchCheck ds_ctxt
\end{code}
%************************************************************************
\begin{code}
matchSimply :: CoreExpr -- Scrutinee
- -> TypecheckedPat -- Pattern it should match
- -> Type -- Type of result
+ -> HsMatchContext Name -- Match kind
+ -> LPat Id -- Pattern it should match
-> CoreExpr -- Return this if it matches
- -> CoreExpr -- Return this if it does
+ -> CoreExpr -- Return this if it doesn't
-> DsM CoreExpr
-matchSimply (Var 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 (outPatType pat) `thenDs` \ scrut_var ->
- matchSimply (Var scrut_var) pat result_ty result_expr msg `thenDs` \ expr ->
- returnDs (Let (NonRec scrut_var scrut_expr) expr)
-
-
-extractMatchResult (MatchResult CantFail _ match_fn _) fail_expr
- = returnDs (match_fn (error "It can't fail!"))
-
-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))
+matchSimply scrut hs_ctx pat result_expr fail_expr
+ = let
+ match_result = cantFailMatchResult result_expr
+ rhs_ty = exprType fail_expr
+ -- Use exprType of fail_expr, because won't refine in the case of failure!
+ in
+ matchSinglePat scrut hs_ctx pat rhs_ty match_result `thenDs` \ match_result' ->
+ extractMatchResult match_result' fail_expr
+
+
+matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
+ -> Type -> MatchResult -> DsM MatchResult
+matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result
+ = getDOptsDs `thenDs` \ dflags ->
+ getSrcSpanDs `thenDs` \ locn ->
+ let
+ match_fn dflags
+ | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
+ | otherwise = match
+ where
+ ds_ctx = DsMatchContext hs_ctx locn
+ in
+ match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper,
+ eqn_pats = [pat],
+ eqn_rhs = match_result }]
+
+matchSinglePat scrut hs_ctx pat ty match_result
+ = selectSimpleMatchVarL pat `thenDs` \ var ->
+ matchSinglePat (Var var) hs_ctx pat ty 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
- -> [TypecheckedMatch]
- -> DsM [EquationInfo]
-
-flattenMatches kind [] = returnDs []
-
-flattenMatches kind (match : matches)
- = flatten_match [] match `thenDs` \ eqn_info ->
- flattenMatches kind matches `thenDs` \ eqn_infos ->
- returnDs (eqn_info : 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 False 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 pats_so_far (SimpleMatch expr)
- = dsExpr expr `thenDs` \ core_expr ->
- returnDs (EqnInfo pats
- (MatchResult CantFail (coreExprType core_expr)
- (\ ignore -> core_expr)
- NoMatchContext))
- -- The NoMatchContext is just a place holder. In a simple match,
- -- 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
-\end{code}
projects / ghc-hetmet.git / blobdiff