module System.Terminal.Emulator.Attrs where

import Control.Lens
import Data.Bits
import Data.Word (Word32)
import qualified System.Console.ANSI.Types as SGR

-- | Attrs:
--
-- @
--     00000000 00000000 000000000000uuii
--     ^^ fg ^^ ^^ bg ^^ ^^^^^^^^^^^^^^^^
--
--     ii : ConsoleIntensity (00 = Normal, 01 = Bold, 10 = Faint)
--     uu : Underlining (00 = NoUnderline, 01 = SingleUnderline, 10 = DoubleUnderline)
-- @
type Attrs = Word32

blankAttrs :: Attrs
blankAttrs :: Attrs
blankAttrs = Attrs
0
{-# INLINE blankAttrs #-}

type Cell = (Char, Attrs)

cellChar :: Lens' Cell Char
cellChar :: (Char -> f Char) -> Cell -> f Cell
cellChar = (Cell -> Char)
-> (Cell -> Char -> Cell) -> Lens Cell Cell Char Char
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Cell -> Char
forall a b. (a, b) -> a
fst (\(Char
_, Attrs
attrs) Char
c -> (Char
c, Attrs
attrs))
{-# INLINE cellChar #-}

cellAttrs :: Lens' Cell Attrs
cellAttrs :: (Attrs -> f Attrs) -> Cell -> f Cell
cellAttrs = (Cell -> Attrs)
-> (Cell -> Attrs -> Cell) -> Lens Cell Cell Attrs Attrs
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Cell -> Attrs
forall a b. (a, b) -> b
snd (\(Char
char, Attrs
_) Attrs
attrs -> (Char
char, Attrs
attrs))
{-# INLINE cellAttrs #-}

attrsFg :: Lens' Attrs (Maybe (SGR.ColorIntensity, SGR.Color))
attrsFg :: (Maybe (ColorIntensity, Color)
 -> f (Maybe (ColorIntensity, Color)))
-> Attrs -> f Attrs
attrsFg = (Attrs -> Maybe (ColorIntensity, Color))
-> (Attrs -> Maybe (ColorIntensity, Color) -> Attrs)
-> Lens
     Attrs
     Attrs
     (Maybe (ColorIntensity, Color))
     (Maybe (ColorIntensity, Color))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Attrs -> Maybe (ColorIntensity, Color)
getter Attrs -> Maybe (ColorIntensity, Color) -> Attrs
setter
  where
    getter :: Attrs -> Maybe (SGR.ColorIntensity, SGR.Color)
    getter :: Attrs -> Maybe (ColorIntensity, Color)
getter Attrs
attrs = Attrs -> Maybe (ColorIntensity, Color)
intToColor (Attrs -> Int -> Attrs
forall a. Bits a => a -> Int -> a
shiftR Attrs
attrs Int
24 Attrs -> Attrs -> Attrs
forall a. Bits a => a -> a -> a
.&. Attrs
0x000000FF)
    setter :: Attrs -> Maybe (SGR.ColorIntensity, SGR.Color) -> Attrs
    setter :: Attrs -> Maybe (ColorIntensity, Color) -> Attrs
setter Attrs
attrs Maybe (ColorIntensity, Color)
color = (Attrs
attrs Attrs -> Attrs -> Attrs
forall a. Bits a => a -> a -> a
.&. Attrs
0x00FFFFFF) Attrs -> Attrs -> Attrs
forall a. Bits a => a -> a -> a
.|. Attrs -> Int -> Attrs
forall a. Bits a => a -> Int -> a
shiftL (Maybe (ColorIntensity, Color) -> Attrs
colorToInt Maybe (ColorIntensity, Color)
color) Int
24
    {-# INLINE getter #-}
    {-# INLINE setter #-}
{-# INLINE attrsFg #-}

attrsBg :: Lens' Attrs (Maybe (SGR.ColorIntensity, SGR.Color))
attrsBg :: (Maybe (ColorIntensity, Color)
 -> f (Maybe (ColorIntensity, Color)))
-> Attrs -> f Attrs
attrsBg = (Attrs -> Maybe (ColorIntensity, Color))
-> (Attrs -> Maybe (ColorIntensity, Color) -> Attrs)
-> Lens
     Attrs
     Attrs
     (Maybe (ColorIntensity, Color))
     (Maybe (ColorIntensity, Color))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Attrs -> Maybe (ColorIntensity, Color)
getter Attrs -> Maybe (ColorIntensity, Color) -> Attrs
setter
  where
    getter :: Attrs -> Maybe (SGR.ColorIntensity, SGR.Color)
    getter :: Attrs -> Maybe (ColorIntensity, Color)
getter Attrs
attrs = Attrs -> Maybe (ColorIntensity, Color)
intToColor (Attrs -> Int -> Attrs
forall a. Bits a => a -> Int -> a
shiftR Attrs
attrs Int
16 Attrs -> Attrs -> Attrs
forall a. Bits a => a -> a -> a
.&. Attrs
0x000000FF)
    setter :: Attrs -> Maybe (SGR.ColorIntensity, SGR.Color) -> Attrs
    setter :: Attrs -> Maybe (ColorIntensity, Color) -> Attrs
setter Attrs
attrs Maybe (ColorIntensity, Color)
color = (Attrs
attrs Attrs -> Attrs -> Attrs
forall a. Bits a => a -> a -> a
.&. Attrs
0xFF00FFFF) Attrs -> Attrs -> Attrs
forall a. Bits a => a -> a -> a
.|. Attrs -> Int -> Attrs
forall a. Bits a => a -> Int -> a
shiftL (Maybe (ColorIntensity, Color) -> Attrs
colorToInt Maybe (ColorIntensity, Color)
color) Int
16
    {-# INLINE getter #-}
    {-# INLINE setter #-}
{-# INLINE attrsBg #-}

attrsIntensity :: Lens' Attrs SGR.ConsoleIntensity
attrsIntensity :: (ConsoleIntensity -> f ConsoleIntensity) -> Attrs -> f Attrs
attrsIntensity = (Attrs -> ConsoleIntensity)
-> (Attrs -> ConsoleIntensity -> Attrs)
-> Lens Attrs Attrs ConsoleIntensity ConsoleIntensity
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Attrs -> ConsoleIntensity
getter Attrs -> ConsoleIntensity -> Attrs
setter
  where
    getter :: Attrs -> SGR.ConsoleIntensity
    getter :: Attrs -> ConsoleIntensity
getter Attrs
attrs
      | Attrs
attrs Attrs -> Attrs -> Attrs
forall a. Bits a => a -> a -> a
.&. Attrs
0x00000003 Attrs -> Attrs -> Bool
forall a. Eq a => a -> a -> Bool
== Attrs
0 = ConsoleIntensity
SGR.NormalIntensity
      | Attrs
attrs Attrs -> Attrs -> Attrs
forall a. Bits a => a -> a -> a
.&. Attrs
0x00000003 Attrs -> Attrs -> Bool
forall a. Eq a => a -> a -> Bool
== Attrs
1 = ConsoleIntensity
SGR.BoldIntensity
      | Bool
otherwise = ConsoleIntensity
SGR.FaintIntensity
    setter :: Attrs -> SGR.ConsoleIntensity -> Attrs
    setter :: Attrs -> ConsoleIntensity -> Attrs
setter Attrs
attrs ConsoleIntensity
intensity = ((Attrs
attrs Attrs -> Attrs -> Attrs
forall a. Bits a => a -> a -> a
.&. Attrs
0xFFFFFFFC) Attrs -> Attrs -> Attrs
forall a. Bits a => a -> a -> a
.|. ConsoleIntensity -> Attrs
consoleIntensityToInt ConsoleIntensity
intensity)
    {-# INLINE getter #-}
    {-# INLINE setter #-}
{-# INLINE attrsIntensity #-}

attrsUnderline :: Lens' Attrs SGR.Underlining
attrsUnderline :: (Underlining -> f Underlining) -> Attrs -> f Attrs
attrsUnderline = (Attrs -> Underlining)
-> (Attrs -> Underlining -> Attrs)
-> Lens Attrs Attrs Underlining Underlining
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Attrs -> Underlining
getter Attrs -> Underlining -> Attrs
setter
  where
    getter :: Attrs -> SGR.Underlining
    getter :: Attrs -> Underlining
getter Attrs
attrs
      | (Attrs -> Int -> Attrs
forall a. Bits a => a -> Int -> a
shiftR Attrs
attrs Int
2) Attrs -> Attrs -> Attrs
forall a. Bits a => a -> a -> a
.&. Attrs
0x00000003 Attrs -> Attrs -> Bool
forall a. Eq a => a -> a -> Bool
== Attrs
0 = Underlining
SGR.NoUnderline
      | (Attrs -> Int -> Attrs
forall a. Bits a => a -> Int -> a
shiftR Attrs
attrs Int
2) Attrs -> Attrs -> Attrs
forall a. Bits a => a -> a -> a
.&. Attrs
0x00000003 Attrs -> Attrs -> Bool
forall a. Eq a => a -> a -> Bool
== Attrs
1 = Underlining
SGR.SingleUnderline
      | Bool
otherwise = Underlining
SGR.DoubleUnderline
    setter :: Attrs -> SGR.Underlining -> Attrs
    setter :: Attrs -> Underlining -> Attrs
setter Attrs
attrs Underlining
underlining = ((Attrs
attrs Attrs -> Attrs -> Attrs
forall a. Bits a => a -> a -> a
.&. Attrs
0xFFFFFFF3) Attrs -> Attrs -> Attrs
forall a. Bits a => a -> a -> a
.|. Attrs -> Int -> Attrs
forall a. Bits a => a -> Int -> a
shiftL (Underlining -> Attrs
underliningToInt Underlining
underlining) Int
2)
    {-# INLINE getter #-}
    {-# INLINE setter #-}
{-# INLINE attrsUnderline #-}

intToColor :: Word32 -> Maybe (SGR.ColorIntensity, SGR.Color)
intToColor :: Attrs -> Maybe (ColorIntensity, Color)
intToColor Attrs
0 = Maybe (ColorIntensity, Color)
forall a. Maybe a
Nothing
intToColor Attrs
1 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Dull, Color
SGR.Black)
intToColor Attrs
2 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Dull, Color
SGR.Red)
intToColor Attrs
3 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Dull, Color
SGR.Green)
intToColor Attrs
4 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Dull, Color
SGR.Yellow)
intToColor Attrs
5 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Dull, Color
SGR.Blue)
intToColor Attrs
6 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Dull, Color
SGR.Magenta)
intToColor Attrs
7 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Dull, Color
SGR.Cyan)
intToColor Attrs
8 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Dull, Color
SGR.White)
intToColor Attrs
9 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Vivid, Color
SGR.Black)
intToColor Attrs
10 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Vivid, Color
SGR.Red)
intToColor Attrs
11 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Vivid, Color
SGR.Green)
intToColor Attrs
12 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Vivid, Color
SGR.Yellow)
intToColor Attrs
13 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Vivid, Color
SGR.Blue)
intToColor Attrs
14 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Vivid, Color
SGR.Magenta)
intToColor Attrs
15 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Vivid, Color
SGR.Cyan)
intToColor Attrs
16 = (ColorIntensity, Color) -> Maybe (ColorIntensity, Color)
forall a. a -> Maybe a
Just (ColorIntensity
SGR.Vivid, Color
SGR.White)
intToColor Attrs
i = [Char] -> Maybe (ColorIntensity, Color)
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe (ColorIntensity, Color))
-> [Char] -> Maybe (ColorIntensity, Color)
forall a b. (a -> b) -> a -> b
$ [Char]
"intToColor: invalid int: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Attrs -> [Char]
forall a. Show a => a -> [Char]
show Attrs
i
{-# INLINE intToColor #-}

colorToInt :: Maybe (SGR.ColorIntensity, SGR.Color) -> Word32
colorToInt :: Maybe (ColorIntensity, Color) -> Attrs
colorToInt Maybe (ColorIntensity, Color)
Nothing = Attrs
0
colorToInt (Just (ColorIntensity
SGR.Dull, Color
SGR.Black)) = Attrs
1
colorToInt (Just (ColorIntensity
SGR.Dull, Color
SGR.Red)) = Attrs
2
colorToInt (Just (ColorIntensity
SGR.Dull, Color
SGR.Green)) = Attrs
3
colorToInt (Just (ColorIntensity
SGR.Dull, Color
SGR.Yellow)) = Attrs
4
colorToInt (Just (ColorIntensity
SGR.Dull, Color
SGR.Blue)) = Attrs
5
colorToInt (Just (ColorIntensity
SGR.Dull, Color
SGR.Magenta)) = Attrs
6
colorToInt (Just (ColorIntensity
SGR.Dull, Color
SGR.Cyan)) = Attrs
7
colorToInt (Just (ColorIntensity
SGR.Dull, Color
SGR.White)) = Attrs
8
colorToInt (Just (ColorIntensity
SGR.Vivid, Color
SGR.Black)) = Attrs
9
colorToInt (Just (ColorIntensity
SGR.Vivid, Color
SGR.Red)) = Attrs
10
colorToInt (Just (ColorIntensity
SGR.Vivid, Color
SGR.Green)) = Attrs
11
colorToInt (Just (ColorIntensity
SGR.Vivid, Color
SGR.Yellow)) = Attrs
12
colorToInt (Just (ColorIntensity
SGR.Vivid, Color
SGR.Blue)) = Attrs
13
colorToInt (Just (ColorIntensity
SGR.Vivid, Color
SGR.Magenta)) = Attrs
14
colorToInt (Just (ColorIntensity
SGR.Vivid, Color
SGR.Cyan)) = Attrs
15
colorToInt (Just (ColorIntensity
SGR.Vivid, Color
SGR.White)) = Attrs
16
{-# INLINE colorToInt #-}

consoleIntensityToInt :: SGR.ConsoleIntensity -> Word32
consoleIntensityToInt :: ConsoleIntensity -> Attrs
consoleIntensityToInt ConsoleIntensity
SGR.NormalIntensity = Attrs
0
consoleIntensityToInt ConsoleIntensity
SGR.BoldIntensity = Attrs
1
consoleIntensityToInt ConsoleIntensity
SGR.FaintIntensity = Attrs
2
{-# INLINE consoleIntensityToInt #-}

underliningToInt :: SGR.Underlining -> Word32
underliningToInt :: Underlining -> Attrs
underliningToInt Underlining
SGR.NoUnderline = Attrs
0
underliningToInt Underlining
SGR.SingleUnderline = Attrs
1
underliningToInt Underlining
SGR.DoubleUnderline = Attrs
2
{-# INLINE underliningToInt #-}