{-# LANGUAGE RecordWildCards, UndecidableInstances #-}

module Blucontrol.Recolor.X (
  RecolorXT
, runRecolorXTIO
, ConfigX (..)
, XError (..)
) where

import Control.DeepSeq
import Control.Exception.Lifted (SomeException (..), bracket, catch)
import Control.Monad.Base
import Control.Monad.Trans.Control
import Control.Monad.Reader
import Control.Monad.Except
import Data.Default
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import GHC.Generics

import Graphics.X11.Xlib.Display (closeDisplay, defaultScreen, openDisplay, rootWindow)
import Graphics.X11.Xlib.Types (Display)

import Blucontrol.RGB
import Blucontrol.Recolor
import Blucontrol.Recolor.X.Internal

newtype RecolorXT m a = RecolorXT { RecolorXT m a -> ExceptT XError (ReaderT Display m) a
unRecolorXT :: ExceptT XError (ReaderT Display m) a }
  deriving (Functor (RecolorXT m)
a -> RecolorXT m a
Functor (RecolorXT m)
-> (forall a. a -> RecolorXT m a)
-> (forall a b.
    RecolorXT m (a -> b) -> RecolorXT m a -> RecolorXT m b)
-> (forall a b c.
    (a -> b -> c) -> RecolorXT m a -> RecolorXT m b -> RecolorXT m c)
-> (forall a b. RecolorXT m a -> RecolorXT m b -> RecolorXT m b)
-> (forall a b. RecolorXT m a -> RecolorXT m b -> RecolorXT m a)
-> Applicative (RecolorXT m)
RecolorXT m a -> RecolorXT m b -> RecolorXT m b
RecolorXT m a -> RecolorXT m b -> RecolorXT m a
RecolorXT m (a -> b) -> RecolorXT m a -> RecolorXT m b
(a -> b -> c) -> RecolorXT m a -> RecolorXT m b -> RecolorXT m c
forall a. a -> RecolorXT m a
forall a b. RecolorXT m a -> RecolorXT m b -> RecolorXT m a
forall a b. RecolorXT m a -> RecolorXT m b -> RecolorXT m b
forall a b. RecolorXT m (a -> b) -> RecolorXT m a -> RecolorXT m b
forall a b c.
(a -> b -> c) -> RecolorXT m a -> RecolorXT m b -> RecolorXT m c
forall (m :: * -> *). Monad m => Functor (RecolorXT m)
forall (m :: * -> *) a. Monad m => a -> RecolorXT m a
forall (m :: * -> *) a b.
Monad m =>
RecolorXT m a -> RecolorXT m b -> RecolorXT m a
forall (m :: * -> *) a b.
Monad m =>
RecolorXT m a -> RecolorXT m b -> RecolorXT m b
forall (m :: * -> *) a b.
Monad m =>
RecolorXT m (a -> b) -> RecolorXT m a -> RecolorXT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> RecolorXT m a -> RecolorXT m b -> RecolorXT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: RecolorXT m a -> RecolorXT m b -> RecolorXT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
RecolorXT m a -> RecolorXT m b -> RecolorXT m a
*> :: RecolorXT m a -> RecolorXT m b -> RecolorXT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
RecolorXT m a -> RecolorXT m b -> RecolorXT m b
liftA2 :: (a -> b -> c) -> RecolorXT m a -> RecolorXT m b -> RecolorXT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> RecolorXT m a -> RecolorXT m b -> RecolorXT m c
<*> :: RecolorXT m (a -> b) -> RecolorXT m a -> RecolorXT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
RecolorXT m (a -> b) -> RecolorXT m a -> RecolorXT m b
pure :: a -> RecolorXT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> RecolorXT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (RecolorXT m)
Applicative, a -> RecolorXT m b -> RecolorXT m a
(a -> b) -> RecolorXT m a -> RecolorXT m b
(forall a b. (a -> b) -> RecolorXT m a -> RecolorXT m b)
-> (forall a b. a -> RecolorXT m b -> RecolorXT m a)
-> Functor (RecolorXT m)
forall a b. a -> RecolorXT m b -> RecolorXT m a
forall a b. (a -> b) -> RecolorXT m a -> RecolorXT m b
forall (m :: * -> *) a b.
Functor m =>
a -> RecolorXT m b -> RecolorXT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RecolorXT m a -> RecolorXT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RecolorXT m b -> RecolorXT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> RecolorXT m b -> RecolorXT m a
fmap :: (a -> b) -> RecolorXT m a -> RecolorXT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RecolorXT m a -> RecolorXT m b
Functor, Applicative (RecolorXT m)
a -> RecolorXT m a
Applicative (RecolorXT m)
-> (forall a b.
    RecolorXT m a -> (a -> RecolorXT m b) -> RecolorXT m b)
-> (forall a b. RecolorXT m a -> RecolorXT m b -> RecolorXT m b)
-> (forall a. a -> RecolorXT m a)
-> Monad (RecolorXT m)
RecolorXT m a -> (a -> RecolorXT m b) -> RecolorXT m b
RecolorXT m a -> RecolorXT m b -> RecolorXT m b
forall a. a -> RecolorXT m a
forall a b. RecolorXT m a -> RecolorXT m b -> RecolorXT m b
forall a b. RecolorXT m a -> (a -> RecolorXT m b) -> RecolorXT m b
forall (m :: * -> *). Monad m => Applicative (RecolorXT m)
forall (m :: * -> *) a. Monad m => a -> RecolorXT m a
forall (m :: * -> *) a b.
Monad m =>
RecolorXT m a -> RecolorXT m b -> RecolorXT m b
forall (m :: * -> *) a b.
Monad m =>
RecolorXT m a -> (a -> RecolorXT m b) -> RecolorXT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> RecolorXT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> RecolorXT m a
>> :: RecolorXT m a -> RecolorXT m b -> RecolorXT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
RecolorXT m a -> RecolorXT m b -> RecolorXT m b
>>= :: RecolorXT m a -> (a -> RecolorXT m b) -> RecolorXT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
RecolorXT m a -> (a -> RecolorXT m b) -> RecolorXT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (RecolorXT m)
Monad, MonadBase b, MonadBaseControl b, MonadError XError)

instance MonadTrans RecolorXT where
  lift :: m a -> RecolorXT m a
lift = ExceptT XError (ReaderT Display m) a -> RecolorXT m a
forall (m :: * -> *) a.
ExceptT XError (ReaderT Display m) a -> RecolorXT m a
RecolorXT (ExceptT XError (ReaderT Display m) a -> RecolorXT m a)
-> (m a -> ExceptT XError (ReaderT Display m) a)
-> m a
-> RecolorXT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Display m a -> ExceptT XError (ReaderT Display m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT Display m a -> ExceptT XError (ReaderT Display m) a)
-> (m a -> ReaderT Display m a)
-> m a
-> ExceptT XError (ReaderT Display m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT Display m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance MonadTransControl RecolorXT where
  type StT RecolorXT a = StT (ReaderT Display) (StT (ExceptT XError) a)
  liftWith :: (Run RecolorXT -> m a) -> RecolorXT m a
liftWith = (forall b. ExceptT XError (ReaderT Display m) b -> RecolorXT m b)
-> (forall (o :: * -> *) b.
    RecolorXT o b -> ExceptT XError (ReaderT Display o) b)
-> (RunDefault2 RecolorXT (ExceptT XError) (ReaderT Display)
    -> m a)
-> RecolorXT m a
forall (m :: * -> *) (n' :: (* -> *) -> * -> *)
       (n :: (* -> *) -> * -> *) (t :: (* -> *) -> * -> *) a.
(Monad m, Monad (n' m), MonadTransControl n,
 MonadTransControl n') =>
(forall b. n (n' m) b -> t m b)
-> (forall (o :: * -> *) b. t o b -> n (n' o) b)
-> (RunDefault2 t n n' -> m a)
-> t m a
defaultLiftWith2 forall b. ExceptT XError (ReaderT Display m) b -> RecolorXT m b
forall (m :: * -> *) a.
ExceptT XError (ReaderT Display m) a -> RecolorXT m a
RecolorXT forall (o :: * -> *) b.
RecolorXT o b -> ExceptT XError (ReaderT Display o) b
unRecolorXT
  restoreT :: m (StT RecolorXT a) -> RecolorXT m a
restoreT = (ExceptT XError (ReaderT Display m) a -> RecolorXT m a)
-> m (StT (ReaderT Display) (StT (ExceptT XError) a))
-> RecolorXT m a
forall (m :: * -> *) (n' :: (* -> *) -> * -> *)
       (n :: (* -> *) -> * -> *) a (t :: (* -> *) -> * -> *).
(Monad m, Monad (n' m), MonadTransControl n,
 MonadTransControl n') =>
(n (n' m) a -> t m a) -> m (StT n' (StT n a)) -> t m a
defaultRestoreT2 ExceptT XError (ReaderT Display m) a -> RecolorXT m a
forall (m :: * -> *) a.
ExceptT XError (ReaderT Display m) a -> RecolorXT m a
RecolorXT

instance MonadBaseControl IO m => MonadRecolor (RecolorXT m) where
  recolor :: Trichromaticity -> RecolorXT m ()
recolor Trichromaticity
rgb = do
    Display
display <- ExceptT XError (ReaderT Display m) Display -> RecolorXT m Display
forall (m :: * -> *) a.
ExceptT XError (ReaderT Display m) a -> RecolorXT m a
RecolorXT ExceptT XError (ReaderT Display m) Display
forall r (m :: * -> *). MonadReader r m => m r
ask
    Window
root <- XError -> IO Window -> RecolorXT m Window
forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadError XError m) =>
XError -> IO a -> m a
liftXIO XError
XErrorRead (IO Window -> RecolorXT m Window)
-> IO Window -> RecolorXT m Window
forall a b. (a -> b) -> a -> b
$
      Display -> ScreenNumber -> IO Window
rootWindow Display
display (ScreenNumber -> IO Window) -> ScreenNumber -> IO Window
forall a b. (a -> b) -> a -> b
$ Display -> ScreenNumber
defaultScreen Display
display

    XError -> IO () -> RecolorXT m ()
forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadError XError m) =>
XError -> IO a -> m a
liftXIO XError
XErrorSetGamma (IO () -> RecolorXT m ()) -> IO () -> RecolorXT m ()
forall a b. (a -> b) -> a -> b
$ XRRGamma -> Display -> Window -> IO ()
xrrSetGamma (Trichromaticity -> XRRGamma
translateRGB Trichromaticity
rgb) Display
display Window
root

runRecolorXT :: Display -> RecolorXT m a -> m (Either XError a)
runRecolorXT :: Display -> RecolorXT m a -> m (Either XError a)
runRecolorXT Display
display RecolorXT m a
tma = ReaderT Display m (Either XError a)
-> Display -> m (Either XError a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ExceptT XError (ReaderT Display m) a
-> ReaderT Display m (Either XError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (RecolorXT m a -> ExceptT XError (ReaderT Display m) a
forall (o :: * -> *) b.
RecolorXT o b -> ExceptT XError (ReaderT Display o) b
unRecolorXT RecolorXT m a
tma)) Display
display

data ConfigX = ConfigX { ConfigX -> Maybe Text
hostName :: Maybe T.Text
                       , ConfigX -> Int
displayServer :: Int
                       , ConfigX -> Maybe Int
screen :: Maybe Int
                       }
  deriving (ConfigX -> ConfigX -> Bool
(ConfigX -> ConfigX -> Bool)
-> (ConfigX -> ConfigX -> Bool) -> Eq ConfigX
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConfigX -> ConfigX -> Bool
$c/= :: ConfigX -> ConfigX -> Bool
== :: ConfigX -> ConfigX -> Bool
$c== :: ConfigX -> ConfigX -> Bool
Eq, (forall x. ConfigX -> Rep ConfigX x)
-> (forall x. Rep ConfigX x -> ConfigX) -> Generic ConfigX
forall x. Rep ConfigX x -> ConfigX
forall x. ConfigX -> Rep ConfigX x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ConfigX x -> ConfigX
$cfrom :: forall x. ConfigX -> Rep ConfigX x
Generic, Eq ConfigX
Eq ConfigX
-> (ConfigX -> ConfigX -> Ordering)
-> (ConfigX -> ConfigX -> Bool)
-> (ConfigX -> ConfigX -> Bool)
-> (ConfigX -> ConfigX -> Bool)
-> (ConfigX -> ConfigX -> Bool)
-> (ConfigX -> ConfigX -> ConfigX)
-> (ConfigX -> ConfigX -> ConfigX)
-> Ord ConfigX
ConfigX -> ConfigX -> Bool
ConfigX -> ConfigX -> Ordering
ConfigX -> ConfigX -> ConfigX
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 :: ConfigX -> ConfigX -> ConfigX
$cmin :: ConfigX -> ConfigX -> ConfigX
max :: ConfigX -> ConfigX -> ConfigX
$cmax :: ConfigX -> ConfigX -> ConfigX
>= :: ConfigX -> ConfigX -> Bool
$c>= :: ConfigX -> ConfigX -> Bool
> :: ConfigX -> ConfigX -> Bool
$c> :: ConfigX -> ConfigX -> Bool
<= :: ConfigX -> ConfigX -> Bool
$c<= :: ConfigX -> ConfigX -> Bool
< :: ConfigX -> ConfigX -> Bool
$c< :: ConfigX -> ConfigX -> Bool
compare :: ConfigX -> ConfigX -> Ordering
$ccompare :: ConfigX -> ConfigX -> Ordering
$cp1Ord :: Eq ConfigX
Ord, ReadPrec [ConfigX]
ReadPrec ConfigX
Int -> ReadS ConfigX
ReadS [ConfigX]
(Int -> ReadS ConfigX)
-> ReadS [ConfigX]
-> ReadPrec ConfigX
-> ReadPrec [ConfigX]
-> Read ConfigX
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ConfigX]
$creadListPrec :: ReadPrec [ConfigX]
readPrec :: ReadPrec ConfigX
$creadPrec :: ReadPrec ConfigX
readList :: ReadS [ConfigX]
$creadList :: ReadS [ConfigX]
readsPrec :: Int -> ReadS ConfigX
$creadsPrec :: Int -> ReadS ConfigX
Read, Int -> ConfigX -> ShowS
[ConfigX] -> ShowS
ConfigX -> String
(Int -> ConfigX -> ShowS)
-> (ConfigX -> String) -> ([ConfigX] -> ShowS) -> Show ConfigX
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConfigX] -> ShowS
$cshowList :: [ConfigX] -> ShowS
show :: ConfigX -> String
$cshow :: ConfigX -> String
showsPrec :: Int -> ConfigX -> ShowS
$cshowsPrec :: Int -> ConfigX -> ShowS
Show)

instance NFData ConfigX

instance Default ConfigX where
  def :: ConfigX
def = ConfigX :: Maybe Text -> Int -> Maybe Int -> ConfigX
ConfigX { hostName :: Maybe Text
hostName = Maybe Text
forall a. Maybe a
Nothing
                , displayServer :: Int
displayServer = Int
0
                , screen :: Maybe Int
screen = Maybe Int
forall a. Maybe a
Nothing
                }

data XError = XErrorCloseDisplay
            | XErrorOpenDisplay
            | XErrorRead
            | XErrorSetGamma
  deriving (XError
XError -> XError -> Bounded XError
forall a. a -> a -> Bounded a
maxBound :: XError
$cmaxBound :: XError
minBound :: XError
$cminBound :: XError
Bounded, Int -> XError
XError -> Int
XError -> [XError]
XError -> XError
XError -> XError -> [XError]
XError -> XError -> XError -> [XError]
(XError -> XError)
-> (XError -> XError)
-> (Int -> XError)
-> (XError -> Int)
-> (XError -> [XError])
-> (XError -> XError -> [XError])
-> (XError -> XError -> [XError])
-> (XError -> XError -> XError -> [XError])
-> Enum XError
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: XError -> XError -> XError -> [XError]
$cenumFromThenTo :: XError -> XError -> XError -> [XError]
enumFromTo :: XError -> XError -> [XError]
$cenumFromTo :: XError -> XError -> [XError]
enumFromThen :: XError -> XError -> [XError]
$cenumFromThen :: XError -> XError -> [XError]
enumFrom :: XError -> [XError]
$cenumFrom :: XError -> [XError]
fromEnum :: XError -> Int
$cfromEnum :: XError -> Int
toEnum :: Int -> XError
$ctoEnum :: Int -> XError
pred :: XError -> XError
$cpred :: XError -> XError
succ :: XError -> XError
$csucc :: XError -> XError
Enum, XError -> XError -> Bool
(XError -> XError -> Bool)
-> (XError -> XError -> Bool) -> Eq XError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XError -> XError -> Bool
$c/= :: XError -> XError -> Bool
== :: XError -> XError -> Bool
$c== :: XError -> XError -> Bool
Eq, (forall x. XError -> Rep XError x)
-> (forall x. Rep XError x -> XError) -> Generic XError
forall x. Rep XError x -> XError
forall x. XError -> Rep XError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep XError x -> XError
$cfrom :: forall x. XError -> Rep XError x
Generic, Eq XError
Eq XError
-> (XError -> XError -> Ordering)
-> (XError -> XError -> Bool)
-> (XError -> XError -> Bool)
-> (XError -> XError -> Bool)
-> (XError -> XError -> Bool)
-> (XError -> XError -> XError)
-> (XError -> XError -> XError)
-> Ord XError
XError -> XError -> Bool
XError -> XError -> Ordering
XError -> XError -> XError
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 :: XError -> XError -> XError
$cmin :: XError -> XError -> XError
max :: XError -> XError -> XError
$cmax :: XError -> XError -> XError
>= :: XError -> XError -> Bool
$c>= :: XError -> XError -> Bool
> :: XError -> XError -> Bool
$c> :: XError -> XError -> Bool
<= :: XError -> XError -> Bool
$c<= :: XError -> XError -> Bool
< :: XError -> XError -> Bool
$c< :: XError -> XError -> Bool
compare :: XError -> XError -> Ordering
$ccompare :: XError -> XError -> Ordering
$cp1Ord :: Eq XError
Ord, ReadPrec [XError]
ReadPrec XError
Int -> ReadS XError
ReadS [XError]
(Int -> ReadS XError)
-> ReadS [XError]
-> ReadPrec XError
-> ReadPrec [XError]
-> Read XError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [XError]
$creadListPrec :: ReadPrec [XError]
readPrec :: ReadPrec XError
$creadPrec :: ReadPrec XError
readList :: ReadS [XError]
$creadList :: ReadS [XError]
readsPrec :: Int -> ReadS XError
$creadsPrec :: Int -> ReadS XError
Read, Int -> XError -> ShowS
[XError] -> ShowS
XError -> String
(Int -> XError -> ShowS)
-> (XError -> String) -> ([XError] -> ShowS) -> Show XError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XError] -> ShowS
$cshowList :: [XError] -> ShowS
show :: XError -> String
$cshow :: XError -> String
showsPrec :: Int -> XError -> ShowS
$cshowsPrec :: Int -> XError -> ShowS
Show)

instance NFData XError

liftXIO :: (MonadBaseControl IO m, MonadError XError m) => XError -> IO a -> m a
liftXIO :: XError -> IO a -> m a
liftXIO XError
xError = (m a -> (SomeException -> m a) -> m a)
-> (SomeException -> m a) -> m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
catch SomeException -> m a
throwXError (m a -> m a) -> (IO a -> m a) -> IO a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
  where throwXError :: SomeException -> m a
throwXError (SomeException e
_) = XError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError XError
xError

runRecolorXTIO :: MonadBaseControl IO m => ConfigX -> RecolorXT m a -> m (Either XError a)
runRecolorXTIO :: ConfigX -> RecolorXT m a -> m (Either XError a)
runRecolorXTIO ConfigX
conf RecolorXT m a
tma = ExceptT XError m a -> m (Either XError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XError m a -> m (Either XError a))
-> ExceptT XError m a -> m (Either XError a)
forall a b. (a -> b) -> a -> b
$ ExceptT XError m Display
-> (Display -> ExceptT XError m ())
-> (Display -> ExceptT XError m a)
-> ExceptT XError m a
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket ExceptT XError m Display
open Display -> ExceptT XError m ()
forall (m :: * -> *).
(MonadBaseControl IO m, MonadError XError m) =>
Display -> m ()
close Display -> ExceptT XError m a
run
  where open :: ExceptT XError m Display
open = XError -> IO Display -> ExceptT XError m Display
forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadError XError m) =>
XError -> IO a -> m a
liftXIO XError
XErrorOpenDisplay (IO Display -> ExceptT XError m Display)
-> IO Display -> ExceptT XError m Display
forall a b. (a -> b) -> a -> b
$ String -> IO Display
openDisplay (String -> IO Display) -> String -> IO Display
forall a b. (a -> b) -> a -> b
$ ConfigX -> String
showDisplay ConfigX
conf
        close :: Display -> m ()
close Display
display = XError -> IO () -> m ()
forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadError XError m) =>
XError -> IO a -> m a
liftXIO XError
XErrorCloseDisplay (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Display -> IO ()
closeDisplay Display
display
        run :: Display -> ExceptT XError m a
run Display
display = m (StT (ExceptT XError) a) -> ExceptT XError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT (m (StT (ExceptT XError) a) -> ExceptT XError m a)
-> m (StT (ExceptT XError) a) -> ExceptT XError m a
forall a b. (a -> b) -> a -> b
$ Display -> RecolorXT m a -> m (Either XError a)
forall (m :: * -> *) a.
Display -> RecolorXT m a -> m (Either XError a)
runRecolorXT Display
display RecolorXT m a
tma

showDisplay :: ConfigX -> String
showDisplay :: ConfigX -> String
showDisplay ConfigX {Int
Maybe Int
Maybe Text
screen :: Maybe Int
displayServer :: Int
hostName :: Maybe Text
screen :: ConfigX -> Maybe Int
displayServer :: ConfigX -> Int
hostName :: ConfigX -> Maybe Text
..} = Text -> String
T.unpack (Text -> String) -> ([Text] -> Text) -> [Text] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat ([Text] -> String) -> [Text] -> String
forall a b. (a -> b) -> a -> b
$
  [ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
hostName
  , Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
displayServer)
  , Text -> (Int -> Text) -> Maybe Int -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Int -> Text) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) Maybe Int
screen
  ]

translateRGB :: Trichromaticity -> XRRGamma
translateRGB :: Trichromaticity -> XRRGamma
translateRGB Trichromaticity {Chromaticity
blue :: Trichromaticity -> Chromaticity
green :: Trichromaticity -> Chromaticity
red :: Trichromaticity -> Chromaticity
blue :: Chromaticity
green :: Chromaticity
red :: Chromaticity
..} = XRRGamma :: Float -> Float -> Float -> XRRGamma
XRRGamma {Float
xrr_gamma_blue :: Float
xrr_gamma_green :: Float
xrr_gamma_red :: Float
xrr_gamma_blue :: Float
xrr_gamma_green :: Float
xrr_gamma_red :: Float
..}
  where xrr_gamma_red :: Float
xrr_gamma_red = Chromaticity -> Float
forall a. (Fractional a, Num a) => Chromaticity -> a
translateColor Chromaticity
red
        xrr_gamma_green :: Float
xrr_gamma_green = Chromaticity -> Float
forall a. (Fractional a, Num a) => Chromaticity -> a
translateColor Chromaticity
green
        xrr_gamma_blue :: Float
xrr_gamma_blue = Chromaticity -> Float
forall a. (Fractional a, Num a) => Chromaticity -> a
translateColor Chromaticity
blue

-- | Create a normalized value for a 'Chromaticity'.
translateColor :: (Fractional a, Num a) => Chromaticity -> a
translateColor :: Chromaticity -> a
translateColor = (a -> a -> a
forall a. Fractional a => a -> a -> a
/ Chromaticity -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bounded Chromaticity => Chromaticity
forall a. Bounded a => a
maxBound @Chromaticity)) (a -> a) -> (Chromaticity -> a) -> Chromaticity -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chromaticity -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral