{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module MSU.Monitors
    ( Monitors(..)
    , readMonitorsFileThrow
    , readMonitorsYaml
    , findMonitors

    -- * Create
    , createMonitor
    , writeMonitorsFile
    )
where

import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.List (find)
import qualified Data.Yaml as Yaml
import GHC.Generics (Generic)
import MSU.Context (Context)
import qualified MSU.Context as Context
import MSU.Match
import qualified MSU.Xrandr.Parse as Xrandr
import System.Directory (doesFileExist)

data Monitors = Monitors
    { Monitors -> String
name :: String
    , Monitors -> MatchContext
match :: MatchContext
    , Monitors -> String
exec :: String
    }
    deriving stock (forall x. Monitors -> Rep Monitors x)
-> (forall x. Rep Monitors x -> Monitors) -> Generic Monitors
forall x. Rep Monitors x -> Monitors
forall x. Monitors -> Rep Monitors x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Monitors x -> Monitors
$cfrom :: forall x. Monitors -> Rep Monitors x
Generic
    deriving anyclass (Value -> Parser [Monitors]
Value -> Parser Monitors
(Value -> Parser Monitors)
-> (Value -> Parser [Monitors]) -> FromJSON Monitors
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Monitors]
$cparseJSONList :: Value -> Parser [Monitors]
parseJSON :: Value -> Parser Monitors
$cparseJSON :: Value -> Parser Monitors
FromJSON, [Monitors] -> Encoding
[Monitors] -> Value
Monitors -> Encoding
Monitors -> Value
(Monitors -> Value)
-> (Monitors -> Encoding)
-> ([Monitors] -> Value)
-> ([Monitors] -> Encoding)
-> ToJSON Monitors
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Monitors] -> Encoding
$ctoEncodingList :: [Monitors] -> Encoding
toJSONList :: [Monitors] -> Value
$ctoJSONList :: [Monitors] -> Value
toEncoding :: Monitors -> Encoding
$ctoEncoding :: Monitors -> Encoding
toJSON :: Monitors -> Value
$ctoJSON :: Monitors -> Value
ToJSON)

data MatchContext = MatchContext
    { MatchContext -> Maybe (Match [String])
displays :: Maybe (Match [String])
    , MatchContext -> Maybe (Match String)
wifi :: Maybe (Match String)
    }
    deriving stock (forall x. MatchContext -> Rep MatchContext x)
-> (forall x. Rep MatchContext x -> MatchContext)
-> Generic MatchContext
forall x. Rep MatchContext x -> MatchContext
forall x. MatchContext -> Rep MatchContext x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MatchContext x -> MatchContext
$cfrom :: forall x. MatchContext -> Rep MatchContext x
Generic
    deriving anyclass (Value -> Parser [MatchContext]
Value -> Parser MatchContext
(Value -> Parser MatchContext)
-> (Value -> Parser [MatchContext]) -> FromJSON MatchContext
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MatchContext]
$cparseJSONList :: Value -> Parser [MatchContext]
parseJSON :: Value -> Parser MatchContext
$cparseJSON :: Value -> Parser MatchContext
FromJSON, [MatchContext] -> Encoding
[MatchContext] -> Value
MatchContext -> Encoding
MatchContext -> Value
(MatchContext -> Value)
-> (MatchContext -> Encoding)
-> ([MatchContext] -> Value)
-> ([MatchContext] -> Encoding)
-> ToJSON MatchContext
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MatchContext] -> Encoding
$ctoEncodingList :: [MatchContext] -> Encoding
toJSONList :: [MatchContext] -> Value
$ctoJSONList :: [MatchContext] -> Value
toEncoding :: MatchContext -> Encoding
$ctoEncoding :: MatchContext -> Encoding
toJSON :: MatchContext -> Value
$ctoJSON :: MatchContext -> Value
ToJSON)

readMonitorsFileThrow :: MonadIO m => FilePath -> m [Monitors]
readMonitorsFileThrow :: String -> m [Monitors]
readMonitorsFileThrow = String -> m [Monitors]
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Yaml.decodeFileThrow

readMonitorsYaml :: ByteString -> Either String [Monitors]
readMonitorsYaml :: ByteString -> Either String [Monitors]
readMonitorsYaml = (ParseException -> String)
-> Either ParseException [Monitors] -> Either String [Monitors]
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseException -> String
forall a. Show a => a -> String
show (Either ParseException [Monitors] -> Either String [Monitors])
-> (ByteString -> Either ParseException [Monitors])
-> ByteString
-> Either String [Monitors]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ParseException [Monitors]
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither'

