packages feed

prettyprinter-ansi-terminal 1.1.1.2 → 1.1.4

raw patch · 12 files changed

Files

CHANGELOG.md view
@@ -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`
+ bench/LargeOutput.hs view
@@ -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)+        ]
misc/version-compatibility-macros.h view
@@ -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
prettyprinter-ansi-terminal.cabal view
@@ -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 <dluposchainsky at google>+maintainer:          Simon Jakobi <simon.jakobi@gmail.com>, David Luposchainsky <dluposchainsky at google> 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
+ src-text/Data/Text.hs view
@@ -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
+ src-text/Data/Text/IO.hs view
@@ -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
+ src-text/Data/Text/Lazy.hs view
@@ -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
+ src-text/Data/Text/Lazy/Builder.hs view
@@ -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
src/Data/Text/Prettyprint/Doc/Render/Terminal.hs view
@@ -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+
src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs view
@@ -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)
+ src/Prettyprinter/Render/Terminal.hs view
@@ -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
+ src/Prettyprinter/Render/Terminal/Internal.hs view
@@ -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)