Chunk.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

module Text.Colour.Chunk where

import Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as ByteString
import Data.Maybe
import Data.String
import Data.Text (Text)
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as LTB
import qualified Data.Text.Lazy.Builder as Text
import qualified Data.Text.Lazy.Encoding as LTE
import Data.Validity
import Data.Word
import GHC.Generics (Generic)
import Text.Colour.Capabilities
import Text.Colour.Code

data Chunk = Chunk
  { chunkText :: !Text,
    chunkItalic :: !(Maybe Bool),
    chunkConsoleIntensity :: !(Maybe ConsoleIntensity),
    chunkUnderlining :: !(Maybe Underlining),
    chunkForeground :: !(Maybe Colour),
    chunkBackground :: !(Maybe Colour)
  }
  deriving (Show, Eq, Generic)

instance Validity Chunk

instance IsString Chunk where
  fromString = chunk . fromString

plainChunk :: TerminalCapabilities -> Chunk -> Bool
plainChunk tc Chunk {..} =
  and
    [ isNothing chunkItalic,
      isNothing chunkConsoleIntensity,
      isNothing chunkUnderlining,
      maybe True (plainColour tc) chunkForeground,
      maybe True (plainColour tc) chunkBackground
    ]

plainColour :: TerminalCapabilities -> Colour -> Bool
plainColour tc = \case
  Colour8 {} -> tc < With8Colours
  Colour8Bit {} -> tc < With8BitColours
  Colour24Bit {} -> tc < With24BitColours

-- | Render chunks directly to a UTF8-encoded 'Bytestring'.
renderChunksUtf8BS :: Foldable f => TerminalCapabilities -> f Chunk -> ByteString
renderChunksUtf8BS tc = TE.encodeUtf8 . renderChunksText tc

