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