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