Rejig name printing a bit

3 files changed, 47 insertions, 27 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index d2c64d9063..a48a955eb6 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -39,7 +39,7 @@ instance Ppr a => Ppr [a] where
 
 ------------------------------
 instance Ppr Name where
-    ppr v = pprName True v -- text (show v)
+    ppr v = pprName v
 
 ------------------------------
 instance Ppr Info where
@@ -77,13 +77,13 @@ instance Ppr Exp where
     ppr = pprExp noPrec
 
 pprInfixExp :: Exp -> Doc
-pprInfixExp (VarE v) = pprName False v
-pprInfixExp (ConE v) = pprName False v
+pprInfixExp (VarE v) = pprName' Infix v
+pprInfixExp (ConE v) = pprName' Infix v
 pprInfixExp _        = error "Attempt to pretty-print non-variable or constructor in infix context!"
 
 pprExp :: Precedence -> Exp -> Doc
-pprExp _ (VarE v)     = ppr v
-pprExp _ (ConE c)     = ppr c
+pprExp _ (VarE v)     = pprName' Applied v
+pprExp _ (ConE c)     = pprName' Applied c
 pprExp i (LitE l)     = pprLit i l
 pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1
                                               <+> pprExp appPrec e2
@@ -175,8 +175,9 @@ pprPat _ (TupP ps)    = parens $ sep $ punctuate comma $ map ppr ps
 pprPat i (ConP s ps)  = parensIf (i > noPrec) $ ppr s
                                             <+> sep (map (pprPat appPrec) ps)
 pprPat i (InfixP p1 n p2)
-                      = parensIf (i > noPrec)
-                      $ pprPat opPrec p1 <+> pprName False n <+> pprPat opPrec p2
+                      = parensIf (i > noPrec) (pprPat opPrec p1 <+>
+                                               pprName' Infix n <+>
+                                               pprPat opPrec p2)
 pprPat i (TildeP p)   = parensIf (i > noPrec) $ char '~' <> pprPat appPrec p
 pprPat i (AsP v p)    = parensIf (i > noPrec) $ ppr v <> text "@"
                                                       <> pprPat appPrec p
@@ -258,7 +259,9 @@ instance Ppr Con where
     ppr (NormalC c sts) = ppr c <+> sep (map pprStrictType sts)
     ppr (RecC c vsts)
         = ppr c <+> braces (sep (punctuate comma $ map pprVarStrictType vsts))
-    ppr (InfixC st1 c st2) = pprStrictType st1 <+> pprName False c <+> pprStrictType st2
+    ppr (InfixC st1 c st2) = pprStrictType st1
+                         <+> pprName' Infix c
+                         <+> pprStrictType st2
     ppr (ForallC ns ctxt con) = text "forall" <+> hsep (map ppr ns)
                             <+> char '.' <+> pprCxt ctxt <+> ppr con
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs
index 0f740a18f7..ae0b5cc24f 100644
--- a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs
@@ -31,11 +31,12 @@ module Language.Haskell.TH.PprLib (
 	-- * Predicates on documents
 	isEmpty,
 
-    to_HPJ_Doc, pprName
+    to_HPJ_Doc, pprName, pprName'
   ) where
 
 
-import Language.Haskell.TH.Syntax (Name(..), showName, NameFlavour(..))
+import Language.Haskell.TH.Syntax
+    (Name(..), showName', NameFlavour(..), NameIs(..))
 import qualified Text.PrettyPrint.HughesPJ as HPJ
 import Control.Monad (liftM, liftM2)
 import Data.Map ( Map )
@@ -114,17 +115,21 @@ punctuate :: Doc -> [Doc] -> [Doc];      -- ^ @punctuate p [d1, ... dn] = [d1 \<
 -- ---------------------------------------------------------------------------
 -- The "implementation"
 
-type State = (Map Name HPJ.Doc, Int)
+type State = (Map Name Name, Int)
 data PprM a = PprM { runPprM :: State -> (a, State) }
 
-pprName :: Bool -> Name -> Doc
-pprName pfx n@(Name o (NameU _))
+pprName :: Name -> Doc
+pprName = pprName' Alone
+
+pprName' :: NameIs -> Name -> Doc
+pprName' ni n@(Name o (NameU _))
  = PprM $ \s@(fm, i@(I# i'))
-        -> case Map.lookup n fm of
-               Just d -> (d, s)
-               Nothing -> let d = HPJ.text $ showName pfx $ Name o (NameU i')
-                          in (d, (Map.insert n d fm, i + 1))
-pprName pfx n = text $ showName pfx n
+        -> let (n', s') = case Map.lookup n fm of
+                         Just d -> (d, s)
+                         Nothing -> let n' = Name o (NameU i')
+                                    in (n', (Map.insert n n' fm, i + 1))
+           in (HPJ.text $ showName' ni n', s')
+pprName' ni n = text $ showName' ni n
 
 {-
 instance Show Name where
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 4399e35415..b9d82e5275 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -22,7 +22,8 @@ module Language.Haskell.TH.Syntax(
 	currentModule, runIO,
 
 	-- Names
-	Name(..), mkName, newName, nameBase, nameModule, showName,
+	Name(..), mkName, newName, nameBase, nameModule,
+    showName, showName', NameIs(..),
 
 	-- The algebraic data types
 	Dec(..), Exp(..), Con(..), Type(..), Cxt, Match(..), 
@@ -432,11 +433,21 @@ instance Ord NameFlavour where
 					    (m1 `compare` m2) 
   (NameG _ _ _)    `compare` other	  = GT
 
-showName :: Bool -> Name -> String
-showName pflg nm | pflg && pnam = nms
-                 | pflg         = "(" ++ nms ++ ")"
-                 | pnam         = "`" ++ nms ++ "`"
-                 | otherwise    = nms
+data NameIs = Alone | Applied | Infix
+
+showName :: Name -> String
+showName = showName' Alone
+
+showName' :: NameIs -> Name -> String
+showName' ni nm
+ = case ni of
+       Alone        -> nms
+       Applied
+        | pnam      -> nms
+        | otherwise -> "(" ++ nms ++ ")"
+       Infix
+        | pnam      -> "`" ++ nms ++ "`"
+        | otherwise -> nms
     where
 	-- For now, we make the NameQ and NameG print the same, even though
 	-- NameQ is a qualified name (so what it means depends on what the
@@ -453,16 +464,17 @@ showName pflg nm | pflg && pnam = nms
 
         pnam = classify nms
 
+        -- True if we are function style, e.g. f, [], (,)
+        -- False if we are operator style, e.g. +, :+
         classify "" = False -- shouldn't happen; . operator is handled below
-        classify (x:xs) | isAlpha x || x == '_' =
+        classify (x:xs) | isAlpha x || (x `elem` "_[]()") =
                             case dropWhile (/='.') xs of
                                   (_:xs') -> classify xs'
                                   []      -> True
                         | otherwise = False
 
 instance Show Name where
-  show = showName True
-
+  show = showName
 
 -- 	Tuple data and type constructors
 tupleDataName  :: Int -> Name	-- Data constructor