{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Module    : Termonad.Config.Colour
-- Description : Termonad Configuration Colour Options
-- Copyright   : (c) Dennis Gosnell, 2018
-- License     : BSD3
-- Stability   : experimental
-- Portability : POSIX
--
-- To use this config extension in your @~\/.config\/termonad\/termonad.hs@, first
-- import this module. Create a new 'ColourExtension' with the 'createColourExtension' function.
-- Then add the 'ColourExtension' to your 'TMConfig' with the 'addColourExtension' function.
--
-- See
-- <https://github.com/cdepillabout/termonad/blob/master/example-config/ExampleColourExtension.hs this code>
-- for a simple example.
--
-- When setting colors, you may find it convenient to use the
-- <http://hackage.haskell.org/package/print-console-colors print-console-colors>
-- package, which provides an executable called @print-console-colors@ that prints
-- all of the colors for your terminal.

module Termonad.Config.Colour
  ( -- * Colour Config
      ColourConfig(..)
    , defaultColourConfig
    -- ** Colour Config Lenses
    , lensCursorFgColour
    , lensCursorBgColour
    , lensForegroundColour
    , lensBackgroundColour
    , lensPalette
    -- * Colour Extension
    , ColourExtension(..)
    , createColourExtension
    , createDefColourExtension
    , addColourExtension
    , addColourConfig
    , colourHook
    , addColourHook
    -- * Palette
    , Palette(..)
    , defaultStandardColours
    , defaultLightColours
    , defaultColourCube
    , defaultGreyscale
    -- * Colour
    -- | Check out the "Data.Colour" module for more info about 'AlphaColour'.
    , AlphaColour
    , createColour
    , sRGB32
    , sRGB32show
    , opaque
    , transparent
    -- * Debugging and Internal Methods
    , showColourVec
    , showColourCube
    , paletteToList
    , coloursFromBits
    , cube
    -- * Doctest setup
    -- $setup
  ) 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
  )

-- $setup
-- >>> import Data.Colour.Names (green, red)
-- >>> import Data.Colour.SRGB (sRGB24show)

-------------------
-- Colour Config --
-------------------

