EscapeCode.hs

{-# OPTIONS_GHC -Wall -Werror #-}

{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe                         #-}

--------------------------------------------------------------------------------

-- |
-- Copyright  : (c) 2026 SPISE MISU ApS
-- License    : SSPL-1.0 OR AGPL-3.0-only
-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>
-- Stability  : experimental

--------------------------------------------------------------------------------

module Agent.Data.ANSI.EscapeCode
  ( Colour
    ( Black
    , Red
    , Green
    , Yellow
    , Blue
    , Magenta
    , Cyan
    , White
    )
  , Frequency
    ( Slow
    , Fast
    )
  --
  , sgr
  --
  , foreground
  , background
  , bold
  , faint
  , italic
  , underline
  , blink
  )
where

--------------------------------------------------------------------------------

data Colour
  = Black
  | Red
  | Green
  | Yellow
  | Blue
  | Magenta
  | Cyan
  | White
  deriving (Eq)

instance Enum Colour where
  fromEnum Black   = 0
  fromEnum Red     = 1
  fromEnum Green   = 2
  fromEnum Yellow  = 3
  fromEnum Blue    = 4
  fromEnum Magenta = 5
  fromEnum Cyan    = 6
  fromEnum White   = 7

  toEnum 0 = Black
  toEnum 1 = Red
  toEnum 2 = Green
  toEnum 3 = Yellow
  toEnum 4 = Blue
  toEnum 5 = Magenta
  toEnum 6 = Cyan
  toEnum 7 = White
  toEnum _ = error "Colour code not supported"

type Bright = Bool

data Background = BG !Bool Bright Colour
data Foreground = FG !Bool Bright Colour

data Frequency
  = Slow
  | Fast

data Blink = B !Bool Frequency

data SelectGraphicRendition
  = SGR !Background !Foreground !Bool !Bool !Bool !Bool !Blink String

instance Show SelectGraphicRendition where
  show (SGR bg fg bo fa it un bl text) =
    "\ESC[" ++
    "0"     ++
    (cb bg) ++
    (cf fg) ++
    (fb bo) ++
    (ff fa) ++
    (fi it) ++
    (fu un) ++
    (bf bl) ++
    "m"     ++
    text    ++
    "\ESC[00m"
    where
      cb (BG True  True  c) = ";" ++ (show $ 60 + 40 + fromEnum c)
      cb (BG True  False c) = ";" ++ (show $      40 + fromEnum c)
      cb (BG False _____ _) = [                                  ]
      cf (FG True  True  c) = ";" ++ (show $ 60 + 30 + fromEnum c)
      cf (FG True  False c) = ";" ++ (show $      30 + fromEnum c)
      cf (FG False _____ _) = [                                  ]
      fb     True  = ";01"
      fb     False = [   ]
      ff     True  = ";02"
      ff     False = [   ]
      fi     True  = ";03"
      fi     False = [   ]
      fu     True  = ";04"
      fu     False = [   ]
      bf (B  True  Slow) = ";05"
      bf (B  True  Fast) = ";06"
      bf (B  False ____) = [   ]

--------------------------------------------------------------------------------

sgr
  :: String
  -> SelectGraphicRendition

foreground
  :: Bright
  -> Colour
  -> SelectGraphicRendition
  -> SelectGraphicRendition

background
  :: Bright
  -> Colour
  -> SelectGraphicRendition
  -> SelectGraphicRendition

bold
  :: SelectGraphicRendition
  -> SelectGraphicRendition

faint
  :: SelectGraphicRendition
  -> SelectGraphicRendition

italic
  :: SelectGraphicRendition
  -> SelectGraphicRendition

underline
  :: SelectGraphicRendition
  -> SelectGraphicRendition

blink
  :: Frequency
  -> SelectGraphicRendition
  -> SelectGraphicRendition

--------------------------------------------------------------------------------

sgr =
  SGR bg fg bo fa it un bl
  where
    fg = FG False undefined undefined
    bg = BG False undefined undefined
    bo = False
    fa = False
    it = False
    un = False
    bl = B False undefined

--------------------------------------------------------------------------------

foreground b c (SGR bg __ bo fa it un bl txt) =
  SGR bg fg bo fa it un bl txt
  where
    fg = FG True b c

background b c (SGR __ fg bo fa it un bl txt) =
  SGR bg fg bo fa it un bl txt
  where
    bg = BG True b c

bold (SGR bg fg __ fa it un bl txt) =
  SGR bg fg bo fa it un bl txt
  where
    bo = True

faint (SGR bg fg bo __ it un bl txt) =
  SGR bg fg bo fa it un bl txt
  where
    fa = True

italic (SGR bg fg bo fa __ un bl txt) =
  SGR bg fg bo fa it un bl txt
  where
    it = True

underline (SGR bg fg bo fa it __ bl txt) =
  SGR bg fg bo fa it un bl txt
  where
    un = True

blink f (SGR bg fg bo fa it un __ txt) =
  SGR bg fg bo fa it un bl txt
  where
    bl = B True f

--------------------------------------------------------------------------------

-- References
--
-- ANSI escape code:
-- * https://en.wikipedia.org/wiki/ANSI_escape_code#SGR_parameters