1{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE DefaultSignatures #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10
11{-# LANGUAGE MultiParamTypeClasses #-}
12{-# LANGUAGE UndecidableInstances #-}
13-- | This module re-exports some of the interface for
14-- "Text.PrettyPrint.Annotated.Leijen" along with additional definitions
15-- useful for stack.
16--
17-- It defines a 'Monoid' instance for 'Doc'.
18module Text.PrettyPrint.Leijen.Extended
19  (
20  -- * Pretty-print typeclass
21  Pretty (..),
22
23  -- * Ansi terminal Doc
24  --
25  -- See "System.Console.ANSI" for 'SGR' values to use beyond the colors
26  -- provided.
27  StyleDoc, StyleAnn(..),
28  -- hDisplayAnsi,
29  displayAnsi, displayPlain, renderDefault,
30
31  -- * Selective re-exports from "Text.PrettyPrint.Annotated.Leijen"
32  --
33  -- Documentation of omissions up-to-date with @annotated-wl-pprint-0.7.0@
34
35  -- ** Documents, parametrized by their annotations
36  --
37  -- Omitted compared to original: @putDoc, hPutDoc@
38  -- Doc,
39
40  -- ** Basic combinators
41  --
42  -- Omitted compared to original: @empty, char, text, (<>)@
43  --
44  -- Instead of @text@ and @char@, use 'fromString'.
45  --
46  -- Instead of @empty@, use 'mempty'.
47  nest, line, linebreak, group, softline, softbreak,
48
49  -- ** Alignment
50  --
51  -- The combinators in this section can not be described by Wadler's
52  -- original combinators. They align their output relative to the
53  -- current output position - in contrast to @nest@ which always
54  -- aligns to the current nesting level. This deprives these
55  -- combinators from being \`optimal\'. In practice however they
56  -- prove to be very useful. The combinators in this section should
57  -- be used with care, since they are more expensive than the other
58  -- combinators. For example, @align@ shouldn't be used to pretty
59  -- print all top-level declarations of a language, but using @hang@
60  -- for let expressions is fine.
61  --
62  -- Omitted compared to original: @list, tupled, semiBraces@
63  align, hang, indent, encloseSep,
64
65  -- ** Operators
66  --
67  -- Omitted compared to original: @(<$>), (</>), (<$$>), (<//>)@
68  (<+>),
69
70  -- ** List combinators
71  hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate,
72
73  -- ** Fillers
74  fill, fillBreak,
75
76  -- ** Bracketing combinators
77  enclose, squotes, dquotes, parens, angles, braces, brackets,
78
79  -- ** Character documents
80  -- Entirely omitted:
81  --
82  -- @
83  -- lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket,
84  -- squote, dquote, semi, colon, comma, space, dot, backslash, equals,
85  -- pipe
86  -- @
87
88  -- ** Primitive type documents
89  -- Entirely omitted:
90  --
91  -- @
92  -- string, int, integer, float, double, rational, bool,
93  -- @
94
95  -- ** Semantic annotations
96  annotate, noAnnotate, styleAnn
97
98  -- ** Rendering
99  -- Original entirely omitted:
100  -- @
101  -- SimpleDoc(..), renderPretty, renderCompact, displayDecorated, displayDecoratedA, display, displayS, displayIO,
102  -- SpanList(..), displaySpans
103  -- @
104
105  -- ** Undocumented
106  -- Entirely omitted:
107  -- @
108  -- column, nesting, width
109  -- @
110  ) where
111
112import Control.Monad.Reader (runReader, local)
113import Data.Array.IArray ((!), (//))
114import qualified Data.Text as T
115import Distribution.ModuleName (ModuleName)
116import qualified Distribution.Text (display)
117import Path
118import RIO
119import qualified RIO.Map as M
120import RIO.PrettyPrint.DefaultStyles (defaultStyles)
121import RIO.PrettyPrint.Types (Style (Dir, File), Styles)
122import RIO.PrettyPrint.StylesUpdate (StylesUpdate (..), HasStylesUpdate, stylesUpdateL)
123import System.Console.ANSI (ConsoleLayer (..), SGR (..), setSGRCode)
124import qualified Text.PrettyPrint.Annotated.Leijen as P
125import Text.PrettyPrint.Annotated.Leijen
126  ( Doc, SimpleDoc (..)
127  )
128
129-- TODO: consider smashing together the code for wl-annotated-pprint and
130-- wl-pprint-text. The code here already handles doing the
131-- ansi-wl-pprint stuff (better!) atop wl-annotated-pprint. So the
132-- result would be a package unifying 3 different wl inspired packages.
133--
134-- Perhaps it can still have native string support, by adding a type
135-- parameter to Doc?
136
137instance Semigroup StyleDoc where
138    StyleDoc x <> StyleDoc y = StyleDoc (x P.<> y)
139instance Monoid StyleDoc where
140    mappend = (<>)
141    mempty = StyleDoc P.empty
142
143--------------------------------------------------------------------------------
144-- Pretty-Print class
145
146class Pretty a where
147    pretty :: a -> StyleDoc
148    default pretty :: Show a => a -> StyleDoc
149    pretty = StyleDoc . fromString . show
150
151instance Pretty StyleDoc where
152    pretty = id
153
154instance Pretty (Path b File) where
155    pretty = styleAnn File . StyleDoc . fromString . toFilePath
156
157instance Pretty (Path b Dir) where
158    pretty = styleAnn Dir . StyleDoc . fromString . toFilePath
159
160instance Pretty ModuleName where
161    pretty = StyleDoc . fromString . Distribution.Text.display
162
163--------------------------------------------------------------------------------
164-- Style Doc
165
166-- |A style annotation.
167newtype StyleAnn = StyleAnn (Maybe Style)
168    deriving (Eq, Show, Semigroup)
169
170instance Monoid StyleAnn where
171    mempty = StyleAnn Nothing
172    mappend = (<>)
173
174-- |A document annotated by a style
175newtype StyleDoc = StyleDoc { unStyleDoc :: Doc StyleAnn }
176  deriving IsString
177
178-- |An ANSI code(s) annotation.
179newtype AnsiAnn = AnsiAnn [SGR]
180    deriving (Eq, Show, Semigroup, Monoid)
181
182-- |Convert a 'SimpleDoc' annotated with 'StyleAnn' to one annotated with
183-- 'AnsiAnn', by reference to a 'Styles'.
184toAnsiDoc :: Styles -> SimpleDoc StyleAnn -> SimpleDoc AnsiAnn
185toAnsiDoc styles = go
186  where
187    go SEmpty        = SEmpty
188    go (SChar c d)   = SChar c (go d)
189    go (SText l s d) = SText l s (go d)
190    go (SLine i d)   = SLine i (go d)
191    go (SAnnotStart (StyleAnn (Just s)) d) =
192        SAnnotStart (AnsiAnn (snd $ styles ! s)) (go d)
193    go (SAnnotStart (StyleAnn Nothing) d) = SAnnotStart (AnsiAnn []) (go d)
194    go (SAnnotStop d) = SAnnotStop (go d)
195
196displayPlain
197    :: (Pretty a, HasLogFunc env, HasStylesUpdate env,
198        MonadReader env m, HasCallStack)
199    => Int -> a -> m Utf8Builder
200displayPlain w =
201    displayAnsiSimple . renderDefault w . fmap (const mempty) . unStyleDoc . pretty
202
203-- TODO: tweak these settings more?
204-- TODO: options for settings if this is released as a lib
205
206renderDefault :: Int -> Doc a -> SimpleDoc a
207renderDefault = P.renderPretty 1
208
209displayAnsi
210    :: (Pretty a, HasLogFunc env, HasStylesUpdate env,
211        MonadReader env m, HasCallStack)
212    => Int -> a -> m Utf8Builder
213displayAnsi w =
214    displayAnsiSimple . renderDefault w . unStyleDoc . pretty
215
216{- Not used --------------------------------------------------------------------
217
218hDisplayAnsi
219    :: (Display a, HasAnsiAnn (Ann a), MonadIO m)
220    => Handle -> Int -> a -> m ()
221hDisplayAnsi h w x = liftIO $ do
222    useAnsi <- hSupportsANSI h
223    T.hPutStr h $ if useAnsi then displayAnsi w x else displayPlain w x
224
225-}
226
227displayAnsiSimple
228    :: (HasLogFunc env, HasStylesUpdate env, MonadReader env m, HasCallStack)
229    => SimpleDoc StyleAnn -> m Utf8Builder
230displayAnsiSimple doc = do
231    update <- view stylesUpdateL
232    let styles = defaultStyles // stylesUpdate update
233        doc' = toAnsiDoc styles doc
234    return $
235        flip runReader mempty $ displayDecoratedWrap go doc'
236  where
237    go (AnsiAnn sgrs) inner = do
238        old <- ask
239        let sgrs' = mapMaybe (\sgr -> if sgr == Reset
240                                        then Nothing
241                                        else Just (getSGRTag sgr, sgr)) sgrs
242            new = if Reset `elem` sgrs
243                      then M.fromList sgrs'
244                      else foldl' (\mp (tag, sgr) -> M.insert tag sgr mp) old sgrs'
245        (extra, contents) <- local (const new) inner
246        return (extra, transitionCodes old new <> contents <> transitionCodes new old)
247    transitionCodes old new =
248        case (null removals, null additions) of
249            (True, True) -> mempty
250            (True, False) -> fromString (setSGRCode additions)
251            (False, _) -> fromString (setSGRCode (Reset : M.elems new))
252      where
253        (removals, additions) = partitionEithers $ M.elems $
254            M.mergeWithKey
255               (\_ o n -> if o == n then Nothing else Just (Right n))
256               (fmap Left)
257               (fmap Right)
258               old
259               new
260
261displayDecoratedWrap
262    :: forall a m. Monad m
263    => (forall b. a -> m (b, Utf8Builder) -> m (b, Utf8Builder))
264    -> SimpleDoc a
265    -> m Utf8Builder
266displayDecoratedWrap f doc = do
267    (mafter, result) <- go doc
268    case mafter of
269      Just _ -> error "Invariant violated by input to displayDecoratedWrap: no matching SAnnotStart for SAnnotStop."
270      Nothing -> return result
271  where
272    spaces n = display (T.replicate n " ")
273
274    go :: SimpleDoc a -> m (Maybe (SimpleDoc a), Utf8Builder)
275    go SEmpty = return (Nothing, mempty)
276    go (SChar c x) = fmap (fmap (display c <>)) (go x)
277    -- NOTE: Could actually use the length to guess at an initial
278    -- allocation.  Better yet would be to just use Text in pprint..
279    go (SText _l s x) = fmap (fmap (fromString s <>)) (go x)
280    go (SLine n x) = fmap (fmap ((display '\n' <>) . (spaces n <>))) (go x)
281    go (SAnnotStart ann x) = do
282        (mafter, contents) <- f ann (go x)
283        case mafter of
284            Just after -> fmap (fmap (contents <>)) (go after)
285            Nothing -> error "Invariant violated by input to displayDecoratedWrap: no matching SAnnotStop for SAnnotStart."
286    go (SAnnotStop x) = return (Just x, mempty)
287
288{- Not used --------------------------------------------------------------------
289
290-- Foreground color combinators
291
292black, red, green, yellow, blue, magenta, cyan, white,
293    dullblack, dullred, dullgreen, dullyellow, dullblue, dullmagenta, dullcyan, dullwhite,
294    onblack, onred, ongreen, onyellow, onblue, onmagenta, oncyan, onwhite,
295    ondullblack, ondullred, ondullgreen, ondullyellow, ondullblue, ondullmagenta, ondullcyan, ondullwhite
296    :: Doc AnsiAnn -> Doc AnsiAnn
297(black, dullblack, onblack, ondullblack) = colorFunctions Black
298(red, dullred, onred, ondullred) = colorFunctions Red
299(green, dullgreen, ongreen, ondullgreen) = colorFunctions Green
300(yellow, dullyellow, onyellow, ondullyellow) = colorFunctions Yellow
301(blue, dullblue, onblue, ondullblue) = colorFunctions Blue
302(magenta, dullmagenta, onmagenta, ondullmagenta) = colorFunctions Magenta
303(cyan, dullcyan, oncyan, ondullcyan) = colorFunctions Cyan
304(white, dullwhite, onwhite, ondullwhite) = colorFunctions White
305
306type EndoAnsiDoc = Doc AnsiAnn -> Doc AnsiAnn
307
308colorFunctions :: Color -> (EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc)
309colorFunctions color =
310    ( ansiAnn [SetColor Foreground Vivid color]
311    , ansiAnn [SetColor Foreground Dull color]
312    , ansiAnn [SetColor Background Vivid color]
313    , ansiAnn [SetColor Background Dull color]
314    )
315
316-}
317
318styleAnn :: Style -> StyleDoc -> StyleDoc
319styleAnn s = StyleDoc . P.annotate (StyleAnn (Just s)) . unStyleDoc
320
321{- Not used --------------------------------------------------------------------
322
323-- Intensity combinators
324
325bold, faint, normal :: Doc AnsiAnn -> Doc AnsiAnn
326bold = ansiAnn [SetConsoleIntensity BoldIntensity]
327faint = ansiAnn [SetConsoleIntensity FaintIntensity]
328normal = ansiAnn [SetConsoleIntensity NormalIntensity]
329
330-}
331
332-- | Tags for each field of state in SGR (Select Graphics Rendition).
333--
334-- It's a bit of a hack that 'TagReset' is included.
335data SGRTag
336    = TagReset
337    | TagConsoleIntensity
338    | TagItalicized
339    | TagUnderlining
340    | TagBlinkSpeed
341    | TagVisible
342    | TagSwapForegroundBackground
343    | TagColorForeground
344    | TagColorBackground
345    | TagRGBColor
346    | TagPaletteColor
347    deriving (Eq, Ord)
348
349getSGRTag :: SGR -> SGRTag
350getSGRTag Reset{}                       = TagReset
351getSGRTag SetConsoleIntensity{}         = TagConsoleIntensity
352getSGRTag SetItalicized{}               = TagItalicized
353getSGRTag SetUnderlining{}              = TagUnderlining
354getSGRTag SetBlinkSpeed{}               = TagBlinkSpeed
355getSGRTag SetVisible{}                  = TagVisible
356getSGRTag SetSwapForegroundBackground{} = TagSwapForegroundBackground
357getSGRTag (SetColor Foreground _ _)     = TagColorForeground
358getSGRTag (SetColor Background _ _)     = TagColorBackground
359getSGRTag SetRGBColor{}                 = TagRGBColor
360getSGRTag SetPaletteColor{}             = TagPaletteColor
361
362(<+>) :: StyleDoc -> StyleDoc -> StyleDoc
363StyleDoc x <+> StyleDoc y = StyleDoc (x P.<+> y)
364
365align :: StyleDoc -> StyleDoc
366align = StyleDoc . P.align . unStyleDoc
367
368noAnnotate :: StyleDoc -> StyleDoc
369noAnnotate = StyleDoc . P.noAnnotate . unStyleDoc
370
371braces :: StyleDoc -> StyleDoc
372braces = StyleDoc . P.braces . unStyleDoc
373
374angles :: StyleDoc -> StyleDoc
375angles = StyleDoc . P.angles . unStyleDoc
376
377parens :: StyleDoc -> StyleDoc
378parens = StyleDoc . P.parens . unStyleDoc
379
380dquotes :: StyleDoc -> StyleDoc
381dquotes = StyleDoc . P.dquotes . unStyleDoc
382
383squotes :: StyleDoc -> StyleDoc
384squotes = StyleDoc . P.squotes . unStyleDoc
385
386brackets :: StyleDoc -> StyleDoc
387brackets = StyleDoc . P.brackets . unStyleDoc
388
389annotate :: StyleAnn -> StyleDoc -> StyleDoc
390annotate a = StyleDoc . P.annotate a . unStyleDoc
391
392nest :: Int -> StyleDoc -> StyleDoc
393nest a = StyleDoc . P.nest a . unStyleDoc
394
395line :: StyleDoc
396line = StyleDoc P.line
397
398linebreak :: StyleDoc
399linebreak = StyleDoc P.linebreak
400
401fill :: Int -> StyleDoc -> StyleDoc
402fill a = StyleDoc . P.fill a . unStyleDoc
403
404fillBreak :: Int -> StyleDoc -> StyleDoc
405fillBreak a = StyleDoc . P.fillBreak a . unStyleDoc
406
407enclose :: StyleDoc -> StyleDoc -> StyleDoc -> StyleDoc
408enclose l r x = l <> x <> r
409
410cat :: [StyleDoc] -> StyleDoc
411cat = StyleDoc . P.cat . map unStyleDoc
412
413punctuate :: StyleDoc -> [StyleDoc] -> [StyleDoc]
414punctuate (StyleDoc x) = map StyleDoc . P.punctuate x . map unStyleDoc
415
416fillCat :: [StyleDoc] -> StyleDoc
417fillCat = StyleDoc . P.fillCat . map unStyleDoc
418
419hcat :: [StyleDoc] -> StyleDoc
420hcat = StyleDoc . P.hcat . map unStyleDoc
421
422vcat :: [StyleDoc] -> StyleDoc
423vcat = StyleDoc . P.vcat . map unStyleDoc
424
425sep :: [StyleDoc] -> StyleDoc
426sep = StyleDoc . P.sep . map unStyleDoc
427
428vsep :: [StyleDoc] -> StyleDoc
429vsep = StyleDoc . P.vsep . map unStyleDoc
430
431hsep :: [StyleDoc] -> StyleDoc
432hsep = StyleDoc . P.hsep . map unStyleDoc
433
434fillSep :: [StyleDoc] -> StyleDoc
435fillSep = StyleDoc . P.fillSep . map unStyleDoc
436
437encloseSep :: StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
438encloseSep (StyleDoc x) (StyleDoc y) (StyleDoc z) =
439  StyleDoc . P.encloseSep x y z . map unStyleDoc
440
441indent :: Int -> StyleDoc -> StyleDoc
442indent a = StyleDoc . P.indent a . unStyleDoc
443
444hang :: Int -> StyleDoc -> StyleDoc
445hang a = StyleDoc . P.hang a . unStyleDoc
446
447softbreak :: StyleDoc
448softbreak = StyleDoc P.softbreak
449
450softline :: StyleDoc
451softline = StyleDoc P.softline
452
453group :: StyleDoc -> StyleDoc
454group = StyleDoc . P.group . unStyleDoc
455