From d33979f980c0512923e577b8b5772e51a114d7fe Mon Sep 17 00:00:00 2001 From: weiss Date: Fri, 16 Feb 2024 16:55:09 +0100 Subject: [PATCH] update workspace --- src/WeissXMonad.hs | 4 +- src/WorkspaceFamily.hs | 220 ++++++++++++++++++++++------------------- 2 files changed, 123 insertions(+), 101 deletions(-) diff --git a/src/WeissXMonad.hs b/src/WeissXMonad.hs index 47077a7..3e16038 100644 --- a/src/WeissXMonad.hs +++ b/src/WeissXMonad.hs @@ -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] diff --git a/src/WorkspaceFamily.hs b/src/WorkspaceFamily.hs index 44774f0..d7ff78e 100644 --- a/src/WorkspaceFamily.hs +++ b/src/WorkspaceFamily.hs @@ -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_) @@ -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) @@ -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 - <$> [ ("览", "") - , ("邮", "h") - , ("媒", "") - , ("聊", "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) = ["", 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 + <$> [ ("览", "") + , ("邮", "h") + , ("媒", "") + , ("聊", "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) = ["", 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) = ["", 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) = "" : 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)) = ["", 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) , ([""], shift) @@ -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 @@ -158,26 +176,17 @@ workspaceKeys' = workspaceKeys :: [(String, X ())] workspaceKeys = fmap (first $ unwords . cons "") 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 _ _ [] = [] @@ -185,3 +194,16 @@ 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