Skip to content

Commit

Permalink
update workspace
Browse files Browse the repository at this point in the history
  • Loading branch information
@WeissP
WeissP committed Feb 16, 2024
1 parent 9d736fe commit d33979f
Show file tree
Hide file tree
Showing 2 changed files with 123 additions and 101 deletions.
4 changes: 2 additions & 2 deletions src/WeissXMonad.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -217,8 +217,8 @@ myManageHook =
composeAll
( concat
[ [isDialog --> doFloat]
, [className =? "Mattermost" --> doShift "聊"]
, [className =? "P3X OneNote" --> doShift "记"]
, [className =? "Mattermost" --> doShift "聊2"]
, [className =? "p3x-onenote" --> doShift "记3"]
, [className =? x --> doIgnore | x <- myIgnoreClass]
, [className =? x --> doHideIgnore | x <- myHideIgnoreClass]
, [className =? x --> doCenterFloat | x <- myCenterFloatClass]
Expand Down
220 changes: 121 additions & 99 deletions src/WorkspaceFamily.hs
View file
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
module WorkspaceFamily (myWorkspaces, workspaceKeys, logWorkspaceFamilies) where

import Control.Monad (when)
import Control.Monad.Extra (fromMaybeM)
import Control.Monad.Extra (fromMaybeM, pureIf)
import Control.Monad.Trans.Maybe
import Data.Bifunctor (Bifunctor (first))
import Data.Foldable (traverse_)
Expand All @@ -18,7 +18,7 @@ import Data.List (
singleton,
sort,
)
import Data.List.Extra (cons, snoc)
import Data.List.Extra (cons, firstJust, snoc)
import Data.Maybe (catMaybes, mapMaybe)
import Data.Maybe.Utils (forceMaybe)
import Data.String (IsString)
Expand All @@ -39,104 +39,122 @@ type Key = String
type FamilyName = String
type FamilyNum = Int

data Family = NumFamily FamilyNum | LabeledFamily FamilyName Key deriving (Show)
allFamilyNums = [1 .. 9]
allFamilies =
(NumFamily <$> allFamilyNums)
<> ( uncurry LabeledFamily
<$> [ ("览", "<Down>")
, ("邮", "h")
, ("媒", "<Up>")
, ("聊", "y")
, ("设", "n")
, ("记", "-")
, (scratchpadWorkspaceTag, "0")
]
)
myWorkspaces = [idWithMember f m | f <- allFamilies, m <- allFamilyMembers]

data WsEffect = WsEffect {runWsEffect :: WorkspaceId -> X (), mayActiviate :: Bool}
instance Semigroup WsEffect where
x <> y =
WsEffect
(\ws -> runWsEffect x ws >> runWsEffect y ws)
(mayActiviate x || mayActiviate y)

type FamilyOrder = Int -- zero based
newtype OrderedFamilies = OrderedFamilies [FamilyNum] deriving newtype (Show)
instance ExtensionClass OrderedFamilies where
initialValue = OrderedFamilies allFamilyNums

class Node n where
fullID :: n -> X WorkspaceId
onActivate :: n -> X ()
runOn :: WsEffect -> n -> X ()
(WsEffect {..}) `runOn` n = when mayActiviate (onActivate n) >> fullID n >>= runWsEffect
nodeKeys :: n -> [Key]

instance Node Family where
newtype NumberedFamily = NumberedFamily Int deriving newtype (Show, Eq)
allNumberedFamilies = NumberedFamily <$> [1 .. 9]
instance Family NumberedFamily where
fName = show
fPrefix nf = fName nf <> "."
idWithMember nf = (fPrefix nf <>) . show
hasWorkspace f ws = fPrefix f `isPrefixOf` ws
instance Node NumberedFamily where
workspaceID = fullID
onActivate n = currentNumberedFamily >>= swapOrderedNumFamilies n
nodeKeys (NumberedFamily n) = ["<Return>", numToKey n]

currentNumberedFamily :: X NumberedFamily
currentNumberedFamily = fromMaybeM (pure $ head allNumberedFamilies) $ runMaybeT $ do
ws <- MaybeT logCurrent
MaybeT $ pure $ find (`hasWorkspace` ws) allNumberedFamilies

swapOrderedNumFamilies :: NumberedFamily -> NumberedFamily -> X ()
swapOrderedNumFamilies a b = XS.modify $ \(OrderedNumFamilies fs) -> OrderedNumFamilies $ swapElements a b fs

data LabeledFamily = LabeledFamily FamilyName Key deriving (Show)
allLabeledFamilies =
uncurry LabeledFamily
<$> [ ("览", "<Down>")
, ("邮", "h")
, ("媒", "<Up>")
, ("聊", "y")
, ("设", "n")
, ("记", "-")
]

instance Family LabeledFamily where
fName (LabeledFamily name _) = name
fPrefix = fName

instance Node LabeledFamily where
workspaceID = fullID
onActivate _ = pure ()
nodeKeys (LabeledFamily _ key) = [key]

class Family a where
fName :: a -> FamilyName
fPrefix :: a -> String
idWithMember :: a -> FamilyMember -> WorkspaceId
idWithMember f = (fPrefix f <>) . show
hasWorkspace :: a -> WorkspaceId -> Bool
hasWorkspace f ws = fPrefix f `isPrefixOf` ws
fullID :: a -> X WorkspaceId
fullID f = storedFamilyMember (fName f) <&> idWithMember f
onActivate (LabeledFamily _ _) = pure ()
onActivate (NumFamily n) = currentFamilyNum >>= swapOrderedFamilies n
nodeKeys (LabeledFamily _ k) = [k]
nodeKeys (NumFamily n) = ["<Return>", numToKey n]

nthNumFamily :: FamilyOrder -> X FamilyNum
nthNumFamily idx = do
(OrderedFamilies fs) <- XS.get
return $ fs !! idx

newtype FamilyStore = FamilyStore (HashMap FamilyName FamilyMember)
instance ExtensionClass FamilyStore where
initialValue = FamilyStore $ M.fromList ((,FamilyMember 1) . fName <$> allFamilies)
data GFamily = forall a. (Family a) => GFamily a
instance Family GFamily where
fName (GFamily f) = fName f
fPrefix (GFamily f) = fPrefix f

storedFamilyMember :: FamilyName -> X FamilyMember
storedFamilyMember name =
XS.get <&> \(FamilyStore hm) -> forceMaybe $ M.lookup name hm
allFamilies :: [GFamily]
allFamilies = (allLabeledFamilies <&> GFamily) <> (allNumberedFamilies <&> GFamily)

updateFamilyStore :: FamilyName -> FamilyMember -> X ()
updateFamilyStore name m = XS.modify $ \(FamilyStore hm) -> FamilyStore $ M.insert name m hm
allFamiliyNames :: [FamilyName]
allFamiliyNames = allFamilies <&> fName

currentFamily :: X Family
currentFamily :: X GFamily
currentFamily = fromMaybeM (pure $ head allFamilies) $ runMaybeT $ do
ws <- MaybeT logCurrent
MaybeT $ pure $ find (`hasWorkspace` ws) allFamilies

currentFamilyNum :: X FamilyNum
currentFamilyNum =
currentFamily >>= \case
NumFamily n -> pure n
LabeledFamily _ _ -> XS.get <&> \(OrderedFamilies fs) -> head fs

logWorkspaceFamilies :: Logger
logWorkspaceFamilies = do
OrderedFamilies nums <- XS.get
ids <- traverse (fullID . NumFamily) (take 3 nums)
return $ Just $ intercalate "→" ids

-- 1 based
newtype FamilyMember = FamilyMember Int deriving newtype (Show)
allFamilyMembers = FamilyMember <$> [1 .. 6]
allFamilyMembers = FamilyMember <$> [1 .. 9]
instance Node FamilyMember where
workspaceID m = currentFamily <&> (`idWithMember` m)
onActivate m = currentFamily >>= (`updateFamilyStore` m) . fName
nodeKeys (FamilyMember m) = ["<End>", numToKey m]

instance Node (FamilyOrder, FamilyMember) where
fullID (idx, m) = nthNumFamily idx <&> (`idWithMember` m) . NumFamily
onActivate (idx, m) = nthNumFamily idx >>= (`updateFamilyStore` m) . fName . NumFamily
workspaceID (idx, m) = nthNumberedFamily idx <&> (`idWithMember` m)
onActivate (idx, m) = nthNumberedFamily idx >>= (`updateFamilyStore` m) . fName
nodeKeys (idx, FamilyMember m) = singleton $ numToKey $ m + [0, 6, 9] !! idx

newtype CurrentFamilyMember = CurrentFamilyMember FamilyMember
instance Node (LabeledFamily, FamilyMember) where
workspaceID = pure . uncurry idWithMember
onActivate (f, m) = updateFamilyStore (fName f) m
nodeKeys (f, FamilyMember m) = "<End>" : nodeKeys f `snoc` numToKey m

class Node n where
workspaceID :: n -> X WorkspaceId
onActivate :: n -> X ()
runOn :: WsEffect -> n -> X ()
(WsEffect {..}) `runOn` n = when mayActiviate (onActivate n) >> workspaceID n >>= runWsEffect
nodeKeys :: n -> [Key]

data WsEffect = WsEffect {runWsEffect :: WorkspaceId -> X (), mayActiviate :: Bool}
instance Semigroup WsEffect where
x <> y =
WsEffect
(\ws -> runWsEffect x ws >> runWsEffect y ws)
(mayActiviate x || mayActiviate y)

type FamilyOrder = Int -- zero based
newtype OrderedNumFamilies = OrderedNumFamilies [NumberedFamily]
deriving newtype (Show)
instance Node CurrentFamilyMember where
fullID (CurrentFamilyMember m) = currentFamily <&> (`idWithMember` m)
onActivate (CurrentFamilyMember m) = currentFamily >>= (`updateFamilyStore` m) . fName
nodeKeys (CurrentFamilyMember (FamilyMember m)) = ["<End>", numToKey m]
instance ExtensionClass OrderedNumFamilies where
initialValue = OrderedNumFamilies allNumberedFamilies

newtype FamilyStore = FamilyStore (HashMap FamilyName FamilyMember)
instance ExtensionClass FamilyStore where
initialValue = FamilyStore $ M.fromList ((,FamilyMember 1) <$> allFamiliyNames)

workspaceKeys' :: [([String], X ())]
workspaceKeys' =
[ op prefix effect
| op <-
make membersWithOrder
<> make (CurrentFamilyMember <$> allFamilyMembers)
<> make allFamilies
<> make allFamilyMembers
<> make allNumberedFamilies
<> make allLabeledFamilies
<> make labeldFamilyMember
, (prefix, effect) <-
[ ([], switch)
, (["<Escape>"], shift)
Expand All @@ -148,8 +166,8 @@ workspaceKeys' =
toPair n effPrefix eff = (effPrefix <> nodeKeys n, eff `runOn` n)
make nodes = toPair <$> nodes
membersWithOrder :: [(FamilyOrder, FamilyMember)] =
(allFamilyMembers <&> (0,)) <> (take 3 allFamilyMembers <&> (1,))

(take 6 allFamilyMembers <&> (0,)) <> (take 3 allFamilyMembers <&> (1,))
labeldFamilyMember = [(f, m) | f <- allLabeledFamilies, m <- allFamilyMembers]
switch = WsEffect (windows . W.greedyView) True
shift = WsEffect (windows . W.shift) False
switchOrFocus = WsEffect Op.switchOrFocus True
Expand All @@ -158,30 +176,34 @@ workspaceKeys' =
workspaceKeys :: [(String, X ())]
workspaceKeys = fmap (first $ unwords . cons "<XF86Launch7>") workspaceKeys'

fName :: Family -> FamilyName
fName (NumFamily num) = show num
fName (LabeledFamily name _) = name

fPrefix :: Family -> String
fPrefix nf@(NumFamily _) = fName nf <> "."
fPrefix lf@(LabeledFamily _ _) = fName lf

idWithMember :: Family -> FamilyMember -> WorkspaceId
idWithMember (LabeledFamily name _) (FamilyMember 1) = name
idWithMember f m = fPrefix f <> show m

hasWorkspace :: Family -> WorkspaceId -> Bool
hasWorkspace f ws = fPrefix f `isPrefixOf` ws
storedFamilyMember :: FamilyName -> X FamilyMember
storedFamilyMember name =
XS.get <&> \(FamilyStore hm) -> forceMaybe $ M.lookup name hm

numToKey :: Int -> String
numToKey s = ["m", ",", ".", "j", "k", "l", "u", "i", "o", "-"] !! (s - 1)
nthNumberedFamily :: FamilyOrder -> X NumberedFamily
nthNumberedFamily idx = do
(OrderedNumFamilies fs) <- XS.get
return $ fs !! idx

swapOrderedFamilies :: FamilyNum -> FamilyNum -> X ()
swapOrderedFamilies a b = XS.modify $ \(OrderedFamilies fs) -> OrderedFamilies $ swapElements a b fs
updateFamilyStore :: FamilyName -> FamilyMember -> X ()
updateFamilyStore name m = XS.modify $ \(FamilyStore hm) -> FamilyStore $ M.insert name m hm

swapElements :: (Eq a) => a -> a -> [a] -> [a]
swapElements _ _ [] = []
swapElements n m (x : xs)
| n == x = m : swapElements n m xs
| m == x = n : swapElements n m xs
| otherwise = x : swapElements n m xs

numToKey :: Int -> String
numToKey s = ["m", ",", ".", "j", "k", "l", "u", "i", "o", "-"] !! (s - 1)

myWorkspaces =
scratchpadWorkspaceTag
: [idWithMember f m | f <- allFamilies, m <- allFamilyMembers]

logWorkspaceFamilies :: Logger
logWorkspaceFamilies = do
OrderedNumFamilies nums <- XS.get
ids <- traverse workspaceID (take 2 nums)
return $ Just $ intercalate "→" ids

0 comments on commit d33979f

Please sign in to comment.