Skip to content

Commit

Permalink
Fix partial uses of head
Browse files Browse the repository at this point in the history
Fixes: #830
Related: #836
  • Loading branch information
slotThe committed Oct 28, 2023
1 parent 42179b8 commit 105e529
Showing 21 changed files with 142 additions and 105 deletions.
9 changes: 5 additions & 4 deletions XMonad/Actions/GridSelect.hs
Original file line number Diff line number Diff line change
@@ -97,6 +97,7 @@ import XMonad.Actions.WindowBringer (bringWindow)
import Text.Printf
import System.Random (mkStdGen, randomR)
import Data.Word (Word8)
import qualified Data.List.NonEmpty as NE

-- $usage
--
@@ -302,14 +303,14 @@ diamondLayer n =
r = tr ++ map (\(x,y) -> (y,-x)) tr
in r ++ map (negate *** negate) r

diamond :: (Enum a, Num a, Eq a) => [(a, a)]
diamond = concatMap diamondLayer [0..]
diamond :: (Enum a, Num a, Eq a) => Stream (a, a)
diamond = fromList $ concatMap diamondLayer [0..]

diamondRestrict :: Integer -> Integer -> Integer -> Integer -> [(Integer, Integer)]
diamondRestrict x y originX originY =
L.filter (\(x',y') -> abs x' <= x && abs y' <= y) .
map (\(x', y') -> (x' + fromInteger originX, y' + fromInteger originY)) .
take 1000 $ diamond
takeS 1000 $ diamond

