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