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