XRandR.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TupleSections #-}
{-
Parsing the output of the xrandr command. For example:

$> xrandr
Screen 0: minimum 8 x 8, current 1920 x 1080, maximum 32767 x 32767
eDP1 connected 1920x1080+0+0 (normal left inverted right x axis y axis) 309mm x 173mm
   1920x1080      60.0*+   59.9  
   1680x1050      60.0     59.9  
   1600x1024      60.2  
   1400x1050      60.0  
   1280x1024      60.0  
   1440x900       59.9  
   1280x960       60.0  
   1360x768       59.8     60.0  
   1152x864       60.0  
   1024x768       60.0  
   800x600        60.3     56.2  
   640x480        59.9  
DP1 disconnected (normal left inverted right x axis y axis)
HDMI1 disconnected (normal left inverted right x axis y axis)
HDMI2 disconnected (normal left inverted right x axis y axis)
VGA1 disconnected (normal left inverted right x axis y axis)
VIRTUAL1 disconnected (normal left inverted right x axis y axis)
 -}
module XMonad.Actions.XRandR
  (isConnected
  ,getXRandR
  ,getXRandR'
  ,parseXRandR
  ,runXRandR
  ,askAndSetDisplaysPositions
  ,askAndSetDisplaysPositions'
  ,setDisplaysPositions
  ,askResolutions
  ,askResolutions'
  ,askAndSetResolutions
  ,askAndSetResolutions'
  ,Pos(..)
  )
where

import           Control.Applicative                   ((<$>),(<|>),(<*>))
import           Control.Monad                         (void)
import           Control.Monad.Error                   (ErrorT(..)
                                                       ,Error
                                                       ,runErrorT)
import           Control.Monad.Trans                   (lift)
import           Control.Monad.Trans.Maybe             (MaybeT(..)
                                                       ,runMaybeT)
import           Control.Monad.IO.Class                (MonadIO,liftIO)
import qualified Data.List                     as List
import qualified Data.Map                      as Map
import           Data.Map                              (Map)
import           Data.Maybe                            (isJust,listToMaybe)
import qualified Data.Set                      as Set
import           Data.Set                              (Set)
import           Data.Traversable                      (forM)
import           Text.ParserCombinators.Parsec         (Parser
                                                       ,ParseError
                                                       ,GenParser
                                                       ,(<?>)
                                                       ,anyChar
                                                       ,char
                                                       ,digit
                                                       ,many1
                                                       ,manyTill
                                                       ,newline
                                                       ,parse
                                                       ,sepBy
                                                       ,skipMany
                                                       ,space
                                                       ,string
                                                       ,try
                                                       )
import           Text.ParserCombinators.Parsec.Char    (alphaNum)
import           Text.ParserCombinators.Parsec.Number  (decimal
                                                       ,int)
