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

module Text.Colour.Chunk where

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

data Chunk = Chunk
  { Chunk -> Text
chunkText :: !Text,
    Chunk -> Maybe Bool
chunkItalic :: !(Maybe Bool),
    Chunk -> Maybe ConsoleIntensity
chunkConsoleIntensity :: !(Maybe ConsoleIntensity),
    Chunk -> Maybe Underlining
chunkUnderlining :: !(Maybe Underlining),
    Chunk -> Maybe Colour
chunkForeground :: !(Maybe Colour),
    Chunk -> Maybe Colour
chunkBackground :: !(Maybe Colour)
  }
  deriving (Int -> Chunk -> ShowS
[Chunk] -> ShowS
Chunk -> String
(Int -> Chunk -> ShowS)
-> (Chunk -> String) -> ([Chunk] -> ShowS) -> Show Chunk
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Chunk] -> ShowS
$cshowList :: [Chunk] -> ShowS
show :: Chunk -> String
$cshow :: Chunk -> String
showsPrec :: Int -> Chunk -> ShowS
$cshowsPrec :: Int -> Chunk -> ShowS
Show, Chunk -> Chunk -> Bool
(Chunk -> Chunk -> Bool) -> (Chunk -> Chunk -> Bool) -> Eq Chunk
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Chunk -> Chunk -> Bool
$c/= :: Chunk -> Chunk -> Bool
== :: Chunk -> Chunk -> Bool
$c== :: Chunk -> Chunk -> Bool
Eq, (forall x. Chunk -> Rep Chunk x)
-> (forall x. Rep Chunk x -> Chunk) -> Generic Chunk
forall x. Rep Chunk x -> Chunk
forall x. Chunk -> Rep Chunk x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Chunk x -> Chunk
$cfrom :: forall x. Chunk -> Rep Chunk x
Generic)

instance Validity Chunk

instance IsString Chunk where
  fromString :: String -> Chunk
fromString = Text -> Chunk
chunk (Text -> Chunk) -> (String -> Text) -> String -> Chunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString

plainChunk :: TerminalCapabilities -> Chunk -> Bool
plainChunk :: TerminalCapabilities -> Chunk -> Bool
plainChunk TerminalCapabilities
tc Chunk {Maybe Bool
Maybe ConsoleIntensity
Maybe Underlining
Maybe Colour
Text
chunkBackground :: Maybe Colour
chunkForeground :: Maybe Colour
chunkUnderlining :: Maybe Underlining
chunkConsoleIntensity :: Maybe ConsoleIntensity
chunkItalic :: Maybe Bool
chunkText :: Text
chunkBackground :: Chunk -> Maybe Colour
chunkForeground :: Chunk -> Maybe Colour
chunkUnderlining :: Chunk -> Maybe Underlining
chunkConsoleIntensity :: Chunk -> Maybe ConsoleIntensity
chunkItalic :: Chunk -> Maybe Bool
chunkText :: Chunk -> Text
..} =
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
    [ Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Bool
chunkItalic,
      Maybe ConsoleIntensity -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ConsoleIntensity
chunkConsoleIntensity,
      Maybe Underlining -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Underlining
chunkUnderlining,
      Bool -> (Colour -> Bool) -> Maybe Colour -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (TerminalCapabilities -> Colour -> Bool
plainColour TerminalCapabilities
tc) Maybe Colour
chunkForeground,
      Bool -> (Colour -> Bool) -> Maybe Colour -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (TerminalCapabilities -> Colour -> Bool
plainColour TerminalCapabilities
tc) Maybe Colour
chunkBackground
    ]

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

-- | Render a chunk directly to bytestring.
renderChunksBS :: Foldable f => TerminalCapabilities -> f Chunk -> ByteString
renderChunksBS :: TerminalCapabilities -> f Chunk -> ByteString
renderChunksBS TerminalCapabilities
tc = ByteString -> ByteString
LB.toStrict (ByteString -> ByteString)
-> (f Chunk -> ByteString) -> f Chunk -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
SBB.toLazyByteString (Builder -> ByteString)
-> (f Chunk -> Builder) -> f Chunk -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TerminalCapabilities -> f Chunk -> Builder
forall (f :: * -> *).
Foldable f =>
TerminalCapabilities -> f Chunk -> Builder
renderChunks TerminalCapabilities
tc

-- | Render chunks to a bytestring builder
renderChunks :: Foldable f => TerminalCapabilities -> f Chunk -> Builder
renderChunks :: TerminalCapabilities -> f Chunk -> Builder
renderChunks TerminalCapabilities
tc = (Chunk -> Builder) -> f Chunk -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (TerminalCapabilities -> Chunk -> Builder
renderChunk TerminalCapabilities
tc)

-- | Render a chunk directly to bytestring.
renderChunkBS :: TerminalCapabilities -> Chunk -> ByteString
renderChunkBS :: TerminalCapabilities -> Chunk -> ByteString
renderChunkBS TerminalCapabilities
tc = ByteString -> ByteString
LB.toStrict (ByteString -> ByteString)
-> (Chunk -> ByteString) -> Chunk -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
SBB.toLazyByteString (Builder -> ByteString)
-> (Chunk -> Builder) -> Chunk -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TerminalCapabilities -> Chunk -> Builder
renderChunk TerminalCapabilities
tc

