{-# 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, and thus the list is navigatable. -}
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)

-- Combinator for combining layouts together into a LayoutList. This amy then be
-- used with the layoutZipper to create a layout zipper.
(|:) :: (LayoutSelect t a, LayoutClass l a) => l a -> t a -> LCons l t a
(|:) = LCons
infixr 5 |:

-- Create a layoutZipper that defaults to the first layout in the list.
layoutZipper :: (LayoutSelect l a) => l a -> LayoutZipper l a
layoutZipper = LayoutZipper 0

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

-- Message to navigate to a layout.
data NavigateLayout =
          -- Sets the layout based on the given function.
          SetLayout {
            changeLayoutFn :: Int -> Int -- Function to use to change the layout.
          , circularBool :: Bool -- True if the layouts should be treated as circular.
          }
          deriving (Typeable)

-- NavigateLayout instance to move to the next layout, circularly.
toNextLayout :: NavigateLayout
toNextLayout = SetLayout (+1) True

-- NavigateLayout instance to move to the previous layout, circularly.
toPreviousLayout :: NavigateLayout
toPreviousLayout = SetLayout (\x -> x - 1) True

-- NavigateLayotu instance to move to the first layout.
toFirstLayout :: NavigateLayout
toFirstLayout = SetLayout (const 0) True

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 (SetLayout fn circ)) =
    let clip = if circ then mod else \i n -> max 0 $ min (n - 1) i in
          return $ Just $ LayoutZipper (clip (fn idx) (nLayouts l)) 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