{-# OPTIONS_HADDOCK hide #-}
module Byline.Internal.Stylized
( Stylized (..),
ToStylizedText (..),
text,
fg,
bg,
bold,
underline,
swapFgBg,
RenderMode (..),
render,
renderText,
)
where
import Byline.Internal.Color (Color)
import qualified Byline.Internal.Color as Color
import Byline.Internal.Types (Modifier (..), OnlyOne (..), Status (..))
import qualified Data.Text.IO as Text
import qualified System.Console.ANSI as ANSI
data Stylized a
=
Stylized Modifier a
|
StylizedList [Stylized a]
deriving (Int -> Stylized a -> ShowS
forall a. Show a => Int -> Stylized a -> ShowS
forall a. Show a => [Stylized a] -> ShowS
forall a. Show a => Stylized a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stylized a] -> ShowS
$cshowList :: forall a. Show a => [Stylized a] -> ShowS
show :: Stylized a -> String
$cshow :: forall a. Show a => Stylized a -> String
showsPrec :: Int -> Stylized a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Stylized a -> ShowS
Show, Stylized a -> Stylized a -> Bool
forall a. Eq a => Stylized a -> Stylized a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Stylized a -> Stylized a -> Bool
$c/= :: forall a. Eq a => Stylized a -> Stylized a -> Bool
== :: Stylized a -> Stylized a -> Bool
$c== :: forall a. Eq a => Stylized a -> Stylized a -> Bool
Eq, forall a b. a -> Stylized b -> Stylized a
forall a b. (a -> b) -> Stylized a -> Stylized b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Stylized b -> Stylized a
$c<$ :: forall a b. a -> Stylized b -> Stylized a
fmap :: forall a b. (a -> b) -> Stylized a -> Stylized b
$cfmap :: forall a b. (a -> b) -> Stylized a -> Stylized b
Functor, forall a. Eq a => a -> Stylized a -> Bool
forall a. Num a => Stylized a -> a
forall a. Ord a => Stylized a -> a
forall m. Monoid m => Stylized m -> m
forall a. Stylized a -> Bool
forall a. Stylized a -> Int
forall a. Stylized a -> [a]
forall a. (a -> a -> a) -> Stylized a -> a
forall m a. Monoid m => (a -> m) -> Stylized a -> m
forall b a. (b -> a -> b) -> b -> Stylized a -> b
forall a b. (a -> b -> b) -> b -> Stylized a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Stylized a -> a
$cproduct :: forall a. Num a => Stylized a -> a
sum :: forall a. Num a => Stylized a -> a
$csum :: forall a. Num a => Stylized a -> a
minimum :: forall a. Ord a => Stylized a -> a
$cminimum :: forall a. Ord a => Stylized a -> a
maximum :: forall a. Ord a => Stylized a -> a
$cmaximum :: forall a. Ord a => Stylized a -> a
elem :: forall a. Eq a => a -> Stylized a -> Bool
$celem :: forall a. Eq a => a -> Stylized a -> Bool
length :: forall a. Stylized a -> Int
$clength :: forall a. Stylized a -> Int
null :: forall a. Stylized a -> Bool
$cnull :: forall a. Stylized a -> Bool
toList :: forall a. Stylized a -> [a]
$ctoList :: forall a. Stylized a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Stylized a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Stylized a -> a
foldr1 :: forall a. (a -> a -> a) -> Stylized a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Stylized a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Stylized a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Stylized a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Stylized a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Stylized a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Stylized a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Stylized a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Stylized a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Stylized a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Stylized a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Stylized a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Stylized a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Stylized a -> m
fold :: forall m. Monoid m => Stylized m -> m
$cfold :: forall m. Monoid m => Stylized m -> m
Foldable, Functor Stylized
Foldable Stylized
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Stylized (m a) -> m (Stylized a)
forall (f :: * -> *) a.
Applicative f =>
Stylized (f a) -> f (Stylized a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Stylized a -> m (Stylized b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Stylized a -> f (Stylized b)
sequence :: forall (m :: * -> *) a. Monad m => Stylized (m a) -> m (Stylized a)
$csequence :: forall (m :: * -> *) a. Monad m => Stylized (m a) -> m (Stylized a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Stylized a -> m (Stylized b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Stylized a -> m (Stylized b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Stylized (f a) -> f (Stylized a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Stylized (f a) -> f (Stylized a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Stylized a -> f (Stylized b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Stylized a -> f (Stylized b)
Traversable)
instance Semigroup (Stylized a) where
<> :: Stylized a -> Stylized a -> Stylized a
(<>) a :: Stylized a
a@(Stylized Modifier
_ a
_) b :: Stylized a
b@(Stylized Modifier
_ a
_) = forall a. [Stylized a] -> Stylized a
StylizedList [Stylized a
a, Stylized a
b]
(<>) a :: Stylized a
a@(Stylized Modifier
_ a
_) (StylizedList [Stylized a]
b) = forall a. [Stylized a] -> Stylized a
StylizedList (Stylized a
a forall a. a -> [a] -> [a]
: [Stylized a]
b)
(<>) (StylizedList [Stylized a]
l) t :: Stylized a
t@(Stylized Modifier
_ a
_) = forall a. [Stylized a] -> Stylized a
StylizedList ([Stylized a]
l forall a. Semigroup a => a -> a -> a
<> [Stylized a
t])
(<>) (StylizedList [Stylized a]
l) (StylizedList [Stylized a]
l') = forall a. [Stylized a] -> Stylized a
StylizedList ([Stylized a]
l forall a. Semigroup a => a -> a -> a
<> [Stylized a]
l')
instance Monoid (Stylized a) where
mempty :: Stylized a
mempty = forall a. [Stylized a] -> Stylized a
StylizedList []
instance IsString (Stylized Text) where
fromString :: String -> Stylized Text
fromString = Text -> Stylized Text
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToText a => a -> Text
toText
class ToStylizedText a where
toStylizedText :: a -> Stylized Text
instance ToStylizedText (Stylized Text) where
toStylizedText :: Stylized Text -> Stylized Text
toStylizedText = forall a. a -> a
id
text :: Text -> Stylized Text
text :: Text -> Stylized Text
text = forall a. Modifier -> a -> Stylized a
Stylized forall a. Monoid a => a
mempty
fg :: Color -> Stylized Text -> Stylized Text
fg :: Color -> Stylized Text -> Stylized Text
fg Color
c (Stylized Modifier
m Text
t) = forall a. Modifier -> a -> Stylized a
Stylized (Modifier
m {modColorFG :: OnlyOne Color
modColorFG = forall a. Maybe a -> OnlyOne a
OnlyOne (forall a. a -> Maybe a
Just Color
c)}) Text
t
fg Color
c (StylizedList [Stylized Text]
l) = forall a. [Stylized a] -> Stylized a
StylizedList (forall a b. (a -> b) -> [a] -> [b]
map (Color -> Stylized Text -> Stylized Text
fg Color
c) [Stylized Text]
l)
bg :: Color -> Stylized Text -> Stylized Text
bg :: Color -> Stylized Text -> Stylized Text
bg Color
c (Stylized Modifier
m Text
t) = forall a. Modifier -> a -> Stylized a
Stylized (Modifier
m {modColorBG :: OnlyOne Color
modColorBG = forall a. Maybe a -> OnlyOne a
OnlyOne (forall a. a -> Maybe a
Just Color
c)}) Text
t
bg Color
c (StylizedList [Stylized Text]
l) = forall a. [Stylized a] -> Stylized a
StylizedList (forall a b. (a -> b) -> [a] -> [b]
map (Color -> Stylized Text -> Stylized Text
bg Color
c) [Stylized Text]
l)
bold :: Stylized Text -> Stylized Text
bold :: Stylized Text -> Stylized Text
bold (Stylized Modifier
m Text
t) = forall a. Modifier -> a -> Stylized a
Stylized (Modifier
m {modBold :: Status
modBold = Status
On}) Text
t
bold (StylizedList [Stylized Text]
l) = forall a. [Stylized a] -> Stylized a
StylizedList (forall a b. (a -> b) -> [a] -> [b]
map Stylized Text -> Stylized Text
bold [Stylized Text]
l)
underline :: Stylized Text -> Stylized Text
underline :: Stylized Text -> Stylized Text
underline (Stylized Modifier
m Text
t) = forall a. Modifier -> a -> Stylized a
Stylized (Modifier
m {modUnderline :: Status
modUnderline = Status
On}) Text
t
underline (StylizedList [Stylized Text]
l) = forall a. [Stylized a] -> Stylized a
StylizedList (forall a b. (a -> b) -> [a] -> [b]
map Stylized Text -> Stylized Text
underline [Stylized Text]
l)
swapFgBg :: Stylized Text -> Stylized Text
swapFgBg :: Stylized Text -> Stylized Text
swapFgBg (Stylized Modifier
m Text
t) = forall a. Modifier -> a -> Stylized a
Stylized (Modifier
m {modSwapFgBg :: Status
modSwapFgBg = Status
On}) Text
t
swapFgBg (StylizedList [Stylized Text]
l) = forall a. [Stylized a] -> Stylized a
StylizedList (forall a b. (a -> b) -> [a] -> [b]
map Stylized Text -> Stylized Text
swapFgBg [Stylized Text]
l)
data RenderMode
=
Plain
|
Simple
|
Term256
|
TermRGB
data RenderInstruction
= RenderText Text
| RenderSGR [ANSI.SGR]
render :: RenderMode -> Handle -> Stylized Text -> IO ()
render :: RenderMode -> Handle -> Stylized Text -> IO ()
render RenderMode
mode Handle
h Stylized Text
stylized = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RenderInstruction -> IO ()
go (RenderMode -> Stylized Text -> [RenderInstruction]
renderInstructions RenderMode
mode Stylized Text
stylized)
where
go :: RenderInstruction -> IO ()
go :: RenderInstruction -> IO ()
go (RenderText Text
t) = Handle -> Text -> IO ()
Text.hPutStr Handle
h Text
t
go (RenderSGR [SGR]
s) = Handle -> [SGR] -> IO ()
ANSI.hSetSGR Handle
h [SGR]
s
renderText :: RenderMode -> Stylized Text -> Text
renderText :: RenderMode -> Stylized Text -> Text
renderText RenderMode
mode Stylized Text
stylized = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap RenderInstruction -> Text
go (RenderMode -> Stylized Text -> [RenderInstruction]
renderInstructions RenderMode
mode Stylized Text
stylized)
where
go :: RenderInstruction -> Text
go :: RenderInstruction -> Text
go = \case
RenderText Text
t -> Text
t
RenderSGR [SGR]
s ->
forall a. ToText a => a -> Text
toText ([SGR] -> String
ANSI.setSGRCode [SGR]
s) forall a. Semigroup a => a -> a -> a
<> Text
"\STX"
renderInstructions :: RenderMode -> Stylized Text -> [RenderInstruction]
renderInstructions :: RenderMode -> Stylized Text -> [RenderInstruction]
renderInstructions RenderMode
mode = \case
Stylized Modifier
m Text
t -> RenderMode -> (Text, Modifier) -> [RenderInstruction]
renderMod RenderMode
mode (Text
t, Modifier
m)
StylizedList [Stylized Text]
xs -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (RenderMode -> Stylized Text -> [RenderInstruction]
renderInstructions RenderMode
mode) [Stylized Text]
xs
where
renderMod :: RenderMode -> (Text, Modifier) -> [RenderInstruction]
renderMod :: RenderMode -> (Text, Modifier) -> [RenderInstruction]
renderMod RenderMode
mode (Text
t, Modifier
m) =
case RenderMode
mode of
RenderMode
Plain ->
[Text -> RenderInstruction
RenderText Text
t]
RenderMode
Simple ->
let color :: ConsoleLayer -> Color -> SGR
color ConsoleLayer
l Color
c = case Color
c of
Color.ColorCode ColorIntensity
ai Color
ac -> ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
l ColorIntensity
ai Color
ac
Color
rgb -> ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
l ColorIntensity
ANSI.Dull (Color -> Color
Color.colorAsANSI Color
rgb)
in Text
-> Modifier
-> (ConsoleLayer -> Color -> SGR)
-> [RenderInstruction]
renderToSGR Text
t Modifier
m ConsoleLayer -> Color -> SGR
color
RenderMode
Term256 ->
let color :: ConsoleLayer -> Color -> SGR
color ConsoleLayer
l = ConsoleLayer -> Word8 -> SGR
ANSI.SetPaletteColor ConsoleLayer
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Word8
Color.colorAsIndex256
in Text
-> Modifier
-> (ConsoleLayer -> Color -> SGR)
-> [RenderInstruction]
renderToSGR Text
t Modifier
m ConsoleLayer -> Color -> SGR
color
RenderMode
TermRGB ->
let color :: ConsoleLayer -> Color -> SGR
color ConsoleLayer
l Color
c = case Color -> Either (ColorIntensity, Color) (Colour Float)
Color.colorAsRGB Color
c of
Left (ColorIntensity
ai,Color
ac) -> ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
l ColorIntensity
ai Color
ac
Right Colour Float
rgb -> ConsoleLayer -> Colour Float -> SGR
ANSI.SetRGBColor ConsoleLayer
l Colour Float
rgb
in Text
-> Modifier
-> (ConsoleLayer -> Color -> SGR)
-> [RenderInstruction]
renderToSGR Text
t Modifier
m ConsoleLayer -> Color -> SGR
color
renderToSGR ::
Text ->
Modifier ->
(ANSI.ConsoleLayer -> Color -> ANSI.SGR) ->
[RenderInstruction]
renderToSGR :: Text
-> Modifier
-> (ConsoleLayer -> Color -> SGR)
-> [RenderInstruction]
renderToSGR Text
t Modifier
m ConsoleLayer -> Color -> SGR
f =
[ [SGR] -> RenderInstruction
RenderSGR (Modifier -> (ConsoleLayer -> Color -> SGR) -> [SGR]
modToSGR Modifier
m ConsoleLayer -> Color -> SGR
f),
Text -> RenderInstruction
RenderText Text
t,
[SGR] -> RenderInstruction
RenderSGR [SGR
ANSI.Reset]
]
modToSGR ::
Modifier ->
(ANSI.ConsoleLayer -> Color -> ANSI.SGR) ->
[ANSI.SGR]
modToSGR :: Modifier -> (ConsoleLayer -> Color -> SGR) -> [SGR]
modToSGR Modifier
mod ConsoleLayer -> Color -> SGR
colorF =
forall a. [Maybe a] -> [a]
catMaybes
[ ConsoleLayer -> Color -> SGR
colorF ConsoleLayer
ANSI.Foreground forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Modifier -> OnlyOne Color) -> Maybe Color
getColor Modifier -> OnlyOne Color
modColorFG,
ConsoleLayer -> Color -> SGR
colorF ConsoleLayer
ANSI.Background forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Modifier -> OnlyOne Color) -> Maybe Color
getColor Modifier -> OnlyOne Color
modColorBG,
ConsoleIntensity -> SGR
ANSI.SetConsoleIntensity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ConsoleIntensity
getIntensity,
Underlining -> SGR
ANSI.SetUnderlining forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Underlining
getUnderlining,
Bool -> SGR
ANSI.SetSwapForegroundBackground forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Bool
getSwapForegroundBackground
]
where
getColor :: (Modifier -> OnlyOne Color) -> Maybe Color
getColor :: (Modifier -> OnlyOne Color) -> Maybe Color
getColor Modifier -> OnlyOne Color
f = forall a. OnlyOne a -> Maybe a
unOne (Modifier -> OnlyOne Color
f Modifier
mod)
getIntensity :: Maybe ANSI.ConsoleIntensity
getIntensity :: Maybe ConsoleIntensity
getIntensity = case Modifier -> Status
modBold Modifier
mod of
Status
Off -> forall a. Maybe a
Nothing
Status
On -> forall a. a -> Maybe a
Just ConsoleIntensity
ANSI.BoldIntensity
getUnderlining :: Maybe ANSI.Underlining
getUnderlining :: Maybe Underlining
getUnderlining = case Modifier -> Status
modUnderline Modifier
mod of
Status
Off -> forall a. Maybe a
Nothing
Status
On -> forall a. a -> Maybe a
Just Underlining
ANSI.SingleUnderline
getSwapForegroundBackground :: Maybe Bool
getSwapForegroundBackground :: Maybe Bool
getSwapForegroundBackground = case Modifier -> Status
modSwapFgBg Modifier
mod of
Status
Off -> forall a. Maybe a
Nothing
Status
On -> forall a. a -> Maybe a
Just Bool
True