-- | Render a chunk to a bytestring builder
renderChunk :: TerminalCapabilities -> Chunk -> Builder
renderChunk :: TerminalCapabilities -> Chunk -> Builder
renderChunk TerminalCapabilities
tc c :: Chunk
c@Chunk {Maybe Bool
Maybe ConsoleIntensity
Maybe Underlining
Maybe Colour
Text
chunkBackground :: Maybe Colour
chunkForeground :: Maybe Colour
chunkUnderlining :: Maybe Underlining
chunkConsoleIntensity :: Maybe ConsoleIntensity
chunkItalic :: Maybe Bool
chunkText :: Text
chunkBackground :: Chunk -> Maybe Colour
chunkForeground :: Chunk -> Maybe Colour
chunkUnderlining :: Chunk -> Maybe Underlining
chunkConsoleIntensity :: Chunk -> Maybe ConsoleIntensity
chunkItalic :: Chunk -> Maybe Bool
chunkText :: Chunk -> Text
..} =
  if TerminalCapabilities -> Chunk -> Bool
plainChunk TerminalCapabilities
tc Chunk
c
    then ByteString -> Builder
SBB.byteString (Text -> ByteString
TE.encodeUtf8 Text
chunkText)
    else
      [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
        [ CSI -> Builder
renderCSI ([SGR] -> CSI
SGR ([SGR] -> CSI) -> [SGR] -> CSI
forall a b. (a -> b) -> a -> b
$ TerminalCapabilities -> Chunk -> [SGR]
chunkSGR TerminalCapabilities
tc Chunk
c),
          ByteString -> Builder
SBB.byteString (Text -> ByteString
TE.encodeUtf8 Text
chunkText),
          CSI -> Builder
renderCSI ([SGR] -> CSI
SGR [SGR
Reset])
        ]

chunkSGR :: TerminalCapabilities -> Chunk -> [SGR]
chunkSGR :: TerminalCapabilities -> Chunk -> [SGR]
chunkSGR TerminalCapabilities
tc Chunk {Maybe Bool
Maybe ConsoleIntensity
Maybe Underlining
Maybe Colour
Text
chunkBackground :: Maybe Colour
chunkForeground :: Maybe Colour
chunkUnderlining :: Maybe Underlining
chunkConsoleIntensity :: Maybe ConsoleIntensity
chunkItalic :: Maybe Bool
chunkText :: Text
chunkBackground :: Chunk -> Maybe Colour
chunkForeground :: Chunk -> Maybe Colour
chunkUnderlining :: Chunk -> Maybe Underlining
chunkConsoleIntensity :: Chunk -> Maybe ConsoleIntensity
chunkItalic :: Chunk -> Maybe Bool
chunkText :: Chunk -> Text
..} =
  [Maybe SGR] -> [SGR]
forall a. [Maybe a] -> [a]
catMaybes
    [ Bool -> SGR
SetItalic (Bool -> SGR) -> Maybe Bool -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Bool
chunkItalic,
      Underlining -> SGR
SetUnderlining (Underlining -> SGR) -> Maybe Underlining -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Underlining
chunkUnderlining,
      ConsoleIntensity -> SGR
SetConsoleIntensity (ConsoleIntensity -> SGR) -> Maybe ConsoleIntensity -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ConsoleIntensity
chunkConsoleIntensity,
      Maybe Colour
chunkForeground Maybe Colour -> (Colour -> Maybe SGR) -> Maybe SGR
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TerminalCapabilities -> ConsoleLayer -> Colour -> Maybe SGR
colourSGR TerminalCapabilities
tc ConsoleLayer
Foreground,
      Maybe Colour
chunkBackground Maybe Colour -> (Colour -> Maybe SGR) -> Maybe SGR
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TerminalCapabilities -> ConsoleLayer -> Colour -> Maybe SGR
colourSGR TerminalCapabilities
tc ConsoleLayer
Background
    ]

-- | Turn a text into a plain chunk, without any styling
chunk :: Text -> Chunk
chunk :: Text -> Chunk
chunk Text
t =
  Chunk :: Text
-> Maybe Bool
-> Maybe ConsoleIntensity
-> Maybe Underlining
-> Maybe Colour
-> Maybe Colour
-> Chunk
Chunk
    { chunkText :: Text
chunkText = Text
t,
      chunkItalic :: Maybe Bool
chunkItalic = Maybe Bool
forall a. Maybe a
Nothing,
      chunkConsoleIntensity :: Maybe ConsoleIntensity
chunkConsoleIntensity = Maybe ConsoleIntensity
forall a. Maybe a
Nothing,
      chunkUnderlining :: Maybe Underlining
chunkUnderlining = Maybe Underlining
forall a. Maybe a
Nothing,
      chunkForeground :: Maybe Colour
chunkForeground = Maybe Colour
forall a. Maybe a
Nothing,
      chunkBackground :: Maybe Colour
chunkBackground = Maybe Colour
forall a. Maybe a
Nothing
    }

fore :: Colour -> Chunk -> Chunk
fore :: Colour -> Chunk -> Chunk
fore Colour
col Chunk
chu = Chunk
chu {chunkForeground :: Maybe Colour
chunkForeground = Colour -> Maybe Colour
forall a. a -> Maybe a
Just Colour
col}

back :: Colour -> Chunk -> Chunk
back :: Colour -> Chunk -> Chunk
back Colour
col Chunk
chu = Chunk
chu {chunkBackground :: Maybe Colour
chunkBackground = Colour -> Maybe Colour
forall a. a -> Maybe a
Just Colour
col}

bold :: Chunk -> Chunk
bold :: Chunk -> Chunk
bold Chunk
chu = Chunk
chu {chunkConsoleIntensity :: Maybe ConsoleIntensity
chunkConsoleIntensity = ConsoleIntensity -> Maybe ConsoleIntensity
forall a. a -> Maybe a
Just ConsoleIntensity
BoldIntensity}

faint :: Chunk -> Chunk
faint :: Chunk -> Chunk
faint Chunk
chu = Chunk
chu {chunkConsoleIntensity :: Maybe ConsoleIntensity
chunkConsoleIntensity = ConsoleIntensity -> Maybe ConsoleIntensity
forall a. a -> Maybe a
Just ConsoleIntensity
FaintIntensity}

italic :: Chunk -> Chunk
italic :: Chunk -> Chunk
italic Chunk
chu = Chunk
chu {chunkItalic :: Maybe Bool
chunkItalic = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True}

underline :: Chunk -> Chunk
underline :: Chunk -> Chunk
underline Chunk
chu = Chunk
chu {chunkUnderlining :: Maybe Underlining
chunkUnderlining = Underlining -> Maybe Underlining
forall a. a -> Maybe a
Just Underlining
SingleUnderline}

doubleUnderline :: Chunk -> Chunk
doubleUnderline :: Chunk -> Chunk
doubleUnderline Chunk
chu = Chunk
chu {chunkUnderlining :: Maybe Underlining
chunkUnderlining = Underlining -> Maybe Underlining
forall a. a -> Maybe a
Just Underlining
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 (Int -> Colour -> ShowS
[Colour] -> ShowS
Colour -> String
(Int -> Colour -> ShowS)
-> (Colour -> String) -> ([Colour] -> ShowS) -> Show Colour
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Colour] -> ShowS
$cshowList :: [Colour] -> ShowS
show :: Colour -> String
$cshow :: Colour -> String
showsPrec :: Int -> Colour -> ShowS
$cshowsPrec :: Int -> Colour -> ShowS
Show, Colour -> Colour -> Bool
(Colour -> Colour -> Bool)
-> (Colour -> Colour -> Bool) -> Eq Colour
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Colour -> Colour -> Bool
$c/= :: Colour -> Colour -> Bool
== :: Colour -> Colour -> Bool
$c== :: Colour -> Colour -> Bool
Eq, (forall x. Colour -> Rep Colour x)
-> (forall x. Rep Colour x -> Colour) -> Generic Colour
forall x. Rep Colour x -> Colour
forall x. Colour -> Rep Colour x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Colour x -> Colour
$cfrom :: forall x. Colour -> Rep Colour x
Generic)

instance Validity Colour

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

black :: Colour
black :: Colour
black = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Dull TerminalColour
Black

red :: Colour
red :: Colour
red = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Dull TerminalColour
Red

green :: Colour
green :: Colour
green = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Dull TerminalColour
Green

yellow :: Colour
yellow :: Colour
yellow = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Dull TerminalColour
Yellow

blue :: Colour
blue :: Colour
blue = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Dull TerminalColour
Blue

magenta :: Colour
magenta :: Colour
magenta = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Dull TerminalColour
Magenta

cyan :: Colour
cyan :: Colour
cyan = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Dull TerminalColour
Cyan

white :: Colour
white :: Colour
white = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Dull TerminalColour
White

brightBlack :: Colour
brightBlack :: Colour
brightBlack = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Bright TerminalColour
Black

brightRed :: Colour
brightRed :: Colour
brightRed = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Bright TerminalColour
Red

brightGreen :: Colour
brightGreen :: Colour
brightGreen = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Bright TerminalColour
Green

brightYellow :: Colour
brightYellow :: Colour
brightYellow = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Bright TerminalColour
Yellow

brightBlue :: Colour
brightBlue :: Colour
brightBlue = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Bright TerminalColour
Blue

brightMagenta :: Colour
brightMagenta :: Colour
brightMagenta = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Bright TerminalColour
Magenta

brightCyan :: Colour
brightCyan :: Colour
brightCyan = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Bright TerminalColour
Cyan

brightWhite :: Colour
brightWhite :: Colour
brightWhite = ColourIntensity -> TerminalColour -> Colour
Colour8 ColourIntensity
Bright TerminalColour
White

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

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

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

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