path: root/src/Rahm/Desktop/Layout/LayoutList.hs

{-# LANGUAGE UndecidableInstances #-}

{-
 - 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 Rahm.Desktop.Layout.LayoutList (
  LayoutList,
  layoutZipper,
  LCons,
  LNil,
  toNextLayout,
  toPreviousLayout,
  toFirstLayout,
  (|:),
  nil
  )where

import Control.Applicative ((<|>))
import Data.Void
import Control.Monad.Identity (runIdentity)
import Data.Maybe (fromMaybe, fromJust)
import Control.Arrow (second)
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)

-- 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 End)))
--
-- 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 End) can only be in the Sel as End 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)
deriving instance (Eq l, Selector l) => Eq (Sel l)

-- Reimplement Void as End, just to keep the two separate, but End is for all
-- intents and purposes Void.
data End
deriving instance Read End
deriving instance Show End
deriving instance Eq End


-- 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 (Eq c) => 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 End structure (which is equivalent to Void) is the "null" selector; the
-- basecase that the Sel selector terminates at.
instance Selector End where

  -- Incrementing the End Selector doesn't do anything.
  increment = const Nothing

  -- Decrementing the End Selector doesn't do anythig
  decrement = const Nothing

  -- There is no initial value for the End selector.
  initial = Nothing

  -- There is not final state for the End selector.
  final = Nothing

-- Increment a selector, but cyclicly
incrementCycle :: (Selector c) => c -> c
incrementCycle c =
  case increment c of
    Nothing -> fromMaybe c initial
    Just x -> x

-- Add two selectors together, incrementing the first until the second cannot be
-- incremented anymore.
addSelector :: (Selector c) => c -> c -> c
addSelector c1 c2 = addSel c1 (decrement c2)
  where
    addSel c1 Nothing = c1
    addSel c1 (Just c2) = addSel (incrementCycle c1) (decrement c2)

-- Turn an int into a selector by repeatably incrementing.
intToSelector :: (Selector c) => Int -> c
intToSelector 0 = fromJust initial
intToSelector n = incrementCycle $ intToSelector (n - 1)

-- A LayoutList consists of a LayoutSelect type and a corresponding Selector.
data LayoutList l a where
  LayoutList ::
    (LayoutSelect l a, Selector (SelectorFor l)) =>
      SelectorFor l -> l a -> LayoutList l a

deriving instance (LayoutSelect l a) => Show (LayoutList l a)
deriving instance (LayoutSelect l a) => Read (LayoutList l a)

(|:) :: (LayoutSelect t a, LayoutClass l a) => l a -> t a -> LCons l t a
(|:) = LCons

infixr 5 |: 

-- Constructs a LayoutList. 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 LayoutList cannot be constructed.
layoutZipper :: (LayoutSelect l a, SelectorFor l ~ Sel n) =>
  l a -> LayoutList l a
layoutZipper = LayoutList Sel

-- The termination of a layout zipper.
nil :: LNil a
nil = LNil

-- Message to navigate to a layout.
newtype NavigateLayout =
          -- Sets the layout based on the given function.
          NavigateLayout {
            changeLayoutFn :: forall c. (Selector c) => c -> c
          }
          deriving (Typeable)

-- NavigateLayout instance to move to the next layout, circularly.
toNextLayout :: NavigateLayout
toNextLayout = NavigateLayout $ addSelector (intToSelector 1)

-- NavigateLayout instance to move to the previous layout, circularly.
toPreviousLayout :: NavigateLayout
toPreviousLayout = NavigateLayout $ \c -> fromMaybe c (decrement c <|> final)

-- NavigateLayotu instance to move to the first layout.
toFirstLayout :: NavigateLayout
toFirstLayout = NavigateLayout (`fromMaybe` initial)

instance Message NavigateLayout where

-- 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) =>
    -- 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))) ->

    -- Returns a result r, and an updated LayoutSelect.
    m (Maybe (r, l a))

-- 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

  -- The SelectorFor Cons is Sel (SelectorFor t). This creates the structure
  -- Sel (Sel (Sel ( ... (Sel End) .. ))) 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)

  -- 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)

  -- 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

-- 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 End type.
instance LayoutSelect LNil a where
  type SelectorFor LNil = End -- LNil cannot be selected.
  update _ _ _ = return Nothing

-- Instance of layout class for LayoutList. 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 (LayoutList l) a where

  runLayout (W.Workspace i (LayoutList 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 (LayoutList idx la))

  pureLayout (LayoutList 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 (LayoutList idx l) r = do
    r <- update idx l $ \layout -> emptyLayout layout r
    case r of
      Nothing -> return ([], Nothing)
      Just (r, la) -> return (r, Just (LayoutList idx la))

  handleMessage (LayoutList idx l) (fromMessage -> Just (NavigateLayout fn)) =
    return $ Just (LayoutList (fn idx) l)

  handleMessage (LayoutList idx l) m = do
    r <- update idx l $ \layout -> ((),) <$> handleMessage layout m
    return $ LayoutList idx . snd <$> r

  pureMessage (LayoutList idx l) m = runIdentity $ do
    r <- update idx l $ \layout -> return ((), pureMessage layout m)
    return $ LayoutList idx . snd <$> r

  description (LayoutList idx l) = runIdentity $ do
    r <- update idx l $ \l -> return (description l, Nothing)
    return $
      case r of
        Nothing -> "No Layout"
        Just (descr, _) -> descr