{-# LANGUAGE GADTs, RankNTypes, FlexibleInstances, MultiParamTypeClasses,
 FlexibleContexts, UndecidableInstances, ViewPatterns, StandaloneDeriving,
 RankNTypes, TupleSections, TypeFamilies #-}

{- 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 Data.Void
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 IsSelected l = Selected | NotSelected l
  deriving (Read, Show)

-- Combinator for combining layouts together into a LayoutList. This amy then be
-- used with the layoutZipper to create a layout zipper.
class SelectionClass c where
  nextSelection :: c -> c
  prevSelection :: c -> c
  firstSelection :: Maybe c
  isSelected :: c -> Bool

instance (SelectionClass t) => SelectionClass (IsSelected t) where
  nextSelection (NotSelected l) = NotSelected (nextSelection l)
  nextSelection Selected = maybe Selected NotSelected firstSelection 

  firstSelection = Just Selected

  prevSelection (NotSelected t) =
    if isSelected t
      then Selected
      else NotSelected (prevSelection t)
  prevSelection Selected = Selected

  isSelected Selected = True
  isSelected _ = False

instance SelectionClass Void where
  nextSelection = absurd
  prevSelection = absurd
  firstSelection = Nothing
  isSelected = const False

data LayoutZipper l a where
  LayoutZipper :: (LayoutSelect l a) => Selection l -> l a -> LayoutZipper l a

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

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

infixr 5 |: 

layoutZipper :: (LayoutSelect l a, Selection l ~ IsSelected n) => l a -> LayoutZipper l a
layoutZipper = LayoutZipper Selected

-- 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. (SelectionClass c) => c -> c
          }
          deriving (Typeable)

-- NavigateLayout instance to move to the next layout, circularly.
toNextLayout :: NavigateLayout
toNextLayout = NavigateLayout nextSelection

-- NavigateLayout instance to move to the previous layout, circularly.
toPreviousLayout :: NavigateLayout
toPreviousLayout = NavigateLayout prevSelection

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

instance Message NavigateLayout where

class (
     Show (l a),
     Read (l a),
     Read (Selection l),
     Show (Selection l),
     SelectionClass (Selection l)) => LayoutSelect l a where
  type Selection l :: *

  update :: forall r m. (Monad m) =>
    Selection l ->
    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,

        Show (Selection t),
        Read (Selection t)) =>
    LayoutSelect (LCons l t) a where

  -- This is something
  type Selection (LCons l t) = IsSelected (Selection t)

  update Selected (LCons layout t) fn = do
    (r, layout') <- fn layout
    return $ Just (r, LCons (fromMaybe layout layout') t)

  update (NotSelected s) (LCons l t) fn =
    fmap (second $ \t' -> LCons l t') <$> update s t fn
  
  nLayouts (LCons _ t) = 1 + nLayouts t

instance LayoutSelect LNil a where
  type Selection LNil = Void -- Cannot be selected

  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 (NavigateLayout fn)) =
    return $ Just (LayoutZipper (fn idx) 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