-- | Deprecated synonym for 'renderChunksUtf8BS'
renderChunksBS :: Foldable f => TerminalCapabilities -> f Chunk -> ByteString
renderChunksBS = renderChunksUtf8BS
{-# DEPRECATED renderChunksBS "Use renderChunksText, or renderChunksUtf8BS if you must." #-}

-- | Render chunks to a UTF8-encoded 'ByteString' 'Bytestring.Builder'.
renderChunksUtf8BSBuilder :: Foldable f => TerminalCapabilities -> f Chunk -> ByteString.Builder
renderChunksUtf8BSBuilder tc = foldMap (renderChunkUtf8BSBuilder tc)

-- | Deprecated synonym for 'renderChunksUtf8BSBuilder'
renderChunks :: Foldable f => TerminalCapabilities -> f Chunk -> ByteString.Builder
renderChunks = renderChunksUtf8BSBuilder
{-# DEPRECATED renderChunks "Use renderChunksBuilder, or renderChunksUtf8BSBuilder if you must." #-}

-- | Render chunks directly to strict 'Text'.
renderChunksText :: Foldable f => TerminalCapabilities -> f Chunk -> Text
renderChunksText tc = LT.toStrict . renderChunksLazyText tc

-- | Render chunks directly to lazy 'LT.Text'.
renderChunksLazyText :: Foldable f => TerminalCapabilities -> f Chunk -> LT.Text
renderChunksLazyText tc = LTB.toLazyText . renderChunksBuilder tc

-- | Render chunks to a lazy 'LT.Text' 'Text.Builder'
renderChunksBuilder :: Foldable f => TerminalCapabilities -> f Chunk -> Text.Builder
renderChunksBuilder tc = foldMap (renderChunkBuilder tc)

-- | Render a chunk directly to a UTF8-encoded 'Bytestring'.
renderChunkUtf8BS :: TerminalCapabilities -> Chunk -> ByteString
renderChunkUtf8BS tc = TE.encodeUtf8 . renderChunkText tc

-- | Deprecated synonym for 'renderChunkUtf8BS'
renderChunkBS :: TerminalCapabilities -> Chunk -> ByteString
renderChunkBS = renderChunkUtf8BS
{-# DEPRECATED renderChunkBS "Use renderChunkText, or renderChunkUtf8BS if you must." #-}

-- | Render a chunk directly to a UTF8-encoded 'Bytestring' 'ByteString.Builder'.
renderChunkUtf8BSBuilder :: TerminalCapabilities -> Chunk -> ByteString.Builder
renderChunkUtf8BSBuilder tc = LTE.encodeUtf8Builder . renderChunkLazyText tc

-- | Deprecated synonym for 'renderChunkUtf8BSBuilder'
renderChunk :: TerminalCapabilities -> Chunk -> ByteString.Builder
renderChunk = renderChunkUtf8BSBuilder
{-# DEPRECATED renderChunk "Use renderChunkBuilder, or renderChunkUtf8BSBuilder if you must." #-}

-- | Render a chunk directly to strict 'Text'.
renderChunkText :: TerminalCapabilities -> Chunk -> Text
renderChunkText tc = LT.toStrict . renderChunkLazyText tc

-- | Render a chunk directly to strict 'LT.Text'.
renderChunkLazyText :: TerminalCapabilities -> Chunk -> LT.Text
renderChunkLazyText tc = LTB.toLazyText . renderChunkBuilder tc

-- | Render a chunk to a lazy 'LT.Text' 'Text.Builder'
renderChunkBuilder :: TerminalCapabilities -> Chunk -> Text.Builder
renderChunkBuilder tc c@Chunk {..} =
  if plainChunk tc c
    then LTB.fromText chunkText
    else
      mconcat
        [ renderCSI (SGR (chunkSGR tc c)),
          LTB.fromText chunkText,
          renderCSI (SGR [Reset])
        ]

chunkSGR :: TerminalCapabilities -> Chunk -> [SGR]
chunkSGR tc Chunk {..} =
  catMaybes
    [ SetItalic <$> chunkItalic,
      SetUnderlining <$> chunkUnderlining,
      SetConsoleIntensity <$> chunkConsoleIntensity,
      chunkForeground >>= colourSGR tc Foreground,
      chunkBackground >>= colourSGR tc Background
    ]

-- | Turn a text into a plain chunk, without any styling
chunk :: Text -> Chunk
chunk t =
  Chunk
    { chunkText = t,
      chunkItalic = Nothing,
      chunkConsoleIntensity = Nothing,
      chunkUnderlining = Nothing,
      chunkForeground = Nothing,
      chunkBackground = Nothing
    }

fore :: Colour -> Chunk -> Chunk
fore col chu = chu {chunkForeground = Just col}

back :: Colour -> Chunk -> Chunk
back col chu = chu {chunkBackground = Just col}

bold :: Chunk -> Chunk
bold chu = chu {chunkConsoleIntensity = Just BoldIntensity}

faint :: Chunk -> Chunk
faint chu = chu {chunkConsoleIntensity = Just FaintIntensity}

italic :: Chunk -> Chunk
italic chu = chu {chunkItalic = Just True}

underline :: Chunk -> Chunk
underline chu = chu {chunkUnderlining = Just SingleUnderline}

doubleUnderline :: Chunk -> Chunk
doubleUnderline chu = chu {chunkUnderlining = Just DoubleUnderline}

-- TODO consider allowing an 8-colour alternative to a given 256-colour
data Colour
  = Colour8 !ColourIntensity !TerminalColour
  | Colour8Bit !Word8 -- The 8-bit colour
  | Colour24Bit !Word8 !Word8 !Word8
  deriving (Show, Eq, Generic)

instance Validity Colour

colourSGR :: TerminalCapabilities -> ConsoleLayer -> Colour -> Maybe SGR
colourSGR tc layer =
  let cap tc' sgr = if tc >= tc' then Just sgr else Nothing
   in \case
        Colour8 intensity terminalColour -> cap With8Colours $ SetColour intensity layer terminalColour
        Colour8Bit w -> cap With8BitColours $ Set8BitColour layer w
        Colour24Bit r g b -> cap With24BitColours $ Set24BitColour layer r g b

black :: Colour
black = Colour8 Dull Black

red :: Colour
red = Colour8 Dull Red

green :: Colour
green = Colour8 Dull Green

yellow :: Colour
yellow = Colour8 Dull Yellow

blue :: Colour
blue = Colour8 Dull Blue

magenta :: Colour
magenta = Colour8 Dull Magenta

cyan :: Colour
cyan = Colour8 Dull Cyan

white :: Colour
white = Colour8 Dull White

brightBlack :: Colour
brightBlack = Colour8 Bright Black

brightRed :: Colour
brightRed = Colour8 Bright Red

brightGreen :: Colour
brightGreen = Colour8 Bright Green

brightYellow :: Colour
brightYellow = Colour8 Bright Yellow

brightBlue :: Colour
brightBlue = Colour8 Bright Blue

brightMagenta :: Colour
brightMagenta = Colour8 Bright Magenta

brightCyan :: Colour
brightCyan = Colour8 Bright Cyan

brightWhite :: Colour
brightWhite = Colour8 Bright White

-- | Bulid an 8-bit RGB Colour
--
-- This will not be rendered unless 'With8BitColours' is used.
colour256 :: Word8 -> Colour
colour256 = Colour8Bit

-- | Alias for 'colour256', bloody americans...
color256 :: Word8 -> Colour
color256 = colour256

-- | Bulid a 24-bit RGB Colour
--
-- This will not be rendered unless 'With24BitColours' is used.
colourRGB :: Word8 -> Word8 -> Word8 -> Colour
colourRGB = Colour24Bit

-- | Alias for 'colourRGB', bloody americans...
colorRGB :: Word8 -> Word8 -> Word8 -> Colour
colorRGB = Colour24Bit