{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}

module System.Taffybar.Test.XvfbSpec
  ( spec
  -- * Virtual X11 server for unit testing
  , withXvfb
  , withXdummy
  , displayArg
  , displayEnv
  , setDefaultDisplay_
  , setDefaultDisplay
  -- ** Randr
  , withRandrSetup
  , randrSetup
  , randrTeardown
  -- *** RANDR config
  , RRSetup(..)
  , RROutput(..)
  , RROutputSettings(..)
  , RRExistingMode(..)
  , RRMode(..)
  , RRModeName(..)
  , RRModeLine(..)
  , RRPosition(..)
  , RRRotation(..)
  , ListIndex(..)
  -- ** Clients
  , withXTerm
  -- * Wrappers around @xprop@ command
  , XPropName(..)
  , xpropName
  , XPropValue(..)
  , xpropValue
  , xpropGet
  , xpropSet
  , xpropRemove
  , xpropList
  ) where

import Control.Applicative ((<|>))
import Control.Monad ((<=<), void, forM_, guard)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Attoparsec.Text.Lazy hiding (takeWhile, take)
import qualified Data.Attoparsec.Text.Lazy as P
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Bifunctor (bimap, second)
import Data.Char (isPrint, isSpace)
import Data.Coerce (coerce)
import Data.Default (Default(..))
import Data.List (findIndex, uncons, dropWhileEnd)
import Data.String (IsString(..))
import Data.Text.Lazy.Encoding (decodeUtf8')
import qualified Data.Text.Lazy as TL
import qualified Data.Text as T
import Data.Function ((&))
import Data.Maybe (maybeToList, mapMaybe, isJust, isNothing)
import GHC.Generics (Generic)
import System.Process.Typed
import System.IO (Handle, hClose, hGetLine)
import Text.Read (readMaybe)
import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Exception (fromEitherM, throwString, bracket_)

import Test.Hspec
import Test.QuickCheck
import Test.QuickCheck.Monadic

import System.Taffybar.Test.UtilSpec (withSetEnv, logSetup, specLog, specLogAt, getSpecLogPriority, Priority(..), setStderrCond, setServiceDefaults, withService)
import System.Taffybar.Information.X11DesktopInfo (DisplayName(..))

------------------------------------------------------------------------

-- | Construct a 'DisplayName' for the given local display number.
displayNumber :: Int -> DisplayName
displayNumber :: Int -> DisplayName
displayNumber Int
n = [Char] -> DisplayName
DisplayName (Int -> [Char]
displaySpec Int
n)

displaySpec :: Int -> String
displaySpec :: Int -> [Char]
displaySpec Int
n = [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n

-- | Produce a @-display@ command-line option, supported by many X11
-- programs.
displayArg :: DisplayName -> [String]
displayArg :: DisplayName -> [[Char]]
displayArg DisplayName
DefaultDisplay = []
displayArg (DisplayName [Char]
d) = [[Char]
"-display", [Char]
d]

displayEnv :: DisplayName -> [(String, String)]
displayEnv :: DisplayName -> [([Char], [Char])]
displayEnv DisplayName
DefaultDisplay = []
displayEnv (DisplayName [Char]
d) = [([Char]
"DISPLAY", [Char]
d)]

------------------------------------------------------------------------

newtype XPropName = XPropName { XPropName -> [Char]
unXPropName :: String }
  deriving (Int -> XPropName -> [Char] -> [Char]
[XPropName] -> [Char] -> [Char]
XPropName -> [Char]
(Int -> XPropName -> [Char] -> [Char])
-> (XPropName -> [Char])
-> ([XPropName] -> [Char] -> [Char])
-> Show XPropName
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> XPropName -> [Char] -> [Char]
showsPrec :: Int -> XPropName -> [Char] -> [Char]
$cshow :: XPropName -> [Char]
show :: XPropName -> [Char]
$cshowList :: [XPropName] -> [Char] -> [Char]
showList :: [XPropName] -> [Char] -> [Char]
Show, ReadPrec [XPropName]
ReadPrec XPropName
Int -> ReadS XPropName
ReadS [XPropName]
(Int -> ReadS XPropName)
-> ReadS [XPropName]
-> ReadPrec XPropName
-> ReadPrec [XPropName]
-> Read XPropName
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS XPropName
readsPrec :: Int -> ReadS XPropName
$creadList :: ReadS [XPropName]
readList :: ReadS [XPropName]
$creadPrec :: ReadPrec XPropName
readPrec :: ReadPrec XPropName
$creadListPrec :: ReadPrec [XPropName]
readListPrec :: ReadPrec [XPropName]
Read, XPropName -> XPropName -> Bool
(XPropName -> XPropName -> Bool)
-> (XPropName -> XPropName -> Bool) -> Eq XPropName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: XPropName -> XPropName -> Bool
== :: XPropName -> XPropName -> Bool
$c/= :: XPropName -> XPropName -> Bool
/= :: XPropName -> XPropName -> Bool
Eq, Eq XPropName
Eq XPropName =>
(XPropName -> XPropName -> Ordering)
-> (XPropName -> XPropName -> Bool)
-> (XPropName -> XPropName -> Bool)
-> (XPropName -> XPropName -> Bool)
-> (XPropName -> XPropName -> Bool)
-> (XPropName -> XPropName -> XPropName)
-> (XPropName -> XPropName -> XPropName)
-> Ord XPropName
XPropName -> XPropName -> Bool
XPropName -> XPropName -> Ordering
XPropName -> XPropName -> XPropName
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
$ccompare :: XPropName -> XPropName -> Ordering
compare :: XPropName -> XPropName -> Ordering
$c< :: XPropName -> XPropName -> Bool
< :: XPropName -> XPropName -> Bool
$c<= :: XPropName -> XPropName -> Bool
<= :: XPropName -> XPropName -> Bool
$c> :: XPropName -> XPropName -> Bool
> :: XPropName -> XPropName -> Bool
$c>= :: XPropName -> XPropName -> Bool
>= :: XPropName -> XPropName -> Bool
$cmax :: XPropName -> XPropName -> XPropName
max :: XPropName -> XPropName -> XPropName
$cmin :: XPropName -> XPropName -> XPropName
min :: XPropName -> XPropName -> XPropName
Ord, (forall x. XPropName -> Rep XPropName x)
-> (forall x. Rep XPropName x -> XPropName) -> Generic XPropName
forall x. Rep XPropName x -> XPropName
forall x. XPropName -> Rep XPropName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. XPropName -> Rep XPropName x
from :: forall x. XPropName -> Rep XPropName x
$cto :: forall x. Rep XPropName x -> XPropName
to :: forall x. Rep XPropName x -> XPropName
Generic)

-- | Construct a valid 'XPropName' from a 'String'. Any names which
-- cause problems when parsing @xprop@ output are not allowed.
xpropName :: String -> Maybe XPropName
xpropName :: [Char] -> Maybe XPropName
xpropName n :: [Char]
n@(Char
c:[Char]
cs)
  | Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
propNameStartChars Bool -> Bool -> Bool
&&
    (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isPrint [Char]
cs Bool -> Bool -> Bool
&&
    Bool -> Bool
not ((Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
propNameBadChars [Char]
cs) = XPropName -> Maybe XPropName
forall a. a -> Maybe a
Just ([Char] -> XPropName
XPropName [Char]
n)
xpropName [Char]
_ = Maybe XPropName
forall a. Maybe a
Nothing

-- | List of characters which are valid first characters of a property
-- name.
propNameStartChars :: [Char]
propNameStartChars :: [Char]
propNameStartChars = [Char
'a'..Char
'z'] [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char
'A'..Char
'Z'] [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char
'_']

propNameBadChars :: Char -> Bool
propNameBadChars :: Char -> Bool
propNameBadChars Char
c = Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'(', Char
')', Char
':']

newtype XPropValue = XPropValue { XPropValue -> [Char]
unXPropValue :: String }
  deriving (Int -> XPropValue -> [Char] -> [Char]
[XPropValue] -> [Char] -> [Char]
XPropValue -> [Char]
(Int -> XPropValue -> [Char] -> [Char])
-> (XPropValue -> [Char])
-> ([XPropValue] -> [Char] -> [Char])
-> Show XPropValue
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> XPropValue -> [Char] -> [Char]
showsPrec :: Int -> XPropValue -> [Char] -> [Char]
$cshow :: XPropValue -> [Char]
show :: XPropValue -> [Char]
$cshowList :: [XPropValue] -> [Char] -> [Char]
showList :: [XPropValue] -> [Char] -> [Char]
Show, ReadPrec [XPropValue]
ReadPrec XPropValue
Int -> ReadS XPropValue
ReadS [XPropValue]
(Int -> ReadS XPropValue)
-> ReadS [XPropValue]
-> ReadPrec XPropValue
-> ReadPrec [XPropValue]
-> Read XPropValue
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS XPropValue
readsPrec :: Int -> ReadS XPropValue
$creadList :: ReadS [XPropValue]
readList :: ReadS [XPropValue]
$creadPrec :: ReadPrec XPropValue
readPrec :: ReadPrec XPropValue
$creadListPrec :: ReadPrec [XPropValue]
readListPrec :: ReadPrec [XPropValue]
Read, XPropValue -> XPropValue -> Bool
(XPropValue -> XPropValue -> Bool)
-> (XPropValue -> XPropValue -> Bool) -> Eq XPropValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: XPropValue -> XPropValue -> Bool
== :: XPropValue -> XPropValue -> Bool
$c/= :: XPropValue -> XPropValue -> Bool
/= :: XPropValue -> XPropValue -> Bool
Eq, Eq XPropValue
Eq XPropValue =>
(XPropValue -> XPropValue -> Ordering)
-> (XPropValue -> XPropValue -> Bool)
-> (XPropValue -> XPropValue -> Bool)
-> (XPropValue -> XPropValue -> Bool)
-> (XPropValue -> XPropValue -> Bool)
-> (XPropValue -> XPropValue -> XPropValue)
-> (XPropValue -> XPropValue -> XPropValue)
-> Ord XPropValue
XPropValue -> XPropValue -> Bool
XPropValue -> XPropValue -> Ordering
XPropValue -> XPropValue -> XPropValue
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
$ccompare :: XPropValue -> XPropValue -> Ordering
compare :: XPropValue -> XPropValue -> Ordering
$c< :: XPropValue -> XPropValue -> Bool
< :: XPropValue -> XPropValue -> Bool
$c<= :: XPropValue -> XPropValue -> Bool
<= :: XPropValue -> XPropValue -> Bool
$c> :: XPropValue -> XPropValue -> Bool
> :: XPropValue -> XPropValue -> Bool
$c>= :: XPropValue -> XPropValue -> Bool
>= :: XPropValue -> XPropValue -> Bool
$cmax :: XPropValue -> XPropValue -> XPropValue
max :: XPropValue -> XPropValue -> XPropValue
$cmin :: XPropValue -> XPropValue -> XPropValue
min :: XPropValue -> XPropValue -> XPropValue
Ord, NonEmpty XPropValue -> XPropValue
XPropValue -> XPropValue -> XPropValue
(XPropValue -> XPropValue -> XPropValue)
-> (NonEmpty XPropValue -> XPropValue)
-> (forall b. Integral b => b -> XPropValue -> XPropValue)
-> Semigroup XPropValue
forall b. Integral b => b -> XPropValue -> XPropValue
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: XPropValue -> XPropValue -> XPropValue
<> :: XPropValue -> XPropValue -> XPropValue
$csconcat :: NonEmpty XPropValue -> XPropValue
sconcat :: NonEmpty XPropValue -> XPropValue
$cstimes :: forall b. Integral b => b -> XPropValue -> XPropValue
stimes :: forall b. Integral b => b -> XPropValue -> XPropValue
Semigroup, Semigroup XPropValue
XPropValue
Semigroup XPropValue =>
XPropValue
-> (XPropValue -> XPropValue -> XPropValue)
-> ([XPropValue] -> XPropValue)
-> Monoid XPropValue
[XPropValue] -> XPropValue
XPropValue -> XPropValue -> XPropValue
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: XPropValue
mempty :: XPropValue
$cmappend :: XPropValue -> XPropValue -> XPropValue
mappend :: XPropValue -> XPropValue -> XPropValue
$cmconcat :: [XPropValue] -> XPropValue
mconcat :: [XPropValue] -> XPropValue
Monoid, (forall x. XPropValue -> Rep XPropValue x)
-> (forall x. Rep XPropValue x -> XPropValue) -> Generic XPropValue
forall x. Rep XPropValue x -> XPropValue
forall x. XPropValue -> Rep XPropValue x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. XPropValue -> Rep XPropValue x
from :: forall x. XPropValue -> Rep XPropValue x
$cto :: forall x. Rep XPropValue x -> XPropValue
to :: forall x. Rep XPropValue x -> XPropValue
Generic)

-- | Construct a valid 'XPropValue' from a 'String'. Any values which
-- cause problems when parsing @xprop@ output are not allowed.
xpropValue :: String -> Maybe XPropValue
xpropValue :: [Char] -> Maybe XPropValue
xpropValue [Char]
n = if Bool -> Bool
not ((Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
propValueBadChars [Char]
n) then XPropValue -> Maybe XPropValue
forall a. a -> Maybe a
Just ([Char] -> XPropValue
XPropValue [Char]
n) else Maybe XPropValue
forall a. Maybe a
Nothing

-- | Predicate on characters which cause difficulties when parsing
-- @xprop@ output.
propValueBadChars :: Char -> Bool
propValueBadChars :: Char -> Bool
propValueBadChars Char
c = Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'"',Char
'\n',Char
'\r'] Bool -> Bool -> Bool
|| Bool -> Bool
not (Char -> Bool
isPrint Char
c)

------------------------------------------------------------------------

xpropProc :: DisplayName -> [String] -> ProcessConfig () () ()
xpropProc :: DisplayName -> [[Char]] -> ProcessConfig () () ()
xpropProc DisplayName
d [[Char]]
args = [Char] -> [[Char]] -> ProcessConfig () () ()
proc [Char]
"xprop" (DisplayName -> [[Char]]
displayArg DisplayName
d [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
args)

xpropGet :: (HasCallStack, MonadIO m) => DisplayName -> XPropName -> m [XPropValue]
xpropGet :: forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
DisplayName -> XPropName -> m [XPropValue]
xpropGet DisplayName
d XPropName
p = do
  [Char] -> m ()
forall (m :: * -> *). MonadIO m => [Char] -> m ()
specLog ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"xpropGet running: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ProcessConfig () () () -> [Char]
forall a. Show a => a -> [Char]
show ProcessConfig () () ()
cfg
  txt <- m ByteString -> m Text
forall (m :: * -> *). MonadIO m => m ByteString -> m Text
decoded (m ByteString -> m Text) -> m ByteString -> m Text
forall a b. (a -> b) -> a -> b
$ ProcessConfig () () () -> m ByteString
forall (m :: * -> *) stdin stdoutIgnored stderr.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderr -> m ByteString
readProcessStdout_ ProcessConfig () () ()
cfg
  specLogAt DEBUG $ "xprop output:\n" ++ TL.unpack txt
  either throwString pure $ parseXProp1 p txt
  where
    cfg :: ProcessConfig () () ()
cfg = DisplayName -> [[Char]] -> ProcessConfig () () ()
xpropProc DisplayName
d [[Char]
"-root", XPropName -> [Char]
unXPropName XPropName
p]
    decoded :: MonadIO m => m BL.ByteString -> m TL.Text
    decoded :: forall (m :: * -> *). MonadIO m => m ByteString -> m Text
decoded = m (Either UnicodeException Text) -> m Text
forall e (m :: * -> *) a.
(Exception e, MonadIO m) =>
m (Either e a) -> m a
fromEitherM (m (Either UnicodeException Text) -> m Text)
-> (m ByteString -> m (Either UnicodeException Text))
-> m ByteString
-> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Either UnicodeException Text)
-> m ByteString -> m (Either UnicodeException Text)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Either UnicodeException Text
decodeUtf8'

parseXProp1 :: XPropName -> TL.Text -> Either String [XPropValue]
parseXProp1 :: XPropName -> Text -> Either [Char] [XPropValue]
parseXProp1 XPropName
p = Either [Char] [XPropValue]
-> ([XPropValue] -> Either [Char] [XPropValue])
-> Maybe [XPropValue]
-> Either [Char] [XPropValue]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Either [Char] [XPropValue]
forall a b. a -> Either a b
Left ([Char]
"property " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ XPropName -> [Char]
forall a. Show a => a -> [Char]
show XPropName
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" not found")) [XPropValue] -> Either [Char] [XPropValue]
forall a b. b -> Either a b
Right (Maybe [XPropValue] -> Either [Char] [XPropValue])
-> ([(XPropName, [XPropValue])] -> Maybe [XPropValue])
-> [(XPropName, [XPropValue])]
-> Either [Char] [XPropValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPropName -> [(XPropName, [XPropValue])] -> Maybe [XPropValue]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup XPropName
p ([(XPropName, [XPropValue])] -> Either [Char] [XPropValue])
-> (Text -> Either [Char] [(XPropName, [XPropValue])])
-> Text
-> Either [Char] [XPropValue]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> Either [Char] [(XPropName, [XPropValue])]
parseXProp

parseXProp :: TL.Text -> Either String [(XPropName, [XPropValue])]
parseXProp :: Text -> Either [Char] [(XPropName, [XPropValue])]
parseXProp = Result [(XPropName, [XPropValue])]
-> Either [Char] [(XPropName, [XPropValue])]
forall r. Result r -> Either [Char] r
eitherResult (Result [(XPropName, [XPropValue])]
 -> Either [Char] [(XPropName, [XPropValue])])
-> (Text -> Result [(XPropName, [XPropValue])])
-> Text
-> Either [Char] [(XPropName, [XPropValue])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser [(XPropName, [XPropValue])]
-> Text -> Result [(XPropName, [XPropValue])]
forall a. Parser a -> Text -> Result a
parse (Parser Text (XPropName, [XPropValue])
-> Parser [(XPropName, [XPropValue])]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Text (XPropName, [XPropValue])
parseProp)
  where
    parseProp :: Parser Text (XPropName, [XPropValue])
parseProp = do
      n <- [Char] -> XPropName
XPropName ([Char] -> XPropName) -> (Text -> [Char]) -> Text -> XPropName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> XPropName) -> Parser Text Text -> Parser Text XPropName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text
parsePropName
      vs <- parsePropValues <|> parseErrorMessage
      pure (n, vs)
    parseErrorMessage :: Parser Text b
parseErrorMessage = do
      Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Char -> Parser Text ())
-> Parser Text Char -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
char Char
':'
      (Char -> Bool) -> Parser Text ()
skipWhile Char -> Bool
isHorizontalSpace
      msg <- (Char -> Bool) -> Parser Text Text
takeTill Char -> Bool
isEndOfLine
      fail $ T.unpack msg
    parsePropValues :: Parser Text [XPropValue]
parsePropValues = do
      t <- Parser Text Text
parsePropType
      skipWhile isHorizontalSpace
      void $ char '='
      skipWhile isHorizontalSpace
      vs <- parsePropValue t `sepBy` parseValueSep
      endOfLine
      pure $ map (XPropValue . T.unpack) vs
    parsePropName :: Parser Text Text
parsePropName = (Char -> Bool) -> Parser Text Text
P.takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':')
    parsePropType :: Parser Text Text
parsePropType = Char -> Parser Text Char
char Char
'(' Parser Text Char -> Parser Text Text -> Parser Text Text
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text Text
P.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')') Parser Text Text -> Parser Text Char -> Parser Text Text
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
')'
    parseValueSep :: Parser Text Char
