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

-- | This module is based, in part, on some of the interface for

-- "Text.PrettyPrint.Annotated.Leijen".

--

module Text.PrettyPrint.Leijen.Extended
  (
    -- * Pretty-print typeclass

    Pretty (..)

    -- * Documents annotated by a style

  , StyleDoc (..)
  , StyleAnn (..)
  , displayAnsi
  , displayPlain
  , renderDefault

    -- * Selective use of the "Text.PrettyPrint.Annotated.Leijen" interface

    --

    -- | Documented omissions by reference to package

    -- @annotated-wl-pprint-0.7.0@.


    -- ** Documents, parametrized by their annotations

    --

    -- | Omitted compared to original:

    --

    -- @

    -- Doc, putDoc, hPutDoc

    -- @


    -- ** Basic combinators

    --

    -- | Omitted compared to the original:

    --

    -- @

    -- empty, char, text, (<>)

    -- @

    --

    -- Instead of @empty@, use 'mempty'.

    --

    -- Instead of @char@ and @text@, use 'fromString'.

    --

    -- A 'Monoid' instance for 'StyleDoc' is defined.

  , 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 the original:

    --

    -- @

    -- list, tupled, semiBraces

    -- @

  , align
  , hang
  , indent
  , encloseSep

    -- ** Operators

    --

    -- | Omitted compared to the 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

  -- | Entirely omitted:

  --

  -- @

  -- SimpleDoc (..), renderPretty, renderCompact, displayDecorated,

  -- displayDecoratedA, display, displayS, displayIO, SpanList (..),

  -- displaySpans

  -- @


  -- ** Undocumented

  -- | Entirely omitted:

  --

  -- @

  -- column, nesting, width

  -- @

  ) where

