From 3249935394c85cc9ca25d6bbbd74da002d43dccf Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sat, 9 Apr 2022 22:39:30 -0600 Subject: Rename LayoutZipper to LayoutList. Add more utils for handling a selector --- src/Internal/Keys.hs | 2 +- src/Internal/Layout.hs | 22 +++- src/Internal/LayoutList.hs | 297 +++++++++++++++++++++++++++++++++++++++++++ src/Internal/LayoutZipper.hs | 275 --------------------------------------- 4 files changed, 315 insertions(+), 281 deletions(-) create mode 100644 src/Internal/LayoutList.hs delete mode 100644 src/Internal/LayoutZipper.hs (limited to 'src') diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs index d340062..01e438c 100644 --- a/src/Internal/Keys.hs +++ b/src/Internal/Keys.hs @@ -46,7 +46,7 @@ import XMonad.Actions.SpawnOn as SpawnOn import qualified Data.Map as Map import qualified XMonad.StackSet as W -import Internal.LayoutZipper +import Internal.LayoutList import Internal.MouseMotion import Internal.Windows import Internal.Lib diff --git a/src/Internal/Layout.hs b/src/Internal/Layout.hs index 562f947..6c78c70 100644 --- a/src/Internal/Layout.hs +++ b/src/Internal/Layout.hs @@ -25,7 +25,7 @@ import XMonad import XMonad.Core import XMonad.Layout.NoBorders (smartBorders, noBorders) -import Internal.LayoutZipper +import Internal.LayoutList import Internal.Windows import qualified Data.Map as M @@ -36,9 +36,9 @@ myLayout = avoidStruts $ spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $ layoutZipper $ - mods (spiral (6/7)) |: + mods (reinterpretIncMaster $ spiral (6/7)) |: mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |: - mods (Corner (3/4) (3/100)) |: + mods (reinterpretIncMaster $ Corner (3/4) (3/100)) |: mods (ModifyDescription TallDescriptionModifier (Tall 1 (3/100) (1/2))) |: mods (ModifyDescription ThreeColDescMod (ThreeCol 1 (3/100) (1/2))) |: mods Grid |: @@ -69,14 +69,14 @@ instance DoReinterpret "ForMosaic" where -- IncMaster message reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = do - (fmap $ SomeMessage . + fmap (SomeMessage . (if n > 0 then expandWindowAlt else shrinkWindowAlt)) <$> getFocusedWindow -- ResizeMaster message reinterpretMessage _ (fromMessage -> Just m) = do - (fmap $ SomeMessage . + fmap (SomeMessage . (case m of Expand -> expandWindowAlt Shrink -> shrinkWindowAlt)) <$> getFocusedWindow @@ -84,6 +84,14 @@ instance DoReinterpret "ForMosaic" where -- Messages that don't match the above, just leave it unmodified. reinterpretMessage _ m = return (Just m) +instance DoReinterpret "IncMasterToResizeMaster" where + reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = + return $ Just $ + if n > 0 + then SomeMessage Expand + else SomeMessage Shrink + reinterpretMessage _ m = return (Just m) + -- Data construct for association a DoReinterpret function with a concrete -- construct that can be used in the LayoutModifier instance. -- @@ -117,6 +125,10 @@ instance (DoReinterpret k) => modifyMosaic :: l a -> ModifiedLayout (ReinterpretMessage "ForMosaic") l a modifyMosaic = ModifiedLayout ReinterpretMessage +reinterpretIncMaster :: + l a -> ModifiedLayout (ReinterpretMessage "IncMasterToResizeMaster") l a +reinterpretIncMaster = ModifiedLayout ReinterpretMessage + mods = ModifiedLayout (Zoomable False 0.05 0.05) . ModifiedLayout (Flippable False) . diff --git a/src/Internal/LayoutList.hs b/src/Internal/LayoutList.hs new file mode 100644 index 0000000..2405f71 --- /dev/null +++ b/src/Internal/LayoutList.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE GADTs, RankNTypes, FlexibleInstances, MultiParamTypeClasses, + FlexibleContexts, UndecidableInstances, ViewPatterns, StandaloneDeriving, + RankNTypes, TupleSections, TypeFamilies #-} + +{- + - This module provides a more powerful version of the "Choose" layout that can + - be bidirectionally navigated. + - + - The indexing uses a type-safe zipper to keep track of the currently-selected + - layout. + -} +module Internal.LayoutList ( + LayoutList, + layoutZipper, + LCons, + LNil, + toNextLayout, + toPreviousLayout, + toFirstLayout, + (|:), + nil + )where + +import Control.Applicative ((<|>)) +import Data.Void +import Control.Monad.Identity (runIdentity) +import Data.Maybe (fromMaybe, fromJust) +import Control.Arrow (second) +import XMonad +import qualified XMonad.StackSet as W +import Data.Proxy + +-- Type-level lists. LNil is the final of the list. LCons contains a layout and a +-- tail. +data LNil a = LNil deriving (Read, Show) +data LCons l t a = LCons (l a) (t a) deriving (Read, Show) + +-- Sel - This defines a structure where either this selected, or some +-- other element is selected. +-- +-- These types can be composed to create what is effectively a bounded integer. +-- I.e. there can be a type like +-- +-- Sel (Sel (Sel (Sel End))) +-- +-- Such a type is equivalent to an integer bounded at 4, because this type can +-- exist in no more than 4 states: +-- +-- Sel +-- Skip Sel +-- Skip (Skip Sel) +-- Skip (Skip (Skip Sel)) +-- +-- Note that a type (Sel End) can only be in the Sel as End may not be +-- construted (without using undefined). +data Sel l = + Sel | + (Selector l) => Skip l +deriving instance (Read l, Selector l) => Read (Sel l) +deriving instance (Show l, Selector l) => Show (Sel l) +deriving instance (Eq l, Selector l) => Eq (Sel l) + +-- Reimplement Void as End, just to keep the two separate, but End is for all +-- intents and purposes Void. +data End +deriving instance Read End +deriving instance Show End +deriving instance Eq End + + +-- Types that constitute a selection. Selections can be moved to the next +-- selection, moved to the previous selection, optionally there could be a +-- previous selection and they may be currently selected. +class (Eq c) => Selector c where + -- Increments the selection to the next state + -- + -- Returns Nothing if the selection class is in the final state and cannot be + -- incremented any farther. (This is helpful to facilitate modular + -- arithmatic) + increment :: c -> Maybe c + + -- Decrements the selection to the previous state. Returns Nothing if the + -- state is already in its initial setting. + decrement :: c -> Maybe c + + -- The initial state. + initial :: Maybe c + + -- The final state. + final :: Maybe c + +-- +-- Is selelected can be in two states: +-- +-- 1. The current element is selected +-- 2. The current element is not selected and another element deeper in the +-- structure is selected. +instance (Selector t) => Selector (Sel t) where + -- If the current element is not selected, increment the tail. + increment (Skip l) = Skip <$> increment l + -- If the current element is selected, the increment is just the initial of + -- the tail. + increment Sel = Skip <$> initial + + -- For a selection, the initial is just this in the Sel state. + initial = Just Sel + + -- Looks ahead at the tail, sees if it is selected, if so, select this one + -- instead, if the one ahead isn't selected, then decrement that one. + decrement (Skip t) = Just $ maybe Sel Skip (decrement t) + decrement Sel = Nothing + + -- Navigates to the end of the structure to find the final form. + final = Just $ maybe Sel Skip final + +-- The End structure (which is equivalent to Void) is the "null" selector; the +-- basecase that the Sel selector terminates at. +instance Selector End where + + -- Incrementing the End Selector doesn't do anything. + increment = const Nothing + + -- Decrementing the End Selector doesn't do anythig + decrement = const Nothing + + -- There is no initial value for the End selector. + initial = Nothing + + -- There is not final state for the End selector. + final = Nothing + +-- Increment a selector, but cyclicly +incrementCycle :: (Selector c) => c -> c +incrementCycle c = + case increment c of + Nothing -> fromMaybe c initial + Just x -> x + +-- Add two selectors together, incrementing the first until the second cannot be +-- incremented anymore. +addSelector :: (Selector c) => c -> c -> c +addSelector c1 c2 = addSel c1 (decrement c2) + where + addSel c1 Nothing = c1 + addSel c1 (Just c2) = addSel (incrementCycle c1) (decrement c2) + +-- Turn an int into a selector by repeatably incrementing. +intToSelector :: (Selector c) => Int -> c +intToSelector 0 = fromJust initial +intToSelector n = incrementCycle $ intToSelector (n - 1) + +-- A LayoutList consists of a LayoutSelect type and a corresponding Selector. +data LayoutList l a where + LayoutList :: + (LayoutSelect l a, Selector (SelectorFor l)) => + SelectorFor l -> l a -> LayoutList l a + +deriving instance (LayoutSelect l a) => Show (LayoutList l a) +deriving instance (LayoutSelect l a) => Read (LayoutList l a) + +(|:) :: (LayoutSelect t a, LayoutClass l a) => l a -> t a -> LCons l t a +(|:) = LCons + +infixr 5 |: + +-- Constructs a LayoutList. This function enforces that the SelectorFor l +-- is a 'Sel' type. Essentially this enforces that there must be at least one +-- underlying layout, otherwise a LayoutList cannot be constructed. +layoutZipper :: (LayoutSelect l a, SelectorFor l ~ Sel n) => + l a -> LayoutList l a +layoutZipper = LayoutList Sel + +-- The termination of a layout zipper. +nil :: LNil a +nil = LNil + +-- Message to navigate to a layout. +newtype NavigateLayout = + -- Sets the layout based on the given function. + NavigateLayout { + changeLayoutFn :: forall c. (Selector c) => c -> c + } + deriving (Typeable) + +-- NavigateLayout instance to move to the next layout, circularly. +toNextLayout :: NavigateLayout +toNextLayout = NavigateLayout $ addSelector (intToSelector 1) + +-- NavigateLayout instance to move to the previous layout, circularly. +toPreviousLayout :: NavigateLayout +toPreviousLayout = NavigateLayout $ \c -> fromMaybe c (decrement c <|> final) + +-- NavigateLayotu instance to move to the first layout. +toFirstLayout :: NavigateLayout +toFirstLayout = NavigateLayout (`fromMaybe` initial) + +instance Message NavigateLayout where + +-- LayoutSelect class Describes a type that can be used to select a layout using +-- the associated type SelectorFor. +-- +-- Instances of this class are LCons and LNil. +class (Show (l a), + Read (l a), + Read (SelectorFor l), + Show (SelectorFor l), + Selector (SelectorFor l)) => LayoutSelect l a where + + -- The selector that is used to update the layout corresponding to the + -- selector. This selector must be an instance of the Selector class. + type SelectorFor l :: * + + -- Update applies a functor to the selected layout and maybe returns a result + -- and an updated layout. + update :: forall r m. (Monad m) => + -- The selector for this type. Determines which layout the function is + -- applied to. + SelectorFor l -> + -- The LayoutSelect being modified. + l a -> + -- Higher-ordered function to generically apply to the Layout associated + -- with the Selector. Works on all LayoutClass's. + (forall l'. (LayoutClass l' a) => l' a -> m (r, Maybe (l' a))) -> + + -- Returns a result r, and an updated LayoutSelect. + m (Maybe (r, l a)) + +-- Instance for LayoutSelect for cons +instance (Read (l a), + LayoutClass l a, + LayoutSelect t a, + Show (SelectorFor t), + Read (SelectorFor t)) => + LayoutSelect (LCons l t) a where + + -- The SelectorFor Cons is Sel (SelectorFor t). This creates the structure + -- Sel (Sel (Sel ( ... (Sel End) .. ))) where the number of Sel's match the + -- number of Cons in this structure enforcing safe selection. + type SelectorFor (LCons l t) = Sel (SelectorFor t) + + -- The current layout in this Cons-list is selected. + update Sel (LCons layout t) fn = do + (r, layout') <- fn layout + return $ Just (r, LCons (fromMaybe layout layout') t) + + -- The current layout is not selected. Move on to another layout. + update (Skip s) (LCons l t) fn = + fmap (second $ \t' -> LCons l t') <$> update s t fn + +-- LNil is a layout select. It doesn't do anything. Indeed update really can't +-- be called on on this because that would require instantiating a End type. +instance LayoutSelect LNil a where + type SelectorFor LNil = End -- LNil cannot be selected. + update _ _ _ = return Nothing + +-- Instance of layout class for LayoutList. The implementation for this +-- just delegates to the underlying LayoutSelect class using the generic +-- update method. +instance (Show (l a), Typeable l, LayoutSelect l a) => + LayoutClass (LayoutList l) a where + + runLayout (W.Workspace i (LayoutList idx l) ms) r = do + r <- update idx l $ \layout -> + runLayout (W.Workspace i layout ms) r + case r of + Nothing -> return ([], Nothing) + Just (r, la) -> return (r, Just (LayoutList idx la)) + + pureLayout (LayoutList idx l) r s = runIdentity $ do + r <- update idx l $ \layout -> return (pureLayout layout r s, Nothing) + case r of + Nothing -> return [] + Just (r, a) -> return r + + emptyLayout (LayoutList idx l) r = do + r <- update idx l $ \layout -> emptyLayout layout r + case r of + Nothing -> return ([], Nothing) + Just (r, la) -> return (r, Just (LayoutList idx la)) + + handleMessage (LayoutList idx l) (fromMessage -> Just (NavigateLayout fn)) = + return $ Just (LayoutList (fn idx) l) + + handleMessage (LayoutList idx l) m = do + r <- update idx l $ \layout -> ((),) <$> handleMessage layout m + return $ LayoutList idx . snd <$> r + + pureMessage (LayoutList idx l) m = runIdentity $ do + r <- update idx l $ \layout -> return ((), pureMessage layout m) + return $ LayoutList idx . snd <$> r + + description (LayoutList idx l) = runIdentity $ do + r <- update idx l $ \l -> return (description l, Nothing) + return $ + case r of + Nothing -> "No Layout" + Just (descr, _) -> descr diff --git a/src/Internal/LayoutZipper.hs b/src/Internal/LayoutZipper.hs deleted file mode 100644 index 7fd4a5f..0000000 --- a/src/Internal/LayoutZipper.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE GADTs, RankNTypes, FlexibleInstances, MultiParamTypeClasses, - FlexibleContexts, UndecidableInstances, ViewPatterns, StandaloneDeriving, - RankNTypes, TupleSections, TypeFamilies #-} - -{- - - This module provides a more powerful version of the "Choose" layout that can - - be bidirectionally navigated. - - - - The indexing uses a type-safe zipper to keep track of the currently-selected - - layout. - -} -module Internal.LayoutZipper ( - LayoutZipper, - layoutZipper, - LCons, - LNil, - toNextLayout, - toPreviousLayout, - toFirstLayout, - (|:), - nil - )where - -import Control.Applicative ((<|>)) -import Data.Void -import Control.Monad.Identity (runIdentity) -import Data.Maybe (fromMaybe) -import Control.Arrow (second) -import XMonad -import qualified XMonad.StackSet as W -import Data.Proxy - --- Type-level lists. LNil is the final of the list. LCons contains a layout and a --- tail. -data LNil a = LNil deriving (Read, Show) -data LCons l t a = LCons (l a) (t a) deriving (Read, Show) - --- Sel - This defines a structure where either this selected, or some --- other element is selected. --- --- These types can be composed to create what is effectively a bounded integer. --- I.e. there can be a type like --- --- Sel (Sel (Sel (Sel Zero))) --- --- Such a type is equivalent to an integer bounded at 4, because this type can --- exist in no more than 4 states: --- --- Sel --- Skip Sel --- Skip (Skip Sel) --- Skip (Skip (Skip Sel)) --- --- Note that a type (Sel Zero) can only be in the Sel as Zero may not be --- construted (without using undefined). -data Sel l = - Sel | - (Selector l) => Skip l -deriving instance (Read l, Selector l) => Read (Sel l) -deriving instance (Show l, Selector l) => Show (Sel l) - --- Reimplement Void as Zero, just to keep the two separate, but Zero is for all --- intents and purposes Void. -data Zero -deriving instance Read Zero -deriving instance Show Zero - - --- Types that constitute a selection. Selections can be moved to the next --- selection, moved to the previous selection, optionally there could be a --- previous selection and they may be currently selected. -class Selector c where - -- Increments the selection to the next state - -- - -- Returns Nothing if the selection class is in the final state and cannot be - -- incremented any farther. (This is helpful to facilitate modular - -- arithmatic) - increment :: c -> Maybe c - - -- Decrements the selection to the previous state. Returns Nothing if the - -- state is already in its initial setting. - decrement :: c -> Maybe c - - -- The initial state. - initial :: Maybe c - - -- The final state. - final :: Maybe c - --- --- Is selelected can be in two states: --- --- 1. The current element is selected --- 2. The current element is not selected and another element deeper in the --- structure is selected. -instance (Selector t) => Selector (Sel t) where - -- If the current element is not selected, increment the tail. - increment (Skip l) = Skip <$> increment l - -- If the current element is selected, the increment is just the initial of - -- the tail. - increment Sel = Skip <$> initial - - -- For a selection, the initial is just this in the Sel state. - initial = Just Sel - - -- Looks ahead at the tail, sees if it is selected, if so, select this one - -- instead, if the one ahead isn't selected, then decrement that one. - decrement (Skip t) = Just $ maybe Sel Skip (decrement t) - decrement Sel = Nothing - - -- Navigates to the end of the structure to find the final form. - final = Just $ maybe Sel Skip final - --- The Zero structure (which is equivalent to Void) is the "null" selector; the --- basecase that the Sel selector terminates at. -instance Selector Zero where - - -- Incrementing the Zero Selector doesn't do anything. - increment = const Nothing - - -- Decrementing the Zero Selector doesn't do anythig - decrement = const Nothing - - -- There is no initial value for the Zero selector. - initial = Nothing - - -- There is not final state for the Zero selector. - final = Nothing - --- A LayoutZipper consists of a LayoutSelect type and a corresponding Selector. -data LayoutZipper l a where - LayoutZipper :: - (LayoutSelect l a, Selector (SelectorFor l)) => - SelectorFor l -> l a -> LayoutZipper l a - -deriving instance (LayoutSelect l a) => Show (LayoutZipper l a) -deriving instance (LayoutSelect l a) => Read (LayoutZipper l a) - -(|:) :: (LayoutSelect t a, LayoutClass l a) => l a -> t a -> LCons l t a -(|:) = LCons - -infixr 5 |: - --- Constructs a LayoutZipper. This function enforces that the SelectorFor l --- is a 'Sel' type. Essentially this enforces that there must be at least one --- underlying layout, otherwise a LayoutZipper cannot be constructed. -layoutZipper :: (LayoutSelect l a, SelectorFor l ~ Sel n) => - l a -> LayoutZipper l a -layoutZipper = LayoutZipper Sel - --- The termination of a layout zipper. -nil :: LNil a -nil = LNil - --- Message to navigate to a layout. -newtype NavigateLayout = - -- Sets the layout based on the given function. - NavigateLayout { - changeLayoutFn :: forall c. (Selector c) => c -> c - } - deriving (Typeable) - --- NavigateLayout instance to move to the next layout, circularly. -toNextLayout :: NavigateLayout -toNextLayout = NavigateLayout $ \c -> fromMaybe c (increment c <|> initial) - --- NavigateLayout instance to move to the previous layout, circularly. -toPreviousLayout :: NavigateLayout -toPreviousLayout = NavigateLayout $ \c -> fromMaybe c (decrement c <|> final) - --- NavigateLayotu instance to move to the first layout. -toFirstLayout :: NavigateLayout -toFirstLayout = NavigateLayout (`fromMaybe` initial) - -instance Message NavigateLayout where - --- LayoutSelect class Describes a type that can be used to select a layout using --- the associated type SelectorFor. --- --- Instances of this class are LCons and LNil. -class (Show (l a), - Read (l a), - Read (SelectorFor l), - Show (SelectorFor l), - Selector (SelectorFor l)) => LayoutSelect l a where - - -- The selector that is used to update the layout corresponding to the - -- selector. This selector must be an instance of the Selector class. - type SelectorFor l :: * - - -- Update applies a functor to the selected layout and maybe returns a result - -- and an updated layout. - update :: forall r m. (Monad m) => - -- The selector for this type. Determines which layout the function is - -- applied to. - SelectorFor l -> - -- The LayoutSelect being modified. - l a -> - -- Higher-ordered function to generically apply to the Layout associated - -- with the Selector. Works on all LayoutClass's. - (forall l'. (LayoutClass l' a) => l' a -> m (r, Maybe (l' a))) -> - - -- Returns a result r, and an updated LayoutSelect. - m (Maybe (r, l a)) - --- Instance for LayoutSelect for cons -instance (Read (l a), - LayoutClass l a, - LayoutSelect t a, - Show (SelectorFor t), - Read (SelectorFor t)) => - LayoutSelect (LCons l t) a where - - -- The SelectorFor Cons is Sel (SelectorFor t). This creates the structure - -- Sel (Sel (Sel ( ... (Sel Zero) .. ))) where the number of Sel's match the - -- number of Cons in this structure enforcing safe selection. - type SelectorFor (LCons l t) = Sel (SelectorFor t) - - -- The current layout in this Cons-list is selected. - update Sel (LCons layout t) fn = do - (r, layout') <- fn layout - return $ Just (r, LCons (fromMaybe layout layout') t) - - -- The current layout is not selected. Move on to another layout. - update (Skip s) (LCons l t) fn = - fmap (second $ \t' -> LCons l t') <$> update s t fn - --- LNil is a layout select. It doesn't do anything. Indeed update really can't --- be called on on this because that would require instantiating a Zero type. -instance LayoutSelect LNil a where - type SelectorFor LNil = Zero -- LNil cannot be selected. - update _ _ _ = return Nothing - --- Instance of layout class for LayoutZipper. The implementation for this --- just delegates to the underlying LayoutSelect class using the generic --- update method. -instance (Show (l a), Typeable l, LayoutSelect l a) => - LayoutClass (LayoutZipper l) a where - - runLayout (W.Workspace i (LayoutZipper idx l) ms) r = do - r <- update idx l $ \layout -> - runLayout (W.Workspace i layout ms) r - case r of - Nothing -> return ([], Nothing) - Just (r, la) -> return (r, Just (LayoutZipper idx la)) - - pureLayout (LayoutZipper idx l) r s = runIdentity $ do - r <- update idx l $ \layout -> return (pureLayout layout r s, Nothing) - case r of - Nothing -> return [] - Just (r, a) -> return r - - emptyLayout (LayoutZipper idx l) r = do - r <- update idx l $ \layout -> emptyLayout layout r - case r of - Nothing -> return ([], Nothing) - Just (r, la) -> return (r, Just (LayoutZipper idx la)) - - handleMessage (LayoutZipper idx l) (fromMessage -> Just (NavigateLayout fn)) = - return $ Just (LayoutZipper (fn idx) l) - - handleMessage (LayoutZipper idx l) m = do - r <- update idx l $ \layout -> ((),) <$> handleMessage layout m - return $ LayoutZipper idx . snd <$> r - - pureMessage (LayoutZipper idx l) m = runIdentity $ do - r <- update idx l $ \layout -> return ((), pureMessage layout m) - return $ LayoutZipper idx . snd <$> r - - description (LayoutZipper idx l) = runIdentity $ do - r <- update idx l $ \l -> return (description l, Nothing) - return $ - case r of - Nothing -> "No Layout" - Just (descr, _) -> descr -- cgit