Commit 0dfd6d6b authored by sof's avatar sof
Browse files

[project @ 1999-01-24 14:00:12 by sof]

Tidied up desugar warnings - will now print out patterns containing
infix constructors correctly.
parent 0b36e002
......@@ -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)
......
......@@ -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}
......
......@@ -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)
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment