Quadrant: my overly complex, generally self-indulgent, and entirely unpolished layout.

Internal.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables, PatternSynonyms, MultiWayIf, RankNTypes #-}
{-# LANGUAGE MonoLocalBinds #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.Quadrant.Internal
-- Description :  The internals and core interface of the Quadrant layout.
-- Copyright   :  (c) 2018  L. S. Leary
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  L. S. Leary
-- Stability   :  unstable
-- Portability :  unportable
--
-- Exposes the internals of the Quadrant layout; do not import this module
-- unless you know what you're doing.
--------------------------------------------------------------------------------

-- TODO
--   - Rename Quadrant to Quadrants?
--   - Should the module be truly internal?
--   - Use PureX?

-- --< Imports >-- {{{

module XMonad.Layout.Quadrant.Internal where

import Data.List (intercalate, nub, find)
import Data.Maybe (fromMaybe, catMaybes, isJust, isNothing, listToMaybe)
import Data.Function ((&))
import Data.Foldable (asum)
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Control.Monad (join, void, guard, when)
import Control.Applicative ((<|>))

import XMonad hiding ((<&&>),(<||>))
import qualified XMonad.StackSet as W

-- }}}

-- --< Usage >-- {{{

-- $Usage
--
-- TODO: write some docs.

-- }}}

-- --< Types >-- {{{

-- --< Spatial >-- {{{

-- $SpatialTypes
-- The @C@, @L@ and @R@ constructors conflict with other constructors common in
-- xmonad.hs source files, so import @hiding@ them if you don't need them.
-- Bidirectional pattern synonyms have been provided so that e.g. @TL@ or @BR@
-- can be used in place of @C T L@ and @C B R@, meaning that none of the @C@,
-- @T@, @B@, @L@ or @R@ constructors are necessary to match on Corners or
-- produce @Corner@ values.

-- | For use as a field in the C data constructor.
data Vertical = T -- ^ Top
              | B -- ^ Bottom
  deriving (Show, Read, Eq)

-- | For use as a field in the C data constructor.
--   Conflicts with Direction2D from XMonad.Util.Types and re-exporters such as
--   XMonad.Actions.Navigation2D.
data Horizontal = L -- ^ Left
                | R -- ^ Right
  deriving (Show, Read, Eq)

-- | For specifying a quadrant of the screen.
--   Conflicts with Side from XMonad.Hooks.ManageHelpers.
data Corner = C Vertical Horizontal
  deriving (Show, Read, Eq)

-- $CornerSynonyms
-- Non-colliding, defactored pattern synonyms for each @Corner@.
pattern TL, TR, BL, BR :: Corner
pattern TL = C T L
pattern TR = C T R
pattern BL = C B L
pattern BR = C B R

-- | For specifying a choice between vertical and horizontal.
data Orientation = X -- ^ Horizontal
                 | Y -- ^ Vertical
  deriving (Show, Read, Eq)

-- }}}

-- --< Quadrant >-- {{{

-- | The Quadrant data type for which the LayoutClass instance is written.
data Quadrant tl tr bl br a = Quadrant
  { internals :: Internal a -- ^ Holds internal state necessary to implement or
                            --   optimise layout operations.
  , qProfile  :: QProfile   -- ^ Holds the settings in use.
  , tl        :: tl a       -- ^ The layout for the top-left quadrant.
  , tr        :: tr a       -- ^ The layout for the top-right quadrant.
  , bl        :: bl a       -- ^ The layout for the bottom-left quadrant.
  , br        :: br a       -- ^ The layout for the bottom-right quadrant.
  } deriving (Show, Read, Eq)

-- | A type synonym simplifying signatures in the case that all quadrants are
--   controlled by layouts of the same type.
type AllQuadrants l = Quadrant l l l l

-- }}}

-- --< QProfile & ProfileMap >-- {{{

-- | TODO
data QProfile = QProfile {
  -- | A linear ordering on the quadrants.
  order      :: [Corner],
  --   Must contain every 'Corner' exactly once.
  qSettings  :: [(Maybe ScreenId, QSettings)], -- TODO: replace this questionable type? Perhaps with (QSettings, Map ScreenId QSettings)?
  -- | A list optionally associating a @QSettings@ with a @ScreenId@.
  -- | Holds various configurations of user settings.
  profileMap :: ProfileMap -- TODO: Separate out.
} deriving (Show, Read, Eq)

instance Default QProfile where
  def = QProfile corners [] M.empty

-- | TODO: Comment.
--   Also: should be:
--   ProfileMap = M.Map _      QProfile
type ProfileMap = M.Map String ([Corner], [(Maybe ScreenId, QSettings)])

-- $ProfileSynonyms
-- Pattern synonyms emphasising that the "active", "alternative" and "lies" are
-- special profiles which module-provided messages read from or write to.
-- TODO: replace these special string keys with a dedicated datatype?
pattern Last, Alternative, Lies :: String

-- | TODO
pattern Last        = "last"

-- | The settings toggled out with 'toggleAltQS' are stored with the key
--   @Alternative@, i.e. @"alternative"@.
pattern Alternative = "alternative"

-- | The settings toggled out with 'toggleLies' are stored with the key @Lies@,
--   i.e. @"lies"@.
pattern Lies        = "lies"

-- }}}

-- --< QSettings >-- {{{

-- | User facing settings for the Quadrant layout.
data QSettings = QSettings {
  -- | Default: 'IfEmpty'. Determines whether or not a window opened at the top
  --   of one quadrant opens into the bottom of the quadrant above (earlier in
  --   the ordering).
  insertAbove :: InsertAbove,
  -- | Default: 'Focused'. The mode used for the passing of unknown Messages to
  --   child layouts.
  passMessTo  :: TargetQ,
  -- | Default: @True@. Determines whether expansion is preferred over centring
  --   when the two conflict.
  preferE     :: Bool,
  -- | Default: @False@. Determines whether or not quadrants will expand out
  --   horizontally when the adjacent quadrant is empty.
  xExpand     :: Bool,
  -- | Default: @True@. Determines whether or not quadrants will expand out
  --   vertically when the adjacent quadrant is empty.
  yExpand     :: Bool,
  -- | Default: @True@. When possible to expand either vertically or
  --   horizontally, prefer the former.
  ePreferV    :: Bool,
  -- | Default: @True@. Centre a quadrant when its horizontal neighbour is
  --   empty.
  xCentre     :: Bool,
  -- | Default: @True@. Centre a quadrant when its vertical neighbour is empty.
  yCentre     :: Bool,
  -- | Default: @False@. When possible to centre either vertically or
  --   horizontally, prefer the former.
  cPreferV    :: Bool,
  -- | Default: @0@. The origin is where the innermost point of each quadrant
  --   meets. This setting determines horizontally where the origin lies
  --   relative to the centre of the screen.
  xOrigin     :: Int,
  -- | Default: @0@. Determines vertically where the origin lies relative to the
  --   centre of the screen.
  yOrigin     :: Int,
  -- | Default: @0@. A horizontal offset given to horizontally centred
  --   quadrants.
  cxOffset    :: Int,
  -- | Default: @0@. A vertical offset given to vertically centred quadrants.
  cyOffset    :: Int
} deriving (Show, Read, Eq)

-- | A data type for specifying where windows should be inserted upon opening at
--   the top of a quadrant.
data InsertAbove
  = Always  -- ^ A window opened at the top of a quadrant always opens into the
            --   quadrant above (earlier in the ordering).
  | IfEmpty -- ^ A window opened at the top of a quadrant will open into the
            --   quadrant above iff that quadrant is empty.
  | Never   -- ^ A window opened in one quadrant will never open into another.
    deriving (Show, Read, Eq)

instance Default QSettings where
  def = QSettings
    { insertAbove = IfEmpty
    , passMessTo  = Focused
    , preferE     = True
    , xExpand     = False
    , yExpand     = True
    , ePreferV    = True
    , xCentre     = True
    , yCentre     = True
    , cPreferV    = False
    , xOrigin     = 0
    , yOrigin     = 0
    , cxOffset    = 0
    , cyOffset    = 0
    }

-- }}}

-- --< QuadrantMessage >-- {{{

-- $QuadrantMessageInterface
-- The 'QuadrantMessage' data constructors are chosen to produce a powerful,
-- low-redundancy interface on top of which cuddlier messages can be
-- implemented. Many of them are expected to have direct utility only for power
-- users with very specific goals, hence their omission from the above config.
-- As a replacement, some notes with nods to in-source usage:
--
--  * 'ModifyQProfile' uses information from both active and inactive settings
--    to alter both. It's used directly to implement 'toggleAltQS',
--    'toggleLies' and 'modifyActiveQS', which is then used to implement all
--    other @modify\*@ and the @transform\*@ messages, which themselves are used
--    to implement shift messages.
--
--  * 'WithFocusedQ' allows you to transform another message into one that's
--    contextual upon which quadrant currently holds the focused window, if any.
--    It's used to implement 'swapWindows' and 'swapWindowsD' in terms of
--    'RedistributeWindows' and the 'Focused' case of 'MessageQ' in terms of the
--    'Only' case.
--
--  * 'ToQuadrantWith' shifts the focused window to another quadrant; it's used
--    to implement 'pushWindow' and 'pushWindowD'.
--
--  * 'RedistributeWindows' shuffles the contents of the quadrants between one
--    another. As previously mentioned, it's used to implement 'swapWindows' and
--    'swapWindowsD' with the help of 'WithFocusedQ'.
--
--  * 'MessageQ' offers precise handling of Messages to child layouts. It's used
--    to implement the default handling of unknown Messages, and in its own
--    implementation of the 'Focused' case in terms of the 'Only' case.

-- | Messages for interacting with the Quadrant layout at runtime.
data QuadrantMessage
  -- | A master message for arbitrary modifications to profiles.
  = ModifyQProfile (QProfile -> QProfile)
  -- | Maybe send a Message that depends on which quadrant has focus,
  --   if any.
  | WithFocusedQ (Maybe Corner -> Maybe SomeMessage)
  -- | Change which quadrant the focused window is tiled in arbitrarily.
  | ToQuadrantWith (Corner -> Corner)
  -- | Redistribute windows amongst quadrants.
  | RedistributeWindows (Corner -> Corner)
  -- | Pass a Message in a 'SomeMessage' wrapper to the layouts in the
  --   targeted quadrants. Provides precise Message handling for child layouts.
  | MessageQ TargetQ SomeMessage
    deriving Typeable

instance Message QuadrantMessage

-- | Target data type for child-layout message handling.
--   Conflicts with All from Data.Monoid and Data.Semigroup.
data TargetQ
  = Focused     -- ^ If there is a quadrant with focus, target it, else discard.
  | All         -- ^ Target all quadrants.
  | None        -- ^ Discard the message.
  | Only Corner -- ^ Target a static quadrant.
    deriving (Show, Read, Eq)

-- }}}

-- --< Private >-- {{{

-- | @Layouts@ is a Constraint synonym asserting that the first four arguments
--   are layouts over the fifth.
--   TODO: use type declaration.
class    ( LayoutClass tl a, LayoutClass tr a
         , LayoutClass bl a, LayoutClass br a) => Layouts tl tr bl br a
instance ( LayoutClass tl a, LayoutClass tr a
         , LayoutClass bl a, LayoutClass br a) => Layouts tl tr bl br a

-- | Given complete @Quadrant@ state and permission to call on @LayoutClass@
--   methods of child layouts, perform arbitrary @X ()@ actions and maybe return
--   changes to the @Quadrant@ state. This allows arbitrary extension to the
--   QuadrantMessage interface without modifying the LayoutClass instance.
newtype QMessageExtension = QMessageExtension
  { runQME
    :: forall tl tr bl br. Layouts tl tr bl br Window
    => Quadrant tl tr bl br Window -> X (Maybe (Quadrant tl tr bl br Window))
  }
instance Message QMessageExtension

-- | Internal state necessary to implement or optimise layouting operations.
data Internal a = Internal
  { inTL     :: [a]               -- ^ The windows in the top-left quadrant.
  , inTR     :: [a]               -- ^ The windows in the top-right quadrant.
  , inBL     :: [a]               -- ^ The windows in the bottom-left quadrant.
  , inBR     :: [a]               -- ^ The windows in the bottom-right quadrant.
  , whereami :: Maybe WorkspaceId -- ^ @handleMessage@ won't tell us.
  , managed  :: S.Set a
  -- ^ A set of all managed windows. Allows quick lookup that reduces the
  --   time complexity of layouting from O(n^2) to O(n log n).
  } deriving (Show, Read, Eq)

instance Default (Internal a) where
  def = Internal def def def def def S.empty

-- | Type-safe non-empty lists used in the insertion algorithm.
-- TODO: use stock non-empty lists? IIRC there was a reason to prefer
-- this alternate formulation (but perhaps not a good one).
data NEList a
  = Single a      -- ^ The last element of an NEList a
  | a :| NEList a -- ^ The cons operation on a and NEList a.
  deriving (Show, Read, Eq)
infixr 8 :|

instance Foldable NEList where
  foldMap f (Single h) = f h
  foldMap f (h:|t)   = f h <> foldMap f t

-- }}}

-- }}}

-- --< Type helper functions >-- {{{

-- | Flip a Corner in its Horizontal or Vertical aspect.
flipC :: Orientation -> Corner -> Corner
flipC X (C v L) = C v R
flipC X (C v R) = C v L
flipC Y (C T h) = C B h
flipC Y (C B h) = C T h

-- | Flip a Corner diagonally.
flipD :: Corner -> Corner
flipD = flipC X . flipC Y

-- | A list holding every corner exactly once, and the default LO.
corners :: [Corner]
corners = [TL, TR, BL, BR]

-- | Parameterised version of the inVH accessor functions.
inCi :: Internal a -> Corner -> [a]
inCi i (C T L) = inTL i
inCi i (C T R) = inTR i
inCi i (C B L) = inBL i
inCi i (C B R) = inBR i

-- | @inCi@ from the outer Quadrant object.
inC :: Quadrant tl tr bl br a -> Corner -> [a]
inC = inCi . internals

-- | Replace the windows in the specified quadrant with the supplied list.
updateIni :: Corner -> [a] -> Internal a -> Internal a
updateIni (C T L) l i = i{ inTL = l }
updateIni (C T R) l i = i{ inTR = l }
updateIni (C B L) l i = i{ inBL = l }
updateIni (C B R) l i = i{ inBR = l }

-- | @updateIni@ from the outer Quadrant object.
updateIn :: Corner -> [a] -> Quadrant tl tr bl br a -> Quadrant tl tr bl br a
updateIn c l q = q{ internals = updateIni c l (internals q) }

-- | Update the windows in the specified quadrant with the given function.
updateWithi :: ([a] -> [a]) -> Corner -> Internal a -> Internal a
updateWithi f c i = updateIni c (f $ inCi i c) i

-- | @updateWithi@ from the outer object.
updateWith
  :: ([a] -> [a]) -> Corner -> Quadrant tl tr bl br a -> Quadrant tl tr bl br a
updateWith f c q = updateIn c (f $ inC q c) q

-- | Produce an NEList from a head and a tail.
-- TODO: I hope I'm not doing this too often.
-- A stock NEList wouldn't need to traverse the whole thing.
toNEList :: a -> [a] -> NEList a
toNEList h (t:ts) = h :| toNEList t ts
toNEList h    []  = Single h

-- | Safe head for non-empty lists.
sHead :: NEList a -> a
sHead (Single h) = h
sHead (h :| _  ) = h

-- }}}

-- --< LayoutClass instance >-- {{{

instance Layouts tl tr bl br Window
  => LayoutClass (Quadrant tl tr bl br) Window where

  description q
    | (length . nub) [tld, trd, bld, brd] == 1 = "AllQuadrants (" ++ tld ++ ")"
    | otherwise = "Quadrants (" ++ tld ++ ", " ++ trd ++ ", "
                                ++ bld ++ ", " ++ brd ++ ")"
    where (tld, trd, bld, brd) = ( description (tl q), description (tr q)
                                 , description (bl q), description (br q) )

  -- --< runLayout >-- {{{

  -- TODO: break up further.
  runLayout (W.Workspace tag q@(Quadrant { internals = i, qProfile = qp }) ms)
         sr@(Rectangle xco yco wid hei) = do

    msId <- getScreenOf tag

    let
      (QProfile lo sets pm, (k, qs)) = fixupLookupQS msId tag qp
      -- Active settings reigned in.
      qs' = qs{  xOrigin = bound wid ( xOrigin qs)
              ,  yOrigin = bound hei ( yOrigin qs)
              , cxOffset = bound wid (cxOffset qs)
              , cyOffset = bound hei (cyOffset qs)
              }
        where bound dim = fi dim `div` 2 - 30 & \v -> max (-v) . min v
      qp' = QProfile (if isValidLO lo then lo else corners) ((k,qs'):sets) pm

      -- Partially updated Internal state.
      i' = remanage (i { whereami = Just tag })
        where
          remanage inst
            | length toManage == length (managedL qp' inst)
            = replacement toManage qp' inst
            | otherwise
            = insertNew toManage qp'
            . delUnmanaged (managed inst S.\\ tMSet)
            $ inst

      -- Perform layouting for a child layout. Type variables are scoped.
      doSubLayout
        :: LayoutClass l Window
        => (Quadrant tl tr bl br Window -> l Window) -> Corner
        -> X ([(Window, Rectangle)], Maybe (l Window))
      doSubLayout sl c = runLayout (W.Workspace tag (sl q) (toMS c)) (rect c)
        where
          -- Produces the Maybe (Stack a)s expected by each sublayout, passing
          -- down correct focus information where it can.
          toMS = tryFocus (W.focus <$> ms) . inCi i'
          -- Use the plain Rectangle for a quadrant to produce an expanded or
          -- centred Rectangle as appropriate given the state.
          rect c' = limit sr . expandQ qs' i' sr c' . centreQ qs' i' sr c'
                  $ (Rectangle <$> xOf <*> yOf <*> wOf <*> hOf) c'
          -- The non-centred, non-expanded Rectangles for each quadrant:
          xOf (C _ L) = xco
          xOf (C _ R) = xco + fi wid `div` 2 + fi (xOrigin qs')
          yOf (C T _) = yco
          yOf (C B _) = yco + fi hei `div` 2 - fi (yOrigin qs')
          wOf (C _ L) = fi (xOrigin qs') + wid `div` 2
          wOf (C _ R) = wid - wOf BL
          hOf (C T _) = - fi (yOrigin qs') + hei `div` 2
          hOf (C B _) = hei - hOf TR

    (tlWRs, mtl) <- doSubLayout tl TL
    (trWRs, mtr) <- doSubLayout tr TR
    (blWRs, mbl) <- doSubLayout bl BL
    (brWRs, mbr) <- doSubLayout br BR

    return ( tlWRs ++ trWRs ++ blWRs ++ brWRs
           , Just $ q{ tl = fromMaybe (tl q) mtl, tr = fromMaybe (tr q) mtr
                     , bl = fromMaybe (bl q) mbl, br = fromMaybe (br q) mbr
                     , internals = i' { managed = tMSet }, qProfile = qp'
                     }
           )
    where
      -- The windows in the current stack, integrated into a list.
      toManage = W.integrate' ms
      -- The new managed.
      tMSet = S.fromList toManage

  -- }}}

  -- --< handleMessage >-- {{{

  -- TODO: refactor to separate each case and combine with asum?
  handleMessage q m = case fromMessage m :: Maybe QuadrantMessage of
    Nothing -> case fromMessage m :: Maybe QMessageExtension of
      Nothing -> case fromMessage m :: Maybe LayoutMessages of
        Nothing               -> handleMessage q . SomeMessage
                               $ MessageQ (passMessTo qs) m
        Just ReleaseResources -> runQME (broadcast m) q
        Just Hide             -> runQME (broadcast m) q
      Just (QMessageExtension f) -> f q
    Just qm -> case qm of
      ModifyQProfile f      -> do
        let q'   = q { qProfile = f ps }
            lo'  = order (f ps)
            cps' = (f ps){ order = order ps }
        if | lo == lo'     -> return   (Just q')
           | isValidLO lo' -> mRestack (Just q')
           | otherwise     -> return . Just $ q { qProfile = cps' }
      WithFocusedQ f         -> getFocus i <&&> snd >>=
                                maybe (return Nothing) (handleMessage q) . f
      MessageQ (Only TL) sm  -> handleMessage (tl q) sm <&&> \l -> q { tl = l }
      MessageQ (Only TR) sm  -> handleMessage (tr q) sm <&&> \l -> q { tr = l }
      MessageQ (Only BL) sm  -> handleMessage (bl q) sm <&&> \l -> q { bl = l }
      MessageQ (Only BR) sm  -> handleMessage (br q) sm <&&> \l -> q { br = l }
      MessageQ All       sm  -> runQME (broadcast sm) q
      MessageQ None      _   -> return Nothing
      MessageQ Focused   sm  -> handleMessage q . SomeMessage . WithFocusedQ
                              $ \mc -> SomeMessage ... MessageQ . Only
                                   <$> mc <*> Just sm
      ToQuadrantWith f       -> runQME (toQuadrantWith f) q >>= mRestack
      RedistributeWindows f  -> mRestack
                              $ (lo      ~&~ \c -> updateWith (inC q c++) (f c))
                                (corners ~&~       updateWith (const []) $ q)
                             <$ guard (corners /= fmap f corners)
      -- Satisfying the almighty exhaustivity checker, wrong though it may be.
      -- TODO: check we still need this.
      _                      -> return Nothing
    where mRestack mq = mq <$ whenJust mq restack
          ps@(QProfile lo _ _) = qProfile q
          qs = getQS ps
          i = internals q

  -- }}}

-- }}}

-- --< Settings >-- {{{

-- | TODO
fixupLookupQS
  :: Maybe ScreenId -> WorkspaceId -> QProfile
  -> (QProfile, (Maybe ScreenId, QSettings))
fixupLookupQS msId wId qp@(QProfile _ _ pm)
  = fromMaybe (qp, (Nothing, def))
  $ check qp <|> do
    (lo, sets) <- M.lookup wId pm
    check (QProfile lo sets pm)
  where
    check p = asum (look p <$> nub [msId, Nothing])
    look p k = case break ((== k) . fst) (qSettings p) of
      (l, s:r) -> Just (modPS (const $ l ++ r) p, s)
      _        -> Nothing
    modPS g ps = ps { qSettings = g (qSettings ps) }

-- | TODO
weakLookupQS :: QProfile -> (QProfile, (Maybe ScreenId, QSettings))
weakLookupQS (QProfile lo (kqs:sets) pm) = (QProfile lo sets pm, kqs)
weakLookupQS qp = (qp, (Nothing, def))

-- | TODO
insertQS :: Maybe ScreenId -> QSettings -> QProfile -> QProfile
insertQS msId qs (QProfile lo sets pm) = QProfile lo ((msId,qs):sets) pm

-- | TODO
weakAlterQS :: QProfile -> (QSettings -> QSettings) -> QProfile
weakAlterQS qp f = let (qpcont, (k, qs)) = weakLookupQS qp
                   in  insertQS k (f qs) qpcont

-- | TODO
getQS :: QProfile -> QSettings
getQS qp = snd . snd $ weakLookupQS qp

-- }}}

-- --< Insertion >-- {{{

-- | Given the new list of windows to manage, insert the new ones into q.
--   Works by building a Map from known windows to (non-empty) lists of new
--   windows to be inserted above them, then passes the job off to insFM.
insertNew :: Ord a => [a] -> QProfile -> Internal a -> Internal a
insertNew tml ps i = foldr (.) id qUpdates i
  where
    -- List of functions to update q with.
    qUpdates = zipWith updateIni (order ps) (qContents intRep')
      where
      -- Gets back the contents of each quadrant from an intRep
      qContents = map catMaybes . splitOn Nothing
      -- Our initial internal representation; wraps all windows in Justs and
      -- concatenates the quadrants, using Nothing as a separator.
      intRep = reverse . intercalate [Nothing]
             $ (<$>) Just . inCi i <$> order ps
      -- Post insertion intRep.
      intRep' = insFM (insertAbove . getQS $ ps) [] intRep (nwMap tml i)

-- Building the aforementioned Map. Any new windows not above a known window
-- are keyed to Nothing.
nwMap :: Ord a => [a] -> Internal a -> M.Map (Maybe a) (NEList (Maybe a))
nwMap tml i = uncurry (mInsert Nothing) (foldl acc ([], M.empty) tml)
  where
    acc (l, wmap) w | w `S.member` managed i
                    = ([], mInsert (Just w) l wmap)
                    | otherwise = (Just w : l, wmap)
    -- Ignoring empties, convert a list to an NEL and insert it with key k.
    mInsert _    []  = id
    mInsert k (w:ws) = M.insert k (toNEList w ws)

-- | Insert from Map. Given the insertAbove setting, a zipper of the
--   concatenated internal representation split over two variables and the Map
--   in question, traverse the zipper bottom-up inserting new windows.
insFM :: Ord a => InsertAbove -> [Maybe a] -> [Maybe a]
      -> M.Map (Maybe a) (NEList (Maybe a)) -> [Maybe a]

-- If we're on a separator, proceed to the next entry.
insFM ia ls (Nothing:rs) nMap = insFM ia (Nothing:ls) rs nMap

-- If we're on a window before a separator and the window is a key in our Map,
-- pop the head of the NEList in the Map, inserting it above the separator if ia
-- is Always or if it's IfEmpty and there isn't a window above the separator
-- already. In this case we proceed to the newly inserted window. Otherwise, we
-- insert all windows from the NEList below the separator and proceed past it,
-- removing the Map entry.
insFM ia ls (Just w:Nothing:rs) nMap = case Just w `M.lookup` nMap of
  Nothing -> insFM ia (Nothing:Just w:ls) rs nMap
  Just l   | ia == Always || ia == IfEmpty
                          && (isNothing . join . listToMaybe) rs
          -> insFM ia (Nothing:Just w:ls) (sHead l:rs) (popMap l (Just w) nMap)
           | otherwise
          -> insFM ia (Nothing:toRList l++Just w:ls) rs (M.delete (Just w) nMap)

-- If we're on a window not before a separator and it's a key in our Map, insert
-- the new windows after it and remove the Map entry. Either way, proceed.
insFM ia ls (Just w:rs) nMap = case Just w `M.lookup` nMap of
  Nothing -> insFM ia (Just w:ls) rs nMap
  Just l  -> insFM ia (toRList l ++ Just w:ls) rs (M.delete (Just w) nMap)

-- If we run out of windows and separators, we then deal with insertions not
-- associated with a window. We wish to perform such insertions above any
-- existing window, so we search for the topmost one. If we find one then we
-- associate it with the windows to be inserted, focus on it and recurse.
-- Otherwise we perform one insertion into the lowest quadrant, focusing on and
-- associating further insertions with that window instead.
insFM ia ls [] nMap = case Nothing `M.lookup` nMap of
  Nothing -> ls
  Just l  -> case break isJust ls of
    (ns, jw:js) -> insFM ia js (jw:ns) (popMap (jw:|l) Nothing nMap)
    (ns,    []) -> insFM ia [] (sHead l:ns) (popMap l Nothing nMap)

-- | Used in insFM to pop an element off the start of a list in the Map and make
--   it the new key.
popMap :: Ord k => NEList k -> k -> M.Map k (NEList k) -> M.Map k (NEList k)
popMap (w1:|ws) = M.insert w1 ws ... M.delete
popMap      _   = M.delete

-- | toList conversion, reversing in the process.
toRList :: NEList a -> [a]
toRList = foldl (flip (:)) []

-- }}}

-- --< Replacement; deletion >-- {{{

-- | Produce a list of all managed windows in their proper order.
managedL :: QProfile -> Internal a -> [a]
managedL ps i = foldMap (inCi i) (order ps)

-- | When the number of windows being managed has not changed, then rather than
--   using the insertion algorithm, this function is applied and old windows
--   are swapped out for new ones in-place.
replacement :: Ord a => [a] -> QProfile -> Internal a -> Internal a
replacement tmL ps i = corners ~&~ updateWithi (map replace) $ i
  where ml = managedL ps i
        replace w = fromMaybe w (M.lookup w repM)
        repM = M.fromList $ filter (uncurry (/=)) (zip ml tmL)

-- | Removes any unmanaged windows from internal state.
delUnmanaged :: Ord a => S.Set a -> Internal a -> Internal a
delUnmanaged dels = corners ~&~ updateWithi (filter (`S.notMember` dels))

-- }}}

-- --< Expansion; centering >-- {{{

-- | Parametrised form of xCentre.
centre :: Orientation -> QSettings -> Bool
centre X = xCentre
centre Y = yCentre

-- | Parametrised form of xExpand.
expand :: Orientation -> QSettings -> Bool
expand X = xExpand
expand Y = yExpand

-- | Given Quadrant state holding settings and the screen Rectangle, perform
--   centring on the Rectangle of the specified quadrant.
centreQ
  :: QSettings -> Internal a -> Rectangle -> Corner -> Rectangle -> Rectangle
centreQ s i (Rectangle _ _ xRes yRes) c (Rectangle x y wid hei)
  = Rectangle (x + translation (cen X) (isR c) ( cxOffset s) (xRes - wid))
              (y + translation (cen Y) (isB c) (-cyOffset s) (yRes - hei))
              wid hei
  where
    translation centring rev offset freeSpace
      | centring  = fi offset + (if rev then -1 else 1) * (fi freeSpace `div` 2)
      | otherwise = 0
    cPrefer X = not . cPreferV
    cPrefer Y = cPreferV
    cen = doQuadAct centre (not . preferE) expand cPrefer s i c
    isR (C _ h) = h == R
    isB (C v _) = v == B

-- | Given Quadrant state holding settings and the screen Rectangle, perform
--   expansion on the Rectangle of the specified quadrant.
expandQ
  :: QSettings -> Internal a -> Rectangle -> Corner -> Rectangle -> Rectangle
expandQ s i (Rectangle l t xRes yRes) c (Rectangle ql qt wid hei)
  = Rectangle (if ex X then l    else ql)  (if ex Y then t    else qt)
              (if ex X then xRes else wid) (if ex Y then yRes else hei)
  where ex = doQuadAct expand preferE centre ePrefer s i c
        ePrefer X = not . ePreferV
        ePrefer Y = ePreferV

-- | The same logic that controls both expansion and centring, factored out.
--   Determines whether or not to perform act1 on the specified quadrant, in the
--   given orientation.
doQuadAct
  :: (Orientation -> QSettings -> Bool)
  -> (               QSettings -> Bool)
  -> (Orientation -> QSettings -> Bool)
  -> (Orientation -> QSettings -> Bool)
  -> QSettings -> Internal a -> Corner -> Orientation -> Bool
doQuadAct act1 pref1 act2 pref2 s i c ori
  -- act1 is enabled along ori in q.
  =  act1 ori s
  -- If act2 is enabled along ori in q, act1 better have preference.
  && (act2 ori s ==> pref1 s)
  -- The quadrant we're expanding or centring into better be empty.
  && cNull i (flipC ori c)
  -- If act1 is enabled in the other orientation, then either the diagonally
  -- opposite quadrant better be empty, or this orientation better have
  -- preference.
  && (act1 (flipO ori) s ==> cNull i (flipD c) || pref2 ori s)
  -- If act2 is enabled in the other orientation, then either the diagonally
  -- opposite quadrant better be empty, or act1 better have preference.
  && (act2 (flipO ori) s ==> cNull i (flipD c) || pref1 s)
  where flipO X = Y
        flipO Y = X
        cNull = null ... inCi

-- | Given the screen Rectangle, reposition a quadrant's Rectangle to fit
--   within. Ensures centred windows with large offsets remain confined within
--   the screen Rectangle if possible.
limit :: Rectangle -> Rectangle -> Rectangle
limit (Rectangle x0 y0 xRes yRes) (Rectangle x y w h) = Rectangle newx newy w h
  where
    newx = max x0 . (x -) . max 0 $ (x + fi w) - (x0 + fi xRes)
    newy = max y0 . (y -) . max 0 $ (y + fi h) - (y0 + fi yRes)

-- }}}

-- --< Messaging >-- {{{

-- | Stack getter function.
getStack :: WorkspaceId -> X (Maybe (W.Stack Window))
getStack tag = withWindowSet $ \ws ->
  return . join $ W.stack <$> find ((== tag) . W.tag) (W.workspaces ws)

-- | Manipulate the stack to better match the Quadrant state; reusing the
--   insertion algorithm to minimally disturb any windows we're ignorant of.
restack :: Quadrant tl tr bl br Window -> X ()
restack (Quadrant { internals = i, qProfile = qp })
  = whenJust mTag (windowsNR . W.mapWorkspace . reSt)
  where
    mTag = whereami i
    reSt tag w@(W.Workspace t _ mSt) | tag == t  = w { W.stack = qStack mSt }
                                     | otherwise = w
    qStack mSt2 = tryFocus (W.focus <$> mSt2) . catMaybes
                $ insFM Never [] intRep (nwMap (W.integrate' mSt2) i)
    intRep = reverse (Just <$> managedL qp i)

-- | Maybe given a focus and a list, try to make a correctly focused W.Stack.
tryFocus :: Eq a => Maybe a -> [a] -> Maybe (W.Stack a)
tryFocus _       []  = Nothing
tryFocus mFoc (w:ws) = mFoc <&> \foc -> case break (== foc) (w:ws) of
    (up, _:down) -> W.Stack foc (reverse up) down
    _            -> W.Stack w [] ws

-- | If there is one, get the focused window and the quadrant housing it.
getFocus :: Internal Window -> X (Maybe (Window, Corner))
getFocus i = do
  mw <- joinMX (whereami i <&> getStack) <&&> W.focus
  let mc = do
        w <- mw
        -- TODO: isn't this just @find@?
        listToMaybe . filter (elem w . inCi i)
                    $ corners
  return $ (,) <$> mw <*> mc
  where
    joinMX :: Maybe (X (Maybe a)) -> X (Maybe a)
    joinMX = fromMaybe (return Nothing)

-- | Maybe move the focused window from its current quadrant to the one f maps
--   it to, without updating the stack.
toQuadrantWith :: (Corner -> Corner) -> QMessageExtension
toQuadrantWith f = QMessageExtension $ \q -> do
  mwc <- getFocus (internals q)
  return $ do
    (w, c) <- mwc
    guard (f c /= c)
    return . updateWith (w:)            (f c)
           . updateWith (filter (w /=))    c
           $ q

-- | Broadcast a Message to all sublayouts.
broadcast :: SomeMessage -> QMessageExtension
broadcast m = QMessageExtension $ \q -> do
  mtl' <- handleMessage (tl q) m
  mtr' <- handleMessage (tr q) m
  mbl' <- handleMessage (bl q) m
  mbr' <- handleMessage (br q) m
  return $ q { tl = fromMaybe (tl q) mtl', tr = fromMaybe (tr q) mtr'
             , bl = fromMaybe (bl q) mbl', br = fromMaybe (br q) mbr'
             }
        <$ asum [void mtl', void mtr', void mbl', void mbr']

-- }}}

-- --< Misc >-- {{{

-- | Given a workspace, get the screen hosting it, if any.
getScreenOf :: WorkspaceId -> X (Maybe ScreenId)
getScreenOf wId = withWindowSet $ \ws ->
  return $ W.screen <$> find ((== wId) . W.tag . W.workspace) (W.screens ws)

-- | Modify the windowset as one would with `windows` but don't perform a full
--   refresh; only update window border colours.
windowsNR :: (WindowSet -> WindowSet) -> X ()
windowsNR f = do
  oldws <- gets windowset
  let newws = f oldws
      mOldW = W.peek oldws
      mNewW = W.peek newws

  when (mOldW /= mNewW) $ do
    XConf { display = dpy, normalBorder = nbc, focusedBorder = fbc } <- ask

    whenJust mOldW $ \oldW -> do
      nbs <- asks (normalBorderColor . config)
      setWindowBorderWithFallback dpy oldW nbs nbc

    whenJust mNewW $ \newW -> do
      fbs <- asks (focusedBorderColor . config)
      setWindowBorderWithFallback dpy newW fbs fbc

  modify $ \xs -> xs { windowset = newws }

-- | Cycle a list to an element satisfying a predicate.
cycleTo :: (a -> Bool) -> [a] -> [a]
cycleTo p as = case break p as of (l, a:r) -> a:r ++ l
                                  _        -> as

-- | Verify that a [Corner] unambiguously represents a linear ordering.
isValidLO :: [Corner] -> Bool
isValidLO cs = (length . take 5) cs == 4 && (length . nub) cs == 4

-- | Blackbird combinator.
-- TODO: rename to (.:)
-- (and, tbh, probably just don't use it)
(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
f ... g = \x -> f . g x
infixl 8 ...

-- | Reverse fmap from Data.Functor. Not in pre 4.11 base.
(<&>) :: Functor f => f a -> (a -> b) -> f b
(<&>) = flip $ (<$>)
infixr 4 <&>

-- | Reverse double-fmap for all those troublesome X (Maybe a)s.
(<&&>) :: (Functor f, Functor g) => f (g a) -> (a -> b) -> f (g b)
(<&&>) = flip $ (<$>) . (<$>)
infixr 4 <&&>

-- | Map over a list and fold down with composition (reversed).
(~&~) :: [a] -> (a -> b -> b) -> (b -> b)
(~&~) = flip $ foldr (.) id ... (<$>)

-- | Alias.
fi :: (Integral a, Num b) => a -> b
fi = fromIntegral

-- | Break xs into the segments not containing x. E.g.
--   lines = splitOn '\n'
--   words = splitOn ' '
splitOn :: Eq a => a -> [a] -> [[a]]
splitOn x xs = let (prex, xonwards) = break (== x) xs in
  prex : case xonwards of _:onwards -> splitOn x onwards
                          _         -> []

-- | Implication. Lower precedence than && and ||.
(==>) :: Bool -> Bool -> Bool
b1 ==> b2 = not b1 || b2
infixl 1 ==>

-- }}}

Quadrant.hs

{-# LANGUAGE PatternSynonyms #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.Quadrant
-- Description :  The outer interface to the Quadrant layout.
-- Copyright   :  (c) 2018  L. S. Leary
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  L. S. Leary
-- Stability   :  unstable
-- Portability :  unportable
--
-- Provides the Quadrant layout which takes as parameters four sublayouts with
-- which to tile each quadrant of the screen, and offers a highly configurable
-- set of possible centring and expansion behaviours when not all quadrants are
-- occupied. It is intended to be used with highly automated layouts like tabbed
-- or Grid in order to bridge a gap between SplitGrid and BSP on the spectrum of
-- layouts trading off automation for window-arranging power.
--------------------------------------------------------------------------------

-- --< Exports; Imports >-- {{{

module XMonad.Layout.Quadrant (
  -- * Usage
  -- $Usage
  Quadrant(..), AllQuadrants,
  -- ** Settings
  QProfile(..), ProfileMap, QSettings(..), InsertAbove(..),
  -- *** Profile Synonyms
  -- $ProfileSynonyms
  pattern Alternative, pattern Lies,
  -- ** Producing Quadrant Values
  quadrant, allQuadrants, quadGrid,
  -- * The QuadrantMessage Interface
  -- $QuadrantMessageInterface
  QuadrantMessage(..), TargetQ(..),
  -- ** User-Level Messages
  -- *** Performing X Actions with Quadrant State
  cycleInQ, cycleThroughQs,
  -- *** Window Shifting
  pushWindow, pushWindowD, swapWindows, swapWindowsD,
  -- *** Changing Settings
  modifyActiveQS, modifyPreferE, modifyExpand, modifyEPreferV,
  modifyInsertAbove, modifyCentre, modifyCPreferV, resetQSettings,
  reorderWith, toggleLtoRTopDown, toggleAltQS, toggleLies,
  transformOrigin, transformCOffset, shiftOrigin, shiftCentred,
  -- ** Convenience Functions
  toggle, set, rotate, cycleIA, messageQ, withFocusedQ, toggleProf,
  -- * Spatial Types
  -- $SpatialTypes
  Corner(..), Vertical(..), Horizontal(..), Orientation(..),
  -- ** Corner Synonyms
  -- $CornerSynonyms
  pattern TL, pattern TR, pattern BL, pattern BR
) where

import Data.Maybe (fromMaybe,listToMaybe)
import qualified Data.Map.Strict as M

import XMonad hiding ((<&&>),(<||>))
import qualified XMonad.StackSet as W
import XMonad.Layout.Grid (Grid(..))
import XMonad.Util.PureX

import XMonad.Layout.Quadrant.Internal

-- }}}

-- --< Usage >-- {{{

-- $Usage
--
-- The Quadrant layout has many settings, and uses a profile system both as an
-- aid to managing them and as a means to implement stateful manipulations on
-- the user side, as demonstrated by the 'toggleLies' message. The settings
-- currently in effect are stored in the 'ProfileMap' under the key 'Active' (or
-- @"active"@); if that location is empty then the name of the workspace is
-- checked before falling back on the global defaults given by the @Default@
-- instance.
--
-- Note that Quadrant can be confusing when you're not used to its behaviour,
-- particularly when centring and expansion of the quadrants—"lies"—obscure
-- which windows belong to which. It's recommended to set up a keybinding to the
-- @toggleLies@ message mentioned above and use it unsparingly until an
-- intuition is formed.
--
-- Example config:
--
-- > import XMonad
-- > import XMonad.Layout.Quadrant hiding (C,L,R)
-- >
-- > import qualified Data.Map as M
-- >
-- > main :: IO ()
-- > main = xmonad def
-- >   { keys = quadKeys <> keys def
-- >   , layoutHook = quadGrid { profiles = myQProfiles } ||| Full
-- >   }
-- >
-- > -- A ProfileMap holding defaults for workspaces with tags "1", "2", "3",
-- > -- "F3", etc. Note it does not set an Active value; if it did the workspace
-- > -- defaults would not be loaded until such a time as the `resetQSettings`
-- > -- message were sent.
-- > myQProfiles :: ProfileMap
-- > myQProfiles = M.fromList $ video ++ coding ++
-- >   [ ("1", def { xExpand = True, ePreferV = False, yOrigin = -220 })
-- >   , ("2", def { yExpand = False, xOrigin = 200, yOrigin = -50 })
-- >   , ("8", def { xExpand = True })
-- >   ] where addFs  = ([id, ('F':)] <*>)
-- >           coding = (,) <$> addFs ["5", "6"] <*> pure def { yOrigin =  210 }
-- >           video  = (,) <$> addFs ["3"]      <*> pure def
-- >             { xOrigin = 630, yOrigin = -340, order = [TL,BL,TR,BR] }
-- >
-- > quadKeys :: XConfig Layout -> Data.Map.Map (ButtonMask, KeySym) (X ())
-- > quadKeys conf = M.fromList
-- >   [ ((modm               , xK_l),      sM   toggleLies)
-- >
-- >   -- Reset settings to defaults.
-- >   , ((modm.|.ctrl.|.shift, xK_r),      sM   resetQSettings)
-- >
-- >   -- Shifting the origin.
-- >   , ((modm.|.ctrl.|.shift, xK_h),      sM $ shiftOrigin X (-30))
-- >   , ((modm.|.ctrl.|.shift, xK_j),      sM $ shiftOrigin Y (-30))
-- >   , ((modm.|.ctrl.|.shift, xK_k),      sM $ shiftOrigin Y   30)
-- >   , ((modm.|.ctrl.|.shift, xK_l),      sM $ shiftOrigin X   30)
-- >
-- >   -- Shift horizontally centred windows left or right.
-- >   , ((       ctrl.|.shift, xK_h),      sM $ shiftCentred X (-30))
-- >   , ((       ctrl.|.shift, xK_l),      sM $ shiftCentred X   30)
-- >   -- Reset offset to 0.
-- >   , ((       ctrl.|.shift, xK_r),      sM $ transformCOffset (set (0,0)))
-- >
-- >   -- Toggle expansion.
-- >   , ((       ctrl.|.shift, xK_j),      sM $ modifyExpand toggle X)
-- >   , ((       ctrl.|.shift, xK_k),      sM $ modifyExpand toggle Y)
-- >   -- Toggle centring.
-- >   , ((       ctrl.|.shift, xK_comma),  sM $ modifyCentre toggle X)
-- >   , ((       ctrl.|.shift, xK_period), sM $ modifyCentre toggle Y)
-- >
-- >   -- Shift the focused window to an adjacent quadrant.
-- >   , ((modm               , xK_a),      sM $ ToQuadrantWith rotate)
-- >   , ((modm               , xK_s),      sM   pushWindowD)
-- >   , ((modm               , xK_d),      sM $ pushWindow X)
-- >   , ((modm               , xK_f),      sM $ pushWindow Y)
-- >
-- >   -- Rotate all windows between quadrants.
-- >   , ((modm       .|.shift, xK_a),      sM $ RedistributeWindows rotate)
-- >   -- Swap the contents of the focused quadrant with an adjacent one.
-- >   , ((modm       .|.shift, xK_s),      sM   swapWindowsD)
-- >   , ((modm       .|.shift, xK_d),      sM $ swapWindows X)
-- >   , ((modm       .|.shift, xK_f),      sM $ swapWindows Y)
-- >
-- >   -- Cycle the insertAbove setting through all three options.
-- >   , ((modm,                xK_a),      sM $ modifyInsertAbove cycleIA)
-- >
-- >   -- Toggle the quadrant ordering between the two most obvious choices.
-- >   , ((modm,                xK_s),      sM   toggleLtoRTopDown)
-- >
-- >   -- Set ePreferV to False so horizontal expansion will be preferred.
-- >   , ((modm,                xK_v),      sM $ modifyEPreferV (set False))
-- >
-- >   ] where sM    = sendMessage
-- >           ctrl  = controlMask
-- >           shift = shiftMask
-- >           modm  = modMask conf

-- }}}

-- --< Quadrant Constructors >-- {{{

-- | A user version of the Quadrant constructor with empty internals passed.
--   Use as, e.g.
--
-- > , layoutHook = quadrant myQProfiles Grid Grid Grid Grid
--
quadrant :: ProfileMap -> tl a -> tr a -> bl a -> br a -> Quadrant tl tr bl br a
quadrant = Quadrant def . QProfile corners []

-- | Construct an empty @'AllQuadrants' l a@ given profiles and a layout. E.g.
--
-- > , layoutHook = allQuadrants myQProfiles Grid
--
allQuadrants :: ProfileMap -> l a -> AllQuadrants l a
allQuadrants profs l = quadrant profs l l l l

-- | Construct an empty, @'AllQuadrants' 'Grid' a@ with target ratio 3/2 and no
--   profiles. E.g.
--
-- > , layoutHook = quadGrid { profiles = myQProfiles }
--
quadGrid :: AllQuadrants Grid a
quadGrid = allQuadrants M.empty $ GridRatio (3/2)

-- }}}

-- --< Messages: X Actions Using Quadrant State >-- {{{

-- | Cycle focus through the windows in the current quadrant.
cycleInQ :: QuadrantMessage
cycleInQ = withFocusedQ $ \c -> QMessageExtension $ \q -> do
  mu <- withFocii $ \_ fw ->
    case cycleTo (== fw) (inC q c) of
      _:w:_ -> Just () <$ modifyWindowSet (W.focusWindow w)
      _     -> return Nothing
  return (mu <&> \_ -> q)

-- | Cycle focus through the quadrants.
cycleThroughQs :: QuadrantMessage
cycleThroughQs = withFocusedQ $ \fc -> QMessageExtension $ \q ->
  let cs = filter (not . null . inC q) (order $ qProfile q)
  in case inC q <$> cycleTo (== fc) cs of
    _:(w:_):_ -> Just q <$ modifyWindowSet (W.focusWindow w)
    _         -> return Nothing

-- }}}

-- --< Messages: Window Manipulation >-- {{{

-- | Move the focused window to the quadrant adjacent with respect to the
--   supplied 'Orientation'.
pushWindow :: Orientation -> QuadrantMessage
pushWindow = ToQuadrantWith . flipC

-- | Move the focused window to the quadrant diagonally opposite.
pushWindowD :: QuadrantMessage
pushWindowD = ToQuadrantWith flipD

-- | Swap the contents of the focused quadrant with those in the quadrant
--   adjacent with respect to the supplied 'Orientation'.
swapWindows :: Orientation -> QuadrantMessage
swapWindows o = WithFocusedQ . (<$>) $ \c1 -> SomeMessage . RedistributeWindows
              $ \c2 -> if c2 `elem` [c1, flipC o c1] then flipC o c2 else c2

-- | Swap the contents of the focused quadrant with those in the quadrant
--   diagonally opposite.
swapWindowsD :: QuadrantMessage
swapWindowsD = WithFocusedQ . (<$>) $ \c1 -> SomeMessage . RedistributeWindows
             $ \c2 -> if c2 `elem` [c1, flipD c1] then flipD c2 else c2

-- }}}

-- --< Messages: Profile Manipulation >-- {{{

-- | Reset settings to defaults.
resetQSettings :: QuadrantMessage
resetQSettings = ModifyQProfile $ \ps ->
  ps { qSettings = drop 1 (qSettings ps) }

-- | Toggle out the 'Active' settings for the 'Alternative' settings. Simply
--   enables the use of two independent configurations.
toggleAltQS :: QuadrantMessage
toggleAltQS = ModifyQProfile $ toggleProf (\_ alts -> alts) Alternative

-- | If you have any centring or expansion settings on, then overwrite the
--   @Lies@ profile with @Active@ and disable them. Otherwise, read in those
--   settings from @Lies@ and write them to @Active@.
toggleLies :: QuadrantMessage
toggleLies = ModifyQProfile  $ toggleProf togL Lies
  where setLies xE yE xC yC s = s { xExpand = xE, yExpand = yE
                                  , xCentre = xC, yCentre = yC }
        togL s l | xExpand s || yExpand s || xCentre s || yCentre s
                 = (\f a -> f a a a a) setLies False s
                 | otherwise
                 = (setLies <$> xExpand <*> yExpand <*> xCentre <*> yCentre) l s

-- }}}

-- --< Messages: Manipulate Active Settings >-- {{{

-- | Modify the settings currently in effect.
modifyActiveQS :: (QSettings -> QSettings) -> QuadrantMessage
modifyActiveQS f = ModifyQProfile $ \qp@(QProfile _ sets _) ->
  qp { qSettings = (take 1 sets <&&> f) ++ drop 1 sets }

-- | Change the 'preferE' setting.
modifyPreferE :: (Bool -> Bool) -> QuadrantMessage
modifyPreferE f = modifyActiveQS $ \s -> s { preferE = f (preferE s) }

-- | Change the 'xExpand' or 'yExpand' setting depending on the supplied
--   'Orientation'.
modifyExpand :: (Bool -> Bool) -> Orientation -> QuadrantMessage
modifyExpand f X = modifyActiveQS $ \s -> s { xExpand = f (xExpand s) }
modifyExpand f Y = modifyActiveQS $ \s -> s { yExpand = f (yExpand s) }

-- | Change the 'ePreferV' setting.
modifyEPreferV :: (Bool -> Bool) -> QuadrantMessage
modifyEPreferV f = modifyActiveQS $ \s -> s { ePreferV = f (ePreferV s) }

-- | Change the 'xCentre' or 'yCentre' setting depending on the supplied
--   'Orientation'.
modifyCentre :: (Bool -> Bool) -> Orientation -> QuadrantMessage
modifyCentre f X = modifyActiveQS $ \s -> s { xCentre = f (xCentre s) }
modifyCentre f Y = modifyActiveQS $ \s -> s { yCentre = f (yCentre s) }

-- | Change the 'cPreferV' setting.
modifyCPreferV :: (Bool -> Bool) -> QuadrantMessage
modifyCPreferV f = modifyActiveQS $ \s -> s { cPreferV = f (cPreferV s) }

-- | Change the 'insertAbove' setting.
modifyInsertAbove :: (InsertAbove -> InsertAbove) -> QuadrantMessage
modifyInsertAbove f = modifyActiveQS
                    $ \s -> s { insertAbove = f (insertAbove s) }

-- | Change the position of the origin arbitrarily.
transformOrigin :: ((Int, Int) -> (Int, Int)) -> QuadrantMessage
transformOrigin transform = modifyActiveQS $ \s ->
  let (newX, newY) = transform (xOrigin s, yOrigin s)
  in  s { xOrigin = newX, yOrigin = newY }

-- | Shift the origin by the given amount along the given axis.
shiftOrigin :: Orientation -> Int -> QuadrantMessage
shiftOrigin X n = transformOrigin $ \(x, y) -> (x + n, y)
shiftOrigin Y n = transformOrigin $ \(x, y) -> (x, y + n)

-- | Change the centring offset arbitrarily.
transformCOffset :: ((Int, Int) -> (Int, Int)) -> QuadrantMessage
transformCOffset transform = modifyActiveQS $ \s ->
  let (newX, newY) = transform (cxOffset s, cyOffset s)
  in  s { cxOffset = newX, cyOffset = newY }

-- | Shift centred quadrants by the given amount along the given axis.
shiftCentred :: Orientation -> Int -> QuadrantMessage
shiftCentred X n = transformCOffset $ \(x, y) -> (x + n, y)
shiftCentred Y n = transformCOffset $ \(x, y) -> (x, y + n)

-- | Change the linear ordering on the quadrants. If the given function does not
--   produce a valid LO from the active one then no change will be made.
reorderWith :: ([Corner] -> [Corner]) -> QuadrantMessage
reorderWith f = ModifyQProfile $ \qp -> qp { order = f (order qp) }

-- | A Message to toggle the linear ordering between two typical values:
--   left to right then top-down, and top-down then left to right.
toggleLtoRTopDown :: QuadrantMessage
toggleLtoRTopDown = reorderWith (g <$>)
  where g TR = BL
        g BL = TR
        g c   = c

-- }}}

-- --< Convenience functions >-- {{{

-- | An alias of 'not'; use in a modify messages to flip a Bool setting.
toggle :: Bool -> Bool
toggle = not

-- | An alias of 'const'; produces a constant function returning the first
--   argument, and hence can be used in modify and transform messages to set a
--   value.
set :: a -> b -> a
set = const

-- | Rotates a 'Corner' 90 degrees clockwise. For use with 'ToQuadrantWith' and
--   'RedistributeWindows'.
rotate :: Corner -> Corner
rotate (C T L) = C T R
rotate (C T R) = C B R
rotate (C B R) = C B L
rotate (C B L) = C T L

-- | Cycles though the values in the InsertAbove type.
cycleIA :: InsertAbove -> InsertAbove
cycleIA IfEmpty = Always
cycleIA Always  = Never
cycleIA Never   = IfEmpty

-- | A version of @WithFocusedQ@ that does not require a @SomeMessage@ wrapper
--   and assumes you want to do nothing if the workspace is empty.
withFocusedQ :: Message m => (Corner -> m) -> QuadrantMessage
withFocusedQ f = WithFocusedQ . (<$>) $ SomeMessage . f

-- | A version of @MessageQ@ that does not require the @SomeMessage@ wrapper.
messageQ :: Message m => TargetQ -> m -> QuadrantMessage
messageQ target message = MessageQ target (SomeMessage message)

-- | Write the current settings to the given profile, then make 'combine' of the
--   current settings and those that were in the given profile current.
--   If the given profile is empty, it's initially treated as equal to current.
toggleProf
  :: (QSettings -> QSettings -> QSettings) -> String -> QProfile -> QProfile
toggleProf combine prof qp@(QProfile lo sets m) =
  qp { profileMap = m' } `weakAlterQS` \qs -> qs `combine` fromMaybe qs maqs
  where insertLookup = M.insertLookupWithKey (\_ a _ -> a)
        (mAltlosets, m') = insertLookup prof (lo, sets) m
        maqs = snd <$> mAltlosets >>= (<$>) snd . listToMaybe

-- }}}