{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving,
             MultiParamTypeClasses, TypeSynonymInstances, DeriveDataTypeable #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Core
-- Copyright   :  (c) Spencer Janssen 2007
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  spencerjanssen@gmail.com
-- Stability   :  unstable
-- Portability :  not portable, uses cunning newtype deriving
--
-- The 'X' monad, a state monad transformer over 'IO', for the window
-- manager state, and support routines.
--
-----------------------------------------------------------------------------

module XMonad.Core (
    X, WindowSet, WindowSpace, WorkspaceId,
    ScreenId(..), ScreenDetail(..), XState(..),
    XConf(..), XConfig(..), LayoutClass(..),
    Layout(..), readsLayout, Typeable, Message,
    SomeMessage(..), fromMessage, LayoutMessages(..),
    StateExtension(..), ExtensionClass(..),
    runX, catchX, userCode, userCodeDef, io, catchIO, installSignalHandlers, uninstallSignalHandlers,
    withDisplay, withWindowSet, isRoot, runOnWorkspaces,
    getAtom, spawn, spawnPID, xfork, recompile, trace, whenJust, whenX,
    getXMonadDir, getXMonadCacheDir, getXMonadDataDir, stateFileName,
    atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, atom_WM_TAKE_FOCUS, withWindowAttributes,
    ManageHook, Query(..), runQuery
  ) where

import XMonad.StackSet hiding (modify)

import Prelude
import Control.Exception.Extensible (fromException, try, bracket, throw, finally, SomeException(..))
import qualified Control.Exception.Extensible as E
import Control.Applicative(Applicative, pure, (<$>), (<*>))
import Control.Monad.Fail
import Control.Monad.State
import Control.Monad.Reader
import Data.Semigroup
import Data.Default
import System.FilePath
import System.IO
import System.Info
import System.Posix.Env (getEnv)
import System.Posix.Process (executeFile, forkProcess, getAnyProcessStatus, createSession)
import System.Posix.Signals
import System.Posix.IO
import System.Posix.Types (ProcessID)
import System.Process
import System.Directory
import System.Exit
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras (getWindowAttributes, WindowAttributes, Event)
import Data.Typeable
import Data.List ((\\))
import Data.Maybe (isJust,fromMaybe)
import Data.Monoid hiding ((<>))
import System.Environment (lookupEnv)

import qualified Data.Map as M
import qualified Data.Set as S

-- | XState, the (mutable) window manager state.
data XState = XState
    { XState -> WindowSet
windowset        :: !WindowSet                     -- ^ workspace list
    , XState -> Set Window
mapped           :: !(S.Set Window)                -- ^ the Set of mapped windows
    , XState -> Map Window Int
waitingUnmap     :: !(M.Map Window Int)            -- ^ the number of expected UnmapEvents
    , XState -> Maybe (Position -> Position -> X (), X ())
dragging         :: !(Maybe (Position -> Position -> X (), X ()))
    , XState -> KeyMask
numberlockMask   :: !KeyMask                       -- ^ The numlock modifier
    , XState -> Map String (Either String StateExtension)
extensibleState  :: !(M.Map String (Either String StateExtension))
    -- ^ stores custom state information.
    --
    -- The module "XMonad.Util.ExtensibleState" in xmonad-contrib
    -- provides additional information and a simple interface for using this.
    }

-- | XConf, the (read-only) window manager configuration.
data XConf = XConf
    { XConf -> Display
display       :: Display        -- ^ the X11 display
    , XConf -> XConfig Layout
config        :: !(XConfig Layout)       -- ^ initial user configuration
    , XConf -> Window
theRoot       :: !Window        -- ^ the root window
    , XConf -> Window
normalBorder  :: !Pixel         -- ^ border color of unfocused windows
    , XConf -> Window
focusedBorder :: !Pixel         -- ^ border color of the focused window
    , XConf -> Map (KeyMask, Window) (X ())
keyActions    :: !(M.Map (KeyMask, KeySym) (X ()))
                                      -- ^ a mapping of key presses to actions
    , XConf -> Map (KeyMask, Window) (Window -> X ())
buttonActions :: !(M.Map (KeyMask, Button) (Window -> X ()))
                                      -- ^ a mapping of button presses to actions
    , XConf -> Bool
mouseFocused :: !Bool           -- ^ was refocus caused by mouse action?
    , XConf -> Maybe (Position, Position)
mousePosition :: !(Maybe (Position, Position))
                                      -- ^ position of the mouse according to
                                      -- the event currently being processed
    , XConf -> Maybe Event
currentEvent :: !(Maybe Event)
                                      -- ^ event currently being processed
    }

-- todo, better name
data XConfig l = XConfig
    { XConfig l -> String
normalBorderColor  :: !String              -- ^ Non focused windows border color. Default: \"#dddddd\"
    , XConfig l -> String
focusedBorderColor :: !String              -- ^ Focused windows border color. Default: \"#ff0000\"
    , XConfig l -> String
terminal           :: !String              -- ^ The preferred terminal application. Default: \"xterm\"
    , XConfig l -> l Window
layoutHook         :: !(l Window)          -- ^ The available layouts
    , XConfig l -> ManageHook
manageHook         :: !ManageHook          -- ^ The action to run when a new window is opened
    , XConfig l -> Event -> X All
handleEventHook    :: !(Event -> X All)    -- ^ Handle an X event, returns (All True) if the default handler
                                                 -- should also be run afterwards. mappend should be used for combining
                                                 -- event hooks in most cases.
    , XConfig l -> [String]
workspaces         :: ![String]            -- ^ The list of workspaces' names
    , XConfig l -> KeyMask
modMask            :: !KeyMask             -- ^ the mod modifier
    , XConfig l -> XConfig Layout -> Map (KeyMask, Window) (X ())
keys               :: !(XConfig Layout -> M.Map (ButtonMask,KeySym) (X ()))
                                                 -- ^ The key binding: a map from key presses and actions
    , XConfig l
-> XConfig Layout -> Map (KeyMask, Window) (Window -> X ())
mouseBindings      :: !(XConfig Layout -> M.Map (ButtonMask, Button) (Window -> X ()))
                                                 -- ^ The mouse bindings
    , XConfig l -> Window
borderWidth        :: !Dimension           -- ^ The border width
    , XConfig l -> X ()
logHook            :: !(X ())              -- ^ The action to perform when the windows set is changed
    , XConfig l -> X ()
startupHook        :: !(X ())              -- ^ The action to perform on startup
    , XConfig l -> Bool
focusFollowsMouse  :: !Bool                -- ^ Whether window entry events can change focus
    , XConfig l -> Bool
clickJustFocuses   :: !Bool                -- ^ False to make a click which changes focus to be additionally passed to the window
    , XConfig l -> Window
clientMask         :: !EventMask           -- ^ The client events that xmonad is interested in
    , XConfig l -> Window
rootMask           :: !EventMask           -- ^ The root events that xmonad is interested in
    , XConfig l -> [String] -> XConfig Layout -> IO (XConfig Layout)
handleExtraArgs    :: !([String] -> XConfig Layout -> IO (XConfig Layout))
                                                 -- ^ Modify the configuration, complain about extra arguments etc. with arguments that are not handled by default
    }


type WindowSet   = StackSet  WorkspaceId (Layout Window) Window ScreenId ScreenDetail
type WindowSpace = Workspace WorkspaceId (Layout Window) Window

-- | Virtual workspace indices
type WorkspaceId = String

-- | Physical screen indices
newtype ScreenId    = S Int deriving (ScreenId -> ScreenId -> Bool
(ScreenId -> ScreenId -> Bool)
-> (ScreenId -> ScreenId -> Bool) -> Eq ScreenId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScreenId -> ScreenId -> Bool
$c/= :: ScreenId -> ScreenId -> Bool
== :: ScreenId -> ScreenId -> Bool
$c== :: ScreenId -> ScreenId -> Bool
Eq,Eq ScreenId
Eq ScreenId =>
(ScreenId -> ScreenId -> Ordering)
-> (ScreenId -> ScreenId -> Bool)
-> (ScreenId -> ScreenId -> Bool)
-> (ScreenId -> ScreenId -> Bool)
-> (ScreenId -> ScreenId -> Bool)
-> (ScreenId -> ScreenId -> ScreenId)
-> (ScreenId -> ScreenId -> ScreenId)
-> Ord ScreenId
ScreenId -> ScreenId -> Bool
ScreenId -> ScreenId -> Ordering
ScreenId -> ScreenId -> ScreenId
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
min :: ScreenId -> ScreenId -> ScreenId
$cmin :: ScreenId -> ScreenId -> ScreenId
max :: ScreenId -> ScreenId -> ScreenId
$cmax :: ScreenId -> ScreenId -> ScreenId
>= :: ScreenId -> ScreenId -> Bool
$c>= :: ScreenId -> ScreenId -> Bool
> :: ScreenId -> ScreenId -> Bool
$c> :: ScreenId -> ScreenId -> Bool
<= :: ScreenId -> ScreenId -> Bool
$c<= :: ScreenId -> ScreenId -> Bool
< :: ScreenId -> ScreenId -> Bool
$c< :: ScreenId -> ScreenId -> Bool
compare :: ScreenId -> ScreenId -> Ordering
$ccompare :: ScreenId -> ScreenId -> Ordering
$cp1Ord :: Eq ScreenId
Ord,Int -> ScreenId -> ShowS
[ScreenId] -> ShowS
ScreenId -> String
(Int -> ScreenId -> ShowS)
-> (ScreenId -> String) -> ([ScreenId] -> ShowS) -> Show ScreenId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScreenId] -> ShowS
$cshowList :: [ScreenId] -> ShowS
show :: ScreenId -> String
$cshow :: ScreenId -> String
showsPrec :: Int -> ScreenId -> ShowS
$cshowsPrec :: Int -> ScreenId -> ShowS
Show,ReadPrec [ScreenId]
ReadPrec ScreenId
Int -> ReadS ScreenId
ReadS [ScreenId]
(Int -> ReadS ScreenId)
-> ReadS [ScreenId]
-> ReadPrec ScreenId
-> ReadPrec [ScreenId]
-> Read ScreenId
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ScreenId]
$creadListPrec :: ReadPrec [ScreenId]
readPrec :: ReadPrec ScreenId
$creadPrec :: ReadPrec ScreenId
readList :: ReadS [ScreenId]
$creadList :: ReadS [ScreenId]
readsPrec :: Int -> ReadS ScreenId
$creadsPrec :: Int -> ReadS ScreenId
Read,Int -> ScreenId
ScreenId -> Int
ScreenId -> [ScreenId]
ScreenId -> ScreenId
ScreenId -> ScreenId -> [ScreenId]
ScreenId -> ScreenId -> ScreenId -> [ScreenId]
(ScreenId -> ScreenId)
-> (ScreenId -> ScreenId)
-> (Int -> ScreenId)
-> (ScreenId -> Int)
-> (ScreenId -> [ScreenId])
-> (ScreenId -> ScreenId -> [ScreenId])
-> (ScreenId -> ScreenId -> [ScreenId])
-> (ScreenId -> ScreenId -> ScreenId -> [ScreenId])
-> Enum ScreenId
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ScreenId -> ScreenId -> ScreenId -> [ScreenId]
$cenumFromThenTo :: ScreenId -> ScreenId -> ScreenId -> [ScreenId]
enumFromTo :: ScreenId -> ScreenId -> [ScreenId]
$cenumFromTo :: ScreenId -> ScreenId -> [ScreenId]
enumFromThen :: ScreenId -> ScreenId -> [ScreenId]
$cenumFromThen :: ScreenId -> ScreenId -> [ScreenId]
enumFrom :: ScreenId -> [ScreenId]
$cenumFrom :: ScreenId -> [ScreenId]
fromEnum :: ScreenId -> Int
$cfromEnum :: ScreenId -> Int
toEnum :: Int -> ScreenId
$ctoEnum :: Int -> ScreenId
pred :: ScreenId -> ScreenId
$cpred :: ScreenId -> ScreenId
succ :: ScreenId -> ScreenId
$csucc :: ScreenId -> ScreenId
Enum,Integer -> ScreenId
ScreenId -> ScreenId
ScreenId -> ScreenId -> ScreenId
(ScreenId -> ScreenId -> ScreenId)
-> (ScreenId -> ScreenId -> ScreenId)
-> (ScreenId -> ScreenId -> ScreenId)
-> (ScreenId -> ScreenId)
-> (ScreenId -> ScreenId)
-> (ScreenId -> ScreenId)
-> (Integer -> ScreenId)
-> Num ScreenId
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> ScreenId
$cfromInteger :: Integer -> ScreenId
signum :: ScreenId -> ScreenId
$csignum :: ScreenId -> ScreenId
abs :: ScreenId -> ScreenId
$cabs :: ScreenId -> ScreenId
negate :: ScreenId -> ScreenId
$cnegate :: ScreenId -> ScreenId
* :: ScreenId -> ScreenId -> ScreenId
$c* :: ScreenId -> ScreenId -> ScreenId
- :: ScreenId -> ScreenId -> ScreenId
$c- :: ScreenId -> ScreenId -> ScreenId
+ :: ScreenId -> ScreenId -> ScreenId
$c+ :: ScreenId -> ScreenId -> ScreenId
Num,Enum ScreenId
Real ScreenId
(Real ScreenId, Enum ScreenId) =>
(ScreenId -> ScreenId -> ScreenId)
-> (ScreenId -> ScreenId -> ScreenId)
-> (ScreenId -> ScreenId -> ScreenId)
-> (ScreenId -> ScreenId -> ScreenId)
-> (ScreenId -> ScreenId -> (ScreenId, ScreenId))
-> (ScreenId -> ScreenId -> (ScreenId, ScreenId))
-> (ScreenId -> Integer)
-> Integral ScreenId
ScreenId -> Integer
ScreenId -> ScreenId -> (ScreenId, ScreenId)
ScreenId -> ScreenId -> ScreenId
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
toInteger :: ScreenId -> Integer
$ctoInteger :: ScreenId -> Integer
divMod :: ScreenId -> ScreenId -> (ScreenId, ScreenId)
$cdivMod :: ScreenId -> ScreenId -> (ScreenId, ScreenId)
quotRem :: ScreenId -> ScreenId -> (ScreenId, ScreenId)
$cquotRem :: ScreenId -> ScreenId -> (ScreenId, ScreenId)
mod :: ScreenId -> ScreenId -> ScreenId
$cmod :: ScreenId -> ScreenId -> ScreenId
div :: ScreenId -> ScreenId -> ScreenId
$cdiv :: ScreenId -> ScreenId -> ScreenId
rem :: ScreenId -> ScreenId -> ScreenId
$crem :: ScreenId -> ScreenId -> ScreenId
quot :: ScreenId -> ScreenId -> ScreenId
$cquot :: ScreenId -> ScreenId -> ScreenId
$cp2Integral :: Enum ScreenId
$cp1Integral :: Real ScreenId
Integral,Num ScreenId
Ord ScreenId
(Num ScreenId, Ord ScreenId) =>
(ScreenId -> Rational) -> Real ScreenId
ScreenId -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
toRational :: ScreenId -> Rational
$ctoRational :: ScreenId -> Rational
$cp2Real :: Ord ScreenId
$cp1Real :: Num ScreenId
Real)

