mirror of
https://github.com/xmonad/xmonad.git
synced 2025-05-19 08:30:21 -07:00
Merge branch 'hlint'
This commit is contained in:
Tomas Janousek
commit
45a89130d9
15
.github/workflows/haskell-ci.yml
vendored
15
.github/workflows/haskell-ci.yml
vendored
@ -160,6 +160,11 @@ jobs:
|
||||
- name: update cabal index
|
||||
run: |
|
||||
$CABAL v2-update -v
|
||||
- name: cache (tools)
|
||||
uses: actions/cache@v2
|
||||
with:
|
||||
key: ${{ runner.os }}-${{ matrix.compiler }}-tools-c0dbbd39
|
||||
path: ~/.haskell-ci-tools
|
||||
- name: install cabal-plan
|
||||
run: |
|
||||
mkdir -p $HOME/.cabal/bin
|
||||
@ -169,6 +174,12 @@ jobs:
|
||||
rm -f cabal-plan.xz
|
||||
chmod a+x $HOME/.cabal/bin/cabal-plan
|
||||
cabal-plan --version
|
||||
- name: install hlint
|
||||
run: |
|
||||
if [ $((HCNUMVER >= 90000 && HCNUMVER < 90200)) -ne 0 ] ; then HLINTVER=$(cd /tmp && (${CABAL} v2-install -v $ARG_COMPILER --dry-run hlint --constraint='hlint >=3.4 && <3.5' | perl -ne 'if (/\bhlint-(\d+(\.\d+)*)\b/) { print "$1"; last; }')); echo "HLint version $HLINTVER" ; fi
|
||||
if [ $((HCNUMVER >= 90000 && HCNUMVER < 90200)) -ne 0 ] ; then if [ ! -e $HOME/.haskell-ci-tools/hlint-$HLINTVER/hlint ]; then echo "Downloading HLint version $HLINTVER"; mkdir -p $HOME/.haskell-ci-tools; curl --write-out 'Status Code: %{http_code} Redirects: %{num_redirects} Total time: %{time_total} Total Dsize: %{size_download}\n' --silent --location --output $HOME/.haskell-ci-tools/hlint-$HLINTVER.tar.gz "https://github.com/ndmitchell/hlint/releases/download/v$HLINTVER/hlint-$HLINTVER-x86_64-linux.tar.gz"; tar -xzv -f $HOME/.haskell-ci-tools/hlint-$HLINTVER.tar.gz -C $HOME/.haskell-ci-tools; fi ; fi
|
||||
if [ $((HCNUMVER >= 90000 && HCNUMVER < 90200)) -ne 0 ] ; then mkdir -p $CABAL_DIR/bin && ln -sf "$HOME/.haskell-ci-tools/hlint-$HLINTVER/hlint" $CABAL_DIR/bin/hlint ; fi
|
||||
if [ $((HCNUMVER >= 90000 && HCNUMVER < 90200)) -ne 0 ] ; then hlint --version ; fi
|
||||
- name: checkout
|
||||
uses: actions/checkout@v2
|
||||
with:
|
||||
@ -228,6 +239,10 @@ jobs:
|
||||
- name: tests
|
||||
run: |
|
||||
$CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
|
||||
- name: hlint
|
||||
run: |
|
||||
if [ $((HCNUMVER >= 90000 && HCNUMVER < 90200)) -ne 0 ] ; then (cd ${PKGDIR_xmonad} && hlint -h ${GITHUB_WORKSPACE}/source/.hlint.yaml -XHaskell2010 src) ; fi
|
||||
if [ $((HCNUMVER >= 90000 && HCNUMVER < 90200)) -ne 0 ] ; then (cd ${PKGDIR_xmonad} && hlint -h ${GITHUB_WORKSPACE}/source/.hlint.yaml -XHaskell2010 .) ; fi
|
||||
- name: cabal check
|
||||
run: |
|
||||
cd ${PKGDIR_xmonad} || false
|
||||
|
||||
2
.hlint.yaml
Normal file
2
.hlint.yaml
Normal file
@ -0,0 +1,2 @@
|
||||
# Ignore these warnings.
|
||||
- ignore: {name: "Use camelCase"}
|
||||
@ -5,6 +5,11 @@ apt:
|
||||
libxrandr-dev
|
||||
libxss-dev
|
||||
|
||||
hlint: True
|
||||
hlint-job: 9.0.2
|
||||
hlint-yaml: .hlint.yaml
|
||||
hlint-version: ==3.4.*
|
||||
|
||||
github-patches:
|
||||
.github/workflows/haskell-ci-hackage.patch
|
||||
|
||||
|
||||
@ -123,7 +123,7 @@ myKeys conf@(XConfig {XMonad.modMask = modm}) = M.fromList $
|
||||
-- , ((modm , xK_b ), sendMessage ToggleStruts)
|
||||
|
||||
-- Quit xmonad
|
||||
, ((modm .|. shiftMask, xK_q ), io (exitWith ExitSuccess))
|
||||
, ((modm .|. shiftMask, xK_q ), io exitSuccess)
|
||||
|
||||
-- Restart xmonad
|
||||
, ((modm , xK_q ), spawn "xmonad --recompile; xmonad --restart")
|
||||
@ -154,18 +154,18 @@ myKeys conf@(XConfig {XMonad.modMask = modm}) = M.fromList $
|
||||
------------------------------------------------------------------------
|
||||
-- Mouse bindings: default actions bound to mouse events
|
||||
--
|
||||
myMouseBindings (XConfig {XMonad.modMask = modm}) = M.fromList $
|
||||
myMouseBindings (XConfig {XMonad.modMask = modm}) = M.fromList
|
||||
|
||||
-- mod-button1, Set the window to floating mode and move by dragging
|
||||
[ ((modm, button1), (\w -> focus w >> mouseMoveWindow w
|
||||
>> windows W.shiftMaster))
|
||||
[ ((modm, button1), \w -> focus w >> mouseMoveWindow w
|
||||
>> windows W.shiftMaster)
|
||||
|
||||
-- mod-button2, Raise the window to the top of the stack
|
||||
, ((modm, button2), (\w -> focus w >> windows W.shiftMaster))
|
||||
, ((modm, button2), \w -> focus w >> windows W.shiftMaster)
|
||||
|
||||
-- mod-button3, Set the window to floating mode and resize by dragging
|
||||
, ((modm, button3), (\w -> focus w >> mouseResizeWindow w
|
||||
>> windows W.shiftMaster))
|
||||
, ((modm, button3), \w -> focus w >> mouseResizeWindow w
|
||||
>> windows W.shiftMaster)
|
||||
|
||||
-- you may also bind events to the mouse scroll wheel (button4 and button5)
|
||||
]
|
||||
|
||||
@ -218,7 +218,7 @@ keys conf@(XConfig {XMonad.modMask = modMask}) = M.fromList $
|
||||
, ((modMask , xK_period), sendMessage (IncMasterN (-1))) -- %! Deincrement the number of windows in the master area
|
||||
|
||||
-- quit, or restart
|
||||
, ((modMask .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) -- %! Quit xmonad
|
||||
, ((modMask .|. shiftMask, xK_q ), io exitSuccess) -- %! Quit xmonad
|
||||
, ((modMask , xK_q ), spawn "if type xmonad; then xmonad --recompile && xmonad --restart; else xmessage xmonad not in \\$PATH: \"$PATH\"; fi") -- %! Restart xmonad
|
||||
|
||||
, ((modMask .|. shiftMask, xK_slash ), helpCommand) -- %! Run xmessage with a summary of the default keybindings (useful for beginners)
|
||||
|
||||
@ -1,6 +1,11 @@
|
||||
{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving,
|
||||
MultiParamTypeClasses, TypeSynonymInstances, DeriveDataTypeable,
|
||||
LambdaCase, NamedFieldPuns, DeriveTraversable #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
@ -35,17 +40,17 @@ module XMonad.Core (
|
||||
import XMonad.StackSet hiding (modify)
|
||||
|
||||
import Prelude
|
||||
import Control.Exception (fromException, try, bracket, bracket_, throw, finally, SomeException(..))
|
||||
import Control.Exception (fromException, try, bracket_, throw, finally, SomeException(..))
|
||||
import qualified Control.Exception as E
|
||||
import Control.Applicative ((<|>), empty)
|
||||
import Control.Monad.Fail
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad (void)
|
||||
import Data.Semigroup
|
||||
import Data.Traversable (for)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Default.Class
|
||||
import Data.List (isInfixOf)
|
||||
import System.FilePath
|
||||
import System.IO
|
||||
import System.Info
|
||||
@ -60,7 +65,7 @@ import System.Exit
|
||||
import Graphics.X11.Xlib
|
||||
import Graphics.X11.Xlib.Extras (getWindowAttributes, WindowAttributes, Event)
|
||||
import Data.Typeable
|
||||
import Data.List ((\\))
|
||||
import Data.List (isInfixOf, (\\))
|
||||
import Data.Maybe (isJust,fromMaybe)
|
||||
|
||||
import qualified Data.Map as M
|
||||
@ -172,7 +177,7 @@ newtype Query a = Query (ReaderT Window X a)
|
||||
deriving (Functor, Applicative, Monad, MonadReader Window, MonadIO)
|
||||
|
||||
runQuery :: Query a -> Window -> X a
|
||||
runQuery (Query m) w = runReaderT m w
|
||||
runQuery (Query m) = runReaderT m
|
||||
|
||||
instance Semigroup a => Semigroup (Query a) where
|
||||
(<>) = liftM2 (<>)
|
||||
@ -195,7 +200,7 @@ catchX job errcase = do
|
||||
st <- get
|
||||
c <- ask
|
||||
(a, s') <- io $ runX c st job `E.catch` \e -> case fromException e of
|
||||
Just x -> throw e `const` (x `asTypeOf` ExitSuccess)
|
||||
Just (_ :: ExitCode) -> throw e
|
||||
_ -> do hPrint stderr e; runX c st errcase
|
||||
put s'
|
||||
return a
|
||||
@ -203,12 +208,12 @@ catchX job errcase = do
|
||||
-- | 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 a = catchX (Just `liftM` a) (return Nothing)
|
||||
userCode a = catchX (Just <$> a) (return 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 defValue a = fromMaybe defValue `liftM` userCode a
|
||||
userCodeDef defValue a = fromMaybe defValue <$> userCode a
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
-- Convenient wrappers to state
|
||||
@ -229,7 +234,7 @@ withWindowAttributes dpy win f = do
|
||||
|
||||
-- | True if the given window is the root window
|
||||
isRoot :: Window -> X Bool
|
||||
isRoot w = (w==) <$> asks theRoot
|
||||
isRoot w = asks $ (w ==) . theRoot
|
||||
|
||||
-- | Wrapper for the common case of atom internment
|
||||
getAtom :: String -> X Atom
|
||||
@ -431,7 +436,7 @@ catchIO f = io (f `E.catch` \(SomeException e) -> hPrint stderr e >> hFlush stde
|
||||
--
|
||||
-- Note this function assumes your locale uses utf8.
|
||||
spawn :: MonadIO m => String -> m ()
|
||||
spawn x = spawnPID x >> return ()
|
||||
spawn x = void $ spawnPID x
|
||||
|
||||
-- | Like 'spawn', but returns the 'ProcessID' of the launched application
|
||||
spawnPID :: MonadIO m => String -> m ProcessID
|
||||
@ -645,7 +650,7 @@ getModTime f = E.catch (Just <$> getModificationTime f) (\(SomeException _) -> r
|
||||
compile :: Directories -> Compile -> IO ExitCode
|
||||
compile dirs method =
|
||||
bracket_ uninstallSignalHandlers installSignalHandlers $
|
||||
bracket (openFile (errFileName dirs) WriteMode) hClose $ \err -> do
|
||||
withFile (errFileName dirs) WriteMode $ \err -> do
|
||||
let run = runProc (cfgDir dirs) err
|
||||
case method of
|
||||
CompileGhc ->
|
||||
|
||||
@ -1,4 +1,6 @@
|
||||
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances, DeriveDataTypeable, LambdaCase, MultiWayIf #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
|
||||
-- --------------------------------------------------------------------------
|
||||
-- |
|
||||
@ -39,7 +41,7 @@ import Data.Maybe (fromMaybe)
|
||||
data Resize = Shrink | Expand
|
||||
|
||||
-- | Increase the number of clients in the master pane.
|
||||
data IncMasterN = IncMasterN !Int
|
||||
newtype IncMasterN = IncMasterN Int
|
||||
|
||||
instance Message Resize
|
||||
instance Message IncMasterN
|
||||
@ -199,8 +201,8 @@ choose (Choose d l r) d' ml mr = f lr
|
||||
(CL, CR) -> (hide l' , return r')
|
||||
(CR, CL) -> (return l', hide r' )
|
||||
(_ , _ ) -> (return l', return r')
|
||||
f (x,y) = fmap Just $ liftM2 (Choose d') x y
|
||||
hide x = fmap (fromMaybe x) $ handle x Hide
|
||||
f (x,y) = Just <$> liftM2 (Choose d') x y
|
||||
hide x = fromMaybe x <$> handle x Hide
|
||||
|
||||
instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where
|
||||
runLayout (W.Workspace i (Choose CL l r) ms) =
|
||||
|
||||
@ -1,4 +1,6 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, NamedFieldPuns #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : XMonad.Main
|
||||
@ -87,14 +89,14 @@ usage :: IO ()
|
||||
usage = do
|
||||
self <- getProgName
|
||||
putStr . unlines $
|
||||
concat ["Usage: ", self, " [OPTION]"] :
|
||||
"Options:" :
|
||||
" --help Print this message" :
|
||||
" --version Print the version number" :
|
||||
" --recompile Recompile your xmonad.hs" :
|
||||
" --replace Replace the running window manager with xmonad" :
|
||||
" --restart Request a running xmonad process to restart" :
|
||||
[]
|
||||
[ "Usage: " <> self <> " [OPTION]"
|
||||
, "Options:"
|
||||
, " --help Print this message"
|
||||
, " --version Print the version number"
|
||||
, " --recompile Recompile your xmonad.hs"
|
||||
, " --replace Replace the running window manager with xmonad"
|
||||
, " --restart Request a running xmonad process to restart"
|
||||
]
|
||||
|
||||
-- | Build the xmonad configuration file with ghc, then execute it.
|
||||
-- If there are no errors, this function does not return. An
|
||||
@ -330,7 +332,7 @@ handle e@(DestroyWindowEvent {ev_window = w}) = do
|
||||
-- it is synthetic or we are not expecting an unmap notification from a window.
|
||||
handle (UnmapEvent {ev_window = w, ev_send_event = synthetic}) = whenX (isClient w) $ do
|
||||
e <- gets (fromMaybe 0 . M.lookup w . waitingUnmap)
|
||||
if (synthetic || e == 0)
|
||||
if synthetic || e == 0
|
||||
then unmanage w
|
||||
else modify (\s -> s { waitingUnmap = M.update mpred w (waitingUnmap s) })
|
||||
where mpred 1 = Nothing
|
||||
@ -428,7 +430,7 @@ handle event@(PropertyEvent { ev_event_type = t, ev_atom = a })
|
||||
|
||||
handle e@ClientMessageEvent { ev_message_type = mt } = do
|
||||
a <- getAtom "XMONAD_RESTART"
|
||||
if (mt == a)
|
||||
if mt == a
|
||||
then restart "xmonad" True
|
||||
else broadcastMessage e
|
||||
|
||||
@ -501,7 +503,7 @@ grabButtons = do
|
||||
io $ ungrabButton dpy anyButton anyModifier rootw
|
||||
ems <- extraModifiers
|
||||
ba <- asks buttonActions
|
||||
mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) ems) (M.keys $ ba)
|
||||
mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) ems) (M.keys ba)
|
||||
|
||||
-- | @replace@ to signals compliant window managers to exit.
|
||||
replace :: Display -> ScreenNumber -> Window -> IO ()
|
||||
|
||||
@ -1,5 +1,3 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : XMonad.ManageHook
|
||||
@ -8,7 +6,6 @@
|
||||
--
|
||||
-- Maintainer : spencerjanssen@gmail.com
|
||||
-- Stability : unstable
|
||||
-- Portability : not portable, uses cunning newtype deriving
|
||||
--
|
||||
-- An EDSL for ManageHooks
|
||||
--
|
||||
@ -65,7 +62,7 @@ infixr 3 <&&>, <||>
|
||||
|
||||
-- | '||' lifted to a 'Monad'.
|
||||
(<||>) :: Monad m => m Bool -> m Bool -> m Bool
|
||||
(<||>) x y = ifM x (pure True) y
|
||||
(<||>) x = ifM x (pure True)
|
||||
|
||||
-- | If-then-else lifted to a 'Monad'.
|
||||
ifM :: Monad m => m Bool -> m a -> m a -> m a
|
||||
@ -98,7 +95,7 @@ className = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resClass $ io $ getC
|
||||
-- | A query that can return an arbitrary X property of type 'String',
|
||||
-- identified by name.
|
||||
stringProperty :: String -> Query String
|
||||
stringProperty p = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap (fromMaybe "") $ getStringProperty d w p)
|
||||
stringProperty p = ask >>= (\w -> liftX $ withDisplay $ \d -> fromMaybe "" <$> getStringProperty d w p)
|
||||
|
||||
getStringProperty :: Display -> Window -> String -> X (Maybe String)
|
||||
getStringProperty d w p = do
|
||||
|
||||
@ -1,4 +1,10 @@
|
||||
{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, PatternGuards, LambdaCase #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
-- --------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : XMonad.Operations
|
||||
@ -66,6 +72,7 @@ import qualified Data.Set as S
|
||||
import Control.Arrow (second)
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Control.Monad (void)
|
||||
import qualified Control.Exception as C
|
||||
|
||||
import System.IO
|
||||
@ -136,7 +143,7 @@ killWindow w = withDisplay $ \d -> do
|
||||
setEventType ev clientMessage
|
||||
setClientMessageEvent ev w wmprot 32 wmdelt currentTime
|
||||
sendEvent d w False noEventMask ev
|
||||
else killClient d w >> return ()
|
||||
else void (killClient d w)
|
||||
|
||||
-- | Kill the currently focused client.
|
||||
kill :: X ()
|
||||
@ -187,7 +194,7 @@ windows f = do
|
||||
|
||||
let m = W.floating ws
|
||||
flt = [(fw, scaleRationalRect viewrect r)
|
||||
| fw <- filter (flip M.member m) (W.index this)
|
||||
| fw <- filter (`M.member` m) (W.index this)
|
||||
, Just r <- [M.lookup fw m]]
|
||||
vs = flt ++ rs
|
||||
|
||||
@ -213,7 +220,7 @@ windows f = do
|
||||
-- all windows that are no longer in the windowset are marked as
|
||||
-- withdrawn, it is important to do this after the above, otherwise 'hide'
|
||||
-- will overwrite withdrawnState with iconicState
|
||||
mapM_ (flip setWMState withdrawnState) (W.allWindows old \\ W.allWindows ws)
|
||||
mapM_ (`setWMState` withdrawnState) (W.allWindows old \\ W.allWindows ws)
|
||||
|
||||
isMouseFocused <- asks mouseFocused
|
||||
unless isMouseFocused $ clearEvents enterWindowMask
|
||||
@ -229,8 +236,8 @@ windowBracket :: (a -> Bool) -> X a -> X a
|
||||
windowBracket p action = withWindowSet $ \old -> do
|
||||
a <- action
|
||||
when (p a) . withWindowSet $ \new -> do
|
||||
modifyWindowSet $ \_ -> old
|
||||
windows $ \_ -> new
|
||||
modifyWindowSet $ const old
|
||||
windows $ const new
|
||||
return a
|
||||
|
||||
-- | Perform an @X@ action. If it returns @Any True@, unwind the
|
||||
@ -417,7 +424,7 @@ setFocusX w = withWindowSet $ \ws -> do
|
||||
currevt <- asks currentEvent
|
||||
let inputHintSet = wmh_flags hints `testBit` inputHintBit
|
||||
|
||||
when ((inputHintSet && wmh_input hints) || (not inputHintSet)) $
|
||||
when (inputHintSet && wmh_input hints || not inputHintSet) $
|
||||
io $ do setInputFocus dpy w revertToPointerRoot 0
|
||||
when (wmtf `elem` protocols) $
|
||||
io $ allocaXEvent $ \ev -> do
|
||||
@ -425,7 +432,7 @@ setFocusX w = withWindowSet $ \ws -> do
|
||||
setClientMessageEvent ev w wmprot 32 wmtf $ maybe currentTime event_time currevt
|
||||
sendEvent dpy w False noEventMask ev
|
||||
where event_time ev =
|
||||
if (ev_event_type ev) `elem` timedEvents then
|
||||
if ev_event_type ev `elem` timedEvents then
|
||||
ev_time ev
|
||||
else
|
||||
currentTime
|
||||
@ -438,7 +445,7 @@ setFocusX w = withWindowSet $ \ws -> do
|
||||
-- layout the windows, in which case changes are handled through a refresh.
|
||||
sendMessage :: Message a => a -> X ()
|
||||
sendMessage a = windowBracket_ $ do
|
||||
w <- W.workspace . W.current <$> gets windowset
|
||||
w <- gets $ W.workspace . W.current . windowset
|
||||
ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing
|
||||
whenJust ml' $ \l' ->
|
||||
modifyWindowSet $ \ws -> ws { W.current = (W.current ws)
|
||||
@ -473,7 +480,7 @@ updateLayout i ml = whenJust ml $ \l ->
|
||||
-- | Set the layout of the currently viewed workspace.
|
||||
setLayout :: Layout Window -> X ()
|
||||
setLayout l = do
|
||||
ss@(W.StackSet { W.current = c@(W.Screen { W.workspace = ws })}) <- gets windowset
|
||||
ss@W.StackSet{ W.current = c@W.Screen{ W.workspace = ws }} <- gets windowset
|
||||
handleMessage (W.layout ws) (SomeMessage ReleaseResources)
|
||||
windows $ const $ ss{ W.current = c{ W.workspace = ws{ W.layout = l } } }
|
||||
|
||||
@ -515,7 +522,7 @@ cleanMask km = do
|
||||
-- | Get the 'Pixel' value for a named color.
|
||||
initColor :: Display -> String -> IO (Maybe Pixel)
|
||||
initColor dpy c = C.handle (\(C.SomeException _) -> return Nothing) $
|
||||
(Just . color_pixel . fst) <$> allocNamedColor dpy colormap c
|
||||
Just . color_pixel . fst <$> allocNamedColor dpy colormap c
|
||||
where colormap = defaultColormap dpy (defaultScreen dpy)
|
||||
|
||||
------------------------------------------------------------------------
|
||||
@ -535,7 +542,7 @@ writeStateToFile = do
|
||||
maybeShow _ = Nothing
|
||||
|
||||
wsData = W.mapLayout show . windowset
|
||||
extState = catMaybes . map maybeShow . M.toList . extensibleState
|
||||
extState = mapMaybe maybeShow . M.toList . extensibleState
|
||||
|
||||
path <- asks $ stateFileName . directories
|
||||
stateData <- gets (\s -> StateFile (wsData s) (extState s))
|
||||
@ -598,11 +605,10 @@ floatLocation w =
|
||||
catchX go $ do
|
||||
-- Fallback solution if `go' fails. Which it might, since it
|
||||
-- calls `getWindowAttributes'.
|
||||
sc <- W.current <$> gets windowset
|
||||
sc <- gets $ W.current . windowset
|
||||
return (W.screen sc, W.RationalRect 0 0 1 1)
|
||||
|
||||
where fi x = fromIntegral x
|
||||
go = withDisplay $ \d -> do
|
||||
where go = withDisplay $ \d -> do
|
||||
ws <- gets windowset
|
||||
wa <- io $ getWindowAttributes d w
|
||||
let bw = (fromIntegral . wa_border_width) wa
|
||||
@ -628,6 +634,9 @@ floatLocation w =
|
||||
|
||||
return (W.screen sc, rr)
|
||||
|
||||
fi :: (Integral a, Num b) => a -> b
|
||||
fi = fromIntegral
|
||||
|
||||
-- | Given a point, determine the screen (if any) that contains it.
|
||||
pointScreen :: Position -> Position
|
||||
-> X (Maybe (W.Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail))
|
||||
@ -726,7 +735,7 @@ mkAdjust w = withDisplay $ \d -> liftIO $ do
|
||||
sh <- getWMNormalHints d w
|
||||
wa <- C.try $ getWindowAttributes d w
|
||||
case wa of
|
||||
Left err -> const (return id) (err :: C.SomeException)
|
||||
Left (_ :: C.SomeException) -> return id
|
||||
Right wa' ->
|
||||
let bw = fromIntegral $ wa_border_width wa'
|
||||
in return $ applySizeHints bw sh
|
||||
|
||||
@ -240,7 +240,7 @@ view i s
|
||||
|
||||
| otherwise = s -- not a member of the stackset
|
||||
|
||||
where equating f = \x y -> f x == f y
|
||||
where equating f x y = f x == f y
|
||||
|
||||
-- 'Catch'ing this might be hard. Relies on monotonically increasing
|
||||
-- workspace tags defined in 'new'
|
||||
|
||||
@ -36,7 +36,7 @@ instance (Integral i, Integral s, Eq a, Arbitrary a, Arbitrary l, Arbitrary sd)
|
||||
-- Pick a random window "number" in each workspace, to give focus.
|
||||
focus <- sequence [ if null windows
|
||||
then return Nothing
|
||||
else liftM Just $ choose (0, length windows - 1)
|
||||
else Just <$> choose (0, length windows - 1)
|
||||
| windows <- wsWindows ]
|
||||
|
||||
let tags = [1 .. fromIntegral numWs]
|
||||
@ -80,7 +80,7 @@ newtype NonEmptyWindowsStackSet = NonEmptyWindowsStackSet T
|
||||
|
||||
instance Arbitrary NonEmptyWindowsStackSet where
|
||||
arbitrary =
|
||||
NonEmptyWindowsStackSet `fmap` (arbitrary `suchThat` (not . null . allWindows))
|
||||
NonEmptyWindowsStackSet <$> (arbitrary `suchThat` (not . null . allWindows))
|
||||
|
||||
instance Arbitrary Rectangle where
|
||||
arbitrary = Rectangle <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
|
||||
@ -99,7 +99,7 @@ newtype NonEmptyNubList a = NonEmptyNubList [a]
|
||||
deriving ( Eq, Ord, Show, Read )
|
||||
|
||||
instance (Eq a, Arbitrary a) => Arbitrary (NonEmptyNubList a) where
|
||||
arbitrary = NonEmptyNubList `fmap` ((liftM nub arbitrary) `suchThat` (not . null))
|
||||
arbitrary = NonEmptyNubList <$> ((nub <$> arbitrary) `suchThat` (not . null))
|
||||
|
||||
|
||||
|
||||
@ -116,7 +116,7 @@ arbitraryTag :: T -> Gen Tag
|
||||
arbitraryTag x = do
|
||||
let ts = tags x
|
||||
-- There must be at least 1 workspace, thus at least 1 tag.
|
||||
idx <- choose (0, (length ts) - 1)
|
||||
idx <- choose (0, length ts - 1)
|
||||
return $ ts!!idx
|
||||
|
||||
-- | Pull out an arbitrary window from a StackSet that is guaranteed to have a
|
||||
@ -136,5 +136,5 @@ arbitraryWindow :: NonEmptyWindowsStackSet -> Gen Window
|
||||
arbitraryWindow (NonEmptyWindowsStackSet x) = do
|
||||
let ws = allWindows x
|
||||
-- We know that there are at least 1 window in a NonEmptyWindowsStackSet.
|
||||
idx <- choose(0, (length ws) - 1)
|
||||
idx <- choose (0, length ws - 1)
|
||||
return $ ws!!idx
|
||||
|
||||
@ -64,7 +64,7 @@ prop_delete_focus_not_end = do
|
||||
-- last one in the stack.
|
||||
`suchThat` \(x' :: T) ->
|
||||
let currWins = index x'
|
||||
in length (currWins) >= 2 && peek x' /= Just (last currWins)
|
||||
in length currWins >= 2 && peek x' /= Just (last currWins)
|
||||
-- This is safe, as we know there are >= 2 windows
|
||||
let Just n = peek x
|
||||
return $ peek (delete n x) == peek (focusDown x)
|
||||
|
||||
@ -32,8 +32,8 @@ prop_focusWindow_master (NonNegative n) (x :: T) =
|
||||
in index (focusWindow (s !! i) x) == index x
|
||||
|
||||
-- shifting focus is trivially reversible
|
||||
prop_focus_left (x :: T) = (focusUp (focusDown x)) == x
|
||||
prop_focus_right (x :: T) = (focusDown (focusUp x)) == x
|
||||
prop_focus_left (x :: T) = focusUp (focusDown x) == x
|
||||
prop_focus_right (x :: T) = focusDown (focusUp x) == x
|
||||
|
||||
-- focus master is idempotent
|
||||
prop_focusMaster_idem (x :: T) = focusMaster x == focusMaster (focusMaster x)
|
||||
@ -47,9 +47,9 @@ prop_focusWindow_works (NonNegative (n :: Int)) (x :: T) =
|
||||
in (focus . fromJust . stack . workspace . current) (focusWindow (s !! i) x) == (s !! i)
|
||||
|
||||
-- rotation through the height of a stack gets us back to the start
|
||||
prop_focus_all_l (x :: T) = (foldr (const focusUp) x [1..n]) == x
|
||||
prop_focus_all_l (x :: T) = foldr (const focusUp) x [1..n] == x
|
||||
where n = length (index x)
|
||||
prop_focus_all_r (x :: T) = (foldr (const focusDown) x [1..n]) == x
|
||||
prop_focus_all_r (x :: T) = foldr (const focusDown) x [1..n] == x
|
||||
where n = length (index x)
|
||||
|
||||
-- prop_rotate_all (x :: T) = f (f x) == f x
|
||||
|
||||
@ -35,7 +35,7 @@ prop_greedyView_local (x :: T) = do
|
||||
-- greedyView is idempotent
|
||||
prop_greedyView_idem (x :: T) = do
|
||||
n <- arbitraryTag x
|
||||
return $ greedyView n (greedyView n x) == (greedyView n x)
|
||||
return $ greedyView n (greedyView n x) == greedyView n x
|
||||
|
||||
-- greedyView is reversible, though shuffles the order of hidden/visible
|
||||
prop_greedyView_reversible (x :: T) = do
|
||||
|
||||
@ -46,7 +46,7 @@ prop_insert_delete x = do
|
||||
|
||||
-- inserting n elements increases current stack size by n
|
||||
prop_size_insert is (EmptyStackSet x) =
|
||||
size (foldr insertUp x ws ) == (length ws)
|
||||
size (foldr insertUp x ws) == length ws
|
||||
where
|
||||
ws = nub is
|
||||
size = length . index
|
||||
|
||||
@ -29,6 +29,6 @@ prop_purelayout_full rect = do
|
||||
|
||||
-- what happens when we send an IncMaster message to Full --- Nothing
|
||||
prop_sendmsg_full (NonNegative k) =
|
||||
isNothing (Full `pureMessage` (SomeMessage (IncMasterN k)))
|
||||
isNothing (Full `pureMessage` SomeMessage (IncMasterN k))
|
||||
|
||||
prop_desc_full = description Full == show Full
|
||||
|
||||
@ -29,12 +29,12 @@ prop_tile_non_overlap rect windows nmaster = noOverlaps (tile pct rect nmaster w
|
||||
|
||||
-- splitting horizontally yields sensible results
|
||||
prop_split_horizontal (NonNegative n) x =
|
||||
(noOverflows (+) (rect_x x) (rect_width x)) ==>
|
||||
noOverflows (+) (rect_x x) (rect_width x) ==>
|
||||
sum (map rect_width xs) == rect_width x
|
||||
&&
|
||||
all (== rect_height x) (map rect_height xs)
|
||||
all (\s -> rect_height s == rect_height x) xs
|
||||
&&
|
||||
(map rect_x xs) == (sort $ map rect_x xs)
|
||||
map rect_x xs == sort (map rect_x xs)
|
||||
|
||||
where
|
||||
xs = splitHorizontally n x
|
||||
@ -72,7 +72,7 @@ prop_shrink_tall (NonNegative n) (Positive delta) (NonNegative frac) =
|
||||
-- remaining fraction should shrink
|
||||
where
|
||||
l1 = Tall n delta frac
|
||||
Just l2@(Tall n' delta' frac') = l1 `pureMessage` (SomeMessage Shrink)
|
||||
Just l2@(Tall n' delta' frac') = l1 `pureMessage` SomeMessage Shrink
|
||||
-- pureMessage :: layout a -> SomeMessage -> Maybe (layout a)
|
||||
|
||||
|
||||
@ -93,7 +93,7 @@ prop_expand_tall (NonNegative n)
|
||||
where
|
||||
frac = min 1 (n1 % d1)
|
||||
l1 = Tall n delta frac
|
||||
Just l2@(Tall n' delta' frac') = l1 `pureMessage` (SomeMessage Expand)
|
||||
Just l2@(Tall n' delta' frac') = l1 `pureMessage` SomeMessage Expand
|
||||
-- pureMessage :: layout a -> SomeMessage -> Maybe (layout a)
|
||||
|
||||
-- what happens when we send an IncMaster message to Tall
|
||||
@ -102,7 +102,7 @@ prop_incmaster_tall (NonNegative n) (Positive delta) (NonNegative frac)
|
||||
delta == delta' && frac == frac' && n' == n + k
|
||||
where
|
||||
l1 = Tall n delta frac
|
||||
Just l2@(Tall n' delta' frac') = l1 `pureMessage` (SomeMessage (IncMasterN k))
|
||||
Just l2@(Tall n' delta' frac') = l1 `pureMessage` SomeMessage (IncMasterN k)
|
||||
-- pureMessage :: layout a -> SomeMessage -> Maybe (layout a)
|
||||
|
||||
|
||||
|
||||
@ -53,8 +53,8 @@ prop_aspect_hint_shrink hint (w,h) = case applyAspectHint hint (w,h) of
|
||||
-- the desired range
|
||||
prop_aspect_fits =
|
||||
forAll ((,,,) <$> pos <*> pos <*> pos <*> pos) $ \ (x,y,a,b) ->
|
||||
let f v = applyAspectHint ((x, y+a), (x+b, y)) v
|
||||
in and [ noOverflows (*) x (y+a), noOverflows (*) (x+b) y ]
|
||||
let f = applyAspectHint ((x, y+a), (x+b, y))
|
||||
in noOverflows (*) x (y+a) && noOverflows (*) (x+b) y
|
||||
==> f (x,y) == (x,y)
|
||||
|
||||
where pos = choose (0, 65535)
|
||||
|
||||
@ -27,7 +27,7 @@ prop_shift_reversible (x :: T) = do
|
||||
-- shiftMaster
|
||||
|
||||
-- focus/local/idempotent same as swapMaster:
|
||||
prop_shift_master_focus (x :: T) = peek x == (peek $ shiftMaster x)
|
||||
prop_shift_master_focus (x :: T) = peek x == peek (shiftMaster x)
|
||||
prop_shift_master_local (x :: T) = hidden_spaces x == hidden_spaces (shiftMaster x)
|
||||
prop_shift_master_idempotent (x :: T) = shiftMaster (shiftMaster x) == shiftMaster x
|
||||
-- ordering is constant modulo the focused window:
|
||||
@ -57,14 +57,14 @@ prop_shift_win_fix_current = do
|
||||
x <- arbitrary `suchThat` \(x' :: T) ->
|
||||
-- Invariant, otherWindows are NOT in the current workspace.
|
||||
let otherWindows = allWindows x' L.\\ index x'
|
||||
in length(tags x') >= 2 && length(otherWindows) >= 1
|
||||
in length (tags x') >= 2 && not (null otherWindows)
|
||||
-- Sadly we have to construct `otherWindows` again, for the actual StackSet
|
||||
-- that got chosen.
|
||||
let otherWindows = allWindows x L.\\ index x
|
||||
-- We know such tag must exists, due to the precondition
|
||||
n <- arbitraryTag x `suchThat` (/= currentTag x)
|
||||
-- we know length is >= 1, from above precondition
|
||||
idx <- choose(0, length(otherWindows) - 1)
|
||||
idx <- choose (0, length otherWindows - 1)
|
||||
let w = otherWindows !! idx
|
||||
return $ (current $ x) == (current $ shiftWin n w x)
|
||||
return $ current x == current (shiftWin n w x)
|
||||
|
||||
|
||||
@ -1,6 +1,10 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
#ifdef VERSION_quickcheck_classes
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
#endif
|
||||
|
||||
module Properties.Stack where
|
||||
|
||||
import Test.QuickCheck
|
||||
@ -24,7 +28,7 @@ import Test.QuickCheck.Classes (
|
||||
-- windows kept in the zipper
|
||||
prop_index_length (x :: T) =
|
||||
case stack . workspace . current $ x of
|
||||
Nothing -> length (index x) == 0
|
||||
Nothing -> null (index x)
|
||||
Just it -> length (index x) == length (focus it : up it ++ down it)
|
||||
|
||||
|
||||
@ -43,7 +47,7 @@ prop_allWindowsMember (NonEmptyWindowsStackSet x) = do
|
||||
-- which is a key component in this test (together with member).
|
||||
let ws = allWindows x
|
||||
-- We know that there are at least 1 window in a NonEmptyWindowsStackSet.
|
||||
idx <- choose(0, (length ws) - 1)
|
||||
idx <- choose (0, length ws - 1)
|
||||
return $ member (ws!!idx) x
|
||||
|
||||
|
||||
@ -56,8 +60,8 @@ prop_filter_order (x :: T) =
|
||||
-- differentiate should return Nothing if the list is empty or Just stack, with
|
||||
-- the first element of the list is current, and the rest of the list is down.
|
||||
prop_differentiate xs =
|
||||
if null xs then differentiate xs == Nothing
|
||||
else (differentiate xs) == Just (Stack (head xs) [] (tail xs))
|
||||
if null xs then isNothing (differentiate xs)
|
||||
else differentiate xs == Just (Stack (head xs) [] (tail xs))
|
||||
where _ = xs :: [Int]
|
||||
|
||||
|
||||
|
||||
@ -58,7 +58,7 @@ invariant (s :: T) = and
|
||||
-- inBounds = and [ w >=0 && w < size s | (w,sc) <- M.assocs (screens s) ]
|
||||
|
||||
monotonic [] = True
|
||||
monotonic (x:[]) = True
|
||||
monotonic [x] = True
|
||||
monotonic (x:y:zs) | x == y-1 = monotonic (y:zs)
|
||||
| otherwise = False
|
||||
|
||||
@ -126,7 +126,7 @@ prop_empty (EmptyStackSet x) =
|
||||
prop_empty_current (EmptyStackSet x) = currentTag x == head (tags x)
|
||||
|
||||
-- no windows will be a member of an empty workspace
|
||||
prop_member_empty i (EmptyStackSet x) = member i x == False
|
||||
prop_member_empty i (EmptyStackSet x) = not (member i x)
|
||||
|
||||
-- peek either yields nothing on the Empty workspace, or Just a valid window
|
||||
prop_member_peek (x :: T) =
|
||||
|
||||
@ -11,8 +11,8 @@ import XMonad.StackSet hiding (filter)
|
||||
-- swapUp, swapDown, swapMaster: reordiring windows
|
||||
|
||||
-- swap is trivially reversible
|
||||
prop_swap_left (x :: T) = (swapUp (swapDown x)) == x
|
||||
prop_swap_right (x :: T) = (swapDown (swapUp x)) == x
|
||||
prop_swap_left (x :: T) = swapUp (swapDown x) == x
|
||||
prop_swap_right (x :: T) = swapDown (swapUp x) == x
|
||||
-- TODO swap is reversible
|
||||
-- swap is reversible, but involves moving focus back the window with
|
||||
-- master on it. easy to do with a mouse...
|
||||
@ -26,12 +26,12 @@ prop_promote_reversible x b = (not . null . fromMaybe [] . flip index x . curren
|
||||
-}
|
||||
|
||||
-- swap doesn't change focus
|
||||
prop_swap_master_focus (x :: T) = peek x == (peek $ swapMaster x)
|
||||
prop_swap_master_focus (x :: T) = peek x == peek (swapMaster x)
|
||||
-- = case peek x of
|
||||
-- Nothing -> True
|
||||
-- Just f -> focus (stack (workspace $ current (swap x))) == f
|
||||
prop_swap_left_focus (x :: T) = peek x == (peek $ swapUp x)
|
||||
prop_swap_right_focus (x :: T) = peek x == (peek $ swapDown x)
|
||||
prop_swap_left_focus (x :: T) = peek x == peek (swapUp x)
|
||||
prop_swap_right_focus (x :: T) = peek x == peek (swapDown x)
|
||||
|
||||
-- swap is local
|
||||
prop_swap_master_local (x :: T) = hidden_spaces x == hidden_spaces (swapMaster x)
|
||||
@ -39,9 +39,9 @@ prop_swap_left_local (x :: T) = hidden_spaces x == hidden_spaces (swapUp x)
|
||||
prop_swap_right_local (x :: T) = hidden_spaces x == hidden_spaces (swapDown x)
|
||||
|
||||
-- rotation through the height of a stack gets us back to the start
|
||||
prop_swap_all_l (x :: T) = (foldr (const swapUp) x [1..n]) == x
|
||||
prop_swap_all_l (x :: T) = foldr (const swapUp) x [1..n] == x
|
||||
where n = length (index x)
|
||||
prop_swap_all_r (x :: T) = (foldr (const swapDown) x [1..n]) == x
|
||||
prop_swap_all_r (x :: T) = foldr (const swapDown) x [1..n] == x
|
||||
where n = length (index x)
|
||||
|
||||
prop_swap_master_idempotent (x :: T) = swapMaster (swapMaster x) == swapMaster x
|
||||
|
||||
@ -37,7 +37,7 @@ prop_view_local (x :: T) = do
|
||||
-- view is idempotent
|
||||
prop_view_idem (x :: T) = do
|
||||
n <- arbitraryTag x
|
||||
return $ view n (view n x) == (view n x)
|
||||
return $ view n (view n x) == view n x
|
||||
|
||||
-- view is reversible, though shuffles the order of hidden/visible
|
||||
prop_view_reversible (x :: T) = do
|
||||
|
||||
@ -12,8 +12,8 @@ hidden_spaces x = map workspace (visible x) ++ hidden x
|
||||
-- normalise workspace list
|
||||
normal s = s { hidden = sortBy g (hidden s), visible = sortBy f (visible s) }
|
||||
where
|
||||
f = \a b -> tag (workspace a) `compare` tag (workspace b)
|
||||
g = \a b -> tag a `compare` tag b
|
||||
f a b = tag (workspace a) `compare` tag (workspace b)
|
||||
g a b = tag a `compare` tag b
|
||||
|
||||
|
||||
noOverlaps [] = True
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user