{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Text.Colour.Capabilities where
import Control.Exception
import GHC.Generics (Generic)
import qualified System.Console.Terminfo as Terminfo
import System.Environment (lookupEnv)
import System.IO
data TerminalCapabilities
=
WithoutColours
|
With8Colours
|
With8BitColours
|
With24BitColours
deriving (Int -> TerminalCapabilities -> ShowS
[TerminalCapabilities] -> ShowS
TerminalCapabilities -> String
(Int -> TerminalCapabilities -> ShowS)
-> (TerminalCapabilities -> String)
-> ([TerminalCapabilities] -> ShowS)
-> Show TerminalCapabilities
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TerminalCapabilities] -> ShowS
$cshowList :: [TerminalCapabilities] -> ShowS
show :: TerminalCapabilities -> String
$cshow :: TerminalCapabilities -> String
showsPrec :: Int -> TerminalCapabilities -> ShowS
$cshowsPrec :: Int -> TerminalCapabilities -> ShowS
Show, TerminalCapabilities -> TerminalCapabilities -> Bool
(TerminalCapabilities -> TerminalCapabilities -> Bool)
-> (TerminalCapabilities -> TerminalCapabilities -> Bool)
-> Eq TerminalCapabilities
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TerminalCapabilities -> TerminalCapabilities -> Bool
$c/= :: TerminalCapabilities -> TerminalCapabilities -> Bool
== :: TerminalCapabilities -> TerminalCapabilities -> Bool
$c== :: TerminalCapabilities -> TerminalCapabilities -> Bool
Eq, Eq TerminalCapabilities
Eq TerminalCapabilities
-> (TerminalCapabilities -> TerminalCapabilities -> Ordering)
-> (TerminalCapabilities -> TerminalCapabilities -> Bool)
-> (TerminalCapabilities -> TerminalCapabilities -> Bool)
-> (TerminalCapabilities -> TerminalCapabilities -> Bool)
-> (TerminalCapabilities -> TerminalCapabilities -> Bool)
-> (TerminalCapabilities
-> TerminalCapabilities -> TerminalCapabilities)
-> (TerminalCapabilities
-> TerminalCapabilities -> TerminalCapabilities)
-> Ord TerminalCapabilities
TerminalCapabilities -> TerminalCapabilities -> Bool
TerminalCapabilities -> TerminalCapabilities -> Ordering
TerminalCapabilities
-> TerminalCapabilities -> TerminalCapabilities
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TerminalCapabilities
-> TerminalCapabilities -> TerminalCapabilities
$cmin :: TerminalCapabilities
-> TerminalCapabilities -> TerminalCapabilities
max :: TerminalCapabilities
-> TerminalCapabilities -> TerminalCapabilities
$cmax :: TerminalCapabilities
-> TerminalCapabilities -> TerminalCapabilities
>= :: TerminalCapabilities -> TerminalCapabilities -> Bool
$c>= :: TerminalCapabilities -> TerminalCapabilities -> Bool
> :: TerminalCapabilities -> TerminalCapabilities -> Bool
$c> :: TerminalCapabilities -> TerminalCapabilities -> Bool
<= :: TerminalCapabilities -> TerminalCapabilities -> Bool
$c<= :: TerminalCapabilities -> TerminalCapabilities -> Bool
< :: TerminalCapabilities -> TerminalCapabilities -> Bool
$c< :: TerminalCapabilities -> TerminalCapabilities -> Bool
compare :: TerminalCapabilities -> TerminalCapabilities -> Ordering
$ccompare :: TerminalCapabilities -> TerminalCapabilities -> Ordering
$cp1Ord :: Eq TerminalCapabilities
Ord, (forall x. TerminalCapabilities -> Rep TerminalCapabilities x)
-> (forall x. Rep TerminalCapabilities x -> TerminalCapabilities)
-> Generic TerminalCapabilities
forall x. Rep TerminalCapabilities x -> TerminalCapabilities
forall x. TerminalCapabilities -> Rep TerminalCapabilities x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TerminalCapabilities x -> TerminalCapabilities
$cfrom :: forall x. TerminalCapabilities -> Rep TerminalCapabilities x
Generic)
getTerminalCapabilitiesFromEnv :: IO TerminalCapabilities
getTerminalCapabilitiesFromEnv :: IO TerminalCapabilities
getTerminalCapabilitiesFromEnv = do
Maybe Terminal
mTerm <- (Terminal -> Maybe Terminal
forall a. a -> Maybe a
Just (Terminal -> Maybe Terminal) -> IO Terminal -> IO (Maybe Terminal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Terminal
Terminfo.setupTermFromEnv) IO (Maybe Terminal)
-> (SetupTermError -> IO (Maybe Terminal)) -> IO (Maybe Terminal)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(SetupTermError
_ :: Terminfo.SetupTermError) -> Maybe Terminal -> IO (Maybe Terminal)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Terminal
forall a. Maybe a
Nothing)
case Maybe Terminal
mTerm of
Maybe Terminal
Nothing -> TerminalCapabilities -> IO TerminalCapabilities
forall (f :: * -> *) a. Applicative f => a -> f a
pure TerminalCapabilities
WithoutColours
Just Terminal
term -> do
Maybe String
mct <- String -> IO (Maybe String)
lookupEnv String
"COLORTERM"
TerminalCapabilities -> IO TerminalCapabilities
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TerminalCapabilities -> IO TerminalCapabilities)
-> TerminalCapabilities -> IO TerminalCapabilities
forall a b. (a -> b) -> a -> b
$ case Maybe String
mct of
Just String
"truecolor" -> TerminalCapabilities
With24BitColours
Just String
"24bit" -> TerminalCapabilities
With24BitColours
Maybe String
_ ->
case Terminal -> Capability Int -> Maybe Int
forall a. Terminal -> Capability a -> Maybe a
Terminfo.getCapability Terminal
term (String -> Capability Int
Terminfo.tiGetNum String
"colors") of
Maybe Int
Nothing -> TerminalCapabilities
WithoutColours
Just Int
c
| Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
256 -> TerminalCapabilities
With24BitColours
| Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
256 -> TerminalCapabilities
With8BitColours
| Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
8 -> TerminalCapabilities
With8Colours
| Bool
otherwise -> TerminalCapabilities
WithoutColours
getTerminalCapabilitiesFromHandle :: Handle -> IO TerminalCapabilities
getTerminalCapabilitiesFromHandle :: Handle -> IO TerminalCapabilities
getTerminalCapabilitiesFromHandle Handle
h = do
Bool
isTerm <- Handle -> IO Bool
hIsTerminalDevice Handle
h
if Bool
isTerm
then IO TerminalCapabilities
getTerminalCapabilitiesFromEnv
else TerminalCapabilities -> IO TerminalCapabilities
forall (f :: * -> *) a. Applicative f => a -> f a
pure TerminalCapabilities
WithoutColours