-- | The 'Rectangle' with screen dimensions
data ScreenDetail   = SD { ScreenDetail -> Rectangle
screenRect :: !Rectangle } deriving (ScreenDetail -> ScreenDetail -> Bool
(ScreenDetail -> ScreenDetail -> Bool)
-> (ScreenDetail -> ScreenDetail -> Bool) -> Eq ScreenDetail
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScreenDetail -> ScreenDetail -> Bool
$c/= :: ScreenDetail -> ScreenDetail -> Bool
== :: ScreenDetail -> ScreenDetail -> Bool
$c== :: ScreenDetail -> ScreenDetail -> Bool
Eq,Int -> ScreenDetail -> ShowS
[ScreenDetail] -> ShowS
ScreenDetail -> String
(Int -> ScreenDetail -> ShowS)
-> (ScreenDetail -> String)
-> ([ScreenDetail] -> ShowS)
-> Show ScreenDetail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScreenDetail] -> ShowS
$cshowList :: [ScreenDetail] -> ShowS
show :: ScreenDetail -> String
$cshow :: ScreenDetail -> String
showsPrec :: Int -> ScreenDetail -> ShowS
$cshowsPrec :: Int -> ScreenDetail -> ShowS
Show, ReadPrec [ScreenDetail]
ReadPrec ScreenDetail
Int -> ReadS ScreenDetail
ReadS [ScreenDetail]
(Int -> ReadS ScreenDetail)
-> ReadS [ScreenDetail]
-> ReadPrec ScreenDetail
-> ReadPrec [ScreenDetail]
-> Read ScreenDetail
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ScreenDetail]
$creadListPrec :: ReadPrec [ScreenDetail]
readPrec :: ReadPrec ScreenDetail
$creadPrec :: ReadPrec ScreenDetail
readList :: ReadS [ScreenDetail]
$creadList :: ReadS [ScreenDetail]
readsPrec :: Int -> ReadS ScreenDetail
$creadsPrec :: Int -> ReadS ScreenDetail
Read)

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

