{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
-- | This module re-exports some of the interface for
-- "Text.PrettyPrint.Annotated.Leijen" along with additional definitions
-- useful for stack.
--
-- It defines a 'Monoid' instance for 'Doc'.
module Text.PrettyPrint.Leijen.Extended
  (
  -- * Pretty-print typeclass
  Pretty (..),

  -- * Ansi terminal Doc
  --
  -- See "System.Console.ANSI" for 'SGR' values to use beyond the colors
  -- provided.
  StyleDoc (..), StyleAnn(..),
  -- hDisplayAnsi,
  displayAnsi, displayPlain, renderDefault,

  -- * Selective re-exports from "Text.PrettyPrint.Annotated.Leijen"
  --
  -- Documentation of omissions up-to-date with @annotated-wl-pprint-0.7.0@

  -- ** Documents, parametrized by their annotations
  --
  -- Omitted compared to original: @putDoc, hPutDoc@
  -- Doc,

  -- ** Basic combinators
  --
  -- Omitted compared to original: @empty, char, text, (<>)@
  --
  -- Instead of @text@ and @char@, use 'fromString'.
  --
  -- Instead of @empty@, use 'mempty'.
  nest, line, linebreak, group, softline, softbreak,

  -- ** Alignment
  --
  -- The combinators in this section can not be described by Wadler's
  -- original combinators. They align their output relative to the
  -- current output position - in contrast to @nest@ which always
  -- aligns to the current nesting level. This deprives these
  -- combinators from being \`optimal\'. In practice however they
  -- prove to be very useful. The combinators in this section should
  -- be used with care, since they are more expensive than the other
  -- combinators. For example, @align@ shouldn't be used to pretty
  -- print all top-level declarations of a language, but using @hang@
  -- for let expressions is fine.
  --
  -- Omitted compared to original: @list, tupled, semiBraces@
  align, hang, indent, encloseSep,

  -- ** Operators
  --
  -- Omitted compared to original: @(<$>), (</>), (<$$>), (<//>)@
  (<+>),

  -- ** List combinators
  hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate,

  -- ** Fillers
  fill, fillBreak,

  -- ** Bracketing combinators
  enclose, squotes, dquotes, parens, angles, braces, brackets,

  -- ** Character documents
  -- Entirely omitted:
  --
  -- @
  -- lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket,
  -- squote, dquote, semi, colon, comma, space, dot, backslash, equals,
  -- pipe
  -- @

  -- ** Primitive type documents
  -- Omitted compared to the original:
  --
  -- @
  -- int, integer, float, double, rational, bool,
  -- @
  string,

  -- ** Semantic annotations
  annotate, noAnnotate, styleAnn

  -- ** Rendering
  -- Original entirely omitted:
  -- @
  -- SimpleDoc(..), renderPretty, renderCompact, displayDecorated, displayDecoratedA, display, displayS, displayIO,
  -- SpanList(..), displaySpans
  -- @

  -- ** Undocumented
  -- Entirely omitted:
  -- @
  -- column, nesting, width
  -- @
  ) where

import Control.Monad.Reader (runReader, local)
import Data.Array.IArray ((!), (//))
import qualified Data.Text as T
import Distribution.ModuleName (ModuleName)
import qualified Distribution.Text (display)
import Path
import RIO
import qualified RIO.Map as M
import RIO.PrettyPrint.DefaultStyles (defaultStyles)
import RIO.PrettyPrint.Types (Style (Dir, File), Styles)
import RIO.PrettyPrint.StylesUpdate (StylesUpdate (..), HasStylesUpdate, stylesUpdateL)
import System.Console.ANSI (ConsoleLayer (..), SGR (..), setSGRCode)
import qualified Text.PrettyPrint.Annotated.Leijen as P
import Text.PrettyPrint.Annotated.Leijen
  ( Doc, SimpleDoc (..)
  )

-- TODO: consider smashing together the code for wl-annotated-pprint and
-- wl-pprint-text. The code here already handles doing the
-- ansi-wl-pprint stuff (better!) atop wl-annotated-pprint. So the
-- result would be a package unifying 3 different wl inspired packages.
--
-- Perhaps it can still have native string support, by adding a type
-- parameter to Doc?

instance Semigroup StyleDoc where
    StyleDoc Doc StyleAnn
x <> :: StyleDoc -> StyleDoc -> StyleDoc
<> StyleDoc Doc StyleAnn
y = Doc StyleAnn -> StyleDoc
StyleDoc (Doc StyleAnn
x forall a. Doc a -> Doc a -> Doc a
P.<> Doc StyleAnn
y)
instance Monoid StyleDoc where
    mappend :: StyleDoc -> StyleDoc -> StyleDoc
mappend = forall a. Semigroup a => a -> a -> a
(<>)
    mempty :: StyleDoc
mempty = Doc StyleAnn -> StyleDoc
StyleDoc forall a. Doc a
P.empty

--------------------------------------------------------------------------------
-- Pretty-Print class

class Pretty a where
    pretty :: a -> StyleDoc
    default pretty :: Show a => a -> StyleDoc
    pretty = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

instance Pretty StyleDoc where
    pretty :: StyleDoc -> StyleDoc
pretty = forall a. a -> a
id

instance Pretty (Path b File) where
    pretty :: Path b File -> StyleDoc
pretty = Style -> StyleDoc -> StyleDoc
styleAnn Style
File forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath

instance Pretty (Path b Dir) where
    pretty :: Path b Dir -> StyleDoc
pretty = Style -> StyleDoc -> StyleDoc
styleAnn Style
Dir forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath

instance Pretty ModuleName where
    pretty :: ModuleName -> StyleDoc
pretty = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> String
Distribution.Text.display

--------------------------------------------------------------------------------
-- Style Doc

-- |A style annotation.
newtype StyleAnn = StyleAnn (Maybe Style)
    deriving (StyleAnn -> StyleAnn -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StyleAnn -> StyleAnn -> Bool
$c/= :: StyleAnn -> StyleAnn -> Bool
== :: StyleAnn -> StyleAnn -> Bool
$c== :: StyleAnn -> StyleAnn -> Bool
Eq, Int -> StyleAnn -> ShowS
[StyleAnn] -> ShowS
StyleAnn -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StyleAnn] -> ShowS
$cshowList :: [StyleAnn] -> ShowS
show :: StyleAnn -> String
$cshow :: StyleAnn -> String
showsPrec :: Int -> StyleAnn -> ShowS
$cshowsPrec :: Int -> StyleAnn -> ShowS
Show, NonEmpty StyleAnn -> StyleAnn
StyleAnn -> StyleAnn -> StyleAnn
forall b. Integral b => b -> StyleAnn -> StyleAnn
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> StyleAnn -> StyleAnn
$cstimes :: forall b. Integral b => b -> StyleAnn -> StyleAnn
sconcat :: NonEmpty StyleAnn -> StyleAnn
$csconcat :: NonEmpty StyleAnn -> StyleAnn
<> :: StyleAnn -> StyleAnn -> StyleAnn
$c<> :: StyleAnn -> StyleAnn -> StyleAnn
Semigroup)

instance Monoid StyleAnn where
    mempty :: StyleAnn
mempty = Maybe Style -> StyleAnn
StyleAnn forall a. Maybe a
Nothing
    mappend :: StyleAnn -> StyleAnn -> StyleAnn
mappend = forall a. Semigroup a => a -> a -> a
(<>)

-- |A document annotated by a style
newtype StyleDoc = StyleDoc { StyleDoc -> Doc StyleAnn
unStyleDoc :: Doc StyleAnn }
  deriving (String -> StyleDoc
forall a. (String -> a) -> IsString a
fromString :: String -> StyleDoc
$cfromString :: String -> StyleDoc
IsString, Int -> StyleDoc -> ShowS
[StyleDoc] -> ShowS
StyleDoc -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StyleDoc] -> ShowS
$cshowList :: [StyleDoc] -> ShowS
show :: StyleDoc -> String
$cshow :: StyleDoc -> String
showsPrec :: Int -> StyleDoc -> ShowS
$cshowsPrec :: Int -> StyleDoc -> ShowS
Show)

-- |An ANSI code(s) annotation.
newtype AnsiAnn = AnsiAnn [SGR]
    deriving (AnsiAnn -> AnsiAnn -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AnsiAnn -> AnsiAnn -> Bool
$c/= :: AnsiAnn -> AnsiAnn -> Bool
== :: AnsiAnn -> AnsiAnn -> Bool
$c== :: AnsiAnn -> AnsiAnn -> Bool
Eq, Int -> AnsiAnn -> ShowS
[AnsiAnn] -> ShowS
AnsiAnn -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AnsiAnn] -> ShowS
$cshowList :: [AnsiAnn] -> ShowS
show :: AnsiAnn -> String
$cshow :: AnsiAnn -> String
showsPrec :: Int -> AnsiAnn -> ShowS
$cshowsPrec :: Int -> AnsiAnn -> ShowS
Show, NonEmpty AnsiAnn -> AnsiAnn
AnsiAnn -> AnsiAnn -> AnsiAnn
forall b. Integral b => b -> AnsiAnn -> AnsiAnn
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> AnsiAnn -> AnsiAnn
$cstimes :: forall b. Integral b => b -> AnsiAnn -> AnsiAnn
sconcat :: NonEmpty AnsiAnn -> AnsiAnn
$csconcat :: NonEmpty AnsiAnn -> AnsiAnn
<> :: AnsiAnn -> AnsiAnn -> AnsiAnn
$c<> :: AnsiAnn -> AnsiAnn -> AnsiAnn
Semigroup, Semigroup AnsiAnn
AnsiAnn
[AnsiAnn] -> AnsiAnn
AnsiAnn -> AnsiAnn -> AnsiAnn
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [AnsiAnn] -> AnsiAnn
$cmconcat :: [AnsiAnn] -> AnsiAnn
mappend :: AnsiAnn -> AnsiAnn -> AnsiAnn
$cmappend :: AnsiAnn -> AnsiAnn -> AnsiAnn
mempty :: AnsiAnn
$cmempty :: AnsiAnn
Monoid)

-- |Convert a 'SimpleDoc' annotated with 'StyleAnn' to one annotated with
-- 'AnsiAnn', by reference to a 'Styles'.
toAnsiDoc :: Styles -> SimpleDoc StyleAnn -> SimpleDoc AnsiAnn
toAnsiDoc :: Styles -> SimpleDoc StyleAnn -> SimpleDoc AnsiAnn
toAnsiDoc Styles
styles = SimpleDoc StyleAnn -> SimpleDoc AnsiAnn
go
  where
    go :: SimpleDoc StyleAnn -> SimpleDoc AnsiAnn
go SimpleDoc StyleAnn
SEmpty        = forall a. SimpleDoc a
SEmpty
    go (SChar Char
c SimpleDoc StyleAnn
d)   = forall a. Char -> SimpleDoc a -> SimpleDoc a
SChar Char
c (SimpleDoc StyleAnn -> SimpleDoc AnsiAnn
go SimpleDoc StyleAnn
d)
    go (SText Int
l String
s SimpleDoc StyleAnn
d) = forall a. Int -> String -> SimpleDoc a -> SimpleDoc a
SText Int
l String
s (SimpleDoc StyleAnn -> SimpleDoc AnsiAnn
go SimpleDoc StyleAnn
d)
    go (SLine Int
i SimpleDoc StyleAnn
d)   = forall a. Int -> SimpleDoc a -> SimpleDoc a
SLine Int
i (SimpleDoc StyleAnn -> SimpleDoc AnsiAnn
go SimpleDoc StyleAnn
d)
    go (SAnnotStart (StyleAnn (Just Style
s)) SimpleDoc StyleAnn
d) =
        forall a. a -> SimpleDoc a -> SimpleDoc a
SAnnotStart ([SGR] -> AnsiAnn
AnsiAnn (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Styles
styles forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Style
s)) (SimpleDoc StyleAnn -> SimpleDoc AnsiAnn
go SimpleDoc StyleAnn
d)
    go (SAnnotStart (StyleAnn Maybe Style
Nothing) SimpleDoc StyleAnn
d) = forall a. a -> SimpleDoc a -> SimpleDoc a
SAnnotStart ([SGR] -> AnsiAnn
AnsiAnn []) (SimpleDoc StyleAnn -> SimpleDoc AnsiAnn
go SimpleDoc StyleAnn
d)
    go (SAnnotStop SimpleDoc StyleAnn
d) = forall a. SimpleDoc a -> SimpleDoc a
SAnnotStop (SimpleDoc StyleAnn -> SimpleDoc AnsiAnn
go SimpleDoc StyleAnn
d)

displayPlain
    :: (Pretty a, HasLogFunc env, HasStylesUpdate env,
        MonadReader env m, HasCallStack)
    => Int -> a -> m Utf8Builder
displayPlain :: forall a env (m :: * -> *).
(Pretty a, HasLogFunc env, HasStylesUpdate env, MonadReader env m,
 HasCallStack) =>
Int -> a -> m Utf8Builder
displayPlain Int
w =
    forall env (m :: * -> *).
(HasLogFunc env, HasStylesUpdate env, MonadReader env m,
 HasCallStack) =>
SimpleDoc StyleAnn -> m Utf8Builder
displayAnsiSimple forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Doc a -> SimpleDoc a
renderDefault Int
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> StyleDoc
pretty

-- TODO: tweak these settings more?
-- TODO: options for settings if this is released as a lib

renderDefault :: Int -> Doc a -> SimpleDoc a
renderDefault :: forall a. Int -> Doc a -> SimpleDoc a
renderDefault = forall a. Float -> Int -> Doc a -> SimpleDoc a
P.renderPretty Float
1

displayAnsi
    :: (Pretty a, HasLogFunc env, HasStylesUpdate env,
        MonadReader env m, HasCallStack)
    => Int -> a -> m Utf8Builder
displayAnsi :: forall a env (m :: * -> *).
(Pretty a, HasLogFunc env, HasStylesUpdate env, MonadReader env m,
 HasCallStack) =>
Int -> a -> m Utf8Builder
displayAnsi Int
w =
    forall env (m :: * -> *).
(HasLogFunc env, HasStylesUpdate env, MonadReader env m,
 HasCallStack) =>
SimpleDoc StyleAnn -> m Utf8Builder
displayAnsiSimple forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Doc a -> SimpleDoc a
renderDefault Int
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> StyleDoc
pretty

{- Not used --------------------------------------------------------------------

hDisplayAnsi
    :: (Display a, HasAnsiAnn (Ann a), MonadIO m)
    => Handle -> Int -> a -> m ()
hDisplayAnsi h w x = liftIO $ do
    useAnsi <- hSupportsANSI h
    T.hPutStr h $ if useAnsi then displayAnsi w x else displayPlain w x

-}

displayAnsiSimple
    :: (HasLogFunc env, HasStylesUpdate env, MonadReader env m, HasCallStack)
    => SimpleDoc StyleAnn -> m Utf8Builder
displayAnsiSimple :: forall env (m :: * -> *).
(HasLogFunc env, HasStylesUpdate env, MonadReader env m,
 HasCallStack) =>
SimpleDoc StyleAnn -> m Utf8Builder
displayAnsiSimple SimpleDoc StyleAnn
doc = do
    StylesUpdate
update <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL
    let styles :: Styles
styles = Styles
defaultStyles forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
// StylesUpdate -> [(Style, (Text, [SGR]))]
stylesUpdate StylesUpdate
update
        doc' :: SimpleDoc AnsiAnn
doc' = Styles -> SimpleDoc StyleAnn -> SimpleDoc AnsiAnn
toAnsiDoc Styles
styles SimpleDoc StyleAnn
doc
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
Monad m =>
(forall b. a -> m (b, Utf8Builder) -> m (b, Utf8Builder))
-> SimpleDoc a -> m Utf8Builder
displayDecoratedWrap forall {m :: * -> *} {b} {a}.
(MonadReader (Map SGRTag SGR) m, Monoid b, IsString b) =>
AnsiAnn -> m (a, b) -> m (a, b)
go SimpleDoc AnsiAnn
doc'
  where
    go :: AnsiAnn -> m (a, b) -> m (a, b)
go (AnsiAnn [SGR]
sgrs) m (a, b)
inner = do
        Map SGRTag SGR
old <- forall r (m :: * -> *). MonadReader r m => m r
ask
        let sgrs' :: [(SGRTag, SGR)]
sgrs' = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\SGR
sgr -> if SGR
sgr forall a. Eq a => a -> a -> Bool
== SGR
Reset
                                        then forall a. Maybe a
Nothing
                                        else forall a. a -> Maybe a
Just (SGR -> SGRTag
getSGRTag SGR
sgr, SGR
sgr)) [SGR]
sgrs
            new :: Map SGRTag SGR
new = if SGR
Reset forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SGR]
sgrs
                      then forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(SGRTag, SGR)]
sgrs'
                      else forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map SGRTag SGR
mp (SGRTag
tag, SGR
sgr) -> forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert SGRTag
tag SGR
sgr Map SGRTag SGR
mp) Map SGRTag SGR
old [(SGRTag, SGR)]
sgrs'
        (a
extra, b
contents) <- forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall a b. a -> b -> a
const Map SGRTag SGR
new) m (a, b)
inner
        forall (m :: * -> *) a. Monad m => a -> m a
return (a
extra, forall {k} {a}.
(Ord k, Monoid a, IsString a) =>
Map k SGR -> Map k SGR -> a
transitionCodes Map SGRTag SGR
old Map SGRTag SGR
new forall a. Semigroup a => a -> a -> a
<> b
contents forall a. Semigroup a => a -> a -> a
<> forall {k} {a}.
(Ord k, Monoid a, IsString a) =>
Map k SGR -> Map k SGR -> a
transitionCodes Map SGRTag SGR
new Map SGRTag SGR
old)
    transitionCodes :: Map k SGR -> Map k SGR -> a
transitionCodes Map k SGR
old Map k SGR
new =
        case (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SGR]
removals, forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SGR]
additions) of
            (Bool
True, Bool
True) -> forall a. Monoid a => a
mempty
            (Bool
True, Bool
False) -> forall a. IsString a => String -> a
fromString ([SGR] -> String
setSGRCode [SGR]
additions)
            (Bool
False, Bool
_) -> forall a. IsString a => String -> a
fromString ([SGR] -> String
setSGRCode (SGR
Reset forall a. a -> [a] -> [a]
: forall k a. Map k a -> [a]
M.elems Map k SGR
new))
      where
        ([SGR]
removals, [SGR]
additions) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems forall a b. (a -> b) -> a -> b
$
            forall k a b c.
Ord k =>
(k -> a -> b -> Maybe c)
-> (Map k a -> Map k c)
-> (Map k b -> Map k c)
-> Map k a
-> Map k b
-> Map k c
M.mergeWithKey
               (\k
_ SGR
o SGR
n -> if SGR
o forall a. Eq a => a -> a -> Bool
== SGR
n then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right SGR
n))
               (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left)
               (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right)
               Map k SGR
old
               Map k SGR
new

displayDecoratedWrap
    :: forall a m. Monad m
    => (forall b. a -> m (b, Utf8Builder) -> m (b, Utf8Builder))
    -> SimpleDoc a
    -> m Utf8Builder
displayDecoratedWrap :: forall a (m :: * -> *).
Monad m =>
(forall b. a -> m (b, Utf8Builder) -> m (b, Utf8Builder))
-> SimpleDoc a -> m Utf8Builder
displayDecoratedWrap forall b. a -> m (b, Utf8Builder) -> m (b, Utf8Builder)
f SimpleDoc a
doc = do
    (Maybe (SimpleDoc a)
mafter, Utf8Builder
result) <- SimpleDoc a -> m (Maybe (SimpleDoc a), Utf8Builder)
go SimpleDoc a
doc
    case Maybe (SimpleDoc a)
mafter of
      Just SimpleDoc a
_ -> forall a. HasCallStack => String -> a
error String
"Invariant violated by input to displayDecoratedWrap: no matching SAnnotStart for SAnnotStop."
      Maybe (SimpleDoc a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Utf8Builder
result
  where
    spaces :: Int -> Utf8Builder
spaces Int
n = forall a. Display a => a -> Utf8Builder
display (Int -> Text -> Text
T.replicate Int
n Text
" ")

    go :: SimpleDoc a -> m (Maybe (SimpleDoc a), Utf8Builder)
    go :: SimpleDoc a -> m (Maybe (SimpleDoc a), Utf8Builder)
go SimpleDoc a
SEmpty = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, forall a. Monoid a => a
mempty)
    go (SChar Char
c SimpleDoc a
x) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Display a => a -> Utf8Builder
display Char
c forall a. Semigroup a => a -> a -> a
<>)) (SimpleDoc a -> m (Maybe (SimpleDoc a), Utf8Builder)
go SimpleDoc a
x)
    -- NOTE: Could actually use the length to guess at an initial
    -- allocation.  Better yet would be to just use Text in pprint..
    go (SText Int
_l String
s SimpleDoc a
x) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. IsString a => String -> a
fromString String
s forall a. Semigroup a => a -> a -> a
<>)) (SimpleDoc a -> m (Maybe (SimpleDoc a), Utf8Builder)
go SimpleDoc a
x)
    go (SLine Int
n SimpleDoc a
x) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a. Display a => a -> Utf8Builder
display Char
'\n' forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Utf8Builder
spaces Int
n forall a. Semigroup a => a -> a -> a
<>))) (SimpleDoc a -> m (Maybe (SimpleDoc a), Utf8Builder)
go SimpleDoc a
x)
    go (SAnnotStart a
ann SimpleDoc a
x) = do
        (Maybe (SimpleDoc a)
mafter, Utf8Builder
contents) <- forall b. a -> m (b, Utf8Builder) -> m (b, Utf8Builder)
f a
ann (SimpleDoc a -> m (Maybe (SimpleDoc a), Utf8Builder)
go SimpleDoc a
x)
        case Maybe (SimpleDoc a)
mafter of
            Just SimpleDoc a
after -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Utf8Builder
contents forall a. Semigroup a => a -> a -> a
<>)) (SimpleDoc a -> m (Maybe (SimpleDoc a), Utf8Builder)
go SimpleDoc a
after)
            Maybe (SimpleDoc a)
Nothing -> forall a. HasCallStack => String -> a
error String
"Invariant violated by input to displayDecoratedWrap: no matching SAnnotStop for SAnnotStart."
    go (SAnnotStop SimpleDoc a
x) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just SimpleDoc a
x, forall a. Monoid a => a
mempty)

{- Not used --------------------------------------------------------------------

-- Foreground color combinators

black, red, green, yellow, blue, magenta, cyan, white,
    dullblack, dullred, dullgreen, dullyellow, dullblue, dullmagenta, dullcyan, dullwhite,
    onblack, onred, ongreen, onyellow, onblue, onmagenta, oncyan, onwhite,
    ondullblack, ondullred, ondullgreen, ondullyellow, ondullblue, ondullmagenta, ondullcyan, ondullwhite
    :: Doc AnsiAnn -> Doc AnsiAnn
(black, dullblack, onblack, ondullblack) = colorFunctions Black
(red, dullred, onred, ondullred) = colorFunctions Red
(green, dullgreen, ongreen, ondullgreen) = colorFunctions Green
(yellow, dullyellow, onyellow, ondullyellow) = colorFunctions Yellow
(blue, dullblue, onblue, ondullblue) = colorFunctions Blue
(magenta, dullmagenta, onmagenta, ondullmagenta) = colorFunctions Magenta
(cyan, dullcyan, oncyan, ondullcyan) = colorFunctions Cyan
(white, dullwhite, onwhite, ondullwhite) = colorFunctions White

type EndoAnsiDoc = Doc AnsiAnn -> Doc AnsiAnn

colorFunctions :: Color -> (EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc, EndoAnsiDoc)
colorFunctions color =
    ( ansiAnn [SetColor Foreground Vivid color]
    , ansiAnn [SetColor Foreground Dull color]
    , ansiAnn [SetColor Background Vivid color]
    , ansiAnn [SetColor Background Dull color]
    )

-}

styleAnn :: Style -> StyleDoc -> StyleDoc
styleAnn :: Style -> StyleDoc -> StyleDoc
styleAnn Style
s = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Doc a -> Doc a
P.annotate (Maybe Style -> StyleAnn
StyleAnn (forall a. a -> Maybe a
Just Style
s)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc

{- Not used --------------------------------------------------------------------

-- Intensity combinators

bold, faint, normal :: Doc AnsiAnn -> Doc AnsiAnn
bold = ansiAnn [SetConsoleIntensity BoldIntensity]
faint = ansiAnn [SetConsoleIntensity FaintIntensity]
normal = ansiAnn [SetConsoleIntensity NormalIntensity]

-}

-- | Tags for each field of state in SGR (Select Graphics Rendition).
--
-- It's a bit of a hack that 'TagReset' is included.
data SGRTag
    = TagReset
    | TagConsoleIntensity
    | TagItalicized
    | TagUnderlining
    | TagBlinkSpeed
    | TagVisible
    | TagSwapForegroundBackground
    | TagColorForeground
    | TagColorBackground
    | TagRGBColor
    | TagPaletteColor
    deriving (SGRTag -> SGRTag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SGRTag -> SGRTag -> Bool
$c/= :: SGRTag -> SGRTag -> Bool
== :: SGRTag -> SGRTag -> Bool
$c== :: SGRTag -> SGRTag -> Bool
Eq, Eq SGRTag
SGRTag -> SGRTag -> Bool
SGRTag -> SGRTag -> Ordering
SGRTag -> SGRTag -> SGRTag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SGRTag -> SGRTag -> SGRTag
$cmin :: SGRTag -> SGRTag -> SGRTag
max :: SGRTag -> SGRTag -> SGRTag
$cmax :: SGRTag -> SGRTag -> SGRTag
>= :: SGRTag -> SGRTag -> Bool
$c>= :: SGRTag -> SGRTag -> Bool
> :: SGRTag -> SGRTag -> Bool
$c> :: SGRTag -> SGRTag -> Bool
<= :: SGRTag -> SGRTag -> Bool
$c<= :: SGRTag -> SGRTag -> Bool
< :: SGRTag -> SGRTag -> Bool
$c< :: SGRTag -> SGRTag -> Bool
compare :: SGRTag -> SGRTag -> Ordering
$ccompare :: SGRTag -> SGRTag -> Ordering
Ord)

getSGRTag :: SGR -> SGRTag
getSGRTag :: SGR -> SGRTag
getSGRTag Reset{}                       = SGRTag
TagReset
getSGRTag SetConsoleIntensity{}         = SGRTag
TagConsoleIntensity
getSGRTag SetItalicized{}               = SGRTag
TagItalicized
getSGRTag SetUnderlining{}              = SGRTag
TagUnderlining
getSGRTag SetBlinkSpeed{}               = SGRTag
TagBlinkSpeed
getSGRTag SetVisible{}                  = SGRTag
TagVisible
getSGRTag SetSwapForegroundBackground{} = SGRTag
TagSwapForegroundBackground
getSGRTag (SetColor ConsoleLayer
Foreground ColorIntensity
_ Color
_)     = SGRTag
TagColorForeground
getSGRTag (SetColor ConsoleLayer
Background ColorIntensity
_ Color
_)     = SGRTag
TagColorBackground
getSGRTag SetRGBColor{}                 = SGRTag
TagRGBColor
getSGRTag SetPaletteColor{}             = SGRTag
TagPaletteColor

(<+>) :: StyleDoc -> StyleDoc -> StyleDoc
StyleDoc Doc StyleAnn
x <+> :: StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc Doc StyleAnn
y = Doc StyleAnn -> StyleDoc
StyleDoc (Doc StyleAnn
x forall a. Doc a -> Doc a -> Doc a
P.<+> Doc StyleAnn
y)

align :: StyleDoc -> StyleDoc
align :: StyleDoc -> StyleDoc
align = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> Doc a
P.align forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc

noAnnotate :: StyleDoc -> StyleDoc
noAnnotate :: StyleDoc -> StyleDoc
noAnnotate = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> Doc a
P.noAnnotate forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc

braces :: StyleDoc -> StyleDoc
braces :: StyleDoc -> StyleDoc
braces = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> Doc a
P.braces forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc

angles :: StyleDoc -> StyleDoc
angles :: StyleDoc -> StyleDoc
angles = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> Doc a
P.angles forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc

parens :: StyleDoc -> StyleDoc
parens :: StyleDoc -> StyleDoc
parens = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> Doc a
P.parens forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc

dquotes :: StyleDoc -> StyleDoc
dquotes :: StyleDoc -> StyleDoc
dquotes = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> Doc a
P.dquotes forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc

squotes :: StyleDoc -> StyleDoc
squotes :: StyleDoc -> StyleDoc
squotes = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> Doc a
P.squotes forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc

brackets :: StyleDoc -> StyleDoc
brackets :: StyleDoc -> StyleDoc
brackets = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> Doc a
P.brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc

-- | The document @string s@ concatenates all characters in @s@ using @line@ for
-- newline characters and @char@ for all other characters. It is used whenever
-- the text contains newline characters.
--
-- @since 0.1.4.0
string :: String -> StyleDoc
string :: String -> StyleDoc
string String
"" = forall a. Monoid a => a
mempty
string (Char
'\n':String
s) = StyleDoc
line forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string String
s
string String
s        = let (String
xs, String
ys) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/=Char
'\n') String
s
                  in  forall a. IsString a => String -> a
fromString String
xs forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string String
ys

annotate :: StyleAnn -> StyleDoc -> StyleDoc
annotate :: StyleAnn -> StyleDoc -> StyleDoc
annotate StyleAnn
a = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Doc a -> Doc a
P.annotate StyleAnn
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc

nest :: Int -> StyleDoc -> StyleDoc
nest :: Int -> StyleDoc -> StyleDoc
nest Int
a = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Doc a -> Doc a
P.nest Int
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc

line :: StyleDoc
line :: StyleDoc
line = Doc StyleAnn -> StyleDoc
StyleDoc forall a. Doc a
P.line

linebreak :: StyleDoc
linebreak :: StyleDoc
linebreak = Doc StyleAnn -> StyleDoc
StyleDoc forall a. Doc a
P.linebreak

fill :: Int -> StyleDoc -> StyleDoc
fill :: Int -> StyleDoc -> StyleDoc
fill Int
a = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Doc a -> Doc a
P.fill Int
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc

fillBreak :: Int -> StyleDoc -> StyleDoc
fillBreak :: Int -> StyleDoc -> StyleDoc
fillBreak Int
a = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Doc a -> Doc a
P.fillBreak Int
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc

enclose :: StyleDoc -> StyleDoc -> StyleDoc -> StyleDoc
enclose :: StyleDoc -> StyleDoc -> StyleDoc -> StyleDoc
enclose StyleDoc
l StyleDoc
r StyleDoc
x = StyleDoc
l forall a. Semigroup a => a -> a -> a
<> StyleDoc
x forall a. Semigroup a => a -> a -> a
<> StyleDoc
r

cat :: [StyleDoc] -> StyleDoc
cat :: [StyleDoc] -> StyleDoc
cat = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Doc a] -> Doc a
P.cat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map StyleDoc -> Doc StyleAnn
unStyleDoc

punctuate :: StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate :: StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate (StyleDoc Doc StyleAnn
x) = forall a b. (a -> b) -> [a] -> [b]
map Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> [Doc a] -> [Doc a]
P.punctuate Doc StyleAnn
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map StyleDoc -> Doc StyleAnn
unStyleDoc

fillCat :: [StyleDoc] -> StyleDoc
fillCat :: [StyleDoc] -> StyleDoc
fillCat = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Doc a] -> Doc a
P.fillCat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map StyleDoc -> Doc StyleAnn
unStyleDoc

hcat :: [StyleDoc] -> StyleDoc
hcat :: [StyleDoc] -> StyleDoc
hcat = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Doc a] -> Doc a
P.hcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map StyleDoc -> Doc StyleAnn
unStyleDoc

vcat :: [StyleDoc] -> StyleDoc
vcat :: [StyleDoc] -> StyleDoc
vcat = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Doc a] -> Doc a
P.vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map StyleDoc -> Doc StyleAnn
unStyleDoc

sep :: [StyleDoc] -> StyleDoc
sep :: [StyleDoc] -> StyleDoc
sep = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Doc a] -> Doc a
P.sep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map StyleDoc -> Doc StyleAnn
unStyleDoc

vsep :: [StyleDoc] -> StyleDoc
vsep :: [StyleDoc] -> StyleDoc
vsep = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Doc a] -> Doc a
P.vsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map StyleDoc -> Doc StyleAnn
unStyleDoc

hsep :: [StyleDoc] -> StyleDoc
hsep :: [StyleDoc] -> StyleDoc
hsep = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Doc a] -> Doc a
P.hsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map StyleDoc -> Doc StyleAnn
unStyleDoc

fillSep :: [StyleDoc] -> StyleDoc
fillSep :: [StyleDoc] -> StyleDoc
fillSep = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Doc a] -> Doc a
P.fillSep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map StyleDoc -> Doc StyleAnn
unStyleDoc

encloseSep :: StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
encloseSep :: StyleDoc -> StyleDoc -> StyleDoc -> [StyleDoc] -> StyleDoc
encloseSep (StyleDoc Doc StyleAnn
x) (StyleDoc Doc StyleAnn
y) (StyleDoc Doc StyleAnn
z) =
  Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> Doc a -> Doc a -> [Doc a] -> Doc a
P.encloseSep Doc StyleAnn
x Doc StyleAnn
y Doc StyleAnn
z forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map StyleDoc -> Doc StyleAnn
unStyleDoc

indent :: Int -> StyleDoc -> StyleDoc
indent :: Int -> StyleDoc -> StyleDoc
indent Int
a = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Doc a -> Doc a
P.indent Int
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc

hang :: Int -> StyleDoc -> StyleDoc
hang :: Int -> StyleDoc -> StyleDoc
hang Int
a = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Doc a -> Doc a
P.hang Int
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc

softbreak :: StyleDoc
softbreak :: StyleDoc
softbreak = Doc StyleAnn -> StyleDoc
StyleDoc forall a. Doc a
P.softbreak

softline :: StyleDoc
softline :: StyleDoc
softline = Doc StyleAnn -> StyleDoc
StyleDoc forall a. Doc a
P.softline

group :: StyleDoc -> StyleDoc
group :: StyleDoc -> StyleDoc
group = Doc StyleAnn -> StyleDoc
StyleDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> Doc a
P.group forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleDoc -> Doc StyleAnn
unStyleDoc