[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

@@ -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)
 

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}
 
 

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)

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