-- | The X monad, 'ReaderT' and 'StateT' transformers over 'IO'
-- encapsulating the window manager configuration and state,
-- respectively.
--
-- Dynamic components may be retrieved with 'get', static components
-- with 'ask'. With newtype deriving we get readers and state monads
-- instantiated on 'XConf' and 'XState' automatically.
--
newtype X a = X (ReaderT XConf (StateT XState IO) a)
    deriving (a -> X b -> X a
(a -> b) -> X a -> X b
(forall a b. (a -> b) -> X a -> X b)
-> (forall a b. a -> X b -> X a) -> Functor X
forall a b. a -> X b -> X a
forall a b. (a -> b) -> X a -> X b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> X b -> X a
$c<$ :: forall a b. a -> X b -> X a
fmap :: (a -> b) -> X a -> X b
$cfmap :: forall a b. (a -> b) -> X a -> X b
Functor, Applicative X
a -> X a
Applicative X =>
(forall a b. X a -> (a -> X b) -> X b)
-> (forall a b. X a -> X b -> X b)
-> (forall a. a -> X a)
-> Monad X
X a -> (a -> X b) -> X b
X a -> X b -> X b
forall a. a -> X a
forall a b. X a -> X b -> X b
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> X a
$creturn :: forall a. a -> X a
>> :: X a -> X b -> X b
$c>> :: forall a b. X a -> X b -> X b
>>= :: X a -> (a -> X b) -> X b
$c>>= :: forall a b. X a -> (a -> X b) -> X b
$cp1Monad :: Applicative X
Monad, Monad X
Monad X => (forall a. String -> X a) -> MonadFail X
String -> X a
forall a. String -> X a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
fail :: String -> X a
$cfail :: forall a. String -> X a
$cp1MonadFail :: Monad X
MonadFail, Monad X
Monad X => (forall a. IO a -> X a) -> MonadIO X
IO a -> X a
forall a. IO a -> X a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> X a
$cliftIO :: forall a. IO a -> X a
$cp1MonadIO :: Monad X
MonadIO, MonadState XState, MonadReader XConf, Typeable)

instance Applicative X where
  pure :: a -> X a
pure = a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: X (a -> b) -> X a -> X b
(<*>) = X (a -> b) -> X a -> X b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Semigroup a => Semigroup (X a) where
    <> :: X a -> X a -> X a
(<>) = (a -> a -> a) -> X a -> X a -> X a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

instance (Monoid a) => Monoid (X a) where
    mempty :: X a
mempty  = a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Monoid a => a
mempty
    mappend :: X a -> X a -> X a
mappend = (a -> a -> a) -> X a -> X a -> X a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Monoid a => a -> a -> a
mappend

instance Default a => Default (X a) where
    def :: X a
def = a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Default a => a
def

type ManageHook = Query (Endo WindowSet)
newtype Query a = Query (ReaderT Window X a)
    deriving (a -> Query b -> Query a
(a -> b) -> Query a -> Query b
(forall a b. (a -> b) -> Query a -> Query b)
-> (forall a b. a -> Query b -> Query a) -> Functor Query
forall a b. a -> Query b -> Query a
forall a b. (a -> b) -> Query a -> Query b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Query b -> Query a
$c<$ :: forall a b. a -> Query b -> Query a
fmap :: (a -> b) -> Query a -> Query b
$cfmap :: forall a b. (a -> b) -> Query a -> Query b
Functor, Functor Query
a -> Query a
Functor Query =>
(forall a. a -> Query a)
-> (forall a b. Query (a -> b) -> Query a -> Query b)
-> (forall a b c. (a -> b -> c) -> Query a -> Query b -> Query c)
-> (forall a b. Query a -> Query b -> Query b)
-> (forall a b. Query a -> Query b -> Query a)
-> Applicative Query
Query a -> Query b -> Query b
Query a -> Query b -> Query a
Query (a -> b) -> Query a -> Query b
(a -> b -> c) -> Query a -> Query b -> Query c
forall a. a -> Query a
forall a b. Query a -> Query b -> Query a
forall a b. Query a -> Query b -> Query b
forall a b. Query (a -> b) -> Query a -> Query b
forall a b c. (a -> b -> c) -> Query a -> Query b -> Query c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Query a -> Query b -> Query a
$c<* :: forall a b. Query a -> Query b -> Query a
*> :: Query a -> Query b -> Query b
$c*> :: forall a b. Query a -> Query b -> Query b
liftA2 :: (a -> b -> c) -> Query a -> Query b -> Query c
$cliftA2 :: forall a b c. (a -> b -> c) -> Query a -> Query b -> Query c
<*> :: Query (a -> b) -> Query a -> Query b
$c<*> :: forall a b. Query (a -> b) -> Query a -> Query b
pure :: a -> Query a
$cpure :: forall a. a -> Query a
$cp1Applicative :: Functor Query
Applicative, Applicative Query
a -> Query a
Applicative Query =>
(forall a b. Query a -> (a -> Query b) -> Query b)
-> (forall a b. Query a -> Query b -> Query b)
-> (forall a. a -> Query a)
-> Monad Query
Query a -> (a -> Query b) -> Query b
Query a -> Query b -> Query b
forall a. a -> Query a
forall a b. Query a -> Query b -> Query b
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Query a
$creturn :: forall a. a -> Query a
>> :: Query a -> Query b -> Query b
$c>> :: forall a b. Query a -> Query b -> Query b
>>= :: Query a -> (a -> Query b) -> Query b
$c>>= :: forall a b. Query a -> (a -> Query b) -> Query b
$cp1Monad :: Applicative Query
Monad, MonadReader Window, Monad Query
Monad Query => (forall a. IO a -> Query a) -> MonadIO Query
IO a -> Query a
forall a. IO a -> Query a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> Query a
$cliftIO :: forall a. IO a -> Query a
$cp1MonadIO :: Monad Query
MonadIO)

runQuery :: Query a -> Window -> X a
runQuery :: Query a -> Window -> X a
runQuery (Query m :: ReaderT Window X a
m) w :: Window
w = ReaderT Window X a -> Window -> X a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Window X a
m Window
w

instance Semigroup a => Semigroup (Query a) where
    <> :: Query a -> Query a -> Query a
(<>) = (a -> a -> a) -> Query a -> Query a -> Query a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

instance Monoid a => Monoid (Query a) where
    mempty :: Query a
mempty  = a -> Query a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Monoid a => a
mempty
    mappend :: Query a -> Query a -> Query a
mappend = (a -> a -> a) -> Query a -> Query a -> Query a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Monoid a => a -> a -> a
mappend

instance Default a => Default (Query a) where
    def :: Query a
def = a -> Query a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Default a => a
def

-- | Run the 'X' monad, given a chunk of 'X' monad code, and an initial state
-- Return the result, and final state
runX :: XConf -> XState -> X a -> IO (a, XState)
runX :: XConf -> XState -> X a -> IO (a, XState)
runX c :: XConf
c st :: XState
st (X a :: ReaderT XConf (StateT XState IO) a
a) = StateT XState IO a -> XState -> IO (a, XState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ReaderT XConf (StateT XState IO) a -> XConf -> StateT XState IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT XConf (StateT XState IO) a
a XConf
c) XState
st

-- | Run in the 'X' monad, and in case of exception, and catch it and log it
-- to stderr, and run the error case.
catchX :: X a -> X a -> X a
catchX :: X a -> X a -> X a
catchX job :: X a
job errcase :: X a
errcase = do
    XState
st <- X XState
forall s (m :: * -> *). MonadState s m => m s
get
    XConf