parseValueSep = Char -> Parser Text Char
char Char
',' Parser Text Char -> Parser Text () -> Parser Text Char
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Char -> Bool) -> Parser Text ()
skipWhile Char -> Bool
isHorizontalSpace
    takeUntilSep :: Parser Text Text
takeUntilSep = (Char -> Bool) -> Parser Text Text
takeTill (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Char -> Bool
isEndOfLine Char
c)
    quotedString :: Parser Text Text
quotedString = Parser Text Text
quotedString' Parser Text Text -> (Text -> Parser Text Text) -> Parser Text Text
forall a b. Parser Text a -> (a -> Parser Text b) -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Parser Text Text
unescape
    quotedString' :: Parser Text Text
quotedString' = Char -> Parser Text Char
char Char
'"' Parser Text Char -> Parser Text Text -> Parser Text Text
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text Text
P.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"') Parser Text Text -> Parser Text Char -> Parser Text Text
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
'"'
    unescape :: Text -> Parser Text Text
unescape = Text -> Parser Text Text
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Parser Text Text)
-> (Text -> Text) -> Text -> Parser Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\\\"" Text
"\"" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\\\\" Text
"\\"
    parsePropValue :: Text -> Parser Text Text
parsePropValue Text
"CARDINAL" = Parser Text Text
takeUntilSep
    parsePropValue Text
"ATOM" = Parser Text Text
takeUntilSep
    parsePropValue Text
"STRING" = Parser Text Text
quotedString
    parsePropValue Text
"UTF8_STRING" = Parser Text Text
quotedString
    parsePropValue Text
t = [Char] -> Parser Text Text
forall a. [Char] -> Parser Text a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser Text Text) -> [Char] -> Parser Text Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Can't parse format \"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\""

xpropSet :: MonadIO m => DisplayName -> XPropName -> XPropValue -> m ()
xpropSet :: forall (m :: * -> *).
MonadIO m =>
DisplayName -> XPropName -> XPropValue -> m ()
xpropSet DisplayName
d (XPropName [Char]
p) (XPropValue [Char]
v) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  [Char] -> IO ()
forall (m :: * -> *). MonadIO m => [Char] -> m ()
specLog ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"xpropSet running: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ProcessConfig () () () -> [Char]
forall a. Show a => a -> [Char]
show ProcessConfig () () ()
cfg
  ProcessConfig () () () -> IO ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_ ProcessConfig () () ()
cfg
  where
    cfg :: ProcessConfig () () ()
cfg = DisplayName -> [[Char]] -> ProcessConfig () () ()
xpropProc DisplayName
d [[Char]]
args
    args :: [[Char]]
args = [[Char]
"-root", [Char]
"-format", [Char]
p, [Char]
"8u", [Char]
"-set", [Char]
p, [Char]
v]

xpropRemove :: MonadIO m => DisplayName -> XPropName -> m ()
xpropRemove :: forall (m :: * -> *). MonadIO m => DisplayName -> XPropName -> m ()
xpropRemove DisplayName
d XPropName
p = do
  [Char] -> m ()
forall (m :: * -> *). MonadIO m => [Char] -> m ()
specLog ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"xpropRemove running: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ProcessConfig () () () -> [Char]
forall a. Show a => a -> [Char]
show ProcessConfig () () ()
cfg
  ProcessConfig () () () -> m ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_ ProcessConfig () () ()
cfg
  where
    cfg :: ProcessConfig () () ()
cfg = DisplayName -> [[Char]] -> ProcessConfig () () ()
xpropProc DisplayName
d [[Char]
"-root", [Char]
"-remove", XPropName -> [Char]
unXPropName XPropName
p]

xpropList :: MonadIO m => DisplayName -> m ()
xpropList :: forall (m :: * -> *). MonadIO m => DisplayName -> m ()
xpropList DisplayName
d = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  [Char] -> IO ()
forall (m :: * -> *). MonadIO m => [Char] -> m ()
specLog ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"xpropList running: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ProcessConfig () () () -> [Char]
forall a. Show a => a -> [Char]
show ProcessConfig () () ()
cfg
  ProcessConfig () () () -> IO ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_ ProcessConfig () () ()
cfg
  where
    cfg :: ProcessConfig () () ()
cfg = DisplayName -> [[Char]] -> ProcessConfig () () ()
xpropProc DisplayName
d [[Char]
"-root"]

------------------------------------------------------------------------

withXTerm :: (DisplayName -> IO a) -> (DisplayName -> IO a)
withXTerm :: forall a. (DisplayName -> IO a) -> DisplayName -> IO a
withXTerm DisplayName -> IO a
action DisplayName
dn = do
  cfg <- Priority -> ProcessConfig () () ()
