\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 ...
-
- pin_eqns (EqnInfo [] match_result1 : more_eqns)
- = pin_eqns more_eqns `thenDs` \ match_result2 ->
- combineMatchResults match_result1 match_result2
+ complete_match (EqnInfo [] match_result@(MatchResult _ _ _ cxt)) is_shadowed
+ | is_shadowed = dsShadowWarn cxt `thenDs` \ _ ->
+ returnDs match_result
- pin_eqns other_pat = panic "match: pin_eqns"
+ | otherwise = returnDs match_result
- 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"
+ eqn_cant_fail :: EquationInfo -> Bool
+ eqn_cant_fail (EqnInfo [] (MatchResult CanFail _ _ _)) = False
+ eqn_cant_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = True
\end{code}
%************************************************************************
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
-- 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
matchWrapper kind [(GRHSMatch
(GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string
- = dsBinds False binds `thenDs` \ core_binds ->
+ = dsBinds binds `thenDs` \ core_binds ->
dsExpr expr `thenDs` \ core_expr ->
returnDs ([], mkCoLetsAny core_binds core_expr)
match 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 ->
+ -- Check for incomplete pattern match
+ (case match_result of
+ MatchResult CanFail result_ty match_fn cxt -> 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 False binds `thenDs` \ core_binds ->
+ = dsBinds binds `thenDs` \ core_binds ->
dsGRHSs ty kind pats grhss `thenDs` \ match_result ->
returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result))
where
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)
- 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
+ (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