-- | This is the color palette to use for the terminal. Each data constructor
-- lets you set progressively more colors.  These colors are used by the
-- terminal to render
-- <https://en.wikipedia.org/wiki/ANSI_escape_code#Colors ANSI escape color codes>.
--
-- There are 256 total terminal colors. 'BasicPalette' lets you set the first 8,
-- 'ExtendedPalette' lets you set the first 16, 'ColourCubePalette' lets you set
-- the first 232, and 'FullPalette' lets you set all 256.
--
-- The first 8 colors codes are the standard colors. The next 8 are the
-- extended (light) colors. The next 216 are a full color cube. The last 24 are a
-- grey scale.
--
-- The following image gives an idea of what each individual color looks like:
--
-- <<https://raw.githubusercontent.com/cdepillabout/termonad/master/img/terminal-colors.png>>
--
-- This picture does not exactly match up with Termonad's default colors, but it gives an
-- idea of what each block of colors represents.
--
-- You can use 'defaultStandardColours', 'defaultLightColours',
-- 'defaultColourCube', and 'defaultGreyscale' as a starting point to
-- customize the colors. The only time you'd need to use a constructor other
-- than 'NoPalette' is when you want to customize the default colors.
-- That is to say, using 'FullPalette' with all the defaults should give you the
-- same result as using 'NoPalette'.
data Palette c
  = NoPalette
  -- ^ Don't set any colors and just use the default from VTE.  This is a black
  -- background with light grey text.
  | BasicPalette !(Vec N8 c)
  -- ^ Set the colors from the standard colors.
  | ExtendedPalette !(Vec N8 c) !(Vec N8 c)
  -- ^ Set the colors from the extended (light) colors (as well as standard colors).
  | ColourCubePalette !(Vec N8 c) !(Vec N8 c) !(Matrix '[N6, N6, N6] c)
  -- ^ Set the colors from the color cube (as well as the standard colors and
  -- extended colors).
  | FullPalette !(Vec N8 c) !(Vec N8 c) !(Matrix '[N6, N6, N6] c) !(Vec N24 c)
  -- ^ Set the colors from the grey scale (as well as the standard colors,
  -- extended colors, and color cube).
  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)

-- | Convert a 'Palette' to a list of colors.  This is helpful for debugging.
paletteToList :: Palette c -> [c]
paletteToList :: Palette c -> [c]
paletteToList = Palette c -> [c]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList

-- | Create a vector of colors based on input bits.
--
-- This is used to derive 'defaultStandardColours' and 'defaultLightColours'.
--
-- >>> coloursFromBits 192 0 == defaultStandardColours
-- True
--
-- >>> coloursFromBits 192 63 == defaultLightColours
-- True
--
-- In general, as an end-user, you shouldn't need to use this.
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

-- | A 'Vec' of standard colors.  Default value for 'BasicPalette'.
--
-- >>> showColourVec defaultStandardColours
-- ["#000000ff","#c00000ff","#00c000ff","#c0c000ff","#0000c0ff","#c000c0ff","#00c0c0ff","#c0c0c0ff"]
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

-- | A 'Vec' of extended (light) colors.  Default value for 'ExtendedPalette'.
--
-- >>> showColourVec defaultLightColours
-- ["#3f3f3fff","#ff3f3fff","#3fff3fff","#ffff3fff","#3f3fffff","#ff3fffff","#3fffffff","#ffffffff"]
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

-- | Convert an 'AlphaColour' to a 'Colour'.
--
-- >>> sRGB24show $ pureColour (opaque green)
-- "#008000"
-- >>> sRGB24show $ pureColour (sRGB32 0x30 0x40 0x50 0x80)
-- "#304050"
--
-- We assume that black is the pure color for a fully transparent
-- 'AlphaColour'.
--
-- >>> sRGB24show $ pureColour transparent
-- "#000000"
--
-- This function has been taken from:
-- https://wiki.haskell.org/Colour#Getting_semi-transparent_coordinates
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

-- | 'round's and then clamps the input between 0 and 'maxBound'.
--
-- Rounds the input:
--
-- >>> quantize (100.2 :: Double) :: Word8
-- 100
--
-- Clamps to 'minBound' if input is too low:
--
-- >>> quantize (-3 :: Double) :: Word8
-- 0
--
-- Clamps to 'maxBound' if input is too high:
-- >>> quantize (1000 :: Double) :: Word8
-- 255
--
-- Function used to quantize the alpha channel in the same way as the 'RGB'
-- components. It has been copied from "Data.Colour.Internal".
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

-- | Show an 'AlphaColour' in hex.
--
-- >>> sRGB32show (opaque red)
-- "#ff0000ff"
--
-- Similar to 'Data.Colour.SRGB.sRGB24show'.
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

    -- This about the same code as in Data.Colour.SRGB.toSRGBBounded
    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)

-- | Create an 'AlphaColour' from a four 'Word8's.
--
-- >>> sRGB32show $ sRGB32 64 96 128 255
-- "#406080ff"
-- >>> sRGB32show $ sRGB32 0x08 0x10 0x20 0x01
-- "#08102001"
--
-- Note that if you specify the alpha as 0 (which means completely
-- translucent), all the color channels will be set to 0 as well.
--
-- >>> sRGB32show $ sRGB32 100 150 200 0
-- "#00000000"
--
-- Similar to 'sRGB24' but also includes an alpha channel.  Most users will
-- probably want to use 'createColour' instead.
sRGB32
  :: Word8 -- ^ red channel
  -> Word8 -- ^ green channel
  -> Word8 -- ^ blue channel
  -> Word8 -- ^ alpha channel
  -> 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)

-- | Create an 'AlphaColour' that is fully 'opaque'.
--
-- >>> sRGB32show $ createColour 64 96 128
-- "#406080ff"
-- >>> sRGB32show $ createColour 0 0 0
-- "#000000ff"
--
-- Similar to 'sRGB24' but for 'AlphaColour'.
createColour
  :: Word8 -- ^ red channel
  -> Word8 -- ^ green channel
  -> Word8 -- ^ blue channel
  -> 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

-- | A helper function for showing all the colors in 'Vec' of colors.
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

