A toy implementation of fully monadic config

xmonad.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE Rank2Types            #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE FunctionalDependencies         #-}
{-# OPTIONS_GHC -Wall #-}

import           Prelude                      hiding (mod)

import           XMonad                       hiding (XConfig (..), get, modify,
                                               put, xmonad)
import           XMonad                       (XConfig (XConfig))
import qualified XMonad                       as X -- (XConfig (..), xmonad)
import qualified XMonad.StackSet              as W


import           Control.Monad.State

import           Control.Arrow                (first, second)
import           Data.Constraint
import           XMonad.Layout.LayoutModifier (LayoutModifier, ModifiedLayout)


type IsLayout l a = (Read (l a), LayoutClass l a)

class CC m a where
  dict :: forall l. IsLayout l a => m l a -> Dict (IsLayout (m l) a)
  cc :: forall l. m l a -> IsLayout l a :- IsLayout (m l) a
  cc x = Sub $ dict x
  {-# MINIMAL dict #-}

wrapLT :: CC m a
       => (forall l. (LayoutClass l a) => l a -> m l a)
       -> Layout a -> Layout a
wrapLT m (Layout la) = Layout (m la) \\ cc (m la)

newtype (f :. g) l a = O (f (g l) a)
infixl 9 :.

unO :: (f :. g) l a -> f (g l) a
unO (O fgla) = fgla

instance Read (m1 (m2 l) a) => Read ((m1 :. m2) l a) where
  readsPrec i = map (first O) . readsPrec i

instance Show (m1 (m2 l) a) => Show ((m1 :. m2) l a) where
  show = show . unO

instance LayoutClass (m1 (m2 l)) a => LayoutClass ((m1 :. m2) l) a where
  runLayout ws@W.Workspace{W.layout = lay} =
    (second (O <$>) <$>) . runLayout (ws{W.layout = unO lay})
  handleMessage lay =
    fmap (fmap O) . handleMessage (unO lay)
  description = description . unO

instance (CC m1 a, CC m2 a) => CC (m1 :. m2) a where
  dict x = Dict \\ trans (cc (unO x)) (cc undefined)

instance CC Mirror a where dict _ = Dict
instance IsLayout m a => CC (Choose m) a where dict _ = Dict
instance LayoutModifier m a => CC (ModifiedLayout m) a where dict _ = Dict

type Prime = Arr (XConfig Layout)
type Arr a = StateT a IO ()

xmonad :: Prime -> IO ()
xmonad prime = xmonad' =<< execStateT prime (def{X.layoutHook = Layout $ X.layoutHook def})
  where xmonad' :: XConfig Layout -> IO ()
        xmonad' cf@XConfig{ X.layoutHook = Layout l } = X.xmonad cf{ X.layoutHook = l }

traceXMLayout :: Prime -> IO ()
traceXMLayout prime = do
  Layout a <- X.layoutHook <$> execStateT prime (def{X.layoutHook = Layout $ X.layoutHook def})
  putStrLn (X.description a)

modifyLayout :: (CC m Window)
              => (forall l. (LayoutClass l Window) => l Window -> m l Window)
              -> Prime
modifyLayout f = modify $ \c -> c { X.layoutHook = wrapLT f $ X.layoutHook c }

-- imagine there is a function f out there somewhere:
-- f :: LayoutClass l a => l a -> Mirror (Mirror (Choose Full l)) a
f x = Mirror $ Mirror $ Mirror $ Full ||| x

test1 :: IO ()
test1 = traceXMLayout $ do
  -- this works OK
  modifyLayout Mirror
  modifyLayout (Full ||| )
  modifyLayout $ sq f
  -- now the remaining problem is to generically push the use
  -- of sq into the definition of modifyLayout

class S l f t | f l -> t where
  sq :: (l a -> f a) -> (l a -> t l a)

-- seems to work based on the printed X.description,
-- and the inferred types of (sq f), sq Mirror etc.
instance {-# INCOHERENT #-} S l (m l) m where
  sq = id

instance S l ((f :. g) l') t => S l (f (g l')) t where
  sq = sq . (O .)