1{-# LANGUAGE CPP #-} 2{-# LANGUAGE OverloadedStrings #-} 3 4{-# OPTIONS_HADDOCK not-home #-} 5 6#include "version-compatibility-macros.h" 7 8-- | __Warning:__ Internal module. May change arbitrarily between versions. 9module Prettyprinter.Render.Terminal.Internal ( 10 -- * Styling 11 AnsiStyle(..), 12 Color(..), 13 14 -- ** Font color 15 color, colorDull, 16 17 -- ** Background color 18 bgColor, bgColorDull, 19 20 -- ** Font style 21 bold, italicized, underlined, 22 23 -- ** Internal markers 24 Intensity(..), 25 Bold(..), 26 Underlined(..), 27 Italicized(..), 28 29 -- * Conversion to ANSI-infused 'Text' 30 renderLazy, renderStrict, 31 32 -- * Render directly to 'stdout' 33 renderIO, 34 35 -- ** Convenience functions 36 putDoc, hPutDoc, 37) where 38 39 40 41import Control.Applicative 42import Data.IORef 43import Data.Maybe 44import Data.Text (Text) 45import qualified Data.Text as T 46import qualified Data.Text.IO as T 47import qualified Data.Text.Lazy as TL 48import qualified Data.Text.Lazy.Builder as TLB 49import qualified System.Console.ANSI as ANSI 50import System.IO (Handle, hPutChar, stdout) 51 52import Data.Text.Prettyprint.Doc 53import Data.Text.Prettyprint.Doc.Render.Util.Panic 54 55#if !(SEMIGROUP_MONOID_SUPERCLASS) 56import Data.Semigroup 57#endif 58 59#if !(MIN_VERSION_base(4,6,0)) 60modifyIORef' :: IORef a -> (a -> a) -> IO () 61modifyIORef' ref f = do 62 x <- readIORef ref 63 let x' = f x 64 x' `seq` writeIORef ref x' 65#endif 66 67-- $setup 68-- 69-- (Definitions for the doctests) 70-- 71-- >>> :set -XOverloadedStrings 72-- >>> import qualified Data.Text.Lazy.IO as TL 73-- >>> import qualified Data.Text.Lazy as TL 74-- >>> import Prettyprinter.Render.Terminal 75 76 77 78-- | The 8 ANSI terminal colors. 79data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White 80 deriving (Eq, Ord, Show) 81 82-- | Dull or vivid coloring, as supported by ANSI terminals. 83data Intensity = Vivid | Dull 84 deriving (Eq, Ord, Show) 85 86-- | Foreground (text) or background (paper) color 87data Layer = Foreground | Background 88 deriving (Eq, Ord, Show) 89 90data Bold = Bold deriving (Eq, Ord, Show) 91data Underlined = Underlined deriving (Eq, Ord, Show) 92data Italicized = Italicized deriving (Eq, Ord, Show) 93 94-- | Style the foreground with a vivid color. 95color :: Color -> AnsiStyle 96color c = mempty { ansiForeground = Just (Vivid, c) } 97 98-- | Style the background with a vivid color. 99bgColor :: Color -> AnsiStyle 100bgColor c = mempty { ansiBackground = Just (Vivid, c) } 101 102-- | Style the foreground with a dull color. 103colorDull :: Color -> AnsiStyle 104colorDull c = mempty { ansiForeground = Just (Dull, c) } 105 106-- | Style the background with a dull color. 107bgColorDull :: Color -> AnsiStyle 108bgColorDull c = mempty { ansiBackground = Just (Dull, c) } 109 110-- | Render in __bold__. 111bold :: AnsiStyle 112bold = mempty { ansiBold = Just Bold } 113 114-- | Render in /italics/. 115italicized :: AnsiStyle 116italicized = mempty { ansiItalics = Just Italicized } 117 118-- | Render underlined. 119underlined :: AnsiStyle 120underlined = mempty { ansiUnderlining = Just Underlined } 121 122-- | @('renderLazy' doc)@ takes the output @doc@ from a rendering function 123-- and transforms it to lazy text, including ANSI styling directives for things 124-- like colorization. 125-- 126-- ANSI color information will be discarded by this function unless you are 127-- running on a Unix-like operating system. This is due to a technical 128-- limitation in Windows ANSI support. 129-- 130-- With a bit of trickery to make the ANSI codes printable, here is an example 131-- that would render colored in an ANSI terminal: 132-- 133-- >>> let render = TL.putStrLn . TL.replace "\ESC" "\\e" . renderLazy . layoutPretty defaultLayoutOptions 134-- >>> let doc = annotate (color Red) ("red" <+> align (vsep [annotate (color Blue <> underlined) ("blue+u" <+> annotate bold "bold" <+> "blue+u"), "red"])) 135-- >>> render (unAnnotate doc) 136-- red blue+u bold blue+u 137-- red 138-- >>> render doc 139-- \e[0;91mred \e[0;94;4mblue+u \e[0;94;1;4mbold\e[0;94;4m blue+u\e[0;91m 140-- red\e[0m 141-- 142-- Run the above via @echo -e '...'@ in your terminal to see the coloring. 143renderLazy :: SimpleDocStream AnsiStyle -> TL.Text 144renderLazy = 145 let push x = (x :) 146 147 unsafePeek [] = panicPeekedEmpty 148 unsafePeek (x:_) = x 149 150 unsafePop [] = panicPoppedEmpty 151 unsafePop (x:xs) = (x, xs) 152 153 go :: [AnsiStyle] -> SimpleDocStream AnsiStyle -> TLB.Builder 154 go s sds = case sds of 155 SFail -> panicUncaughtFail 156 SEmpty -> mempty 157 SChar c rest -> TLB.singleton c <> go s rest 158 SText _ t rest -> TLB.fromText t <> go s rest 159 SLine i rest -> TLB.singleton '\n' <> TLB.fromText (T.replicate i " ") <> go s rest 160 SAnnPush style rest -> 161 let currentStyle = unsafePeek s 162 newStyle = style <> currentStyle 163 in TLB.fromText (styleToRawText newStyle) <> go (push style s) rest 164 SAnnPop rest -> 165 let (_currentStyle, s') = unsafePop s 166 newStyle = unsafePeek s' 167 in TLB.fromText (styleToRawText newStyle) <> go s' rest 168 169 in TLB.toLazyText . go [mempty] 170 171 172-- | @('renderIO' h sdoc)@ writes @sdoc@ to the handle @h@. 173-- 174-- >>> let render = renderIO System.IO.stdout . layoutPretty defaultLayoutOptions 175-- >>> let doc = annotate (color Red) ("red" <+> align (vsep [annotate (color Blue <> underlined) ("blue+u" <+> annotate bold "bold" <+> "blue+u"), "red"])) 176-- 177-- We render the 'unAnnotate'd version here, since the ANSI codes don’t display 178-- well in Haddock, 179-- 180-- >>> render (unAnnotate doc) 181-- red blue+u bold blue+u 182-- red 183-- 184-- This function behaves just like 185-- 186-- @ 187-- 'renderIO' h sdoc = 'TL.hPutStr' h ('renderLazy' sdoc) 188-- @ 189-- 190-- but will not generate any intermediate text, rendering directly to the 191-- handle. 192renderIO :: Handle -> SimpleDocStream AnsiStyle -> IO () 193renderIO h sdoc = do 194 styleStackRef <- newIORef [mempty] 195 196 let push x = modifyIORef' styleStackRef (x :) 197 unsafePeek = readIORef styleStackRef >>= \tok -> case tok of 198 [] -> panicPeekedEmpty 199 x:_ -> pure x 200 unsafePop = readIORef styleStackRef >>= \tok -> case tok of 201 [] -> panicPoppedEmpty 202 x:xs -> writeIORef styleStackRef xs >> pure x 203 204 let go = \sds -> case sds of 205 SFail -> panicUncaughtFail 206 SEmpty -> pure () 207 SChar c rest -> do 208 hPutChar h c 209 go rest 210 SText _ t rest -> do 211 T.hPutStr h t 212 go rest 213 SLine i rest -> do 214 hPutChar h '\n' 215 T.hPutStr h (T.replicate i (T.singleton ' ')) 216 go rest 217 SAnnPush style rest -> do 218 currentStyle <- unsafePeek 219 let newStyle = style <> currentStyle 220 push newStyle 221 T.hPutStr h (styleToRawText newStyle) 222 go rest 223 SAnnPop rest -> do 224 _currentStyle <- unsafePop 225 newStyle <- unsafePeek 226 T.hPutStr h (styleToRawText newStyle) 227 go rest 228 go sdoc 229 readIORef styleStackRef >>= \stack -> case stack of 230 [] -> panicStyleStackFullyConsumed 231 [_] -> pure () 232 xs -> panicStyleStackNotFullyConsumed (length xs) 233 234panicStyleStackFullyConsumed :: void 235panicStyleStackFullyConsumed 236 = error ("There is no empty style left at the end of rendering" ++ 237 " (but there should be). Please report this as a bug.") 238 239panicStyleStackNotFullyConsumed :: Int -> void 240panicStyleStackNotFullyConsumed len 241 = error ("There are " <> show len <> " styles left at the" ++ 242 "end of rendering (there should be only 1). Please report" ++ 243 " this as a bug.") 244 245-- $ 246-- >>> let render = renderIO System.IO.stdout . layoutPretty defaultLayoutOptions 247-- >>> let doc = annotate (color Red) ("red" <+> align (vsep [annotate (color Blue <> underlined) ("blue+u" <+> annotate bold "bold" <+> "blue+u"), "red"])) 248-- >>> render (unAnnotate doc) 249-- red blue+u bold blue+u 250-- red 251-- 252-- This test won’t work since I don’t know how to type \ESC for doctest :-/ 253-- -- >>> render doc 254-- -- \ESC[0;91mred \ESC[0;94;4mblue+u \ESC[0;94;1;4mbold\ESC[0;94;4m blue+u\ESC[0;91m 255-- -- red\ESC[0m 256 257-- | Render the annotated document in a certain style. Styles not set in the 258-- annotation will use the style of the surrounding document, or the terminal’s 259-- default if none has been set yet. 260-- 261-- @ 262-- style = 'color' 'Green' '<>' 'bold' 263-- styledDoc = 'annotate' style "hello world" 264-- @ 265data AnsiStyle = SetAnsiStyle 266 { ansiForeground :: Maybe (Intensity, Color) -- ^ Set the foreground color, or keep the old one. 267 , ansiBackground :: Maybe (Intensity, Color) -- ^ Set the background color, or keep the old one. 268 , ansiBold :: Maybe Bold -- ^ Switch on boldness, or don’t do anything. 269 , ansiItalics :: Maybe Italicized -- ^ Switch on italics, or don’t do anything. 270 , ansiUnderlining :: Maybe Underlined -- ^ Switch on underlining, or don’t do anything. 271 } deriving (Eq, Ord, Show) 272 273-- | Keep the first decision for each of foreground color, background color, 274-- boldness, italication, and underlining. If a certain style is not set, the 275-- terminal’s default will be used. 276-- 277-- Example: 278-- 279-- @ 280-- 'color' 'Red' '<>' 'color' 'Green' 281-- @ 282-- 283-- is red because the first color wins, and not bold because (or if) that’s the 284-- terminal’s default. 285instance Semigroup AnsiStyle where 286 cs1 <> cs2 = SetAnsiStyle 287 { ansiForeground = ansiForeground cs1 <|> ansiForeground cs2 288 , ansiBackground = ansiBackground cs1 <|> ansiBackground cs2 289 , ansiBold = ansiBold cs1 <|> ansiBold cs2 290 , ansiItalics = ansiItalics cs1 <|> ansiItalics cs2 291 , ansiUnderlining = ansiUnderlining cs1 <|> ansiUnderlining cs2 } 292 293-- | 'mempty' does nothing, which is equivalent to inheriting the style of the 294-- surrounding doc, or the terminal’s default if no style has been set yet. 295instance Monoid AnsiStyle where 296 mempty = SetAnsiStyle Nothing Nothing Nothing Nothing Nothing 297 mappend = (<>) 298 299styleToRawText :: AnsiStyle -> Text 300styleToRawText = T.pack . ANSI.setSGRCode . stylesToSgrs 301 where 302 stylesToSgrs :: AnsiStyle -> [ANSI.SGR] 303 stylesToSgrs (SetAnsiStyle fg bg b i u) = catMaybes 304 [ Just ANSI.Reset 305 , fmap (\(intensity, c) -> ANSI.SetColor ANSI.Foreground (convertIntensity intensity) (convertColor c)) fg 306 , fmap (\(intensity, c) -> ANSI.SetColor ANSI.Background (convertIntensity intensity) (convertColor c)) bg 307 , fmap (\_ -> ANSI.SetConsoleIntensity ANSI.BoldIntensity) b 308 , fmap (\_ -> ANSI.SetItalicized True) i 309 , fmap (\_ -> ANSI.SetUnderlining ANSI.SingleUnderline) u 310 ] 311 312 convertIntensity :: Intensity -> ANSI.ColorIntensity 313 convertIntensity = \i -> case i of 314 Vivid -> ANSI.Vivid 315 Dull -> ANSI.Dull 316 317 convertColor :: Color -> ANSI.Color 318 convertColor = \c -> case c of 319 Black -> ANSI.Black 320 Red -> ANSI.Red 321 Green -> ANSI.Green 322 Yellow -> ANSI.Yellow 323 Blue -> ANSI.Blue 324 Magenta -> ANSI.Magenta 325 Cyan -> ANSI.Cyan 326 White -> ANSI.White 327 328 329 330-- | @('renderStrict' sdoc)@ takes the output @sdoc@ from a rendering and 331-- transforms it to strict text. 332renderStrict :: SimpleDocStream AnsiStyle -> Text 333renderStrict = TL.toStrict . renderLazy 334 335-- | @('putDoc' doc)@ prettyprints document @doc@ to standard output using 336-- 'defaultLayoutOptions'. 337-- 338-- >>> putDoc ("hello" <+> "world") 339-- hello world 340-- 341-- @ 342-- 'putDoc' = 'hPutDoc' 'stdout' 343-- @ 344putDoc :: Doc AnsiStyle -> IO () 345putDoc = hPutDoc stdout 346 347-- | Like 'putDoc', but instead of using 'stdout', print to a user-provided 348-- handle, e.g. a file or a socket using 'defaultLayoutOptions'. 349-- 350-- > main = withFile "someFile.txt" (\h -> hPutDoc h (vcat ["vertical", "text"])) 351-- 352-- @ 353-- 'hPutDoc' h doc = 'renderIO' h ('layoutPretty' 'defaultLayoutOptions' doc) 354-- @ 355hPutDoc :: Handle -> Doc AnsiStyle -> IO () 356hPutDoc h doc = renderIO h (layoutPretty defaultLayoutOptions doc) 357