-- | Specify a colour cube with one colour vector for its displacement and three
-- colour vectors for its edges. Produces a uniform 6x6x6 grid bounded by
-- and orthognal to the faces.
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

-- | A matrix of a 6 x 6 x 6 color cube. Default value for 'ColourCubePalette'.
--
-- >>> putStrLn $ pack $ showColourCube defaultColourCube
-- [ [ #000000ff, #00005fff, #000087ff, #0000afff, #0000d7ff, #0000ffff
--   , #005f00ff, #005f5fff, #005f87ff, #005fafff, #005fd7ff, #005fffff
--   , #008700ff, #00875fff, #008787ff, #0087afff, #0087d7ff, #0087ffff
--   , #00af00ff, #00af5fff, #00af87ff, #00afafff, #00afd7ff, #00afffff
--   , #00d700ff, #00d75fff, #00d787ff, #00d7afff, #00d7d7ff, #00d7ffff
--   , #00ff00ff, #00ff5fff, #00ff87ff, #00ffafff, #00ffd7ff, #00ffffff
--   ]
-- , [ #5f0000ff, #5f005fff, #5f0087ff, #5f00afff, #5f00d7ff, #5f00ffff
--   , #5f5f00ff, #5f5f5fff, #5f5f87ff, #5f5fafff, #5f5fd7ff, #5f5fffff
--   , #5f8700ff, #5f875fff, #5f8787ff, #5f87afff, #5f87d7ff, #5f87ffff
--   , #5faf00ff, #5faf5fff, #5faf87ff, #5fafafff, #5fafd7ff, #5fafffff
--   , #5fd700ff, #5fd75fff, #5fd787ff, #5fd7afff, #5fd7d7ff, #5fd7ffff
--   , #5fff00ff, #5fff5fff, #5fff87ff, #5fffafff, #5fffd7ff, #5fffffff
--   ]
-- , [ #870000ff, #87005fff, #870087ff, #8700afff, #8700d7ff, #8700ffff
--   , #875f00ff, #875f5fff, #875f87ff, #875fafff, #875fd7ff, #875fffff
--   , #878700ff, #87875fff, #878787ff, #8787afff, #8787d7ff, #8787ffff
--   , #87af00ff, #87af5fff, #87af87ff, #87afafff, #87afd7ff, #87afffff
--   , #87d700ff, #87d75fff, #87d787ff, #87d7afff, #87d7d7ff, #87d7ffff
--   , #87ff00ff, #87ff5fff, #87ff87ff, #87ffafff, #87ffd7ff, #87ffffff
--   ]
-- , [ #af0000ff, #af005fff, #af0087ff, #af00afff, #af00d7ff, #af00ffff
--   , #af5f00ff, #af5f5fff, #af5f87ff, #af5fafff, #af5fd7ff, #af5fffff
--   , #af8700ff, #af875fff, #af8787ff, #af87afff, #af87d7ff, #af87ffff
--   , #afaf00ff, #afaf5fff, #afaf87ff, #afafafff, #afafd7ff, #afafffff
--   , #afd700ff, #afd75fff, #afd787ff, #afd7afff, #afd7d7ff, #afd7ffff
--   , #afff00ff, #afff5fff, #afff87ff, #afffafff, #afffd7ff, #afffffff
--   ]
-- , [ #d70000ff, #d7005fff, #d70087ff, #d700afff, #d700d7ff, #d700ffff
--   , #d75f00ff, #d75f5fff, #d75f87ff, #d75fafff, #d75fd7ff, #d75fffff
--   , #d78700ff, #d7875fff, #d78787ff, #d787afff, #d787d7ff, #d787ffff
--   , #d7af00ff, #d7af5fff, #d7af87ff, #d7afafff, #d7afd7ff, #d7afffff
--   , #d7d700ff, #d7d75fff, #d7d787ff, #d7d7afff, #d7d7d7ff, #d7d7ffff
--   , #d7ff00ff, #d7ff5fff, #d7ff87ff, #d7ffafff, #d7ffd7ff, #d7ffffff
--   ]
-- , [ #ff0000ff, #ff005fff, #ff0087ff, #ff00afff, #ff00d7ff, #ff00ffff
--   , #ff5f00ff, #ff5f5fff, #ff5f87ff, #ff5fafff, #ff5fd7ff, #ff5fffff
--   , #ff8700ff, #ff875fff, #ff8787ff, #ff87afff, #ff87d7ff, #ff87ffff
--   , #ffaf00ff, #ffaf5fff, #ffaf87ff, #ffafafff, #ffafd7ff, #ffafffff
--   , #ffd700ff, #ffd75fff, #ffd787ff, #ffd7afff, #ffd7d7ff, #ffd7ffff
--   , #ffff00ff, #ffff5fff, #ffff87ff, #ffffafff, #ffffd7ff, #ffffffff
--   ]
-- ]
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'