c <- X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask
    (a :: a
a, s' :: XState
s') <- IO (a, XState) -> X (a, XState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (a, XState) -> X (a, XState))
-> IO (a, XState) -> X (a, XState)
forall a b. (a -> b) -> a -> b
$ XConf -> XState -> X a -> IO (a, XState)
forall a. XConf -> XState -> X a -> IO (a, XState)
runX XConf
c XState
st X a
job IO (a, XState)
-> (SomeException -> IO (a, XState)) -> IO (a, XState)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \e :: SomeException
e -> case SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                        Just x :: ExitCode
x -> SomeException -> IO (a, XState)
forall a e. Exception e => e -> a
throw SomeException
e IO (a, XState) -> ExitCode -> IO (a, XState)
forall a b. a -> b -> a
`const` (ExitCode
x ExitCode -> ExitCode -> ExitCode
forall a. a -> a -> a
`asTypeOf` ExitCode
ExitSuccess)
                        _ -> do Handle -> SomeException -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr SomeException
e; XConf -> XState -> X a -> IO (a, XState)
forall a. XConf -> XState -> X a -> IO (a, XState)
runX XConf
c XState
st X a
errcase
    XState -> X ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put XState
s'
    a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Execute the argument, catching all exceptions.  Either this function or
-- 'catchX' should be used at all callsites of user customized code.
userCode :: X a -> X (Maybe a)
userCode :: X a -> X (Maybe a)
userCode a :: X a
a = X (Maybe a) -> X (Maybe a) -> X (Maybe a)
forall a. X a -> X a -> X a
catchX (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> X a -> X (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` X a
a) (Maybe a -> X (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing)

-- | Same as userCode but with a default argument to return instead of using
-- Maybe, provided for convenience.
userCodeDef :: a -> X a -> X a
userCodeDef :: a -> X a -> X a
userCodeDef defValue :: a
defValue a :: X a
a = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
defValue (Maybe a -> a) -> X (Maybe a) -> X a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` X a -> X (Maybe a)
forall a. X a -> X (Maybe a)
userCode X a
a

-- ---------------------------------------------------------------------
-- Convenient wrappers to state

-- | Run a monad action with the current display settings
withDisplay :: (Display -> X a) -> X a
withDisplay :: (Display -> X a) -> X a
withDisplay   f :: Display -> X a
f = (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display X Display -> (Display -> X a) -> X a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Display -> X a
f

-- | Run a monadic action with the current stack set
withWindowSet :: (WindowSet -> X a) -> X a
withWindowSet :: (WindowSet -> X a) -> X a
withWindowSet f :: WindowSet -> X a
f = (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset X WindowSet -> (WindowSet -> X a) -> X a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WindowSet -> X a
f

-- | Safely access window attributes.
withWindowAttributes :: Display -> Window -> (WindowAttributes -> X ()) -> X ()
withWindowAttributes :: Display -> Window -> (WindowAttributes -> X ()) -> X ()
withWindowAttributes dpy :: Display
dpy win :: Window
win f :: WindowAttributes -> X ()
f = do
    Maybe WindowAttributes
wa <- X WindowAttributes -> X (Maybe WindowAttributes)
forall a. X a -> X (Maybe a)
userCode (IO WindowAttributes -> X WindowAttributes
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO WindowAttributes -> X WindowAttributes)
-> IO WindowAttributes -> X WindowAttributes
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO WindowAttributes
getWindowAttributes Display
dpy Window
win)
    X () -> X () -> X ()
forall a. X a -> X a -> X a
catchX (Maybe WindowAttributes -> (WindowAttributes -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe WindowAttributes
wa WindowAttributes -> X ()
f) (() -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | True if the given window is the root window
isRoot :: Window -> X Bool
isRoot :: Window -> X Bool
isRoot w :: Window
w = (Window
wWindow -> Window -> Bool
forall a. Eq a => a -> a -> Bool
==) (Window -> Bool) -> X Window -> X Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (XConf -> Window) -> X Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot

-- | Wrapper for the common case of atom internment
getAtom :: String -> X Atom
getAtom :: String -> X Window
getAtom str :: String
str = (Display -> X Window) -> X Window
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X Window) -> X Window)
-> (Display -> X Window) -> X Window
forall a b. (a -> b) -> a -> b
$ \dpy :: Display
dpy -> IO Window -> X Window
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Window -> X Window) -> IO Window -> X Window
forall a b. (a -> b) -> a -> b
$ Display -> String -> Bool -> IO Window
internAtom Display
dpy String
str Bool
False

-- | Common non-predefined atoms
atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, atom_WM_STATE, atom_WM_TAKE_FOCUS :: X Atom
atom_WM_PROTOCOLS :: X Window
atom_WM_PROTOCOLS       = String -> X Window
getAtom "WM_PROTOCOLS"
atom_WM_DELETE_WINDOW :: X Window
atom_WM_DELETE_WINDOW   = String -> X Window
getAtom "WM_DELETE_WINDOW"
atom_WM_STATE :: X Window
atom_WM_STATE           = String -> X Window
getAtom "WM_STATE"
atom_WM_TAKE_FOCUS :: X Window
atom_WM_TAKE_FOCUS      = String -> X Window
getAtom "WM_TAKE_FOCUS"

------------------------------------------------------------------------
-- LayoutClass handling. See particular instances in Operations.hs

-- | An existential type that can hold any object that is in 'Read'
--   and 'LayoutClass'.
data Layout a = forall l. (LayoutClass l a, Read (l a)) => Layout (l a)

-- | Using the 'Layout' as a witness, parse existentially wrapped windows
-- from a 'String'.
readsLayout :: Layout a -> String -> [(Layout a, String)]
readsLayout :: Layout a -> String -> [(Layout a, String)]
readsLayout (Layout l :: l a
l) s :: String
s = [(l a -> Layout a
forall a (l :: * -> *).
(LayoutClass l a, Read (l a)) =>
l a -> Layout a
Layout (l a -> l a -> l a
forall a. a -> a -> a
asTypeOf l a
x l a
l), String
rs) | (x :: l a
x, rs :: String
rs) <- ReadS (l a)
forall a. Read a => ReadS a
reads String
s]

-- | Every layout must be an instance of 'LayoutClass', which defines
-- the basic layout operations along with a sensible default for each.
--
-- Minimal complete definition:
--
-- * 'runLayout' || (('doLayout' || 'pureLayout') && 'emptyLayout'), and
--
-- * 'handleMessage' || 'pureMessage'
--
-- You should also strongly consider implementing 'description',
-- although it is not required.
--
-- Note that any code which /uses/ 'LayoutClass' methods should only
-- ever call 'runLayout', 'handleMessage', and 'description'!  In
-- other words, the only calls to 'doLayout', 'pureMessage', and other
-- such methods should be from the default implementations of
-- 'runLayout', 'handleMessage', and so on.  This ensures that the
-- proper methods will be used, regardless of the particular methods
-- that any 'LayoutClass' instance chooses to define.
class Show (layout a) => LayoutClass layout a where

    -- | By default, 'runLayout' calls 'doLayout' if there are any
    --   windows to be laid out, and 'emptyLayout' otherwise.  Most
    --   instances of 'LayoutClass' probably do not need to implement
    --   'runLayout'; it is only useful for layouts which wish to make
    --   use of more of the 'Workspace' information (for example,
    --   "XMonad.Layout.PerWorkspace").
    runLayout :: Workspace WorkspaceId (layout a) a
              -> Rectangle
              -> X ([(a, Rectangle)], Maybe (layout a))
    runLayout (Workspace _ l :: layout a
l ms :: Maybe (Stack a)
ms) r :: Rectangle
r = X ([(a, Rectangle)], Maybe (layout a))
-> (Stack a -> X ([(a, Rectangle)], Maybe (layout a)))
-> Maybe (Stack a)
-> X ([(a, Rectangle)], Maybe (layout a))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (layout a -> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
emptyLayout layout a
l Rectangle
r) (layout a
-> Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (layout a))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a
-> Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (layout a))
doLayout layout a
l Rectangle
r) Maybe (Stack a)
ms

    -- | Given a 'Rectangle' in which to place the windows, and a 'Stack'
    -- of windows, return a list of windows and their corresponding
    -- Rectangles.  If an element is not given a Rectangle by
    -- 'doLayout', then it is not shown on screen.  The order of
    -- windows in this list should be the desired stacking order.
    --
    -- Also possibly return a modified layout (by returning @Just
    -- newLayout@), if this layout needs to be modified (e.g. if it
    -- keeps track of some sort of state).  Return @Nothing@ if the
    -- layout does not need to be modified.
    --
    -- Layouts which do not need access to the 'X' monad ('IO', window
    -- manager state, or configuration) and do not keep track of their
    -- own state should implement 'pureLayout' instead of 'doLayout'.
    doLayout    :: layout a -> Rectangle -> Stack a
                -> X ([(a, Rectangle)], Maybe (layout a))
    doLayout l :: layout a
l r :: Rectangle
r s :: Stack a
s   = ([(a, Rectangle)], Maybe (layout a))
-> X ([(a, Rectangle)], Maybe (layout a))
forall (m :: * -> *) a. Monad m => a -> m a
return (layout a -> Rectangle -> Stack a -> [(a, Rectangle)]
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> Rectangle -> Stack a -> [(a, Rectangle)]
pureLayout layout a
l Rectangle
r Stack a
s, Maybe (layout a)
forall a. Maybe a
Nothing)

    -- | This is a pure version of 'doLayout', for cases where we
    -- don't need access to the 'X' monad to determine how to lay out
    -- the windows, and we don't need to modify the layout itself.
    pureLayout  :: layout a -> Rectangle -> Stack a -> [(a, Rectangle)]
    pureLayout _ r :: Rectangle
r s :: Stack a
s = [(Stack a -> a
forall a. Stack a -> a
focus Stack a
s, Rectangle
r)]

    -- | 'emptyLayout' is called when there are no windows.
    emptyLayout :: layout a -> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
    emptyLayout _ _ = ([(a, Rectangle)], Maybe (layout a))
-> X ([(a, Rectangle)], Maybe (layout a))
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Maybe (layout a)
forall a. Maybe a
Nothing)

    -- | 'handleMessage' performs message handling.  If
    -- 'handleMessage' returns @Nothing@, then the layout did not
    -- respond to the message and the screen is not refreshed.
    -- Otherwise, 'handleMessage' returns an updated layout and the
    -- screen is refreshed.
    --
    -- Layouts which do not need access to the 'X' monad to decide how
    -- to handle messages should implement 'pureMessage' instead of
    -- 'handleMessage' (this restricts the risk of error, and makes
    -- testing much easier).
    handleMessage :: layout a -> SomeMessage -> X (Maybe (layout a))
    handleMessage l :: layout a
