{-# 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
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
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)
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
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
]
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}
data Colour
= Colour8 !ColourIntensity !TerminalColour
| Colour8Bit !Word8
| 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
colour256 :: Word8 -> Colour
colour256 :: Word8 -> Colour
colour256 = Word8 -> Colour
Colour8Bit
color256 :: Word8 -> Colour
color256 :: Word8 -> Colour
color256 = Word8 -> Colour
colour256
colourRGB :: Word8 -> Word8 -> Word8 -> Colour
colourRGB :: Word8 -> Word8 -> Word8 -> Colour
colourRGB = Word8 -> Word8 -> Word8 -> Colour
Colour24Bit
colorRGB :: Word8 -> Word8 -> Word8 -> Colour
colorRGB :: Word8 -> Word8 -> Word8 -> Colour
colorRGB = Word8 -> Word8 -> Word8 -> Colour
Colour24Bit