mkUnboxedTupleTy, unboxedTupleCon
)
import UniqSet
+import ErrUtils ( addErrLocHdrLine, dontAddErrLoc )
import Outputable
\end{code}
dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn
where
warn | length qs > maximum_output
- = hang (pp_context ctx (ptext SLIT("are overlapped")))
- 12 ((vcat $ map (ppr_eqn kind) (take maximum_output qs))
- $$ ptext SLIT("..."))
+ = pp_context ctx (ptext SLIT("are overlapped"))
+ 8 (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
+ ptext SLIT("..."))
| otherwise
- = hang (pp_context ctx (ptext SLIT("are overlapped")))
- 12 (vcat $ map (ppr_eqn kind) qs)
+ = pp_context ctx (ptext SLIT("are overlapped"))
+ 8 (\ f -> vcat $ map (ppr_eqn f kind) qs)
+
dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
where
warn | length pats > maximum_output
- = hang (pp_context ctx (ptext SLIT("are non-exhaustive")))
- 12 (hang (ptext SLIT("Patterns not recognized:"))
- 4 ((vcat $ map (ppr_incomplete_pats kind) (take maximum_output pats))
- $$ ptext SLIT("...")))
+ = pp_context ctx (ptext SLIT("are non-exhaustive"))
+ 8 (\ f -> hang (ptext SLIT("Patterns not recognized:"))
+ 4 (vcat (map (ppr_incomplete_pats kind)
+ (take maximum_output pats))
+ $$ ptext SLIT("...")))
| otherwise
- = hang (pp_context ctx (ptext SLIT("are non-exhaustive")))
- 12 (hang (ptext SLIT("Patterns not recognized:"))
- 4 (vcat $ map (ppr_incomplete_pats kind) pats))
+ = pp_context ctx (ptext SLIT("are non-exhaustive"))
+ 8 (\ f -> hang (ptext SLIT("Patterns not recognized:"))
+ 4 (vcat $ map (ppr_incomplete_pats kind) pats))
-pp_context NoMatchContext msg = ptext SLIT("Some match(es)") <+> msg
+pp_context NoMatchContext msg ind rest_of_msg_fun
+ = dontAddErrLoc "" (ptext SLIT("Some match(es)") <+> hang msg ind (rest_of_msg_fun id))
-pp_context (DsMatchContext kind pats loc) msg
- = hang (hcat [ppr loc, ptext SLIT(": ")])
- 4 (hang message
- 4 (pp_match kind pats))
+pp_context (DsMatchContext kind pats loc) msg ind rest_of_msg_fun
+ = case pp_match kind pats of
+ (ppr_match, pref) ->
+ addErrLocHdrLine loc message (nest ind (rest_of_msg_fun pref))
+ where
+ message = ptext SLIT("Pattern match(es)") <+> msg <+> ppr_match <> char ':'
where
- message = ptext SLIT("Pattern match(es)") <+> msg
-
pp_match (FunMatch fun) pats
- = hsep [ptext SLIT("in the definition of function"), quotes (ppr fun)]
+ = 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)
+ = (hang (ptext SLIT("in a group of case alternatives beginning"))
+ 4 (ppr_pats pats)
+ , id
+ )
pp_match PatBindMatch pats
- = hang (ptext SLIT("in a pattern binding:"))
- 4 (ppr_pats 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)
+ = ( 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)
+ = ( 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)
+ = ( 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)
+ = ( hang (ptext SLIT("in a `let' pattern binding"))
+ 4 (ppr_pats pats)
+ , id
+ )
ppr_pats pats = sep (map ppr pats)
separator (ListCompMatch) = SLIT("<-")
separator (LetMatch) = SLIT("=")
-ppr_shadow_pats kind pats = sep [ppr_pats pats, ptext (separator kind), ptext SLIT("...")]
+ppr_shadow_pats kind pats
+ = sep [ppr_pats pats, ptext (separator kind), ptext SLIT("...")]
ppr_incomplete_pats kind (pats,[]) = ppr_pats pats
ppr_incomplete_pats kind (pats,constraints) =
ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`not_elem`"), ppr pats]
-ppr_eqn kind (EqnInfo _ _ pats _) = ppr_shadow_pats kind pats
+ppr_eqn prefixF kind (EqnInfo _ _ pats _) = prefixF (ppr_shadow_pats kind pats)
\end{code}
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
+ = if ( (isWildPat p1 && isWildPat p2)
+ || (isConPat p1 && isConPat p2)
+ || (isLitPat p1 && isLitPat p2) ) then
eq1 `tack_onto` unmixed_rest
else
[ eq1 ] : unmixed_rest
-- DsM'd because of internal call to "match".
-- "tidy1" does the interesting stuff, looking at
-- one pattern and fiddling the list of bindings.
+ --
+ -- POST CONDITION: head pattern in the EqnInfo is
+ -- WildPat
+ -- ConPat
+ -- NPat
+ -- LitPat
+ -- NPlusKPat
+ -- 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')
matchUnmixedEqns [] _ = panic "matchUnmixedEqns: no names"
matchUnmixedEqns all_vars@(var:vars) eqns_info
- | irrefutablePat first_pat
- = ASSERT( irrefutablePats column_1_pats ) -- Sanity check
+ | isWildPat first_pat
+ = ASSERT( all isWildPat column_1_pats ) -- Sanity check
-- Real true variables, just like in matchVar, SLPJ p 94
+ -- No binding to do: they'll all be wildcards by now (done in tidy)
match vars remaining_eqns_info
| isConPat first_pat
-> 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 = ....
-
- This special case have been ``undone'' due to problems with the new warnings
- messages (Check.lhs.check). We need there the name of the variables to be able to
- print later the equation. JJQC 30-11-97
-
-\begin{old_code}
-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 [GRHS [ExprStmt expr _]] binds _))] error_string
- = dsExpr expr `thenDs` \ core_expr ->
- dsLet binds core_expr `thenDs` \ rhs ->
- returnDs ([], rhs)
-\end{old_code}
-
- And all the rest... (general case)
-
-
There is one small problem with the Lambda Patterns, when somebody
writes something similar to:
(\ (x:xs) -> ...)
ASSERT( all (== result_ty) result_tys )
returnDs (result_ty, eqn_infos)
where
- flatten_match (match, eqn_no) = flatten_match_help [] match eqn_no
-
- flatten_match_help :: [TypecheckedPat] -- Reversed list of patterns encountered so far
- -> TypecheckedMatch
- -> EqnNo
- -> DsM (Type, EquationInfo)
-
- flatten_match_help pats_so_far (PatMatch pat match) n
- = flatten_match_help (pat:pats_so_far) match n
-
- flatten_match_help pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty)) n
- = dsGRHSs kind pats grhss `thenDs` \ match_result ->
+ 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
- (adjustMatchResultDs (dsLet binds) match_result))
- -- NB: nested dsLet inside matchResult
- where
- pats = reverse pats_so_far -- They've accumulated in reverse order
-
- flatten_match_help pats_so_far (SimpleMatch expr) n
- = dsExpr expr `thenDs` \ core_expr ->
- getSrcLocDs `thenDs` \ locn ->
- returnDs (coreExprType core_expr,
- EqnInfo n (DsMatchContext kind pats locn) pats
- (cantFailMatchResult core_expr))
- where
- pats = reverse pats_so_far -- They've accumulated in reverse order
+ returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats match_result)
\end{code}
projects / ghc-hetmet.git / blobdiff