import           XMonad                                (X)
import           XMonad.Prompt                         (XPConfig(..)
                                                       ,mkComplFunFromList')
import           XMonad.Prompt.Input                   (inputPromptWithCompl)
import           XMonad.Util.Run                       (runProcessWithInput)


instance Error ParseError

-- width and height
type Resolution = (Int,Int)
type Offset = (Int,Int)

data XRDisplayData = XRDisplayData
                     { status      :: Maybe (Resolution,Offset) 
                     , resolutions :: [Resolution] -- | supported resolutions
                     }
  deriving Show

isConnected :: XRDisplayData -> Bool
isConnected = isJust . status

-- A display is composed by its id and its data
type Display  = (String,XRDisplayData)
type Displays = Map String XRDisplayData

showRes :: (Int,Int) -> String
showRes (w,h) = show w ++ 'x':show h

instance Show Display where
  show (did,ddata) = List.intercalate "\n" (headLine:tailLines)
    where
      conn = case status ddata of
               Nothing -> "disconnected"
               Just (r,o) -> "connected " ++ showRes r ++ showOff o
      showOff (w,h) = showSignum w ++ showSignum h
      showSignum x = if signum x >= 0 then '+':show x else show x
      headLine = did ++ ' ': conn
      tailLines = fmap (\(w,h) -> "   " ++ show w ++ 'x':show h)
                       (resolutions ddata)

instance Show Displays where
  show = List.intercalate "\n" . fmap show . Map.toList

-------------
-- PARSING --

getXRandR :: MonadIO m => ErrorT ParseError m Displays
getXRandR = liftIO runXRandR >>= ErrorT . return . parseXRandR

getXRandR' :: MonadIO m => m (Either ParseError Displays)
getXRandR' = runErrorT getXRandR

runXRandR :: MonadIO m => m String
runXRandR = runProcessWithInput "xrandr" [] ""

parseXRandR :: String -> Either ParseError Displays
parseXRandR = parse xrandrOut "(unknown)"

-- ignore the entire line
skipUntilNewLine :: Parser ()
skipUntilNewLine = manyTill anyChar newline >> return ()

xrandrOut :: Parser Displays
xrandrOut = skipMany screen >> (Map.fromList <$> many1 display)

screen :: Parser ()
screen = string "Screen" >> skipUntilNewLine

display :: Parser Display
display = do
  did <- many1 alphaNum <?> "display id"
  space
  status_ <- connectedStatus <|>
             (string "disconnected" >> return Nothing) <?>
             "(connected|disconnected)"
  skipUntilNewLine
  resolutions_ <- (resolutionPrefix >> resolutionLine `sepBy` resolutionPrefix) <|>
                  return []

  return (did,XRDisplayData status_ resolutions_)
  where
    resolutionPrefix = space >> space >> space
    resolutionLine = resolution >>= \r -> skipUntilNewLine >> return r
    resAndOffset = Just <$> ((,) <$> resolution <*> offset)
    connectedStatus = do
      string "connected"
      space
      (string "primary" >> space >> resAndOffset) <|> resAndOffset

resolution :: Parser Resolution
resolution = do
  width <- decimal
  char 'x'
  height <- decimal
  return (width,height)

offset :: Parser Offset
offset = (,) <$> int <*> int 

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


-------------
-- ACTIONS --

data Pos = LeftOf String | RightOf String
  deriving Show

posToCmd :: Pos -> [String]
posToCmd (LeftOf s) = ["--left-of",s]
posToCmd (RightOf s) = ["--right-of",s]

data ASDError = Parse ParseError | NoValidSetup

instance Show ASDError where
  show (Parse pe)   = show pe
  show NoValidSetup = "setup not valid"

askAndSetDisplaysPositions' :: XPConfig -> X (Either ASDError (String,Map String Pos))
askAndSetDisplaysPositions' conf = getXRandR' >>= \case
    Left error -> return $ Left (Parse error)
    Right res  -> do
      askAndSetDisplaysPositions conf (Map.keysSet $ Map.filter isConnected res) >>= \case
        Nothing -> return $ Left NoValidSetup
        Just setup -> return $ Right setup


askAndSetDisplaysPositions :: XPConfig -> Set String -> X (Maybe (String,Map String Pos))
askAndSetDisplaysPositions conf ds =
  runMaybeT (askDisplaysPositions conf ds) >>= \case
    Nothing    -> return Nothing
    Just setup -> uncurry setDisplaysPositions setup >> return (Just setup)

setDisplaysPositions :: (Functor m,MonadIO m) => String -> Map String Pos -> m ()
setDisplaysPositions primary others = void $ runProcessWithInput "xrandr" args ""
  where
    args = mkOut primary ++ "--primary":othersArgs
    othersArgs = concatMap (\(sc,pos) -> mkOut sc ++ posToCmd pos)
                           (Map.toList others )
    mkOut out = ["--output",out]

askDisplaysPositions :: XPConfig -> Set String -> MaybeT X (String,Map String Pos)
askDisplaysPositions conf ds
  | Set.size ds == 1 = return (List.head $ Set.toList ds,Map.empty)
  | otherwise = do
    -- ask for primary
    p <- askPrimary conf ds
    
    -- ask for others
    os <- forM (Set.toList $ Set.delete p ds) $ \d -> do
            let choices = mkPos p d ++ concatMap (mkPos d) (Set.toList $ Set.delete d ds)
            let compFun = mkComplFunFromList' choices
            dpos <- fmap ((d,) . toPos) <$> lift (inputPromptWithCompl conf d compFun)
            MaybeT $ return dpos
    
    return (p,Map.fromList os)
    where
      mkPos target other = ["left of " ++ other,"right of " ++ other]
      toPos p
        | "left of " `List.isPrefixOf` p = LeftOf (List.drop (length "left of ") p)
        | "right of " `List.isPrefixOf` p = RightOf (List.drop (length "right of ") p)

askPrimary :: XPConfig -> Set String -> MaybeT X String
askPrimary conf ds = lift (inputPromptWithCompl conf "Primary" compFun) >>= MaybeT . return
  where
    compFun = mkComplFunFromList' (Set.toList ds)

askResolutions :: XPConfig -> Displays -> MaybeT X (Map String Resolution)
askResolutions conf ds = Map.fromList <$> choices
  where
    choices = forM (Map.toList ds) $ \(s,screenData) -> do
                let ress = fmap showRes $ resolutions screenData
                let comp = mkComplFunFromList' ress
                maybeRawRes <- lift (inputPromptWithCompl conf s comp)
                maybeRes <- MaybeT . return $ fmap readRes maybeRawRes
                MaybeT . return $ fmap ((s,)) maybeRes
    readRes :: String -> Maybe Resolution
    readRes rn = case (\(f,s) -> (f,tail s)) (List.span (/= 'x') rn) of
                   (n1,n2) -> (,) <$> readsInt n1 <*> readsInt n2
                   otherwise -> Nothing
    readsInt :: String -> Maybe Int
    readsInt = fmap fst . listToMaybe . reads

askResolutions' :: XPConfig -> Displays -> X (Maybe (Map String Resolution))
askResolutions' conf ds = runMaybeT (askResolutions conf ds)

setResolutions :: (Functor m,MonadIO m) => Map String Resolution -> m ()
setResolutions ress = void $ runProcessWithInput "xrandr" args ""
  where
    args = concatMap mkArg $ Map.toList ress
    mkArg (dis,res) = ["--output",dis,"--mode",showRes res]

askAndSetResolutions :: XPConfig -> Displays -> X (Maybe (Map String Resolution))
askAndSetResolutions conf ds = runMaybeT (askResolutions conf ds) >>= \case
                                 Nothing -> return Nothing
                                 Just re -> setResolutions re >> return (Just re)

askAndSetResolutions' :: XPConfig -> X (Either ASDError (Map String Resolution))
askAndSetResolutions' conf = getXRandR' >>= \case
    Left error -> return $ Left (Parse error)
    Right res  ->
      askAndSetResolutions conf (Map.filter isConnected res) >>= \case
        Nothing -> return $ Left NoValidSetup
        Just setup -> return $ Right setup