l  = Maybe (layout a) -> X (Maybe (layout a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (layout a) -> X (Maybe (layout a)))
-> (SomeMessage -> Maybe (layout a))
-> SomeMessage
-> X (Maybe (layout a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. layout a -> SomeMessage -> Maybe (layout a)
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> Maybe (layout a)
pureMessage layout a
l

    -- | Respond to a message by (possibly) changing our layout, but
    -- taking no other action.  If the layout changes, the screen will
    -- be refreshed.
    pureMessage :: layout a -> SomeMessage -> Maybe (layout a)
    pureMessage _ _  = Maybe (layout a)
forall a. Maybe a
Nothing

    -- | This should be a human-readable string that is used when
    -- selecting layouts by name.  The default implementation is
    -- 'show', which is in some cases a poor default.
    description :: layout a -> String
    description      = layout a -> String
forall a. Show a => a -> String
show

instance LayoutClass Layout Window where
    runLayout :: Workspace String (Layout Window) Window
-> Rectangle -> X ([(Window, Rectangle)], Maybe (Layout Window))
runLayout (Workspace i :: String
i (Layout l :: l Window
l) ms :: Maybe (Stack Window)
ms) r :: Rectangle
r = (Maybe (l Window) -> Maybe (Layout Window))
-> ([(Window, Rectangle)], Maybe (l Window))
-> ([(Window, Rectangle)], Maybe (Layout Window))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((l Window -> Layout Window)
-> Maybe (l Window) -> Maybe (Layout Window)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap l Window -> Layout Window
forall a (l :: * -> *).
(LayoutClass l a, Read (l a)) =>
l a -> Layout a
Layout) (([(Window, Rectangle)], Maybe (l Window))
 -> ([(Window, Rectangle)], Maybe (Layout Window)))
-> X ([(Window, Rectangle)], Maybe (l Window))
-> X ([(Window, Rectangle)], Maybe (Layout Window))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Workspace String (l Window) Window
-> Rectangle -> X ([(Window, Rectangle)], Maybe (l Window))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout (String
-> l Window
-> Maybe (Stack Window)
-> Workspace String (l Window) Window
forall i l a. i -> l -> Maybe (Stack a) -> Workspace i l a
Workspace String
i l Window
l Maybe (Stack Window)
ms) Rectangle
r
    doLayout :: Layout Window
-> Rectangle
-> Stack Window
-> X ([(Window, Rectangle)], Maybe (Layout Window))
doLayout (Layout l :: l Window
l) r :: Rectangle
r s :: Stack Window
s  = (Maybe (l Window) -> Maybe (Layout Window))
-> ([(Window, Rectangle)], Maybe (l Window))
-> ([(Window, Rectangle)], Maybe (Layout Window))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((l Window -> Layout Window)
-> Maybe (l Window) -> Maybe (Layout Window)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap l Window -> Layout Window
forall a (l :: * -> *).
(LayoutClass l a, Read (l a)) =>
l a -> Layout a
Layout) (([(Window, Rectangle)], Maybe (l Window))
 -> ([(Window, Rectangle)], Maybe (Layout Window)))
-> X ([(Window, Rectangle)], Maybe (l Window))
-> X ([(Window, Rectangle)], Maybe (Layout Window))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` l Window
-> Rectangle
-> Stack Window
-> X ([(Window, Rectangle)], Maybe (l Window))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a
-> Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (layout a))
doLayout l Window
l Rectangle
r Stack Window
s
    emptyLayout :: Layout Window
-> Rectangle -> X ([(Window, Rectangle)], Maybe (Layout Window))
emptyLayout (Layout l :: l Window
l) r :: Rectangle
r = (Maybe (l Window) -> Maybe (Layout Window))
-> ([(Window, Rectangle)], Maybe (l Window))
-> ([(Window, Rectangle)], Maybe (Layout Window))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((l Window -> Layout Window)
-> Maybe (l Window) -> Maybe (Layout Window)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap l Window -> Layout Window
forall a (l :: * -> *).
(LayoutClass l a, Read (l a)) =>
l a -> Layout a
Layout) (([(Window, Rectangle)], Maybe (l Window))
 -> ([(Window, Rectangle)], Maybe (Layout Window)))
-> X ([(Window, Rectangle)], Maybe (l Window))
-> X ([(Window, Rectangle)], Maybe (Layout Window))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` l Window
-> Rectangle -> X ([(Window, Rectangle)], Maybe (l Window))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
emptyLayout l Window
l Rectangle
r
    handleMessage :: Layout Window -> SomeMessage -> X (Maybe (Layout Window))
handleMessage (Layout l :: l Window
l) = (Maybe (l Window) -> Maybe (Layout Window))
-> X (Maybe (l Window)) -> X (Maybe (Layout Window))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((l Window -> Layout Window)
-> Maybe (l Window) -> Maybe (Layout Window)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap l Window -> Layout Window
forall a (l :: * -> *).
(LayoutClass l a, Read (l a)) =>
l a -> Layout a
Layout) (X (Maybe (l Window)) -> X (Maybe (Layout Window)))
-> (SomeMessage -> X (Maybe (l Window)))
-> SomeMessage
-> X (Maybe (Layout Window))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l Window -> SomeMessage -> X (Maybe (l Window))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l Window
l
    description :: Layout Window -> String
description (Layout l :: l Window
l)   = l Window -> String
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> String
description l Window
l

instance Show (Layout a) where show :: Layout a -> String
show (Layout l :: l a
l) = l a -> String
forall a. Show a => a -> String
show l a
l

-- | Based on ideas in /An Extensible Dynamically-Typed Hierarchy of
-- Exceptions/, Simon Marlow, 2006. Use extensible messages to the
-- 'handleMessage' handler.
--
-- User-extensible messages must be a member of this class.
--
class Typeable a => Message a

-- |
-- A wrapped value of some type in the 'Message' class.
--
data SomeMessage = forall a. Message a => SomeMessage a

-- |
-- And now, unwrap a given, unknown 'Message' type, performing a (dynamic)
-- type check on the result.
--
fromMessage :: Message m => SomeMessage -> Maybe m
fromMessage :: SomeMessage -> Maybe m
fromMessage (SomeMessage m :: a
m) = a -> Maybe m
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
m

-- X Events are valid Messages.
instance Message Event

-- | 'LayoutMessages' are core messages that all layouts (especially stateful
-- layouts) should consider handling.
data LayoutMessages = Hide              -- ^ sent when a layout becomes non-visible
                    | ReleaseResources  -- ^ sent when xmonad is exiting or restarting
    deriving (Typeable, LayoutMessages -> LayoutMessages -> Bool
(LayoutMessages -> LayoutMessages -> Bool)
-> (LayoutMessages -> LayoutMessages -> Bool) -> Eq LayoutMessages
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LayoutMessages -> LayoutMessages -> Bool
$c/= :: LayoutMessages -> LayoutMessages -> Bool
== :: LayoutMessages -> LayoutMessages -> Bool
$c== :: LayoutMessages -> LayoutMessages -> Bool
Eq)

instance Message LayoutMessages

-- ---------------------------------------------------------------------
-- Extensible state
--

-- | Every module must make the data it wants to store
-- an instance of this class.
--
-- Minimal complete definition: initialValue
class Typeable a => ExtensionClass a where
    -- | Defines an initial value for the state extension
    initialValue :: a
    -- | Specifies whether the state extension should be
    -- persistent. Setting this method to 'PersistentExtension'
    -- will make the stored data survive restarts, but
    -- requires a to be an instance of Read and Show.
    --
    -- It defaults to 'StateExtension', i.e. no persistence.
    extensionType :: a -> StateExtension
    extensionType = a -> StateExtension
forall a. ExtensionClass a => a -> StateExtension
StateExtension

-- | Existential type to store a state extension.
data StateExtension =
    forall a. ExtensionClass a => StateExtension a
    -- ^ Non-persistent state extension
  | forall a. (Read a, Show a, ExtensionClass a) => PersistentExtension a
    -- ^ Persistent extension

-- ---------------------------------------------------------------------
-- | General utilities
--
-- Lift an 'IO' action into the 'X' monad
io :: MonadIO m => IO a -> m a
io :: IO a -> m a
io = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | Lift an 'IO' action into the 'X' monad.  If the action results in an 'IO'
-- exception, log the exception to stderr and continue normal execution.
catchIO :: MonadIO m => IO () -> m ()
catchIO :: IO () -> m ()
catchIO f :: IO ()
f = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO ()
f IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException e :: e
e) -> Handle -> e -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr e
e IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stderr)

-- | spawn. Launch an external application. Specifically, it double-forks and
-- runs the 'String' you pass as a command to \/bin\/sh.
--
-- Note this function assumes your locale uses utf8.
spawn :: MonadIO m => String -> m ()
spawn :: String -> m ()
spawn x :: String
x = String -> m ProcessID
forall (m :: * -> *). MonadIO m => String -> m ProcessID
spawnPID String
x m ProcessID -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Like 'spawn', but returns the 'ProcessID' of the launched application
spawnPID :: MonadIO m => String -> m ProcessID
spawnPID :: String -> m ProcessID
spawnPID x :: String
x = IO () -> m ProcessID
forall (m :: * -> *). MonadIO m => IO () -> m ProcessID
xfork (IO () -> m ProcessID) -> IO () -> m ProcessID
forall a b. (a -> b) -> a -> b
$ String -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
forall a.
String -> Bool -> [String] -> Maybe [(String, String)] -> IO a
executeFile "/bin/sh" Bool
False ["-c", String
x] Maybe [(String, String)]
forall a. Maybe a
Nothing

-- | A replacement for 'forkProcess' which resets default signal handlers.
xfork :: MonadIO m => IO () -> m ProcessID
xfork :: IO () -> m ProcessID
xfork x :: IO ()
x = IO ProcessID -> m ProcessID
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO ProcessID -> m ProcessID)
-> (IO () -> IO ProcessID) -> IO () -> m ProcessID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ProcessID
forkProcess (IO () -> IO ProcessID)
-> (IO () -> IO ()) -> IO () -> IO ProcessID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally IO ()
nullStdin (IO () -> m ProcessID) -> IO () -> m ProcessID
forall a b. (a -> b) -> a -> b
$ do
                IO ()
