diff options
| -rw-r--r-- | src/Internal/LayoutZipper.hs | 246 |
1 files changed, 175 insertions, 71 deletions
diff --git a/src/Internal/LayoutZipper.hs b/src/Internal/LayoutZipper.hs index 7af7d7b..7fd4a5f 100644 --- a/src/Internal/LayoutZipper.hs +++ b/src/Internal/LayoutZipper.hs @@ -2,10 +2,26 @@ FlexibleContexts, UndecidableInstances, ViewPatterns, StandaloneDeriving, RankNTypes, TupleSections, TypeFamilies #-} -{- This module provides a more powerful version of the choose layout, using a - - list to store the layouts, and thus the list is navigatable. -} -module Internal.LayoutZipper where - +{- + - 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) @@ -14,43 +30,108 @@ 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) -data IsSelected l = Selected | NotSelected l - deriving (Read, Show) - --- Combinator for combining layouts together into a LayoutList. This amy then be --- used with the layoutZipper to create a layout zipper. -class SelectionClass c where - nextSelection :: c -> c - prevSelection :: c -> c - firstSelection :: Maybe c - isSelected :: c -> Bool - -instance (SelectionClass t) => SelectionClass (IsSelected t) where - nextSelection (NotSelected l) = NotSelected (nextSelection l) - nextSelection Selected = maybe Selected NotSelected firstSelection - - firstSelection = Just Selected - - prevSelection (NotSelected t) = - if isSelected t - then Selected - else NotSelected (prevSelection t) - prevSelection Selected = Selected - - isSelected Selected = True - isSelected _ = False - -instance SelectionClass Void where - nextSelection = absurd - prevSelection = absurd - firstSelection = Nothing - isSelected = const False - +-- 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) => Selection l -> l a -> LayoutZipper l a + 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) @@ -60,8 +141,12 @@ deriving instance (LayoutSelect l a) => Read (LayoutZipper l a) infixr 5 |: -layoutZipper :: (LayoutSelect l a, Selection l ~ IsSelected n) => l a -> LayoutZipper l a -layoutZipper = LayoutZipper Selected +-- 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 @@ -71,68 +156,87 @@ nil = LNil newtype NavigateLayout = -- Sets the layout based on the given function. NavigateLayout { - changeLayoutFn :: forall c. (SelectionClass c) => c -> c + changeLayoutFn :: forall c. (Selector c) => c -> c } deriving (Typeable) -- NavigateLayout instance to move to the next layout, circularly. toNextLayout :: NavigateLayout -toNextLayout = NavigateLayout nextSelection +toNextLayout = NavigateLayout $ \c -> fromMaybe c (increment c <|> initial) -- NavigateLayout instance to move to the previous layout, circularly. toPreviousLayout :: NavigateLayout -toPreviousLayout = NavigateLayout prevSelection +toPreviousLayout = NavigateLayout $ \c -> fromMaybe c (decrement c <|> final) -- NavigateLayotu instance to move to the first layout. toFirstLayout :: NavigateLayout -toFirstLayout = NavigateLayout (`fromMaybe` firstSelection) +toFirstLayout = NavigateLayout (`fromMaybe` initial) instance Message NavigateLayout where -class ( - Show (l a), - Read (l a), - Read (Selection l), - Show (Selection l), - SelectionClass (Selection l)) => LayoutSelect l a where - type Selection l :: * - +-- 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) => - Selection l -> + -- 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))) -> - m (Maybe (r, l a)) - - nLayouts :: l a -> Int -instance ( - Read (l a), - LayoutClass l a, - LayoutSelect t a, + -- Returns a result r, and an updated LayoutSelect. + m (Maybe (r, l a)) - Show (Selection t), - Read (Selection t)) => +-- 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 - -- This is something - type Selection (LCons l t) = IsSelected (Selection t) + -- 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) - update Selected (LCons layout t) fn = do + -- 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) - update (NotSelected s) (LCons l t) fn = + -- 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 - - nLayouts (LCons _ t) = 1 + nLayouts t +-- 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 Selection LNil = Void -- Cannot be selected - + type SelectorFor LNil = Zero -- LNil cannot be selected. update _ _ _ = return Nothing - nLayouts _ = 0 -instance (Show (l a), Typeable l, LayoutSelect l a) => LayoutClass (LayoutZipper l) a where +-- 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 |