{-# 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 { colour    :: Maybe Color
                               , vivid     :: Bool
                               , underline :: Bool
                               , bold      :: Bool
                               , italic    :: Bool
                               }
                   deriving (Eq, Show)

mkColour :: Color -> IdrisColour
mkColour c = IdrisColour (Just c) True False False False

data ColourTheme = ColourTheme { keywordColour   :: IdrisColour
                               , boundVarColour  :: IdrisColour
                               , implicitColour  :: IdrisColour
                               , functionColour  :: IdrisColour
                               , typeColour      :: IdrisColour
                               , dataColour      :: IdrisColour
                               , promptColour    :: IdrisColour
                               , postulateColour :: IdrisColour
                               }
                   deriving (Eq, Show, Generic)

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

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

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

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

-- | End a colour region on a handle
hEndColourise :: Handle -> IdrisColour -> IO ()
hEndColourise h _ = hSetSGR h [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 c v u b i) str = setSGRCode sgr ++ "\STX" ++ str ++ setSGRCode [Reset] ++ "\STX"
    where sgr = fg c ++
                [SetUnderlining SingleUnderline | u] ++
                [SetConsoleIntensity BoldIntensity | b] ++
                [SetItalicized True | i]
          fg Nothing = []
          fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c]

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

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

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

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

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

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

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

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

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


data ColourType = KeywordColour
                | BoundVarColour
                | ImplicitColour
                | FunctionColour
                | TypeColour
                | DataColour
                | PromptColour
                | PostulateColour
                  deriving (Eq, Show, Bounded, Enum)