forall (m :: * -> *). MonadIO m => m ()
uninstallSignalHandlers
                IO ProcessID
createSession
                IO ()
x
 where
    nullStdin :: IO ()
nullStdin = do
        Fd
fd <- String -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd "/dev/null" OpenMode
ReadOnly Maybe FileMode
forall a. Maybe a
Nothing OpenFileFlags
defaultFileFlags
        Fd -> Fd -> IO Fd
dupTo Fd
fd Fd
stdInput
        Fd -> IO ()
closeFd Fd
fd

-- | This is basically a map function, running a function in the 'X' monad on
-- each workspace with the output of that function being the modified workspace.
runOnWorkspaces :: (WindowSpace -> X WindowSpace) -> X ()
runOnWorkspaces :: (Workspace String (Layout Window) Window
 -> X (Workspace String (Layout Window) Window))
-> X ()
runOnWorkspaces job :: Workspace String (Layout Window) Window
-> X (Workspace String (Layout Window) Window)
job = do
    WindowSet
ws <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
    [Workspace String (Layout Window) Window]
h <- (Workspace String (Layout Window) Window
 -> X (Workspace String (Layout Window) Window))
-> [Workspace String (Layout Window) Window]
-> X [Workspace String (Layout Window) Window]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Workspace String (Layout Window) Window
-> X (Workspace String (Layout Window) Window)
job ([Workspace String (Layout Window) Window]
 -> X [Workspace String (Layout Window) Window])
-> [Workspace String (Layout Window) Window]
-> X [Workspace String (Layout Window) Window]
forall a b. (a -> b) -> a -> b
$ WindowSet -> [Workspace String (Layout Window) Window]
forall i l a sid sd. StackSet i l a sid sd -> [Workspace i l a]
hidden WindowSet
ws
    c :: Screen String (Layout Window) Window ScreenId ScreenDetail
c:v :: [Screen String (Layout Window) Window ScreenId ScreenDetail]
v <- (Screen String (Layout Window) Window ScreenId ScreenDetail
 -> X (Screen String (Layout Window) Window ScreenId ScreenDetail))
-> [Screen String (Layout Window) Window ScreenId ScreenDetail]
-> X [Screen String (Layout Window) Window ScreenId ScreenDetail]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\s :: Screen String (Layout Window) Window ScreenId ScreenDetail
s -> (\w :: Workspace String (Layout Window) Window
w -> Screen String (Layout Window) Window ScreenId ScreenDetail
s { workspace :: Workspace String (Layout Window) Window
workspace = Workspace String (Layout Window) Window
w}) (Workspace String (Layout Window) Window
 -> Screen String (Layout Window) Window ScreenId ScreenDetail)
-> X (Workspace String (Layout Window) Window)
-> X (Screen String (Layout Window) Window ScreenId ScreenDetail)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Workspace String (Layout Window) Window
-> X (Workspace String (Layout Window) Window)
job (Screen String (Layout Window) Window ScreenId ScreenDetail
-> Workspace String (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
workspace Screen String (Layout Window) Window ScreenId ScreenDetail
s))
             ([Screen String (Layout Window) Window ScreenId ScreenDetail]
 -> X [Screen String (Layout Window) Window ScreenId ScreenDetail])
-> [Screen String (Layout Window) Window ScreenId ScreenDetail]
-> X [Screen String (Layout Window) Window ScreenId ScreenDetail]
forall a b. (a -> b) -> a -> b
$ WindowSet
-> Screen String (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
current WindowSet
ws Screen String (Layout Window) Window ScreenId ScreenDetail
-> [Screen String (Layout Window) Window ScreenId ScreenDetail]
-> [Screen String (Layout Window) Window ScreenId ScreenDetail]
forall a. a -> [a] -> [a]
: WindowSet
-> [Screen String (Layout Window) Window ScreenId ScreenDetail]
forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
visible WindowSet
ws
    (XState -> XState) -> X ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XState -> XState) -> X ()) -> (XState -> XState) -> X ()
forall a b. (a -> b) -> a -> b
$ \s :: XState
s -> XState
s { windowset :: WindowSet
windowset = WindowSet
ws { current :: Screen String (Layout Window) Window ScreenId ScreenDetail
current = Screen String (Layout Window) Window ScreenId ScreenDetail
c, visible :: [Screen String (Layout Window) Window ScreenId ScreenDetail]
visible = [Screen String (Layout Window) Window ScreenId ScreenDetail]
v, hidden :: [Workspace String (Layout Window) Window]
hidden = [Workspace String (Layout Window) Window]
h } }

-- | Return the path to the xmonad configuration directory.  This
-- directory is where user configuration files are stored (e.g, the
-- xmonad.hs file).  You may also create a @lib@ subdirectory in the
-- configuration directory and the default recompile command will add
-- it to the GHC include path.
--
-- Several directories are considered.  In order of
-- preference:
--
--   1. The directory specified in the @XMONAD_CONFIG_DIR@ environment variable.
--   2. The @~\/.xmonad@ directory.
--   3. The @XDG_CONFIG_HOME/xmonad@ directory.
--
-- The first directory that exists will be used.  If none of the
-- directories exist then (1) will be used if it is set, otherwise (2)
-- will be used.  Either way, a directory will be created if necessary.
getXMonadDir :: MonadIO m => m String
getXMonadDir :: m String
getXMonadDir =
    String -> [IO String] -> m String