makeXterm (Priority -> ProcessConfig () () ())
-> IO Priority -> IO (ProcessConfig () () ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Priority
forall (m :: * -> *). MonadIO m => m Priority
getSpecLogPriority
  specLog $ "withXTerm running: " ++ show cfg
  withProcessTerm cfg $ const $ do
    threadDelay 500_000 -- give xterm some time to start
    action dn
  where
    makeXterm :: Priority -> ProcessConfig () () ()
makeXterm Priority
v = [Char] -> [[Char]] -> ProcessConfig () () ()
proc [Char]
"xterm" (DisplayName -> [[Char]]
displayArg DisplayName
dn) ProcessConfig () () ()
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
forall a b. a -> (a -> b) -> b
& Priority -> ProcessConfig () () () -> ProcessConfig () () ()
forall i o e.
Priority -> ProcessConfig i o e -> ProcessConfig i o ()
setStderrCond Priority
v

------------------------------------------------------------------------

consumeXDisplayFd :: Handle -> IO DisplayName
consumeXDisplayFd :: Handle -> IO DisplayName
consumeXDisplayFd Handle
h = do
  l <- [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe ([Char] -> Maybe Int) -> IO [Char] -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO [Char]
hGetLine Handle
h
  hClose h
  d <- maybe (throwString "Failed to parse display number") (pure . displayNumber) l
  specLog $ "X is on display " ++ show d
  pure d

withXserver :: String -> [String] -> Maybe Int -> (DisplayName -> IO a) -> IO a
withXserver :: forall a.
[Char] -> [[Char]] -> Maybe Int -> (DisplayName -> IO a) -> IO a
withXserver [Char]
prog [[Char]]
args Maybe Int
display DisplayName -> IO a
action = do
  cfg <- Priority -> ProcessConfig () Handle ()
makeXvfb (Priority -> ProcessConfig () Handle ())
-> IO Priority -> IO (ProcessConfig () Handle ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Priority
forall (m :: * -> *). MonadIO m => m Priority
getSpecLogPriority
  specLog $ "withXserver running: " ++ show cfg
  withService cfg $ \Process () Handle ()
p -> do
    d <- Handle -> IO DisplayName
consumeXDisplayFd (Process () Handle () -> Handle
forall stdin stdout stderr. Process stdin stdout stderr -> stdout
getStdout Process () Handle ()
p)
    action d
  where
    args' :: [[Char]]
args' = [[Char]]
displayArgMaybe [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"-displayfd", [Char]
"1", [Char]
"-terminate", [Char]
"60"] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
args
    makeXvfb :: Priority -> ProcessConfig () Handle ()
makeXvfb Priority
logLevel = [Char] -> [[Char]] -> ProcessConfig () () ()
proc [Char]
prog [[Char]]
args'
      ProcessConfig () () ()
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
forall a b. a -> (a -> b) -> b
& Priority -> ProcessConfig () () () -> ProcessConfig () () ()
forall i o e.
Priority -> ProcessConfig i o e -> ProcessConfig () () ()
setServiceDefaults Priority
logLevel
      ProcessConfig () () ()
-> (ProcessConfig () () () -> ProcessConfig () Handle ())
-> ProcessConfig () Handle ()
forall a b. a -> (a -> b) -> b
& StreamSpec 'STOutput Handle
-> ProcessConfig () () () -> ProcessConfig () Handle ()
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe

    displayArgMaybe :: [[Char]]
displayArgMaybe = Maybe [Char] -> [[Char]]
forall a. Maybe a -> [a]
maybeToList ((Int -> [Char]) -> Maybe Int -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> [Char]
displaySpec Maybe Int
display)

withXvfb :: (DisplayName -> IO a) -> IO a
withXvfb :: forall a. (DisplayName -> IO a) -> IO a
withXvfb = [Char] -> [[Char]] -> Maybe Int -> (DisplayName -> IO a) -> IO a
forall a.
[Char] -> [[Char]] -> Maybe Int -> (DisplayName -> IO a) -> IO a
withXserver [Char]
"Xvfb" [[Char]
"-screen", [Char]
"0", [Char]
"1024x768x24"] Maybe Int
forall a. Maybe a
Nothing

withXdummy :: (DisplayName -> IO a) -> IO a
withXdummy :: forall a. (DisplayName -> IO a) -> IO a
withXdummy = [Char] -> [[Char]] -> Maybe Int -> (DisplayName -> IO a) -> IO a
forall a.
[Char] -> [[Char]] -> Maybe Int -> (DisplayName -> IO a) -> IO a
withXserver [Char]
"xdummy" [] Maybe Int
forall a. Maybe a
Nothing

-- | Using the given 'DisplayName', run an action with the @DISPLAY@
-- environment variable set.
--
-- NB. Don't run tests in parallel if using this. Environment
-- variables are process-global.
setDefaultDisplay_ :: DisplayName -> IO a -> IO a
setDefaultDisplay_ :: forall a. DisplayName -> IO a -> IO a
setDefaultDisplay_ = [([Char], [Char])] -> IO a -> IO a
forall a. [([Char], [Char])] -> IO a -> IO a
withSetEnv ([([Char], [Char])] -> IO a -> IO a)
-> (DisplayName -> [([Char], [Char])])
-> DisplayName
-> IO a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DisplayName -> [([Char], [Char])]
displayEnv

-- | Same as 'setDefaultDisplay_', except the 'DisplayName' parameter
-- is passed through to the action.
setDefaultDisplay :: DisplayName -> (DisplayName -> IO a) -> IO a
setDefaultDisplay :: forall a. DisplayName -> (DisplayName -> IO a) -> IO a
setDefaultDisplay DisplayName
d DisplayName -> IO a
action = DisplayName -> IO a -> IO a
forall a. DisplayName -> IO a -> IO a
setDefaultDisplay_ DisplayName
d (DisplayName -> IO a
action DisplayName
d)

------------------------------------------------------------------------

-- | Adds a guiding phantom type annotation for indices into lists.
-- fixme: zipper rather than indices
newtype ListIndex a = ListIndex { forall a. ListIndex a -> Int
unListIndex :: Int }
  deriving (Int -> ListIndex a -> [Char] -> [Char]
[ListIndex a] -> [Char] -> [Char]
ListIndex a -> [Char]
(Int -> ListIndex a -> [Char] -> [Char])
-> (ListIndex a -> [Char])
-> ([ListIndex a] -> [Char] -> [Char])
-> Show (ListIndex a)
forall a. Int -> ListIndex a -> [Char] -> [Char]
forall a. [ListIndex a] -> [Char] -> [Char]
forall a. ListIndex a -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: forall a. Int -> ListIndex a -> [Char] -> [Char]
showsPrec :: Int -> ListIndex a -> [Char] -> [Char]
$cshow :: forall a. ListIndex a -> [Char]
show :: ListIndex a -> [Char]
$cshowList :: forall a. [ListIndex a] -> [Char] -> [Char]
showList :: [ListIndex a] -> [Char] -> [Char]
Show, ReadPrec [ListIndex a]
ReadPrec (ListIndex a)
Int -> ReadS (ListIndex a)
ReadS [ListIndex a]
(Int -> ReadS (ListIndex a))
-> ReadS [ListIndex a]
-> ReadPrec (ListIndex a)
-> ReadPrec [ListIndex a]
-> Read (ListIndex a)
forall a. ReadPrec [ListIndex a]
forall a. ReadPrec (ListIndex a)
forall a. Int -> ReadS (ListIndex a)
forall a. ReadS [ListIndex a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Int -> ReadS (ListIndex a)
readsPrec :: Int -> ReadS (ListIndex a)
$creadList :: forall a. ReadS [ListIndex a]
readList :: ReadS [ListIndex a]
$creadPrec :: forall a. ReadPrec (ListIndex a)
readPrec :: ReadPrec (ListIndex a)
$creadListPrec :: forall a. ReadPrec [ListIndex a]
readListPrec :: ReadPrec [ListIndex a]
Read, ListIndex a -> ListIndex a -> Bool
(ListIndex a -> ListIndex a -> Bool)
-> (ListIndex a -> ListIndex a -> Bool) -> Eq (ListIndex a)
forall a. ListIndex a -> ListIndex a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. ListIndex a -> ListIndex a -> Bool
== :: ListIndex a -> ListIndex a -> Bool
$c/= :: forall a. ListIndex a -> ListIndex a -> Bool
/= :: ListIndex a -> ListIndex a -> Bool
Eq, Eq (ListIndex a)
Eq (ListIndex a) =>
(ListIndex a -> ListIndex a -> Ordering)
-> (ListIndex a -> ListIndex a -> Bool)
-> (ListIndex a -> ListIndex a -> Bool)
-> (ListIndex a -> ListIndex a -> Bool)
-> (ListIndex a -> ListIndex a -> Bool)
-> (ListIndex a -> ListIndex a -> ListIndex a)
-> (ListIndex a -> ListIndex a -> ListIndex a)
-> Ord (ListIndex a)
ListIndex a -> ListIndex a -> Bool
ListIndex a -> ListIndex a -> Ordering
ListIndex a -> ListIndex a -> ListIndex a
forall a. Eq (ListIndex a)
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
forall a. ListIndex a -> ListIndex a -> Bool
forall a. ListIndex a -> ListIndex a -> Ordering
forall a. ListIndex a -> ListIndex a -> ListIndex a
$ccompare :: forall a. ListIndex a -> ListIndex a -> Ordering
compare :: ListIndex a -> ListIndex a -> Ordering
$c< :: forall a. ListIndex a -> ListIndex a -> Bool
< :: ListIndex a -> ListIndex a -> Bool
$c<= :: forall a. ListIndex a -> ListIndex a -> Bool
<= :: ListIndex a -> ListIndex a -> Bool
$c> :: forall a. ListIndex a -> ListIndex a -> Bool
> :: ListIndex a -> ListIndex a -> Bool
$c>= :: forall a. ListIndex a -> ListIndex a -> Bool
>= :: ListIndex a -> ListIndex a -> Bool
$cmax :: forall a. ListIndex a -> ListIndex a -> ListIndex a
max :: ListIndex a -> ListIndex a -> ListIndex a
$cmin :: forall a. ListIndex a -> ListIndex a -> ListIndex a
min :: ListIndex a -> ListIndex a -> ListIndex a
Ord, Int -> ListIndex a
ListIndex a -> Int
ListIndex a -> [ListIndex a]
ListIndex a -> ListIndex a
ListIndex a -> ListIndex a -> [ListIndex a]
ListIndex a -> ListIndex a -> ListIndex a -> [ListIndex a]
(ListIndex a -> ListIndex a)
-> (ListIndex a -> ListIndex a)
-> (Int -> ListIndex a)
-> (ListIndex a -> Int)
-> (ListIndex a -> [ListIndex a])
-> (ListIndex a -> ListIndex a -> [ListIndex a])
-> (ListIndex a -> ListIndex a -> [ListIndex a])
-> (ListIndex a -> ListIndex a -> ListIndex a -> [ListIndex a])
-> Enum (ListIndex a)
forall a. Int -> ListIndex a
forall a. ListIndex a -> Int
forall a. ListIndex a -> [ListIndex a]
forall a. ListIndex a -> ListIndex a
forall a. ListIndex a -> ListIndex a -> [ListIndex a]
forall a.
ListIndex a -> ListIndex a -> ListIndex a -> [ListIndex a]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: forall a. ListIndex a -> ListIndex a
succ :: ListIndex a -> ListIndex a
$cpred :: forall a. ListIndex a -> ListIndex a
pred :: ListIndex a -> ListIndex a
$ctoEnum :: forall a. Int -> ListIndex a
toEnum :: Int -> ListIndex a
$cfromEnum :: forall a. ListIndex a -> Int
fromEnum :: ListIndex a -> Int
$cenumFrom :: forall a. ListIndex a -> [ListIndex a]
enumFrom :: ListIndex a -> [ListIndex a]
$cenumFromThen :: forall a. ListIndex a -> ListIndex a -> [ListIndex a]
enumFromThen :: ListIndex a -> ListIndex a -> [ListIndex a]
$cenumFromTo :: forall a. ListIndex a -> ListIndex a -> [ListIndex a]
enumFromTo :: ListIndex a -> ListIndex a -> [ListIndex a]
$cenumFromThenTo :: forall a.
ListIndex a -> ListIndex a -> ListIndex a -> [ListIndex a]
enumFromThenTo :: ListIndex a -> ListIndex a -> ListIndex a -> [ListIndex a]
Enum, Integer -> ListIndex a
ListIndex a -> ListIndex a
ListIndex a -> ListIndex a -> ListIndex a
(ListIndex a -> ListIndex a -> ListIndex a)
-> (ListIndex a -> ListIndex a -> ListIndex a)
-> (ListIndex a -> ListIndex a -> ListIndex a)
-> (ListIndex a -> ListIndex a)
-> (ListIndex a -> ListIndex a)
-> (ListIndex a -> ListIndex a)
-> (Integer -> ListIndex a)
-> Num (ListIndex a)
forall a. Integer -> ListIndex a
forall a. ListIndex a -> ListIndex a
forall a. ListIndex a -> ListIndex a -> ListIndex a
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: forall a. ListIndex a -> ListIndex a -> ListIndex a
+ :: ListIndex a -> ListIndex a -> ListIndex a
$c- :: forall a. ListIndex a -> ListIndex a -> ListIndex a
- :: ListIndex a -> ListIndex a -> ListIndex a
$c* :: forall a. ListIndex a -> ListIndex a -> ListIndex a
* :: ListIndex a -> ListIndex a -> ListIndex a
$cnegate :: forall a. ListIndex a -> ListIndex a
negate :: ListIndex a -> ListIndex a
$cabs :: forall a. ListIndex a -> ListIndex a
abs :: ListIndex a -> ListIndex a
$csignum :: forall a. ListIndex a -> ListIndex a
signum :: ListIndex a -> ListIndex a
$cfromInteger :: forall a. Integer -> ListIndex a
fromInteger :: Integer -> ListIndex a
Num, Num (ListIndex a)
Ord (ListIndex a)
(Num (ListIndex a), Ord (ListIndex a)) =>
(ListIndex a -> Rational) -> Real (ListIndex a)
ListIndex a -> Rational
forall a. Num (ListIndex a)
forall a. Ord (ListIndex a)
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
forall a. ListIndex a -> Rational
$ctoRational :: forall a. ListIndex a -> Rational
toRational :: ListIndex a -> Rational
Real, Enum (ListIndex a)
Real (ListIndex a)
(Real (ListIndex a), Enum (ListIndex a)) =>
(ListIndex a -> ListIndex a -> ListIndex a)
-> (ListIndex a -> ListIndex a -> ListIndex a)
-> (ListIndex a -> ListIndex a -> ListIndex a)
-> (ListIndex a -> ListIndex a -> ListIndex a)
-> (ListIndex a -> ListIndex a -> (ListIndex a, ListIndex a))
-> (ListIndex a -> ListIndex a -> (ListIndex a, ListIndex a))
-> (ListIndex a -> Integer)
-> Integral (ListIndex a)
ListIndex a -> Integer
ListIndex a -> ListIndex a -> (ListIndex a, ListIndex a)
ListIndex a -> ListIndex a -> ListIndex a
forall a. Enum (ListIndex a)
forall a. Real (ListIndex a)
forall a.
(Real a, Enum a) =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
forall a. ListIndex a -> Integer
forall a. ListIndex a -> ListIndex a -> (ListIndex a, ListIndex a)
forall a. ListIndex a -> ListIndex a -> ListIndex a
$cquot :: forall a. ListIndex a -> ListIndex a -> ListIndex a
quot :: ListIndex a -> ListIndex a -> ListIndex a
$crem :: forall a. ListIndex a -> ListIndex a -> ListIndex a
rem :: ListIndex a -> ListIndex a -> ListIndex a
$cdiv :: forall a. ListIndex a -> ListIndex a -> ListIndex a
div :: ListIndex a -> ListIndex a -> ListIndex a
$cmod :: forall a. ListIndex a -> ListIndex a -> ListIndex a
mod :: ListIndex a -> ListIndex a -> ListIndex a
$cquotRem :: forall a. ListIndex a -> ListIndex a -> (ListIndex a, ListIndex a)
quotRem :: ListIndex a -> ListIndex a -> (ListIndex a, ListIndex a)
$cdivMod :: forall a. ListIndex a -> ListIndex a -> (ListIndex a, ListIndex a)
divMod :: ListIndex a -> ListIndex a -> (ListIndex a, ListIndex a)
$ctoInteger :: forall a. ListIndex a -> Integer
toInteger :: ListIndex a -> Integer
Integral, (forall x. ListIndex a -> Rep (ListIndex a) x)
-> (forall x. Rep (ListIndex a) x -> ListIndex a)
-> Generic (ListIndex a)
forall x. Rep (ListIndex a) x -> ListIndex a
forall x. ListIndex a -> Rep (ListIndex a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ListIndex a) x -> ListIndex a
forall a x. ListIndex a -> Rep (ListIndex a) x
$cfrom :: forall a x. ListIndex a -> Rep (ListIndex a) x
from :: forall x. ListIndex a -> Rep (ListIndex a) x
$cto :: forall a x. Rep (ListIndex a) x -> ListIndex a
to :: forall x. Rep (ListIndex a) x -> ListIndex a
Generic)

enumerate :: [a] -> [(ListIndex a, a)]
enumerate :: forall a. [a] -> [(ListIndex a, a)]
enumerate = [ListIndex a] -> [a] -> [(ListIndex a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ListIndex a
0..]

bounds' :: Integral n => (n, n) -> (ListIndex a, ListIndex a)
bounds' :: forall n a. Integral n => (n, n) -> (ListIndex a, ListIndex a)
bounds' = let f :: n -> ListIndex a
f = Int -> ListIndex a
forall a. Int -> ListIndex a
ListIndex (Int -> ListIndex a) -> (n -> Int) -> n -> ListIndex a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral in (n -> ListIndex a)
-> (n -> ListIndex a) -> (n, n) -> (ListIndex a, ListIndex a)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap n -> ListIndex a
forall {a}. n -> ListIndex a
f n -> ListIndex a
forall {a}. n -> ListIndex a
f

bounds :: [a] -> (ListIndex a, ListIndex a)
bounds :: forall a. [a] -> (ListIndex a, ListIndex a)
bounds [a]
xs = (Int, Int) -> (ListIndex a, ListIndex a)
forall n a. Integral n => (n, n) -> (ListIndex a, ListIndex a)
bounds' (Int
0, [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

atIndex :: [a] -> ListIndex a -> a
atIndex :: forall a. [a] -> ListIndex a -> a
atIndex [a]
as (ListIndex Int
i) = [a]
as [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! Int
i

chooseListIndexN :: Int -> Gen (ListIndex a)
chooseListIndexN :: forall a. Int -> Gen (ListIndex a)
chooseListIndexN Int
n = Int -> ListIndex a
forall a. Int -> ListIndex a
ListIndex (Int -> ListIndex a) -> Gen Int -> Gen (ListIndex a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
chooseInt (Int
0, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

chooseListIndex :: [a] -> Gen (ListIndex a)
chooseListIndex :: forall a. [a] -> Gen (ListIndex a)
chooseListIndex = Int -> Gen (ListIndex a)
forall a. Int -> Gen (ListIndex a)
chooseListIndexN (Int -> Gen (ListIndex a))
-> ([a] -> Int) -> [a] -> Gen (ListIndex a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length

------------------------------------------------------------------------

data RRSetup = RRSetup
  { RRSetup -> [RROutput]
outputs :: [RROutput]
  , RRSetup -> Maybe (ListIndex RROutput)
primary :: Maybe (ListIndex RROutput)
  , RRSetup -> [RRMode]
newModes :: [RRMode] -- unused by outputs
  } deriving (Int -> RRSetup -> [Char] -> [Char]
[RRSetup] -> [Char] -> [Char]
RRSetup -> [Char]
(Int -> RRSetup -> [Char] -> [Char])
-> (RRSetup -> [Char])
-> ([RRSetup] -> [Char] -> [Char])
-> Show RRSetup
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> RRSetup -> [Char] -> [Char]
showsPrec :: Int -> RRSetup -> [Char] -> [Char]
$cshow :: RRSetup -> [Char]
show :: RRSetup -> [Char]
$cshowList :: [RRSetup] -> [Char] -> [Char]
showList :: [RRSetup] -> [Char] -> [Char]
Show, ReadPrec [RRSetup]
ReadPrec RRSetup
Int -> ReadS RRSetup
ReadS [RRSetup]
(Int -> ReadS RRSetup)
-> ReadS [RRSetup]
-> ReadPrec RRSetup
-> ReadPrec [RRSetup]
-> Read RRSetup
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS RRSetup
readsPrec :: Int -> ReadS RRSetup
$creadList :: ReadS [RRSetup]
readList :: ReadS [RRSetup]
$creadPrec :: ReadPrec RRSetup
readPrec :: ReadPrec RRSetup
$creadListPrec :: ReadPrec [RRSetup]
readListPrec :: ReadPrec [RRSetup]
Read, RRSetup -> RRSetup -> Bool
(RRSetup -> RRSetup -> Bool)
-> (RRSetup -> RRSetup -> Bool) -> Eq RRSetup
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RRSetup -> RRSetup -> Bool
== :: RRSetup -> RRSetup -> Bool
$c/= :: RRSetup -> RRSetup -> Bool
/= :: RRSetup -> RRSetup -> Bool
Eq, (forall x. RRSetup -> Rep RRSetup x)
-> (forall x. Rep RRSetup x -> RRSetup) -> Generic RRSetup
forall x. Rep RRSetup x -> RRSetup
forall x. RRSetup -> Rep RRSetup x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RRSetup -> Rep RRSetup x
from :: forall x. RRSetup -> Rep RRSetup x
$cto :: forall x. Rep RRSetup x -> RRSetup
to :: forall x. Rep RRSetup x -> RRSetup
Generic)

instance Default RRSetup where
  def :: RRSetup
def = RRSetup { outputs :: [RROutput]
outputs = [RROutput
forall a. Default a => a
def], primary :: Maybe (ListIndex RROutput)
primary = ListIndex RROutput -> Maybe (ListIndex RROutput)
forall a. a -> Maybe a
Just ListIndex RROutput
0, newModes :: [RRMode]
newModes = [] }

data RROutput = RROutput
  { RROutput -> Maybe RRExistingMode
mode :: Maybe RRExistingMode
  , RROutput -> RROutputSettings
settings :: RROutputSettings
  , RROutput -> RRPosition
position :: RRPosition
  } deriving (Int -> RROutput -> [Char] -> [Char]
[RROutput] -> [Char] -> [Char]
RROutput -> [Char]
(Int -> RROutput -> [Char] -> [Char])
-> (RROutput -> [Char])
-> ([RROutput] -> [Char] -> [Char])
-> Show RROutput
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> RROutput -> [Char] -> [Char]
showsPrec :: Int -> RROutput -> [Char] -> [Char]
$cshow :: RROutput -> [Char]
show :: RROutput -> [Char]
$cshowList :: [RROutput] -> [Char] -> [Char]
showList :: [RROutput] -> [Char] -> [Char]
Show, ReadPrec [RROutput]
ReadPrec RROutput
Int -> ReadS RROutput
ReadS [RROutput]
(Int -> ReadS RROutput)
-> ReadS [RROutput]
-> ReadPrec RROutput
-> ReadPrec [RROutput]
-> Read RROutput
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS RROutput
readsPrec :: Int -> ReadS RROutput
$creadList :: ReadS [RROutput]
readList :: ReadS [RROutput]
$creadPrec :: ReadPrec RROutput
readPrec :: ReadPrec RROutput
$creadListPrec :: ReadPrec [RROutput]
readListPrec :: ReadPrec [RROutput]
Read, RROutput -> RROutput -> Bool
(RROutput -> RROutput -> Bool)
-> (RROutput -> RROutput -> Bool) -> Eq RROutput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RROutput -> RROutput -> Bool
== :: RROutput -> RROutput -> Bool
$c/= :: RROutput -> RROutput -> Bool
/= :: RROutput -> RROutput -> Bool
Eq, (forall x. RROutput -> Rep RROutput x)
-> (forall x. Rep RROutput x -> RROutput) -> Generic RROutput
forall x. Rep RROutput x -> RROutput
forall x. RROutput -> Rep RROutput x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RROutput -> Rep RROutput x
from :: forall x. RROutput -> Rep RROutput x
$cto :: forall x. Rep RROutput x -> RROutput
to :: forall x. Rep RROutput x -> RROutput
Generic)

instance Default RROutput where
  def :: RROutput
def = RROutput { mode :: Maybe RRExistingMode
mode = Maybe RRExistingMode
forall a. Default a => a
def, settings :: RROutputSettings
settings = RROutputSettings
forall a. Default a => a
def, position :: RRPosition
position = RRPosition
forall a. Default a => a
def }

rrOutputOff :: RROutput
rrOutputOff :: RROutput
rrOutputOff = RROutput
forall a. Default a => a
def { settings = def { disabled = True } }

data RROutputSettings = RROutputSettings
  { RROutputSettings -> Bool
disabled :: Bool
  , RROutputSettings -> RRRotation
rotate :: RRRotation
  } deriving (Int -> RROutputSettings -> [Char] -> [Char]
[RROutputSettings] -> [Char] -> [Char]
RROutputSettings -> [Char]
(Int -> RROutputSettings -> [Char] -> [Char])
-> (RROutputSettings -> [Char])
-> ([RROutputSettings] -> [Char] -> [Char])
-> Show RROutputSettings
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> RROutputSettings -> [Char] -> [Char]
showsPrec :: Int -> RROutputSettings -> [Char] -> [Char]
$cshow :: RROutputSettings -> [Char]
show :: RROutputSettings -> [Char]
$cshowList :: [RROutputSettings] -> [Char] -> [Char]
showList :: [RROutputSettings] -> [Char] -> [Char]
Show, ReadPrec [RROutputSettings]
ReadPrec RROutputSettings
Int -> ReadS RROutputSettings
ReadS [RROutputSettings]
(Int -> ReadS RROutputSettings)
-> ReadS [RROutputSettings]
-> ReadPrec RROutputSettings
-> ReadPrec [RROutputSettings]
-> Read RROutputSettings
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS RROutputSettings
readsPrec :: Int -> ReadS RROutputSettings
$creadList :: ReadS [RROutputSettings]
readList :: ReadS [RROutputSettings]
$creadPrec :: ReadPrec RROutputSettings
readPrec :: ReadPrec RROutputSettings
$creadListPrec :: ReadPrec [RROutputSettings]
readListPrec :: ReadPrec [RROutputSettings]
Read, RROutputSettings -> RROutputSettings -> Bool
(RROutputSettings -> RROutputSettings -> Bool)
-> (RROutputSettings -> RROutputSettings -> Bool)
-> Eq RROutputSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RROutputSettings -> RROutputSettings -> Bool
== :: RROutputSettings -> RROutputSettings -> Bool
$c/= :: RROutputSettings -> RROutputSettings -> Bool
/= :: RROutputSettings -> RROutputSettings -> Bool
Eq, (forall x. RROutputSettings -> Rep RROutputSettings x)
-> (forall x. Rep RROutputSettings x -> RROutputSettings)
-> Generic RROutputSettings
forall x. Rep RROutputSettings x -> RROutputSettings
forall x. RROutputSettings -> Rep RROutputSettings x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RROutputSettings -> Rep RROutputSettings x
from :: forall x. RROutputSettings -> Rep RROutputSettings x
$cto :: forall x. Rep RROutputSettings x -> RROutputSettings
to :: forall x. Rep RROutputSettings x -> RROutputSettings
Generic)

instance Default RROutputSettings where
  def :: RROutputSettings
def = RROutputSettings { disabled :: Bool
disabled = Bool
False, rotate :: RRRotation
rotate = RRRotation
forall a. Default a => a
def }

-- | This is an index into 'modeLines'.
newtype RRExistingMode = RRExistingMode { RRExistingMode -> ListIndex RRMode
unRRExistingMode :: ListIndex RRMode }
  deriving (Int -> RRExistingMode -> [Char] -> [Char]
[RRExistingMode] -> [Char] -> [Char]
RRExistingMode -> [Char]
(Int -> RRExistingMode -> [Char] -> [Char])
-> (RRExistingMode -> [Char])
-> ([RRExistingMode] -> [Char] -> [Char])
-> Show RRExistingMode
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> RRExistingMode -> [Char] -> [Char]
showsPrec :: Int -> RRExistingMode -> [Char] -> [Char]
$cshow :: RRExistingMode -> [Char]
show :: RRExistingMode -> [Char]
$cshowList :: [RRExistingMode] -> [Char] -> [Char]
showList :: [RRExistingMode] -> [Char] -> [Char]
Show, ReadPrec [RRExistingMode]
ReadPrec RRExistingMode
Int -> ReadS RRExistingMode
ReadS [RRExistingMode]
(Int -> ReadS RRExistingMode)
-> ReadS [RRExistingMode]
-> ReadPrec RRExistingMode
-> ReadPrec [RRExistingMode]
-> Read RRExistingMode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS RRExistingMode
readsPrec :: Int -> ReadS RRExistingMode
$creadList :: ReadS [RRExistingMode]
readList :: ReadS [RRExistingMode]
$creadPrec :: ReadPrec RRExistingMode
readPrec :: ReadPrec RRExistingMode
$creadListPrec :: ReadPrec [RRExistingMode]
readListPrec :: ReadPrec [RRExistingMode]
Read, RRExistingMode -> RRExistingMode -> Bool
(RRExistingMode -> RRExistingMode -> Bool)
-> (RRExistingMode -> RRExistingMode -> Bool) -> Eq RRExistingMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RRExistingMode -> RRExistingMode -> Bool
== :: RRExistingMode -> RRExistingMode -> Bool
$c/= :: RRExistingMode -> RRExistingMode -> Bool
/= :: RRExistingMode -> RRExistingMode -> Bool
Eq, Eq RRExistingMode
Eq RRExistingMode =>
(RRExistingMode -> RRExistingMode -> Ordering)
-> (RRExistingMode -> RRExistingMode -> Bool)
-> (RRExistingMode -> RRExistingMode -> Bool)
-> (RRExistingMode -> RRExistingMode -> Bool)
-> (RRExistingMode -> RRExistingMode -> Bool)
-> (RRExistingMode -> RRExistingMode -> RRExistingMode)
-> (RRExistingMode -> RRExistingMode -> RRExistingMode)
-> Ord RRExistingMode
RRExistingMode -> RRExistingMode -> Bool
RRExistingMode -> RRExistingMode -> Ordering
RRExistingMode -> RRExistingMode -> RRExistingMode
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
$ccompare :: RRExistingMode -> RRExistingMode -> Ordering
compare :: RRExistingMode -> RRExistingMode -> Ordering
$c< :: RRExistingMode -> RRExistingMode -> Bool
< :: RRExistingMode -> RRExistingMode -> Bool
$c<= :: RRExistingMode -> RRExistingMode -> Bool
<= :: RRExistingMode -> RRExistingMode -> Bool
$c> :: RRExistingMode -> RRExistingMode -> Bool
> :: RRExistingMode -> RRExistingMode -> Bool
$c>= :: RRExistingMode -> RRExistingMode -> Bool
>= :: RRExistingMode -> RRExistingMode -> Bool
$cmax :: RRExistingMode -> RRExistingMode -> RRExistingMode
max :: RRExistingMode -> RRExistingMode -> RRExistingMode
$cmin :: RRExistingMode -> RRExistingMode -> RRExistingMode
min :: RRExistingMode -> RRExistingMode -> RRExistingMode
Ord, Int -> RRExistingMode
RRExistingMode -> Int
RRExistingMode -> [RRExistingMode]
RRExistingMode -> RRExistingMode
RRExistingMode -> RRExistingMode -> [RRExistingMode]
RRExistingMode
-> RRExistingMode -> RRExistingMode -> [RRExistingMode]
(RRExistingMode -> RRExistingMode)
-> (RRExistingMode -> RRExistingMode)
-> (Int -> RRExistingMode)
-> (RRExistingMode -> Int)
-> (RRExistingMode -> [RRExistingMode])
-> (RRExistingMode -> RRExistingMode -> [RRExistingMode])
-> (RRExistingMode -> RRExistingMode -> [RRExistingMode])
-> (RRExistingMode
    -> RRExistingMode -> RRExistingMode -> [RRExistingMode])
-> Enum RRExistingMode
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: RRExistingMode -> RRExistingMode
succ :: RRExistingMode -> RRExistingMode
$cpred :: RRExistingMode -> RRExistingMode
pred :: RRExistingMode -> RRExistingMode
$ctoEnum :: Int -> RRExistingMode
toEnum :: Int -> RRExistingMode
$cfromEnum :: RRExistingMode -> Int
fromEnum :: RRExistingMode -> Int
$cenumFrom :: RRExistingMode -> [RRExistingMode]
enumFrom :: RRExistingMode -> [RRExistingMode]
$cenumFromThen :: RRExistingMode -> RRExistingMode -> [RRExistingMode]
enumFromThen :: RRExistingMode -> RRExistingMode -> [RRExistingMode]
$cenumFromTo :: RRExistingMode -> RRExistingMode -> [RRExistingMode]
enumFromTo :: RRExistingMode -> RRExistingMode -> [RRExistingMode]
$cenumFromThenTo :: RRExistingMode
-> RRExistingMode -> RRExistingMode -> [RRExistingMode]
enumFromThenTo :: RRExistingMode
-> RRExistingMode -> RRExistingMode -> [RRExistingMode]
Enum, (forall x. RRExistingMode -> Rep RRExistingMode x)
-> (forall x. Rep RRExistingMode x -> RRExistingMode)
-> Generic RRExistingMode
forall x. Rep RRExistingMode x -> RRExistingMode
forall x. RRExistingMode -> Rep RRExistingMode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RRExistingMode -> Rep RRExistingMode x
from :: forall x. RRExistingMode -> Rep RRExistingMode x
$cto :: forall x. Rep RRExistingMode x -> RRExistingMode
to :: forall x. Rep RRExistingMode x -> RRExistingMode
Generic)

instance Bounded RRExistingMode where
  minBound :: RRExistingMode
minBound = ListIndex RRMode -> RRExistingMode
RRExistingMode ListIndex RRMode
0
  maxBound :: RRExistingMode
maxBound = ListIndex RRMode -> RRExistingMode
RRExistingMode ((ListIndex RRMode, ListIndex RRMode) -> ListIndex RRMode
forall a b. (a, b) -> b
snd ([RRMode] -> (ListIndex RRMode, ListIndex RRMode)
forall a. [a] -> (ListIndex a, ListIndex a)
bounds [RRMode]
modeLines))

instance Default RRExistingMode where
  def :: RRExistingMode
def = RRExistingMode
forall a. Bounded a => a
minBound

data RRMode = RRMode
  { RRMode -> RRModeName
name :: RRModeName
  , RRMode -> RRModeLine
modeLine :: RRModeLine
  } deriving (Int -> RRMode -> [Char] -> [Char]
[RRMode] -> [Char] -> [Char]
RRMode -> [Char]
(Int -> RRMode -> [Char] -> [Char])
-> (RRMode -> [Char])
-> ([RRMode] -> [Char] -> [Char])
-> Show RRMode
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> RRMode -> [Char] -> [Char]
showsPrec :: Int -> RRMode -> [Char] -> [Char]
$cshow :: RRMode -> [Char]
show :: RRMode -> [Char]
$cshowList :: [RRMode] -> [Char] -> [Char]
showList :: [RRMode] -> [Char] -> [Char]
Show, ReadPrec [RRMode]
ReadPrec RRMode
Int -> ReadS RRMode
ReadS [RRMode]
(Int -> ReadS RRMode)
-> ReadS [RRMode]
-> ReadPrec RRMode
-> ReadPrec [RRMode]
-> Read RRMode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS RRMode
readsPrec :: Int -> ReadS RRMode
$creadList :: ReadS [RRMode]
readList :: ReadS [RRMode]
$creadPrec :: ReadPrec RRMode
readPrec :: ReadPrec RRMode
$creadListPrec :: ReadPrec [RRMode]
readListPrec :: ReadPrec [RRMode]
Read, RRMode -> RRMode -> Bool
(RRMode -> RRMode -> Bool)
-> (RRMode -> RRMode -> Bool) -> Eq RRMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RRMode -> RRMode -> Bool
== :: RRMode -> RRMode -> Bool
$c/= :: RRMode -> RRMode -> Bool
/= :: RRMode -> RRMode -> Bool
Eq, (forall x. RRMode -> Rep RRMode x)
-> (forall x. Rep RRMode x -> RRMode) -> Generic RRMode
forall x. Rep RRMode x -> RRMode
forall x. RRMode -> Rep RRMode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RRMode -> Rep RRMode x
from :: forall x. RRMode -> Rep RRMode x
$cto :: forall x. Rep RRMode x -> RRMode
to :: forall x. Rep RRMode x -> RRMode
Generic)

instance IsString RRMode where
  fromString :: [Char] -> RRMode
fromString = (RRModeName -> RRModeLine -> RRMode)
-> (RRModeName, RRModeLine) -> RRMode
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry RRModeName -> RRModeLine -> RRMode
RRMode ((RRModeName, RRModeLine) -> RRMode)
-> ([Char] -> (RRModeName, RRModeLine)) -> [Char] -> RRMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> RRModeName)
-> ([Char] -> RRModeLine)
-> ([Char], [Char])
-> (RRModeName, RRModeLine)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ([Char] -> RRModeName
RRModeName ([Char] -> RRModeName)
-> ([Char] -> [Char]) -> [Char] -> RRModeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
unquote) [Char] -> RRModeLine
RRModeLine (([Char], [Char]) -> (RRModeName, RRModeLine))
-> ([Char] -> ([Char], [Char]))
-> [Char]
-> (RRModeName, RRModeLine)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ([Char], [Char])
split
    where
      split :: [Char] -> ([Char], [Char])
split = ([Char] -> [Char]) -> ([Char], [Char]) -> ([Char], [Char])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace) (([Char], [Char]) -> ([Char], [Char]))
-> ([Char] -> ([Char], [Char])) -> [Char] -> ([Char], [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace
      unquote :: [Char] -> [Char]
unquote = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"')

newtype RRModeName = RRModeName { RRModeName -> [Char]
unRRModeName :: String }
  deriving (Int -> RRModeName -> [Char] -> [Char]
[RRModeName] -> [Char] -> [Char]
RRModeName -> [Char]
(Int -> RRModeName -> [Char] -> [Char])
-> (RRModeName -> [Char])
-> ([RRModeName] -> [Char] -> [Char])
-> Show RRModeName
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> RRModeName -> [Char] -> [Char]
showsPrec :: Int -> RRModeName -> [Char] -> [Char]
$cshow :: RRModeName -> [Char]
show :: RRModeName -> [Char]
$cshowList :: [RRModeName] -> [Char] -> [Char]
showList :: [RRModeName] -> [Char] -> [Char]
Show, ReadPrec [RRModeName]
ReadPrec RRModeName
Int -> ReadS RRModeName
ReadS [RRModeName]
(Int -> ReadS RRModeName)
-> ReadS [RRModeName]
-> ReadPrec RRModeName
-> ReadPrec [RRModeName]
-> Read RRModeName
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS RRModeName
readsPrec :: Int -> ReadS RRModeName
$creadList :: ReadS [RRModeName]
readList :: ReadS [RRModeName]
$creadPrec :: ReadPrec RRModeName
readPrec :: ReadPrec RRModeName
$creadListPrec :: ReadPrec [RRModeName]
readListPrec :: ReadPrec [RRModeName]
Read, RRModeName -> RRModeName -> Bool
(RRModeName -> RRModeName -> Bool)
-> (RRModeName -> RRModeName -> Bool) -> Eq RRModeName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RRModeName -> RRModeName -> Bool
== :: RRModeName -> RRModeName -> Bool
$c/= :: RRModeName -> RRModeName -> Bool
/= :: RRModeName -> RRModeName -> Bool
Eq, [Char] -> RRModeName
([Char] -> RRModeName) -> IsString RRModeName
forall a. ([Char] -> a) -> IsString a
$cfromString :: [Char] -> RRModeName
fromString :: [Char] -> RRModeName
IsString, (forall x. RRModeName -> Rep RRModeName x)
-> (forall x. Rep RRModeName x -> RRModeName) -> Generic RRModeName
forall x. Rep RRModeName x -> RRModeName
forall x. RRModeName -> Rep RRModeName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RRModeName -> Rep RRModeName x
from :: forall x. RRModeName -> Rep RRModeName x
$cto :: forall x. Rep RRModeName x -> RRModeName
to :: forall x. Rep RRModeName x -> RRModeName
Generic)

newtype RRModeLine = RRModeLine { RRModeLine -> [Char]
unRRModeLine :: String }
  deriving (Int -> RRModeLine -> [Char] -> [Char]
[RRModeLine] -> [Char] -> [Char]
RRModeLine -> [Char]
(Int -> RRModeLine -> [Char] -> [Char])
-> (RRModeLine -> [Char])
-> ([RRModeLine] -> [Char] -> [Char])
-> Show RRModeLine
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> RRModeLine -> [Char] -> [Char]
showsPrec :: Int -> RRModeLine -> [Char] -> [Char]
$cshow :: RRModeLine -> [Char]
show :: RRModeLine -> [Char]
$cshowList :: [RRModeLine] -> [Char] -> [Char]
showList :: [RRModeLine] -> [Char] -> [Char]
Show, ReadPrec [RRModeLine]
ReadPrec RRModeLine
Int -> ReadS RRModeLine
ReadS [RRModeLine]
(Int -> ReadS RRModeLine)
-> ReadS [RRModeLine]
-> ReadPrec RRModeLine
-> ReadPrec [RRModeLine]
-> Read RRModeLine
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS RRModeLine
readsPrec :: Int -> ReadS RRModeLine
$creadList :: ReadS [RRModeLine]
readList :: ReadS [RRModeLine]
$creadPrec :: ReadPrec RRModeLine
readPrec :: ReadPrec RRModeLine
$creadListPrec :: ReadPrec [RRModeLine]
readListPrec :: ReadPrec [RRModeLine]
Read, RRModeLine -> RRModeLine -> Bool
(RRModeLine -> RRModeLine -> Bool)
-> (RRModeLine -> RRModeLine -> Bool) -> Eq RRModeLine
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RRModeLine -> RRModeLine -> Bool
== :: RRModeLine -> RRModeLine -> Bool
$c/= :: RRModeLine -> RRModeLine -> Bool
/= :: RRModeLine -> RRModeLine -> Bool
Eq, [Char] -> RRModeLine
([Char] -> RRModeLine) -> IsString RRModeLine
forall a. ([Char] -> a) -> IsString a
$cfromString :: [Char] -> RRModeLine
fromString :: [Char] -> RRModeLine
IsString, (forall x. RRModeLine -> Rep RRModeLine x)
-> (forall x. Rep RRModeLine x -> RRModeLine) -> Generic RRModeLine
forall x. Rep RRModeLine x -> RRModeLine
forall x. RRModeLine -> Rep RRModeLine x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RRModeLine -> Rep RRModeLine x
from :: forall x. RRModeLine -> Rep RRModeLine x
$cto :: forall x. Rep RRModeLine x -> RRModeLine
to :: forall x. Rep RRModeLine x -> RRModeLine
Generic)

data RRPosition = SameAs | RightOf | LeftOf | Below | Above
  deriving (Int -> RRPosition -> [Char] -> [Char]
[RRPosition] -> [Char] -> [Char]
RRPosition -> [Char]
(Int -> RRPosition -> [Char] -> [Char])
-> (RRPosition -> [Char])
-> ([RRPosition] -> [Char] -> [Char])
-> Show RRPosition
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> RRPosition -> [Char] -> [Char]
showsPrec :: Int -> RRPosition -> [Char] -> [Char]
$cshow :: RRPosition -> [Char]
show :: RRPosition -> [Char]
$cshowList :: [RRPosition] -> [Char] -> [Char]
showList :: [RRPosition] -> [Char] -> [Char]
Show, ReadPrec [RRPosition]
ReadPrec RRPosition
Int -> ReadS RRPosition
ReadS [RRPosition]
(Int -> ReadS RRPosition)
-> ReadS [RRPosition]
-> ReadPrec RRPosition
-> ReadPrec [RRPosition]
-> Read RRPosition
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS RRPosition
readsPrec :: Int -> ReadS RRPosition
$creadList :: ReadS [RRPosition]
readList :: ReadS [RRPosition]
$creadPrec :: ReadPrec RRPosition
readPrec :: ReadPrec RRPosition
$creadListPrec :: ReadPrec [RRPosition]
readListPrec :: ReadPrec [RRPosition]
Read, RRPosition -> RRPosition -> Bool
(RRPosition -> RRPosition -> Bool)
-> (RRPosition -> RRPosition -> Bool) -> Eq RRPosition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RRPosition -> RRPosition -> Bool
== :: RRPosition -> RRPosition -> Bool
$c/= :: RRPosition -> RRPosition -> Bool
/= :: RRPosition -> RRPosition -> Bool
Eq, RRPosition
RRPosition -> RRPosition -> Bounded RRPosition
forall a. a -> a -> Bounded a
$cminBound :: RRPosition
minBound :: RRPosition
$cmaxBound :: RRPosition
maxBound :: RRPosition
Bounded, Int -> RRPosition
RRPosition -> Int
RRPosition -> [RRPosition]
RRPosition -> RRPosition
RRPosition -> RRPosition -> [RRPosition]
RRPosition -> RRPosition -> RRPosition -> [RRPosition]
(RRPosition -> RRPosition)
-> (RRPosition -> RRPosition)
-> (Int -> RRPosition)
-> (RRPosition -> Int)
-> (RRPosition -> [RRPosition])
-> (RRPosition -> RRPosition -> [RRPosition])
-> (RRPosition -> RRPosition -> [RRPosition])
-> (RRPosition -> RRPosition -> RRPosition -> [RRPosition])
-> Enum RRPosition
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: RRPosition -> RRPosition
succ :: RRPosition -> RRPosition
$cpred :: RRPosition -> RRPosition
pred :: RRPosition -> RRPosition
$ctoEnum :: Int -> RRPosition
toEnum :: Int -> RRPosition
$cfromEnum :: RRPosition -> Int
fromEnum :: RRPosition -> Int
$cenumFrom :: RRPosition -> [RRPosition]
enumFrom :: RRPosition -> [RRPosition]
$cenumFromThen :: RRPosition -> RRPosition -> [RRPosition]
enumFromThen :: RRPosition -> RRPosition -> [RRPosition]
$cenumFromTo :: RRPosition -> RRPosition -> [RRPosition]
enumFromTo :: RRPosition -> RRPosition -> [RRPosition]
$cenumFromThenTo :: RRPosition -> RRPosition -> RRPosition -> [RRPosition]
enumFromThenTo :: RRPosition -> RRPosition -> RRPosition -> [RRPosition]
Enum, (forall x. RRPosition -> Rep RRPosition x)
-> (forall x. Rep RRPosition x -> RRPosition) -> Generic RRPosition
forall x. Rep RRPosition x -> RRPosition
forall x. RRPosition -> Rep RRPosition x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RRPosition -> Rep RRPosition x
from :: forall x. RRPosition -> Rep RRPosition x
$cto :: forall x. Rep RRPosition x -> RRPosition
to :: forall x. Rep RRPosition x -> RRPosition
Generic)

instance Default RRPosition where
  def :: RRPosition
def = RRPosition
SameAs

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

instance Default RRRotation where
  def :: RRRotation
def = RRRotation
Unrotated

-- | These 'modeLines' are pre-configured in @xdummy@. They can be
-- referred to by name ('RRExistingMode'), or used in 'Arbitrary'
-- instances to generate new modelines.
modeLines :: [RRMode]
modeLines :: [RRMode]
modeLines =
  [ RRMode
"1280x1024 157.500 1280 1344 1504 1728 1024 1025 1028 1072 +HSync +VSync +preferred"
  , RRMode
"1280x1024 135.000 1280 1296 1440 1688 1024 1025 1028 1066 +HSync +VSync"
  , RRMode
"1280x1024 108.000 1280 1328 1440 1688 1024 1025 1028 1066 +HSync +VSync"
  , RRMode
"1280x960 148.500 1280 1344 1504 1728 960 961 964 1011 +HSync +VSync"
  , RRMode
"1280x960 108.000 1280 1376 1488 1800 960 961 964 1000 +HSync +VSync"
  , RRMode
"1280x800 83.500 1280 1352 1480 1680 800 803 809 831 -HSync +VSync"
  , RRMode
"1152x864 108.000 1152 1216 1344 1600 864 865 868 900 +HSync +VSync"
  , RRMode
"1280x720 74.500 1280 1344 1472 1664 720 723 728 748 -HSync +VSync"
  , RRMode
"1024x768 94.500 1024 1072 1168 1376 768 769 772 808 +HSync +VSync"
  , RRMode
"1024x768 78.750 1024 1040 1136 1312 768 769 772 800 +HSync +VSync"
  , RRMode
"1024x768 75.000 1024 1048 1184 1328 768 771 777 806 -HSync -VSync"
  , RRMode
"1024x768 65.000 1024 1048 1184 1344 768 771 777 806 -HSync -VSync"
  , RRMode
"1024x576 46.500 1024 1064 1160 1296 576 579 584 599 -HSync +VSync"
  , RRMode
"832x624 57.284 832 864 928 1152 624 625 628 667 -HSync -VSync"
  , RRMode
"960x540 40.750 960 992 1088 1216 540 543 548 562 -HSync +VSync"
  , RRMode
"800x600 56.300 800 832 896 1048 600 601 604 631 +HSync +VSync"
  , RRMode
"800x600 50.000 800 856 976 1040 600 637 643 666 +HSync +VSync"
  , RRMode
"800x600 49.500 800 816 896 1056 600 601 604 625 +HSync +VSync"
  , RRMode
"800x600 40.000 800 840 968 1056 600 601 605 628 +HSync +VSync"
  , RRMode
"800x600 36.000 800 824 896 1024 600 601 603 625 +HSync +VSync"
  , RRMode
"864x486 32.500 864 888 968 1072 486 489 494 506 -HSync +VSync"
  , RRMode
"640x480 36.000 640 696 752 832 480 481 484 509 -HSync -VSync"
  , RRMode
"640x480 31.500 640 656 720 840 480 481 484 500 -HSync -VSync"
  , RRMode
"640x480 31.500 640 664 704 832 480 489 492 520 -HSync -VSync"
  , RRMode
"640x480 25.175 640 656 752 800 480 490 492 525 -HSync -VSync"
  , RRMode
"720x400 35.500 720 756 828 936 400 401 404 446 -HSync +VSync"
  , RRMode
"640x400 31.500 640 672 736 832 400 401 404 445 -HSync +VSync"
  , RRMode
"640x350 31.500 640 672 736 832 350 382 385 445 +HSync -VSync"
  ]

xrandr :: DisplayName -> [String] -> ProcessConfig () () ()
xrandr :: DisplayName -> [[Char]] -> ProcessConfig () () ()
xrandr DisplayName
d [[Char]]
args = [Char] -> [[Char]] -> ProcessConfig () () ()
proc [Char]
"xrandr" (DisplayName -> [[Char]]
displayArg DisplayName
d [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
args)

runXrandr :: DisplayName -> [String] -> IO ()
runXrandr :: DisplayName -> [[Char]] -> IO ()
runXrandr DisplayName
d [[Char]]
args = do
  let cfg :: ProcessConfig () () ()
cfg = DisplayName -> [[Char]] -> ProcessConfig () () ()
xrandr DisplayName
d [[Char]]
args
  [Char] -> IO ()
forall (m :: * -> *). MonadIO m => [Char] -> m ()
specLog ([Char]
"running: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ProcessConfig () () () -> [Char]
forall a. Show a => a -> [Char]
show ProcessConfig () () ()
cfg)
  -- NB. void . readProcess_ instead of runProcess_ so that stderr
  -- can be included in the ExitCodeException.
  IO (ByteString, ByteString) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ByteString, ByteString) -> IO ())
-> IO (ByteString, ByteString) -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessConfig () () () -> IO (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_ ProcessConfig () () ()
cfg

runXrandrSilent :: DisplayName -> [String] -> IO ExitCode
runXrandrSilent :: DisplayName -> [[Char]] -> IO ExitCode
runXrandrSilent DisplayName
d [[Char]]
args = do
  let cfg :: ProcessConfig () () ()
cfg = DisplayName -> [[Char]] -> ProcessConfig () () ()
xrandr DisplayName
d [[Char]]
args ProcessConfig () () ()
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
forall a b. a -> (a -> b) -> b
& StreamSpec 'STOutput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
nullStream ProcessConfig () () ()
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
forall a b. a -> (a -> b) -> b
& StreamSpec 'STOutput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
nullStream
  [Char] -> IO ()
forall (m :: * -> *). MonadIO m => [Char] -> m ()
specLog ([Char]
"running: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ProcessConfig () () () -> [Char]
forall a. Show a => a -> [Char]
show ProcessConfig () () ()
cfg)
  ProcessConfig () () () -> IO ExitCode
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ExitCode
runProcess ProcessConfig () () ()
cfg

withRandrSetup :: DisplayName -> RRSetup -> (IO a -> IO a)
withRandrSetup :: forall a. DisplayName -> RRSetup -> IO a -> IO a
withRandrSetup DisplayName
d RRSetup
rr = IO () -> IO () -> IO a -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
bracket_ (DisplayName -> RRSetup -> IO ()
randrSetup DisplayName
d RRSetup
rr) (DisplayName -> RRSetup -> IO ()
randrTeardown DisplayName
d RRSetup
rr)

randrSetup :: DisplayName -> RRSetup -> IO ()
randrSetup :: DisplayName -> RRSetup -> IO ()
randrSetup DisplayName
d RRSetup
rr = do
  -- TODO: is it possible to smush these into one xrandr command?
  [RRMode] -> (RRMode -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ RRSetup
rr.newModes ((RRMode -> IO ()) -> IO ()) -> (RRMode -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \RRMode
m ->
    DisplayName -> [[Char]] -> IO ()
runXrandr DisplayName
d ([[Char]] -> IO ()) -> [[Char]] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]
"--newmode", RRModeName -> [Char]
forall a b. Coercible a b => a -> b
coerce RRMode
m.name] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]]
words (RRModeLine -> [Char]
forall a b. Coercible a b => a -> b
coerce RRMode
m.modeLine)

  [(ListIndex RROutput, RROutput)]
-> ((ListIndex RROutput, RROutput) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([RROutput] -> [(ListIndex RROutput, RROutput)]
forall a. [a] -> [(ListIndex a, a)]
enumerate RRSetup
rr.outputs) (((ListIndex RROutput, RROutput) -> IO ()) -> IO ())
-> ((ListIndex RROutput, RROutput) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ListIndex RROutput
i, RROutput
o) -> case RROutput
o.mode of
    Just RRExistingMode
m -> DisplayName -> [[Char]] -> IO ()
runXrandr DisplayName
d [[Char]
"--addmode", ListIndex RROutput -> [Char]
outputName ListIndex RROutput
i, RRExistingMode -> [Char]
modeName RRExistingMode
m]
    Maybe RRExistingMode
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  DisplayName -> [[Char]] -> IO ()
runXrandr DisplayName
d [[Char]]
args

  where
    args :: [[Char]]
args = [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]]
globalArgs [[[Char]]] -> [[[Char]]] -> [[[Char]]]
forall a. [a] -> [a] -> [a]
++ [[[Char]]]
givenArgs [[[Char]]] -> [[[Char]]] -> [[[Char]]]
forall a. [a] -> [a] -> [a]
++ [RROutput] -> [[[Char]]]
switchOffOthers RRSetup
rr.outputs)
    globalArgs :: [[[Char]]]
globalArgs = [ [[Char]
"--noprimary" | Maybe (ListIndex RROutput) -> Bool
forall a. Maybe a -> Bool
isNothing RRSetup
rr.primary ] ]

    givenArgs :: [[[Char]]]
givenArgs = (ListIndex RROutput -> RROutput -> [[Char]])
-> [ListIndex RROutput] -> [RROutput] -> [[[Char]]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ListIndex RROutput -> RROutput -> [[Char]]
outputArgs [ListIndex RROutput
0..] RRSetup
rr.outputs

    outputArgs :: ListIndex RROutput -> RROutput -> [String]
    outputArgs :: ListIndex RROutput -> RROutput -> [[Char]]
outputArgs ListIndex RROutput
i RROutput
output =
      [ [Char]
"--output", ListIndex RROutput -> [Char]
outputName ListIndex RROutput
i
      , [Char]
"--rotate", RRRotation -> [Char]
rrRotation RROutput
output.settings.rotate
      ] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
      [[Char]]
-> (RRExistingMode -> [[Char]]) -> Maybe RRExistingMode -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [[Char]
"--preferred"] (\RRExistingMode
m -> [[Char]
"--mode", RRExistingMode -> [Char]
modeName RRExistingMode
m]) RROutput
output.mode [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
      [[Char]
"--off" | RROutput
output.settings.disabled ] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
      [[Char]
"--primary" | RRSetup
rr.primary Maybe (ListIndex RROutput) -> Maybe (ListIndex RROutput) -> Bool
forall a. Eq a => a -> a -> Bool
== ListIndex RROutput -> Maybe (ListIndex RROutput)
forall a. a -> Maybe a
Just ListIndex RROutput
i] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
      (if ListIndex RROutput
i ListIndex RROutput -> ListIndex RROutput -> Bool
forall a. Ord a => a -> a -> Bool
> ListIndex RROutput
0 then [[Char]
"--" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RRPosition -> [Char]
rrPosition RROutput
output.position, ListIndex RROutput -> [Char]
outputName (ListIndex RROutput
i ListIndex RROutput -> ListIndex RROutput -> ListIndex RROutput
forall a. Num a => a -> a -> a
- ListIndex RROutput
1)] else [])

    switchOffOthers :: [RROutput] -> [[String]]
    switchOffOthers :: [RROutput] -> [[[Char]]]
switchOffOthers [RROutput]
os = [ [[Char]
"--output", ListIndex RROutput -> [Char]
outputName ListIndex RROutput
i, [Char]
"--off"]
                         | ListIndex RROutput
i <- [Int -> ListIndex RROutput
forall a. Int -> ListIndex a
ListIndex ([RROutput] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RROutput]
os)..ListIndex RROutput
15] ]

randrTeardown :: DisplayName -> RRSetup -> IO ()
randrTeardown :: DisplayName -> RRSetup -> IO ()
randrTeardown DisplayName
d RRSetup
rr = do
  [(ListIndex RROutput, RROutput)]
-> ((ListIndex RROutput, RROutput) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([RROutput] -> [(ListIndex RROutput, RROutput)]
forall a. [a] -> [(ListIndex a, a)]
enumerate RRSetup
rr.outputs) (((ListIndex RROutput, RROutput) -> IO ()) -> IO ())
-> ((ListIndex RROutput, RROutput) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ListIndex RROutput
i, RROutput
o) -> case RROutput
o.mode of
    Just RRExistingMode
m -> IO ExitCode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ DisplayName -> [[Char]] -> IO ExitCode
runXrandrSilent DisplayName
d [[Char]
"--delmode", ListIndex RROutput -> [Char]
outputName ListIndex RROutput
i, RRExistingMode -> [Char]
modeName RRExistingMode
m]
    Maybe RRExistingMode
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  [RRMode] -> (RRMode -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ RRSetup
rr.newModes ((RRMode -> IO ()) -> IO ()) -> (RRMode -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \RRMode
m ->
    IO ExitCode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ DisplayName -> [[Char]] -> IO ExitCode
runXrandrSilent DisplayName
d [[Char]
"--rmmode", RRModeName -> [Char]
forall a b. Coercible a b => a -> b
coerce RRMode
m.name]

rrRotation :: RRRotation -> String
rrRotation :: RRRotation -> [Char]
rrRotation = \case
  RRRotation
Unrotated -> [Char]
"normal"
  RRRotation
RotateLeft -> [Char]
"left"
  RRRotation
Inverted -> [Char]
"inverted"
  RRRotation
RotateRight -> [Char]
"right"

rrPosition :: RRPosition -> String
rrPosition :: RRPosition -> [Char]
rrPosition = \case
  RRPosition
SameAs -> [Char]
"same-as"
  RRPosition
LeftOf -> [Char]
"left-of"
  RRPosition
RightOf -> [Char]
"right-of"
  RRPosition
Above -> [Char]
"above"
  RRPosition
Below -> [Char]
"below"

-- | Find the name of the nth RANDR output.
-- Obviously this only works with @xdummy@ config.
outputName :: ListIndex RROutput -> String
outputName :: ListIndex RROutput -> [Char]
outputName (ListIndex Int
i) = [Char]
"DUMMY" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i

-- | Find the name of a modeline preconfigured in @xdummy@.
modeName :: RRExistingMode -> String
modeName :: RRExistingMode -> [Char]
modeName = RRModeName -> [Char]
unRRModeName (RRModeName -> [Char])
-> (RRExistingMode -> RRModeName) -> RRExistingMode -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RRMode -> RRModeName
name (RRMode -> RRModeName)
-> (RRExistingMode -> RRMode) -> RRExistingMode -> RRModeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListIndex RRMode -> RRMode
existingModeName (ListIndex RRMode -> RRMode)
-> (RRExistingMode -> ListIndex RRMode) -> RRExistingMode -> RRMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RRExistingMode -> ListIndex RRMode
unRRExistingMode
  where
    existingModeName :: ListIndex RRMode -> RRMode
existingModeName ListIndex RRMode
i = [RRMode]
modeLines [RRMode] -> ListIndex RRMode -> RRMode
forall a. [a] -> ListIndex a -> a
`atIndex` ListIndex RRMode
i

-- | Invent a name for a new X modeline.
newModeName :: ListIndex RRModeLine -> RRModeName
newModeName :: ListIndex RRModeLine -> RRModeName
newModeName (ListIndex Int
i) = [Char] -> RRModeName
RRModeName ([Char]
"newmode" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)

------------------------------------------------------------------------

-- | Test the test util functions.
spec :: Spec
spec :: Spec
spec = Spec -> Spec
forall a. HasCallStack => SpecWith a -> SpecWith a
logSetup (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
  [Char] -> Spec -> Spec
forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"xvfb" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ (ActionWith DisplayName -> IO ()) -> SpecWith DisplayName -> Spec
forall a.
HasCallStack =>
(ActionWith a -> IO ()) -> SpecWith a -> Spec
aroundAll (ActionWith DisplayName -> IO ()
forall a. (DisplayName -> IO a) -> IO a
withXvfb (ActionWith DisplayName -> IO ())
-> (ActionWith DisplayName -> ActionWith DisplayName)
-> ActionWith DisplayName
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActionWith DisplayName -> ActionWith DisplayName
forall a. (DisplayName -> IO a) -> DisplayName -> IO a
withXTerm) (SpecWith DisplayName -> Spec) -> SpecWith DisplayName -> Spec
forall a b. (a -> b) -> a -> b
$ do
    [Char]
-> (DisplayName -> Property)
-> SpecWith (Arg (DisplayName -> Property))
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"xprop" ((DisplayName -> Property)
 -> SpecWith (Arg (DisplayName -> Property)))
-> (DisplayName -> Property)
-> SpecWith (Arg (DisplayName -> Property))
forall a b. (a -> b) -> a -> b
$ (XPropName -> XPropValue -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((XPropName -> XPropValue -> Property) -> Property)
-> (DisplayName -> XPropName -> XPropValue -> Property)
-> DisplayName
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => DisplayName -> XPropName -> XPropValue -> Property
DisplayName -> XPropName -> XPropValue -> Property
prop_xprop
  [Char] -> Spec -> Spec
forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"xdummy" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ (ActionWith DisplayName -> IO ()) -> SpecWith DisplayName -> Spec
forall a.
HasCallStack =>
(ActionWith a -> IO ()) -> SpecWith a -> Spec
aroundAll ActionWith DisplayName -> IO ()
forall a. (DisplayName -> IO a) -> IO a
withXdummy (SpecWith DisplayName -> Spec) -> SpecWith DisplayName -> Spec
forall a b. (a -> b) -> a -> b
$ do
    [Char]
-> (DisplayName -> Property)
-> SpecWith (Arg (DisplayName -> Property))
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"xprop" ((DisplayName -> Property)
 -> SpecWith (Arg (DisplayName -> Property)))
-> (DisplayName -> Property)
-> SpecWith (Arg (DisplayName -> Property))
forall a b. (a -> b) -> a -> b
$ (XPropName -> XPropValue -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((XPropName -> XPropValue -> Property) -> Property)
-> (DisplayName -> XPropName -> XPropValue -> Property)
-> DisplayName
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => DisplayName -> XPropName -> XPropValue -> Property
DisplayName -> XPropName -> XPropValue -> Property
prop_xprop
    [Char]
-> (DisplayName -> Property)
-> SpecWith (Arg (DisplayName -> Property))
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"xrandr" ((DisplayName -> Property)
 -> SpecWith (Arg (DisplayName -> Property)))
-> (DisplayName -> Property)
-> SpecWith (Arg (DisplayName -> Property))
forall a b. (a -> b) -> a -> b
$ (RRSetup -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((RRSetup -> Property) -> Property)
-> (DisplayName -> RRSetup -> Property) -> DisplayName -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => DisplayName -> RRSetup -> Property
DisplayName -> RRSetup -> Property
prop_xrandr

------------------------------------------------------------------------

prop_xprop :: HasCallStack => DisplayName -> XPropName -> XPropValue -> Property
prop_xprop :: HasCallStack => DisplayName -> XPropName -> XPropValue -> Property
prop_xprop DisplayName
d XPropName
name XPropValue
value = PropertyM IO Property -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO Property -> Property)
-> PropertyM IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  DisplayName -> XPropName -> XPropValue -> PropertyM IO ()
forall (m :: * -> *).
MonadIO m =>
DisplayName -> XPropName -> XPropValue -> m ()
xpropSet DisplayName
d XPropName
name XPropValue
value
  value' <- DisplayName -> XPropName -> PropertyM IO [XPropValue]
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
DisplayName -> XPropName -> m [XPropValue]
xpropGet DisplayName
d XPropName
name
  xpropRemove d name
  pure $ if value /= mempty
    then value' === [value]
    else value' === []

instance Arbitrary XPropName where
  arbitrary :: Gen XPropName
arbitrary = ((:) (Char -> [Char] -> [Char]) -> Gen Char -> Gen ([Char] -> [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Gen Char
forall a. HasCallStack => [a] -> Gen a
elements [Char]
propNameStartChars Gen ([Char] -> [Char]) -> Gen [Char] -> Gen [Char]
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Char -> Gen [Char]
forall a. Gen a -> Gen [a]
listOf Gen Char
arbitraryASCIIChar) Gen [Char] -> ([Char] -> Maybe XPropName) -> Gen XPropName
forall a b. Gen a -> (a -> Maybe b) -> Gen b
`suchThatMap` [Char] -> Maybe XPropName
xpropName
  shrink :: XPropName -> [XPropName]
shrink = (XPropName -> Maybe XPropName) -> [XPropName] -> [XPropName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Char] -> Maybe XPropName
xpropName ([Char] -> Maybe XPropName)
-> (XPropName -> [Char]) -> XPropName -> Maybe XPropName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPropName -> [Char]
unXPropName) ([XPropName] -> [XPropName])
-> (XPropName -> [XPropName]) -> XPropName -> [XPropName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPropName -> [XPropName]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

instance Arbitrary XPropValue where
  arbitrary :: Gen XPropValue
arbitrary = (PrintableString -> [Char]) -> Gen PrintableString -> Gen [Char]
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrintableString -> [Char]
getPrintableString Gen PrintableString
forall a. Arbitrary a => Gen a
arbitrary Gen [Char] -> ([Char] -> Maybe XPropValue) -> Gen XPropValue
forall a b. Gen a -> (a -> Maybe b) -> Gen b
`suchThatMap` [Char] -> Maybe XPropValue
xpropValue
  shrink :: XPropValue -> [XPropValue]
shrink = (XPropValue -> Maybe XPropValue) -> [XPropValue] -> [XPropValue]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Char] -> Maybe XPropValue
xpropValue ([Char] -> Maybe XPropValue)
-> (XPropValue -> [Char]) -> XPropValue -> Maybe XPropValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPropValue -> [Char]
unXPropValue) ([XPropValue] -> [XPropValue])
-> (XPropValue -> [XPropValue]) -> XPropValue -> [XPropValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPropValue -> [XPropValue]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

------------------------------------------------------------------------

prop_xrandr :: HasCallStack => DisplayName -> RRSetup -> Property
prop_xrandr :: HasCallStack => DisplayName -> RRSetup -> Property
prop_xrandr DisplayName
d RRSetup
rr = Property -> Property
decorate (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ PropertyM IO Property -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO Property -> Property)
-> PropertyM IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
    qrr <- IO [(Bool, (Int, Bool))] -> PropertyM IO [(Bool, (Int, Bool))]
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO [(Bool, (Int, Bool))] -> PropertyM IO [(Bool, (Int, Bool))])
-> IO [(Bool, (Int, Bool))] -> PropertyM IO [(Bool, (Int, Bool))]
forall a b. (a -> b) -> a -> b
$ DisplayName
-> RRSetup -> IO [(Bool, (Int, Bool))] -> IO [(Bool, (Int, Bool))]
forall a. DisplayName -> RRSetup -> IO a -> IO a
withRandrSetup DisplayName
d RRSetup
rr (DisplayName -> IO [(Bool, (Int, Bool))]
randrQuery DisplayName
d)
    let (rr', qrr') = reformat rr qrr
    pure $ qrr' === rr'
  where
    decorate :: Property -> Property
decorate =
      [Char] -> [[Char]] -> Property -> Property
forall prop.
Testable prop =>
[Char] -> [[Char]] -> prop -> Property
tabulate [Char]
"Outputs" [ListIndex RROutput -> [Char]
outputName ListIndex RROutput
i | (ListIndex RROutput
i, RROutput
o) <- [RROutput] -> [(ListIndex RROutput, RROutput)]
forall a. [a] -> [(ListIndex a, a)]
enumerate RRSetup
rr.outputs, Bool -> Bool
not RROutput
o.settings.disabled] (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (if (RROutput -> Bool) -> [RROutput] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((RRRotation -> RRRotation -> Bool
forall a. Eq a => a -> a -> Bool
/= RRRotation
Unrotated) (RRRotation -> Bool)
-> (RROutput -> RRRotation) -> RROutput -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RROutputSettings -> RRRotation
rotate (RROutputSettings -> RRRotation)
-> (RROutput -> RROutputSettings) -> RROutput -> RRRotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RROutput -> RROutputSettings
settings) RRSetup
rr.outputs then [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
label [Char]
"rotation" else Property -> Property
forall a. a -> a
id) (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (if (RROutput -> Bool) -> [RROutput] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe RRExistingMode -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe RRExistingMode -> Bool)
-> (RROutput -> Maybe RRExistingMode) -> RROutput -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RROutput -> Maybe RRExistingMode
mode) RRSetup
rr.outputs then [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
label [Char]
"using preferred mode" else Property -> Property
forall a. a -> a
id) (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Double -> Bool -> [Char] -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> [Char] -> prop -> Property
cover Double
50 ([RROutput] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length RRSetup
rr.outputs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) [Char]
"non-trivial"

    reformat :: RRSetup -> [(Bool, b)] -> ([(Int, Bool)], [b])
reformat RRSetup
rrs = [((Int, Bool), b)] -> ([(Int, Bool)], [b])
forall a b. [(a, b)] -> ([a], [b])
unzip
      ([((Int, Bool), b)] -> ([(Int, Bool)], [b]))
-> ([(Bool, b)] -> [((Int, Bool), b)])
-> [(Bool, b)]
-> ([(Int, Bool)], [b])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Bool, (Int, Bool)), (Bool, b)) -> ((Int, Bool), b))
-> [((Bool, (Int, Bool)), (Bool, b))] -> [((Int, Bool), b)]
forall a b. (a -> b) -> [a] -> [b]
map (((Bool, (Int, Bool)) -> (Int, Bool))
-> ((Bool, b) -> b)
-> ((Bool, (Int, Bool)), (Bool, b))
-> ((Int, Bool), b)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Bool, (Int, Bool)) -> (Int, Bool)
forall a b. (a, b) -> b
snd (Bool, b) -> b
forall a b. (a, b) -> b
snd)
      ([((Bool, (Int, Bool)), (Bool, b))] -> [((Int, Bool), b)])
-> ([(Bool, b)] -> [((Bool, (Int, Bool)), (Bool, b))])
-> [(Bool, b)]
-> [((Int, Bool), b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Bool, (Int, Bool)), (Bool, b)) -> Bool)
-> [((Bool, (Int, Bool)), (Bool, b))]
-> [((Bool, (Int, Bool)), (Bool, b))]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Bool -> Bool
not (Bool -> Bool)
-> (((Bool, (Int, Bool)), (Bool, b)) -> Bool)
-> ((Bool, (Int, Bool)), (Bool, b))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Bool -> Bool) -> (Bool, Bool) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> Bool -> Bool
(||) ((Bool, Bool) -> Bool)
-> (((Bool, (Int, Bool)), (Bool, b)) -> (Bool, Bool))
-> ((Bool, (Int, Bool)), (Bool, b))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, (Int, Bool)) -> Bool)
-> ((Bool, b) -> Bool)
-> ((Bool, (Int, Bool)), (Bool, b))
-> (Bool, Bool)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Bool, (Int, Bool)) -> Bool
forall a b. (a, b) -> a
fst (Bool, b) -> Bool
forall a b. (a, b) -> a
fst)
      ([((Bool, (Int, Bool)), (Bool, b))]
 -> [((Bool, (Int, Bool)), (Bool, b))])
-> ([(Bool, b)] -> [((Bool, (Int, Bool)), (Bool, b))])
-> [(Bool, b)]
-> [((Bool, (Int, Bool)), (Bool, b))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Bool, (Int, Bool))]
-> [(Bool, b)] -> [((Bool, (Int, Bool)), (Bool, b))]
forall a b. [a] -> [b] -> [(a, b)]
zip (RRSetup -> [(Bool, (Int, Bool))]
tuplify (Int -> RRSetup -> RRSetup
backfill Int
16 RRSetup
rrs))

    tuplify :: RRSetup -> [(Bool, (Int, Bool))]
tuplify RRSetup{[RRMode]
[RROutput]
Maybe (ListIndex RROutput)
outputs :: RRSetup -> [RROutput]
primary :: RRSetup -> Maybe (ListIndex RROutput)
newModes :: RRSetup -> [RRMode]
outputs :: [RROutput]
primary :: Maybe (ListIndex RROutput)
newModes :: [RRMode]
..} =
      [ (Bool -> Bool
not RROutput
o.settings.disabled, (Int
i, ListIndex RROutput -> Maybe (ListIndex RROutput)
forall a. a -> Maybe a
Just (Int -> ListIndex RROutput
forall a. Int -> ListIndex a
ListIndex Int
i) Maybe (ListIndex RROutput) -> Maybe (ListIndex RROutput) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (ListIndex RROutput)
primary))
      | (Int
i, RROutput
o) <- [Int] -> [RROutput] -> [(Int, RROutput)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [RROutput]
outputs ]

    backfill :: Int -> RRSetup -> RRSetup
backfill Int
n RRSetup
rrs = RRSetup
rrs { outputs = rr.outputs ++ extras }
      where extras :: [RROutput]
extras = Int -> RROutput -> [RROutput]
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [RROutput] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length RRSetup
rr.outputs)) RROutput
rrOutputOff

-- | Scans output of @xrandr --query@ and returns values relevant to
-- test assertions.
randrQuery :: DisplayName -> IO [(Bool, (Int, Bool))]
randrQuery :: DisplayName -> IO [(Bool, (Int, Bool))]
randrQuery DisplayName
d = ByteString -> [(Bool, (Int, Bool))]
parseXrandr (ByteString -> [(Bool, (Int, Bool))])
-> IO ByteString -> IO [(Bool, (Int, Bool))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProcessConfig () () () -> IO ByteString
forall (m :: * -> *) stdin stdoutIgnored stderr.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderr -> m ByteString
readProcessStdout_ (DisplayName -> [[Char]] -> ProcessConfig () () ()
xrandr DisplayName
d [[Char]
"--query"])
  where
    parseXrandr :: ByteString -> [(Bool, (Int, Bool))]
parseXrandr = (ByteString -> Maybe (Bool, (Int, Bool)))
-> [ByteString] -> [(Bool, (Int, Bool))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ByteString -> Maybe (Bool, (Int, Bool))
forall {a}. Read a => ByteString -> Maybe (Bool, (a, Bool))
parseOutput ([ByteString] -> [(Bool, (Int, Bool))])
-> (ByteString -> [ByteString])
-> ByteString
-> [(Bool, (Int, Bool))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BL.lines
    parseOutput :: ByteString -> Maybe (Bool, (a, Bool))
parseOutput ByteString
line = do
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString
"DUMMY" ByteString -> ByteString -> Bool
`BL.isPrefixOf` ByteString
line)
      let line' :: [Char]
line' = ByteString -> [Char]
BL.unpack (Int64 -> ByteString -> ByteString
BL.drop Int64
5 ByteString
line)
      (w, ws) <- [[Char]] -> Maybe ([Char], [[Char]])
forall a. [a] -> Maybe (a, [a])
uncons ([Char] -> [[Char]]
words [Char]
line')
      let e = [Char]
"connected" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
ws
      n <- readMaybe w
      let p = [Char]
"primary" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
ws
      return (e, (n, p))

instance Arbitrary RRSetup where
  arbitrary :: Gen RRSetup
arbitrary = do
    nOutputs <- (Int, Int) -> Gen Int
chooseInt (Int
1, Int
5)

    nNewModes <- chooseInt (1, nOutputs)
    newModeLines <- vectorOf nNewModes (elements (map modeLine modeLines))

    let newModes = [ RRModeName -> RRModeLine -> RRMode
RRMode (ListIndex RRModeLine -> RRModeName
newModeName ListIndex RRModeLine
i) RRModeLine
m | (ListIndex RRModeLine
i, RRModeLine
m) <- [RRModeLine] -> [(ListIndex RRModeLine, RRModeLine)]
forall a. [a] -> [(ListIndex a, a)]
enumerate [RRModeLine]
newModeLines ]

    -- TODO: also use new modes for outputs
    -- mode <- chooseListIndex newModes

    outputs <- vector nOutputs
    primary <- frequency [ (5, Just <$> chooseListIndex outputs)
                         , (1, pure Nothing) ]
    pure $ RRSetup{..}

  shrink :: RRSetup -> [RRSetup]
shrink RRSetup
rr = do
    (primary, outputs) <- [(Maybe (ListIndex RROutput), [RROutput])]
shrinkOutputs
    guard $ not $ null outputs
    pure $ RRSetup {newModes = [], ..}

    where
      shrinkOutputs :: [(Maybe (ListIndex RROutput), [RROutput])]
shrinkOutputs = case RRSetup
rr.primary of
        Just ListIndex RROutput
p -> (RROutput -> [RROutput])
-> (ListIndex RROutput, [RROutput])
-> [(Maybe (ListIndex RROutput), [RROutput])]
forall a.
(a -> [a]) -> (ListIndex a, [a]) -> [(Maybe (ListIndex a), [a])]
shrinkListIx RROutput -> [RROutput]
forall a. Arbitrary a => a -> [a]
shrink (ListIndex RROutput
p, RRSetup
rr.outputs)
        Maybe (ListIndex RROutput)
Nothing -> ([RROutput] -> (Maybe (ListIndex RROutput), [RROutput]))
-> [[RROutput]] -> [(Maybe (ListIndex RROutput), [RROutput])]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe (ListIndex RROutput)
forall a. Maybe a
Nothing,) ((RROutput -> [RROutput]) -> [RROutput] -> [[RROutput]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList RROutput -> [RROutput]
forall a. Arbitrary a => a -> [a]
shrink RRSetup
rr.outputs)

      -- fixme: shrink modes properly too, and adjust mode within outputs
      -- shrinkModes ms = do
      --   ms' <- shrinkListP shrink ms
      --   pure ms'

shrinkListIx :: (a -> [a]) -> (ListIndex a, [a]) -> [(Maybe (ListIndex a), [a])]
shrinkListIx :: forall a.
(a -> [a]) -> (ListIndex a, [a]) -> [(Maybe (ListIndex a), [a])]
shrinkListIx a -> [a]
shr (ListIndex a
ix, [a]
xs) = ([(ListIndex a, a)] -> (Maybe (ListIndex a), [a]))
-> [[(ListIndex a, a)]] -> [(Maybe (ListIndex a), [a])]
forall a b. (a -> b) -> [a] -> [b]
map [(ListIndex a, a)] -> (Maybe (ListIndex a), [a])
forall {b} {a}. [(ListIndex a, b)] -> (Maybe (ListIndex a), [b])
unwrap ([[(ListIndex a, a)]] -> [(Maybe (ListIndex a), [a])])
-> [[(ListIndex a, a)]] -> [(Maybe (ListIndex a), [a])]
forall a b. (a -> b) -> a -> b
$ ((ListIndex a, a) -> [(ListIndex a, a)])
-> [(ListIndex a, a)] -> [[(ListIndex a, a)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ((a -> [a]) -> (ListIndex a, a) -> [(ListIndex a, a)]
forall a b. (a -> [a]) -> (b, a) -> [(b, a)]
shrinkSecond a -> [a]
shr) ([a] -> [(ListIndex a, a)]
forall {b}. [b] -> [(ListIndex a, b)]
wrap [a]
xs)
  where
    wrap :: [b] -> [(ListIndex a, b)]
wrap = [ListIndex a] -> [b] -> [(ListIndex a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ListIndex a
0..]
    unwrap :: [(ListIndex a, b)] -> (Maybe (ListIndex a), [b])
unwrap [(ListIndex a, b)]
ixs = let ix' :: Maybe Int
ix' = ((ListIndex a, b) -> Bool) -> [(ListIndex a, b)] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex ((ListIndex a -> ListIndex a -> Bool
forall a. Eq a => a -> a -> Bool
== ListIndex a
ix) (ListIndex a -> Bool)
-> ((ListIndex a, b) -> ListIndex a) -> (ListIndex a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ListIndex a, b) -> ListIndex a
forall a b. (a, b) -> a
fst) [(ListIndex a, b)]
ixs
                 in ((Int -> ListIndex a) -> Maybe Int -> Maybe (ListIndex a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> ListIndex a
forall a. Int -> ListIndex a
ListIndex Maybe Int
ix', ((ListIndex a, b) -> b) -> [(ListIndex a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (ListIndex a, b) -> b
forall a b. (a, b) -> b
snd [(ListIndex a, b)]
ixs)

    shrinkSecond :: (a -> [a]) -> (b, a) -> [(b, a)]
    shrinkSecond :: forall a b. (a -> [a]) -> (b, a) -> [(b, a)]
shrinkSecond a -> [a]
f (b
b, a
a) = (a -> (b, a)) -> [a] -> [(b, a)]
forall a b. (a -> b) -> [a] -> [b]
map (b
b,) (a -> [a]
f a
a)

instance Arbitrary RROutput where
  -- Always set a mode because "--preferred" option seems dodgy
  arbitrary :: Gen RROutput
arbitrary = Maybe RRExistingMode -> RROutputSettings -> RRPosition -> RROutput
RROutput (Maybe RRExistingMode
 -> RROutputSettings -> RRPosition -> RROutput)
-> Gen (Maybe RRExistingMode)
-> Gen (RROutputSettings -> RRPosition -> RROutput)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RRExistingMode -> Maybe RRExistingMode)
-> Gen RRExistingMode -> Gen (Maybe RRExistingMode)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RRExistingMode -> Maybe RRExistingMode
forall a. a -> Maybe a
Just Gen RRExistingMode
forall a. Arbitrary a => Gen a
arbitrary Gen (RROutputSettings -> RRPosition -> RROutput)
-> Gen RROutputSettings -> Gen (RRPosition -> RROutput)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen RROutputSettings
forall a. Arbitrary a => Gen a
arbitrary Gen (RRPosition -> RROutput) -> Gen RRPosition -> Gen RROutput
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen RRPosition
forall a. Arbitrary a => Gen a
arbitrary
  shrink :: RROutput -> [RROutput]
shrink RROutput
o = [ Maybe RRExistingMode -> RROutputSettings -> RRPosition -> RROutput
RROutput Maybe RRExistingMode
m RROutputSettings
s RRPosition
p
             | (Maybe RRExistingMode
m, RROutputSettings
s, RRPosition
p) <- (Maybe RRExistingMode, RROutputSettings, RRPosition)
-> [(Maybe RRExistingMode, RROutputSettings, RRPosition)]
forall a. Arbitrary a => a -> [a]
shrink (RROutput
o.mode, RROutput
o.settings, RROutput
o.position)
             , Maybe RRExistingMode -> Bool
forall a. Maybe a -> Bool
isJust Maybe RRExistingMode
m
             ]

instance Arbitrary RROutputSettings where
  -- Rotation and reflection don't seem to work for xdummy
  arbitrary :: Gen RROutputSettings
arbitrary = Bool -> RRRotation -> RROutputSettings
RROutputSettings
    (Bool -> RRRotation -> RROutputSettings)
-> Gen Bool -> Gen (RRRotation -> RROutputSettings)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Gen Bool)] -> Gen Bool
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
5, Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False), (Int
1, Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)]
    Gen (RRRotation -> RROutputSettings)
-> Gen RRRotation -> Gen RROutputSettings
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RRRotation -> Gen RRRotation
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RRRotation
Unrotated
  shrink :: RROutputSettings -> [RROutputSettings]
shrink = RROutputSettings -> [RROutputSettings]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

instance Arbitrary RRExistingMode where
  arbitrary :: Gen RRExistingMode
arbitrary = ListIndex RRMode -> RRExistingMode
RRExistingMode (ListIndex RRMode -> RRExistingMode)
-> Gen (ListIndex RRMode) -> Gen RRExistingMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RRMode] -> Gen (ListIndex RRMode)
forall a. [a] -> Gen (ListIndex a)
chooseListIndex [RRMode]
modeLines
  shrink :: RRExistingMode -> [RRExistingMode]
shrink = (Positive Int -> RRExistingMode)
-> (RRExistingMode -> Positive Int)
-> RRExistingMode
-> [RRExistingMode]
forall a b. Arbitrary a => (a -> b) -> (b -> a) -> b -> [b]
shrinkMap (ListIndex RRMode -> RRExistingMode
RRExistingMode (ListIndex RRMode -> RRExistingMode)
-> (Positive Int -> ListIndex RRMode)
-> Positive Int
-> RRExistingMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ListIndex RRMode
forall a. Int -> ListIndex a
ListIndex (Int -> ListIndex RRMode)
-> (Positive Int -> Int) -> Positive Int -> ListIndex RRMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive Int -> Int
forall a. Positive a -> a
getPositive) (Int -> Positive Int
forall a. a -> Positive a
Positive (Int -> Positive Int)
-> (RRExistingMode -> Int) -> RRExistingMode -> Positive Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListIndex RRMode -> Int
forall a. ListIndex a -> Int
unListIndex (ListIndex RRMode -> Int)
-> (RRExistingMode -> ListIndex RRMode) -> RRExistingMode -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RRExistingMode -> ListIndex RRMode
unRRExistingMode)

instance Arbitrary RRPosition where
  arbitrary :: Gen RRPosition
arbitrary = [(Int, Gen RRPosition)] -> Gen RRPosition
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency ([(Int, Gen RRPosition)] -> Gen RRPosition)
-> [(Int, Gen RRPosition)] -> Gen RRPosition
forall a b. (a -> b) -> a -> b
$ ((Int, RRPosition) -> (Int, Gen RRPosition))
-> [(Int, RRPosition)] -> [(Int, Gen RRPosition)]
forall a b. (a -> b) -> [a] -> [b]
map ((RRPosition -> Gen RRPosition)
-> (Int, RRPosition) -> (Int, Gen RRPosition)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second RRPosition -> Gen RRPosition
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
    [ (Int
2, RRPosition
SameAs)
    , (Int
1, RRPosition
LeftOf)
    , (Int
4, RRPosition
RightOf)
    , (Int
1, RRPosition
Above)
    , (Int
2, RRPosition
Below)
    ]
  shrink :: RRPosition -> [RRPosition]
shrink = RRPosition -> [RRPosition]
forall a. (Bounded a, Enum a, Eq a) => a -> [a]
shrinkBoundedEnum

instance Arbitrary RRRotation where
  arbitrary :: Gen RRRotation
arbitrary = [(Int, Gen RRRotation)] -> Gen RRRotation
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency ([(Int, Gen RRRotation)] -> Gen RRRotation)
-> [(Int, Gen RRRotation)] -> Gen RRRotation
forall a b. (a -> b) -> a -> b
$ ((Int, RRRotation) -> (Int, Gen RRRotation))
-> [(Int, RRRotation)] -> [(Int, Gen RRRotation)]
forall a b. (a -> b) -> [a] -> [b]
map ((RRRotation -> Gen RRRotation)
-> (Int, RRRotation) -> (Int, Gen RRRotation)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second RRRotation -> Gen RRRotation
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
    [ (Int
4, RRRotation
Unrotated)
    , (Int
2, RRRotation
Inverted)
    , (Int
1, RRRotation
RotateLeft)
    , (Int
1, RRRotation
RotateRight)
    ]
  shrink :: RRRotation -> [RRRotation]
shrink = RRRotation -> [RRRotation]
forall a. (Bounded a, Enum a, Eq a) => a -> [a]
shrinkBoundedEnum