module System.Terminal.Pretty where

import           Data.Text                     as T
import           Data.Text.Prettyprint.Doc
import           Prelude                   hiding (putChar)

import           System.Terminal.MonadPrinter

-- | Print an annotated `Doc`.
--
-- Example:
--
-- @
-- import System.Terminal
-- import Data.Text.Prettyprint.Doc
--
-- printer :: (`MonadFormatingPrinter` m, `MonadColorPrinter` m) => m ()
-- printer = `putDoc` $ `annotate` (foreground $ `bright` `blue`) "This is blue!" <> `line`
--                 <> `annotate` `bold` ("Just bold!" <> otherDoc <> "..just bold again")
--
-- otherDoc :: (`MonadColorPrinter` m, `Attribute` m ~ ann) => `Doc` ann
-- otherDoc = `annotate` (`background` `red`) " BOLD ON RED BACKGROUND "
-- @
--
-- Note the necessary unification of `Attribute` `m` and `ann` in the definition of `otherDoc`!
putDoc :: (MonadMarkupPrinter m) => Doc (Attribute m) -> m ()
putDoc :: forall (m :: * -> *).
MonadMarkupPrinter m =>
Doc (Attribute m) -> m ()
putDoc Doc (Attribute m)
doc = do
    Int
w <- m Int
forall (m :: * -> *). MonadPrinter m => m Int
getLineWidth
    SimpleDocStream (Attribute m) -> m ()
forall (m :: * -> *).
MonadMarkupPrinter m =>
SimpleDocStream (Attribute m) -> m ()
putSimpleDocStream (Int -> SimpleDocStream (Attribute m)
sdoc Int
w)
    where
        options :: Int -> LayoutOptions
options Int
w = LayoutOptions
defaultLayoutOptions { layoutPageWidth = AvailablePerLine w 1.0 }
        sdoc :: Int -> SimpleDocStream (Attribute m)
sdoc Int
w    = LayoutOptions -> Doc (Attribute m) -> SimpleDocStream (Attribute m)
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart (Int -> LayoutOptions
options Int
w) Doc (Attribute m)
doc

-- | Like `putDoc` but adds an additional newline.
putDocLn :: (MonadMarkupPrinter m) => Doc (Attribute m) -> m ()
putDocLn :: forall (m :: * -> *).
MonadMarkupPrinter m =>
Doc (Attribute m) -> m ()
putDocLn Doc (Attribute m)
doc = Doc (Attribute m) -> m ()
forall (m :: * -> *).
MonadMarkupPrinter m =>
Doc (Attribute m) -> m ()
putDoc Doc (Attribute m)
doc m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: * -> *). MonadPrinter m => m ()
putLn

-- | Prints types instantiating the `Pretty` class.
putPretty :: (MonadMarkupPrinter m, Pretty a) => a -> m ()
putPretty :: forall (m :: * -> *) a.
(MonadMarkupPrinter m, Pretty a) =>
a -> m ()
putPretty a
a = Doc (Attribute m) -> m ()
forall (m :: * -> *).
MonadMarkupPrinter m =>
Doc (Attribute m) -> m ()
putDoc (a -> Doc (Attribute m)
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
a)

-- | Prints types instantiating the `Pretty` class and adds an additional newline.
putPrettyLn :: (MonadMarkupPrinter m, Pretty a) => a -> m ()
putPrettyLn :: forall (m :: * -> *) a.
(MonadMarkupPrinter m, Pretty a) =>
a -> m ()
putPrettyLn a
a = a -> m ()
forall (m :: * -> *) a.
(MonadMarkupPrinter m, Pretty a) =>
a -> m ()
putPretty a
a m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: * -> *). MonadPrinter m => m ()
putLn

-- | Prints `SimpleDocStream`s (rather internal and not for the average user).
putSimpleDocStream :: (MonadMarkupPrinter m) => SimpleDocStream (Attribute m) -> m ()
putSimpleDocStream :: forall (m :: * -> *).
MonadMarkupPrinter m =>
SimpleDocStream (Attribute m) -> m ()
putSimpleDocStream SimpleDocStream (Attribute m)
sdoc = do
    m ()
