{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.HsColour.Colourise
  ( module Language.Haskell.HsColour.ColourHighlight
  , ColourPrefs(..)
  , readColourPrefs
  , defaultColourPrefs
  , colourise
  ) where

import Language.Haskell.HsColour.ColourHighlight
import Language.Haskell.HsColour.Classify (TokenType(..))

import System.IO (hPutStrLn,stderr)
import System.Environment (getEnv)
import Data.List
import Prelude hiding (catch)
import Control.Exception.Base (catch)

-- | Colour preferences.
data ColourPrefs = ColourPrefs
  { ColourPrefs -> [Highlight]
keyword, ColourPrefs -> [Highlight]
keyglyph, ColourPrefs -> [Highlight]
layout, ColourPrefs -> [Highlight]
comment
  , ColourPrefs -> [Highlight]
conid, ColourPrefs -> [Highlight]
varid, ColourPrefs -> [Highlight]
conop, ColourPrefs -> [Highlight]
varop
  , ColourPrefs -> [Highlight]
string, ColourPrefs -> [Highlight]
char, ColourPrefs -> [Highlight]
number, ColourPrefs -> [Highlight]
cpp
  , ColourPrefs -> [Highlight]
selection, ColourPrefs -> [Highlight]
variantselection, ColourPrefs -> [Highlight]
definition :: [Highlight]
  } deriving (ColourPrefs -> ColourPrefs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColourPrefs -> ColourPrefs -> Bool
$c/= :: ColourPrefs -> ColourPrefs -> Bool
== :: ColourPrefs -> ColourPrefs -> Bool
$c== :: ColourPrefs -> ColourPrefs -> Bool
Eq,Int -> ColourPrefs -> ShowS
[ColourPrefs] -> ShowS
ColourPrefs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ColourPrefs] -> ShowS
$cshowList :: [ColourPrefs] -> ShowS
show :: ColourPrefs -> String
$cshow :: ColourPrefs -> String
showsPrec :: Int -> ColourPrefs -> ShowS
$cshowsPrec :: Int -> ColourPrefs -> ShowS
Show,ReadPrec [ColourPrefs]
ReadPrec ColourPrefs
Int -> ReadS ColourPrefs
ReadS [ColourPrefs]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ColourPrefs]
$creadListPrec :: ReadPrec [ColourPrefs]
readPrec :: ReadPrec ColourPrefs
$creadPrec :: ReadPrec ColourPrefs
readList :: ReadS [ColourPrefs]
$creadList :: ReadS [ColourPrefs]
readsPrec :: Int -> ReadS ColourPrefs
$creadsPrec :: Int -> ReadS ColourPrefs
Read)

defaultColourPrefs :: ColourPrefs
defaultColourPrefs = ColourPrefs
  { keyword :: [Highlight]
keyword  = [Colour -> Highlight
Foreground Colour
Green,Highlight
Underscore]
  , keyglyph :: [Highlight]
keyglyph = [Colour -> Highlight
Foreground Colour
Red]
  , layout :: [Highlight]
layout   = [Colour -> Highlight
Foreground Colour
Cyan]
  , comment :: [Highlight]
comment  = [Colour -> Highlight
Foreground Colour
Blue, Highlight
Italic]
  , conid :: [Highlight]
conid    = [Highlight
Normal]
  , varid :: [Highlight]
varid    = [Highlight
Normal]
  , conop :: [Highlight]
conop    = [Colour -> Highlight
Foreground Colour
Red,Highlight
Bold]
  , varop :: [Highlight]
varop    = [Colour -> Highlight
Foreground Colour
Cyan]
  , string :: [Highlight]
string   = [Colour -> Highlight
Foreground Colour
Magenta]
  , char :: [Highlight]
char     = [Colour -> Highlight
Foreground Colour
Magenta]
  , number :: [Highlight]
number   = [Colour -> Highlight
Foreground Colour
Magenta]
  , cpp :: [Highlight]
cpp      = [Colour -> Highlight
Foreground Colour
Magenta,Highlight
Dim]
  , selection :: [Highlight]
selection = [Highlight
Bold, Colour -> Highlight
Foreground Colour
Magenta]
  , variantselection :: [Highlight]
variantselection = [Highlight
Dim, Colour -> Highlight
Foreground Colour
Red, Highlight
Underscore]
  , definition :: [Highlight]
definition = [Colour -> Highlight
Foreground Colour
Blue]
  }