-- | Helper function for showing all the colors in a color cube. This is used
-- for debugging.
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 =
  -- TODO: This function will only work with a 6x6x6 matrix, but it could be
  -- generalized to work with any Rank-3 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

-- | A 'Vec' of a grey scale.  Default value for 'FullPalette'.
--
-- >>> showColourVec defaultGreyscale
-- ["#080808ff","#121212ff","#1c1c1cff","#262626ff","#303030ff","#3a3a3aff","#444444ff","#4e4e4eff","#585858ff","#626262ff","#6c6c6cff","#767676ff","#808080ff","#8a8a8aff","#949494ff","#9e9e9eff","#a8a8a8ff","#b2b2b2ff","#bcbcbcff","#c6c6c6ff","#d0d0d0ff","#dadadaff","#e4e4e4ff","#eeeeeeff"]
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

-- | The configuration for the colors used by Termonad.
--
-- 'foregroundColour' and 'backgroundColour' allow you to set the color of the
-- foreground text and background of the terminal.
--
-- 'palette' allows you to set the full color palette used by the terminal.
-- See 'Palette' for more information.
--
-- If you don't set 'foregroundColour', 'backgroundColour', or 'palette', the
-- defaults from VTE are used.
--
-- If you want to use a terminal with a white (or light) background and a black
-- foreground, it may be a good idea to change some of the colors in the
-- 'Palette' as well.
--
-- VTE works as follows: if you don't explicitly set a background or foreground color,
-- it takes the 0th colour from the 'palette' to be the background color, and the 7th
-- colour from the 'palette' to be the foreground color.  If you notice oddities with
-- colouring in certain applications, it may be helpful to make sure that these
-- 'palette' colours match up with the 'backgroundColour' and 'foregroundColour' you
-- have set.)
--
-- 'cursorFgColour' and 'cursorBgColour' allow you to set the foreground color
-- of the text under the cursor, as well as the color of the cursor itself.
--
-- Termonad will behave differently depending on the combination
-- 'cursorFgColour' and 'cursorBgColour' being 'Set' vs. 'Unset'.
-- Here is the summary of the different possibilities:
--
-- * 'cursorFgColour' is 'Set' and 'cursorBgColour' is 'Set'
--
--     The foreground and background colors of the cursor are as you have set.
--
-- * 'cursorFgColour' is 'Set' and 'cursorBgColour' is 'Unset'
--
--     The cursor background color turns completely black so that it is not
--     visible.  The foreground color of the cursor is the color that you have
--     'Set'.  This ends up being mostly unusable, so you are recommended to
--     always 'Set' 'cursorBgColour' when you have 'Set' 'cursorFgColour'.
--
-- * 'cursorFgColour' is 'Unset' and 'cursorBgColour' is 'Set'
--
--     The cursor background color becomes the color you 'Set', while the cursor
--     foreground color doesn't change from the letter it is over.  For instance,
--     imagine there is a letter on the screen with a black background and a
--     green foreground.  If you bring the cursor overtop of it, the cursor
--     background will be the color you have 'Set', while the cursor foreground
--     will be green.
--
--     This is completely usable, but is slightly annoying if you place the cursor
--     over a letter with the same foreground color as the cursor's background
--     color, because the letter will not be readable. For instance, imagine you
--     have set your cursor background color to red, and somewhere on the screen
--     there is a letter with a black background and a red foreground. If you move
--     your cursor over the letter, the background of the cursor will be red (as
--     you have set), and the cursor foreground will be red (to match the original
--     foreground color of the letter). This will make it so you can't
--     actually read the letter, because the foreground and background are both
--     red.
--
-- * 'cursorFgColour' is 'Unset' and 'cursorBgColour' is 'Unset'
--
--     This combination makes the cursor inverse of whatever text it is over.
--     If your cursor is over red text with a black background, the cursor
--     background will be red and the cursor foreground will be black.
--
--     This is the default.
--
-- 'cursorFgColour' is not supported in @vte-2.91@ versions older than 0.44.
-- (This is somewhat confusing. Note that @vte-2.91@ is the name of the system
-- library, and @0.44@ is its version number.)
--
-- See 'defaultColourConfig' for the defaults for 'ColourConfig' used in Termonad.
data ColourConfig c = ColourConfig
  { ColourConfig c -> Option c
cursorFgColour :: !(Option c)
    -- ^ Foreground color of the cursor.  This is the color of the text that
    -- the cursor is over.  This is not supported on older versions of VTE.
  , ColourConfig c -> Option c
cursorBgColour :: !(Option c)
    -- ^ Background color of the cursor.  This is the color of the cursor
    -- itself.
  , ColourConfig c -> Option c
foregroundColour :: !(Option c)
    -- ^ Color of the default foreground text in the terminal.
  , ColourConfig c -> Option c
backgroundColour :: !(Option c)
    -- ^ Background color for the terminal
  , ColourConfig c -> Palette c
palette :: !(Palette c)
    -- ^ Color palette for the terminal.  See 'Palette'.
  } 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)

