XvfbSpec.hs

{-# 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 n = DisplayName (displaySpec n)

displaySpec :: Int -> String
displaySpec n = ":" ++ show n

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

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

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

newtype XPropName = XPropName { unXPropName :: String }
  deriving (Show, Read, Eq, Ord, 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 n@(c:cs)
  | c `elem` propNameStartChars &&
    all isPrint cs &&
    not (any propNameBadChars cs) = Just (XPropName n)
xpropName _ = Nothing

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

propNameBadChars :: Char -> Bool
propNameBadChars c = isSpace c || c `elem` ['(', ')', ':']

newtype XPropValue = XPropValue { unXPropValue :: String }
  deriving (Show, Read, Eq, Ord, Semigroup, Monoid, 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 n = if not (any propValueBadChars n) then Just (XPropValue n) else Nothing

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

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

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

xpropGet :: (HasCallStack, MonadIO m) => DisplayName -> XPropName -> m [XPropValue]
xpropGet d p = do
  specLog $ "xpropGet running: " ++ show cfg
  txt <- decoded $ readProcessStdout_ cfg
  specLogAt DEBUG $ "xprop output:\n" ++ TL.unpack txt
  either throwString pure $ parseXProp1 p txt
  where
    cfg = xpropProc d ["-root", unXPropName p]
    decoded :: MonadIO m => m BL.ByteString -> m TL.Text
    decoded = fromEitherM . fmap decodeUtf8'

parseXProp1 :: XPropName -> TL.Text -> Either String [XPropValue]
parseXProp1 p = maybe (Left ("property " ++ show p ++ " not found")) Right . lookup p <=< parseXProp

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

xpropSet :: MonadIO m => DisplayName -> XPropName -> XPropValue -> m ()
xpropSet d (XPropName p) (XPropValue v) = liftIO $ do
  specLog $ "xpropSet running: " ++ show cfg
  runProcess_ cfg
  where
    cfg = xpropProc d args
    args = ["-root", "-format", p, "8u", "-set", p, v]

xpropRemove :: MonadIO m => DisplayName -> XPropName -> m ()
xpropRemove d p = do
  specLog $ "xpropRemove running: " ++ show cfg
  runProcess_ cfg
  where
    cfg = xpropProc d ["-root", "-remove", unXPropName p]

xpropList :: MonadIO m => DisplayName -> m ()
xpropList d = liftIO $ do
  specLog $ "xpropList running: " ++ show cfg
  runProcess_ cfg
  where
    cfg = xpropProc d ["-root"]

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

withXTerm :: (DisplayName -> IO a) -> (DisplayName -> IO a)
withXTerm action dn = do
  cfg <- makeXterm <$> getSpecLogPriority
  specLog $ "withXTerm running: " ++ show cfg
  withProcessTerm cfg $ const $ do
    threadDelay 500_000 -- give xterm some time to start
    action dn
  where
    makeXterm v = proc "xterm" (displayArg dn) & setStderrCond v

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

consumeXDisplayFd :: Handle -> IO DisplayName
consumeXDisplayFd h = do
  l <- readMaybe <$> hGetLine 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 prog args display action = do
  cfg <- makeXvfb <$> getSpecLogPriority
  specLog $ "withXserver running: " ++ show cfg
  withService cfg $ \p -> do
    d <- consumeXDisplayFd (getStdout p)
    action d
  where
    args' = displayArgMaybe ++ ["-displayfd", "1", "-terminate", "60"] ++ args
    makeXvfb logLevel = proc prog args'
      & setServiceDefaults logLevel
      & setStdout createPipe

    displayArgMaybe = maybeToList (fmap displaySpec display)

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

withXdummy :: (DisplayName -> IO a) -> IO a
withXdummy = withXserver "xdummy" [] 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_ = withSetEnv . displayEnv

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

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

-- | Adds a guiding phantom type annotation for indices into lists.
-- fixme: zipper rather than indices
newtype ListIndex a = ListIndex { unListIndex :: Int }
  deriving (Show, Read, Eq, Ord, Enum, Num, Real, Integral, Generic)

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

bounds' :: Integral n => (n, n) -> (ListIndex a, ListIndex a)
bounds' = let f = ListIndex . fromIntegral in bimap f f

bounds :: [a] -> (ListIndex a, ListIndex a)
bounds xs = bounds' (0, length xs - 1)

atIndex :: [a] -> ListIndex a -> a
atIndex as (ListIndex i) = as !! i

chooseListIndexN :: Int -> Gen (ListIndex a)
chooseListIndexN n = ListIndex <$> chooseInt (0, n - 1)

chooseListIndex :: [a] -> Gen (ListIndex a)
chooseListIndex = chooseListIndexN . length

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

data RRSetup = RRSetup
  { outputs :: [RROutput]
  , primary :: Maybe (ListIndex RROutput)
  , newModes :: [RRMode] -- unused by outputs
  } deriving (Show, Read, Eq, Generic)

instance Default RRSetup where
  def = RRSetup { outputs = [def], primary = Just 0, newModes = [] }

data RROutput = RROutput
  { mode :: Maybe RRExistingMode
  , settings :: RROutputSettings
  , position :: RRPosition
  } deriving (Show, Read, Eq, Generic)

instance Default RROutput where
  def = RROutput { mode = def, settings = def, position = def }

rrOutputOff :: RROutput
rrOutputOff = def { settings = def { disabled = True } }

data RROutputSettings = RROutputSettings
  { disabled :: Bool
  , rotate :: RRRotation
  } deriving (Show, Read, Eq, Generic)

instance Default RROutputSettings where
  def = RROutputSettings { disabled = False, rotate = def }

-- | This is an index into 'modeLines'.
newtype RRExistingMode = RRExistingMode { unRRExistingMode :: ListIndex RRMode }
  deriving (Show, Read, Eq, Ord, Enum, Generic)

instance Bounded RRExistingMode where
  minBound = RRExistingMode 0
  maxBound = RRExistingMode (snd (bounds modeLines))

instance Default RRExistingMode where
  def = minBound

data RRMode = RRMode
  { name :: RRModeName
  , modeLine :: RRModeLine
  } deriving (Show, Read, Eq, Generic)

instance IsString RRMode where
  fromString = uncurry RRMode . bimap (RRModeName . unquote) RRModeLine . split
    where
      split = second (dropWhile isSpace) . break isSpace
      unquote = takeWhile (/= '"') . dropWhile (== '"')

newtype RRModeName = RRModeName { unRRModeName :: String }
  deriving (Show, Read, Eq, IsString, Generic)

newtype RRModeLine = RRModeLine { unRRModeLine :: String }
  deriving (Show, Read, Eq, IsString, Generic)

data RRPosition = SameAs | RightOf | LeftOf | Below | Above
  deriving (Show, Read, Eq, Bounded, Enum, Generic)

instance Default RRPosition where
  def = SameAs

data RRRotation = Unrotated | RotateLeft | Inverted | RotateRight
  deriving (Show, Read, Eq, Ord, Bounded, Enum, Generic)

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

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

runXrandr :: DisplayName -> [String] -> IO ()
runXrandr d args = do
  let cfg = xrandr d args
  specLog ("running: " ++ show cfg)
  -- NB. void . readProcess_ instead of runProcess_ so that stderr
  -- can be included in the ExitCodeException.
  void $ readProcess_ cfg

runXrandrSilent :: DisplayName -> [String] -> IO ExitCode
runXrandrSilent d args = do
  let cfg = xrandr d args & setStdout nullStream & setStderr nullStream
  specLog ("running: " ++ show cfg)
  runProcess cfg

withRandrSetup :: DisplayName -> RRSetup -> (IO a -> IO a)
withRandrSetup d rr = bracket_ (randrSetup d rr) (randrTeardown d rr)

randrSetup :: DisplayName -> RRSetup -> IO ()
randrSetup d rr = do
  -- TODO: is it possible to smush these into one xrandr command?
  forM_ rr.newModes $ \m ->
    runXrandr d $ ["--newmode", coerce m.name] ++ words (coerce m.modeLine)

  forM_ (enumerate rr.outputs) $ \(i, o) -> case o.mode of
    Just m -> runXrandr d ["--addmode", outputName i, modeName m]
    Nothing -> pure ()

  runXrandr d args

  where
    args = concat (globalArgs ++ givenArgs ++ switchOffOthers rr.outputs)
    globalArgs = [ ["--noprimary" | isNothing rr.primary ] ]

    givenArgs = zipWith outputArgs [0..] rr.outputs

    outputArgs :: ListIndex RROutput -> RROutput -> [String]
    outputArgs i output =
      [ "--output", outputName i
      , "--rotate", rrRotation output.settings.rotate
      ] ++
      maybe ["--preferred"] (\m -> ["--mode", modeName m]) output.mode ++
      ["--off" | output.settings.disabled ] ++
      ["--primary" | rr.primary == Just i] ++
      (if i > 0 then ["--" ++ rrPosition output.position, outputName (i - 1)] else [])

    switchOffOthers :: [RROutput] -> [[String]]
    switchOffOthers os = [ ["--output", outputName i, "--off"]
                         | i <- [ListIndex (length os)..15] ]

randrTeardown :: DisplayName -> RRSetup -> IO ()
randrTeardown d rr = do
  forM_ (enumerate rr.outputs) $ \(i, o) -> case o.mode of
    Just m -> void $ runXrandrSilent d ["--delmode", outputName i, modeName m]
    Nothing -> pure ()

  forM_ rr.newModes $ \m ->
    void $ runXrandrSilent d ["--rmmode", coerce m.name]

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

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

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

-- | Find the name of a modeline preconfigured in @xdummy@.
modeName :: RRExistingMode -> String
modeName = unRRModeName . name . existingModeName . unRRExistingMode
  where
    existingModeName i = modeLines `atIndex` i

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

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

-- | Test the test util functions.
spec :: Spec
spec = logSetup $ do
  describe "xvfb" $ aroundAll (withXvfb . withXTerm) $ do
    it "xprop" $ property . prop_xprop
  describe "xdummy" $ aroundAll withXdummy $ do
    it "xprop" $ property . prop_xprop
    it "xrandr" $ property . prop_xrandr

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

prop_xprop :: HasCallStack => DisplayName -> XPropName -> XPropValue -> Property
prop_xprop d name value = monadicIO $ do
  xpropSet d name value
  value' <- xpropGet d name
  xpropRemove d name
  pure $ if value /= mempty
    then value' === [value]
    else value' === []

instance Arbitrary XPropName where
  arbitrary = ((:) <$> elements propNameStartChars <*> listOf arbitraryASCIIChar) `suchThatMap` xpropName
  shrink = mapMaybe (xpropName . unXPropName) . genericShrink

instance Arbitrary XPropValue where
  arbitrary = fmap getPrintableString arbitrary `suchThatMap` xpropValue
  shrink = mapMaybe (xpropValue . unXPropValue) . genericShrink

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

prop_xrandr :: HasCallStack => DisplayName -> RRSetup -> Property
prop_xrandr d rr = decorate $ monadicIO $ do
    qrr <- run $ withRandrSetup d rr (randrQuery d)
    let (rr', qrr') = reformat rr qrr
    pure $ qrr' === rr'
  where
    decorate =
      tabulate "Outputs" [outputName i | (i, o) <- enumerate rr.outputs, not o.settings.disabled] .
      (if any ((/= Unrotated) . rotate . settings) rr.outputs then label "rotation" else id) .
      (if any (isNothing . mode) rr.outputs then label "using preferred mode" else id) .
      cover 50 (length rr.outputs > 1) "non-trivial"

    reformat rrs = unzip
      . map (bimap snd snd)
      . dropWhileEnd (not . uncurry (||) . bimap fst fst)
      . zip (tuplify (backfill 16 rrs))

    tuplify RRSetup{..} =
      [ (not o.settings.disabled, (i, Just (ListIndex i) == primary))
      | (i, o) <- zip [0..] outputs ]

    backfill n rrs = rrs { outputs = rr.outputs ++ extras }
      where extras = replicate (max 0 (n - length rr.outputs)) rrOutputOff

-- | Scans output of @xrandr --query@ and returns values relevant to
-- test assertions.
randrQuery :: DisplayName -> IO [(Bool, (Int, Bool))]
randrQuery d = parseXrandr <$> readProcessStdout_ (xrandr d ["--query"])
  where
    parseXrandr = mapMaybe parseOutput . BL.lines
    parseOutput line = do
      guard ("DUMMY" `BL.isPrefixOf` line)
      let line' = BL.unpack (BL.drop 5 line)
      (w, ws) <- uncons (words line')
      let e = "connected" `elem` ws
      n <- readMaybe w
      let p = "primary" `elem` ws
      return (e, (n, p))

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

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

    let newModes = [ RRMode (newModeName i) m | (i, m) <- enumerate 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 rr = do
    (primary, outputs) <- shrinkOutputs
    guard $ not $ null outputs
    pure $ RRSetup {newModes = [], ..}

    where
      shrinkOutputs = case rr.primary of
        Just p -> shrinkListIx shrink (p, rr.outputs)
        Nothing -> map (Nothing,) (shrinkList shrink 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 shr (ix, xs) = map unwrap $ shrinkList (shrinkSecond shr) (wrap xs)
  where
    wrap = zip [0..]
    unwrap ixs = let ix' = findIndex ((== ix) . fst) ixs
                 in (fmap ListIndex ix', map snd ixs)

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

instance Arbitrary RROutput where
  -- Always set a mode because "--preferred" option seems dodgy
  arbitrary = RROutput <$> fmap Just arbitrary <*> arbitrary <*> arbitrary
  shrink o = [ RROutput m s p
             | (m, s, p) <- shrink (o.mode, o.settings, o.position)
             , isJust m
             ]

instance Arbitrary RROutputSettings where
  -- Rotation and reflection don't seem to work for xdummy
  arbitrary = RROutputSettings
    <$> frequency [(5, pure False), (1, pure True)]
    <*> pure Unrotated
  shrink = genericShrink

instance Arbitrary RRExistingMode where
  arbitrary = RRExistingMode <$> chooseListIndex modeLines
  shrink = shrinkMap (RRExistingMode . ListIndex . getPositive) (Positive . unListIndex . unRRExistingMode)

instance Arbitrary RRPosition where
  arbitrary = frequency $ map (second pure)
    [ (2, SameAs)
    , (1, LeftOf)
    , (4, RightOf)
    , (1, Above)
    , (2, Below)
    ]
  shrink = shrinkBoundedEnum

instance Arbitrary RRRotation where
  arbitrary = frequency $ map (second pure)
    [ (4, Unrotated)
    , (2, Inverted)
    , (1, RotateLeft)
    , (1, RotateRight)
    ]
  shrink = shrinkBoundedEnum