-- NOTE, should we give a warning message on a failed reading?
parseColourPrefs :: String -> String -> IO ColourPrefs
parseColourPrefs :: String -> String -> IO ColourPrefs
parseColourPrefs String
file String
x =
    case forall a. Read a => ReadS a
reads String
x of
        (ColourPrefs
res,String
_):[(ColourPrefs, String)]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ColourPrefs
res
        [(ColourPrefs, String)]
_ -> do Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"Could not parse colour prefs from "forall a. [a] -> [a] -> [a]
++String
file
                                  forall a. [a] -> [a] -> [a]
++String
": reverting to defaults")
                forall (m :: * -> *) a. Monad m => a -> m a
return ColourPrefs
defaultColourPrefs

-- | Read colour preferences from .hscolour file in the current directory, or failing that,
--   from \$HOME\/.hscolour, and failing that, returns a default set of prefs.
readColourPrefs :: IO ColourPrefs
readColourPrefs :: IO ColourPrefs
readColourPrefs = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
  (do String
val <- String -> IO String
readFile String
".hscolour"
      String -> String -> IO ColourPrefs
parseColourPrefs String
".hscolour" String
val)
  (\ (IOError
_::IOError)-> forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
    (do String
home <- String -> IO String
getEnv String
"HOME"
        String
val <- String -> IO String
readFile (String
homeforall a. [a] -> [a] -> [a]
++String
"/.hscolour")
        String -> String -> IO ColourPrefs
parseColourPrefs (String
homeforall a. [a] -> [a] -> [a]
++String
"/.hscolour") String
val)
    (\ (IOError
_::IOError)-> forall (m :: * -> *) a. Monad m => a -> m a
return ColourPrefs
defaultColourPrefs))

-- | Convert token classification to colour highlights.
colourise :: ColourPrefs -> TokenType -> [Highlight]
colourise :: ColourPrefs -> TokenType -> [Highlight]
colourise ColourPrefs
pref TokenType
Space    = [Highlight
Normal]
colourise ColourPrefs
pref TokenType
Comment  = ColourPrefs -> [Highlight]
comment ColourPrefs
pref
colourise ColourPrefs
pref TokenType
Keyword  = ColourPrefs -> [Highlight]
keyword ColourPrefs
pref
colourise ColourPrefs
pref TokenType
Keyglyph = ColourPrefs -> [Highlight]
keyglyph ColourPrefs
pref
colourise ColourPrefs
pref TokenType
Layout   = ColourPrefs -> [Highlight]
layout ColourPrefs
pref
colourise ColourPrefs
pref TokenType
Conid    = ColourPrefs -> [Highlight]
conid ColourPrefs
pref
colourise ColourPrefs
pref TokenType
Varid    = ColourPrefs -> [Highlight]
varid ColourPrefs
pref
colourise ColourPrefs
pref TokenType
Conop    = ColourPrefs -> [Highlight]
conop ColourPrefs
pref
colourise ColourPrefs
pref TokenType
Varop    = ColourPrefs -> [Highlight]
varop ColourPrefs
pref
colourise ColourPrefs
pref TokenType
String   = ColourPrefs -> [Highlight]
string ColourPrefs
pref
colourise ColourPrefs
pref TokenType
Char     = ColourPrefs -> [Highlight]
char ColourPrefs
pref
colourise ColourPrefs
pref TokenType
Number   = ColourPrefs -> [Highlight]
number ColourPrefs
pref
colourise ColourPrefs
pref TokenType
Cpp      = ColourPrefs -> [Highlight]
cpp ColourPrefs
pref
colourise ColourPrefs
pref TokenType
Error    = ColourPrefs -> [Highlight]
selection ColourPrefs
pref
colourise ColourPrefs
pref TokenType
Definition = ColourPrefs -> [Highlight]
definition ColourPrefs
pref