{-# LANGUAGE DeriveGeneric #-}
{-|
Module      : Idris.Colours
Description : Support for colours within Idris.

License     : BSD3
Maintainer  : The Idris Community.
-}
module Idris.Colours (
    IdrisColour(..)
  , ColourTheme(..)
  , defaultTheme
  , colouriseKwd, colouriseBound, colouriseImplicit, colourisePostulate
  , colouriseType, colouriseFun, colouriseData, colouriseKeyword
  , colourisePrompt, colourise, ColourType(..), hStartColourise, hEndColourise
  ) where

import GHC.Generics (Generic)
import System.Console.ANSI
import System.IO (Handle)

data IdrisColour = IdrisColour { IdrisColour -> Maybe Color
colour    :: Maybe Color
                               , IdrisColour -> Bool
vivid     :: Bool
                               , IdrisColour -> Bool
underline :: Bool
                               , IdrisColour -> Bool
bold      :: Bool
                               , IdrisColour -> Bool
italic    :: Bool
                               }
                   deriving (IdrisColour -> IdrisColour -> Bool
(IdrisColour -> IdrisColour -> Bool)
-> (IdrisColour -> IdrisColour -> Bool) -> Eq IdrisColour
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IdrisColour -> IdrisColour -> Bool
== :: IdrisColour -> IdrisColour -> Bool
$c/= :: IdrisColour -> IdrisColour -> Bool
/= :: IdrisColour -> IdrisColour -> Bool
Eq, Int -> IdrisColour -> ShowS
[IdrisColour] -> ShowS
IdrisColour -> String
(Int -> IdrisColour -> ShowS)
-> (IdrisColour -> String)
-> ([IdrisColour] -> ShowS)
-> Show IdrisColour
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IdrisColour -> ShowS
showsPrec :: Int -> IdrisColour -> ShowS
$cshow :: IdrisColour -> String
show :: IdrisColour -> String
$cshowList :: [IdrisColour] -> ShowS
showList :: [IdrisColour] -> ShowS
Show)

mkColour :: Color -> IdrisColour
mkColour :: Color -> IdrisColour
mkColour Color
c = Maybe Color -> Bool -> Bool -> Bool -> Bool -> IdrisColour
IdrisColour (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
c) Bool
True Bool
False Bool
False Bool
False

data ColourTheme = ColourTheme { ColourTheme -> IdrisColour
keywordColour   :: IdrisColour
                               , ColourTheme -> IdrisColour
boundVarColour  :: IdrisColour
                               , ColourTheme -> IdrisColour
implicitColour  :: IdrisColour
                               , ColourTheme -> IdrisColour
functionColour  :: IdrisColour
                               , ColourTheme -> IdrisColour
typeColour      :: IdrisColour
                               , ColourTheme -> IdrisColour
dataColour      :: IdrisColour
                               , ColourTheme -> IdrisColour
promptColour    :: IdrisColour
                               , ColourTheme -> IdrisColour
postulateColour :: IdrisColour
                               }
                   deriving (ColourTheme -> ColourTheme -> Bool
(ColourTheme -> ColourTheme -> Bool)
-> (ColourTheme -> ColourTheme -> Bool) -> Eq ColourTheme
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ColourTheme -> ColourTheme -> Bool
== :: ColourTheme -> ColourTheme -> Bool
$c/= :: ColourTheme -> ColourTheme -> Bool
/= :: ColourTheme -> ColourTheme -> Bool
Eq, Int -> ColourTheme -> ShowS
[ColourTheme] -> ShowS
ColourTheme -> String
(Int -> ColourTheme -> ShowS)
-> (ColourTheme -> String)
-> ([ColourTheme] -> ShowS)
-> Show ColourTheme
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ColourTheme -> ShowS
showsPrec :: Int -> ColourTheme -> ShowS
$cshow :: ColourTheme -> String
show :: ColourTheme -> String
$cshowList :: [ColourTheme] -> ShowS
showList :: [ColourTheme] -> ShowS
Show, (forall x. ColourTheme -> Rep ColourTheme x)
-> (forall x. Rep ColourTheme x -> ColourTheme)
-> Generic ColourTheme
forall x. Rep ColourTheme x -> ColourTheme
forall x. ColourTheme -> Rep ColourTheme x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ColourTheme -> Rep ColourTheme x
from :: forall x. ColourTheme -> Rep ColourTheme x
$cto :: forall x. Rep ColourTheme x -> ColourTheme
to :: forall x. Rep ColourTheme x -> ColourTheme
Generic)

-- | Idris's default console colour theme
defaultTheme :: ColourTheme
defaultTheme :: ColourTheme
defaultTheme = ColourTheme { keywordColour :: IdrisColour
keywordColour = Maybe Color -> Bool -> Bool -> Bool -> Bool -> IdrisColour
IdrisColour Maybe Color
forall a. Maybe a
Nothing Bool
True Bool
False Bool
True Bool
False
                           , boundVarColour :: IdrisColour
boundVarColour = Color -> IdrisColour
mkColour Color
Magenta
                           , implicitColour :: IdrisColour
implicitColour = Maybe Color -> Bool -> Bool -> Bool -> Bool -> IdrisColour
IdrisColour (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
Magenta) Bool
True Bool
True Bool
False Bool
False
                           , functionColour :: IdrisColour
functionColour = Color -> IdrisColour
mkColour Color
Green
                           , typeColour :: IdrisColour
typeColour = Color -> IdrisColour
mkColour Color
Blue
                           , dataColour :: IdrisColour
dataColour = Color -> IdrisColour
mkColour Color
Red
                           , promptColour :: IdrisColour
promptColour = Maybe Color -> Bool -> Bool -> Bool -> Bool -> IdrisColour
IdrisColour Maybe Color
forall a. Maybe a
Nothing Bool
True Bool
False Bool
True Bool
False
                           , postulateColour :: IdrisColour
postulateColour = Maybe Color -> Bool -> Bool -> Bool -> Bool -> IdrisColour
IdrisColour (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
Green) Bool
True Bool
False Bool
True Bool
False
                           }

-- | Compute the ANSI colours corresponding to an Idris colour
mkSGR :: IdrisColour -> [SGR]
mkSGR :: IdrisColour -> [SGR]
mkSGR (IdrisColour Maybe Color
c Bool
v Bool
u Bool
b Bool
i) =
    Maybe Color -> [SGR]
fg Maybe Color
c [SGR] -> [SGR] -> [SGR]
forall a. [a] -> [a] -> [a]
++
    [Underlining -> SGR
SetUnderlining Underlining
SingleUnderline | Bool
u] [SGR] -> [SGR] -> [SGR]
forall a. [a] -> [a] -> [a]
++
    [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity | Bool
b] [SGR] -> [SGR] -> [SGR]
forall a. [a] -> [a] -> [a]
++
    [Bool -> SGR
SetItalicized Bool
True | Bool
i]
  where
    fg :: Maybe Color -> [SGR]
fg Maybe Color
Nothing = []
    fg (Just Color
c) = [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground (if Bool
v then ColorIntensity
Vivid else ColorIntensity
Dull) Color
c]

-- | Set the colour of a string using POSIX escape codes
colourise :: IdrisColour -> String -> String
colourise :: IdrisColour -> ShowS
colourise IdrisColour
c String
str = [SGR] -> String
setSGRCode (IdrisColour -> [SGR]
mkSGR IdrisColour
c) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ [SGR] -> String
setSGRCode [SGR
Reset]

-- | Start a colour on a handle, to support colour output on Windows
hStartColourise :: Handle -> IdrisColour -> IO ()
hStartColourise :: Handle -> IdrisColour -> IO ()
hStartColourise Handle
h IdrisColour
c = Handle -> [SGR] -> IO ()
hSetSGR Handle
h (IdrisColour -> [SGR]
mkSGR IdrisColour
c)

-- | End a colour region on a handle
hEndColourise :: Handle -> IdrisColour -> IO ()
hEndColourise :: Handle -> IdrisColour -> IO ()
hEndColourise Handle
h IdrisColour
_ = Handle -> [SGR] -> IO ()
hSetSGR Handle
h [SGR
Reset]

-- | Set the colour of a string using POSIX escape codes, with trailing '\STX' denoting the end
-- (required by Haskeline in the prompt string)
colouriseWithSTX :: IdrisColour -> String -> String
colouriseWithSTX :: IdrisColour -> ShowS
colouriseWithSTX (IdrisColour Maybe Color
c Bool
v Bool
u Bool
b Bool
i) String
str = [SGR] -> String
setSGRCode [SGR]
sgr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\STX" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ [SGR] -> String
setSGRCode [SGR
Reset] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\STX"
    where sgr :: [SGR]
sgr = Maybe Color -> [SGR]
fg Maybe Color
c [SGR] -> [SGR] -> [SGR]
forall a. [a] -> [a] -> [a]
++
                [Underlining -> SGR
SetUnderlining Underlining
SingleUnderline | Bool
u] [SGR] -> [SGR] -> [SGR]
forall a. [a] -> [a] -> [a]
++
                [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity | Bool
b] [SGR] -> [SGR] -> [SGR]
forall a. [a] -> [a] -> [a]
++
                [Bool -> SGR
SetItalicized Bool
True | Bool
i]
          fg :: Maybe Color -> [SGR]
fg Maybe Color
Nothing = []
          fg (Just Color
c) = [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground (if Bool
v then ColorIntensity
Vivid else ColorIntensity
Dull) Color
c]

colouriseKwd :: ColourTheme -> String -> String
colouriseKwd :: ColourTheme -> ShowS
colouriseKwd ColourTheme
t = IdrisColour -> ShowS
colourise (ColourTheme -> IdrisColour
keywordColour ColourTheme
t)

colouriseBound :: ColourTheme -> String -> String
colouriseBound :: ColourTheme -> ShowS
colouriseBound ColourTheme
t = IdrisColour -> ShowS
colourise (ColourTheme -> IdrisColour
boundVarColour ColourTheme
t)

colouriseImplicit :: ColourTheme -> String -> String
colouriseImplicit :: ColourTheme -> ShowS
colouriseImplicit ColourTheme
t = IdrisColour -> ShowS
colourise (ColourTheme -> IdrisColour
implicitColour ColourTheme
t)

colouriseFun :: ColourTheme -> String -> String
colouriseFun :: ColourTheme -> ShowS
colouriseFun ColourTheme
t = IdrisColour -> ShowS
colourise (ColourTheme -> IdrisColour
functionColour ColourTheme
t)

colouriseType :: ColourTheme -> String -> String
colouriseType :: ColourTheme -> ShowS
colouriseType ColourTheme
t = IdrisColour -> ShowS
colourise (ColourTheme -> IdrisColour
typeColour ColourTheme
t)

colouriseData :: ColourTheme -> String -> String
colouriseData :: ColourTheme -> ShowS
colouriseData ColourTheme
t = IdrisColour -> ShowS
colourise (ColourTheme -> IdrisColour
dataColour ColourTheme
t)

colourisePrompt :: ColourTheme -> String -> String
colourisePrompt :: ColourTheme -> ShowS
colourisePrompt ColourTheme
t = IdrisColour -> ShowS
colouriseWithSTX (ColourTheme -> IdrisColour
promptColour ColourTheme
t)

colouriseKeyword :: ColourTheme -> String -> String
colouriseKeyword :: ColourTheme -> ShowS
colouriseKeyword ColourTheme
t = IdrisColour -> ShowS
colourise (ColourTheme -> IdrisColour
keywordColour ColourTheme
t)

colourisePostulate :: ColourTheme -> String -> String
colourisePostulate :: ColourTheme -> ShowS
colourisePostulate ColourTheme
t = IdrisColour -> ShowS
colourise (ColourTheme -> IdrisColour
postulateColour ColourTheme
t)


data ColourType = KeywordColour
                | BoundVarColour
                | ImplicitColour
                | FunctionColour
                | TypeColour
                | DataColour
                | PromptColour
                | PostulateColour
                  deriving (ColourType -> ColourType -> Bool
(ColourType -> ColourType -> Bool)
-> (ColourType -> ColourType -> Bool) -> Eq ColourType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ColourType -> ColourType -> Bool
== :: ColourType -> ColourType -> Bool
$c/= :: ColourType -> ColourType -> Bool
/= :: ColourType -> ColourType -> Bool
Eq, Int -> ColourType -> ShowS
[ColourType] -> ShowS
ColourType -> String
(Int -> ColourType -> ShowS)
-> (ColourType -> String)
-> ([ColourType] -> ShowS)
-> Show ColourType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ColourType -> ShowS
showsPrec :: Int -> ColourType -> ShowS
$cshow :: ColourType -> String
show :: ColourType -> String
$cshowList :: [ColourType] -> ShowS
showList :: [ColourType] -> ShowS
Show, ColourType
ColourType -> ColourType -> Bounded ColourType
forall a. a -> a -> Bounded a
$cminBound :: ColourType
minBound :: ColourType
$cmaxBound :: ColourType
maxBound :: ColourType
Bounded, Int -> ColourType
ColourType -> Int
ColourType -> [ColourType]
ColourType -> ColourType
ColourType -> ColourType -> [ColourType]
ColourType -> ColourType -> ColourType -> [ColourType]
(ColourType -> ColourType)
-> (ColourType -> ColourType)
-> (Int -> ColourType)
-> (ColourType -> Int)
-> (ColourType -> [ColourType])
-> (ColourType -> ColourType -> [ColourType])
-> (ColourType -> ColourType -> [ColourType])
-> (ColourType -> ColourType -> ColourType -> [ColourType])
-> Enum ColourType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ColourType -> ColourType
succ :: ColourType -> ColourType
$cpred :: ColourType -> ColourType
pred :: ColourType -> ColourType
$ctoEnum :: Int -> ColourType
toEnum :: Int -> ColourType
$cfromEnum :: ColourType -> Int
fromEnum :: ColourType -> Int
$cenumFrom :: ColourType -> [ColourType]
enumFrom :: ColourType -> [ColourType]
$cenumFromThen :: ColourType -> ColourType -> [ColourType]
enumFromThen :: ColourType -> ColourType -> [ColourType]
$cenumFromTo :: ColourType -> ColourType -> [ColourType]
enumFromTo :: ColourType -> ColourType -> [ColourType]
$cenumFromThenTo :: ColourType -> ColourType -> ColourType -> [ColourType]
enumFromThenTo :: ColourType -> ColourType -> ColourType -> [ColourType]
Enum)