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