From eb5addb90f58ed0aa7e6f504fa2c960dd8228b1e Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Wed, 11 Sep 2013 19:14:25 +0200 Subject: Rename XMonad to MetaTile --- MetaTile/Layout.hs | 210 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 210 insertions(+) create mode 100644 MetaTile/Layout.hs (limited to 'MetaTile/Layout.hs') diff --git a/MetaTile/Layout.hs b/MetaTile/Layout.hs new file mode 100644 index 0000000..47fd4f9 --- /dev/null +++ b/MetaTile/Layout.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances, DeriveDataTypeable #-} + +-- -------------------------------------------------------------------------- +-- | +-- Module : MetaTile.Layout +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : spencerjanssen@gmail.com +-- Stability : unstable +-- Portability : not portable, Typeable deriving, mtl, posix +-- +-- The collection of core layouts. +-- +----------------------------------------------------------------------------- + +module MetaTile.Layout ( + Full(..), Tall(..), Mirror(..), + Resize(..), IncMasterN(..), Choose, (|||), ChangeLayout(..), + mirrorRect, splitVertically, + splitHorizontally, splitHorizontallyBy, splitVerticallyBy, + + tile + + ) where + +import MetaTile.Core + +import Graphics.X11 (Rectangle(..)) +import qualified MetaTile.StackSet as W +import Control.Arrow ((***), second) +import Control.Monad +import Data.Maybe (fromMaybe) + +------------------------------------------------------------------------ + +-- | Change the size of the master pane. +data Resize = Shrink | Expand deriving Typeable + +-- | Increase the number of clients in the master pane. +data IncMasterN = IncMasterN !Int deriving Typeable + +instance Message Resize +instance Message IncMasterN + +-- | Simple fullscreen mode. Renders the focused window fullscreen. +data Full a = Full deriving (Show, Read) + +instance LayoutClass Full a + +-- | The builtin tiling mode of xmonad. Supports 'Shrink', 'Expand' and +-- 'IncMasterN'. +data Tall a = Tall { tallNMaster :: !Int -- ^ The default number of windows in the master pane (default: 1) + , tallRatioIncrement :: !Rational -- ^ Percent of screen to increment by when resizing panes (default: 3/100) + , tallRatio :: !Rational -- ^ Default proportion of screen occupied by master pane (default: 1/2) + } + deriving (Show, Read) + -- TODO should be capped [0..1] .. + +-- a nice pure layout, lots of properties for the layout, and its messages, in Properties.hs +instance LayoutClass Tall a where + pureLayout (Tall nmaster _ frac) r s = zip ws rs + where ws = W.integrate s + rs = tile frac r nmaster (length ws) + + pureMessage (Tall nmaster delta frac) m = + msum [fmap resize (fromMessage m) + ,fmap incmastern (fromMessage m)] + + where resize Shrink = Tall nmaster delta (max 0 $ frac-delta) + resize Expand = Tall nmaster delta (min 1 $ frac+delta) + incmastern (IncMasterN d) = Tall (max 0 (nmaster+d)) delta frac + + description _ = "Tall" + +-- | Compute the positions for windows using the default two-pane tiling +-- algorithm. +-- +-- The screen is divided into two panes. All clients are +-- then partioned between these two panes. One pane, the master, by +-- convention has the least number of windows in it. +tile + :: Rational -- ^ @frac@, what proportion of the screen to devote to the master area + -> Rectangle -- ^ @r@, the rectangle representing the screen + -> Int -- ^ @nmaster@, the number of windows in the master pane + -> Int -- ^ @n@, the total number of windows to tile + -> [Rectangle] +tile f r nmaster n = if n <= nmaster || nmaster == 0 + then splitVertically n r + else splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2 -- two columns + where (r1,r2) = splitHorizontallyBy f r + +-- +-- Divide the screen vertically into n subrectangles +-- +splitVertically, splitHorizontally :: Int -> Rectangle -> [Rectangle] +splitVertically n r | n < 2 = [r] +splitVertically n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh : + splitVertically (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh)) + where smallh = sh `div` fromIntegral n --hmm, this is a fold or map. + +-- Not used in the core, but exported +splitHorizontally n = map mirrorRect . splitVertically n . mirrorRect + +-- Divide the screen into two rectangles, using a rational to specify the ratio +splitHorizontallyBy, splitVerticallyBy :: RealFrac r => r -> Rectangle -> (Rectangle, Rectangle) +splitHorizontallyBy f (Rectangle sx sy sw sh) = + ( Rectangle sx sy leftw sh + , Rectangle (sx + fromIntegral leftw) sy (sw-fromIntegral leftw) sh) + where leftw = floor $ fromIntegral sw * f + +-- Not used in the core, but exported +splitVerticallyBy f = (mirrorRect *** mirrorRect) . splitHorizontallyBy f . mirrorRect + +------------------------------------------------------------------------ + +-- | Mirror a layout, compute its 90 degree rotated form. +newtype Mirror l a = Mirror (l a) deriving (Show, Read) + +instance LayoutClass l a => LayoutClass (Mirror l) a where + runLayout (W.Workspace i (Mirror l) ms) r = (map (second mirrorRect) *** fmap Mirror) + `fmap` runLayout (W.Workspace i l ms) (mirrorRect r) + handleMessage (Mirror l) = fmap (fmap Mirror) . handleMessage l + description (Mirror l) = "Mirror "++ description l + +-- | Mirror a rectangle. +mirrorRect :: Rectangle -> Rectangle +mirrorRect (Rectangle rx ry rw rh) = Rectangle ry rx rh rw + +------------------------------------------------------------------------ +-- LayoutClass selection manager +-- Layouts that transition between other layouts + +-- | Messages to change the current layout. +data ChangeLayout = FirstLayout | NextLayout deriving (Eq, Show, Typeable) + +instance Message ChangeLayout + +-- | The layout choice combinator +(|||) :: (LayoutClass l a, LayoutClass r a) => l a -> r a -> Choose l r a +(|||) = Choose L +infixr 5 ||| + +-- | A layout that allows users to switch between various layout options. +data Choose l r a = Choose LR (l a) (r a) deriving (Read, Show) + +-- | Are we on the left or right sub-layout? +data LR = L | R deriving (Read, Show, Eq) + +data NextNoWrap = NextNoWrap deriving (Eq, Show, Typeable) +instance Message NextNoWrap + +-- | A small wrapper around handleMessage, as it is tedious to write +-- SomeMessage repeatedly. +handle :: (LayoutClass l a, Message m) => l a -> m -> X (Maybe (l a)) +handle l m = handleMessage l (SomeMessage m) + +-- | A smart constructor that takes some potential modifications, returns a +-- new structure if any fields have changed, and performs any necessary cleanup +-- on newly non-visible layouts. +choose :: (LayoutClass l a, LayoutClass r a) + => Choose l r a-> LR -> Maybe (l a) -> Maybe (r a) -> X (Maybe (Choose l r a)) +choose (Choose d _ _) d' Nothing Nothing | d == d' = return Nothing +choose (Choose d l r) d' ml mr = f lr + where + (l', r') = (fromMaybe l ml, fromMaybe r mr) + lr = case (d, d') of + (L, R) -> (hide l' , return r') + (R, L) -> (return l', hide r' ) + (_, _) -> (return l', return r') + f (x,y) = fmap Just $ liftM2 (Choose d') x y + hide x = fmap (fromMaybe x) $ handle x Hide + +instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where + runLayout (W.Workspace i (Choose L l r) ms) = + fmap (second . fmap $ flip (Choose L) r) . runLayout (W.Workspace i l ms) + runLayout (W.Workspace i (Choose R l r) ms) = + fmap (second . fmap $ Choose R l) . runLayout (W.Workspace i r ms) + + description (Choose L l _) = description l + description (Choose R _ r) = description r + + handleMessage lr m | Just NextLayout <- fromMessage m = do + mlr' <- handle lr NextNoWrap + maybe (handle lr FirstLayout) (return . Just) mlr' + + handleMessage c@(Choose d l r) m | Just NextNoWrap <- fromMessage m = + case d of + L -> do + ml <- handle l NextNoWrap + case ml of + Just _ -> choose c L ml Nothing + Nothing -> choose c R Nothing =<< handle r FirstLayout + + R -> choose c R Nothing =<< handle r NextNoWrap + + handleMessage c@(Choose _ l _) m | Just FirstLayout <- fromMessage m = + flip (choose c L) Nothing =<< handle l FirstLayout + + handleMessage c@(Choose d l r) m | Just ReleaseResources <- fromMessage m = + join $ liftM2 (choose c d) (handle l ReleaseResources) (handle r ReleaseResources) + + handleMessage c@(Choose d l r) m = do + ml' <- case d of + L -> handleMessage l m + R -> return Nothing + mr' <- case d of + L -> return Nothing + R -> handleMessage r m + choose c d ml' mr' -- cgit v1.2.3