Commit d2196957 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Rejig name printing a bit

parent de7bb878
......@@ -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
......
......@@ -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
......
......@@ -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
......
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