diff options
| -rw-r--r-- | src/Internal/LayoutZipper.hs | 166 |
1 files changed, 166 insertions, 0 deletions
diff --git a/src/Internal/LayoutZipper.hs b/src/Internal/LayoutZipper.hs new file mode 100644 index 0000000..d31360b --- /dev/null +++ b/src/Internal/LayoutZipper.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE GADTs, RankNTypes, FlexibleInstances, MultiParamTypeClasses, + FlexibleContexts, UndecidableInstances, ViewPatterns, StandaloneDeriving, + RankNTypes, TupleSections #-} + +{- This module provides a more powerful version of the choose layout, using a + - list to store the layouts. -} +module Internal.LayoutZipper where + +import Control.Monad.Identity (runIdentity) +import Data.Maybe (fromMaybe) +import Control.Arrow (second) +import XMonad +import qualified XMonad.StackSet as W +import Data.Proxy + +data LNil a = LNil deriving (Read, Show) +data LCons l t a = LCons (l a) (t a) deriving (Read, Show) + +data LayoutZipper l a = LayoutZipper Int (l a) + deriving (Read, Show) + +(|:) :: (LayoutSelect t a, LayoutClass l a) => l a -> t a -> LCons l t a +(|:) = LCons +infixr 5 |: + +layoutZipper :: (LayoutSelect l a) => l a -> LayoutZipper l a +layoutZipper = LayoutZipper 0 + +nil :: LNil a +nil = LNil + +data NavigateLayout = ToNextLayout | ToPreviousLayout deriving (Typeable, Show) +instance Message NavigateLayout where + +class LayoutSelect l a where + update :: forall r m. (Monad m) => + Int -> + l a -> + (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) => + LayoutSelect (LCons l t) a where + + update 0 (LCons layout t) fn = do + (r, layout') <- fn layout + return $ Just (r, LCons (fromMaybe layout layout') t) + + update n (LCons l t) fn = do + (fmap . fmap) (second $ \t' -> LCons l t') $ update (n - 1) t fn + + nLayouts (LCons _ t) = 1 + nLayouts t + +instance LayoutSelect LNil a where + update _ _ _ = return Nothing + nLayouts _ = 0 + +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 ToNextLayout) = + if idx < nLayouts l - 1 + then return $ Just (LayoutZipper (idx + 1) l) + else return $ Just (LayoutZipper 0 l) + handleMessage (LayoutZipper idx l) (fromMessage -> Just ToPreviousLayout) = + if idx > 0 + then return $ Just (LayoutZipper (idx - 1) l) + else return $ Just (LayoutZipper (nLayouts l - 1) 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 + +-- data LayoutZipper l a = LayoutZipper [Layout a] [Layout a] +-- deriving (Read, Show) + + +-- instance LayoutClass Layout a where +-- runLayout (W.Workspace i (Layout l) ms) r = do +-- (rects, new) <- runLayout (W.Workspace i l ms) r +-- return (rects, fmap Layout new) +-- doLayout (Layout l) r s = do +-- (rs, l') <- doLayout l r s +-- return (rs, fmap Layout l') +-- pureLayout (Layout l) r s = pureLayout l r s +-- emptyLayout (Layout l) = (fmap . second . fmap) Layout . emptyLayout l +-- handleMessage (Layout l) = (fmap . fmap) Layout . handleMessage l +-- pureMessage (Layout l) = fmap Layout . pureMessage l +-- description (Layout l) = description l + +-- replaceHead :: LayoutZipper a -> Layout a -> LayoutZipper a +-- replaceHead (LayoutZipper (_:hs) ts) h = LayoutZipper (h:hs) ts +-- replaceHead z _ = z +-- +-- nil :: LayoutZipper a +-- nil = LayoutZipper [] [] +-- +-- (|:) :: (Read (l a), LayoutClass l a) => l a -> LayoutZipper a -> LayoutZipper a +-- (|:) l (LayoutZipper h t) = LayoutZipper (Layout l : h) t +-- +-- infixr 5 |: +-- +-- +-- +-- instance (LayoutClass Layout a) => LayoutClass LayoutZipper a where +-- runLayout (W.Workspace i z@(LayoutZipper (a:_) _) ms) = do +-- fmap (second . fmap $ replaceHead z) . +-- runLayout (W.Workspace i a ms) +-- runLayout (W.Workspace _ z _) = emptyLayout z +-- +-- doLayout z@(LayoutZipper (h:_) _) r s = do +-- (rects, mh) <- doLayout h r s +-- return (rects, fmap (replaceHead z) mh) +-- doLayout z r s = emptyLayout z r +-- +-- pureLayout (LayoutZipper (h:_) _) = pureLayout h +-- pureLayout l = \_ _ -> [] +-- +-- emptyLayout z@(LayoutZipper (h:_) _) r = do +-- (rects, mh) <- emptyLayout h r +-- return (rects, replaceHead z <$> mh) +-- emptyLayout _ _ = return ([], Nothing) +-- +-- handleMessage (LayoutZipper (hs) (t:ts)) (fromMessage -> Just ToNextLayout) = +-- return $ return $ LayoutZipper (t:hs) ts +-- handleMessage (LayoutZipper (h:hs) (ts)) (fromMessage -> Just ToPreviousLayout) = +-- return $ +-- case hs of +-- [] -> Nothing +-- _ -> Just (LayoutZipper hs (h:ts)) +-- handleMessage z@(LayoutZipper (h:_) _) m = +-- (fmap $ fmap $ replaceHead z) (handleMessage h m) +-- handleMessage _ _ = return Nothing +-- +-- pureMessage z@(LayoutZipper (h:_) _) = fmap (replaceHead z) . pureMessage h +-- +-- description (LayoutZipper (h:_) _) = description h |