module Data.Fmt.Ansi (
    -- * Ansi terminal codes
    code,
    codes,
    erase,
    reset,
    shift,
    scroll,

    -- ** Emphasis
    blink,
    bold,
    faint,
    italic,
    underline,

    -- ** Color
    dull,
    vivid,
    layer,
    palette,
    Palette,
    XColor,
    Color (..),
    ConsoleLayer (..),
) where

import Data.Fmt
import Data.Word
import System.Console.ANSI.Codes
import System.Console.ANSI.Types

-- Ansi terminal formatters

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

code :: (Semigroup m, IsString m) => SGR -> Fmt m s a -> Fmt m s a
code :: forall m s a.
(Semigroup m, IsString m) =>
SGR -> Fmt m s a -> Fmt m s a
code = [SGR] -> Fmt m s a -> Fmt m s a
forall m s a.
(Semigroup m, IsString m) =>
[SGR] -> Fmt m s a -> Fmt m s a
codes ([SGR] -> Fmt m s a -> Fmt m s a)
-> (SGR -> [SGR]) -> SGR -> Fmt m s a -> Fmt m s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SGR -> [SGR]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Wrap content with escape sequence to set and reset color of normal intensity.
codes :: (Semigroup m, IsString m) => [SGR] -> Fmt m s a -> Fmt m s a
codes :: forall m s a.
(Semigroup m, IsString m) =>
[SGR] -> Fmt m s a -> Fmt m s a
codes [SGR]
sgr Fmt m s a
x = Fmt m a a -> Fmt m s s -> Fmt m s a -> Fmt m s a
forall m b2 c a b1.
Semigroup m =>
Fmt m b2 c -> Fmt m a b1 -> Fmt m b1 b2 -> Fmt m a c
enclose Fmt m a a
before Fmt m s s
after Fmt m s a
x
  where
    before :: Fmt m a a
before = String -> Fmt m a a
forall a. IsString a => String -> a
fromString (String -> Fmt m a a) -> String -> Fmt m a a
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [SGR]
sgr
    after :: Fmt m s s
after = String -> Fmt m s s
forall a. IsString a => String -> a
fromString (String -> Fmt m s s) -> String -> Fmt m s s
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [SGR
Reset]

erase :: (Semigroup m, IsString m) => Ordering -> Fmt m s a -> Fmt m s a
erase :: forall m s a.
(Semigroup m, IsString m) =>
Ordering -> Fmt m s a -> Fmt m s a
erase Ordering
LT = m -> Fmt m s a -> Fmt m s a
forall m a b. Semigroup m => m -> Fmt m a b -> Fmt m a b
suffix (m -> Fmt m s a -> Fmt m s a) -> m -> Fmt m s a -> Fmt m s a
forall a b. (a -> b) -> a -> b
$ String -> m
forall a. IsString a => String -> a
fromString String
clearFromCursorToLineBeginningCode
erase Ordering
EQ = m -> Fmt m s a -> Fmt m s a
forall m a b. Semigroup m => m -> Fmt m a b -> Fmt m a b
suffix (m -> Fmt m s a -> Fmt m s a) -> m -> Fmt m s a -> Fmt m s a
forall a b. (a -> b) -> a -> b
$ String -> m
forall a. IsString a => String -> a
fromString String
clearLineCode
erase Ordering
GT = m -> Fmt m s a -> Fmt m s a
forall m a b. Semigroup m => m -> Fmt m a b -> Fmt m a b
suffix (m -> Fmt m s a -> Fmt m s a) -> m -> Fmt m s a -> Fmt m s a
forall a b. (a -> b) -> a -> b
$ String -> m
forall a. IsString a => String -> a
fromString String
clearFromCursorToLineEndCode

reset :: (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a
reset :: forall m s a. (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a
reset = m -> Fmt m s a -> Fmt m s a
forall m a b. Semigroup m => m -> Fmt m a b -> Fmt m a b
prefix (m -> Fmt m s a -> Fmt m s a) -> m -> Fmt m s a -> Fmt m s a
forall a b. (a -> b) -> a -> b
$ String -> m
forall a. IsString a => String -> a
fromString (String -> m) -> String -> m
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [SGR
Reset]

shift :: (Semigroup m, IsString m) => Either Int Int -> Fmt m s a -> Fmt m s a
shift :: forall m s a.
(Semigroup m, IsString m) =>
Either Int Int -> Fmt m s a -> Fmt m s a
shift = m -> Fmt m s a -> Fmt m s a
forall m a b. Semigroup m => m -> Fmt m a b -> Fmt m a b
prefix (m -> Fmt m s a -> Fmt m s a)
-> (Either Int Int -> m)
-> Either Int Int
-> Fmt m s a
-> Fmt m s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m
forall a. IsString a => String -> a
fromString (String -> m) -> (Either Int Int -> String) -> Either Int Int -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> String) -> (Int -> String) -> Either Int Int -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Int -> String
cursorBackwardCode Int -> String
cursorForwardCode

scroll :: (Semigroup m, IsString m) => Either Int Int -> Fmt m s a -> Fmt m s a
scroll :: forall m s a.
(Semigroup m, IsString m) =>
Either Int Int -> Fmt m s a -> Fmt m s a
scroll = m -> Fmt m s a -> Fmt m s a
forall m a b. Semigroup m => m -> Fmt m a b -> Fmt m a b
prefix (m -> Fmt m s a -> Fmt m s a)
-> (Either Int Int -> m)
-> Either Int Int
-> Fmt m s a
-> Fmt m s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m
forall a. IsString a => String -> a
fromString (String -> m) -> (Either Int Int -> String) -> Either Int Int -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> String) -> (Int -> String) -> Either Int Int -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Int -> String
scrollPageUpCode Int -> String
scrollPageDownCode