findInElementMap :: (Eq a) => a -> [(a, b)] -> Maybe (a, b)
findInElementMap pos = find ((== pos) . fst)
@@ -658,7 +659,7 @@ gridselect gsconfig elements =
originPosX = floor $ (gs_originFractX gsconfig - (1/2)) * 2 * fromIntegral restrictX
originPosY = floor $ (gs_originFractY gsconfig - (1/2)) * 2 * fromIntegral restrictY
coords = diamondRestrict restrictX restrictY originPosX originPosY
s = TwoDState { td_curpos = head coords,
s = TwoDState { td_curpos = NE.head (notEmpty coords),
td_availSlots = coords,
td_elements = elements,
td_gsconfig = gsconfig,
3 changes: 2 additions & 1 deletion XMonad/Actions/Navigation2D.hs
Original file line number Diff line number Diff line change
@@ -66,6 +66,7 @@ import qualified XMonad.StackSet as W
import qualified XMonad.Util.ExtensibleState as XS
import XMonad.Util.EZConfig (additionalKeys, additionalKeysP)
import XMonad.Util.Types
import qualified Data.List.NonEmpty as NE

-- $usage
-- #Usage#
@@ -883,7 +884,7 @@ swap win winset = W.focusWindow cur
-- Reconstruct the workspaces' window stacks to reflect the swap.
newvisws = zipWith (\ws wns -> ws { W.stack = W.differentiate wns }) visws newwins
newscrs = zipWith (\scr ws -> scr { W.workspace = ws }) scrs newvisws
newwinset = winset { W.current = head newscrs
newwinset = winset { W.current = NE.head (notEmpty newscrs) -- Always at least one screen.
, W.visible = drop 1 newscrs
}

12 changes: 7 additions & 5 deletions XMonad/Actions/Prefix.hs
Original file line number Diff line number Diff line change
@@ -41,6 +41,8 @@ import XMonad.Util.ExtensibleState as XS
import XMonad.Util.Paste (sendKey)
import XMonad.Actions.Submap (submapDefaultWithKey)
import XMonad.Util.EZConfig (readKeySequence)
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty ((<|))

{- $usage
@@ -129,7 +131,7 @@ usePrefixArgument :: LayoutClass l Window
-> XConfig l
-> XConfig l
usePrefixArgument prefix conf =
conf{ keys = M.insert binding (handlePrefixArg [binding]) . keys conf }
conf{ keys = M.insert binding (handlePrefixArg (binding :| [])) . keys conf }
where
binding = case readKeySequence conf prefix of
Just (key :| []) -> key
@@ -141,7 +143,7 @@ useDefaultPrefixArgument :: LayoutClass l Window
-> XConfig l
useDefaultPrefixArgument = usePrefixArgument "C-u"

handlePrefixArg :: [(KeyMask, KeySym)] -> X ()
handlePrefixArg :: NonEmpty (KeyMask, KeySym) -> X ()
handlePrefixArg events = do
ks <- asks keyActions
logger <- asks (logHook . config)
@@ -162,12 +164,12 @@ handlePrefixArg events = do
Raw _ -> XS.put $ Numeric x
Numeric a -> XS.put $ Numeric $ a * 10 + x
None -> return () -- should never happen
handlePrefixArg (key:events)
handlePrefixArg (key <| events)
else do
prefix <- XS.get
mapM_ (uncurry sendKey) $ case prefix of
Raw a -> replicate a (head events) ++ [key]
_ -> reverse (key:events)
Raw a -> replicate a (NE.head events) ++ [key]
_ -> reverse (key : toList events)
keyToNum = (xK_0, 0) : zip [xK_1 .. xK_9] [1..9]

-- | Turn a prefix-aware X action into an X-action.
8 changes: 5 additions & 3 deletions XMonad/Actions/ShowText.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Actions.ShowText
@@ -26,7 +27,7 @@ module XMonad.Actions.ShowText
import Data.Map (Map,empty,insert,lookup)
import Prelude hiding (lookup)
import XMonad
import XMonad.Prelude (All, fi, when)
import XMonad.Prelude (All, fi, listToMaybe)
import XMonad.StackSet (current,screen)
import XMonad.Util.Font (Align(AlignCenter)
, initXMF
@@ -87,8 +88,9 @@ handleTimerEvent :: Event -> X All
handleTimerEvent (ClientMessageEvent _ _ _ dis _ mtyp d) = do
(ShowText m) <- ES.get :: X ShowText
a <- io $ internAtom dis "XMONAD_TIMER" False
when (mtyp == a && not (null d))
(whenJust (lookup (fromIntegral $ head d) m) deleteWindow)
if | mtyp == a, Just dh <- listToMaybe d ->
whenJust (lookup (fromIntegral dh) m) deleteWindow
| otherwise -> pure ()
mempty
handleTimerEvent _ = mempty

5 changes: 3 additions & 2 deletions XMonad/Actions/SwapPromote.hs
Original file line number Diff line number Diff line change
@@ -63,6 +63,7 @@ import qualified XMonad.Util.ExtensibleState as XS
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Arrow
import qualified Data.List.NonEmpty as NE


-- $usage
@@ -240,8 +241,8 @@ swapApply ignoreFloats swapFunction = do
(r,s2) = stackSplit s1 fl' :: ([(Int,Window)],W.Stack Window)
(b,s3) = swapFunction pm s2
s4 = stackMerge s3 r
mh = let w = head . W.integrate $ s3
in const $ w : delete w ch
mh = let w = NE.head . notEmpty . W.integrate $ s3
in const $ w : delete w ch
in (b,Just s4,mh)
(x,y,z) = maybe (False,Nothing,id) swapApply' st
-- Any floating master windows will be added to the history when 'windows'
10 changes: 8 additions & 2 deletions XMonad/Actions/WindowGo.hs
Original file line number Diff line number Diff line change
@@ -48,6 +48,8 @@ import XMonad.Operations (windows)
import XMonad.Prompt.Shell (getBrowser, getEditor)
import qualified XMonad.StackSet as W (peek, swapMaster, focusWindow, workspaces, StackSet, Workspace, integrate', tag, stack)
import XMonad.Util.Run (safeSpawnProg)
import qualified Data.List.NonEmpty as NE

{- $usage
Import the module into your @~\/.xmonad\/xmonad.hs@:
@@ -90,7 +92,10 @@ ifWindows qry f el = withWindowSet $ \wins -> do
-- | The same as ifWindows, but applies a ManageHook to the first match
-- instead and discards the other matches
ifWindow :: Query Bool -> ManageHook -> X () -> X ()
ifWindow qry mh = ifWindows qry (windows . appEndo <=< runQuery mh . head)
ifWindow qry mh = ifWindows qry (windows . appEndo <=< runQuery mh . NE.head . notEmpty)
-- ifWindows guarantees that the list given to the function is
-- non-empty. This should really use Data.List.NonEmpty, but, alas,
-- that would be a breaking change.

{- | 'action' is an executable to be run via 'safeSpawnProg' (of "XMonad.Util.Run") if the Window cannot be found.
Presumably this executable is the same one that you were looking for.
@@ -165,7 +170,8 @@ raiseNextMaybeCustomFocus focusFn f qry = flip (ifWindows qry) f $ \ws -> do
let (notEmpty -> _ :| (notEmpty -> y :| _)) = dropWhile (/=w) $ cycle ws
-- cannot fail to match
in windows $ focusFn y
_ -> windows . focusFn . head $ ws
_ -> windows . focusFn . NE.head . notEmpty $ ws
-- ws is non-empty by ifWindows's definition.

-- | Given a function which gets us a String, we try to raise a window with that classname,
-- or we then interpret that String as a executable name.
5 changes: 3 additions & 2 deletions XMonad/Actions/Workscreen.hs
Original file line number Diff line number Diff line change
@@ -109,5 +109,6 @@ shiftWs a = drop 1 a ++ take 1 a
-- @WorkscreenId@.
shiftToWorkscreen :: WorkscreenId -> X ()
shiftToWorkscreen wscrId = do (WorkscreenStorage _ a) <- XS.get
let ws = head . workspaces $ a !! wscrId
windows $ W.shift ws
case workspaces (a !! wscrId) of
[] -> pure ()
(w : _) -> windows $ W.shift w
8 changes: 4 additions & 4 deletions XMonad/Actions/WorkspaceCursors.hs
Original file line number Diff line number Diff line change
@@ -95,10 +95,10 @@ import XMonad.Prelude

-- | makeCursors requires a nonempty string, and each sublist must be nonempty
makeCursors :: [[String]] -> Cursors String
makeCursors [] = error "Workspace Cursors cannot be empty"
makeCursors a = concat . reverse <$> foldl addDim x xs
where x = end $ map return $ head a
xs = map (map return) $ drop 1 a
makeCursors [] = error "Workspace Cursors cannot be empty"
makeCursors (a : as) = concat . reverse <$> foldl addDim x xs
where x = end $ map return a
xs = map (map return) as
-- this could probably be simplified, but this true:
-- toList . makeCursors == map (concat . reverse) . sequence . reverse . map (map (:[]))
-- the strange order is used because it makes the regular M-1..9
10 changes: 6 additions & 4 deletions XMonad/Hooks/Minimize.hs
Original file line number Diff line number Diff line change
@@ -43,10 +43,12 @@ minimizeEventHook ClientMessageEvent{ev_window = w,
a_cs <- getAtom "WM_CHANGE_STATE"

when (mt == a_aw) $ maximizeWindow w
when (mt == a_cs) $ do
let message = fromIntegral . head $ dt
when (message == normalState) $ maximizeWindow w
when (message == iconicState) $ minimizeWindow w
when (mt == a_cs) $ case listToMaybe dt of
Nothing -> pure ()
Just dth -> do
let message = fromIntegral dth
when (message == normalState) $ maximizeWindow w
when (message == iconicState) $ minimizeWindow w

return (All True)
minimizeEventHook _ = return (All True)
23 changes: 12 additions & 11 deletions XMonad/Hooks/Place.hs
Original file line number Diff line number Diff line change
@@ -186,21 +186,22 @@ placeHook p = do window <- ask
-- spawned. Each of them also needs an associated screen
-- rectangle; for hidden workspaces, we use the current
-- workspace's screen.
let infos = filter ((window `elem`) . stackContents . S.stack . fst)
let infos = find ((window `elem`) . stackContents . S.stack . fst)
$ [screenInfo $ S.current theWS]
++ map screenInfo (S.visible theWS)
++ map (, currentRect) (S.hidden theWS)

guard(not $ null infos)

let (workspace, screen) = head infos
rs = mapMaybe (`M.lookup` allRs)
$ organizeClients workspace window floats
r' = purePlaceWindow p screen rs pointer r
newRect = r2rr screen r'
newFloats = M.insert window newRect (S.floating theWS)

return $ theWS { S.floating = newFloats }
case infos of
Nothing -> empty
Just info -> do
let (workspace, screen) = info
rs = mapMaybe (`M.lookup` allRs)
$ organizeClients workspace window floats
r' = purePlaceWindow p screen rs pointer r
newRect = r2rr screen r'
newFloats = M.insert window newRect (S.floating theWS)

return $ theWS { S.floating = newFloats }


placeWindow :: Placement -> Window
16 changes: 9 additions & 7 deletions XMonad/Hooks/ServerMode.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE MultiWayIf #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Hooks.ServerMode
@@ -89,13 +90,14 @@ serverModeEventHookCmd' cmdAction = serverModeEventHookF "XMONAD_COMMAND" (mapM_
--
serverModeEventHookF :: String -> (String -> X ()) -> Event -> X All
serverModeEventHookF key func ClientMessageEvent {ev_message_type = mt, ev_data = dt} = do
d <- asks display
atm <- io $ internAtom d key False
when (mt == atm && dt /= []) $ do
let atom = fromIntegral (head dt)
d <- asks display
atm <- io $ internAtom d key False
if | mt == atm, Just dth <- listToMaybe dt -> do
let atom = fromIntegral dth
cmd <- io $ getAtomName d atom
case cmd of
Just command -> func command
Nothing -> io $ hPutStrLn stderr ("Couldn't retrieve atom " ++ show atom)
return (All True)
Just command -> func command
Nothing -> io $ hPutStrLn stderr ("Couldn't retrieve atom " ++ show atom)
| otherwise -> pure ()
return (All True)
serverModeEventHookF _ _ _ = return (All True)
9 changes: 7 additions & 2 deletions XMonad/Hooks/StatusBar/PP.hs
Original file line number Diff line number Diff line change
@@ -57,6 +57,7 @@ module XMonad.Hooks.StatusBar.PP (

import Control.Monad.Reader
import Control.DeepSeq
import qualified Data.List.NonEmpty as NE

import XMonad
import XMonad.Prelude
@@ -463,8 +464,12 @@ xmobarStrip :: String -> String
xmobarStrip = converge (xmobarStripTags ["fc","icon","action"])

converge :: (Eq a) => (a -> a) -> a -> a
converge f a = let xs = iterate f a
in fst $ head $ dropWhile (uncurry (/=)) $ zip xs $ drop 1 xs
converge f a
= fst . NE.head . notEmpty -- If this function terminates, we will find a match.
. dropWhile (uncurry (/=))
. zip xs
$ drop 1 xs
where xs = iterate f a

xmobarStripTags :: [String] -- ^ tags
-> String -> String -- ^ with all \<tag\>...\</tag\> removed
8 changes: 4 additions & 4 deletions XMonad/Layout/Combo.hs
Original file line number Diff line number Diff line change
@@ -28,7 +28,7 @@ module XMonad.Layout.Combo (

import XMonad hiding (focus)
import XMonad.Layout.WindowNavigation (MoveWindowToWindow (..))
import XMonad.Prelude (delete, fromMaybe, intersect, isJust, (\\))
import XMonad.Prelude (delete, fromMaybe, intersect, isJust, (\\), listToMaybe)
import XMonad.StackSet (Stack (..), Workspace (..), integrate')
import XMonad.Util.Stack (zipperFocusedAtFirstOf)

@@ -124,9 +124,9 @@ instance (LayoutClass l (), LayoutClass l1 a, LayoutClass l2 a, Read a, Show a,
msuper' <- broadcastPrivate m [super]
if isJust msuper' || isJust ml1' || isJust ml2'
then return $ Just $ C2 f ws2
(maybe super head msuper')
(maybe l1 head ml1')
(maybe l2 head ml2')
(fromMaybe super (listToMaybe =<< msuper'))
(fromMaybe l1 (listToMaybe =<< ml1'))
(fromMaybe l2 (listToMaybe =<< ml2'))
else return Nothing
description (C2 _ _ super l1 l2) = "combining "++ description l1 ++" and "++
description l2 ++" with "++ description super
2 changes: 1 addition & 1 deletion XMonad/Layout/MultiColumns.hs
Original file line number Diff line number Diff line change
@@ -97,7 +97,7 @@ instance LayoutClass MultiCol a where
where resize Shrink = l { multiColSize = max (-0.5) $ s-ds }
resize Expand = l { multiColSize = min 1 $ s+ds }
incmastern (IncMasterN x) = l { multiColNWin = take a n ++ [newval] ++ drop 1 r }
where newval = max 0 $ head r + x
where newval = max 0 $ maybe 0 (x +) (listToMaybe r)
r = drop a n
n = multiColNWin l
ds = multiColDeltaSize l
36 changes: 19 additions & 17 deletions XMonad/Layout/OneBig.hs
Original file line number Diff line number Diff line change
@@ -55,23 +55,25 @@ oneBigMessage (OneBig cx cy) m = fmap resize (fromMessage m)

-- | Main layout function
oneBigLayout :: OneBig a -> Rectangle -> W.Stack a -> [(a, Rectangle)]
oneBigLayout (OneBig cx cy) rect stack = [(master,masterRect)]
++ divideBottom bottomRect bottomWs
++ divideRight rightRect rightWs
where ws = W.integrate stack
n = length ws
ht (Rectangle _ _ _ hh) = hh
wd (Rectangle _ _ ww _) = ww
h' = round (fromIntegral (ht rect)*cy)
w = wd rect
m = calcBottomWs n w h'
master = head ws
other = drop 1 ws
bottomWs = take m other
rightWs = drop m other
masterRect = cmaster n m cx cy rect
bottomRect = cbottom cy rect
rightRect = cright cx cy rect
oneBigLayout (OneBig cx cy) rect stack =
let ws = W.integrate stack
n = length ws
in case ws of
[] -> []
(master : other) -> [(master,masterRect)]
++ divideBottom bottomRect bottomWs
++ divideRight rightRect rightWs
where
ht (Rectangle _ _ _ hh) = hh
wd (Rectangle _ _ ww _) = ww
h' = round (fromIntegral (ht rect)*cy)
w = wd rect
m = calcBottomWs n w h'
bottomWs = take m other
rightWs = drop m other
masterRect = cmaster n m cx cy rect
bottomRect = cbottom cy rect
rightRect = cright cx cy rect

-- | Calculate how many windows must be placed at bottom
calcBottomWs :: Int -> Dimension -> Dimension -> Int
Loading
Oops, something went wrong.

0 comments on commit 105e529

Please sign in to comment.