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 IO (hPutStrLn,stderr)
import System (getEnv)
import List

-- | Colour preferences.
data variantselection :: [Highlight]ColourPrefs = ColourPrefs ::
  [Highlight]
  -> [Highlight]
  -> [Highlight]
  -> [Highlight]
  -> [Highlight]
  -> [Highlight]
  -> [Highlight]
  -> [Highlight]
  -> [Highlight]
  -> [Highlight]
  -> [Highlight]
  -> [Highlight]
  -> [Highlight]
  -> [Highlight]
  -> [Highlight]
  -> ColourPrefsColourPrefs
  { keyword :: ColourPrefs -> [Highlight]keyword, keyglyph :: ColourPrefs -> [Highlight]keyglyph, layout :: ColourPrefs -> [Highlight]layout, comment :: ColourPrefs -> [Highlight]comment
  , conid :: ColourPrefs -> [Highlight]conid, varid :: ColourPrefs -> [Highlight]varid, conop :: ColourPrefs -> [Highlight]conop, varop :: ColourPrefs -> [Highlight]varop
  , string :: ColourPrefs -> [Highlight]string, char :: ColourPrefs -> [Highlight]char, number :: ColourPrefs -> [Highlight]number, cpp :: ColourPrefs -> [Highlight]cpp
  , selection :: ColourPrefs -> [Highlight]selection, variantselection :: ColourPrefs -> [Highlight]variantselection, definition :: ColourPrefs -> [Highlight]definition :: [Highlight]
  } deriving (D:Eq :: (a -> a -> Bool) -> (a -> a -> Bool) -> T:Eq aEq,D:Show ::
  (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> T:Show aShow,D:Read ::
  (Int -> ReadS a)
  -> ReadS [a]
  -> ReadPrec a
  -> ReadPrec [a]
  -> T:Read aRead)

defaultColourPrefs :: ColourPrefsdefaultColourPrefs = ColourPrefs
  { keyword :: [Highlight]keyword  = [Foreground :: Colour -> HighlightForeground Green :: ColourGreen,Underscore :: HighlightUnderscore]
  , keyglyph :: [Highlight]keyglyph = [Foreground :: Colour -> HighlightForeground Red :: ColourRed]
  , layout :: [Highlight]layout   = [Foreground :: Colour -> HighlightForeground Cyan :: ColourCyan]
  , comment :: [Highlight]comment  = [Foreground :: Colour -> HighlightForeground Blue :: ColourBlue, Italic :: HighlightItalic]
  , conid :: [Highlight]conid    = [Normal :: HighlightNormal]
  , varid :: [Highlight]varid    = [Normal :: HighlightNormal]
  , conop :: [Highlight]conop    = [Foreground :: Colour -> HighlightForeground Red :: ColourRed,Bold :: HighlightBold]
  , varop :: [Highlight]varop    = [Foreground :: Colour -> HighlightForeground Cyan :: ColourCyan]
  , string :: [Highlight]string   = [Foreground :: Colour -> HighlightForeground Magenta :: ColourMagenta]
  , char :: [Highlight]char     = [Foreground :: Colour -> HighlightForeground Magenta :: ColourMagenta]
  , number :: [Highlight]number   = [Foreground :: Colour -> HighlightForeground Magenta :: ColourMagenta]
  , cpp :: [Highlight]cpp      = [Foreground :: Colour -> HighlightForeground Magenta :: ColourMagenta,Dim :: HighlightDim]
  , selection :: [Highlight]selection = [Bold :: HighlightBold, Foreground :: Colour -> HighlightForeground Magenta :: ColourMagenta]
  , variantselection :: [Highlight]variantselection = [Dim :: HighlightDim, Foreground :: Colour -> HighlightForeground Red :: ColourRed, Underscore :: HighlightUnderscore]
  , definition :: [Highlight]definition = [Foreground :: Colour -> HighlightForeground Blue :: ColourBlue]
  }

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

-- | 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 ColourPrefsreadColourPrefs = catch :: IO a -> (IOError -> IO a) -> IO acatch
  (do val :: Stringval <- readFile :: FilePath -> IO StringreadFile ".hscolour"
      parseColourPrefs :: String -> String -> IO ColourPrefsparseColourPrefs ".hscolour" val :: Stringval)
  (\_-> catch :: IO a -> (IOError -> IO a) -> IO acatch
    (do home :: Stringhome <- getEnv :: String -> IO StringgetEnv "HOME"
        val :: Stringval <- readFile :: FilePath -> IO StringreadFile (home :: Stringhome(++) :: [a] -> [a] -> [a]++"/.hscolour")
        parseColourPrefs :: String -> String -> IO ColourPrefsparseColourPrefs (home :: Stringhome(++) :: [a] -> [a] -> [a]++"/.hscolour") val :: Stringval)
    (\_-> return :: Monad m => forall a. a -> m areturn defaultColourPrefs :: ColourPrefsdefaultColourPrefs))

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