forall (m :: * -> *). MonadMarkupPrinter m => m ()
resetAttributes
    [Attribute m] -> SimpleDocStream (Attribute m) -> m ()
forall {m :: * -> *}.
MonadMarkupPrinter m =>
[Attribute m] -> SimpleDocStream (Attribute m) -> m ()
f [] SimpleDocStream (Attribute m)
sdoc
    where
        f :: [Attribute m] -> SimpleDocStream (Attribute m) -> m ()
f [Attribute m]
_       SimpleDocStream (Attribute m)
SFail          = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        f [Attribute m]
_       SimpleDocStream (Attribute m)
SEmpty         = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        f    [Attribute m]
aa  (SChar Char
c    SimpleDocStream (Attribute m)
xx) = Char -> m ()
forall (m :: * -> *). MonadPrinter m => Char -> m ()
putChar Char
c                             m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Attribute m] -> SimpleDocStream (Attribute m) -> m ()
f    [Attribute m]
aa  SimpleDocStream (Attribute m)
xx
        f    [Attribute m]
aa  (SText Int
_ Text
t  SimpleDocStream (Attribute m)
xx) = Text -> m ()
forall (m :: * -> *). MonadPrinter m => Text -> m ()
putText Text
t                             m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Attribute m] -> SimpleDocStream (Attribute m) -> m ()
f    [Attribute m]
aa  SimpleDocStream (Attribute m)
xx
        f    [Attribute m]
aa  (SLine Int
i    SimpleDocStream (Attribute m)
xx) = m ()
forall (m :: * -> *). MonadPrinter m => m ()
putLn m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> m ()
forall (m :: * -> *). MonadPrinter m => Text -> m ()
putText (Int -> Text -> Text
T.replicate Int
i Text
" ")  m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Attribute m] -> SimpleDocStream (Attribute m) -> m ()
f    [Attribute m]
aa  SimpleDocStream (Attribute m)
xx
        f    [Attribute m]
aa  (SAnnPush Attribute m
a SimpleDocStream (Attribute m)
xx) = Attribute m -> m ()
forall (m :: * -> *). MonadMarkupPrinter m => Attribute m -> m ()
setAttribute Attribute m
a                        m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Attribute m] -> SimpleDocStream (Attribute m) -> m ()
f (Attribute m
aAttribute m -> [Attribute m] -> [Attribute m]
forall a. a -> [a] -> [a]
:[Attribute m]
aa) SimpleDocStream (Attribute m)
xx
        f    []  (SAnnPop    SimpleDocStream (Attribute m)
xx) =                                          [Attribute m] -> SimpleDocStream (Attribute m) -> m ()
f    []  SimpleDocStream (Attribute m)
xx
        f (Attribute m
a:[Attribute m]
aa) (SAnnPop    SimpleDocStream (Attribute m)
xx) = case (Attribute m -> Bool) -> [Attribute m] -> [Attribute m]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Attribute m -> Attribute m -> Bool
forall (m :: * -> *).
MonadMarkupPrinter m =>
Attribute m -> Attribute m -> Bool
resetsAttribute Attribute m
a) [Attribute m]
aa of
            []    -> Attribute m -> m ()
forall (m :: * -> *). MonadMarkupPrinter m => Attribute m -> m ()
resetAttribute Attribute m
a m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Attribute m] -> SimpleDocStream (Attribute m) -> m ()
f [Attribute m]
aa SimpleDocStream (Attribute m)
xx
            (Attribute m
e:[Attribute m]
_) -> Attribute m -> m ()
forall (m :: * -> *). MonadMarkupPrinter m => Attribute m -> m ()
setAttribute   Attribute m
e m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Attribute m] -> SimpleDocStream (Attribute m) -> m ()
f [Attribute m]
aa SimpleDocStream (Attribute m)
xx