-pprOutPat sty (WildPat ty) = char '_'
-pprOutPat sty (VarPat var) = ppr sty var
-pprOutPat sty (LazyPat pat) = hcat [char '~', ppr sty pat]
-pprOutPat sty (AsPat name pat)
- = parens (hcat [ppr sty name, char '@', ppr sty pat])
-
-pprOutPat sty (ConPat name ty [])
- = (<>) (ppr sty name)
- (ifPprShowAll sty (pprConPatTy sty ty))
-
-pprOutPat sty (ConPat name ty pats)
- = hcat [parens (hcat [ppr sty name, space, interppSP sty pats]),
- ifPprShowAll sty (pprConPatTy sty ty) ]
-
-pprOutPat sty (ConOpPat pat1 op pat2 ty)
- = parens (hcat [ppr sty pat1, space, ppr sty op, space, ppr sty pat2])
-
-pprOutPat sty (ListPat ty pats)
- = brackets (interpp'SP sty pats)
-pprOutPat sty (TuplePat pats)
- = parens (interpp'SP sty pats)
-
-pprOutPat sty (RecPat con ty rpats)
- = hcat [ppr sty con, braces (hsep (punctuate comma (map (pp_rpat sty) rpats)))]
+pprOutPat (WildPat ty) = char '_'
+pprOutPat (VarPat var) = ppr var
+pprOutPat (LazyPat pat) = hcat [char '~', ppr pat]
+pprOutPat (AsPat name pat)
+ = parens (hcat [ppr name, char '@', ppr 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)
+ = getPprStyle $ \ sty ->
+ parens $
+ case pats of
+ [p1,p2]
+ | userStyle sty && isDataSymOcc (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)
+pprOutPat (TuplePat pats boxity) = tupleParens boxity (interpp'SP pats)
+
+pprOutPat (RecPat con ty tvs dicts rpats)
+ = hsep [ppr con, interppSP tvs, interppSP dicts, braces (hsep (punctuate comma (map (pp_rpat) rpats)))]