findMonitors :: Context -> [Monitors] -> Maybe Monitors
findMonitors :: Context -> [Monitors] -> Maybe Monitors
findMonitors Context
context = (Monitors -> Bool) -> [Monitors] -> Maybe Monitors
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Monitors -> Bool) -> [Monitors] -> Maybe Monitors)
-> (Monitors -> Bool) -> [Monitors] -> Maybe Monitors
forall a b. (a -> b) -> a -> b
$ \Monitors {String
MatchContext
exec :: String
match :: MatchContext
name :: String
exec :: Monitors -> String
match :: Monitors -> MatchContext
name :: Monitors -> String
..} ->
    let
        connected :: [Display]
connected = (Display -> Bool) -> [Display] -> [Display]
forall a. (a -> Bool) -> [a] -> [a]
filter Display -> Bool
Xrandr.connected ([Display] -> [Display]) -> [Display] -> [Display]
forall a b. (a -> b) -> a -> b
$ Context -> [Display]
Context.displays Context
context
        names :: [String]
names = (Display -> String) -> [Display] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Display -> String
Xrandr.name [Display]
connected
        mEssid :: Maybe String
mEssid = Wifi -> String
Context.essid (Wifi -> String) -> Maybe Wifi -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Maybe Wifi
Context.wifi Context
context
    in MatchContext -> Maybe (Match [String])
displays MatchContext
match Maybe (Match [String]) -> [String] -> Bool
forall a. Eq a => Maybe (Match a) -> a -> Bool
`matches` [String]
names Bool -> Bool -> Bool
&& MatchContext -> Maybe (Match String)
wifi MatchContext
match Maybe (Match String) -> Maybe String -> Bool
forall a. Eq a => Maybe (Match a) -> Maybe a -> Bool
`matchesMaybe` Maybe String
mEssid

createMonitor :: Context -> Monitors
createMonitor :: Context -> Monitors
createMonitor Context
context = Monitors :: String -> MatchContext -> String -> Monitors
Monitors
    { name :: String
name = String
"created"
    , match :: MatchContext
match = MatchContext :: Maybe (Match [String]) -> Maybe (Match String) -> MatchContext
MatchContext
        { displays :: Maybe (Match [String])
displays = Match [String] -> Maybe (Match [String])
forall a. a -> Maybe a
Just (Match [String] -> Maybe (Match [String]))
-> Match [String] -> Maybe (Match [String])
forall a b. (a -> b) -> a -> b
$ [String] -> Match [String]
forall a. a -> Match a
Eq [String]
connectedNames
        , wifi :: Maybe (Match String)
wifi = String -> Match String
forall a. a -> Match a
Eq (String -> Match String)
-> (Wifi -> String) -> Wifi -> Match String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wifi -> String
Context.essid (Wifi -> Match String) -> Maybe Wifi -> Maybe (Match String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Maybe Wifi
Context.wifi Context
context
        }
    , exec :: String
exec = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String
"xrandr" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Display -> [String]) -> [Display] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Display -> [String]
xrandrArg ([Display] -> [String]) -> [Display] -> [String]
forall a b. (a -> b) -> a -> b
$ Context -> [Display]
Context.displays
        Context
context
    }
  where
    connectedNames :: [String]
connectedNames =
        (Display -> String) -> [Display] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Display -> String
Xrandr.name ([Display] -> [String]) -> [Display] -> [String]
forall a b. (a -> b) -> a -> b
$ (Display -> Bool) -> [Display] -> [Display]
forall a. (a -> Bool) -> [a] -> [a]
filter Display -> Bool
Xrandr.connected ([Display] -> [Display]) -> [Display] -> [Display]
forall a b. (a -> b) -> a -> b
$ Context -> [Display]
Context.displays Context
context

    xrandrArg :: Display -> [String]
xrandrArg Display
display =
        [String
"--output", Display -> String
Xrandr.name Display
display]
            [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> if Display -> Bool
Xrandr.connected Display
display then Display -> [String]
xrandrMode Display
display else []

    xrandrMode :: Display -> [String]
xrandrMode Display
display = case Display -> [(Int, Int)]
Xrandr.modes Display
display of
        ((Int
x, Int
y) : [(Int, Int)]
_) -> [String
"--mode", Int -> String
forall a. Show a => a -> String
show Int
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"x" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
y]
        [(Int, Int)]
_ -> []

writeMonitorsFile :: MonadIO m => FilePath -> Monitors -> m ()
writeMonitorsFile :: String -> Monitors -> m ()
writeMonitorsFile String
path Monitors
monitors = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
exists <- String -> IO Bool
doesFileExist String
path
    if Bool
exists
        then String -> ByteString -> IO ()
BS.appendFile String
path (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
prefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
encoded
        else String -> ByteString -> IO ()
BS.writeFile String
path ByteString
encoded
  where
    prefix :: ByteString
prefix = ByteString
"\n# TODO: created automatically\n"
    encoded :: ByteString
encoded = [Monitors] -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode [Monitors
monitors]