-- Emphasis

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

blink :: (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a
blink :: forall m s a. (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a
blink = SGR -> Fmt m s a -> Fmt m s a
forall m s a.
(Semigroup m, IsString m) =>
SGR -> Fmt m s a -> Fmt m s a
code (SGR -> Fmt m s a -> Fmt m s a) -> SGR -> Fmt m s a -> Fmt m s a
forall a b. (a -> b) -> a -> b
$ BlinkSpeed -> SGR
SetBlinkSpeed BlinkSpeed
SlowBlink

bold :: (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a
bold :: forall m s a. (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a
bold = SGR -> Fmt m s a -> Fmt m s a
forall m s a.
(Semigroup m, IsString m) =>
SGR -> Fmt m s a -> Fmt m s a
code (SGR -> Fmt m s a -> Fmt m s a) -> SGR -> Fmt m s a -> Fmt m s a
forall a b. (a -> b) -> a -> b
$ ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity

italic :: (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a
italic :: forall m s a. (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a
italic = SGR -> Fmt m s a -> Fmt m s a
forall m s a.
(Semigroup m, IsString m) =>
SGR -> Fmt m s a -> Fmt m s a
code (SGR -> Fmt m s a -> Fmt m s a) -> SGR -> Fmt m s a -> Fmt m s a
forall a b. (a -> b) -> a -> b
$ Bool -> SGR
SetItalicized Bool
True

underline :: (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a
underline :: forall m s a. (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a
underline = SGR -> Fmt m s a -> Fmt m s a
forall m s a.
(Semigroup m, IsString m) =>
SGR -> Fmt m s a -> Fmt m s a
code (SGR -> Fmt m s a -> Fmt m s a) -> SGR -> Fmt m s a -> Fmt m s a
forall a b. (a -> b) -> a -> b
$ Underlining -> SGR
SetUnderlining Underlining
SingleUnderline

faint :: (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a
faint :: forall m s a. (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a
faint = SGR -> Fmt m s a -> Fmt m s a
forall m s a.
(Semigroup m, IsString m) =>
SGR -> Fmt m s a -> Fmt m s a
code (SGR -> Fmt m s a -> Fmt m s a) -> SGR -> Fmt m s a -> Fmt m s a
forall a b. (a -> b) -> a -> b
$ ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
FaintIntensity

-- Color

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

-- | The xterm < https://en.wikipedia.org/wiki/8-bit_color 8 bit > color encoding.
type XColor = Word8

-- | A simple palette consisting of a foreground and background color.
type Palette = (XColor, XColor)

dull :: (Semigroup m, IsString m) => Color -> ConsoleLayer -> Fmt m s a -> Fmt m s a
dull :: forall m s a.
(Semigroup m, IsString m) =>
Color -> ConsoleLayer -> Fmt m s a -> Fmt m s a
dull = XColor -> ConsoleLayer -> Fmt m s a -> Fmt m s a
forall m s a.
(Semigroup m, IsString m) =>
XColor -> ConsoleLayer -> Fmt m s a -> Fmt m s a
layer (XColor -> ConsoleLayer -> Fmt m s a -> Fmt m s a)
-> (Color -> XColor)
-> Color
-> ConsoleLayer
-> Fmt m s a
-> Fmt m s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColorIntensity -> Color -> XColor
xtermSystem ColorIntensity
Dull

vivid :: (Semigroup m, IsString m) => Color -> ConsoleLayer -> Fmt m s a -> Fmt m s a
vivid :: forall m s a.
(Semigroup m, IsString m) =>
Color -> ConsoleLayer -> Fmt m s a -> Fmt m s a
vivid = XColor -> ConsoleLayer -> Fmt m s a -> Fmt m s a
forall m s a.
(Semigroup m, IsString m) =>
XColor -> ConsoleLayer -> Fmt m s a -> Fmt m s a
layer (XColor -> ConsoleLayer -> Fmt m s a -> Fmt m s a)
-> (Color -> XColor)
-> Color
-> ConsoleLayer
-> Fmt m s a
-> Fmt m s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColorIntensity -> Color -> XColor
xtermSystem ColorIntensity
Vivid

--vivid col lay = code $ SetColor lay Vivid col

layer :: (Semigroup m, IsString m) => XColor -> ConsoleLayer -> Fmt m s a -> Fmt m s a
layer :: forall m s a.
(Semigroup m, IsString m) =>
XColor -> ConsoleLayer -> Fmt m s a -> Fmt m s a
layer XColor
pal ConsoleLayer
lay = SGR -> Fmt m s a -> Fmt m s a
forall m s a.
(Semigroup m, IsString m) =>
SGR -> Fmt m s a -> Fmt m s a
code (SGR -> Fmt m s a -> Fmt m s a) -> SGR -> Fmt m s a -> Fmt m s a
forall a b. (a -> b) -> a -> b
$ ConsoleLayer -> XColor -> SGR
SetPaletteColor ConsoleLayer
lay XColor
pal

palette :: (Semigroup m, IsString m) => Palette -> Fmt m s a -> Fmt m s a
palette :: forall m s a.
(Semigroup m, IsString m) =>
Palette -> Fmt m s a -> Fmt m s a
palette (XColor
fg, XColor
bg) = [SGR] -> Fmt m s a -> Fmt m s a
forall m s a.
(Semigroup m, IsString m) =>
[SGR] -> Fmt m s a -> Fmt m s a
codes [ConsoleLayer -> XColor -> SGR
SetPaletteColor ConsoleLayer
Foreground XColor
fg, ConsoleLayer -> XColor -> SGR
SetPaletteColor ConsoleLayer
Background XColor
bg]