{-# LANGUAGE CPP               #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}

#include "version-compatibility-macros.h"

-- | Render 'SimpleDocStream' in a terminal.
module Data.Text.Prettyprint.Doc.Render.Terminal (
    -- * Styling
    AnsiTerminal(..), Color(..), Intensity(..), Layer(..),

    -- ** Font color convenience definitions
    color, colorDull,
    --
    -- ** Background color convenience definitions
    bgColor, bgColorDull,

    -- ** Font style convenience definitions
    bold, italics, underline,

    -- * Conversion to ANSI-infused 'Text'
    renderLazy, renderStrict,

    -- * Render directly to 'stdout'
    renderIO,

    -- ** Convenience functions
    putDoc, hPutDoc,
) where



import           Control.Monad
import           Data.Functor
import           Data.Maybe
import           Data.Text              (Text)
import qualified Data.Text              as T
import qualified Data.Text.Lazy         as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.IO      as TL
import qualified System.Console.ANSI    as ANSI
import           System.IO              (Handle, stdout)

import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Util.Panic
import Data.Text.Prettyprint.Doc.Render.Util.StackMachine

#if !(APPLICATIVE_MONAD)
import Control.Applicative
#endif



-- $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



-- | A general ANSI style. Use e.g. 'color' or 'bold' to apply a style to a
-- 'Doc'ument.
data AnsiTerminal =
      Italicized
    | Bold
    | Underlined
    | Color Layer Intensity Color
    deriving (Eq, Ord, Show)

-- | 8 different colors, so that all can be displayed in an ANSI terminal.
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)

-- | Style the foreground with a vivid color.
color :: Color -> Doc AnsiTerminal -> Doc AnsiTerminal
color c = annotate (Color Foreground Vivid c)

-- | Style the background with a vivid color.
bgColor :: Color -> Doc AnsiTerminal -> Doc AnsiTerminal
bgColor c = annotate (Color Background Vivid c)

-- | Style the foreground with a dull color.
colorDull :: Color -> Doc AnsiTerminal -> Doc AnsiTerminal
colorDull c = annotate (Color Foreground Dull c)

-- | Style the background with a dull color.
bgColorDull :: Color -> Doc AnsiTerminal -> Doc AnsiTerminal
bgColorDull c = annotate (Color Background Dull c)

-- | Render the enclosed document in __bold__.
bold :: Doc AnsiTerminal -> Doc AnsiTerminal
bold = annotate Bold

-- | Render the enclosed document in /italics/.
italics :: Doc AnsiTerminal -> Doc AnsiTerminal
italics = annotate Italicized