forall (m :: * -> *).
MonadIO m =>
String -> [IO String] -> m String
findFirstDirWithEnv "XMONAD_CONFIG_DIR"
      [ String -> IO String
getAppUserDataDirectory "xmonad"
      , XDGDirectory -> String -> IO String
getXDGDirectory XDGDirectory
XDGConfig "xmonad"
      ]

-- | Return the path to the xmonad cache directory.  This directory is
-- used to store temporary files that can easily be recreated.  For
-- example, the XPrompt history file.
--
-- Several directories are considered.  In order of preference:
--
--   1. The directory specified in the @XMONAD_CACHE_DIR@ environment variable.
--   2. The @~\/.xmonad@ directory.
--   3. The @XDG_CACHE_HOME/xmonad@ directory.
--
-- The first directory that exists will be used.  If none of the
-- directories exist then (1) will be used if it is set, otherwise (2)
-- will be used.  Either way, a directory will be created if necessary.
getXMonadCacheDir :: MonadIO m => m String
getXMonadCacheDir :: m String
getXMonadCacheDir =
    String -> [IO String] -> m String
forall (m :: * -> *).
MonadIO m =>
String -> [IO String] -> m String
findFirstDirWithEnv "XMONAD_CACHE_DIR"
      [ String -> IO String
getAppUserDataDirectory "xmonad"
      , XDGDirectory -> String -> IO String
getXDGDirectory XDGDirectory
XDGCache "xmonad"
      ]

-- | Return the path to the xmonad data directory.  This directory is
-- used by XMonad to store data files such as the run-time state file
-- and the configuration binary generated by GHC.
--
-- Several directories are considered.  In order of preference:
--
--   1. The directory specified in the @XMONAD_DATA_DIR@ environment variable.
--   2. The @~\/.xmonad@ directory.
--   3. The @XDG_DATA_HOME/xmonad@ directory.
--
-- The first directory that exists will be used.  If none of the
-- directories exist then (1) will be used if it is set, otherwise (2)
-- will be used.  Either way, a directory will be created if necessary.
getXMonadDataDir :: MonadIO m => m String
getXMonadDataDir :: m String
getXMonadDataDir =
    String -> [IO String] -> m String
forall (m :: * -> *).
MonadIO m =>
String -> [IO String] -> m String
findFirstDirWithEnv "XMONAD_DATA_DIR"
      [ String -> IO String
getAppUserDataDirectory "xmonad"
      , XDGDirectory -> String -> IO String
getXDGDirectory XDGDirectory
XDGData "xmonad"
      ]

-- | Helper function that will find the first existing directory and
-- return its path.  If none of the directories can be found, create
-- and return the first from the list.  If the list is empty this
-- function returns the historical @~\/.xmonad@ directory.
findFirstDirOf :: MonadIO m => [IO FilePath] -> m FilePath
findFirstDirOf :: [IO String] -> m String
findFirstDirOf []        = [IO String] -> m String
forall (m :: * -> *). MonadIO m => [IO String] -> m String
findFirstDirOf [String -> IO String
getAppUserDataDirectory "xmonad"]
findFirstDirOf possibles :: [IO String]
possibles = do
    Maybe String
found <- [IO String] -> m (Maybe String)
forall (m :: * -> *). MonadIO m => [IO String] -> m (Maybe String)
go [IO String]
possibles

    case Maybe String
found of
      Just path :: String
path -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
path
      Nothing   -> do
        String
primary <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io ([IO String] -> IO String
forall a. [a] -> a
head [IO String]
possibles)
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
primary)
        String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
primary

  where
    go :: [IO String] -> m (Maybe String)
go []     = Maybe String -> m (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
    go (x :: IO String
x:xs :: [IO String]
xs) = do
      String
dir    <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io IO String
x
      Bool
exists <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> IO Bool
doesDirectoryExist String
dir)
      if Bool
exists then Maybe String -> m (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
dir) else [IO String] -> m (Maybe String)
go [IO String]
xs

-- | Simple wrapper around @findFirstDirOf@ that allows the primary
-- path to be specified by an environment variable.
findFirstDirWithEnv :: MonadIO m => String -> [IO FilePath] -> m FilePath
findFirstDirWithEnv :: String -> [IO String] -> m String
findFirstDirWithEnv envName :: String
envName paths :: [IO String]
paths = do
    Maybe String
envPath' <- IO (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> IO (Maybe String)
getEnv String
envName)

    case Maybe String
envPath' of
      Nothing      -> [IO String] -> m String
forall (m :: * -> *). MonadIO m => [IO String] -> m String
findFirstDirOf [IO String]
paths
      Just envPath :: String
envPath -> [IO String] -> m String
forall (m :: * -> *). MonadIO m => [IO String] -> m String
findFirstDirOf (String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
envPathIO String -> [IO String] -> [IO String]
forall a. a -> [a] -> [a]
:[IO String]
paths)

-- | Helper function to retrieve the various XDG directories.
-- This has been based on the implementation shipped with GHC version 8.0.1 or
-- higher. Put here to preserve compatibility with older GHC versions.
getXDGDirectory :: XDGDirectory -> FilePath -> IO FilePath
getXDGDirectory :: XDGDirectory -> String -> IO String
getXDGDirectory xdgDir :: XDGDirectory
xdgDir suffix :: String
suffix =
  ShowS
normalise ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
</> String
suffix) ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  case XDGDirectory
xdgDir of
    XDGData   -> String -> String -> IO String
get "XDG_DATA_HOME"   ".local/share"
    XDGConfig -> String -> String -> IO String
get "XDG_CONFIG_HOME" ".config"
    XDGCache  -> String -> String -> IO String
get "XDG_CACHE_HOME"  ".cache"
  where
    get :: String -> String -> IO String
get name :: String
name fallback :: String
fallback = do
      Maybe String
env <- String -> IO (Maybe String)
lookupEnv String
name
      case Maybe String
env of
        Nothing -> IO String
fallback'
        Just path :: String
path
          | String -> Bool
isRelative String
path -> IO String
fallback'
          | Bool
otherwise -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
path
      where
        fallback' :: IO String
fallback' = (String -> ShowS
</> String
fallback) ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getHomeDirectory
data XDGDirectory = XDGData | XDGConfig | XDGCache

-- | Get the name of the file used to store the xmonad window state.
stateFileName :: (Functor m, MonadIO m) => m FilePath
stateFileName :: m String
stateFileName = (String -> ShowS
</> "xmonad.state") ShowS -> m String -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
forall (m :: * -> *). MonadIO m => m String
getXMonadDataDir

-- | 'recompile force', recompile the xmonad configuration file when
-- any of the following apply:
--
--      * force is 'True'
--
--      * the xmonad executable does not exist
--
--      * the xmonad executable is older than xmonad.hs or any file in
--        the @lib@ directory (under the configuration directory).
--
-- The -i flag is used to restrict recompilation to the xmonad.hs file only,
-- and any files in the aforementioned @lib@ directory.
--
-- Compilation errors (if any) are logged to the @xmonad.errors@ file
-- in the xmonad data directory.  If GHC indicates failure with a
-- non-zero exit code, an xmessage displaying that file is spawned.
--
-- 'False' is returned if there are compilation errors.
--
recompile :: MonadIO m => Bool -> m Bool
recompile :: Bool -> m Bool
recompile force :: Bool
force = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
    String
cfgdir  <- IO String
forall (m :: * -> *). MonadIO m => m String
getXMonadDir
    String
datadir <- IO String
forall (m :: * -> *). MonadIO m => m String
getXMonadDataDir
    let binn :: String
binn = "xmonad-"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
archString -> ShowS
forall a. [a] -> [a] -> [a]
++"-"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
os
        bin :: String
bin  = String
datadir String -> ShowS
</> String
binn
        err :: String
err  = String
datadir String -> ShowS
</> "xmonad.errors"
        src :: String
src  = String
cfgdir String -> ShowS
</> "xmonad.hs"
        lib :: String
lib  = String
cfgdir String -> ShowS
</> "lib"
        buildscript :: String
buildscript = String
cfgdir String -> ShowS
</> "build"

    [Maybe UTCTime]
