module Match ( match, matchWrapper, matchSimply ) where
-import Ubiq
-import DsLoop -- here for paranoia-checking reasons
+IMP_Ubiq()
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
+IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons
-- and to break dsExpr/dsBinds-ish loop
-
-import HsSyn
-import TcHsSyn ( TypecheckedPat(..), TypecheckedMatch(..),
- TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
+#else
+import {-# SOURCE #-} DsExpr ( dsExpr )
+import {-# SOURCE #-} DsBinds ( dsBinds )
+#endif
+
+import CmdLineOpts ( opt_WarnIncompletePatterns, opt_WarnOverlappedPatterns )
+import HsSyn
+import TcHsSyn ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedMatch),
+ SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) )
import DsHsSyn ( outPatType, collectTypedPatBinders )
import CoreSyn
+import CoreUtils ( coreExprType )
import DsMonad
import DsGRHSs ( dsGRHSs )
import DsUtils
import MatchCon ( matchConFamily )
import MatchLit ( matchLiterals )
-import CoreUtils ( escErrorMsg, mkErrorApp )
-import FieldLabel ( allFieldLabelTags, fieldLabelTag )
-import Id ( idType, mkTupleCon, dataConSig,
- recordSelectorFieldLabel,
- GenId{-instance-}
+import FieldLabel ( FieldLabel {- Eq instance -} )
+import Id ( idType, dataConFieldLabels,
+ dataConArgTys, recordSelectorFieldLabel,
+ GenId{-instance-}, SYN_IE(Id)
+ )
+import Name ( Name {--O only-} )
+import Outputable ( PprStyle(..), Outputable(..) )
+import PprType ( GenType{-instance-}, GenTyVar{-ditto-} )
+import Pretty ( Doc )
+import PrelVals ( pAT_ERROR_ID )
+import Type ( isPrimType, eqTy, getAppDataTyConExpandingDicts,
+ instantiateTauTy, SYN_IE(Type)
+ )
+import TyVar ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
+import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
+ addrPrimTy, wordPrimTy
)
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance-}, GenTyVar{-ditto-} )
-import PrelInfo ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
+import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
charTy, charDataCon, intTy, intDataCon,
- floatTy, floatDataCon, doubleTy, doubleDataCon,
- integerTy, intPrimTy, charPrimTy,
- floatPrimTy, doublePrimTy, stringTy,
- addrTy, addrPrimTy, addrDataCon,
- wordTy, wordPrimTy, wordDataCon )
-import Type ( isPrimType, eqTy, getAppDataTyCon,
- instantiateTauTy
+ floatTy, floatDataCon, doubleTy, tupleCon,
+ doubleDataCon, stringTy, addrTy,
+ addrDataCon, wordTy, wordDataCon
)
-import TyVar ( GenTyVar{-instance Eq-} )
import Unique ( Unique{-instance Eq-} )
import Util ( panic, pprPanic, assertPanic )
\end{code}
\begin{code}
match [] eqns_info shadows
- = pin_eqns eqns_info `thenDs` \ match_result@(MatchResult _ _ _ cxt) ->
+ = complete_matches eqns_info (any eqn_cant_fail shadows)
+ where
+ complete_matches [eqn] is_shadowed
+ = complete_match eqn is_shadowed
+
+ complete_matches (eqn:eqns) is_shadowed
+ = complete_match eqn is_shadowed `thenDs` \ match_result1 ->
+ complete_matches eqns (is_shadowed || eqn_cant_fail eqn) `thenDs` \ match_result2 ->
+ combineMatchResults match_result1 match_result2
-- 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
-
- where
- pin_eqns [EqnInfo [] match_result] = returnDs match_result
- -- Last eqn... can't have pats ...
+ complete_match (EqnInfo [] match_result@(MatchResult _ _ _ cxt)) is_shadowed
+ | opt_WarnOverlappedPatterns && is_shadowed =
+ dsShadowWarn cxt `thenDs` \ _ ->
+ returnDs match_result
- 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
+ | otherwise = returnDs match_result
- shadow_can_fail (EqnInfo [] (MatchResult CanFail _ _ _)) = True
- shadow_can_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = False
- shadow_can_fail other = panic "match:shadow_can_fail"
+ eqn_cant_fail :: EquationInfo -> Bool
+ eqn_cant_fail (EqnInfo [] (MatchResult CanFail _ _ _)) = False
+ eqn_cant_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = True
\end{code}
%************************************************************************
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
+ = if ( (irrefutablePat p1 && irrefutablePat p2)
+ || (isConPat p1 && isConPat p2)
+ || (isLitPat p1 && isLitPat p2) ) then
eq1 `tack_onto` unmixed_rest
else
[ eq1 ] : unmixed_rest
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
-}
tidy1 v (LazyPat pat) match_result
- = mkSelectorBinds [] pat l_to_l (Var v) `thenDs` \ sel_binds ->
+ = mkSelectorBinds pat (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
-- re-express <con-something> as (ConPat ...) [directly]
tidy1 v (RecPat con_id pat_ty rpats) match_result
= returnDs (ConPat con_id pat_ty pats, match_result)
where
- pats = map mk_pat tagged_arg_tys
+ pats = map mk_pat tagged_arg_tys
-- Boring stuff to find the arg-tys of the constructor
- (tyvars, _, arg_tys, _) = dataConSig con_id
- (_, inst_tys, _) = getAppDataTyCon pat_ty
- tenv = tyvars `zip` inst_tys
- con_arg_tys' = map (instantiateTauTy tenv) arg_tys
- tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags
+ (_, inst_tys, _) = getAppDataTyConExpandingDicts pat_ty
+ con_arg_tys' = dataConArgTys con_id inst_tys
+ tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels con_id)
-- 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
+ mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat,_) <- rpats,
+ recordSelectorFieldLabel sel_id == lbl
] of
(pat:pats) -> ASSERT( null pats )
pat
where
arity = length pats
tuple_ConPat
- = ConPat (mkTupleCon arity)
+ = ConPat (tupleCon arity)
(mkTupleTy arity (map outPatType pats))
pats
-- 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
| 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]
+
+ -- Convert the literal pattern "" to the constructor pattern [].
+ | null_str_lit lit = ConPat nilDataCon lit_ty []
+
| otherwise = pat
mk_int (HsInt i) = HsIntPrim i
mk_double (HsFrac f) = HsDoublePrim f
mk_double l@(HsLitLit s) = l
+ null_str_lit (HsString s) = _NULL_ s
+ null_str_lit other_lit = False
+
-- and everything else goes through unchanged...
tidy1 v non_interesting_pat match_result
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
+ | 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
- | 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 shadows
- | 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
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,
returnDs (var:vars, core_expr)
matchWrapper kind [(PatMatch (WildPat ty) match)] error_string
- = newSysLocalDs ty `thenDs` \ var ->
+ = 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 binds `thenDs` \ core_binds ->
- dsExpr expr `thenDs` \ core_expr ->
+ = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds ->
+ dsExpr expr `thenDs` \ core_expr ->
returnDs ([], mkCoLetsAny core_binds core_expr)
----------------------------------------------------------------------------
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 ->
+ 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
- let
- src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line
- fail_expr = mkErrorApp result_ty str_var (src_loc_str++": "++error_string)
- in
- extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
+ mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr ->
+
+ -- Check for incomplete pattern match
+ (case match_result of
+ MatchResult CanFail result_ty match_fn cxt
+ | opt_WarnIncompletePatterns
+ -> dsIncompleteWarn cxt
+ other -> returnDs ()
+ ) `thenDs` \ _ ->
+
+ extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
returnDs (new_vars, result_expr)
\end{code}
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) ->
+extractMatchResult (MatchResult CanFail result_ty match_fn cxt) fail_expr
+ = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) ->
returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails))
\end{code}
= flatten_match (pat:pats_so_far) match
flatten_match pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
- = dsBinds binds `thenDs` \ core_binds ->
+ = dsBinds False{-don't auto-scc-} 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 ->
+ getSrcLocDs `thenDs` \ locn ->
+ returnDs (EqnInfo pats
+ (MatchResult CantFail (coreExprType core_expr)
+ (\ ignore -> core_expr)
+ (DsMatchContext kind pats locn)))
+
+ -- 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