diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 6e61b4f..59d3f46 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -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 diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000..bed37de --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,2 @@ +# Ignore these warnings. +- ignore: {name: "Use camelCase"} diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 8c62418..90b2aca 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -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 diff --git a/man/xmonad.hs b/man/xmonad.hs index e63d91a..922ad07 100644 --- a/man/xmonad.hs +++ b/man/xmonad.hs @@ -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) ] diff --git a/src/XMonad/Config.hs b/src/XMonad/Config.hs index a450fbc..793096e 100644 --- a/src/XMonad/Config.hs +++ b/src/XMonad/Config.hs @@ -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) diff --git a/src/XMonad/Core.hs b/src/XMonad/Core.hs index f02081e..aff0857 100644 --- a/src/XMonad/Core.hs +++ b/src/XMonad/Core.hs @@ -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 -> diff --git a/src/XMonad/Layout.hs b/src/XMonad/Layout.hs index 90b4c68..ba7d3c3 100644 --- a/src/XMonad/Layout.hs +++ b/src/XMonad/Layout.hs @@ -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) = diff --git a/src/XMonad/Main.hs b/src/XMonad/Main.hs index da1d1f7..170a019 100644 --- a/src/XMonad/Main.hs +++ b/src/XMonad/Main.hs @@ -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 () diff --git a/src/XMonad/ManageHook.hs b/src/XMonad/ManageHook.hs index fb28d10..5e59d1b 100644 --- a/src/XMonad/ManageHook.hs +++ b/src/XMonad/ManageHook.hs @@ -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 diff --git a/src/XMonad/Operations.hs b/src/XMonad/Operations.hs index dd0241d..d012436 100644 --- a/src/XMonad/Operations.hs +++ b/src/XMonad/Operations.hs @@ -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,9 +480,9 @@ 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 } } } + windows $ const $ ss{ W.current = c{ W.workspace = ws{ W.layout = l } } } ------------------------------------------------------------------------ -- Utilities @@ -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 diff --git a/src/XMonad/StackSet.hs b/src/XMonad/StackSet.hs index 8e93a3d..53c7cd8 100644 --- a/src/XMonad/StackSet.hs +++ b/src/XMonad/StackSet.hs @@ -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' diff --git a/tests/Instances.hs b/tests/Instances.hs index e52c5ec..77d8fb5 100644 --- a/tests/Instances.hs +++ b/tests/Instances.hs @@ -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 diff --git a/tests/Properties/Delete.hs b/tests/Properties/Delete.hs index a8b8dd1..fed3409 100644 --- a/tests/Properties/Delete.hs +++ b/tests/Properties/Delete.hs @@ -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) diff --git a/tests/Properties/Focus.hs b/tests/Properties/Focus.hs index 6bc0055..a3ea84e 100644 --- a/tests/Properties/Focus.hs +++ b/tests/Properties/Focus.hs @@ -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 diff --git a/tests/Properties/GreedyView.hs b/tests/Properties/GreedyView.hs index 3f2eb9b..09dd1b8 100644 --- a/tests/Properties/GreedyView.hs +++ b/tests/Properties/GreedyView.hs @@ -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 diff --git a/tests/Properties/Insert.hs b/tests/Properties/Insert.hs index c277795..6730269 100644 --- a/tests/Properties/Insert.hs +++ b/tests/Properties/Insert.hs @@ -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 diff --git a/tests/Properties/Layout/Full.hs b/tests/Properties/Layout/Full.hs index eca6ec3..3bb8d60 100644 --- a/tests/Properties/Layout/Full.hs +++ b/tests/Properties/Layout/Full.hs @@ -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 diff --git a/tests/Properties/Layout/Tall.hs b/tests/Properties/Layout/Tall.hs index 5353e62..45cfe72 100644 --- a/tests/Properties/Layout/Tall.hs +++ b/tests/Properties/Layout/Tall.hs @@ -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) diff --git a/tests/Properties/Screen.hs b/tests/Properties/Screen.hs index b679fb9..b3d3468 100644 --- a/tests/Properties/Screen.hs +++ b/tests/Properties/Screen.hs @@ -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) diff --git a/tests/Properties/Shift.hs b/tests/Properties/Shift.hs index 2150cbf..144b19f 100644 --- a/tests/Properties/Shift.hs +++ b/tests/Properties/Shift.hs @@ -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) diff --git a/tests/Properties/Stack.hs b/tests/Properties/Stack.hs index 344c4c3..f85ca3e 100644 --- a/tests/Properties/Stack.hs +++ b/tests/Properties/Stack.hs @@ -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] diff --git a/tests/Properties/StackSet.hs b/tests/Properties/StackSet.hs index 7fc5192..0b1e8f1 100644 --- a/tests/Properties/StackSet.hs +++ b/tests/Properties/StackSet.hs @@ -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) = diff --git a/tests/Properties/Swap.hs b/tests/Properties/Swap.hs index a516f2c..fb8e529 100644 --- a/tests/Properties/Swap.hs +++ b/tests/Properties/Swap.hs @@ -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 diff --git a/tests/Properties/View.hs b/tests/Properties/View.hs index ef9b58d..fe56ba3 100644 --- a/tests/Properties/View.hs +++ b/tests/Properties/View.hs @@ -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 diff --git a/tests/Utils.hs b/tests/Utils.hs index e3eef0f..4ae4416 100644 --- a/tests/Utils.hs +++ b/tests/Utils.hs @@ -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