diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 1.1.1 + +- Expose `AnsiStyle`’s constructors for adaptability + # 1.1 - Overhauled the API significantly – Styles are now combined using the diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md deleted file mode 100644 --- a/CONTRIBUTORS.md +++ /dev/null @@ -1,22 +0,0 @@ -# Contributors - -A list of people that have contributed to this library, be it code, ideas, or -even just as rubber ducks. :-) - -Ordered by earliest appearance in the git log. - -## `prettyprinter` library (this one) - -- David Luposchainsky, @quchen – current maintainer - -## `ansi-wl-pprint` (origin forked from) - -- Edward Kmett, @edwardk – maintainer of `ansi-wl-pprint` -- Herbert Valerio Riedel, @hvr -- Bradford Larsen -- Sebastian Witte -- Andrew Shulaev -- David Fox -- Max Bolingbroke -- Samir Jindel -- Bryan O'Sullivan, @bos diff --git a/prettyprinter-ansi-terminal.cabal b/prettyprinter-ansi-terminal.cabal --- a/prettyprinter-ansi-terminal.cabal +++ b/prettyprinter-ansi-terminal.cabal @@ -1,5 +1,5 @@ name: prettyprinter-ansi-terminal -version: 1.1 +version: 1.1.1 cabal-version: >= 1.10 category: User Interfaces, Text synopsis: ANSI terminal backend for the »prettyprinter« package. @@ -8,7 +8,6 @@ license-file: LICENSE.md extra-source-files: README.md , misc/version-compatibility-macros.h - , CONTRIBUTORS.md , CHANGELOG.md author: David Luposchainsky maintainer: David Luposchainsky @@ -23,6 +22,7 @@ library exposed-modules: Data.Text.Prettyprint.Doc.Render.Terminal + , Data.Text.Prettyprint.Doc.Render.Terminal.Internal ghc-options: -Wall hs-source-dirs: src include-dirs: misc @@ -35,14 +35,14 @@ build-depends: base >= 4.7 && < 5 - , ansi-terminal >= 0.4.0 && < 0.7 - , text == 1.2.* - , prettyprinter < 1.2 + , ansi-terminal >= 0.4.0 + , text >= 1.2 + , prettyprinter >= 1 if impl(ghc >= 8.0) ghc-options: -Wcompat if impl(ghc < 8.0) - build-depends: semigroups >= 0.1 && < 0.19 + build-depends: semigroups >= 0.1 test-suite doctest type: exitcode-stdio-1.0 diff --git a/src/Data/Text/Prettyprint/Doc/Render/Terminal.hs b/src/Data/Text/Prettyprint/Doc/Render/Terminal.hs --- a/src/Data/Text/Prettyprint/Doc/Render/Terminal.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/Terminal.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -#include "version-compatibility-macros.h" - -- | Render 'SimpleDocStream' in a terminal. module Data.Text.Prettyprint.Doc.Render.Terminal ( -- * Styling @@ -19,6 +13,15 @@ -- ** Font style bold, italicized, underlined, + -- ** Internal markers + -- + -- | These should only be used for writing adaptors to other libraries; for + -- the average use case, use 'bold', 'bgColorDull', etc. + Intensity(..), + Bold(..), + Underlined(..), + Italicized(..), + -- * Conversion to ANSI-infused 'Text' renderLazy, renderStrict, @@ -29,245 +32,4 @@ putDoc, hPutDoc, ) where - - -import Control.Applicative -import Data.Maybe -import Data.Semigroup -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB -import qualified Data.Text.Lazy.IO as TL -import qualified System.Console.ANSI as ANSI -import System.IO (Handle, stdout) - -import Data.Text.Prettyprint.Doc -import Data.Text.Prettyprint.Doc.Render.Util.Panic -import Data.Text.Prettyprint.Doc.Render.Util.StackMachine - -#if !(APPLICATIVE_MONAD) -import Control.Applicative -#endif - - - --- $setup --- --- (Definitions for the doctests) --- --- >>> :set -XOverloadedStrings --- >>> import qualified Data.Text.Lazy.IO as TL --- >>> import qualified Data.Text.Lazy as TL --- >>> import Data.Text.Prettyprint.Doc.Render.Terminal - - - --- | The 8 ANSI terminal colors. -data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White - deriving (Eq, Ord, Show) - --- | Dull or vivid coloring, as supported by ANSI terminals. -data Intensity = Vivid | Dull - deriving (Eq, Ord, Show) - --- | Foreground (text) or background (paper) color -data Layer = Foreground | Background - deriving (Eq, Ord, Show) - -data Bold = Bold deriving (Eq, Ord, Show) -data Underlined = Underlined deriving (Eq, Ord, Show) -data Italicized = Italicized deriving (Eq, Ord, Show) - --- | Style the foreground with a vivid color. -color :: Color -> AnsiStyle -color c = mempty { ansiForeground = Just (Vivid, c) } - --- | Style the background with a vivid color. -bgColor :: Color -> AnsiStyle -bgColor c = mempty { ansiBackground = Just (Vivid, c) } - --- | Style the foreground with a dull color. -colorDull :: Color -> AnsiStyle -colorDull c = mempty { ansiForeground = Just (Dull, c) } - --- | Style the background with a dull color. -bgColorDull :: Color -> AnsiStyle -bgColorDull c = mempty { ansiBackground = Just (Dull, c) } - --- | Render in __bold__. -bold :: AnsiStyle -bold = mempty { ansiBold = Just Bold } - --- | Render in /italics/. -italicized :: AnsiStyle -italicized = mempty { ansiItalics = Just Italicized } - --- | Render underlined. -underlined :: AnsiStyle -underlined = mempty { ansiUnderlining = Just Underlined } - - - --- | @('renderLazy' doc)@ takes the output @doc@ from a rendering function --- and transforms it to lazy text, including ANSI styling directives for things --- like colorization. --- --- ANSI color information will be discarded by this function unless you are --- running on a Unix-like operating system. This is due to a technical --- limitation in Windows ANSI support. --- --- With a bit of trickery to make the ANSI codes printable, here is an example --- that would render colored in an ANSI terminal: --- --- >>> let render = TL.putStrLn . TL.replace "\ESC" "\\e" . renderLazy . layoutPretty defaultLayoutOptions --- >>> let doc = annotate (color Red) ("red" <+> align (vsep [annotate (color Blue <> underlined) ("blue+u" <+> annotate bold "bold" <+> "blue+u"), "red"])) --- >>> render (unAnnotate doc) --- red blue+u bold blue+u --- red --- >>> render doc --- \e[0;91mred \e[0;94;4mblue+u \e[0;94;1;4mbold\e[0;94;4m blue+u\e[0;91m --- red\e[0m --- --- Run the above via @echo -e '...'@ in your terminal to see the coloring. -renderLazy :: SimpleDocStream AnsiStyle -> TL.Text -renderLazy doc - = let (resultBuilder, remainingStyles) = execStackMachine [mempty] (build doc) - in case remainingStyles of - [] -> error ("There is no empty style left at the end of rendering" ++ - " (but there should be). Please report this as a bug.") - [_] -> TLB.toLazyText resultBuilder - xs -> error ("There are " <> show (length xs) <> " styles left at the" ++ - "end of rendering (there should be only 1). Please report" ++ - " this as a bug.") - -build :: SimpleDocStream AnsiStyle -> StackMachine TLB.Builder AnsiStyle () -build = \case - SFail -> panicUncaughtFail - SEmpty -> pure () - SChar c x -> do - writeOutput (TLB.singleton c) - build x - SText _l t x -> do - writeOutput (TLB.fromText t) - build x - SLine i x -> do - writeOutput (TLB.singleton '\n') - writeOutput (TLB.fromText (T.replicate i " ")) - build x - SAnnPush s x -> do - currentStyle <- unsafePeekStyle - let newStyle = s <> currentStyle - writeOutput (styleToRaw newStyle) - pushStyle newStyle - build x - SAnnPop x -> do - _currentStyle <- unsafePopStyle - newStyle <- unsafePeekStyle - writeOutput (styleToRaw newStyle) - build x - --- | Begin rendering in a certain style. Instead of using this type directly, --- use the 'Semigroup' instance to create new styles out of the smart --- constructors, such as --- --- @ --- style = 'color' 'Green' '<>' 'bold' --- styledDoc = 'annotate' style "hello world" --- @ -data AnsiStyle = SetAnsiStyle - { ansiForeground :: Maybe (Intensity, Color) - , ansiBackground :: Maybe (Intensity, Color) - , ansiBold :: Maybe Bold - , ansiItalics :: Maybe Italicized - , ansiUnderlining :: Maybe Underlined } - deriving (Eq, Ord, Show) - --- | Keep the first decision for each of foreground color, background color, --- boldness, italication, and underlining. --- --- Example: --- --- @ --- 'color' 'Red' '<>' 'color' 'Green' --- @ --- --- is red. -instance Semigroup AnsiStyle where - cs1 <> cs2 = SetAnsiStyle - { ansiForeground = ansiForeground cs1 <|> ansiForeground cs2 - , ansiBackground = ansiBackground cs1 <|> ansiBackground cs2 - , ansiBold = ansiBold cs1 <|> ansiBold cs2 - , ansiItalics = ansiItalics cs1 <|> ansiItalics cs2 - , ansiUnderlining = ansiUnderlining cs1 <|> ansiUnderlining cs2 } - -instance Monoid AnsiStyle where - mempty = SetAnsiStyle Nothing Nothing Nothing Nothing Nothing - mappend = (<>) - -styleToRaw :: AnsiStyle -> TLB.Builder -styleToRaw = TLB.fromString . ANSI.setSGRCode . stylesToSgrs - where - stylesToSgrs :: AnsiStyle -> [ANSI.SGR] - stylesToSgrs (SetAnsiStyle fg bg b i u) = catMaybes - [ Just ANSI.Reset - , fmap (\(intensity, c) -> ANSI.SetColor ANSI.Foreground (convertIntensity intensity) (convertColor c)) fg - , fmap (\(intensity, c) -> ANSI.SetColor ANSI.Background (convertIntensity intensity) (convertColor c)) bg - , fmap (\_ -> ANSI.SetConsoleIntensity ANSI.BoldIntensity) b - , fmap (\_ -> ANSI.SetItalicized True) i - , fmap (\_ -> ANSI.SetUnderlining ANSI.SingleUnderline) u - ] - - convertIntensity :: Intensity -> ANSI.ColorIntensity - convertIntensity = \case - Vivid -> ANSI.Vivid - Dull -> ANSI.Dull - - convertColor :: Color -> ANSI.Color - convertColor = \case - Black -> ANSI.Black - Red -> ANSI.Red - Green -> ANSI.Green - Yellow -> ANSI.Yellow - Blue -> ANSI.Blue - Magenta -> ANSI.Magenta - Cyan -> ANSI.Cyan - White -> ANSI.White - - - --- | @('renderStrict' sdoc)@ takes the output @sdoc@ from a rendering and --- transforms it to strict text. -renderStrict :: SimpleDocStream AnsiStyle -> Text -renderStrict = TL.toStrict . renderLazy - --- | @('renderIO' h sdoc)@ writes @sdoc@ to the file @h@. --- --- >>> renderIO System.IO.stdout (layoutPretty defaultLayoutOptions "hello\nworld") --- hello --- world -renderIO :: Handle -> SimpleDocStream AnsiStyle -> IO () -renderIO h sdoc = TL.hPutStrLn h (renderLazy sdoc) - --- | @('putDoc' doc)@ prettyprints document @doc@ to standard output using --- 'defaultLayoutOptions'. --- --- >>> putDoc ("hello" <+> "world") --- hello world --- --- @ --- 'putDoc' = 'hPutDoc' 'stdout' --- @ -putDoc :: Doc AnsiStyle -> IO () -putDoc = hPutDoc stdout - --- | Like 'putDoc', but instead of using 'stdout', print to a user-provided --- handle, e.g. a file or a socket using 'defaultLayoutOptions'. --- --- > main = withFile "someFile.txt" (\h -> hPutDoc h (vcat ["vertical", "text"])) --- --- @ --- 'hPutDoc' h doc = 'renderIO' h ('layoutPretty' 'defaultLayoutOptions' doc) --- @ -hPutDoc :: Handle -> Doc AnsiStyle -> IO () -hPutDoc h doc = renderIO h (layoutPretty defaultLayoutOptions doc) +import Data.Text.Prettyprint.Doc.Render.Terminal.Internal diff --git a/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs b/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +#include "version-compatibility-macros.h" + +-- | __Warning:__ Internal module. May change arbitrarily between versions. +module Data.Text.Prettyprint.Doc.Render.Terminal.Internal where + + + +import Control.Applicative +import Data.Maybe +import Data.Semigroup +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Text.Lazy.IO as TL +import qualified System.Console.ANSI as ANSI +import System.IO (Handle, stdout) + +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Util.Panic +import Data.Text.Prettyprint.Doc.Render.Util.StackMachine + +#if !(APPLICATIVE_MONAD) +import Control.Applicative +#endif + + + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> :set -XOverloadedStrings +-- >>> import qualified Data.Text.Lazy.IO as TL +-- >>> import qualified Data.Text.Lazy as TL +-- >>> import Data.Text.Prettyprint.Doc.Render.Terminal + + + +-- | The 8 ANSI terminal colors. +data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White + deriving (Eq, Ord, Show) + +-- | Dull or vivid coloring, as supported by ANSI terminals. +data Intensity = Vivid | Dull + deriving (Eq, Ord, Show) + +-- | Foreground (text) or background (paper) color +data Layer = Foreground | Background + deriving (Eq, Ord, Show) + +data Bold = Bold deriving (Eq, Ord, Show) +data Underlined = Underlined deriving (Eq, Ord, Show) +data Italicized = Italicized deriving (Eq, Ord, Show) + +-- | Style the foreground with a vivid color. +color :: Color -> AnsiStyle +color c = mempty { ansiForeground = Just (Vivid, c) } + +-- | Style the background with a vivid color. +bgColor :: Color -> AnsiStyle +bgColor c = mempty { ansiBackground = Just (Vivid, c) } + +-- | Style the foreground with a dull color. +colorDull :: Color -> AnsiStyle +colorDull c = mempty { ansiForeground = Just (Dull, c) } + +-- | Style the background with a dull color. +bgColorDull :: Color -> AnsiStyle +bgColorDull c = mempty { ansiBackground = Just (Dull, c) } + +-- | Render in __bold__. +bold :: AnsiStyle +bold = mempty { ansiBold = Just Bold } + +-- | Render in /italics/. +italicized :: AnsiStyle +italicized = mempty { ansiItalics = Just Italicized } + +-- | Render underlined. +underlined :: AnsiStyle +underlined = mempty { ansiUnderlining = Just Underlined } + + + +-- | @('renderLazy' doc)@ takes the output @doc@ from a rendering function +-- and transforms it to lazy text, including ANSI styling directives for things +-- like colorization. +-- +-- ANSI color information will be discarded by this function unless you are +-- running on a Unix-like operating system. This is due to a technical +-- limitation in Windows ANSI support. +-- +-- With a bit of trickery to make the ANSI codes printable, here is an example +-- that would render colored in an ANSI terminal: +-- +-- >>> let render = TL.putStrLn . TL.replace "\ESC" "\\e" . renderLazy . layoutPretty defaultLayoutOptions +-- >>> let doc = annotate (color Red) ("red" <+> align (vsep [annotate (color Blue <> underlined) ("blue+u" <+> annotate bold "bold" <+> "blue+u"), "red"])) +-- >>> render (unAnnotate doc) +-- red blue+u bold blue+u +-- red +-- >>> render doc +-- \e[0;91mred \e[0;94;4mblue+u \e[0;94;1;4mbold\e[0;94;4m blue+u\e[0;91m +-- red\e[0m +-- +-- Run the above via @echo -e '...'@ in your terminal to see the coloring. +renderLazy :: SimpleDocStream AnsiStyle -> TL.Text +renderLazy doc + = let (resultBuilder, remainingStyles) = execStackMachine [mempty] (build doc) + in case remainingStyles of + [] -> error ("There is no empty style left at the end of rendering" ++ + " (but there should be). Please report this as a bug.") + [_] -> TLB.toLazyText resultBuilder + xs -> error ("There are " <> show (length xs) <> " styles left at the" ++ + "end of rendering (there should be only 1). Please report" ++ + " this as a bug.") + +build :: SimpleDocStream AnsiStyle -> StackMachine TLB.Builder AnsiStyle () +build = \case + SFail -> panicUncaughtFail + SEmpty -> pure () + SChar c x -> do + writeOutput (TLB.singleton c) + build x + SText _l t x -> do + writeOutput (TLB.fromText t) + build x + SLine i x -> do + writeOutput (TLB.singleton '\n') + writeOutput (TLB.fromText (T.replicate i " ")) + build x + SAnnPush s x -> do + currentStyle <- unsafePeekStyle + let newStyle = s <> currentStyle + writeOutput (styleToRaw newStyle) + pushStyle newStyle + build x + SAnnPop x -> do + _currentStyle <- unsafePopStyle + newStyle <- unsafePeekStyle + writeOutput (styleToRaw newStyle) + build x + +-- | Begin rendering in a certain style. Instead of using this type directly, +-- consider using the 'Semigroup' instance to create new styles out of the smart +-- constructors, such as +-- +-- @ +-- style = 'color' 'Green' '<>' 'bold' +-- styledDoc = 'annotate' style "hello world" +-- @ +data AnsiStyle = SetAnsiStyle + { ansiForeground :: Maybe (Intensity, Color) -- ^ Set the foreground color, or keep the old one. + , ansiBackground :: Maybe (Intensity, Color) -- ^ Set the background color, or keep the old one. + , ansiBold :: Maybe Bold -- ^ Switch on boldness, or don’t do anything. + , ansiItalics :: Maybe Italicized -- ^ Switch on italics, or don’t do anything. + , ansiUnderlining :: Maybe Underlined -- ^ Switch on underlining, or don’t do anything. + } deriving (Eq, Ord, Show) + +-- | Keep the first decision for each of foreground color, background color, +-- boldness, italication, and underlining. +-- +-- Example: +-- +-- @ +-- 'color' 'Red' '<>' 'color' 'Green' +-- @ +-- +-- is red. +instance Semigroup AnsiStyle where + cs1 <> cs2 = SetAnsiStyle + { ansiForeground = ansiForeground cs1 <|> ansiForeground cs2 + , ansiBackground = ansiBackground cs1 <|> ansiBackground cs2 + , ansiBold = ansiBold cs1 <|> ansiBold cs2 + , ansiItalics = ansiItalics cs1 <|> ansiItalics cs2 + , ansiUnderlining = ansiUnderlining cs1 <|> ansiUnderlining cs2 } + +instance Monoid AnsiStyle where + mempty = SetAnsiStyle Nothing Nothing Nothing Nothing Nothing + mappend = (<>) + +styleToRaw :: AnsiStyle -> TLB.Builder +styleToRaw = TLB.fromString . ANSI.setSGRCode . stylesToSgrs + where + stylesToSgrs :: AnsiStyle -> [ANSI.SGR] + stylesToSgrs (SetAnsiStyle fg bg b i u) = catMaybes + [ Just ANSI.Reset + , fmap (\(intensity, c) -> ANSI.SetColor ANSI.Foreground (convertIntensity intensity) (convertColor c)) fg + , fmap (\(intensity, c) -> ANSI.SetColor ANSI.Background (convertIntensity intensity) (convertColor c)) bg + , fmap (\_ -> ANSI.SetConsoleIntensity ANSI.BoldIntensity) b + , fmap (\_ -> ANSI.SetItalicized True) i + , fmap (\_ -> ANSI.SetUnderlining ANSI.SingleUnderline) u + ] + + convertIntensity :: Intensity -> ANSI.ColorIntensity + convertIntensity = \case + Vivid -> ANSI.Vivid + Dull -> ANSI.Dull + + convertColor :: Color -> ANSI.Color + convertColor = \case + Black -> ANSI.Black + Red -> ANSI.Red + Green -> ANSI.Green + Yellow -> ANSI.Yellow + Blue -> ANSI.Blue + Magenta -> ANSI.Magenta + Cyan -> ANSI.Cyan + White -> ANSI.White + + + +-- | @('renderStrict' sdoc)@ takes the output @sdoc@ from a rendering and +-- transforms it to strict text. +renderStrict :: SimpleDocStream AnsiStyle -> Text +renderStrict = TL.toStrict . renderLazy + +-- | @('renderIO' h sdoc)@ writes @sdoc@ to the file @h@. +-- +-- >>> renderIO System.IO.stdout (layoutPretty defaultLayoutOptions "hello\nworld") +-- hello +-- world +renderIO :: Handle -> SimpleDocStream AnsiStyle -> IO () +renderIO h sdoc = TL.hPutStrLn h (renderLazy sdoc) + +-- | @('putDoc' doc)@ prettyprints document @doc@ to standard output using +-- 'defaultLayoutOptions'. +-- +-- >>> putDoc ("hello" <+> "world") +-- hello world +-- +-- @ +-- 'putDoc' = 'hPutDoc' 'stdout' +-- @ +putDoc :: Doc AnsiStyle -> IO () +putDoc = hPutDoc stdout + +-- | Like 'putDoc', but instead of using 'stdout', print to a user-provided +-- handle, e.g. a file or a socket using 'defaultLayoutOptions'. +-- +-- > main = withFile "someFile.txt" (\h -> hPutDoc h (vcat ["vertical", "text"])) +-- +-- @ +-- 'hPutDoc' h doc = 'renderIO' h ('layoutPretty' 'defaultLayoutOptions' doc) +-- @ +hPutDoc :: Handle -> Doc AnsiStyle -> IO () +hPutDoc h doc = renderIO h (layoutPretty defaultLayoutOptions doc)