libTs <- (String -> IO (Maybe UTCTime)) -> [String] -> IO [Maybe UTCTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Maybe UTCTime)
getModTime ([String] -> IO [Maybe UTCTime])
-> ([String] -> [String]) -> [String] -> IO [Maybe UTCTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter String -> Bool
isSource ([String] -> IO [Maybe UTCTime])
-> IO [String] -> IO [Maybe UTCTime]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO [String]
allFiles String
lib
    Maybe UTCTime
srcT <- String -> IO (Maybe UTCTime)
getModTime String
src
    Maybe UTCTime
binT <- String -> IO (Maybe UTCTime)
getModTime String
bin

    Bool
useBuildscript <- do
      Bool
exists <- String -> IO Bool
doesFileExist String
buildscript
      if Bool
exists
        then do
          Bool
isExe <- String -> IO Bool
isExecutable String
buildscript
          if Bool
isExe
            then do
              String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
trace (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "XMonad will use build script at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
buildscript String -> ShowS
forall a. [a] -> [a] -> [a]
++ " to recompile."
              Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            else do
              String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
trace (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                [ "XMonad will not use build script, because " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
buildscript String -> ShowS
forall a. [a] -> [a] -> [a]
++ " is not executable."
                , "Suggested resolution to use it: chmod u+x " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
buildscript
                ]
              Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        else do
          String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
trace (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            "XMonad will use ghc to recompile, because " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
buildscript String -> ShowS
forall a. [a] -> [a] -> [a]
++ " does not exist."
          Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    Bool
shouldRecompile <-
      if Bool
useBuildscript Bool -> Bool -> Bool
|| Bool
force
        then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else if (Maybe UTCTime -> Bool) -> [Maybe UTCTime] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe UTCTime
binT Maybe UTCTime -> Maybe UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<) (Maybe UTCTime
srcT Maybe UTCTime -> [Maybe UTCTime] -> [Maybe UTCTime]
forall a. a -> [a] -> [a]
: [Maybe UTCTime]
libTs)
          then do
            String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
trace "XMonad doing recompile because some files have changed."
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          else do
            String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
trace "XMonad skipping recompile because it is not forced (e.g. via --recompile), and neither xmonad.hs nor any *.hs / *.lhs / *.hsc files in lib/ have been changed."
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    if Bool
shouldRecompile
      then do
        -- temporarily disable SIGCHLD ignoring:
        IO ()
forall (m :: * -> *). MonadIO m => m ()
uninstallSignalHandlers
        ExitCode
status <- IO Handle
-> (Handle -> IO ()) -> (Handle -> IO ExitCode) -> IO ExitCode
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IOMode -> IO Handle
openFile String
err IOMode
WriteMode) Handle -> IO ()
hClose ((Handle -> IO ExitCode) -> IO ExitCode)
-> (Handle -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \errHandle :: Handle
errHandle ->
            ProcessHandle -> IO ExitCode
waitForProcess (ProcessHandle -> IO ExitCode) -> IO ProcessHandle -> IO ExitCode
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< if Bool
useBuildscript
                               then String -> String -> String -> Handle -> IO ProcessHandle
compileScript String
bin String
cfgdir String
buildscript Handle
errHandle
                               else String -> String -> Handle -> IO ProcessHandle
compileGHC String
bin String
cfgdir Handle
errHandle

        -- re-enable SIGCHLD:
        IO ()
forall (m :: * -> *). MonadIO m => m ()
installSignalHandlers

        -- now, if it fails, run xmessage to let the user know:
        if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
            then String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
trace "XMonad recompilation process exited with success!"
            else do
                String
ghcErr <- String -> IO String
readFile String
err
                let msg :: String
msg = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                        ["Error detected while loading xmonad configuration file: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
src]
                        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
lines (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ghcErr then ExitCode -> String
forall a. Show a => a -> String
show ExitCode
status else String
ghcErr)
                        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["","Please check the file for errors."]
                -- nb, the ordering of printing, then forking, is crucial due to
                -- lazy evaluation
                Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg
                IO () -> IO ProcessID
forkProcess (IO () -> IO ProcessID) -> IO () -> IO ProcessID
forall a b. (a -> b) -> a -> b
$ String -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
forall a.
String -> Bool -> [String] -> Maybe [(String, String)] -> IO a
executeFile "xmessage" Bool
True ["-default", "okay", ShowS
replaceUnicode String
msg] Maybe [(String, String)]
forall a. Maybe a
Nothing
                () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess)
      else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
 where getModTime :: String -> IO (Maybe UTCTime)
getModTime f :: String
f = IO (Maybe UTCTime)
-> (SomeException -> IO (Maybe UTCTime)) -> IO (Maybe UTCTime)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> IO UTCTime -> IO (Maybe UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO UTCTime
getModificationTime String
f) (\(SomeException _) -> Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing)
       isSource :: String -> Bool
isSource = (String -> [String] -> Bool) -> [String] -> String -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [".hs",".lhs",".hsc"] (String -> Bool) -> ShowS -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeExtension
       isExecutable :: String -> IO Bool
isExecutable f :: String
f = IO Bool -> (SomeException -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (Permissions -> Bool
executable (Permissions -> Bool) -> IO Permissions -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Permissions
getPermissions String
f) (\(SomeException _) -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
       allFiles :: String -> IO [String]
allFiles t :: String
t = do
            let prep :: [String] -> [String]
prep = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
tString -> ShowS
</>) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [".",".."])
            [String]
cs <- [String] -> [String]
prep ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String] -> (SomeException -> IO [String]) -> IO [String]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (String -> IO [String]
getDirectoryContents String
t) (\(SomeException _) -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
            [String]
ds <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesDirectoryExist [String]
cs
            [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String])
-> ([[String]] -> [[String]]) -> [[String]] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([String]
cs [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
\\ [String]
ds)[String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
:) ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [String]
allFiles [String]
ds
       -- Replace some of the unicode symbols GHC uses in its output
       replaceUnicode :: ShowS
replaceUnicode = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> ShowS) -> (Char -> Char) -> ShowS
forall a b. (a -> b) -> a -> b
$ \c :: Char
c -> case Char
c of
           '\8226' -> '*'  -- •
           '\8216' -> '`'  -- ‘
           '\8217' -> '`'  -- ’
           _ -> Char
c
       compileGHC :: String -> String -> Handle -> IO ProcessHandle
compileGHC bin :: String
bin dir :: String
dir errHandle :: Handle
errHandle =
         String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess "ghc" ["--make"
                          , "xmonad.hs"
                          , "-i"
                          , "-ilib"
                          , "-fforce-recomp"
                          , "-main-is", "main"
                          , "-v0"
                          , "-o", String
bin
                          ] (String -> Maybe String
forall a. a -> Maybe a
Just String
dir) Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
errHandle)
       compileScript :: String -> String -> String -> Handle -> IO ProcessHandle
compileScript bin :: String
bin dir :: String
dir script :: String
script errHandle :: Handle
errHandle =
         String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess String
script [String
bin] (String -> Maybe String
forall a. a -> Maybe a
Just String
dir) Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
errHandle)

-- | Conditionally run an action, using a @Maybe a@ to decide.
whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust :: Maybe a -> (a -> m ()) -> m ()
whenJust mg :: Maybe a
mg f :: a -> m ()
f = m () -> (a -> m ()) -> Maybe a -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) a -> m ()
f Maybe a
mg

-- | Conditionally run an action, using a 'X' event to decide
whenX :: X Bool -> X () -> X ()
whenX :: X Bool -> X () -> X ()
whenX a :: X Bool
a f :: X ()
f = X Bool
a X Bool -> (Bool -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b :: Bool
b -> Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b X ()
f

-- | A 'trace' for the 'X' monad. Logs a string to stderr. The result may
-- be found in your .xsession-errors file
trace :: MonadIO m => String -> m ()
trace :: String -> m ()
trace = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
stderr

-- | Ignore SIGPIPE to avoid termination when a pipe is full, and SIGCHLD to
-- avoid zombie processes, and clean up any extant zombie processes.
installSignalHandlers :: MonadIO m => m ()
installSignalHandlers :: m ()
installSignalHandlers = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
openEndedPipe Handler
Ignore Maybe SignalSet
forall a. Maybe a
Nothing
    Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigCHLD Handler
Ignore Maybe SignalSet
forall a. Maybe a
Nothing
    (forall a. IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try :: IO a -> IO (Either SomeException a))
      (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \more :: IO ()
more -> do
        Maybe (ProcessID, ProcessStatus)
x <- Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
getAnyProcessStatus Bool
False Bool
False
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (ProcessID, ProcessStatus) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (ProcessID, ProcessStatus)
x) IO ()
more
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

uninstallSignalHandlers :: MonadIO m => m ()
uninstallSignalHandlers :: m ()
uninstallSignalHandlers = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
openEndedPipe Handler
Default Maybe SignalSet
forall a. Maybe a
Nothing
    Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigCHLD Handler
Default Maybe SignalSet
forall a. Maybe a
Nothing
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()