import           Control.Monad.Reader ( local, runReader )
import           Data.Array.IArray ( (!), (//) )
import qualified Data.Text as T
import           Distribution.ModuleName ( ModuleName )
import           Distribution.System ( Arch (..), OS (..) )
import qualified Distribution.Text ( display )
import           Distribution.Utils.Generic ( lowercase )
import           Path ( Dir, File, Path, SomeBase, prjSomeBase, toFilePath )
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
                   ( HasStylesUpdate, StylesUpdate (..), 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 (SomeBase File) where
  pretty :: SomeBase File -> StyleDoc
pretty = forall t a. (forall b. Path b t -> a) -> SomeBase t -> a
prjSomeBase forall a. Pretty a => a -> StyleDoc
pretty

instance Pretty (SomeBase Dir) where
  pretty :: SomeBase Dir -> StyleDoc
pretty = forall t a. (forall b. Path b t -> a) -> SomeBase t -> a
prjSomeBase forall a. Pretty a => a -> StyleDoc
pretty

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

instance Pretty Arch where
  pretty :: Arch -> StyleDoc
pretty (OtherArch String
name) = forall a. IsString a => String -> a
fromString String
name
  pretty Arch
other = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ String -> String
lowercase forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Arch
other

instance Pretty OS where
  pretty :: OS -> StyleDoc
pretty (OtherOS String
name) = forall a. IsString a => String -> a
fromString String
name
  pretty OS
other = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ String -> String
lowercase forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show OS
other

--------------------------------------------------------------------------------

-- 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 -> String -> String
[StyleAnn] -> String -> String
StyleAnn -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [StyleAnn] -> String -> String
$cshowList :: [StyleAnn] -> String -> String
show :: StyleAnn -> String
$cshow :: StyleAnn -> String
showsPrec :: Int -> StyleAnn -> String -> String
$cshowsPrec :: Int -> StyleAnn -> String -> String
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 -> String -> String
[StyleDoc] -> String -> String
StyleDoc -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [StyleDoc] -> String -> String
$cshowList :: [StyleDoc] -> String -> String
show :: StyleDoc -> String
$cshow :: StyleDoc -> String
showsPrec :: Int -> StyleDoc -> String -> String
$cshowsPrec :: Int -> StyleDoc -> String -> String
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 -> String -> String
[AnsiAnn] -> String -> String
AnsiAnn -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [AnsiAnn] -> String -> String
$cshowList :: [AnsiAnn] -> String -> String
show :: AnsiAnn -> String
$cshow :: AnsiAnn -> String
showsPrec :: Int -> AnsiAnn -> String -> String
$cshowsPrec :: Int -> AnsiAnn -> String -> String
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

-- | The document @(x \<+\> y)@ concatenates document @x@ and @y@ with a

-- @(fromString \"\ \")@ in between. (infixr 6)

(<+>) :: 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)

-- | The document @(align x)@ renders document @x@ with the nesting level set to

-- the current column. It is used for example to implement 'hang'.

--

-- As an example, we will put a document right above another one, regardless of

-- the current nesting level:

--

-- > x $$ y = align (x <> line <> y)

--

-- > test = fromString "hi" <+> (fromString "nice" $$ fromString "world")

--

-- which will be layed out as:

--

-- @

-- hi nice

--    world

-- @

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

-- | Strip annotations from a document. This is useful for re-using the textual

-- formatting of some sub-document, but applying a different high-level

-- annotation.

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

-- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and \"}\".

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

-- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and \"\>\".

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

-- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\" and

-- \")\".

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

-- | Document @(dquotes x)@ encloses document @x@ with double quotes '\"'.

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

-- | Document @(squotes x)@ encloses document @x@ with single quotes \"'\".

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

-- | Document @(brackets x)@ encloses document @x@ in square brackets, \"[\" and

-- \"]\".

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 @fromString@ 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

-- | The document @(nest i x)@ renders document @x@ with the current indentation

-- level increased by i (See also 'hang', 'align' and 'indent').

--

-- >    nest 2 (fromString "hello" <> line <> fromString "world")

-- > <> line

-- > <> fromString "!"

--

-- outputs as:

--

-- @

-- hello

--   world

-- !

-- @

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

-- | The @line@ document advances to the next line and indents to the current

-- nesting level. Document @line@ behaves like @(fromString \" \")@ if the line

-- break is undone by 'group'.

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

-- | The @linebreak@ document advances to the next line and indents to the

-- current nesting level. Document @linebreak@ behaves like 'mempty' if the line

-- break is undone by 'group'.

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

-- | The document @(fill i x)@ renders document @x@. It than appends

-- @(fromString \"\ \")@s until the width is equal to @i@. If the width of @x@

-- is already larger, nothing is appended. This combinator is quite useful in

-- practice to output a list of bindings. The following example demonstrates

-- this.

--

-- > types = [ ("empty", "Doc a")

-- >         , ("nest", "Int -> Doc a -> Doc a")

-- >         , ("linebreak", "Doc a")

-- >         ]

-- >

-- > ptype (name, tp) =

-- >   fill 6 (fromString name) <+> fromString "::" <+> fromString tp

-- >

-- > test = fromString "let" <+> align (vcat (map ptype types))

--

-- Which is layed out as:

--

-- @

-- let empty  :: Doc a

--     nest   :: Int -> Doc a -> Doc a

--     linebreak :: Doc a

-- @

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

-- | The document @(fillBreak i x)@ first renders document @x@. It then appends

-- @(fromString \"\ \")@s until the width is equal to @i@. If the width of @x@

-- is already larger than @i@, the nesting level is increased by @i@ and a

-- @line@ is appended. When we redefine @ptype@ in the previous example to use

-- @fillBreak@, we get a useful variation of the previous output:

--

-- > ptype (name, tp) =

-- >   fillBreak 6 (fromString name) <+> fromString "::" <+> fromString tp

--

-- The output will now be:

--

-- @

-- let empty  :: Doc a

--     nest   :: Int -> Doc a -> Doc a

--     linebreak

--            :: Doc a

-- @

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

-- | The document @(enclose l r x)@ encloses document @x@ between documents @l@

-- and @r@ using @(\<\>)@.

--

-- > enclose l r x   = l <> x <> r

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

-- | The document @(cat xs)@ concatenates all documents @xs@ either

-- horizontally with @(\<\>)@, if it fits the page, or vertically with

-- @(\<\> linebreak \<\>)@.

--

-- > cat xs = group (vcat xs)

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 p xs)@ concatenates all documents in @xs@ with document @p@

-- except for the last document.

--

-- > someText = map fromString ["words", "in", "a", "tuple"]

-- > test = parens (align (cat (punctuate comma someText)))

--

-- This is layed out on a page width of 20 as:

--

-- @

-- (words,in,a,tuple)

-- @

--

-- But when the page width is 15, it is layed out as:

--

-- @

-- (words,

--  in,

--  a,

--  tuple)

-- @

--

-- (If you want put the commas in front of their elements instead of at the end,

-- you should use 'encloseSep'.)

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

-- | The document @(fillCat xs)@ concatenates documents @xs@ horizontally with

-- @(\<\>)@ as long as its fits the page, than inserts a @linebreak@ and

-- continues doing that for all documents in @xs@.

--

-- > fillCat xs = foldr (<> softbreak <>) mempty xs

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

-- | The document @(hcat xs)@ concatenates all documents @xs@ horizontally with

-- @(\<\>)@.

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

-- | The document @(vcat xs)@ concatenates all documents @xs@ vertically with

-- @(\<\> linebreak \<\>)@. If a 'group' undoes the line breaks inserted by

-- 'vcat', all documents are directly concatenated.

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

-- | The document @(sep xs)@ concatenates all documents @xs@ either horizontally

-- with @(\<+\>)@, if it fits the page, or vertically with @(\<\> line \<\>)@.

--

-- > sep xs = group (vsep xs)

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

-- | The document @(vsep xs)@ concatenates all documents @xs@ vertically with

-- @(\<\> line \<\>)@. If a 'group' undoes the line breaks inserted by 'vsep',

-- all documents are separated with a space.

--

-- > someText = map fromString (words ("text to lay out"))

-- >

-- > test = fromString "some" <+> vsep someText

--

-- This is layed out as:

--

-- @

-- some text

-- to

-- lay

-- out

-- @

--

-- The 'align' combinator can be used to align the documents under their first

-- element

--

-- > test = fromString "some" <+> align (vsep someText)

--

-- Which is printed as:

--

-- @

-- some text

--      to

--      lay

--      out

-- @

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

-- | The document @(hsep xs)@ concatenates all documents @xs@ horizontally with

-- @('<+>')@.

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

-- | The document @(fillSep xs)@ concatenates documents @xs@ horizontally with

-- @('<+>')@ as long as its fits the page, than inserts a 'line' and continues

-- doing that for all documents in @xs@.

--

-- > fillSep xs = foldr (<> softline <>) mempty xs

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

-- | The document @(encloseSep l r sep xs)@ concatenates the documents @xs@

-- separated by @sep@ and encloses the resulting document by @l@ and @r@. The

-- documents are rendered horizontally if that fits the page. Otherwise they are

-- aligned vertically. All separators are put in front of the elements. For

-- example, the combinator 'list' can be defined with 'encloseSep':

--

-- > list xs = encloseSep lbracket rbracket comma xs

-- > test = fromString "list" <+> (list (map int [10, 200, 3000]))

--

-- Which is layed out with a page width of 20 as:

--

-- @

-- list [10,200,3000]

-- @

--

-- But when the page width is 15, it is layed out as:

--

-- @

-- list [10

--      ,200

--      ,3000]

-- @

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

-- | The document @(indent i x)@ indents document @x@ with @i@ spaces.

--

-- > test = indent 4 (fillSep (map fromString

-- >        (words "the indent combinator indents these words !")))

--

-- Which lays out with a page width of 20 as:

--

-- @

--     the indent

--     combinator

--     indents these

--     words !

-- @

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

-- | The hang combinator implements hanging indentation. The document

-- @(hang i x)@ renders document @x@ with a nesting level set to the current

-- column plus @i@. The following example uses hanging indentation for some

-- text:

--

-- > test = hang 4 (fillSep (map fromString

-- >        (words "the hang combinator indents these words !")))

--

-- Which lays out on a page with a width of 20 characters as:

--

-- @

-- the hang combinator

--     indents these

--     words !

-- @

--

-- The @hang@ combinator is implemented as:

--

-- > hang i x = align (nest i x)

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

-- | The document @softbreak@ behaves like 'mempty' if the resulting output fits

-- the page, otherwise it behaves like 'line'.

--

-- > softbreak = group linebreak

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

-- | The document @softline@ behaves like @(fromString \"\ \")@ if the resulting

-- output fits the page, otherwise it behaves like 'line'.

--

-- > softline = group line

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

-- | The @group@ combinator is used to specify alternative layouts. The document

-- @(group x)@ undoes all line breaks in document @x@. The resulting line is

-- added to the current line if that fits the page. Otherwise, the document @x@

-- is rendered without any changes.

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