diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,35 @@ +# [1.1.4] – April 2026 + +- [Add `text` flag](https://github.com/quchen/prettyprinter/pull/279) +- [Fix inconsistency between `renderLazy`/`renderIO`](https://github.com/quchen/prettyprinter/pull/261) +- [Drop support for GHC 7](https://github.com/quchen/prettyprinter/pull/278) +- [Remove compatibility code for GHC < 8](https://github.com/quchen/prettyprinter/pull/285) +- [Make it compile with MicroHs](https://github.com/quchen/prettyprinter/pull/270) + +[1.1.4]: https://github.com/quchen/prettyprinter/compare/ansi-terminal-v1.1.3...ansi-terminal-v1.1.4 + +# [1.1.3] + +- [Deprecate the `Data.Text.Prettyprint.*` modules](https://github.com/quchen/prettyprinter/pull/203) + * Users should migrate to the new `Prettyprinter` module hierarchy. + * The old modules will be removed no sooner than September 2022. + +[1.1.3]: https://github.com/quchen/prettyprinter/compare/ansi-terminal-v1.1.2...ansi-terminal-v1.1.3 + +# [1.1.2] + +- [Add shallower `Prettyprinter` module hierarchy exposing the same API.](https://github.com/quchen/prettyprinter/pull/174) + * The current plan for the existing `Data.Text.Prettyprint.Doc*` modules is: + * Start deprecation in early 2021. + * Remove the modules after a deprecation period of at least one year. +- [Make `renderLazy` lazy, and speed it up.](https://github.com/quchen/prettyprinter/pull/176) +- [Add export list for Prettyprinter.Render.Terminal.Internal.](https://github.com/quchen/prettyprinter/pull/148) +- [Optimize generating spaces for indentation.](https://github.com/quchen/prettyprinter/pull/132) +- [Enable `-O2`.](https://github.com/quchen/prettyprinter/pull/144) +- [Extend GHC support to 7.6 and 7.4.](https://github.com/quchen/prettyprinter/pull/74) + +[1.1.2]: https://github.com/quchen/prettyprinter/compare/ansi-terminal-v1.1.1.2...ansi-terminal-v1.1.2 + # 1.1.1.2 - Fix documentation claiming there would be a trailing newline in `renderIO` diff --git a/bench/LargeOutput.hs b/bench/LargeOutput.hs new file mode 100644 --- /dev/null +++ b/bench/LargeOutput.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | This benchmark is derived from the large-output benchmark in prettyprinter, but contains additional annotations. +module Main (main) where + +import Prelude () +import Prelude.Compat + +import Control.DeepSeq +import Control.Monad.Compat +import Data.Char +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as TL +import GHC.Generics +import Prettyprinter +import Prettyprinter.Render.Terminal as Terminal +import qualified Prettyprinter.Render.Text as Text +import Test.QuickCheck +import Test.QuickCheck.Gen +import Test.QuickCheck.Random +import Test.Tasty.Bench + + + +newtype Program = Program Binds deriving (Show, Generic) +newtype Binds = Binds (Map Text LambdaForm) deriving (Show, Generic) +data LambdaForm = LambdaForm ![Text] ![Text] !Expr deriving (Show, Generic) +data Expr + = Let Binds Expr + | Case Expr [Alt] + | AppF Text [Text] + | AppC Text [Text] + | AppP Text Text Text + | LitE Int + deriving (Show, Generic) +data Alt = Alt Text [Text] Expr deriving (Show, Generic) + +instance NFData Program +instance NFData Binds +instance NFData LambdaForm +instance NFData Expr +instance NFData Alt + +instance Arbitrary Program where arbitrary = fmap Program arbitrary +instance Arbitrary Binds where + arbitrary = do + NonEmpty xs <- arbitrary + pure (Binds (M.fromList xs)) +instance Arbitrary LambdaForm where + arbitrary = LambdaForm <$> fromTo 0 2 arbitrary <*> fromTo 0 2 arbitrary <*> arbitrary + +instance Arbitrary Expr where + arbitrary = (oneof . map scaled) + [ Let <$> arbitrary <*> arbitrary + , Case <$> arbitrary <*> (do NonEmpty xs <- arbitrary; pure xs) + , AppF <$> arbitrary <*> fromTo 0 3 arbitrary + , AppC <$> ucFirst arbitrary <*> fromTo 0 3 arbitrary + , AppP <$> arbitrary <*> arbitrary <*> arbitrary + , LitE <$> arbitrary ] +instance Arbitrary Alt where arbitrary = Alt <$> ucFirst arbitrary <*> fromTo 0 3 arbitrary <*> arbitrary +instance Arbitrary Text where + arbitrary = do + n <- choose (3,6) + str <- replicateM n (elements ['a'..'z']) + if str `elem` ["let", "in", "case", "of"] + then arbitrary + else pure (T.pack str) + +ucFirst :: Gen Text -> Gen Text +ucFirst gen = do + x <- gen + case T.uncons x of + Nothing -> pure x + Just (t,ext) -> pure (T.cons (toUpper t) ext) + +anCol :: Color -> Doc AnsiStyle -> Doc AnsiStyle +anCol = annotate . color + +prettyProgram :: Program -> Doc AnsiStyle +prettyProgram (Program binds) = annotate italicized (prettyBinds binds) + +prettyBinds :: Binds -> Doc AnsiStyle +prettyBinds (Binds bs) = align (vsep (map prettyBinding (M.assocs bs))) + where + prettyBinding (var, lambda) = pretty var <+> anCol Red "=" <+> prettyLambdaForm lambda + +prettyLambdaForm :: LambdaForm -> Doc AnsiStyle +prettyLambdaForm (LambdaForm free bound body) = (prettyExp . (<+> anCol Blue "->") . prettyBound . prettyFree) (anCol Blue "\\") + where + prettyFree | null free = id + | otherwise = (<> anCol Blue lparen <> hsep (map pretty free) <> anCol Blue rparen) + prettyBound | null bound = id + | null free = (<> hsep (map pretty bound)) + | otherwise = (<+> hsep (map pretty bound)) + prettyExp = (<+> prettyExpr body) + +prettyExpr :: Expr -> Doc AnsiStyle +prettyExpr = \expr -> case expr of + Let binds body -> + align (vsep [ anCol Red "let" <+> align (prettyBinds binds) + , anCol Red "in" <+> prettyExpr body ]) + + Case scrutinee alts -> vsep + [ anCol Yellow "case" <+> prettyExpr scrutinee <+> anCol Yellow "of" + , indent 4 (align (vsep (map prettyAlt alts))) ] + + AppF f [] -> (annotate bold . anCol Green) (pretty f) + AppF f args -> (annotate bold . anCol Green) (pretty f) <+> hsep (map pretty args) + + AppC c [] -> (annotate bold . anCol Green) (pretty c) + AppC c args -> (annotate bold . anCol Green) (pretty c) <+> hsep (map pretty args) + + AppP op x y -> (annotate bold . anCol Green) (pretty op) <+> pretty x <+> pretty y + + LitE lit -> (annotate bold . anCol Green) (pretty lit) + +prettyAlt :: Alt -> Doc AnsiStyle +prettyAlt (Alt con [] body) = pretty con <+> anCol Yellow "->" <+> prettyExpr body +prettyAlt (Alt con args body) = pretty con <+> hsep (map pretty args) <+> anCol Yellow "->" <+> prettyExpr body + +scaled :: Gen a -> Gen a +scaled = scale (\n -> n * 2 `quot` 3) + +fromTo :: Int -> Int -> Gen b -> Gen b +fromTo a b gen = do + n <- choose (min a b, max a b) + resize n gen + +randomProgram + :: Int -- ^ Seed + -> Int -- ^ Generator size + -> Program +randomProgram seed size = let MkGen gen = arbitrary in gen (mkQCGen seed) size + +main :: IO () +main = do + let prog = randomProgram 1 60 + layoutOpts = defaultLayoutOptions { layoutPageWidth = Unbounded } + renderedProg = (renderLazy . layoutPretty layoutOpts . prettyProgram) prog + (progLines, progWidth) = let l = TL.lines renderedProg in (length l, maximum (map TL.length l)) + putDoc ("Program size:" <+> pretty progLines <+> "lines, maximum width:" <+> pretty progWidth) + + let render :: (SimpleDocStream AnsiStyle -> TL.Text) -> Program -> TL.Text + render r = r . layoutPretty layoutOpts . prettyProgram + + rnf prog `seq` T.putStrLn "Starting benchmark…" + + defaultMain + [ bench "prettyprinter-ansi-terminal" (nf (render Terminal.renderLazy) prog) + , bench "prettyprinter" (nf (render Text.renderLazy) prog) + ] diff --git a/misc/version-compatibility-macros.h b/misc/version-compatibility-macros.h --- a/misc/version-compatibility-macros.h +++ b/misc/version-compatibility-macros.h @@ -8,12 +8,12 @@ -- These macros allow writing CPP compatibility hacks in a way that makes their -- purpose much clearer than just demanding a specific version of a library. -#define APPLICATIVE_MONAD MIN_VERSION_base(4,8,0) -#define FOLDABLE_TRAVERSABLE_IN_PRELUDE MIN_VERSION_base(4,8,0) -#define MONOID_IN_PRELUDE MIN_VERSION_base(4,8,0) -#define NATURAL_IN_BASE MIN_VERSION_base(4,8,0) +#define FOLDABLE_TRAVERSABLE_IN_PRELUDE !defined(__MHS__) -#define SEMIGROUP_IN_BASE MIN_VERSION_base(4,9,0) -#define MONAD_FAIL MIN_VERSION_base(4,9,0) +#define LIFTA2_IN_PRELUDE MIN_VERSION_base(4,18,0) + +#define SEMIGROUP_MONOID_SUPERCLASS MIN_VERSION_base(4,11,0) + +#define FAIL_IN_MONAD !(MIN_VERSION_base(4,13,0)) #endif 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.1.2 +version: 1.1.4 cabal-version: >= 1.10 category: User Interfaces, Text synopsis: ANSI terminal backend for the »prettyprinter« package. @@ -10,49 +10,78 @@ , misc/version-compatibility-macros.h , CHANGELOG.md author: David Luposchainsky -maintainer: David Luposchainsky +maintainer: Simon Jakobi , David Luposchainsky bug-reports: http://github.com/quchen/prettyprinter/issues homepage: http://github.com/quchen/prettyprinter build-type: Simple -tested-with: GHC==7.8.4, GHC==7.10.2, GHC==7.10.3, GHC==8.0.1, GHC==8.0.2 +tested-with: GHC==9.14.1, GHC==9.12.2, GHC==9.10.3, GHC==9.8.4, GHC==9.6.7, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 source-repository head type: git - location: git://github.com/quchen/prettyprinter.git + location: https://github.com/quchen/prettyprinter +flag text + description: While it's a core value of @prettyprinter@ packages to use @Text@, there are rare + circumstances (mostly when @prettyprinter@ arises as a dependency of + test suites of packages like @bytestring@ or @text@ themselves) when + this is inconvenient. In this case one can disable this flag, so that + @prettyprinter-ansi-terminal@ fallbacks to @String@. + default: True + manual: True + library exposed-modules: Data.Text.Prettyprint.Doc.Render.Terminal , Data.Text.Prettyprint.Doc.Render.Terminal.Internal - ghc-options: -Wall + , Prettyprinter.Render.Terminal + , Prettyprinter.Render.Terminal.Internal + ghc-options: -Wall -O2 -Wcompat hs-source-dirs: src include-dirs: misc default-language: Haskell2010 other-extensions: CPP - , LambdaCase , OverloadedStrings build-depends: - base >= 4.7 && < 5 + base >= 4.9 && < 5 , ansi-terminal >= 0.4.0 - , text >= 1.2 - , prettyprinter >= 1.1.1 - - if impl(ghc >= 8.0) - ghc-options: -Wcompat - if !impl(ghc >= 8.0) - build-depends: semigroups >= 0.1 + , prettyprinter >= 1.7.0 + if flag(text) + build-depends: text >= 1.2 + else + -- A fake text package, emulating the same API, but backed by String + hs-source-dirs: src-text + other-modules: + Data.Text + , Data.Text.IO + , Data.Text.Lazy + , Data.Text.Lazy.Builder test-suite doctest type: exitcode-stdio-1.0 hs-source-dirs: test/Doctest main-is: Main.hs build-depends: - base >= 4.7 && < 5 + base >= 4.9 && < 5 , doctest >= 0.9 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 - if impl (ghc < 7.10) - buildable: False - -- Doctest cannot search folders in old versions it seems :-( + +benchmark large-output + build-depends: + base >= 4.9 && < 5 + , base-compat >=0.9.3 && <0.15 + , containers + , deepseq + , tasty-bench >= 0.2 + , prettyprinter + , prettyprinter-ansi-terminal + , QuickCheck >= 2.8 + , text + + hs-source-dirs: bench + main-is: LargeOutput.hs + ghc-options: -O2 -rtsopts -Wall + default-language: Haskell2010 + type: exitcode-stdio-1.0 diff --git a/src-text/Data/Text.hs b/src-text/Data/Text.hs new file mode 100644 --- /dev/null +++ b/src-text/Data/Text.hs @@ -0,0 +1,46 @@ +-- Provide a fake API, mimicking Data.Text from text package, +-- but actually backed by type Text = String. It is used only in rare +-- circumstances, when prettyprinter is built with -text flag. +-- + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Data.Text where + +import Prelude hiding (head, length, null, replicate) +import qualified Data.Char +import qualified Data.List + +type Text = String +cons = (:) +dropWhileEnd = Data.List.dropWhileEnd +head = Data.List.head +intercalate = Data.List.intercalate +length = Data.List.length :: [Char] -> Int +lines = Data.List.lines +map = Data.List.map +null = Data.List.null :: [Char] -> Bool +pack = id +replicate = (Data.List.concat .) . Data.List.replicate +singleton = (:[]) +snoc xs x = xs ++ [x] +stripEnd = dropWhileEnd Data.Char.isSpace +unlines = Data.List.unlines +unpack = id +words = Data.List.words + +uncons :: Text -> Maybe (Char, Text) +uncons [] = Nothing +uncons (x : xs) = Just (x, xs) + +splitOn :: Text -> Text -> [Text] +splitOn pat src + | null pat = error "splitOn: empty pattern" + | otherwise = go [] src + where + go acc [] = [reverse acc] + go acc xs@(y : ys) + | pat `Data.List.isPrefixOf` xs + = reverse acc : go [] (drop (length pat) xs) + | otherwise + = go (y : acc) ys diff --git a/src-text/Data/Text/IO.hs b/src-text/Data/Text/IO.hs new file mode 100644 --- /dev/null +++ b/src-text/Data/Text/IO.hs @@ -0,0 +1,13 @@ +-- Provide a fake API, mimicking Data.Text.IO from text package, +-- but actually backed by type Text = String. It is used only in rare +-- circumstances, when prettyprinter is built with -text flag. +-- + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Data.Text.IO where + +import qualified System.IO + +hPutStr = System.IO.hPutStr +putStrLn = System.IO.putStrLn diff --git a/src-text/Data/Text/Lazy.hs b/src-text/Data/Text/Lazy.hs new file mode 100644 --- /dev/null +++ b/src-text/Data/Text/Lazy.hs @@ -0,0 +1,15 @@ +-- Provide a fake API, mimicking Data.Text.Lazy from text package, +-- but actually backed by type Text = String. It is used only in rare +-- circumstances, when prettyprinter is built with -text flag. +-- + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Data.Text.Lazy where + +import Data.Text as T + +type Text = T.Text +length = T.length +lines = T.lines +toStrict = id diff --git a/src-text/Data/Text/Lazy/Builder.hs b/src-text/Data/Text/Lazy/Builder.hs new file mode 100644 --- /dev/null +++ b/src-text/Data/Text/Lazy/Builder.hs @@ -0,0 +1,13 @@ +-- Provide a fake API, mimicking Data.Text.Lazy.Builder from text package, +-- but actually backed by type Builder = String. It is used only in rare +-- circumstances, when prettyprinter is built with -text flag. +-- + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Data.Text.Lazy.Builder where + +type Builder = String +fromText = id +singleton = (:[]) +toLazyText = id 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,35 +1,6 @@ --- | Render 'SimpleDocStream' in a terminal. -module Data.Text.Prettyprint.Doc.Render.Terminal ( - -- * Styling - AnsiStyle, - Color(..), - - -- ** Font color - color, colorDull, - - -- ** Background color - bgColor, bgColorDull, - - -- ** 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, - - -- * Render directly to 'stdout' - renderIO, - - -- ** Convenience functions - putDoc, hPutDoc, +module Data.Text.Prettyprint.Doc.Render.Terminal {-# DEPRECATED "Use \"Prettyprinter.Render.Terminal\" instead." #-} ( + module Prettyprinter.Render.Terminal ) where -import Data.Text.Prettyprint.Doc.Render.Terminal.Internal +import Prettyprinter.Render.Terminal + diff --git a/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs b/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs --- a/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs +++ b/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs @@ -1,334 +1,7 @@ -{-# 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 Control.Monad.ST -import Data.IORef -import Data.Maybe -import Data.Semigroup -import Data.STRef -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB -import qualified System.Console.ANSI as ANSI -import System.IO (Handle, hPutChar, stdout) - -import Data.Text.Prettyprint.Doc -import Data.Text.Prettyprint.Doc.Render.Util.Panic - - - --- $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 sdoc = runST (do - styleStackRef <- newSTRef [mempty] - outputRef <- newSTRef mempty - - let push x = modifySTRef' styleStackRef (x :) - unsafePeek = readSTRef styleStackRef >>= \case - [] -> panicPeekedEmpty - x:_ -> pure x - unsafePop = readSTRef styleStackRef >>= \case - [] -> panicPeekedEmpty - x:xs -> writeSTRef styleStackRef xs >> pure x - writeOutput x = modifySTRef outputRef (<> x) - - let go = \case - SFail -> panicUncaughtFail - SEmpty -> pure () - SChar c rest -> do - writeOutput (TLB.singleton c) - go rest - SText _ t rest -> do - writeOutput (TLB.fromText t) - go rest - SLine i rest -> do - writeOutput (TLB.singleton '\n' <> TLB.fromText (T.replicate i " ")) - go rest - SAnnPush style rest -> do - currentStyle <- unsafePeek - let newStyle = style <> currentStyle - push newStyle - writeOutput (TLB.fromText (styleToRawText newStyle)) - go rest - SAnnPop rest -> do - _currentStyle <- unsafePop - newStyle <- unsafePeek - writeOutput (TLB.fromText (styleToRawText newStyle)) - go rest - go sdoc - readSTRef styleStackRef >>= \case - [] -> panicStyleStackFullyConsumed - [_] -> fmap TLB.toLazyText (readSTRef outputRef) - xs -> panicStyleStackNotFullyConsumed (length xs) ) - --- | @('renderIO' h sdoc)@ writes @sdoc@ to the handle @h@. --- --- >>> let render = renderIO System.IO.stdout . layoutPretty defaultLayoutOptions --- >>> let doc = annotate (color Red) ("red" <+> align (vsep [annotate (color Blue <> underlined) ("blue+u" <+> annotate bold "bold" <+> "blue+u"), "red"])) --- --- We render the 'unAnnotate'd version here, since the ANSI codes don’t display --- well in Haddock, --- --- >>> render (unAnnotate doc) --- red blue+u bold blue+u --- red --- --- This function behaves just like --- --- @ --- 'renderIO' h sdoc = 'TL.hPutStr' h ('renderLazy' sdoc) --- @ --- --- but will not generate any intermediate text, rendering directly to the --- handle. -renderIO :: Handle -> SimpleDocStream AnsiStyle -> IO () -renderIO h sdoc = do - styleStackRef <- newIORef [mempty] - - let push x = modifyIORef' styleStackRef (x :) - unsafePeek = readIORef styleStackRef >>= \case - [] -> panicPeekedEmpty - x:_ -> pure x - unsafePop = readIORef styleStackRef >>= \case - [] -> panicPeekedEmpty - x:xs -> writeIORef styleStackRef xs >> pure x - - let go = \case - SFail -> panicUncaughtFail - SEmpty -> pure () - SChar c rest -> do - hPutChar h c - go rest - SText _ t rest -> do - T.hPutStr h t - go rest - SLine i rest -> do - hPutChar h '\n' - T.hPutStr h (T.replicate i " ") - go rest - SAnnPush style rest -> do - currentStyle <- unsafePeek - let newStyle = style <> currentStyle - push newStyle - T.hPutStr h (styleToRawText newStyle) - go rest - SAnnPop rest -> do - _currentStyle <- unsafePop - newStyle <- unsafePeek - T.hPutStr h (styleToRawText newStyle) - go rest - go sdoc - readIORef styleStackRef >>= \case - [] -> panicStyleStackFullyConsumed - [_] -> pure () - xs -> panicStyleStackNotFullyConsumed (length xs) - -panicStyleStackFullyConsumed :: void -panicStyleStackFullyConsumed - = error ("There is no empty style left at the end of rendering" ++ - " (but there should be). Please report this as a bug.") - -panicStyleStackNotFullyConsumed :: Int -> void -panicStyleStackNotFullyConsumed len - = error ("There are " <> show len <> " styles left at the" ++ - "end of rendering (there should be only 1). Please report" ++ - " this as a bug.") - --- $ --- >>> let render = renderIO System.IO.stdout . 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 --- --- This test won’t work since I don’t know how to type \ESC for doctest :-/ --- -- >>> render doc --- -- \ESC[0;91mred \ESC[0;94;4mblue+u \ESC[0;94;1;4mbold\ESC[0;94;4m blue+u\ESC[0;91m --- -- red\ESC[0m - --- | Render the annotated document in a certain style. Styles not set in the --- annotation will use the style of the surrounding document, or the terminal’s --- default if none has been set yet. --- --- @ --- 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. If a certain style is not set, the --- terminal’s default will be used. --- --- Example: --- --- @ --- 'color' 'Red' '<>' 'color' 'Green' --- @ --- --- is red because the first color wins, and not bold because (or if) that’s the --- terminal’s default. -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 } - --- | 'mempty' does nothing, which is equivalent to inheriting the style of the --- surrounding doc, or the terminal’s default if no style has been set yet. -instance Monoid AnsiStyle where - mempty = SetAnsiStyle Nothing Nothing Nothing Nothing Nothing - mappend = (<>) - -styleToRawText :: AnsiStyle -> Text -styleToRawText = T.pack . 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 +module Data.Text.Prettyprint.Doc.Render.Terminal.Internal {-# DEPRECATED "Use \"Prettyprinter.Render.Terminal.Internal\" instead." #-} ( + module Prettyprinter.Render.Terminal.Internal +) where +import Prettyprinter.Render.Terminal.Internal --- | @('renderStrict' sdoc)@ takes the output @sdoc@ from a rendering and --- transforms it to strict text. -renderStrict :: SimpleDocStream AnsiStyle -> Text -renderStrict = TL.toStrict . renderLazy - --- | @('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) diff --git a/src/Prettyprinter/Render/Terminal.hs b/src/Prettyprinter/Render/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Render/Terminal.hs @@ -0,0 +1,35 @@ +-- | Render 'SimpleDocStream' in a terminal. +module Prettyprinter.Render.Terminal ( + -- * Styling + AnsiStyle, + Color(..), + + -- ** Font color + color, colorDull, + + -- ** Background color + bgColor, bgColorDull, + + -- ** 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, + + -- * Render directly to 'stdout' + renderIO, + + -- ** Convenience functions + putDoc, hPutDoc, +) where + +import Prettyprinter.Render.Terminal.Internal diff --git a/src/Prettyprinter/Render/Terminal/Internal.hs b/src/Prettyprinter/Render/Terminal/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Render/Terminal/Internal.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_HADDOCK not-home #-} + +#include "version-compatibility-macros.h" + +-- | __Warning:__ Internal module. May change arbitrarily between versions. +module Prettyprinter.Render.Terminal.Internal ( + -- * Styling + AnsiStyle(..), + Color(..), + + -- ** Font color + color, colorDull, + + -- ** Background color + bgColor, bgColorDull, + + -- ** Font style + bold, italicized, underlined, + + -- ** Internal markers + Intensity(..), + Bold(..), + Underlined(..), + Italicized(..), + + -- * Conversion to ANSI-infused 'Text' + renderLazy, renderStrict, + + -- * Render directly to 'stdout' + renderIO, + + -- ** Convenience functions + putDoc, hPutDoc, +) where + + + +import Control.Applicative +import Data.IORef +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified System.Console.ANSI as ANSI +import System.IO (Handle, hPutChar, stdout) + +import Prettyprinter +import Prettyprinter.Render.Util.Panic + +#if !(SEMIGROUP_MONOID_SUPERCLASS) +import Data.Semigroup (Semigroup(..)) +#endif + +-- $setup +-- +-- (Definitions for the doctests) +-- +-- >>> :set -XOverloadedStrings +-- >>> import qualified Data.Text.Lazy.IO as TL +-- >>> import qualified Data.Text.Lazy as TL +-- >>> import Prettyprinter.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 = + let push x = (x :) + + unsafePeek [] = panicPeekedEmpty + unsafePeek (x:_) = x + + unsafePop [] = panicPoppedEmpty + unsafePop (x:xs) = (x, xs) + + go :: [AnsiStyle] -> SimpleDocStream AnsiStyle -> TLB.Builder + go s sds = case sds of + SFail -> panicUncaughtFail + SEmpty -> mempty + SChar c rest -> TLB.singleton c <> go s rest + SText _ t rest -> TLB.fromText t <> go s rest + SLine i rest -> TLB.singleton '\n' <> TLB.fromText (T.replicate i " ") <> go s rest + SAnnPush style rest -> + let currentStyle = unsafePeek s + newStyle = style <> currentStyle + in TLB.fromText (styleToRawText newStyle) <> go (push newStyle s) rest + SAnnPop rest -> + let (_currentStyle, s') = unsafePop s + newStyle = unsafePeek s' + in TLB.fromText (styleToRawText newStyle) <> go s' rest + + in TLB.toLazyText . go [mempty] + + +-- | @('renderIO' h sdoc)@ writes @sdoc@ to the handle @h@. +-- +-- >>> let render = renderIO System.IO.stdout . layoutPretty defaultLayoutOptions +-- >>> let doc = annotate (color Red) ("red" <+> align (vsep [annotate (color Blue <> underlined) ("blue+u" <+> annotate bold "bold" <+> "blue+u"), "red"])) +-- +-- We render the 'unAnnotate'd version here, since the ANSI codes don’t display +-- well in Haddock, +-- +-- >>> render (unAnnotate doc) +-- red blue+u bold blue+u +-- red +-- +-- This function behaves just like +-- +-- @ +-- 'renderIO' h sdoc = 'TL.hPutStr' h ('renderLazy' sdoc) +-- @ +-- +-- but will not generate any intermediate text, rendering directly to the +-- handle. +renderIO :: Handle -> SimpleDocStream AnsiStyle -> IO () +renderIO h sdoc = do + styleStackRef <- newIORef [mempty] + + let push x = modifyIORef' styleStackRef (x :) + unsafePeek = readIORef styleStackRef >>= \tok -> case tok of + [] -> panicPeekedEmpty + x:_ -> pure x + unsafePop = readIORef styleStackRef >>= \tok -> case tok of + [] -> panicPoppedEmpty + x:xs -> writeIORef styleStackRef xs >> pure x + + let go = \sds -> case sds of + SFail -> panicUncaughtFail + SEmpty -> pure () + SChar c rest -> do + hPutChar h c + go rest + SText _ t rest -> do + T.hPutStr h t + go rest + SLine i rest -> do + hPutChar h '\n' + T.hPutStr h (T.replicate i (T.singleton ' ')) + go rest + SAnnPush style rest -> do + currentStyle <- unsafePeek + let newStyle = style <> currentStyle + push newStyle + T.hPutStr h (styleToRawText newStyle) + go rest + SAnnPop rest -> do + _currentStyle <- unsafePop + newStyle <- unsafePeek + T.hPutStr h (styleToRawText newStyle) + go rest + go sdoc + readIORef styleStackRef >>= \stack -> case stack of + [] -> panicStyleStackFullyConsumed + [_] -> pure () + xs -> panicStyleStackNotFullyConsumed (length xs) + +panicStyleStackFullyConsumed :: void +panicStyleStackFullyConsumed + = error ("There is no empty style left at the end of rendering" ++ + " (but there should be). Please report this as a bug.") + +panicStyleStackNotFullyConsumed :: Int -> void +panicStyleStackNotFullyConsumed len + = error ("There are " <> show len <> " styles left at the" ++ + "end of rendering (there should be only 1). Please report" ++ + " this as a bug.") + +-- $ +-- >>> let render = renderIO System.IO.stdout . 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 +-- +-- This test won’t work since I don’t know how to type \ESC for doctest :-/ +-- -- >>> render doc +-- -- \ESC[0;91mred \ESC[0;94;4mblue+u \ESC[0;94;1;4mbold\ESC[0;94;4m blue+u\ESC[0;91m +-- -- red\ESC[0m + +-- | Render the annotated document in a certain style. Styles not set in the +-- annotation will use the style of the surrounding document, or the terminal’s +-- default if none has been set yet. +-- +-- @ +-- 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. If a certain style is not set, the +-- terminal’s default will be used. +-- +-- Example: +-- +-- @ +-- 'color' 'Red' '<>' 'color' 'Green' +-- @ +-- +-- is red because the first color wins, and not bold because (or if) that’s the +-- terminal’s default. +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 } + +-- | 'mempty' does nothing, which is equivalent to inheriting the style of the +-- surrounding doc, or the terminal’s default if no style has been set yet. +instance Monoid AnsiStyle where + mempty = SetAnsiStyle Nothing Nothing Nothing Nothing Nothing + mappend = (<>) + +styleToRawText :: AnsiStyle -> Text +styleToRawText = T.pack . 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 = \i -> case i of + Vivid -> ANSI.Vivid + Dull -> ANSI.Dull + + convertColor :: Color -> ANSI.Color + convertColor = \c -> case c of + 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 + +-- | @('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)