-- | Render the enclosed document underlined.
underline :: Doc AnsiTerminal -> Doc AnsiTerminal
underline = annotate 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 = color Red ("red" <+> align (vsep [color Blue ("blue" <+> bold "bold" <+> "blue"), "red"]))
-- >>> render (unAnnotate doc)
-- red blue bold blue
--     red
-- >>> render doc
-- \e[0;91mred \e[0;94mblue \e[0;94;1mbold\e[0;94m blue\e[0;91m
--     red\e[0m
--
-- Run the above via @echo -e '...'@ in your terminal to see the coloring.
renderLazy :: SimpleDocStream AnsiTerminal -> TL.Text
renderLazy doc
  = let (resultBuilder, remainingStyles) = execStackMachine [emptyStyle] (build doc)
    in case remainingStyles of
        [] -> error ("There is no empty style left at the end of rendering" ++
                     " (but there should be). Please report this as a bug.")
        [_] -> TLB.toLazyText resultBuilder
        xs -> error ("There are " <> show (length xs) <> " styles left at the" ++
                     "end of rendering (there should be only 1). Please report" ++
                     " this as a bug.")

build :: SimpleDocStream AnsiTerminal -> StackMachine TLB.Builder CombinedStyle ()
build = \case
    SFail -> panicUncaughtFail
    SEmpty -> pure ()
    SChar c x -> do
        writeOutput (TLB.singleton c)
        build x
    SText _l t x -> do
        writeOutput (TLB.fromText t)
        build x
    SLine i x -> do
        writeOutput (TLB.singleton '\n')
        writeOutput (TLB.fromText (T.replicate i " "))
        build x
    SAnnPush s x -> do
        currentStyle <- unsafePeekStyle
        let newStyle = currentStyle `addStyle` s
        writeOutput (styleToBuilder newStyle)
        pushStyle newStyle
        build x
    SAnnPop x -> do
        _currentStyle <- unsafePopStyle
        newStyle <- unsafePeekStyle
        writeOutput (styleToBuilder newStyle)
        build x

styleToBuilder :: CombinedStyle -> TLB.Builder
styleToBuilder = TLB.fromString . ANSI.setSGRCode . stylesToSgrs

data CombinedStyle = CombinedStyle
    (Maybe (Intensity, Color)) -- Foreground
    (Maybe (Intensity, Color)) -- Background
    Bool                       -- Bold
    Bool                       -- Italics
    Bool                       -- Underlining

addStyle :: CombinedStyle -> AnsiTerminal -> CombinedStyle
addStyle (CombinedStyle m'fg m'bg b i u) = \case
    Italicized              -> CombinedStyle m'fg m'bg b True u
    Bold                    -> CombinedStyle m'fg m'bg True i u
    Underlined              -> CombinedStyle m'fg m'bg b i True
    Color Foreground dv col -> CombinedStyle (Just (dv, col)) m'bg b i u
    Color Background dv col -> CombinedStyle m'fg (Just (dv, col)) b i u

emptyStyle :: CombinedStyle
emptyStyle = CombinedStyle Nothing Nothing False False False

stylesToSgrs :: CombinedStyle -> [ANSI.SGR]
stylesToSgrs (CombinedStyle m'fg m'bg b i u) = catMaybes
    [ Just ANSI.Reset
    , fmap (\(intensity, c) -> ANSI.SetColor ANSI.Foreground (convertIntensity intensity) (convertColor c)) m'fg
    , fmap (\(intensity, c) -> ANSI.SetColor ANSI.Background (convertIntensity intensity) (convertColor c)) m'bg
    , guard b $> ANSI.SetConsoleIntensity ANSI.BoldIntensity
    , guard i $> ANSI.SetItalicized True
    , guard u $> ANSI.SetUnderlining ANSI.SingleUnderline
    ]
  where
    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



-- | @('renderStrict' sdoc)@ takes the output @sdoc@ from a rendering and
-- transforms it to strict text.
renderStrict :: SimpleDocStream AnsiTerminal -> Text
renderStrict = TL.toStrict . renderLazy



-- | @('renderIO' h sdoc)@ writes @sdoc@ to the file @h@.
--
-- >>> renderIO System.IO.stdout (layoutPretty defaultLayoutOptions "hello\nworld")
-- hello
-- world
renderIO :: Handle -> SimpleDocStream AnsiTerminal -> IO ()
renderIO h sdoc = TL.hPutStrLn h (renderLazy sdoc)

-- | @('putDoc' doc)@ prettyprints document @doc@ to standard output, with a page
-- width of 80 characters and a ribbon width of 32 characters.
--
-- >>> putDoc ("hello" <+> "world")
-- hello world
--
-- @
-- 'putDoc' = 'hPutDoc' 'stdout'
-- @
putDoc :: Doc AnsiTerminal -> IO ()
putDoc = hPutDoc stdout

-- | Like 'putDoc', but instead of using 'stdout', print to a user-provided
-- handle, e.g. a file or a socket. Uses a line length of 80, and a ribbon width
-- of 32 characters.
--
-- > main = withFile "someFile.txt" (\h -> hPutDoc h (vcat ["vertical", "text"]))
--
-- @
-- 'hPutDoc' h doc = 'renderIO' h ('layoutPretty' 'defaultLayoutOptions' doc)
-- @
hPutDoc :: Handle -> Doc AnsiTerminal -> IO ()
hPutDoc h doc = renderIO h (layoutPretty defaultLayoutOptions doc)