src/Rahm/Desktop/Layout/ReinterpretMessage.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48

module Rahm.Desktop.Layout.ReinterpretMessage where

import XMonad (SomeMessage, X)
import XMonad.Layout.LayoutModifier (LayoutModifier(..))
import Data.Proxy (Proxy (..))

-- This is a type class that defines how to reinterpret a message. One can think
-- of this as a kind of type-level function. It lets one associate a function
-- (reinterpretMessage) with a type construct, which for the case below is a
-- Symbol.
--
-- It would be nice to attach this function to the LayoutModifier directly as a
-- value, however LayoutModifiers must be Show-able and Read-able and functions
-- are not. However encoding in the typesystem itsef which function is to be
-- called is the best alternative I have.
class DoReinterpret (k :: t) where
  reinterpretMessage ::
    Proxy k -> SomeMessage -> X (Maybe SomeMessage)

-- Data construct for association a DoReinterpret function with a concrete
-- construct that can be used in the LayoutModifier instance.
--
-- It would be nice to have ReinterpretMessage hold the function as a value
-- rather than delegate to this kind-instance, however, it won't work because
-- LayoutModifiers have to be Read-able and Show-able, and functions are neither
-- of those, so a value-level function may not be a member of a LayoutModifier,
-- thus I have to settle for delegating to a hard-coded instance using
-- type-classes.
data ReinterpretMessage k a = ReinterpretMessage
  deriving (Show, Read)

-- Instance for ReinterpretMessage as a Layout modifier.
instance (DoReinterpret k) =>
      LayoutModifier (ReinterpretMessage k) a where

  handleMessOrMaybeModifyIt self message = do

    -- Delegates to the reinterpretMessage function associated with the
    -- type-variable k.
    newMessage <- reinterpretMessage (ofProxy self) message
    case newMessage of
      Just m -> return $ Just $ Right m
      Nothing -> return $ Just $ Left self
    where
      -- ofProxy just provides reifies the phantom type k so the type system can
      -- figure out what instance to go to.
      ofProxy :: ReinterpretMessage k a -> Proxy k
      ofProxy _ = Proxy