{-# LANGUAGE RecordWildCards #-}

module MSU.Xrandr.Parse
    ( Display(..)
    , parseXrandr
    , parseXrandrUnsafe
    )
where

import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO)
import Text.Parsec
import Text.Parsec.String
import UnliftIO.Exception (throwString)

data Display = Display
    { Display -> String
name :: String
    , Display -> Bool
connected :: Bool
    , Display -> [(Int, Int)]
modes :: [(Int, Int)]
    }
    deriving (Display -> Display -> Bool
(Display -> Display -> Bool)
-> (Display -> Display -> Bool) -> Eq Display
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Display -> Display -> Bool
$c/= :: Display -> Display -> Bool
== :: Display -> Display -> Bool
$c== :: Display -> Display -> Bool
Eq, Int -> Display -> ShowS
[Display] -> ShowS
Display -> String
(Int -> Display -> ShowS)
-> (Display -> String) -> ([Display] -> ShowS) -> Show Display
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Display] -> ShowS
$cshowList :: [Display] -> ShowS
show :: Display -> String
$cshow :: Display -> String
showsPrec :: Int -> Display -> ShowS
$cshowsPrec :: Int -> Display -> ShowS
Show)

parseXrandr :: String -> Either ParseError [Display]
parseXrandr :: String -> Either ParseError [Display]
parseXrandr = Parsec String () [Display]
-> String -> String -> Either ParseError [Display]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () [Display]
parseDisplays String
"xrandr --query"

parseXrandrUnsafe :: MonadIO m => String -> m [Display]
parseXrandrUnsafe :: String -> m [Display]
parseXrandrUnsafe = (ParseError -> m [Display])
-> ([Display] -> m [Display])
-> Either ParseError [Display]
-> m [Display]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m [Display]
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> m [Display])
-> (ParseError -> String) -> ParseError -> m [Display]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show) [Display] -> m [Display]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ParseError [Display] -> m [Display])
-> (String -> Either ParseError [Display]) -> String -> m [Display]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either ParseError [Display]
parseXrandr

parseDisplays :: Parser [Display]
parseDisplays :: Parsec String () [Display]
parseDisplays = String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"Screen" ParsecT String () Identity String
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity ()
ignoreLine ParsecT String () Identity ()
-> Parsec String () [Display] -> Parsec String () [Display]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity Display
-> ParsecT String () Identity () -> Parsec String () [Display]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Display
parseDisplay ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof

parseDisplay :: Parser Display
parseDisplay :: ParsecT String () Identity Display
parseDisplay = do
    String
name <- ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m t
anyToken ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
    Bool
connected <- Parser Bool
parseConnected Parser Bool -> ParsecT String () Identity () -> Parser Bool
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
ignoreLine
    [(Int, Int)]
modes <- if Bool
connected then Parser [(Int, Int)]
parseModeLines else Parser [(Int, Int)]
skipModeLines
    Display -> ParsecT String () Identity Display
forall (f :: * -> *) a. Applicative f => a -> f a
pure Display :: String -> Bool -> [(Int, Int)] -> Display
Display { Bool
String
[(Int, Int)]
modes :: [(Int, Int)]
connected :: Bool
name :: String
modes :: [(Int, Int)]
connected :: Bool
name :: String
.. }

parseConnected :: Parser Bool
parseConnected :: Parser Bool
parseConnected = Bool
True Bool -> ParsecT String () Identity String -> Parser Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"connected" Parser Bool -> Parser Bool -> Parser Bool
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Bool
False Bool -> ParsecT String () Identity String -> Parser Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"disconnected"

parseModeLines :: Parser [(Int, Int)]
parseModeLines :: Parser [(Int, Int)]
parseModeLines = ParsecT String () Identity (Int, Int)
-> ParsecT String () Identity () -> Parser [(Int, Int)]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity (Int, Int)
parseModeLine ParsecT String () Identity ()
nextDisplay

skipModeLines :: Parser [(Int, Int)]
skipModeLines :: Parser [(Int, Int)]
skipModeLines = [] [(Int, Int)]
-> ParsecT String () Identity () -> Parser [(Int, Int)]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT String () Identity () -> ParsecT String () Identity ()
ignoreLinesTill ParsecT String () Identity ()
nextDisplay

parseModeLine :: Parser (Int, Int)
parseModeLine :: ParsecT String () Identity (Int, Int)
parseModeLine =
    (,)
        (Int -> Int -> (Int, Int))
-> ParsecT String () Identity Int
-> ParsecT String () Identity (Int -> (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Int
forall a. Read a => String -> a
read (String -> Int)
-> ParsecT String () Identity String
-> ParsecT String () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT String () Identity ()
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit))
        ParsecT String () Identity (Int -> (Int, Int))
-> ParsecT String () Identity Int
-> ParsecT String () Identity (Int, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> Int
forall a. Read a => String -> a
read (String -> Int)
-> ParsecT String () Identity String
-> ParsecT String () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'x' ParsecT String () Identity Char
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit ParsecT String () Identity String
-> ParsecT String () Identity ()
-> ParsecT String () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
ignoreLine))

nextDisplay :: Parser ()
nextDisplay :: ParsecT String () Identity ()
nextDisplay = ParsecT String () Identity () -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (ParsecT String () Identity () -> ParsecT String () Identity ())
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity Display -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity Display
 -> ParsecT String () Identity ())
-> ParsecT String () Identity Display
-> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity Display
-> ParsecT String () Identity Display
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT String () Identity Display
parseDisplay

ignoreLinesTill :: Parser () -> Parser ()
ignoreLinesTill :: ParsecT String () Identity () -> ParsecT String () Identity ()
ignoreLinesTill ParsecT String () Identity ()
p = ParsecT String () Identity [()] -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity [()] -> ParsecT String () Identity ())
-> ParsecT String () Identity [()] -> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity ()
-> ParsecT String () Identity () -> ParsecT String () Identity [()]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity ()
ignoreLine (ParsecT String () Identity () -> ParsecT String () Identity [()])
-> ParsecT String () Identity () -> ParsecT String () Identity [()]
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity ()
p ParsecT String () Identity ()
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof

ignoreLine :: Parser ()
ignoreLine :: ParsecT String () Identity ()
ignoreLine = ParsecT String () Identity String -> ParsecT String () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity String
 -> ParsecT String () Identity ())
-> ParsecT String () Identity String
-> ParsecT String () Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m t
anyToken ParsecT String () Identity Char
eol
  where
    eol :: Parser Char
    eol :: ParsecT String () Identity Char
eol = Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\n'