-- | Default setting for a 'ColourConfig'.  The cursor colors, font foreground
-- color, background color, and color palette are all left at the defaults set
-- by VTE.
--
-- >>> defaultColourConfig
-- ColourConfig {cursorFgColour = Unset, cursorBgColour = Unset, foregroundColour = Unset, backgroundColour = Unset, palette = NoPalette}
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
 )

------------------------------
-- ConfigExtension Instance --
------------------------------

-- | Extension that allows setting colors for terminals in Termonad.
data ColourExtension = ColourExtension
  { ColourExtension -> MVar (ColourConfig (AlphaColour Double))
colourExtConf :: MVar (ColourConfig (AlphaColour Double))
    -- ^ 'MVar' holding the current 'ColourConfig'.  This could potentially be
    -- passed to other extensions or user code.  This would allow changing the
    -- colors for new terminals in realtime.
  , ColourExtension -> TMState -> Terminal -> IO ()
colourExtCreateTermHook :: TMState -> Terminal -> IO ()
    -- ^ The 'createTermHook' used by the 'ColourExtension'.  This sets the
    -- colors for a new terminal based on the 'ColourConfig' in 'colourExtConf'.
  }

-- | The default 'createTermHook' for 'colourExtCreateTermHook'.  Set the colors
-- for a terminal based on the given 'ColourConfig'.
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

-- | Create a 'ColourExtension' based on a given 'ColourConfig'.
--
-- Most users will want to use this.
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
      }

-- | Create a 'ColourExtension' based on 'defaultColourConfig'.
--
-- Note that this is not needed if you just want to use the default colors for
-- Termonad.  However, if you want to pass around the 'MVar' 'ColourConfig' for
-- extensions to use, then you may need this function.
createDefColourExtension :: IO ColourExtension
createDefColourExtension :: IO ColourExtension
createDefColourExtension = ColourConfig (AlphaColour Double) -> IO ColourExtension
createColourExtension ColourConfig (AlphaColour Double)
defaultColourConfig

-- | Add a given 'ColourConfig' to a 'TMConfig'.  This adds 'colourHook' to the
-- 'createTermHook' in 'TMConfig'.
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

-- | This is similar to 'addColourConfig', but can be used on a
-- 'ColourExtension' created with 'createColourExtension'.
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

-- | This function shows how to combine 'createTermHook's.
--
-- This first runs the old hook, followed by the new hook.
--
-- This is used internally by 'addColourConfig' and 'addColourExtension'.
addColourHook
  :: (TMState -> Terminal -> IO ()) -- ^ New hook
  -> (TMState -> Terminal -> IO ()) -- ^ Old hook
  -> 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