Bidirection navigation for layouts!

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