[project @ 2004-01-15 14:43:24 by igloo]
[ghc.git] / libraries / template-haskell / Language / Haskell / TH / PprLib.hs
1 {-# OPTIONS -fglasgow-exts #-}
2
3 -- Monadic front-end to Text.PrettyPrint.HughesPJ
4
5 module Language.Haskell.TH.PprLib (
6
7 -- * The document type
8 Doc, -- Abstract, instance of Show
9
10 -- * Primitive Documents
11 empty,
12 semi, comma, colon, space, equals,
13 lparen, rparen, lbrack, rbrack, lbrace, rbrace,
14
15 -- * Converting values into documents
16 text, char, ptext,
17 int, integer, float, double, rational,
18
19 -- * Wrapping documents in delimiters
20 parens, brackets, braces, quotes, doubleQuotes,
21
22 -- * Combining documents
23 (<>), (<+>), hcat, hsep,
24 ($$), ($+$), vcat,
25 sep, cat,
26 fsep, fcat,
27 nest,
28 hang, punctuate,
29
30 -- * Predicates on documents
31 isEmpty,
32
33 to_HPJ_Doc, pprName
34 ) where
35
36
37 import Language.Haskell.TH.Syntax (Name(..), NameFlavour(..))
38 import qualified Text.PrettyPrint.HughesPJ as HPJ
39 import Monad (liftM, liftM2)
40 import Data.FiniteMap (FiniteMap, lookupFM, emptyFM, addToFM)
41 import GHC.Base (Int(..))
42
43 infixl 6 <>
44 infixl 6 <+>
45 infixl 5 $$, $+$
46
47 -- ---------------------------------------------------------------------------
48 -- The interface
49
50 -- The primitive Doc values
51
52 instance Show Doc where
53 show d = HPJ.render (to_HPJ_Doc d)
54
55 isEmpty :: Doc -> PprM Bool; -- ^ Returns 'True' if the document is empty
56
57 empty :: Doc; -- ^ An empty document
58 semi :: Doc; -- ^ A ';' character
59 comma :: Doc; -- ^ A ',' character
60 colon :: Doc; -- ^ A ':' character
61 space :: Doc; -- ^ A space character
62 equals :: Doc; -- ^ A '=' character
63 lparen :: Doc; -- ^ A '(' character
64 rparen :: Doc; -- ^ A ')' character
65 lbrack :: Doc; -- ^ A '[' character
66 rbrack :: Doc; -- ^ A ']' character
67 lbrace :: Doc; -- ^ A '{' character
68 rbrace :: Doc; -- ^ A '}' character
69
70 text :: String -> Doc
71 ptext :: String -> Doc
72 char :: Char -> Doc
73 int :: Int -> Doc
74 integer :: Integer -> Doc
75 float :: Float -> Doc
76 double :: Double -> Doc
77 rational :: Rational -> Doc
78
79
80 parens :: Doc -> Doc; -- ^ Wrap document in @(...)@
81 brackets :: Doc -> Doc; -- ^ Wrap document in @[...]@
82 braces :: Doc -> Doc; -- ^ Wrap document in @{...}@
83 quotes :: Doc -> Doc; -- ^ Wrap document in @\'...\'@
84 doubleQuotes :: Doc -> Doc; -- ^ Wrap document in @\"...\"@
85
86 -- Combining @Doc@ values
87
88 (<>) :: Doc -> Doc -> Doc; -- ^Beside
89 hcat :: [Doc] -> Doc; -- ^List version of '<>'
90 (<+>) :: Doc -> Doc -> Doc; -- ^Beside, separated by space
91 hsep :: [Doc] -> Doc; -- ^List version of '<+>'
92
93 ($$) :: Doc -> Doc -> Doc; -- ^Above; if there is no
94 -- overlap it \"dovetails\" the two
95 ($+$) :: Doc -> Doc -> Doc; -- ^Above, without dovetailing.
96 vcat :: [Doc] -> Doc; -- ^List version of '$$'
97
98 cat :: [Doc] -> Doc; -- ^ Either hcat or vcat
99 sep :: [Doc] -> Doc; -- ^ Either hsep or vcat
100 fcat :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of cat
101 fsep :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of sep
102
103 nest :: Int -> Doc -> Doc; -- ^ Nested
104
105
106 -- GHC-specific ones.
107
108 hang :: Doc -> Int -> Doc -> Doc; -- ^ @hang d1 n d2 = sep [d1, nest n d2]@
109 punctuate :: Doc -> [Doc] -> [Doc]; -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
110
111
112 -- ---------------------------------------------------------------------------
113 -- The "implementation"
114
115 type State = (FiniteMap Name HPJ.Doc, Int)
116 data PprM a = PprM { runPprM :: State -> (a, State) }
117
118 pprName :: Name -> Doc
119 pprName n@(Name o (NameU _))
120 = PprM $ \s@(fm, i@(I# i'))
121 -> case lookupFM fm n of
122 Just d -> (d, s)
123 Nothing -> let d = HPJ.text $ show $ Name o (NameU i')
124 in (d, (addToFM fm n d, i + 1))
125 pprName n = text $ show n
126
127 {-
128 instance Show Name where
129 show (Name occ (NameU u)) = occString occ ++ "_" ++ show (I# u)
130 show (Name occ NameS) = occString occ
131 show (Name occ (NameG ns m)) = modString m ++ "." ++ occString occ
132
133 data Name = Name OccName NameFlavour
134
135 data NameFlavour
136 | NameU Int# -- A unique local name
137 -}
138
139 to_HPJ_Doc :: Doc -> HPJ.Doc
140 to_HPJ_Doc d = fst $ runPprM d (emptyFM, 0)
141
142 instance Monad PprM where
143 return x = PprM $ \s -> (x, s)
144 m >>= k = PprM $ \s -> let (x, s') = runPprM m s
145 in runPprM (k x) s'
146
147 type Doc = PprM HPJ.Doc
148
149 -- The primitive Doc values
150
151 isEmpty = liftM HPJ.isEmpty
152
153 empty = return HPJ.empty
154 semi = return HPJ.semi
155 comma = return HPJ.comma
156 colon = return HPJ.colon
157 space = return HPJ.space
158 equals = return HPJ.equals
159 lparen = return HPJ.lparen
160 rparen = return HPJ.rparen
161 lbrack = return HPJ.lbrack
162 rbrack = return HPJ.rbrack
163 lbrace = return HPJ.lbrace
164 rbrace = return HPJ.rbrace
165
166 text = return . HPJ.text
167 ptext = return . HPJ.ptext
168 char = return . HPJ.char
169 int = return . HPJ.int
170 integer = return . HPJ.integer
171 float = return . HPJ.float
172 double = return . HPJ.double
173 rational = return . HPJ.rational
174
175
176 parens = liftM HPJ.parens
177 brackets = liftM HPJ.brackets
178 braces = liftM HPJ.braces
179 quotes = liftM HPJ.quotes
180 doubleQuotes = liftM HPJ.doubleQuotes
181
182 -- Combining @Doc@ values
183
184 (<>) = liftM2 (HPJ.<>)
185 hcat = liftM HPJ.hcat . sequence
186 (<+>) = liftM2 (HPJ.<+>)
187 hsep = liftM HPJ.hsep . sequence
188
189 ($$) = liftM2 (HPJ.$$)
190 ($+$) = liftM2 (HPJ.$+$)
191 vcat = liftM HPJ.vcat . sequence
192
193 cat = liftM HPJ.cat . sequence
194 sep = liftM HPJ.sep . sequence
195 fcat = liftM HPJ.fcat . sequence
196 fsep = liftM HPJ.fsep . sequence
197
198 nest n = liftM (HPJ.nest n)
199
200 hang d1 n d2 = do d1' <- d1
201 d2' <- d2
202 return (HPJ.hang d1' n d2')
203 {-
204 punctuate p ds = do p' <- p
205 ds' <- sequence ds
206 map return (HPJ.punctuate p' ds')
207 -}
208 punctuate p ds = undefined
209 -- punctuate :: M Doc -> [M Doc] -> [M Doc]
210