From 0dfd6d6bac63c0976f4b94243499d678eee30765 Mon Sep 17 00:00:00 2001 From: sof Date: Sun, 24 Jan 1999 14:00:14 +0000 Subject: [PATCH] [project @ 1999-01-24 14:00:12 by sof] Tidied up desugar warnings - will now print out patterns containing infix constructors correctly. --- ghc/compiler/deSugar/Check.lhs | 26 ++++++-------- ghc/compiler/deSugar/Match.lhs | 74 +++++++++++++++++++++++++--------------- ghc/compiler/hsSyn/HsPat.lhs | 26 ++++++++------ ghc/compiler/main/ErrUtils.lhs | 2 +- 4 files changed, 74 insertions(+), 54 deletions(-) diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 342bfa8..4d1f001 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -6,7 +6,7 @@ \begin{code} -module Check ( check , ExhaustivePat, WarningPat, BoxedString(..) ) where +module Check ( check , ExhaustivePat ) where import HsSyn @@ -112,14 +112,8 @@ Then we need to use InPats. \begin{code} -newtype BoxedString = BS Name - -type WarningPat = InPat BoxedString -type ExhaustivePat = ([WarningPat], [(BoxedString, [HsLit])]) - - -instance Outputable BoxedString where - ppr (BS n) = ppr n +type WarningPat = InPat Name +type ExhaustivePat = ([WarningPat], [(Name, [HsLit])]) check :: [EquationInfo] -> ([ExhaustivePat],EqnSet) @@ -134,7 +128,7 @@ untidy_exhaustive ([pat], messages) = untidy_exhaustive (pats, messages) = (map untidy_pars pats, map untidy_message messages) -untidy_message :: (BoxedString, [HsLit]) -> (BoxedString, [HsLit]) +untidy_message :: (Name, [HsLit]) -> (Name, [HsLit]) untidy_message (string, lits) = (string, map untidy_lit lits) \end{code} @@ -393,7 +387,7 @@ remove_first_column (ConPat con _ _ _ con_pats) qs = make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat make_row_vars used_lits (EqnInfo _ _ pats _ ) = (VarPatIn new_var:take (length (tail pats)) (repeat new_wild_pat),[(new_var,used_lits)]) - where new_var = BS hash_x + where new_var = hash_x hash_x = mkLocalName unboundKey {- doesn't matter much -} (varOcc SLIT("#x")) @@ -520,8 +514,8 @@ not the second. isInfixCon con = isConSymOcc (getOccName con) -is_nil (ConPatIn (BS con) []) = con == getName nilDataCon -is_nil _ = False +is_nil (ConPatIn con []) = con == getName nilDataCon +is_nil _ = False is_list (ListPatIn _) = True is_list _ = False @@ -536,7 +530,7 @@ make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat make_con (ConPat id _ _ _ _) (p:q:ps, constraints) | return_list id q = (make_list p q : ps, constraints) | isInfixCon id = ((ConOpPatIn p name fixity q) : ps, constraints) - where name = BS (getName id) + where name = getName id fixity = panic "Check.make_con: Guessing fixity" make_con (ConPat id _ _ _ pats) (ps,constraints) @@ -544,7 +538,7 @@ make_con (ConPat id _ _ _ pats) (ps,constraints) | isUnboxedTupleCon id = (TuplePatIn pats_con False : rest_pats, constraints) | otherwise = (ConPatIn name pats_con : rest_pats, constraints) where num_args = length pats - name = BS (getName id) + name = getName id pats_con = take num_args ps rest_pats = drop num_args ps @@ -554,7 +548,7 @@ make_whole_con con | isInfixCon con = ConOpPatIn new_wild_pat name fixity new_wi | otherwise = ConPatIn name pats where fixity = panic "Check.make_whole_con: Guessing fixity" - name = BS (getName con) + name = getName con arity = dataConSourceArity con pats = take arity (repeat new_wild_pat) diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 9ac0d39..b0f58d1 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -95,11 +95,11 @@ dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn where warn | length qs > maximum_output = pp_context ctx (ptext SLIT("are overlapped")) - 8 (vcat (map (ppr_eqn kind) (take maximum_output qs)) $$ + 8 (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ ptext SLIT("...")) | otherwise = pp_context ctx (ptext SLIT("are overlapped")) - 8 (vcat $ map (ppr_eqn kind) qs) + 8 (\ f -> vcat $ map (ppr_eqn f kind) qs) dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () @@ -107,47 +107,66 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn where warn | length pats > maximum_output = pp_context ctx (ptext SLIT("are non-exhaustive")) - 8 (hang (ptext SLIT("Patterns not recognized:")) - 4 ((vcat $ map (ppr_incomplete_pats kind) (take maximum_output pats)) - $$ ptext SLIT("..."))) + 8 (\ f -> hang (ptext SLIT("Patterns not recognized:")) + 4 (vcat (map (ppr_incomplete_pats kind) + (take maximum_output pats)) + $$ ptext SLIT("..."))) | otherwise = pp_context ctx (ptext SLIT("are non-exhaustive")) - 8 (hang (ptext SLIT("Patterns not recognized:")) - 4 (vcat $ map (ppr_incomplete_pats kind) pats)) + 8 (\ f -> hang (ptext SLIT("Patterns not recognized:")) + 4 (vcat $ map (ppr_incomplete_pats kind) pats)) -pp_context NoMatchContext msg ind rest_of_msg = dontAddErrLoc "" (ptext SLIT("Some match(es)") <+> hang msg ind rest_of_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 ind rest_of_msg - = addErrLocHdrLine loc message (hang (pp_match kind pats) ind rest_of_msg) +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) @@ -159,7 +178,8 @@ separator (DoBindMatch) = SLIT("<-") 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) = @@ -169,7 +189,7 @@ 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} diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index d115306..cbd0e0d 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -26,6 +26,7 @@ import BasicTypes ( Fixity ) -- others: import Var ( Id, TyVar ) import DataCon ( DataCon, dataConTyCon ) +import Name ( isConSymOcc, getOccName, NamedThing ) import Maybes ( maybeToBool ) import Outputable import TyCon ( maybeTyConSingleCon ) @@ -67,15 +68,12 @@ data InPat name data OutPat id = WildPat Type -- wild card - - | VarPat id -- variable (type is in the Id) - + | VarPat id -- variable (type is in the Id) | LazyPat (OutPat id) -- lazy pattern - - | AsPat id -- as pattern + | AsPat id -- as pattern (OutPat id) - | ListPat -- syntactic list + | ListPat -- syntactic list Type -- the type of the elements [OutPat id] @@ -86,7 +84,7 @@ data OutPat id | ConPat DataCon Type -- the type of the pattern [TyVar] -- Existentially bound type variables - [id] -- Ditto dictionaries + [id] -- Ditto dictionaries [OutPat id] -- ConOpPats are only used on the input side @@ -144,7 +142,7 @@ pprInPat (AsPatIn name pat) = parens (hcat [ppr name, char '@', ppr pat]) pprInPat (ConPatIn c pats) | null pats = ppr c - | otherwise = hsep [ppr c, interppSP pats] -- ParPats put in the parens + | otherwise = hsep [ppr c, interppSP pats] -- inner ParPats supply the necessary parens. pprInPat (ConOpPatIn pat1 op fixity pat2) = hsep [ppr pat1, ppr op, ppr pat2] -- ParPats put in parens @@ -182,7 +180,7 @@ pprInPat (RecPatIn con rpats) \end{code} \begin{code} -instance (Outputable id) => Outputable (OutPat id) where +instance (NamedThing id, Outputable id) => Outputable (OutPat id) where ppr = pprOutPat \end{code} @@ -196,8 +194,16 @@ pprOutPat (AsPat name pat) pprOutPat (ConPat name ty [] [] []) = ppr name +-- Kludge to get infix constructors to come out right +-- when ppr'ing desugar warnings. pprOutPat (ConPat name ty tyvars dicts pats) - = parens (hsep [ppr name, interppSP tyvars, interppSP dicts, interppSP pats]) + = getPprStyle $ \ sty -> + parens $ + case pats of + [p1,p2] + | userStyle sty && isConSymOcc (getOccName name) -> + hsep [ppr p1, ppr name, ppr p2] + _ -> hsep [ppr name, interppSP tyvars, interppSP dicts, interppSP pats] pprOutPat (ListPat ty pats) = brackets (interpp'SP pats) diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index 9281fa2..b461e4b 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -60,7 +60,7 @@ dontAddErrLoc title rest_of_err_msg pprBagOfErrors :: Bag ErrMsg -> SDoc pprBagOfErrors bag_of_errors - = vcat [space $$ p | (_,p) <- sorted_errs ] + = vcat [p $$ text "" | (_,p) <- sorted_errs ] where bag_ls = bagToList bag_of_errors sorted_errs = sortLt occ'ed_before bag_ls -- 1.7.10.4