X.L.NoBorders: Add unit test for multihead floats

This commit is contained in:
Tomas Janousek 2021-01-26 22:17:11 +00:00
parent 9cff824a24
commit 48156cafb8
3 changed files with 78 additions and 0 deletions

View File

@ -4,6 +4,7 @@ import Test.Hspec
import Test.Hspec.QuickCheck
import qualified ManageDocks
import qualified NoBorders
import qualified RotateSome
import qualified Selective
import qualified SwapWorkspaces
@ -41,3 +42,4 @@ main = hspec $ do
prop "prop_split" $ XPrompt.prop_split
prop "prop_spliInSubListsAt" $ XPrompt.prop_spliInSubListsAt
prop "prop_skipGetLastWord" $ XPrompt.prop_skipGetLastWord
context "NoBorders" $ NoBorders.spec

74
tests/NoBorders.hs Normal file
View File

@ -0,0 +1,74 @@
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wall #-}
module NoBorders where
import Test.Hspec
import qualified Data.Map as M
import XMonad hiding (Screen)
import qualified XMonad.Layout.NoBorders as NB
import XMonad.StackSet
spec :: Spec
spec = do
describe "dualhead, fullscreen float on each" $ do
let s1 = differentiate [1]
let s2 = differentiate [2]
let floats = [(1, rrFull), (2, rrFull)]
let ws = wsDualHead s1 s2 floats
context "Ambiguity(Never)" $ do
let amb = NB.Never
it "removes border on current screen" $ do
NB.hiddens amb ws r1 s1 [] `shouldBe` [1]
NB.hiddens amb ws r3 s1 [] `shouldBe` [1]
it "removes border on visible screen" $ do
NB.hiddens amb ws r2 s2 [] `shouldBe` [2]
NB.hiddens amb ws r4 s2 [] `shouldBe` [2]
context "Ambiguity(OnlyScreenFloat)" $ do
let amb = NB.OnlyScreenFloat
it "removes border on current screen" $ do
NB.hiddens amb ws r1 s1 [] `shouldBe` [1]
NB.hiddens amb ws r3 s1 [] `shouldBe` [1]
it "removes border on visible screen" $ do
NB.hiddens amb ws r2 s2 [] `shouldBe` [2]
NB.hiddens amb ws r4 s2 [] `shouldBe` [2]
context "Ambiguity(OnlyLayoutFloat)" $ do
let amb = NB.OnlyLayoutFloat
it "removes border on current screen" $ do
NB.hiddens amb ws r1 s1 [] `shouldBe` [1]
it "removes border on visible screen" $ do
NB.hiddens amb ws r2 s2 [] `shouldBe` [2]
-- +------+------+
-- | r1 | r2 |
-- | | |
-- |+----+|+----+|
-- || r3 ||| r4 ||
-- |+----+|+----+|
-- +------+------+
r1, r2, r3, r4 :: Rectangle
r1 = Rectangle 0 0 100 100
r2 = Rectangle 100 0 100 100
r3 = Rectangle 10 10 80 80
r4 = Rectangle 110 10 80 80
rrFull :: RationalRect
rrFull = RationalRect 0 0 1 1
-- | Current screen @r1@ with window stack @w1@,
-- visible screen @r2@ with ws @w2@,
-- no hidden screens, maybe some floats.
wsDualHead :: Maybe (Stack Window) -> Maybe (Stack Window)
-> [(Window, RationalRect)] -> WindowSet
wsDualHead w1 w2 f = StackSet{..}
where
current = mkScreen 1 r1 w1; visible = [mkScreen 2 r2 w2]; hidden = []
floating = M.fromList f
mkScreen :: ScreenId -> Rectangle -> Maybe (Stack Window)
-> Screen WorkspaceId l Window ScreenId ScreenDetail
mkScreen i r s = Screen{ workspace = w, screen = i, screenDetail = sd }
where
w = Workspace{ tag = show i, layout = undefined, stack = s }
sd = SD{ screenRect = r }

View File

@ -366,6 +366,7 @@ test-suite tests
type: exitcode-stdio-1.0
main-is: Main.hs
other-modules: ManageDocks
NoBorders
RotateSome
Selective
SwapWorkspaces
@ -382,6 +383,7 @@ test-suite tests
XMonad.Hooks.WorkspaceHistory
XMonad.Layout.LayoutModifier
XMonad.Layout.LimitWindows
XMonad.Layout.NoBorders
XMonad.Prompt
XMonad.Prompt.Shell
XMonad.Util.ExtensibleState