{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module Termonad.Config.Colour
(
ColourConfig(..)
, defaultColourConfig
, lensCursorFgColour
, lensCursorBgColour
, lensForegroundColour
, lensBackgroundColour
, lensPalette
, ColourExtension(..)
, createColourExtension
, createDefColourExtension
, addColourExtension
, addColourConfig
, colourHook
, addColourHook
, Palette(..)
, defaultStandardColours
, defaultLightColours
, defaultColourCube
, defaultGreyscale
, AlphaColour
, createColour
, sRGB32
, sRGB32show
, opaque
, transparent
, showColourVec
, showColourCube
, paletteToList
, coloursFromBits
, cube
) where
import Termonad.Prelude hiding ((\\), index)
import Control.Lens ((%~), makeLensesFor)
import Data.Colour
( AlphaColour
, Colour
, affineCombo
, alphaChannel
, black
, darken
, opaque
, over
, transparent
, withOpacity
)
import Data.Colour.SRGB (RGB(RGB), toSRGB, toSRGB24, sRGB24)
import qualified Data.Foldable
import GI.Gdk
( RGBA
, newZeroRGBA
, setRGBAAlpha
, setRGBABlue
, setRGBAGreen
, setRGBARed
)
import GI.Vte
( Terminal
, terminalSetColors
, terminalSetColorCursor
#ifdef VTE_VERSION_GEQ_0_44
, terminalSetColorCursorForeground
#endif
, terminalSetColorBackground
, terminalSetColorForeground
)
import Text.Printf (printf)
import Text.Show (showString)
import Termonad.Config.Vec
import Termonad.Lenses (lensCreateTermHook, lensHooks)
import Termonad.Types
( Option(Unset)
, TMConfig
, TMState
, whenSet
)
data Palette c
= NoPalette
| BasicPalette !(Vec N8 c)
| ExtendedPalette !(Vec N8 c) !(Vec N8 c)
| ColourCubePalette !(Vec N8 c) !(Vec N8 c) !(Matrix '[N6, N6, N6] c)
| FullPalette !(Vec N8 c) !(Vec N8 c) !(Matrix '[N6, N6, N6] c) !(Vec N24 c)
deriving (Palette c -> Palette c -> Bool
(Palette c -> Palette c -> Bool)
-> (Palette c -> Palette c -> Bool) -> Eq (Palette c)
forall c. Eq c => Palette c -> Palette c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Palette c -> Palette c -> Bool
$c/= :: forall c. Eq c => Palette c -> Palette c -> Bool
== :: Palette c -> Palette c -> Bool
$c== :: forall c. Eq c => Palette c -> Palette c -> Bool
Eq, Int -> Palette c -> ShowS
[Palette c] -> ShowS
Palette c -> String
(Int -> Palette c -> ShowS)
-> (Palette c -> String)
-> ([Palette c] -> ShowS)
-> Show (Palette c)
forall c. Show c => Int -> Palette c -> ShowS
forall c. Show c => [Palette c] -> ShowS
forall c. Show c => Palette c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Palette c] -> ShowS
$cshowList :: forall c. Show c => [Palette c] -> ShowS
show :: Palette c -> String
$cshow :: forall c. Show c => Palette c -> String
showsPrec :: Int -> Palette c -> ShowS
$cshowsPrec :: forall c. Show c => Int -> Palette c -> ShowS
Show, a -> Palette b -> Palette a
(a -> b) -> Palette a -> Palette b
(forall a b. (a -> b) -> Palette a -> Palette b)
-> (forall a b. a -> Palette b -> Palette a) -> Functor Palette
forall a b. a -> Palette b -> Palette a
forall a b. (a -> b) -> Palette a -> Palette b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Palette b -> Palette a
$c<$ :: forall a b. a -> Palette b -> Palette a
fmap :: (a -> b) -> Palette a -> Palette b
$cfmap :: forall a b. (a -> b) -> Palette a -> Palette b
Functor, Palette a -> Bool
(a -> m) -> Palette a -> m
(a -> b -> b) -> b -> Palette a -> b
(forall m. Monoid m => Palette m -> m)
-> (forall m a. Monoid m => (a -> m) -> Palette a -> m)
-> (forall m a. Monoid m => (a -> m) -> Palette a -> m)
-> (forall a b. (a -> b -> b) -> b -> Palette a -> b)
-> (forall a b. (a -> b -> b) -> b -> Palette a -> b)
-> (forall b a. (b -> a -> b) -> b -> Palette a -> b)
-> (forall b a. (b -> a -> b) -> b -> Palette a -> b)
-> (forall a. (a -> a -> a) -> Palette a -> a)
-> (forall a. (a -> a -> a) -> Palette a -> a)
-> (forall a. Palette a -> [a])
-> (forall a. Palette a -> Bool)
-> (forall a. Palette a -> Int)
-> (forall a. Eq a => a -> Palette a -> Bool)
-> (forall a. Ord a => Palette a -> a)
-> (forall a. Ord a => Palette a -> a)
-> (forall a. Num a => Palette a -> a)
-> (forall a. Num a => Palette a -> a)
-> Foldable Palette
forall a. Eq a => a -> Palette a -> Bool
forall a. Num a => Palette a -> a
forall a. Ord a => Palette a -> a
forall m. Monoid m => Palette m -> m
forall a. Palette a -> Bool
forall a. Palette a -> Int
forall a. Palette a -> [a]
forall a. (a -> a -> a) -> Palette a -> a
forall m a. Monoid m => (a -> m) -> Palette a -> m
forall b a. (b -> a -> b) -> b -> Palette a -> b
forall a b. (a -> b -> b) -> b -> Palette 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 :: Palette a -> a
$cproduct :: forall a. Num a => Palette a -> a
sum :: Palette a -> a
$csum :: forall a. Num a => Palette a -> a
minimum :: Palette a -> a
$cminimum :: forall a. Ord a => Palette a -> a
maximum :: Palette a -> a
$cmaximum :: forall a. Ord a => Palette a -> a
elem :: a -> Palette a -> Bool
$celem :: forall a. Eq a => a -> Palette a -> Bool
length :: Palette a -> Int
$clength :: forall a. Palette a -> Int
null :: Palette a -> Bool
$cnull :: forall a. Palette a -> Bool
toList :: Palette a -> [a]
$ctoList :: forall a. Palette a -> [a]
foldl1 :: (a -> a -> a) -> Palette a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Palette a -> a
foldr1 :: (a -> a -> a) -> Palette a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Palette a -> a
foldl' :: (b -> a -> b) -> b -> Palette a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Palette a -> b
foldl :: (b -> a -> b) -> b -> Palette a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Palette a -> b
foldr' :: (a -> b -> b) -> b -> Palette a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Palette a -> b
foldr :: (a -> b -> b) -> b -> Palette a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Palette a -> b
foldMap' :: (a -> m) -> Palette a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Palette a -> m
foldMap :: (a -> m) -> Palette a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Palette a -> m
fold :: Palette m -> m
$cfold :: forall m. Monoid m => Palette m -> m
Foldable)
paletteToList :: Palette c -> [c]
paletteToList :: Palette c -> [c]
paletteToList = Palette c -> [c]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList
coloursFromBits :: forall b. (Ord b, Floating b) => Word8 -> Word8 -> Vec N8 (AlphaColour b)
coloursFromBits :: Word8 -> Word8 -> Vec N8 (AlphaColour b)
coloursFromBits scale :: Word8
scale offset :: Word8
offset = (Fin ('S ('S ('S ('S ('S ('S ('S ('S ZSym0))))))))
-> AlphaColour b)
-> Vec
('S ('S ('S ('S ('S ('S ('S ('S ZSym0)))))))) (AlphaColour b)
forall (n :: Peano) a. SingI n => (Fin n -> a) -> Vec n a
genVec_ Fin ('S ('S ('S ('S ('S ('S ('S ('S ZSym0)))))))) -> AlphaColour b
Fin N8 -> AlphaColour b
createElem
where
createElem :: Fin N8 -> AlphaColour b
createElem :: Fin N8 -> AlphaColour b
createElem finN :: Fin N8
finN =
let red :: Word8
red = Int -> Fin N8 -> Word8
cmp 0 Fin N8
finN
green :: Word8
green = Int -> Fin N8 -> Word8
cmp 1 Fin N8
finN
blue :: Word8
blue = Int -> Fin N8 -> Word8
cmp 2 Fin N8
finN
color :: AlphaColour b
color = Colour b -> AlphaColour b
forall a. Num a => Colour a -> AlphaColour a
opaque (Colour b -> AlphaColour b) -> Colour b -> AlphaColour b
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> Word8 -> Colour b
forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 Word8
red Word8
green Word8
blue
in AlphaColour b
color
cmp :: Int -> Fin N8 -> Word8
cmp :: Int -> Fin N8 -> Word8
cmp i :: Int
i = (Word8
offset Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+) (Word8 -> Word8)
-> (Fin ('S ('S ('S ('S ('S ('S ('S ('S ZSym0)))))))) -> Word8)
-> Fin ('S ('S ('S ('S ('S ('S ('S ('S ZSym0))))))))
-> Word8
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Word8
scale Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
*) (Word8 -> Word8)
-> (Fin ('S ('S ('S ('S ('S ('S ('S ('S ZSym0)))))))) -> Word8)
-> Fin ('S ('S ('S ('S ('S ('S ('S ('S ZSym0))))))))
-> Word8
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8)
-> (Fin ('S ('S ('S ('S ('S ('S ('S ('S ZSym0)))))))) -> Int)
-> Fin ('S ('S ('S ('S ('S ('S ('S ('S ZSym0))))))))
-> Word8
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Int -> Int
bit Int
i (Int -> Int)
-> (Fin ('S ('S ('S ('S ('S ('S ('S ('S ZSym0)))))))) -> Int)
-> Fin ('S ('S ('S ('S ('S ('S ('S ('S ZSym0))))))))
-> Int
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Fin ('S ('S ('S ('S ('S ('S ('S ('S ZSym0)))))))) -> Int
forall (n :: Peano). Fin n -> Int
toIntFin
bit :: Int -> Int -> Int
bit :: Int -> Int -> Int
bit m :: Int
m i :: Int
i = Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
m) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 2
defaultStandardColours :: (Ord b, Floating b) => Vec N8 (AlphaColour b)
defaultStandardColours :: Vec N8 (AlphaColour b)
defaultStandardColours = Word8 -> Word8 -> Vec N8 (AlphaColour b)
forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Vec N8 (AlphaColour b)
coloursFromBits 192 0
defaultLightColours :: (Ord b, Floating b) => Vec N8 (AlphaColour b)
defaultLightColours :: Vec N8 (AlphaColour b)
defaultLightColours = Word8 -> Word8 -> Vec N8 (AlphaColour b)
forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Vec N8 (AlphaColour b)
coloursFromBits 192 63
pureColour :: AlphaColour Double -> Colour Double
pureColour :: AlphaColour Double -> Colour Double
pureColour alaphaColour :: AlphaColour Double
alaphaColour
| Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = Double -> Colour Double -> Colour Double
forall (f :: * -> *) a. (ColourOps f, Num a) => a -> f a -> f a
darken (Double -> Double
forall a. Fractional a => a -> a
recip Double
a) (AlphaColour Double
alaphaColour AlphaColour Double -> Colour Double -> Colour Double
forall (f :: * -> *) a.
(ColourOps f, Num a) =>
AlphaColour a -> f a -> f a
`over` Colour Double
forall a. Num a => Colour a
black)
| Bool
otherwise = Colour Double
forall a. Num a => Colour a
black
where
a :: Double
a :: Double
a = AlphaColour Double -> Double
forall a. AlphaColour a -> a
alphaChannel AlphaColour Double
alaphaColour
quantize :: forall a b. (RealFrac a, Integral b, Bounded b) => a -> b
quantize :: a -> b
quantize x :: a
x
| a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= b -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
l = b
l
| b -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
h a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
x = b
h
| Bool
otherwise = a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round a
x
where
l :: b
l :: b
l = b
forall a. Bounded a => a
minBound
h :: b
h :: b
h = b
forall a. Bounded a => a
maxBound
sRGB32show :: AlphaColour Double -> String
sRGB32show :: AlphaColour Double -> String
sRGB32show c :: AlphaColour Double
c = String -> Word8 -> Word8 -> Word8 -> Word8 -> String
forall r. PrintfType r => String -> r
printf "#%02x%02x%02x%02x" Word8
r Word8
g Word8
b Word8
a
where
r, g, b :: Word8
RGB r :: Word8
r g :: Word8
g b :: Word8
b = Colour Double -> RGB Word8
forall b. (RealFrac b, Floating b) => Colour b -> RGB Word8
toSRGB24 (Colour Double -> RGB Word8) -> Colour Double -> RGB Word8
forall a b. (a -> b) -> a -> b
$ AlphaColour Double -> Colour Double
pureColour AlphaColour Double
c
a :: Word8
a :: Word8
a = Double -> Word8
forall a b. (RealFrac a, Integral b, Bounded b) => a -> b
quantize (255 Double -> Double -> Double
forall a. Num a => a -> a -> a
* AlphaColour Double -> Double
forall a. AlphaColour a -> a
alphaChannel AlphaColour Double
c)
sRGB32
:: Word8
-> Word8
-> Word8
-> Word8
-> AlphaColour Double
sRGB32 :: Word8 -> Word8 -> Word8 -> Word8 -> AlphaColour Double
sRGB32 r :: Word8
r g :: Word8
g b :: Word8
b 255 = Colour Double -> Double -> AlphaColour Double
forall a. Num a => Colour a -> a -> AlphaColour a
withOpacity (Word8 -> Word8 -> Word8 -> Colour Double
forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 Word8
r Word8
g Word8
b) 1
sRGB32 r :: Word8
r g :: Word8
g b :: Word8
b a :: Word8
a =
let aDouble :: Double
aDouble = Word8 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
a Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 255
in (Colour Double -> Double -> AlphaColour Double
forall a. Num a => Colour a -> a -> AlphaColour a
withOpacity (Word8 -> Word8 -> Word8 -> Colour Double
forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 Word8
r Word8
g Word8
b) Double
aDouble)
createColour
:: Word8
-> Word8
-> Word8
-> AlphaColour Double
createColour :: Word8 -> Word8 -> Word8 -> AlphaColour Double
createColour r :: Word8
r g :: Word8
g b :: Word8
b = Word8 -> Word8 -> Word8 -> Word8 -> AlphaColour Double
sRGB32 Word8
r Word8
g Word8
b 255
showColourVec :: forall n. Vec n (AlphaColour Double) -> [String]
showColourVec :: Vec n (AlphaColour Double) -> [String]
showColourVec = (AlphaColour Double -> String) -> [AlphaColour Double] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AlphaColour Double -> String
sRGB32show ([AlphaColour Double] -> [String])
-> (Vec n (AlphaColour Double) -> [AlphaColour Double])
-> Vec n (AlphaColour Double)
-> [String]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Vec n (AlphaColour Double) -> [AlphaColour Double]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList
cube ::
forall b. Fractional b
=> AlphaColour b
-> Vec N3 (AlphaColour b)
-> Matrix '[ N6, N6, N6] (AlphaColour b)
cube :: AlphaColour b
-> Vec N3 (AlphaColour b) -> Matrix '[N6, N6, N6] (AlphaColour b)
cube d :: AlphaColour b
d (i :: AlphaColour b
i :* j :: AlphaColour b
j :* k :: AlphaColour b
k :* EmptyVec) =
(HList
Fin
'[ 'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0)))))]
-> AlphaColour b)
-> Matrix '[N6, N6, N6] (AlphaColour b)
forall (ns :: [Peano]) a.
SingI ns =>
(HList Fin ns -> a) -> Matrix ns a
genMatrix_ ((HList
Fin
'[ 'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0)))))]
-> AlphaColour b)
-> Matrix '[N6, N6, N6] (AlphaColour b))
-> (HList
Fin
'[ 'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0)))))]
-> AlphaColour b)
-> Matrix '[N6, N6, N6] (AlphaColour b)
forall a b. (a -> b) -> a -> b
$
\(x :: Fin a
x :< y :: Fin a
y :< z :: Fin a
z :< EmptyHList) ->
[(b, AlphaColour b)] -> AlphaColour b -> AlphaColour b
forall (f :: * -> *) a.
(AffineSpace f, Num a) =>
[(a, f a)] -> f a -> f a
affineCombo [(1, AlphaColour b
d), (Fin N6 -> b
coef Fin a
Fin N6
x, AlphaColour b
i), (Fin N6 -> b
coef Fin a
Fin N6
y, AlphaColour b
j), (Fin N6 -> b
coef Fin a
Fin N6
z, AlphaColour b
k)] (AlphaColour b -> AlphaColour b) -> AlphaColour b -> AlphaColour b
forall a b. (a -> b) -> a -> b
$ Colour b -> AlphaColour b
forall a. Num a => Colour a -> AlphaColour a
opaque Colour b
forall a. Num a => Colour a
black
where
coef :: Fin N6 -> b
coef :: Fin N6 -> b
coef fin' :: Fin N6
fin' = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Fin ('S ('S ('S ('S ('S ('S ZSym0)))))) -> Int
forall (n :: Peano). Fin n -> Int
toIntFin Fin ('S ('S ('S ('S ('S ('S ZSym0))))))
Fin N6
fin') b -> b -> b
forall a. Fractional a => a -> a -> a
/ 5
defaultColourCube :: (Ord b, Floating b) => Matrix '[N6, N6, N6] (AlphaColour b)
defaultColourCube :: Matrix '[N6, N6, N6] (AlphaColour b)
defaultColourCube =
(HList
Fin
'[ 'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0)))))]
-> AlphaColour b)
-> Matrix '[N6, N6, N6] (AlphaColour b)
forall (ns :: [Peano]) a.
SingI ns =>
(HList Fin ns -> a) -> Matrix ns a
genMatrix_ ((HList
Fin
'[ 'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0)))))]
-> AlphaColour b)
-> Matrix '[N6, N6, N6] (AlphaColour b))
-> (HList
Fin
'[ 'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0)))))]
-> AlphaColour b)
-> Matrix '[N6, N6, N6] (AlphaColour b)
forall a b. (a -> b) -> a -> b
$ \(x :: Fin a
x :< y :: Fin a
y :< z :: Fin a
z :< EmptyHList) -> Colour b -> AlphaColour b
forall a. Num a => Colour a -> AlphaColour a
opaque (Colour b -> AlphaColour b) -> Colour b -> AlphaColour b
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> Word8 -> Colour b
forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 (Fin N6 -> Word8
cmp Fin a
Fin N6
x) (Fin N6 -> Word8
cmp Fin a
Fin N6
y) (Fin N6 -> Word8
cmp Fin a
Fin N6
z)
where
cmp :: Fin N6 -> Word8
cmp :: Fin N6 -> Word8
cmp i :: Fin N6
i =
let i' :: Word8
i' = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Fin ('S ('S ('S ('S ('S ('S ZSym0)))))) -> Int
forall (n :: Peano). Fin n -> Int
toIntFin Fin ('S ('S ('S ('S ('S ('S ZSym0))))))
Fin N6
i)
in Word8 -> Word8
forall a. Num a => a -> a
signum Word8
i' Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* 55 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ 40 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
i'
showColourCube :: Matrix '[N6, N6, N6] (AlphaColour Double) -> String
showColourCube :: Matrix '[N6, N6, N6] (AlphaColour Double) -> String
showColourCube matrix :: Matrix '[N6, N6, N6] (AlphaColour Double)
matrix =
let itemList :: [AlphaColour Double]
itemList = Matrix
'[ 'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0)))))]
(AlphaColour Double)
-> [AlphaColour Double]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList Matrix
'[ 'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0))))),
'S ('S ('S ('S ('S ('S ZSym0)))))]
(AlphaColour Double)
Matrix '[N6, N6, N6] (AlphaColour Double)
matrix
in [AlphaColour Double] -> ShowS
showSColourCube [AlphaColour Double]
itemList ""
where
showSColourCube :: [AlphaColour Double] -> String -> String
showSColourCube :: [AlphaColour Double] -> ShowS
showSColourCube itemList :: [AlphaColour Double]
itemList =
String -> ShowS
showString "[ " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Int -> [AlphaColour Double] -> ShowS
showSquare 0 [AlphaColour Double]
itemList ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Int -> [AlphaColour Double] -> ShowS
showSquare 1 [AlphaColour Double]
itemList ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Int -> [AlphaColour Double] -> ShowS
showSquare 2 [AlphaColour Double]
itemList ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Int -> [AlphaColour Double] -> ShowS
showSquare 3 [AlphaColour Double]
itemList ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Int -> [AlphaColour Double] -> ShowS
showSquare 4 [AlphaColour Double]
itemList ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Int -> [AlphaColour Double] -> ShowS
showSquare 5 [AlphaColour Double]
itemList ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString "]"
showSquare :: Int -> [AlphaColour Double] -> String -> String
showSquare :: Int -> [AlphaColour Double] -> ShowS
showSquare i :: Int
i colours :: [AlphaColour Double]
colours =
String -> ShowS
showString "[ " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Int -> Int -> [AlphaColour Double] -> ShowS
showRow Int
i 0 [AlphaColour Double]
colours ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Int -> Int -> [AlphaColour Double] -> ShowS
showRow Int
i 1 [AlphaColour Double]
colours ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Int -> Int -> [AlphaColour Double] -> ShowS
showRow Int
i 2 [AlphaColour Double]
colours ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Int -> Int -> [AlphaColour Double] -> ShowS
showRow Int
i 3 [AlphaColour Double]
colours ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Int -> Int -> [AlphaColour Double] -> ShowS
showRow Int
i 4 [AlphaColour Double]
colours ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Int -> Int -> [AlphaColour Double] -> ShowS
showRow Int
i 5 [AlphaColour Double]
colours ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString "]\n"
showRow :: Int -> Int -> [AlphaColour Double] -> String -> String
showRow :: Int -> Int -> [AlphaColour Double] -> ShowS
showRow i :: Int
i j :: Int
j colours :: [AlphaColour Double]
colours =
AlphaColour Double -> ShowS
showCol ([AlphaColour Double] -> AlphaColour Double
forall mono. MonoFoldable mono => mono -> Element mono
headEx ([AlphaColour Double] -> AlphaColour Double)
-> [AlphaColour Double] -> AlphaColour Double
forall a b. (a -> b) -> a -> b
$ Index [AlphaColour Double]
-> [AlphaColour Double] -> [AlphaColour Double]
forall seq. IsSequence seq => Index seq -> seq -> seq
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* 36 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
* 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 0) [AlphaColour Double]
colours) ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
AlphaColour Double -> ShowS
showCol ([AlphaColour Double] -> AlphaColour Double
forall mono. MonoFoldable mono => mono -> Element mono
headEx ([AlphaColour Double] -> AlphaColour Double)
-> [AlphaColour Double] -> AlphaColour Double
forall a b. (a -> b) -> a -> b
$ Index [AlphaColour Double]
-> [AlphaColour Double] -> [AlphaColour Double]
forall seq. IsSequence seq => Index seq -> seq -> seq
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* 36 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
* 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) [AlphaColour Double]
colours) ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
AlphaColour Double -> ShowS
showCol ([AlphaColour Double] -> AlphaColour Double
forall mono. MonoFoldable mono => mono -> Element mono
headEx ([AlphaColour Double] -> AlphaColour Double)
-> [AlphaColour Double] -> AlphaColour Double
forall a b. (a -> b) -> a -> b
$ Index [AlphaColour Double]
-> [AlphaColour Double] -> [AlphaColour Double]
forall seq. IsSequence seq => Index seq -> seq -> seq
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* 36 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
* 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) [AlphaColour Double]
colours) ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
AlphaColour Double -> ShowS
showCol ([AlphaColour Double] -> AlphaColour Double
forall mono. MonoFoldable mono => mono -> Element mono
headEx ([AlphaColour Double] -> AlphaColour Double)
-> [AlphaColour Double] -> AlphaColour Double
forall a b. (a -> b) -> a -> b
$ Index [AlphaColour Double]
-> [AlphaColour Double] -> [AlphaColour Double]
forall seq. IsSequence seq => Index seq -> seq -> seq
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* 36 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
* 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3) [AlphaColour Double]
colours) ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
AlphaColour Double -> ShowS
showCol ([AlphaColour Double] -> AlphaColour Double
forall mono. MonoFoldable mono => mono -> Element mono
headEx ([AlphaColour Double] -> AlphaColour Double)
-> [AlphaColour Double] -> AlphaColour Double
forall a b. (a -> b) -> a -> b
$ Index [AlphaColour Double]
-> [AlphaColour Double] -> [AlphaColour Double]
forall seq. IsSequence seq => Index seq -> seq -> seq
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* 36 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
* 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4) [AlphaColour Double]
colours) ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
AlphaColour Double -> ShowS
showCol ([AlphaColour Double] -> AlphaColour Double
forall mono. MonoFoldable mono => mono -> Element mono
headEx ([AlphaColour Double] -> AlphaColour Double)
-> [AlphaColour Double] -> AlphaColour Double
forall a b. (a -> b) -> a -> b
$ Index [AlphaColour Double]
-> [AlphaColour Double] -> [AlphaColour Double]
forall seq. IsSequence seq => Index seq -> seq -> seq
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* 36 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
* 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 5) [AlphaColour Double]
colours) ShowS -> ShowS -> ShowS
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
String -> ShowS
showString "\n "
showCol :: AlphaColour Double -> String -> String
showCol :: AlphaColour Double -> ShowS
showCol col :: AlphaColour Double
col str :: String
str = AlphaColour Double -> String
sRGB32show AlphaColour Double
col String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
str
defaultGreyscale :: (Ord b, Floating b) => Vec N24 (AlphaColour b)
defaultGreyscale :: Vec N24 (AlphaColour b)
defaultGreyscale = (Fin
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
ZSym0))))))))))))))))))))))))
-> AlphaColour b)
-> Vec N24 (AlphaColour b)
forall (n :: Peano) a. SingI n => (Fin n -> a) -> Vec n a
genVec_ ((Fin
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
ZSym0))))))))))))))))))))))))
-> AlphaColour b)
-> Vec N24 (AlphaColour b))
-> (Fin
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
ZSym0))))))))))))))))))))))))
-> AlphaColour b)
-> Vec N24 (AlphaColour b)
forall a b. (a -> b) -> a -> b
$ \n :: Fin
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
ZSym0))))))))))))))))))))))))
n ->
let l :: Word8
l = 8 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ 10 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Fin
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
ZSym0))))))))))))))))))))))))
-> Int
forall (n :: Peano). Fin n -> Int
toIntFin Fin
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
('S
ZSym0))))))))))))))))))))))))
n)
in Colour b -> AlphaColour b
forall a. Num a => Colour a -> AlphaColour a
opaque (Colour b -> AlphaColour b) -> Colour b -> AlphaColour b
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> Word8 -> Colour b
forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 Word8
l Word8
l Word8
l
data ColourConfig c = ColourConfig
{ ColourConfig c -> Option c
cursorFgColour :: !(Option c)
, ColourConfig c -> Option c
cursorBgColour :: !(Option c)
, ColourConfig c -> Option c
foregroundColour :: !(Option c)
, ColourConfig c -> Option c
backgroundColour :: !(Option c)
, ColourConfig c -> Palette c
palette :: !(Palette c)
} deriving (ColourConfig c -> ColourConfig c -> Bool
(ColourConfig c -> ColourConfig c -> Bool)
-> (ColourConfig c -> ColourConfig c -> Bool)
-> Eq (ColourConfig c)
forall c. Eq c => ColourConfig c -> ColourConfig c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColourConfig c -> ColourConfig c -> Bool
$c/= :: forall c. Eq c => ColourConfig c -> ColourConfig c -> Bool
== :: ColourConfig c -> ColourConfig c -> Bool
$c== :: forall c. Eq c => ColourConfig c -> ColourConfig c -> Bool
Eq, Int -> ColourConfig c -> ShowS
[ColourConfig c] -> ShowS
ColourConfig c -> String
(Int -> ColourConfig c -> ShowS)
-> (ColourConfig c -> String)
-> ([ColourConfig c] -> ShowS)
-> Show (ColourConfig c)
forall c. Show c => Int -> ColourConfig c -> ShowS
forall c. Show c => [ColourConfig c] -> ShowS
forall c. Show c => ColourConfig c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ColourConfig c] -> ShowS
$cshowList :: forall c. Show c => [ColourConfig c] -> ShowS
show :: ColourConfig c -> String
$cshow :: forall c. Show c => ColourConfig c -> String
showsPrec :: Int -> ColourConfig c -> ShowS
$cshowsPrec :: forall c. Show c => Int -> ColourConfig c -> ShowS
Show, a -> ColourConfig b -> ColourConfig a
(a -> b) -> ColourConfig a -> ColourConfig b
(forall a b. (a -> b) -> ColourConfig a -> ColourConfig b)
-> (forall a b. a -> ColourConfig b -> ColourConfig a)
-> Functor ColourConfig
forall a b. a -> ColourConfig b -> ColourConfig a
forall a b. (a -> b) -> ColourConfig a -> ColourConfig b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ColourConfig b -> ColourConfig a
$c<$ :: forall a b. a -> ColourConfig b -> ColourConfig a
fmap :: (a -> b) -> ColourConfig a -> ColourConfig b
$cfmap :: forall a b. (a -> b) -> ColourConfig a -> ColourConfig b
Functor)
defaultColourConfig :: ColourConfig (AlphaColour Double)
defaultColourConfig :: ColourConfig (AlphaColour Double)
defaultColourConfig = $WColourConfig :: forall c.
Option c
-> Option c -> Option c -> Option c -> Palette c -> ColourConfig c
ColourConfig
{ cursorFgColour :: Option (AlphaColour Double)
cursorFgColour = Option (AlphaColour Double)
forall a. Option a
Unset
, cursorBgColour :: Option (AlphaColour Double)
cursorBgColour = Option (AlphaColour Double)
forall a. Option a
Unset
, foregroundColour :: Option (AlphaColour Double)
foregroundColour = Option (AlphaColour Double)
forall a. Option a
Unset
, backgroundColour :: Option (AlphaColour Double)
backgroundColour = Option (AlphaColour Double)
forall a. Option a
Unset
, palette :: Palette (AlphaColour Double)
palette = Palette (AlphaColour Double)
forall c. Palette c
NoPalette
}
$(makeLensesFor
[ ("cursorFgColour", "lensCursorFgColour")
, ("cursorBgColour", "lensCursorBgColour")
, ("foregroundColour", "lensForegroundColour")
, ("backgroundColour", "lensBackgroundColour")
, ("palette", "lensPalette")
]
''ColourConfig
)
data ColourExtension = ColourExtension
{ ColourExtension -> MVar (ColourConfig (AlphaColour Double))
colourExtConf :: MVar (ColourConfig (AlphaColour Double))
, ColourExtension -> TMState -> Terminal -> IO ()
colourExtCreateTermHook :: TMState -> Terminal -> IO ()
}
colourHook :: MVar (ColourConfig (AlphaColour Double)) -> TMState -> Terminal -> IO ()
colourHook :: MVar (ColourConfig (AlphaColour Double))
-> TMState -> Terminal -> IO ()
colourHook mvarColourConf :: MVar (ColourConfig (AlphaColour Double))
mvarColourConf _ vteTerm :: Terminal
vteTerm = do
ColourConfig (AlphaColour Double)
colourConf <- MVar (ColourConfig (AlphaColour Double))
-> IO (ColourConfig (AlphaColour Double))
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar (ColourConfig (AlphaColour Double))
mvarColourConf
let paletteColourList :: [AlphaColour Double]
paletteColourList = Palette (AlphaColour Double) -> [AlphaColour Double]
forall a. Palette a -> [a]
paletteToList (Palette (AlphaColour Double) -> [AlphaColour Double])
-> Palette (AlphaColour Double) -> [AlphaColour Double]
forall a b. (a -> b) -> a -> b
$ ColourConfig (AlphaColour Double) -> Palette (AlphaColour Double)
forall c. ColourConfig c -> Palette c
palette ColourConfig (AlphaColour Double)
colourConf
[RGBA]
rgbaPaletteColourList <- (AlphaColour Double -> IO RGBA)
-> [AlphaColour Double] -> IO [RGBA]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse AlphaColour Double -> IO RGBA
colourToRgba [AlphaColour Double]
paletteColourList
Terminal -> Maybe RGBA -> Maybe RGBA -> Maybe [RGBA] -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Maybe RGBA -> Maybe RGBA -> Maybe [RGBA] -> m ()
terminalSetColors Terminal
vteTerm Maybe RGBA
forall a. Maybe a
Nothing Maybe RGBA
forall a. Maybe a
Nothing ([RGBA] -> Maybe [RGBA]
forall a. a -> Maybe a
Just [RGBA]
rgbaPaletteColourList)
Option (AlphaColour Double)
-> (AlphaColour Double -> IO ()) -> IO ()
forall m a. Monoid m => Option a -> (a -> m) -> m
whenSet (ColourConfig (AlphaColour Double) -> Option (AlphaColour Double)
forall c. ColourConfig c -> Option c
backgroundColour ColourConfig (AlphaColour Double)
colourConf) ((AlphaColour Double -> IO ()) -> IO ())
-> (AlphaColour Double -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
Terminal -> RGBA -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> RGBA -> m ()
terminalSetColorBackground Terminal
vteTerm (RGBA -> IO ())
-> (AlphaColour Double -> IO RGBA) -> AlphaColour Double -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< AlphaColour Double -> IO RGBA
colourToRgba
Option (AlphaColour Double)
-> (AlphaColour Double -> IO ()) -> IO ()
forall m a. Monoid m => Option a -> (a -> m) -> m
whenSet (ColourConfig (AlphaColour Double) -> Option (AlphaColour Double)
forall c. ColourConfig c -> Option c
foregroundColour ColourConfig (AlphaColour Double)
colourConf) ((AlphaColour Double -> IO ()) -> IO ())
-> (AlphaColour Double -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
Terminal -> RGBA -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> RGBA -> m ()
terminalSetColorForeground Terminal
vteTerm (RGBA -> IO ())
-> (AlphaColour Double -> IO RGBA) -> AlphaColour Double -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< AlphaColour Double -> IO RGBA
colourToRgba
Option (AlphaColour Double)
-> (AlphaColour Double -> IO ()) -> IO ()
forall m a. Monoid m => Option a -> (a -> m) -> m
whenSet (ColourConfig (AlphaColour Double) -> Option (AlphaColour Double)
forall c. ColourConfig c -> Option c
cursorBgColour ColourConfig (AlphaColour Double)
colourConf) ((AlphaColour Double -> IO ()) -> IO ())
-> (AlphaColour Double -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
Terminal -> Maybe RGBA -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Maybe RGBA -> m ()
terminalSetColorCursor Terminal
vteTerm (Maybe RGBA -> IO ()) -> (RGBA -> Maybe RGBA) -> RGBA -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. RGBA -> Maybe RGBA
forall a. a -> Maybe a
Just (RGBA -> IO ())
-> (AlphaColour Double -> IO RGBA) -> AlphaColour Double -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< AlphaColour Double -> IO RGBA
colourToRgba
#ifdef VTE_VERSION_GEQ_0_44
whenSet (cursorFgColour colourConf) $
terminalSetColorCursorForeground vteTerm . Just <=< colourToRgba
#endif
colourToRgba :: AlphaColour Double -> IO RGBA
colourToRgba :: AlphaColour Double -> IO RGBA
colourToRgba colour :: AlphaColour Double
colour = do
let RGB red :: Double
red green :: Double
green blue :: Double
blue = Colour Double -> RGB Double
forall b. (Ord b, Floating b) => Colour b -> RGB b
toSRGB (Colour Double -> RGB Double) -> Colour Double -> RGB Double
forall a b. (a -> b) -> a -> b
$ AlphaColour Double -> Colour Double
pureColour AlphaColour Double
colour
alpha :: Double
alpha = AlphaColour Double -> Double
forall a. AlphaColour a -> a
alphaChannel AlphaColour Double
colour
RGBA
rgba <- IO RGBA
forall (m :: * -> *). MonadIO m => m RGBA
newZeroRGBA
RGBA -> Double -> IO ()
forall (m :: * -> *). MonadIO m => RGBA -> Double -> m ()
setRGBARed RGBA
rgba Double
red
RGBA -> Double -> IO ()
forall (m :: * -> *). MonadIO m => RGBA -> Double -> m ()
setRGBAGreen RGBA
rgba Double
green
RGBA -> Double -> IO ()
forall (m :: * -> *). MonadIO m => RGBA -> Double -> m ()
setRGBABlue RGBA
rgba Double
blue
RGBA -> Double -> IO ()
forall (m :: * -> *). MonadIO m => RGBA -> Double -> m ()
setRGBAAlpha RGBA
rgba Double
alpha
RGBA -> IO RGBA
forall (f :: * -> *) a. Applicative f => a -> f a
pure RGBA
rgba
createColourExtension :: ColourConfig (AlphaColour Double) -> IO ColourExtension
createColourExtension :: ColourConfig (AlphaColour Double) -> IO ColourExtension
createColourExtension conf :: ColourConfig (AlphaColour Double)
conf = do
MVar (ColourConfig (AlphaColour Double))
mvarConf <- ColourConfig (AlphaColour Double)
-> IO (MVar (ColourConfig (AlphaColour Double)))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ColourConfig (AlphaColour Double)
conf
ColourExtension -> IO ColourExtension
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ColourExtension -> IO ColourExtension)
-> ColourExtension -> IO ColourExtension
forall a b. (a -> b) -> a -> b
$
ColourExtension :: MVar (ColourConfig (AlphaColour Double))
-> (TMState -> Terminal -> IO ()) -> ColourExtension
ColourExtension
{ colourExtConf :: MVar (ColourConfig (AlphaColour Double))
colourExtConf = MVar (ColourConfig (AlphaColour Double))
mvarConf
, colourExtCreateTermHook :: TMState -> Terminal -> IO ()
colourExtCreateTermHook = MVar (ColourConfig (AlphaColour Double))
-> TMState -> Terminal -> IO ()
colourHook MVar (ColourConfig (AlphaColour Double))
mvarConf
}
createDefColourExtension :: IO ColourExtension
createDefColourExtension :: IO ColourExtension
createDefColourExtension = ColourConfig (AlphaColour Double) -> IO ColourExtension
createColourExtension ColourConfig (AlphaColour Double)
defaultColourConfig
addColourConfig :: TMConfig -> ColourConfig (AlphaColour Double) -> IO TMConfig
addColourConfig :: TMConfig -> ColourConfig (AlphaColour Double) -> IO TMConfig
addColourConfig tmConf :: TMConfig
tmConf colConf :: ColourConfig (AlphaColour Double)
colConf = do
ColourExtension _ newHook :: TMState -> Terminal -> IO ()
newHook <- ColourConfig (AlphaColour Double) -> IO ColourExtension
createColourExtension ColourConfig (AlphaColour Double)
colConf
let newTMConf :: TMConfig
newTMConf = TMConfig
tmConf TMConfig -> (TMConfig -> TMConfig) -> TMConfig
forall a b. a -> (a -> b) -> b
& (ConfigHooks -> Identity ConfigHooks)
-> TMConfig -> Identity TMConfig
Lens' TMConfig ConfigHooks
lensHooks ((ConfigHooks -> Identity ConfigHooks)
-> TMConfig -> Identity TMConfig)
-> (((TMState -> Terminal -> IO ())
-> Identity (TMState -> Terminal -> IO ()))
-> ConfigHooks -> Identity ConfigHooks)
-> ((TMState -> Terminal -> IO ())
-> Identity (TMState -> Terminal -> IO ()))
-> TMConfig
-> Identity TMConfig
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((TMState -> Terminal -> IO ())
-> Identity (TMState -> Terminal -> IO ()))
-> ConfigHooks -> Identity ConfigHooks
Iso' ConfigHooks (TMState -> Terminal -> IO ())
lensCreateTermHook (((TMState -> Terminal -> IO ())
-> Identity (TMState -> Terminal -> IO ()))
-> TMConfig -> Identity TMConfig)
-> ((TMState -> Terminal -> IO ()) -> TMState -> Terminal -> IO ())
-> TMConfig
-> TMConfig
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (TMState -> Terminal -> IO ())
-> (TMState -> Terminal -> IO ()) -> TMState -> Terminal -> IO ()
addColourHook TMState -> Terminal -> IO ()
newHook
TMConfig -> IO TMConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure TMConfig
newTMConf
addColourExtension :: TMConfig -> ColourExtension -> TMConfig
addColourExtension :: TMConfig -> ColourExtension -> TMConfig
addColourExtension tmConf :: TMConfig
tmConf (ColourExtension _ newHook :: TMState -> Terminal -> IO ()
newHook) =
TMConfig
tmConf TMConfig -> (TMConfig -> TMConfig) -> TMConfig
forall a b. a -> (a -> b) -> b
& (ConfigHooks -> Identity ConfigHooks)
-> TMConfig -> Identity TMConfig
Lens' TMConfig ConfigHooks
lensHooks ((ConfigHooks -> Identity ConfigHooks)
-> TMConfig -> Identity TMConfig)
-> (((TMState -> Terminal -> IO ())
-> Identity (TMState -> Terminal -> IO ()))
-> ConfigHooks -> Identity ConfigHooks)
-> ((TMState -> Terminal -> IO ())
-> Identity (TMState -> Terminal -> IO ()))
-> TMConfig
-> Identity TMConfig
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((TMState -> Terminal -> IO ())
-> Identity (TMState -> Terminal -> IO ()))
-> ConfigHooks -> Identity ConfigHooks
Iso' ConfigHooks (TMState -> Terminal -> IO ())
lensCreateTermHook (((TMState -> Terminal -> IO ())
-> Identity (TMState -> Terminal -> IO ()))
-> TMConfig -> Identity TMConfig)
-> ((TMState -> Terminal -> IO ()) -> TMState -> Terminal -> IO ())
-> TMConfig
-> TMConfig
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (TMState -> Terminal -> IO ())
-> (TMState -> Terminal -> IO ()) -> TMState -> Terminal -> IO ()
addColourHook TMState -> Terminal -> IO ()
newHook
addColourHook
:: (TMState -> Terminal -> IO ())
-> (TMState -> Terminal -> IO ())
-> TMState
-> Terminal
-> IO ()
addColourHook :: (TMState -> Terminal -> IO ())
-> (TMState -> Terminal -> IO ()) -> TMState -> Terminal -> IO ()
addColourHook newHook :: TMState -> Terminal -> IO ()
newHook oldHook :: TMState -> Terminal -> IO ()
oldHook tmState :: TMState
tmState term :: Terminal
term = do
TMState -> Terminal -> IO ()
oldHook TMState
tmState Terminal
term
TMState -> Terminal -> IO ()
newHook TMState
tmState Terminal
term