{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.DebugEvents
-- Description :  Dump diagnostic information about X11 events received by xmonad.
-- Copyright   :  (c) Brandon S Allbery KF8NH, 2012
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  allbery.b@gmail.com
-- Stability   :  unstable
-- Portability :  not portable
--
-- Module to dump diagnostic information about X11 events received by
-- @xmonad@.  This is incomplete due to 'Event' being incomplete and not
-- providing information about a number of events, and enforcing artificial
-- constraints on others (for example 'ClientMessage'); the @X11@ package
-- will require a number of changes to fix these problems.
--
-----------------------------------------------------------------------------

module XMonad.Hooks.DebugEvents (debugEventsHook) where

import           Prelude

import           XMonad                               hiding (windowEvent
                                                             ,(-->)
                                                             )
import           XMonad.Prelude                       hiding (fi, bool)

import           XMonad.Hooks.DebugKeyEvents                 (debugKeyEvents)
import           XMonad.Util.DebugWindow                     (debugWindow)

-- import           Graphics.X11.Xlib.Extras.GetAtomName        (getAtomName)

import           Control.Exception                    as E
import           Control.Monad.Fail
import           Control.Monad.State
import           Control.Monad.Reader
import           Codec.Binary.UTF8.String
import           Foreign
import           Foreign.C.Types
import           Numeric                                     (showHex)
import           System.Exit
import           System.IO
import           System.Process

-- | Event hook to dump all received events.  You should probably not use this
--   unconditionally; it will produce massive amounts of output.
debugEventsHook   :: Event -> X All
debugEventsHook :: Event -> X All
debugEventsHook Event
e =  Event -> X ()
debugEventsHook' Event
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)

-- | Dump an X11 event.  Can't be used directly as a 'handleEventHook'.
debugEventsHook' :: Event -> X ()

debugEventsHook' :: Event -> X ()
debugEventsHook' ConfigureRequestEvent{ev_window :: Event -> Word32
ev_window       = Word32
w
                                      ,ev_parent :: Event -> Word32
ev_parent       = Word32
p
                                      ,ev_x :: Event -> CInt
ev_x            = CInt
x
                                      ,ev_y :: Event -> CInt
ev_y            = CInt
y
                                      ,ev_width :: Event -> CInt
ev_width        = CInt
wid
                                      ,ev_height :: Event -> CInt
ev_height       = CInt
ht
                                      ,ev_border_width :: Event -> CInt
ev_border_width = CInt
bw
                                      ,ev_above :: Event -> Word32
ev_above        = Word32
above
                                      ,ev_detail :: Event -> CInt
ev_detail       = CInt
place
                                      ,ev_value_mask :: Event -> CULong
ev_value_mask   = CULong
msk
                                      } = do
  String -> Word32 -> X ()
windowEvent String
"ConfigureRequest" Word32
w
  String -> Word32 -> X ()
windowEvent String
"  parent"         Word32
p
--  mask <- quickFormat msk $ dumpBits wmCRMask
--  say "  requested parameters" $ concat ['(':show wid
--                                        ,'x':show ht
--                                        ,')':if bw == 0 then "" else '+':show bw
--                                        ,'@':'(':show x
--                                        ,',':show y
--                                        ,") mask "
--                                        ,mask
--                                        ]
  String
s <- forall i.
(Storable i, Integral i) =>
[i] -> Decoder Bool -> X String
quickFormat [CInt
x,CInt
y,CInt
wid,CInt
ht,CInt
bw,forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
above,CInt
place] forall a b. (a -> b) -> a -> b
$
       CULong -> [(String, Decoder Bool, Word32)] -> Decoder Bool
dumpListByMask' CULong
msk [(String
"x"           ,Decoder Bool
dump32              ,Word32
cARDINAL)
                           ,(String
"y"           ,Decoder Bool
dump32              ,Word32
cARDINAL)
                           ,(String
"width"       ,Decoder Bool
dump32              ,Word32
cARDINAL)
                           ,(String
"height"      ,Decoder Bool
dump32              ,Word32
cARDINAL)
                           ,(String
"border_width",Decoder Bool
dump32              ,Word32
cARDINAL)
                           ,(String
"sibling"     ,Decoder Bool
dumpWindow          ,Word32
wINDOW  )
                           ,(String
"detail"      ,[String] -> Decoder Bool
dumpEnum [String]
wmPlacement,Word32
cARDINAL)
                           ]
  String -> String -> X ()
say String
"  requested" String
s

debugEventsHook' ConfigureEvent        {ev_window :: Event -> Word32
ev_window = Word32
w
                                       ,ev_above :: Event -> Word32
ev_above  = Word32
above
                                       } = do
  String -> Word32 -> X ()
windowEvent String
"Configure" Word32
w
  -- most of the content is covered by debugWindow
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
above forall a. Eq a => a -> a -> Bool
/= Word32
none) forall a b. (a -> b) -> a -> b
$ Word32 -> X String
debugWindow Word32
above forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> String -> X ()
say String
"  above"

debugEventsHook' MapRequestEvent       {ev_window :: Event -> Word32
ev_window     = Word32
w
                                       ,ev_parent :: Event -> Word32
ev_parent     = Word32
p
                                       } =
  String -> Word32 -> X ()
windowEvent String
"MapRequest" Word32
w forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  String -> Word32 -> X ()
windowEvent String
"  parent"   Word32
p

debugEventsHook' e :: Event
e@KeyEvent {ev_event_type :: Event -> Word32
ev_event_type = Word32
t}
    | Word32
t forall a. Eq a => a -> a -> Bool
== Word32
keyPress =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Handle -> String -> IO ()
hPutStr Handle
stderr String
"KeyPress ") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  Event -> X All
debugKeyEvents Event
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

debugEventsHook' ButtonEvent           {ev_window :: Event -> Word32
ev_window = Word32
w
                                       ,ev_state :: Event -> KeyMask
ev_state  = KeyMask
s
                                       ,ev_button :: Event -> Word32
ev_button = Word32
b
                                       } = do
  String -> Word32 -> X ()
windowEvent String
"Button" Word32
w
  KeyMask
nl <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> KeyMask
numberlockMask
  let msk :: String
msk | KeyMask
s forall a. Eq a => a -> a -> Bool
== KeyMask
0    = String
""
          | Bool
otherwise = String
"modifiers " forall a. [a] -> [a] -> [a]
++ KeyMask -> KeyMask -> String
keymaskToString KeyMask
nl KeyMask
s
  String -> String -> X ()
say String
"  button" forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Word32
b forall a. [a] -> [a] -> [a]
++ String
msk

debugEventsHook' DestroyWindowEvent    {ev_window :: Event -> Word32
ev_window = Word32
w
                                        } =
  String -> Word32 -> X ()
windowEvent String
"DestroyWindow" Word32
w

debugEventsHook' UnmapEvent            {ev_window :: Event -> Word32
ev_window = Word32
w
                                       } =
  String -> Word32 -> X ()
windowEvent String
"Unmap" Word32
w

debugEventsHook' MapNotifyEvent        {ev_window :: Event -> Word32
ev_window = Word32
w
                                       } =
  String -> Word32 -> X ()
windowEvent String
"MapNotify" Word32
w

{- way too much output; suppressed.

debugEventsHook' (CrossingEvent        {ev_window    = w
                                       ,ev_subwindow = s
                                       }) =
  windowEvent "Crossing"    w >>
  windowEvent "  subwindow" s
-}
debugEventsHook' CrossingEvent         {} =
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

debugEventsHook' SelectionRequest      {ev_requestor :: Event -> Word32
ev_requestor = Word32
rw
                                       ,ev_owner :: Event -> Word32
ev_owner     = Word32
ow
                                       ,ev_selection :: Event -> Word32
ev_selection = Word32
a
                                       } =
  String -> Word32 -> X ()
windowEvent String
"SelectionRequest" Word32
rw forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  String -> Word32 -> X ()
windowEvent String
"  owner"          Word32
ow forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  String -> Word32 -> X ()
atomEvent   String
"  atom"           Word32
a

debugEventsHook' PropertyEvent         {ev_window :: Event -> Word32
ev_window    = Word32
w
                                       ,ev_atom :: Event -> Word32
ev_atom      = Word32
a
                                       ,ev_propstate :: Event -> CInt
ev_propstate = CInt
s
                                       } = do
  String
a' <- Word32 -> X String
atomName Word32
a
  -- too many of these, and they're not real useful
  if String
a' forall a. Eq a => a -> a -> Bool
== String
"_NET_WM_USER_TIME" then forall (m :: * -> *) a. Monad m => a -> m a
return () else do
    String -> Word32 -> X ()
windowEvent String
"Property on" Word32
w
    String
s' <- case CInt
s of
            CInt
1 -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"deleted"
            CInt
0 -> Word32 -> String -> Word32 -> Int -> X String
dumpProperty Word32
a String
a' Word32
w (Int
7 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
a')
            CInt
_ -> forall a. HasCallStack => String -> a
error String
"Illegal propState; Xlib corrupted?"
    String -> String -> X ()
say String
"  atom" forall a b. (a -> b) -> a -> b
$ String
a' forall a. [a] -> [a] -> [a]
++ String
s'

debugEventsHook' ExposeEvent           {ev_window :: Event -> Word32
ev_window = Word32
w
                                       } =
  String -> Word32 -> X ()
windowEvent String
"Expose" Word32
w

debugEventsHook' ClientMessageEvent    {ev_window :: Event -> Word32
ev_window       = Word32
w
                                       ,ev_message_type :: Event -> Word32
ev_message_type = Word32
a
                                       -- @@@ they did it again!  no ev_format,
                                       --     and ev_data is [CInt]
                                       -- @@@ and get a load of the trainwreck
                                       --     that is setClientMessageEvent!
--                                     ,ev_format       = b
                                       ,ev_data :: Event -> [CInt]
ev_data         = [CInt]
vs'
                                       } = do
  String -> Word32 -> X ()
windowEvent String
"ClientMessage on" Word32
w
  String
n <- Word32 -> X String
atomName Word32
a
  -- this is a sort of custom property
  -- @@@ this likely won't work as is; type information varies, I think
  (Word32
ta,Int
b,Int
l) <- case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
n [(String, (String, Int, Int))]
clientMessages of
                Maybe (String, Int, Int)
Nothing        -> forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
a,Int
32,forall (t :: * -> *) a. Foldable t => t a -> Int
length [CInt]
vs')
                Just (String
ta',Int
b,Int
l) -> do
                  Word32
ta <- String -> X Word32
getAtom String
ta'
                  forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
ta,Int
b,Int
l)
  let wl :: Int
wl = Int -> Int
bytes Int
b
  [CUChar]
vs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take (Int
l forall a. Num a => a -> a -> a
* Int
wl) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CInt] -> IO [CUChar]
splitCInt [CInt]
vs'
  String
s <- Word32
-> Word32
-> String
-> Word32
-> Int
-> [CUChar]
-> CULong
-> Int
-> X String
dumpProperty' Word32
w Word32
a String
n Word32
ta Int
b [CUChar]
vs CULong
0 (Int
10 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
n)
  String -> String -> X ()
say String
"  message" forall a b. (a -> b) -> a -> b
$ String
n forall a. [a] -> [a] -> [a]
++ String
s

debugEventsHook' Event
_                      = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Emit information about an atom.
atomName   :: Atom -> X String
atomName :: Word32 -> X String
atomName Word32
a =  forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d ->
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (String
"(unknown atom " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word32
a forall a. [a] -> [a] -> [a]
++ String
")") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> Word32 -> IO (Maybe String)
getAtomName Display
d Word32
a

-- | Emit an atom with respect to the current event.
atomEvent     :: String -> Atom -> X ()
atomEvent :: String -> Word32 -> X ()
atomEvent String
l Word32
a =  Word32 -> X String
atomName Word32
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> String -> X ()
say String
l

-- | Emit a window with respect to the current event.
windowEvent     :: String -> Window -> X ()
windowEvent :: String -> Word32 -> X ()
windowEvent String
l Word32
w =  Word32 -> X String
debugWindow Word32
w forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> String -> X ()
say String
l

-- | Helper to emit tagged event information.
say     :: String -> String -> X ()
say :: String -> String -> X ()
say String
l String
s =  forall (m :: * -> *). MonadIO m => String -> m ()
trace forall a b. (a -> b) -> a -> b
$ String
l forall a. [a] -> [a] -> [a]
++ Char
' 'forall a. a -> [a] -> [a]
:String
s

-- | Deconstuct a list of 'CInt's into raw bytes
splitCInt    :: [CInt] -> IO Raw
splitCInt :: [CInt] -> IO [CUChar]
splitCInt [CInt]
vs =  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [CInt]
vs forall a b. (a -> b) -> a -> b
$ \Ptr CInt
p ->
                forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (Int
4 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length [CInt]
vs) (forall a b. Ptr a -> Ptr b
castPtr Ptr CInt
p :: Ptr CUChar)

-- | Specify how to decode some common client messages.
clientMessages :: [(String,(String,Int,Int))]
clientMessages :: [(String, (String, Int, Int))]
clientMessages =  [(String
"_NET_ACTIVE_WINDOW",(String
"_NET_ACTIVE_WINDOW",Int
32,Int
1))
                  ,(String
"WM_CHANGE_STATE"   ,(String
"WM_STATE"          ,Int
32,Int
2))
                  ,(String
"WM_COMMAND"        ,(String
"STRING"            , Int
8,Int
0))
                  ,(String
"WM_SAVE_YOURSELF"  ,(String
"STRING"            , Int
8,Int
0))
                  ]

-- formatting properties.  ick. --

-- @@@ Document the parser.  Someday.

type Raw     = [CUChar]

data Decode = Decode {Decode -> Word32
property :: Atom          -- original property atom
                     ,Decode -> String
pName    :: String        -- its name
                     ,Decode -> Word32
pType    :: Atom          -- base property type atom
                     ,Decode -> Int
width    :: Int           -- declared data width
                     ,Decode -> Word32
window   :: Window        -- source window
                     ,Decode -> Int
indent   :: Int           -- current indent (via local)
                     ,Decode -> Int
limit    :: Int           -- line length
                     }

-- the result accumulates here mainly for the benefit of the indenter
data DecodeState = DecS {DecodeState -> [CUChar]
value :: Raw           -- unconsumed raw property value
                        ,DecodeState -> String
accum :: String        -- output accumulator
                        ,DecodeState -> String
joint :: String        -- separator when adding to accumulator
                        }

newtype Decoder a = Decoder (ReaderT Decode (StateT DecodeState X) a)
#ifndef __HADDOCK__
    deriving (forall a b. a -> Decoder b -> Decoder a
forall a b. (a -> b) -> Decoder a -> Decoder b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Decoder b -> Decoder a
$c<$ :: forall a b. a -> Decoder b -> Decoder a
fmap :: forall a b. (a -> b) -> Decoder a -> Decoder b
$cfmap :: forall a b. (a -> b) -> Decoder a -> Decoder b
Functor
             ,Functor Decoder
forall a. a -> Decoder a
forall a b. Decoder a -> Decoder b -> Decoder a
forall a b. Decoder a -> Decoder b -> Decoder b
forall a b. Decoder (a -> b) -> Decoder a -> Decoder b
forall a b c. (a -> b -> c) -> Decoder a -> Decoder b -> Decoder c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Decoder a -> Decoder b -> Decoder a
$c<* :: forall a b. Decoder a -> Decoder b -> Decoder a
*> :: forall a b. Decoder a -> Decoder b -> Decoder b
$c*> :: forall a b. Decoder a -> Decoder b -> Decoder b
liftA2 :: forall a b c. (a -> b -> c) -> Decoder a -> Decoder b -> Decoder c
$cliftA2 :: forall a b c. (a -> b -> c) -> Decoder a -> Decoder b -> Decoder c
<*> :: forall a b. Decoder (a -> b) -> Decoder a -> Decoder b
$c<*> :: forall a b. Decoder (a -> b) -> Decoder a -> Decoder b
pure :: forall a. a -> Decoder a
$cpure :: forall a. a -> Decoder a
Applicative
             ,Applicative Decoder
forall a. a -> Decoder a
forall a b. Decoder a -> Decoder b -> Decoder b
forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Decoder a
$creturn :: forall a. a -> Decoder a
>> :: forall a b. Decoder a -> Decoder b -> Decoder b
$c>> :: forall a b. Decoder a -> Decoder b -> Decoder b
>>= :: forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
$c>>= :: forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
Monad
             ,Monad Decoder
forall a. IO a -> Decoder a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> Decoder a
$cliftIO :: forall a. IO a -> Decoder a
MonadIO
             ,Monad Decoder
forall a. String -> Decoder a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> Decoder a
$cfail :: forall a. String -> Decoder a
MonadFail
             ,MonadState  DecodeState
             ,MonadReader Decode
             )
#endif

-- | Retrive, parse, and dump a window property.  As all the high-level property
--   interfaces lose information necessary to decode properties correctly, we
--   work at the lowest level available.
dumpProperty          :: Atom -> String -> Window -> Int -> X String
dumpProperty :: Word32 -> String -> Word32 -> Int -> X String
dumpProperty Word32
a String
n Word32
w Int
i  =  do
  Either String (Word32, Int, CULong, [CUChar])
prop <- forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d ->
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io     forall a b. (a -> b) -> a -> b
$
    forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr Word32
fmtp ->
    forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr CInt
szp  ->
    forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr CULong
lenp ->
    forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr CULong
ackp ->
    forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CUChar)
vsp  -> do
    CInt
rc   <- Display
-> Word32
-> Word32
-> CLong
-> CLong
-> Bool
-> Word32
-> Ptr Word32
-> Ptr CInt
-> Ptr CULong
-> Ptr CULong
-> Ptr (Ptr CUChar)
-> IO CInt
xGetWindowProperty
              Display
d
              Word32
w
              Word32
a
              CLong
0
              forall a. Bounded a => a
maxBound
              Bool
False
              Word32
anyPropertyType
              Ptr Word32
fmtp
              Ptr CInt
szp
              Ptr CULong
lenp
              Ptr CULong
ackp
              Ptr (Ptr CUChar)
vsp
    case CInt
rc of
      CInt
0 -> do
        Word32
fmt <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek Ptr Word32
fmtp
        Ptr CUChar
vs' <-                     forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CUChar)
vsp
        Int
sz  <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
szp
        case () of
          () | Word32
fmt forall a. Eq a => a -> a -> Bool
== Word32
none     -> forall a. Ptr a -> IO CInt
xFree Ptr CUChar
vs' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left   String
"(property deleted)"   )
             | Int
sz forall a. Ord a => a -> a -> Bool
< Int
0          -> forall a. Ptr a -> IO CInt
xFree Ptr CUChar
vs' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"(illegal bit size " forall a. [a] -> [a] -> [a]
++
                                                              forall a. Show a => a -> String
show Int
sz              forall a. [a] -> [a] -> [a]
++
                                                              String
")"                    )
             | Int
sz forall a. Integral a => a -> a -> a
`mod` Int
8 forall a. Eq a => a -> a -> Bool
/= Int
0 -> forall a. Ptr a -> IO CInt
xFree Ptr CUChar
vs' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"(illegal bit size " forall a. [a] -> [a] -> [a]
++
                                                              forall a. Show a => a -> String
show Int
sz              forall a. [a] -> [a] -> [a]
++
                                                              String
")"                    )
             | Bool
otherwise       -> do
                 Int
len <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek Ptr CULong
lenp
                 -- that's as in "ack! it's fugged!"
                 CULong
ack <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek Ptr CULong
ackp
                 [CUChar]
vs <- forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (Int
len forall a. Num a => a -> a -> a
* Int -> Int
bytes Int
sz) Ptr CUChar
vs'
                 CInt
_ <- forall a. Ptr a -> IO CInt
xFree Ptr CUChar
vs'
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Word32
fmt,Int
sz,CULong
ack,[CUChar]
vs)
      CInt
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"getWindowProperty failed: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CInt
e
  case Either String (Word32, Int, CULong, [CUChar])
prop of
    Left  String
_               -> forall (m :: * -> *) a. Monad m => a -> m a
return String
""
    Right (Word32
fmt,Int
sz,CULong
ack,[CUChar]
vs) -> Word32
-> Word32
-> String
-> Word32
-> Int
-> [CUChar]
-> CULong
-> Int
-> X String
dumpProperty' Word32
w Word32
a String
n Word32
fmt Int
sz [CUChar]
vs CULong
ack Int
i

-- @@@ am I better off passing in the Decode and DecodeState?
-- | Parse and dump a property (or a 'ClientMessage').
dumpProperty'                             :: Window -- source window
                                          -> Atom   -- property id
                                          -> String -- property name
                                          -> Atom   -- property type
                                          -> Int    -- bit width
                                          -> Raw    -- raw value
                                          -> CULong -- size of un-dumped content
                                          -> Int    -- indent for output formatting
                                          -> X String
dumpProperty' :: Word32
-> Word32
-> String
-> Word32
-> Int
-> [CUChar]
-> CULong
-> Int
-> X String
dumpProperty' Word32
w Word32
a String
n Word32
fmt Int
sz [CUChar]
vs CULong
ack Int
i =  do
  String
ptn <- Word32 -> X String
atomName Word32
fmt
  let dec :: Decode
dec  = Decode {property :: Word32
property = Word32
a
                    ,pName :: String
pName    = String
n
                    ,pType :: Word32
pType    = Word32
fmt
                    ,width :: Int
width    = Int
sz
                    ,indent :: Int
indent   = Int
i forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ptn forall a. Num a => a -> a -> a
+ Int
6
                    ,window :: Word32
window   = Word32
w
                    ,limit :: Int
limit    = Int
96
                    }
      dec' :: Decode
dec' = Decode
dec    {pType :: Word32
pType    = Word32
cARDINAL
                    ,width :: Int
width    = Int
8
                    }
      ds :: DecodeState
ds   = DecS   {value :: [CUChar]
value    = [CUChar]
vs
                    -- @@@ probably should push this outside, since it doesn't
                    --     make sense for ClientMessage
                    ,accum :: String
accum    = String
" (" forall a. [a] -> [a] -> [a]
++ String
ptn forall a. [a] -> [a] -> [a]
++ String
") "
                    ,joint :: String
joint    = String
"= "
                    }
  (Bool
_,DecodeState
ds') <- Decode -> DecodeState -> Decoder Bool -> X (Bool, DecodeState)
runDecode Decode
dec DecodeState
ds forall a b. (a -> b) -> a -> b
$ Word32 -> String -> Decoder Bool
dumpProp Word32
a String
n
  let fin :: Int
fin = forall (t :: * -> *) a. Foldable t => t a -> Int
length (DecodeState -> [CUChar]
value DecodeState
ds')
      len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length [CUChar]
vs
      lost :: String
lost = if CULong
ack forall a. Eq a => a -> a -> Bool
== CULong
0 then String
"" else String
"and " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CULong
ack forall a. [a] -> [a] -> [a]
++ String
" lost bytes"
      unk :: String
unk = case () of
              () | Int
fin forall a. Eq a => a -> a -> Bool
== Int
len -> String
"undecodeable "
                 | Int
fin forall a. Eq a => a -> a -> Bool
== Int
0   -> String
"."
                 | Bool
otherwise  -> String
"and remainder (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
len forall a. Num a => a -> a -> a
- Int
fin) forall a. [a] -> [a] -> [a]
++ Char
'/'forall a. a -> [a] -> [a]
:forall a. Show a => a -> String
show Int
len forall a. [a] -> [a] -> [a]
++ String
")"
  (Bool
_,DecodeState
ds'') <- if Int
fin forall a. Eq a => a -> a -> Bool
== Int
0
              then forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,DecodeState
ds')
              else Decode -> DecodeState -> Decoder Bool -> X (Bool, DecodeState)
runDecode Decode
dec' (String -> DecodeState -> DecodeState
withJoint' String
unk DecodeState
ds' ) forall a b. (a -> b) -> a -> b
$ Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
dump8
  (Bool
_,DecodeState
ds''') <- if CULong
ack forall a. Eq a => a -> a -> Bool
== CULong
0
               then forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,DecodeState
ds'')
               else Decode -> DecodeState -> Decoder Bool -> X (Bool, DecodeState)
runDecode Decode
dec' (String -> DecodeState -> DecodeState
withJoint' String
" " DecodeState
ds'') forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
propSimple String
lost -- @@@
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DecodeState -> String
accum DecodeState
ds'''

-- | A simplified version of 'dumpProperty\'', to format random values from
--   events.
quickFormat     :: (Storable i, Integral i) => [i] -> Decoder Bool -> X String
quickFormat :: forall i.
(Storable i, Integral i) =>
[i] -> Decoder Bool -> X String
quickFormat [i]
v Decoder Bool
f =  do
  let vl :: Int
vl = forall (t :: * -> *) a. Foldable t => t a -> Int
length [i]
v
  [CUChar]
vs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$
        forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
vl forall a b. (a -> b) -> a -> b
$
        \Ptr CULong
p -> forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr CULong
p (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral [i]
v :: [CULong]) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (Int
4 forall a. Num a => a -> a -> a
* Int
vl) (forall a b. Ptr a -> Ptr b
castPtr Ptr CULong
p :: Ptr CUChar)
  let dec :: Decode
dec = Decode {property :: Word32
property = Word32
none
                   ,pName :: String
pName    = String
""
                   ,pType :: Word32
pType    = Word32
cARDINAL
                   ,width :: Int
width    = Int
32
                   ,indent :: Int
indent   = Int
0
                   ,window :: Word32
window   = Word32
none
                   ,limit :: Int
limit    = forall a. Bounded a => a
maxBound
                   }
      ds :: DecodeState
ds  = DecS   {value :: [CUChar]
value    = [CUChar]
vs
                   ,accum :: String
accum    = String
""
                   ,joint :: String
joint    = String
""
                   }
  (Bool
r,DecodeState
ds') <- Decode -> DecodeState -> Decoder Bool -> X (Bool, DecodeState)
runDecode Decode
dec DecodeState
ds Decoder Bool
f
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DecodeState -> String
accum DecodeState
ds' forall a. [a] -> [a] -> [a]
++ if Bool
r then String
"" else String
"?"

-- | Launch a decoding parser, returning success and final state.
runDecode                 :: Decode -> DecodeState -> Decoder Bool -> X (Bool,DecodeState)
runDecode :: Decode -> DecodeState -> Decoder Bool -> X (Bool, DecodeState)
runDecode Decode
c DecodeState
s (Decoder ReaderT Decode (StateT DecodeState X) Bool
p) =  forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Decode (StateT DecodeState X) Bool
p Decode
c) DecodeState
s

-- Coerce bit size to bytes.
bytes   :: Int -> Int
bytes :: Int -> Int
bytes Int
w =  Int
w forall a. Integral a => a -> a -> a
`div` Int
8

-- | The top level property decoder, for a wide variety of standard ICCCM and
--   EWMH window properties.  We pass part of the 'ReaderT' as arguments for
--   pattern matching.
dumpProp                                              :: Atom -> String -> Decoder Bool

dumpProp :: Word32 -> String -> Decoder Bool
dumpProp Word32
_ String
"CLIPBOARD"                                =  Decoder Bool
dumpSelection
dumpProp Word32
_ String
"_NET_SUPPORTED"                           =  Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
dumpAtom
dumpProp Word32
_ String
"_NET_CLIENT_LIST"                         =  Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
dumpWindow
dumpProp Word32
_ String
"_NET_CLIENT_LIST_STACKING"                =  Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
dumpWindow
dumpProp Word32
_ String
"_NET_NUMBER_OF_DESKTOPS"                  =  Decoder Bool
dump32
dumpProp Word32
_ String
"_NET_VIRTUAL_ROOTS"                       =  Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
dumpWindow
dumpProp Word32
_ String
"_NET_DESKTOP_GEOMETRY"                    =  Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
dump32
dumpProp Word32
_ String
"_NET_DESKTOP_VIEWPORT"                    =  [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"w",Decoder Bool
dump32)
                                                                  ,(String
"h",Decoder Bool
dump32)
                                                                  ]
dumpProp Word32
_ String
"_NET_CURRENT_DESKTOP"                     =  Decoder Bool
dump32
dumpProp Word32
_ String
"_NET_DESKTOP_NAMES"                       =  Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
dumpUTF
dumpProp Word32
_ String
"_NET_ACTIVE_WINDOW"                       =  Decoder Bool
dumpActiveWindow
dumpProp Word32
_ String
"_NET_WORKAREA"                            =  [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"start"
                                                                   ,[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"x",Decoder Bool
dump32)
                                                                             ,(String
"y",Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ,(String
"size"
                                                                   ,[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"w",Decoder Bool
dump32)
                                                                             ,(String
"h",Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ]
dumpProp Word32
_ String
"_NET_SUPPORTING_WM_CHECK"                 =  Decoder Bool
dumpWindow
dumpProp Word32
_ String
"_NET_DESKTOP_LAYOUT"                      =  [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"orientation"
                                                                   ,[String] -> Decoder Bool
dumpEnum [String]
nwmOrientation
                                                                   )
                                                                  ,(String
"size"
                                                                   ,[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"cols",Decoder Bool
dump32)
                                                                             ,(String
"rows",Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ,(String
"origin"
                                                                   ,[String] -> Decoder Bool
dumpEnum [String]
nwmOrigin
                                                                   )
                                                                  ]
dumpProp Word32
_ String
"_NET_SHOWING_DESKTOP"                     =  Decoder Bool
dump32
dumpProp Word32
_ String
"_NET_WM_NAME"                             =  Decoder Bool
dumpUTF
dumpProp Word32
_ String
"_NET_WM_VISIBLE_NAME"                     =  Decoder Bool
dumpUTF
dumpProp Word32
_ String
"_NET_WM_ICON_NAME"                        =  Decoder Bool
dumpUTF
dumpProp Word32
_ String
"_NET_WM_VISIBLE_ICON_NAME"                =  Decoder Bool
dumpUTF
dumpProp Word32
_ String
"_NET_WM_DESKTOP"                          =  [(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer
0xFFFFFFFF,String
"all")]
                                                                    Decoder Bool
dump32
dumpProp Word32
_ String
"_NET_WM_WINDOW_TYPE"                      =  Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
dumpAtom
dumpProp Word32
_ String
"_NET_WM_STATE"                            =  Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
dumpAtom
dumpProp Word32
_ String
"_NET_WM_ALLOWED_ACTIONS"                  =  Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
dumpAtom
dumpProp Word32
_ String
"_NET_WM_STRUT"                            =  [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"left gap"  ,Decoder Bool
dump32)
                                                                  ,(String
"right gap" ,Decoder Bool
dump32)
                                                                  ,(String
"top gap"   ,Decoder Bool
dump32)
                                                                  ,(String
"bottom gap",Decoder Bool
dump32)
                                                                  ]
dumpProp Word32
_ String
"_NET_WM_STRUT_PARTIAL"                    =  [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"left gap"    ,Decoder Bool
dump32)
                                                                  ,(String
"right gap"   ,Decoder Bool
dump32)
                                                                  ,(String
"top gap"     ,Decoder Bool
dump32)
                                                                  ,(String
"bottom gap"  ,Decoder Bool
dump32)
                                                                  ,(String
"left start"  ,Decoder Bool
dump32)
                                                                  ,(String
"left end"    ,Decoder Bool
dump32)
                                                                  ,(String
"right start" ,Decoder Bool
dump32)
                                                                  ,(String
"right end"   ,Decoder Bool
dump32)
                                                                  ,(String
"top start"   ,Decoder Bool
dump32)
                                                                  ,(String
"top end"     ,Decoder Bool
dump32)
                                                                  ,(String
"bottom start",Decoder Bool
dump32)
                                                                  ,(String
"bottom end"  ,Decoder Bool
dump32)
                                                                  ]
dumpProp Word32
_ String
"_NET_WM_ICON_GEOMETRY"                    =  [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"x",Decoder Bool
dump32)
                                                                  ,(String
"y",Decoder Bool
dump32)
                                                                  ,(String
"w",Decoder Bool
dump32)
                                                                  ,(String
"h",Decoder Bool
dump32)
                                                                  ]
-- no, I'm not going to duplicate xprop *completely*!
dumpProp Word32
_ String
"_NET_WM_ICON"                             =  String -> Decoder Bool
propSimple String
"(icon)"
dumpProp Word32
_ String
"_NET_WM_PID"                              =  Decoder Bool
dumpPid
dumpProp Word32
_ String
"_NET_WM_HANDLED_ICONS"                    =  String -> Decoder Bool
propSimple String
"(defined)"
dumpProp Word32
_ String
"_NET_WM_USER_TIME"                        =  [(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer
0,String
"do not map initially")]
                                                                    Decoder Bool
dumpTime
dumpProp Word32
_ String
"_NET_FRAME_EXTENTS"                       =  [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"left"  ,Decoder Bool
dump32)
                                                                  ,(String
"right" ,Decoder Bool
dump32)
                                                                  ,(String
"top"   ,Decoder Bool
dump32)
                                                                  ,(String
"bottom",Decoder Bool
dump32)
                                                                  ]
dumpProp Word32
_ String
"_NET_WM_SYNC_REQUEST_COUNTER"             =  [(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer
0,String
"illegal value 0")]
                                                                    Decoder Bool
dump64
dumpProp Word32
_ String
"_NET_STARTUP_ID"                          =  Decoder Bool
dumpUTF
dumpProp Word32
_ String
"WM_PROTOCOLS"                             =  Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
dumpAtom
dumpProp Word32
_ String
"WM_COLORMAP_WINDOWS"                      =  Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
dumpWindow
dumpProp Word32
_ String
"WM_STATE"                                 =  Decoder Bool
dumpState
dumpProp Word32
_ String
"WM_LOCALE_NAME"                           =  Decoder Bool
dumpString
dumpProp Word32
_ String
"WM_CLIENT_LEADER"                         =  Decoder Bool
dumpWindow
dumpProp Word32
_ String
"_NET_WM_WINDOW_OPACITY"                   =  Decoder Bool
dumpPercent
dumpProp Word32
_ String
"XdndAware"                                =  Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
dumpAtom
dumpProp Word32
_ String
"_XKLAVIER_TRANSPARENT"                    =  Int -> Decoder Bool
dumpInteger Int
32
dumpProp Word32
_ String
"_XKLAVIER_STATE"                          =  [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"state"     ,Int -> Decoder Bool
dumpInteger Int
32)
                                                                  ,(String
"indicators",Decoder Bool
dumpXKlInds)
                                                                  ]
dumpProp Word32
_ String
"_MOTIF_DRAG_RECEIVER_INFO"                =  Decoder Bool
dumpMotifDragReceiver
dumpProp Word32
_ String
"_OL_WIN_ATTR"                             =  Decoder Bool
dumpOLAttrs
dumpProp Word32
_ String
"_OL_DECOR_ADD"                            =  Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
dumpAtom
dumpProp Word32
_ String
"_OL_DECOR_DEL"                            =  Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
dumpAtom
dumpProp Word32
_ String
"_MOTIF_WM_HINTS"                          =  Decoder Bool
dumpMwmHints
dumpProp Word32
_ String
"_MOTIF_WM_INFO"                           =  Decoder Bool
dumpMwmInfo
dumpProp Word32
_ String
"_XMONAD_DECORATED_BY"                     =  Decoder Bool
dumpWindow
dumpProp Word32
_ String
"_XMONAD_DECORATION_FOR"                   =  Decoder Bool
dumpWindow
dumpProp Word32
a String
_ | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
wM_NAME                           =  Decoder Bool
dumpString
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
pRIMARY                           =  Decoder Bool
dumpSelection
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
sECONDARY                         =  Decoder Bool
dumpSelection
               -- this is gross
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
wM_TRANSIENT_FOR                  =  do
                 Integer
root <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. X a -> Decoder a
inX (forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Word32
theRoot)
                 Word32
w <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Word32
window
                 WMHints {wmh_window_group :: WMHints -> Word32
wmh_window_group = Word32
wgroup} <-
                   forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip Display -> Word32 -> IO WMHints
getWMHints Word32
w
                 [(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer
0   ,String
"window group " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word32
wgroup)
                            ,(Integer
root,String
"window group " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word32
wgroup)
                            ]
                            Decoder Bool
dumpWindow
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
rESOURCE_MANAGER                  =  Decoder Bool
dumpString
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
wM_COMMAND                        =  Decoder Bool
dumpString
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
wM_HINTS                          =  Decoder Bool
dumpWmHints
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
wM_CLIENT_MACHINE                 =  Decoder Bool
dumpString
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
wM_ICON_NAME                      =  Decoder Bool
dumpString
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
wM_ICON_SIZE                      =  [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"min size"
                                                                   ,[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"w",Decoder Bool
dump32)
                                                                             ,(String
"h",Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ,(String
"max size"
                                                                   ,[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"w",Decoder Bool
dump32)
                                                                             ,(String
"h",Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ,(String
"increment"
                                                                   ,[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"w",Decoder Bool
dump32)
                                                                             ,(String
"h",Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ]
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
wM_NORMAL_HINTS                   =  Decoder Bool
(...)
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
wM_ZOOM_HINTS                     =  Decoder Bool
(...) -- same as previous
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
rGB_DEFAULT_MAP                   =  Decoder Bool
(...) -- XStandardColormap
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
rGB_BEST_MAP                      =  Decoder Bool
(...) -- "
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
rGB_RED_MAP                       =  Decoder Bool
(...) -- "
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
rGB_GREEN_MAP                     =  Decoder Bool
(...) -- "
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
rGB_BLUE_MAP                      =  Decoder Bool
(...) -- "
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
rGB_GRAY_MAP                      =  Decoder Bool
(...) -- "
             | Word32
a forall a. Eq a => a -> a -> Bool
== Word32
wM_CLASS                          =  [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"name" ,Decoder Bool
dumpString)
                                                                  ,(String
"class",Decoder Bool
dumpString)
                                                                  ]
dumpProp Word32
_ String
s | String
s String -> String -> Bool
`isCountOf` String
"WM_S"                   =  Decoder Bool
dumpSelection
             | String
s String -> String -> Bool
`isCountOf` String
"_NET_WM_CM_S"           =  Decoder Bool
dumpSelection
             | String
s String -> String -> Bool
`isCountOf` String
"_NET_DESKTOP_LAYOUT_S"  =  Decoder Bool
dumpSelection
             | String
s String -> String -> Bool
`isCountOf` String
"CUT_BUFFER"             =  Decoder Bool
dumpString
             -- and dumpProperties does the rest
             | Bool
otherwise                              =  forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- lower level decoders --

-- alter the current joint
withJoint   :: String -> Decoder a -> Decoder a
withJoint :: forall a. String -> Decoder a -> Decoder a
withJoint String
j =  ((forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ String -> DecodeState -> DecodeState
withJoint' String
j) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>)

withJoint'     :: String -> DecodeState -> DecodeState
withJoint' :: String -> DecodeState -> DecodeState
withJoint' String
j DecodeState
s =  DecodeState
s {joint :: String
joint = String
j}

-- lift an X into a Decoder
inX :: X a -> Decoder a
inX :: forall a. X a -> Decoder a
inX =  forall a. ReaderT Decode (StateT DecodeState X) a -> Decoder a
Decoder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- flip isPrefixOf, but the remainder must be all digits
isCountOf         :: String -> String -> Bool
-- note that \NUL is safe because atom names have to be C strings
String
s isCountOf :: String -> String -> Bool
`isCountOf` String
pfx =  forall (t :: * -> *) a. Foldable t => t a -> Bool
null                     forall a b. (a -> b) -> a -> b
$
                     forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isDigit        forall a b. (a -> b) -> a -> b
$
                     forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst                  forall a b. (a -> b) -> a -> b
$
                     forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(==)) forall a b. (a -> b) -> a -> b
$
                     forall a b. [a] -> [b] -> [(a, b)]
zip String
s                    forall a b. (a -> b) -> a -> b
$
                     String
pfx forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Char
'\NUL'

-- localize an increased indent
withIndent   :: Int -> Decoder a -> Decoder a
withIndent :: forall a. Int -> Decoder a -> Decoder a
withIndent Int
w =  forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Decode
r -> Decode
r {indent :: Int
indent = Decode -> Int
indent Decode
r forall a. Num a => a -> a -> a
+ Int
w})

-- dump an array of items.  this dumps the entire property
dumpArray      :: Decoder Bool -> Decoder Bool
dumpArray :: Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
item =  do
  forall a. Int -> Decoder a -> Decoder a
withIndent Int
1 forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
append String
"[" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. String -> Decoder a -> Decoder a
withJoint String
"" (Decoder Bool -> String -> Decoder Bool
dumpArray' Decoder Bool
item String
"")

-- step through values as an array, ending on parse error or end of list
dumpArray'          :: Decoder Bool -> String -> Decoder Bool
dumpArray' :: Decoder Bool -> String -> Decoder Bool
dumpArray' Decoder Bool
item String
pfx =  do
  [CUChar]
vs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CUChar]
vs
    then String -> Decoder Bool
append String
"]"
    else String -> Decoder Bool
append String
pfx forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
whenD Decoder Bool
item (Decoder Bool -> String -> Decoder Bool
dumpArray' Decoder Bool
item String
",")

-- keep parsing until a parse step fails
-- @@@ which points out that all my uses of @whenX (return ...)@ are actually 'when',
--     which suggests that 'whenX' is *also* the same function... yep.  ISAGN
whenD     :: Monad m => m Bool -> m Bool -> m Bool
whenD :: forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
whenD m Bool
p m Bool
f =  m Bool
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> if Bool
b then m Bool
f else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- verify a decoder parameter, else call error reporter
-- once again, it's more general than I originally wrote
guardR                  :: (MonadReader r m, Eq v)
                        => (r -> v)                -- value selector
                        -> v                       -- expected value
                        -> (v -> v -> m a)         -- error reporter
                        -> m a                     -- continuation (hush)
                        -> m a
guardR :: forall r (m :: * -> *) v a.
(MonadReader r m, Eq v) =>
(r -> v) -> v -> (v -> v -> m a) -> m a -> m a
guardR r -> v
sel v
val v -> v -> m a
err m a
good =  do
  v
v <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> v
sel
  if v
v forall a. Eq a => a -> a -> Bool
== v
val then m a
good else v -> v -> m a
err v
v v
val

-- this is kinda dumb
fi       :: Bool -> a -> a -> a
fi :: forall a. Bool -> a -> a -> a
fi Bool
p a
n a
y =  if Bool
p then a
y else a
n -- flip (if' p), if that existed

-- verify we have the expected word size
guardSize      :: Int -> Decoder Bool -> Decoder Bool
-- see XSync documentation for this insanity
guardSize :: Int -> Decoder Bool -> Decoder Bool
guardSize Int
64 =  forall r (m :: * -> *) v a.
(MonadReader r m, Eq v) =>
(r -> v) -> v -> (v -> v -> m a) -> m a -> m a
guardR Decode -> Int
width Int
32 Int -> Int -> Decoder Bool
propSizeErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Decoder a -> Decoder a -> Decoder a
guardSize' Int
8         Decoder Bool
propShortErr
guardSize  Int
w =  forall r (m :: * -> *) v a.
(MonadReader r m, Eq v) =>
(r -> v) -> v -> (v -> v -> m a) -> m a -> m a
guardR Decode -> Int
width  Int
w Int -> Int -> Decoder Bool
propSizeErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Decoder a -> Decoder a -> Decoder a
guardSize' (Int -> Int
bytes Int
w) Decoder Bool
propShortErr

guardSize'       :: Int -> Decoder a -> Decoder a -> Decoder a
guardSize' :: forall a. Int -> Decoder a -> Decoder a -> Decoder a
guardSize' Int
l Decoder a
n Decoder a
y =  forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[CUChar]
vs -> forall a. Bool -> a -> a -> a
fi (forall (t :: * -> *) a. Foldable t => t a -> Int
length [CUChar]
vs forall a. Ord a => a -> a -> Bool
>= Int
l) Decoder a
n Decoder a
y

-- verify we have the expected property type
guardType    :: Atom -> Decoder Bool -> Decoder Bool
guardType :: Word32 -> Decoder Bool -> Decoder Bool
guardType  Word32
t =  forall r (m :: * -> *) v a.
(MonadReader r m, Eq v) =>
(r -> v) -> v -> (v -> v -> m a) -> m a -> m a
guardR Decode -> Word32
pType Word32
t Word32 -> Word32 -> Decoder Bool
propTypeErr

-- dump a structure as a named tuple
dumpList       :: [(String,Decoder Bool)] -> Decoder Bool
dumpList :: [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String, Decoder Bool)]
proto =  do
  Word32
a <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Word32
pType
  CULong
-> [(String, Decoder Bool, Word32)] -> String -> Decoder Bool
dumpList'' (forall a. Bounded a => a
maxBound :: CULong) (forall a b. (a -> b) -> [a] -> [b]
map (\(String
s,Decoder Bool
d) -> (String
s,Decoder Bool
d,Word32
a)) [(String, Decoder Bool)]
proto) String
"("

-- same but elements have their own distinct types
dumpList'       :: [(String,Decoder Bool,Atom)] -> Decoder Bool
dumpList' :: [(String, Decoder Bool, Word32)] -> Decoder Bool
dumpList' [(String, Decoder Bool, Word32)]
proto =  CULong
-> [(String, Decoder Bool, Word32)] -> String -> Decoder Bool
dumpList'' (forall a. Bounded a => a
maxBound :: CULong) [(String, Decoder Bool, Word32)]
proto String
"("

-- same but only dump elements identified by provided mask
dumpListByMask     :: CULong -> [(String,Decoder Bool)] -> Decoder Bool
dumpListByMask :: CULong -> [(String, Decoder Bool)] -> Decoder Bool
dumpListByMask CULong
m [(String, Decoder Bool)]
p =  do
  Word32
a <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Word32
pType
  CULong
-> [(String, Decoder Bool, Word32)] -> String -> Decoder Bool
dumpList'' CULong
m (forall a b. (a -> b) -> [a] -> [b]
map (\(String
s,Decoder Bool
d) -> (String
s,Decoder Bool
d,Word32
a)) [(String, Decoder Bool)]
p) String
"("

-- and the previous two combined
dumpListByMask'     :: CULong -> [(String,Decoder Bool,Atom)] -> Decoder Bool
dumpListByMask' :: CULong -> [(String, Decoder Bool, Word32)] -> Decoder Bool
dumpListByMask' CULong
m [(String, Decoder Bool, Word32)]
p =  CULong
-> [(String, Decoder Bool, Word32)] -> String -> Decoder Bool
dumpList'' CULong
m [(String, Decoder Bool, Word32)]
p String
"("

dumpList''                    :: CULong -> [(String,Decoder Bool,Atom)] -> String -> Decoder Bool
dumpList'' :: CULong
-> [(String, Decoder Bool, Word32)] -> String -> Decoder Bool
dumpList'' CULong
_ []           String
_   =  String -> Decoder Bool
append String
")" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
dumpList'' CULong
0 [(String, Decoder Bool, Word32)]
_            String
_   =  String -> Decoder Bool
append String
")" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
dumpList'' CULong
m ((String
l,Decoder Bool
p,Word32
t):[(String, Decoder Bool, Word32)]
ps) String
sep = do
  (Bool
e,String
sep') <- if CULong
m forall a. Bits a => a -> a -> a
.&. CULong
1 forall a. Eq a => a -> a -> Bool
== CULong
0
              then do
                -- @@@ ew
                DecodeState
st <- forall s (m :: * -> *). MonadState s m => m s
get
                Bool
e <- forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Decode
r -> Decode
r {pType :: Word32
pType = Word32
t}) Decoder Bool
p
                [CUChar]
v' <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value
                forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ DecodeState
st {value :: [CUChar]
value = [CUChar]
v'}
                forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
e,String
sep)
              else do
                let label :: String
label = String
sep forall a. [a] -> [a] -> [a]
++ String
l forall a. [a] -> [a] -> [a]
++ String
" = "
                String -> Decoder Bool
append String
label
                Bool
e <- forall a. String -> Decoder a -> Decoder a
withJoint String
"" forall a b. (a -> b) -> a -> b
$ do
                       forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Decode
r -> Decode
r {pType :: Word32
pType  = Word32
t
                                      ,indent :: Int
indent = Decode -> Int
indent Decode
r forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
label
                                      })
                             Decoder Bool
p
                forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
e,String
",")
  if Bool
e then CULong
-> [(String, Decoder Bool, Word32)] -> String -> Decoder Bool
dumpList'' (CULong
m forall a. Bits a => a -> Int -> a
`shiftR` Int
1) [(String, Decoder Bool, Word32)]
ps String
sep' else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
e

-- do the getTextProperty dance, the hard way.
-- @@@ @COMPOUND_TEXT@ not supported yet.
dumpString :: Decoder Bool
dumpString :: Decoder Bool
dumpString =  do
  Word32
fmt <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Word32
pType
  [Word32
cOMPOUND_TEXT,Word32
uTF8_STRING] <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> X Word32
getAtom [String
"COMPOUND_TEXT",String
"UTF8_STRING"]
  case () of
    () | Word32
fmt forall a. Eq a => a -> a -> Bool
== Word32
cOMPOUND_TEXT -> Int -> Decoder Bool -> Decoder Bool
guardSize Int
16 Decoder Bool
(...)
       | Word32
fmt forall a. Eq a => a -> a -> Bool
== Word32
sTRING        -> Int -> Decoder Bool -> Decoder Bool
guardSize  Int
8 forall a b. (a -> b) -> a -> b
$ do
                                   [CUChar]
vs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value
                                   forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DecodeState
r -> DecodeState
r {value :: [CUChar]
value = []})
                                   let ss :: [String]
ss = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Enum a, Enum b) => a -> b
twiddle [CUChar]
vs) forall a b. (a -> b) -> a -> b
$
                                            \String
s -> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s
                                                  then forall a. Maybe a
Nothing
                                                  else let (String
w,String
s'') = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'\NUL') String
s
                                                           s' :: String
s'      = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s''
                                                                     then String
s''
                                                                     else forall a. [a] -> [a]
tail String
s''
                                                        in forall a. a -> Maybe a
Just (String
w,String
s')
                                   case [String]
ss of
                                     [String
s] -> String -> Decoder Bool
append forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show String
s
                                     [String]
ss' -> let go :: [a] -> String -> Decoder Bool
go (a
s:[a]
ss'') String
c = String -> Decoder Bool
append String
c        forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                                                String -> Decoder Bool
append (forall a. Show a => a -> String
show a
s) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                                                [a] -> String -> Decoder Bool
go [a]
ss'' String
","
                                                go []       String
_ = String -> Decoder Bool
append String
"]"
                                             in String -> Decoder Bool
append String
"[" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {a}. Show a => [a] -> String -> Decoder Bool
go [String]
ss' String
""
       | Word32
fmt forall a. Eq a => a -> a -> Bool
== Word32
uTF8_STRING   -> Decoder Bool
dumpUTF -- duplicate type test instead of code :)
       | Bool
otherwise            -> forall a. X a -> Decoder a
inX (Word32 -> X String
atomName Word32
fmt) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                                 String -> Decoder Bool
failure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"unrecognized string type " forall a. [a] -> [a] -> [a]
++)

-- show who owns a selection
dumpSelection :: Decoder Bool
dumpSelection :: Decoder Bool
dumpSelection =  do
  -- system selections contain a window ID; others are random
  -- note that the window ID will be the same as the owner, so
  -- we don't really care anyway.  we *do* want the selection owner
  Word32
a <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Word32
property
  Word32
owner <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Word32 -> IO Word32
xGetSelectionOwner Display
d Word32
a
  if Word32
owner forall a. Eq a => a -> a -> Bool
== Word32
none
    then String -> Decoder Bool
append String
"unowned"
    else do
      String
w <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ Word32 -> X String
debugWindow Word32
owner
      String -> Decoder Bool
append forall a b. (a -> b) -> a -> b
$ String
"owned by " forall a. [a] -> [a] -> [a]
++ String
w

-- for now, not querying Xkb
dumpXKlInds :: Decoder Bool
dumpXKlInds :: Decoder Bool
dumpXKlInds =  Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
iNTEGER forall a b. (a -> b) -> a -> b
$ do
                 Maybe Word32
n <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Decoder (Maybe Integer)
getInt' Int
32
                 case Maybe Word32
n of
                   Maybe Word32
Nothing -> Decoder Bool
propShortErr
                   Just Word32
is -> String -> Decoder Bool
append forall a b. (a -> b) -> a -> b
$ String
"indicators " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (Word32 -> Word32 -> Int -> [String] -> [String]
dumpInds Word32
is Word32
1 Int
1 [])
  where
    dumpInds                               :: Word32 -> Word32 -> Int -> [String] -> [String]
    dumpInds :: Word32 -> Word32 -> Int -> [String] -> [String]
dumpInds Word32
n Word32
bt Int
c [String]
bs | Word32
n forall a. Eq a => a -> a -> Bool
== Word32
0 Bool -> Bool -> Bool
&& Int
c forall a. Eq a => a -> a -> Bool
== Int
1 =  [String
"none"]
                       | Word32
n forall a. Eq a => a -> a -> Bool
== Word32
0           =  [String]
bs
                       | Word32
n forall a. Bits a => a -> a -> a
.&. Word32
bt forall a. Eq a => a -> a -> Bool
/= Word32
0    =  Word32 -> Word32 -> Int -> [String] -> [String]
dumpInds (Word32
n forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> a
complement Word32
bt)
                                                      (Word32
bt forall a. Bits a => a -> Int -> a
`shiftL` Int
1)
                                                      (Int
c forall a. Num a => a -> a -> a
+ Int
1)
                                                      (forall a. Show a => a -> String
show Int
cforall a. a -> [a] -> [a]
:[String]
bs)
                       | Bool
otherwise        =  Word32 -> Word32 -> Int -> [String] -> [String]
dumpInds Word32
n
                                                      (Word32
bt forall a. Bits a => a -> Int -> a
`shiftL` Int
1)
                                                      (Int
c forall a. Num a => a -> a -> a
+ Int
1)
                                                      [String]
bs

-- decode an Atom
dumpAtom :: Decoder Bool
dumpAtom :: Decoder Bool
dumpAtom =
  Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
aTOM forall a b. (a -> b) -> a -> b
$ do
  Maybe Integer
a <- Int -> Decoder (Maybe Integer)
getInt' Int
32
  case Maybe Integer
a of
    Maybe Integer
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Just Integer
a' -> do
           String
an <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ Word32 -> X String
atomName forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
a'
           String -> Decoder Bool
append String
an

dumpWindow :: Decoder Bool
dumpWindow :: Decoder Bool
dumpWindow =  Int -> Decoder Bool -> Decoder Bool
guardSize Int
32 forall a b. (a -> b) -> a -> b
$ Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
wINDOW forall a b. (a -> b) -> a -> b
$ do
                Maybe Integer
w <- Int -> Decoder (Maybe Integer)
getInt' Int
32
                case Maybe Integer
w of
                  Maybe Integer
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                  Just Integer
w' -> forall a. X a -> Decoder a
inX (Word32 -> X String
debugWindow (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
w')) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Decoder Bool
append

-- a bit of a hack; as a Property it's a wINDOW, as a ClientMessage it's a list
dumpActiveWindow :: Decoder Bool
dumpActiveWindow :: Decoder Bool
dumpActiveWindow =  Int -> Decoder Bool -> Decoder Bool
guardSize Int
32 forall a b. (a -> b) -> a -> b
$ do
                      Word32
t <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Word32
pType
                      Word32
nAW <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ String -> X Word32
getAtom String
"_NET_ACTIVE_WINDOW"
                      case () of
                        () | Word32
t forall a. Eq a => a -> a -> Bool
== Word32
wINDOW -> Decoder Bool
dumpWindow
                           | Word32
t forall a. Eq a => a -> a -> Bool
== Word32
nAW    -> [(String, Decoder Bool, Word32)] -> Decoder Bool
dumpList' [(String
"source"       ,[String] -> Decoder Bool
dumpEnum [String]
awSource,Word32
cARDINAL)
                                                      ,(String
"timestamp"    ,Decoder Bool
dumpTime         ,Word32
cARDINAL)
                                                      ,(String
"active window",Decoder Bool
dumpWindow       ,Word32
wINDOW  )
                                                      ]
                        ()
_                -> do
                                     String
t' <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ Word32 -> X String
atomName Word32
t
                                     String -> Decoder Bool
failure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"(bad type "
                                                      ,String
t'
                                                      ,String
"; expected WINDOW or _NET_ACTIVE_WINDOW"
                                                      ]
-- dump a generic CARDINAL value
dumpInt   :: Int -> Decoder Bool
dumpInt :: Int -> Decoder Bool
dumpInt Int
w =  Int -> Decoder Bool -> Decoder Bool
guardSize Int
w forall a b. (a -> b) -> a -> b
$ Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
cARDINAL forall a b. (a -> b) -> a -> b
$ Int -> (Integer -> String) -> Decoder Bool
getInt Int
w forall a. Show a => a -> String
show

-- INTEGER is the signed version of CARDINAL
dumpInteger   :: Int -> Decoder Bool
dumpInteger :: Int -> Decoder Bool
dumpInteger Int
w =  Int -> Decoder Bool -> Decoder Bool
guardSize Int
w forall a b. (a -> b) -> a -> b
$ Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
iNTEGER forall a b. (a -> b) -> a -> b
$ Int -> (Integer -> String) -> Decoder Bool
getInt Int
w (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer -> Integer
signed Int
w)

-- reinterpret an unsigned as a signed
signed     :: Int -> Integer -> Integer
signed :: Int -> Integer -> Integer
signed Int
w Integer
i =  forall a. Bits a => Int -> a
bit (Int
w forall a. Num a => a -> a -> a
+ Int
1) forall a. Num a => a -> a -> a
- Integer
i

-- and wrappers to keep the parse list in bounds
dump64 :: Decoder Bool
dump64 :: Decoder Bool
dump64 =  Int -> Decoder Bool
dumpInt Int
64

dump32 :: Decoder Bool
dump32 :: Decoder Bool
dump32 =  Int -> Decoder Bool
dumpInt Int
32

{- not used in standard properties
dump16 :: Decoder Bool
dump16 =  dumpInt 16
-}

dump8 :: Decoder Bool
dump8 :: Decoder Bool
dump8 =  Int -> Decoder Bool
dumpInt Int
8

-- I am assuming for the moment that this is a single string.
-- This might be false; consider the way the STRING properties
-- handle lists.
dumpUTF :: Decoder Bool
dumpUTF :: Decoder Bool
dumpUTF =  do
  Word32
uTF8_STRING <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ String -> X Word32
getAtom String
"UTF8_STRING"
  Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
uTF8_STRING forall a b. (a -> b) -> a -> b
$ Int -> Decoder Bool -> Decoder Bool
guardSize Int
8 forall a b. (a -> b) -> a -> b
$ do
    [CUChar]
s <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DecodeState
r -> DecodeState
r {value :: [CUChar]
value = []})
    String -> Decoder Bool
append forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> String
decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ [CUChar]
s
    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- dump an enumerated value using a translation table
dumpEnum'        :: [String] -> Atom -> Decoder Bool
dumpEnum' :: [String] -> Word32 -> Decoder Bool
dumpEnum' [String]
ss Word32
fmt =  Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
fmt forall a b. (a -> b) -> a -> b
$
                    Int -> (Integer -> String) -> Decoder Bool
getInt Int
32     forall a b. (a -> b) -> a -> b
$
                    \Integer
r -> case () of
                            () | Integer
r forall a. Ord a => a -> a -> Bool
< Integer
0                 -> String
"undefined value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
r
                               | Integer
r forall a. Ord a => a -> a -> Bool
>= forall i a. Num i => [a] -> i
genericLength [String]
ss -> String
"undefined value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
r
                               | Bool
otherwise             -> forall i a. Integral i => [a] -> i -> a
genericIndex [String]
ss Integer
r

-- we do not, unlike @xev@, try to ascii-art pixmaps.
dumpPixmap :: Decoder Bool
dumpPixmap :: Decoder Bool
dumpPixmap =  Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
pIXMAP forall a b. (a -> b) -> a -> b
$ do
                Maybe Integer
p' <- Int -> Decoder (Maybe Integer)
getInt' Int
32
                case Maybe Integer
p' of
                  Maybe Integer
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                  Just Integer
p  -> do
                    String -> Decoder Bool
append forall a b. (a -> b) -> a -> b
$ String
"pixmap " forall a. [a] -> [a] -> [a]
++ forall a. (Integral a, Show a) => a -> String -> String
showHex Integer
p String
""
                    Maybe (Word32, Position, Position, Word32, Word32, Word32, CInt)
g' <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$
                            (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display
-> Word32
-> IO (Word32, Position, Position, Word32, Word32, Word32, CInt)
getGeometry Display
d (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
p))
                            forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch`
                            \SomeException
e -> case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                                    Just ExitCode
x -> forall a e. Exception e => e -> a
throw SomeException
e forall a b. a -> b -> a
`const` (ExitCode
x forall a. a -> a -> a
`asTypeOf` ExitCode
ExitSuccess)
                                    Maybe ExitCode
_      -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                    case Maybe (Word32, Position, Position, Word32, Word32, Word32, CInt)
g' of
                      Maybe (Word32, Position, Position, Word32, Word32, Word32, CInt)
Nothing                   -> String -> Decoder Bool
append String
" (deleted)"
                      Just (Word32
_,Position
x,Position
y,Word32
wid,Word32
ht,Word32
bw,CInt
dp) ->
                          String -> Decoder Bool
append forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                     [String
" ("
                                     ,forall a. Show a => a -> String
show Word32
wid
                                     ,Char
'x'forall a. a -> [a] -> [a]
:forall a. Show a => a -> String
show Word32
ht
                                     ,Char
'x'forall a. a -> [a] -> [a]
:forall a. Show a => a -> String
show CInt
dp
                                     ,Char
')'forall a. a -> [a] -> [a]
:if Word32
bw forall a. Eq a => a -> a -> Bool
== Word32
0 then String
"" else Char
'+'forall a. a -> [a] -> [a]
:forall a. Show a => a -> String
show Word32
bw
                                     ,String
"@("
                                     ,forall a. Show a => a -> String
show Position
x
                                     ,Char
','forall a. a -> [a] -> [a]
:forall a. Show a => a -> String
show Position
y
                                     ,String
")"
                                     ]

dumpOLAttrs :: Decoder Bool
dumpOLAttrs :: Decoder Bool
dumpOLAttrs = do
  Word32
pt <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ String -> X Word32
getAtom String
"_OL_WIN_ATTR"
  Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
pt forall a b. (a -> b) -> a -> b
$ do
    Maybe Integer
msk <- Int -> Decoder (Maybe Integer)
getInt' Int
32
    case Maybe Integer
msk of
      Maybe Integer
Nothing   -> Decoder Bool
propShortErr
      Just Integer
msk' -> CULong -> [(String, Decoder Bool)] -> Decoder Bool
dumpListByMask (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
msk') [(String
"window type" ,Decoder Bool
dumpAtom     )
                                                      ,(String
"menu"        ,Decoder Bool
dump32       ) -- @@@ unk
                                                      ,(String
"pushpin"     ,[String] -> Decoder Bool
dumpEnum [String]
bool)
                                                      ,(String
"limited menu",Decoder Bool
dump32       ) -- @@@ unk
                                                      ]

dumpMwmHints :: Decoder Bool
dumpMwmHints :: Decoder Bool
dumpMwmHints =  do
  Word32
ta <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Word32
property
  Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
ta forall a b. (a -> b) -> a -> b
$ do
    Maybe Integer
msk <- Int -> Decoder (Maybe Integer)
getInt' Int
32
    case Maybe Integer
msk of
      Maybe Integer
Nothing   -> Decoder Bool
propShortErr
      Just Integer
msk' -> CULong -> [(String, Decoder Bool)] -> Decoder Bool
dumpListByMask (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
msk') [(String
"functions"  ,[String] -> Decoder Bool
dumpBits [String]
mwmFuncs    )
                                                      ,(String
"decorations",[String] -> Decoder Bool
dumpBits [String]
mwmDecos    )
                                                      ,(String
"input mode" ,[String] -> Decoder Bool
dumpEnum [String]
mwmInputMode)
                                                      ,(String
"status"     ,[String] -> Decoder Bool
dumpBits [String]
mwmState    )
                                                      ]

dumpMwmInfo :: Decoder Bool
dumpMwmInfo :: Decoder Bool
dumpMwmInfo =  do
  Word32
ta <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Word32
property
  Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
ta forall a b. (a -> b) -> a -> b
$ [(String, Decoder Bool, Word32)] -> Decoder Bool
dumpList' [(String
"flags" ,[String] -> Decoder Bool
dumpBits [String]
mwmHints,Word32
cARDINAL)
                           ,(String
"window",Decoder Bool
dumpWindow       ,Word32
wINDOW  )
                           ]

-- the most common case
dumpEnum    :: [String] -> Decoder Bool
dumpEnum :: [String] -> Decoder Bool
dumpEnum [String]
ss =  [String] -> Word32 -> Decoder Bool
dumpEnum' [String]
ss Word32
cARDINAL

-- implement exceptional cases atop a normal dumper
-- @@@ there's gotta be a better way
dumpExcept           :: [(Integer,String)] -> Decoder Bool -> Decoder Bool
dumpExcept :: [(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer, String)]
xs Decoder Bool
item = do
  -- this horror brought to you by reparsing to get the right value for our use
  DecodeState
sp <- forall s (m :: * -> *). MonadState s m => m s
get
  Bool
rc <- Decoder Bool
item
  if Bool -> Bool
not Bool
rc then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else do
    DecodeState
that <- forall s (m :: * -> *). MonadState s m => m s
get -- if none match then we just restore the value parse
    [CUChar]
vs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value
    let w :: Int
w = (forall (t :: * -> *) a. Foldable t => t a -> Int
length (DecodeState -> [CUChar]
value DecodeState
sp) forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [CUChar]
vs) forall a. Num a => a -> a -> a
* Int
8
    -- now we get to reparse again so we get our copy of it
    forall s (m :: * -> *). MonadState s m => s -> m ()
put DecodeState
sp
    Integer
v <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. HasCallStack => Maybe a -> a
fromJust (Int -> Decoder (Maybe Integer)
getInt' Int
w)
    -- and after all that, we can process the exception list
    [(Integer, String)] -> DecodeState -> Integer -> Decoder Bool
dumpExcept' [(Integer, String)]
xs DecodeState
that Integer
v

dumpExcept'                                      :: [(Integer,String)]
                                                 -> DecodeState
                                                 -> Integer
                                                 -> Decoder Bool
dumpExcept' :: [(Integer, String)] -> DecodeState -> Integer -> Decoder Bool
dumpExcept' []             DecodeState
that Integer
_                =  forall s (m :: * -> *). MonadState s m => s -> m ()
put DecodeState
that forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
dumpExcept' ((Integer
exc,String
str):[(Integer, String)]
xs) DecodeState
that Integer
val | Integer
exc forall a. Eq a => a -> a -> Bool
== Integer
val =  String -> Decoder Bool
append String
str
                                    | Bool
otherwise  =  [(Integer, String)] -> DecodeState -> Integer -> Decoder Bool
dumpExcept' [(Integer, String)]
xs DecodeState
that Integer
val

-- use @ps@ to get process information.
-- @@@@ assumes a POSIX @ps@, not a BSDish one.
dumpPid :: Decoder Bool
dumpPid :: Decoder Bool
dumpPid =  Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
cARDINAL forall a b. (a -> b) -> a -> b
$ do
             Maybe Integer
n <- Int -> Decoder (Maybe Integer)
getInt' Int
32
             case Maybe Integer
n of
               Maybe Integer
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
               Just Integer
pid' -> do
                      let pid :: String
pid = forall a. Show a => a -> String
show Integer
pid'
                          ps :: CreateProcess
ps  = (String -> [String] -> CreateProcess
proc String
"/bin/ps" [String
"-fp" forall a. [a] -> [a] -> [a]
++ String
pid]) {std_out :: StdStream
std_out = StdStream
CreatePipe}
                      (Maybe Handle
_,Maybe Handle
o,Maybe Handle
_,ProcessHandle
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
ps
                      case Maybe Handle
o of
                        Maybe Handle
Nothing -> String -> Decoder Bool
append forall a b. (a -> b) -> a -> b
$ String
"pid " forall a. [a] -> [a] -> [a]
++ String
pid
                        Just Handle
p' -> do
                                  [String]
prc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ String -> [String]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO String
hGetContents Handle
p'
                                  -- deliberately forcing it
                                  String -> Decoder Bool
append forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
prc forall a. Ord a => a -> a -> Bool
< Int
2
                                           then String
"pid " forall a. [a] -> [a] -> [a]
++ String
pid
                                           else [String]
prc forall a. [a] -> Int -> a
!! Int
1

dumpTime :: Decoder Bool
dumpTime :: Decoder Bool
dumpTime =  String -> Decoder Bool
append String
"server event # " forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Decoder Bool
dump32

dumpState :: Decoder Bool
dumpState :: Decoder Bool
dumpState =  do
  Word32
wM_STATE <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ String -> X Word32
getAtom String
"WM_STATE"
  Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
wM_STATE forall a b. (a -> b) -> a -> b
$ [(String, Decoder Bool, Word32)] -> Decoder Bool
dumpList' [(String
"state"      ,[String] -> Decoder Bool
dumpEnum [String]
wmState,Word32
cARDINAL)
                                 ,(String
"icon window",Decoder Bool
dumpWindow      ,Word32
wINDOW  )
                                 ]

dumpMotifDragReceiver :: Decoder Bool
dumpMotifDragReceiver :: Decoder Bool
dumpMotifDragReceiver =  do
  Word32
ta <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ String -> X Word32
getAtom String
"_MOTIF_DRAG_RECEIVER_INFO"
  Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
ta forall a b. (a -> b) -> a -> b
$ [(String, Decoder Bool, Word32)] -> Decoder Bool
dumpList' [(String
"endian"    ,Decoder Bool
dumpMotifEndian,Word32
cARDINAL)
                           ,(String
"version"   ,Decoder Bool
dump8          ,Word32
cARDINAL)
                           ,(String
"style"     ,Decoder Bool
dumpMDropStyle ,Word32
cARDINAL) -- @@@ dummy
                           ]

dumpMDropStyle :: Decoder Bool
dumpMDropStyle :: Decoder Bool
dumpMDropStyle =  do
  Maybe Integer
d <- Int -> Decoder (Maybe Integer)
getInt' Int
8
  Int -> Decoder Bool -> Decoder Bool
pad Int
1 forall a b. (a -> b) -> a -> b
$ case Maybe Integer
d of
            Maybe Integer
Nothing             -> Decoder Bool
propShortErr
            Just Integer
ps | Integer
ps forall a. Eq a => a -> a -> Bool
== Integer
0   -> Int -> Decoder Bool -> Decoder Bool
pad Int
12 forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
append String
"none"
                    | Integer
ps forall a. Eq a => a -> a -> Bool
== Integer
1   -> Int -> Decoder Bool -> Decoder Bool
pad Int
12 forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
append String
"drop only"
                    | Integer
ps forall a. Eq a => a -> a -> Bool
== Integer
2   ->          String -> Decoder Bool
append String
"prefer preregister " forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Decoder Bool
dumpMDPrereg
                    | Integer
ps forall a. Eq a => a -> a -> Bool
== Integer
3   ->          String -> Decoder Bool
append String
"preregister "        forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Decoder Bool
dumpMDPrereg
                    | Integer
ps forall a. Eq a => a -> a -> Bool
== Integer
4   -> Int -> Decoder Bool -> Decoder Bool
pad Int
12 forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
append String
"prefer dynamic"
                    | Integer
ps forall a. Eq a => a -> a -> Bool
== Integer
5   -> Int -> Decoder Bool -> Decoder Bool
pad Int
12 forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
append String
"dynamic"
                    | Integer
ps forall a. Eq a => a -> a -> Bool
== Integer
6   -> Int -> Decoder Bool -> Decoder Bool
pad Int
12 forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
append String
"prefer receiver"
                    | Bool
otherwise -> String -> Decoder Bool
failure forall a b. (a -> b) -> a -> b
$ String
"unknown drop style " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
ps

dumpMDPrereg :: Decoder Bool
dumpMDPrereg :: Decoder Bool
dumpMDPrereg =  do
  -- this is a bit ugly; we pretend to be extending the above dumpList'
  String -> Decoder Bool
append String
","
  String -> Decoder Bool
append String
"proxy window = "
  forall a. Int -> Decoder a -> Decoder a
withIndent Int
15 Decoder Bool
dumpWindow
  String -> Decoder Bool
append String
","
  String -> Decoder Bool
append String
"drop sites = "
  Maybe Integer
dsc' <- Int -> Decoder (Maybe Integer)
getInt' Int
16
  case Maybe Integer
dsc' of
    Maybe Integer
Nothing  -> Decoder Bool
propShortErr
    Just Integer
dsc -> do
      forall a. Int -> Decoder a -> Decoder a
withIndent Int
13 forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
append (forall a. Show a => a -> String
show Integer
dsc)
      Int -> Decoder Bool -> Decoder Bool
pad Int
2 forall a b. (a -> b) -> a -> b
$ do
        String -> Decoder Bool
append String
","
        String -> Decoder Bool
append String
"total size = "
        forall a. Int -> Decoder a -> Decoder a
withIndent Int
13 Decoder Bool
dump32
        Int -> Decoder Bool
dumpMDBlocks forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
dsc

dumpMDBlocks   :: Int -> Decoder Bool
dumpMDBlocks :: Int -> Decoder Bool
dumpMDBlocks Int
_ =  String -> Decoder Bool
propSimple String
"(drop site info)" -- @@@ maybe later if needed

dumpMotifEndian :: Decoder Bool
dumpMotifEndian :: Decoder Bool
dumpMotifEndian =  Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
cARDINAL forall a b. (a -> b) -> a -> b
$ Int -> Decoder Bool -> Decoder Bool
guardSize Int
8 forall a b. (a -> b) -> a -> b
$ do
  String
c <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Enum a, Enum b) => a -> b
twiddle forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Decoder [CUChar]
eat Int
1
  case String
c of
    [Char
'l'] -> String -> Decoder Bool
append String
"little"
    [Char
'B'] -> String -> Decoder Bool
append String
"big"
    String
_     -> String -> Decoder Bool
failure String
"bad endian flag"

pad     :: Int -> Decoder Bool -> Decoder Bool
pad :: Int -> Decoder Bool -> Decoder Bool
pad Int
n Decoder Bool
p =  do
  [CUChar]
vs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value
  if forall (t :: * -> *) a. Foldable t => t a -> Int
length [CUChar]
vs forall a. Ord a => a -> a -> Bool
< Int
n
    then Decoder Bool
propShortErr
    else forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DecodeState
r -> DecodeState
r {value :: [CUChar]
value = forall a. Int -> [a] -> [a]
drop Int
n [CUChar]
vs}) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Decoder Bool
p

dumpPercent :: Decoder Bool
dumpPercent :: Decoder Bool
dumpPercent =  Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
cARDINAL forall a b. (a -> b) -> a -> b
$ do
                 Maybe Integer
n <- Int -> Decoder (Maybe Integer)
getInt' Int
32
                 case Maybe Integer
n of
                   Maybe Integer
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                   Just Integer
n' ->
                       let pct :: Double
pct = Double
100 forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n' forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word32)
                           pct :: Double
                        in String -> Decoder Bool
append forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall a b. (RealFrac a, Integral b) => a -> b
round Double
pct :: Integer) forall a. [a] -> [a] -> [a]
++ String
"%"

dumpWmHints :: Decoder Bool
dumpWmHints :: Decoder Bool
dumpWmHints =
  Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
wM_HINTS forall a b. (a -> b) -> a -> b
$ do
  Maybe Integer
msk <- Int -> Decoder (Maybe Integer)
getInt' Int
32
  case Maybe Integer
msk of
    Maybe Integer
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Just Integer
msk' -> CULong -> [(String, Decoder Bool, Word32)] -> Decoder Bool
dumpListByMask' (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
msk')
                                 [(String
"input"        ,[String] -> Decoder Bool
dumpEnum [String]
bool   ,Word32
cARDINAL)
                                 ,(String
"initial_state",[String] -> Decoder Bool
dumpEnum [String]
wmState,Word32
cARDINAL)
                                 ,(String
"icon_pixmap"  ,Decoder Bool
dumpPixmap      ,Word32
pIXMAP  )
                                 ,(String
"icon_window"  ,Decoder Bool
dumpWindow      ,Word32
wINDOW  )
                                 ,(String
"icon_x"       ,Decoder Bool
dump32          ,Word32
cARDINAL)
                                 ,(String
"icon_y"       ,Decoder Bool
dump32          ,Word32
cARDINAL)
                                 ,(String
"icon_mask"    ,Decoder Bool
dumpPixmap      ,Word32
pIXMAP  )
                                 ,(String
"window_group" ,Decoder Bool
dumpWindow      ,Word32
wINDOW  )
                                 ]

dumpBits    :: [String] -> Decoder Bool
dumpBits :: [String] -> Decoder Bool
dumpBits [String]
bs =  Word32 -> Decoder Bool -> Decoder Bool
guardType Word32
cARDINAL forall a b. (a -> b) -> a -> b
$ do
                 Maybe Integer
n <- Int -> Decoder (Maybe Integer)
getInt' Int
32
                 case Maybe Integer
n of
                   Maybe Integer
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                   Just Integer
n' -> [String] -> Int -> Int -> String -> Decoder Bool
dumpBits' [String]
bs Int
1 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n') String
""

dumpBits' :: [String] -> Int -> Int -> String -> Decoder Bool
dumpBits' :: [String] -> Int -> Int -> String -> Decoder Bool
dumpBits' []     Int
_ Int
n String
p = if Int
n forall a. Eq a => a -> a -> Bool
== Int
0 then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else String -> Decoder Bool
append (String
p forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n)
dumpBits' (String
s:[String]
ss) Int
b Int
n String
p = do
  String
p' <- if Int
n forall a. Bits a => a -> a -> a
.&. Int
b forall a. Eq a => a -> a -> Bool
/= Int
0
        then String -> Decoder Bool
append (String
p forall a. [a] -> [a] -> [a]
++ String
s) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return String
"|"
        else forall (m :: * -> *) a. Monad m => a -> m a
return String
p
  [String] -> Int -> Int -> String -> Decoder Bool
dumpBits' [String]
ss (Int
b forall a. Bits a => a -> Int -> a
`shiftL` Int
1) (Int
n forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> a
complement Int
b) String
p'

-- enum definitions --

mwmFuncs :: [String]
mwmFuncs :: [String]
mwmFuncs =  [String
"all except"
            ,String
"resize"
            ,String
"move"
            ,String
"minimize"
            ,String
"maximize"
            ,String
"close"
            ]

mwmDecos :: [String]
mwmDecos :: [String]
mwmDecos =  [String
"all except"
            ,String
"border"
            ,String
"resize handle"
            ,String
"title"
            ,String
"menu button"
            ,String
"maximize button"
            ,String
"minimize button"
            ]

mwmInputMode :: [String]
mwmInputMode :: [String]
mwmInputMode =  [String
"modeless"
                ,String
"application modal"
                ,String
"system model"
                ,String
"full application modal"
                ]

mwmState :: [String]
mwmState :: [String]
mwmState =  [String
"tearoff window"
            ]

mwmHints :: [String]
mwmHints :: [String]
mwmHints =  [String
"standard startup"
            ,String
"custom startup"
            ]

awSource :: [String]
awSource :: [String]
awSource =  [String
"unspecified"
            ,String
"application"
            ,String
"pager/task list"
            ]

{- eventually...
wmHintsFlags :: [String]
wmHintsFlags =  ["Input"
                ,"State"
                ,"IconPixmap"
                ,"IconWindow"
                ,"IconX"
                ,"IconY"
                ,"IconMask"
                ,"WindowGroup"
                ]

wmCRMask :: [String]
wmCRMask =  ["X"
            ,"Y"
            ,"Width"
            ,"Height"
            ,"BorderWidth"
            ,"Sibling"
            ,"StackMode"
            ]
-}

wmPlacement :: [String]
wmPlacement :: [String]
wmPlacement =  [String
"Above"
               ,String
"Below"
               ,String
"TopIf"
               ,String
"BottomIf"
               ,String
"Opposite"
               ]

bool :: [String]
bool :: [String]
bool =  [String
"False",String
"True"]

nwmOrientation :: [String]
nwmOrientation :: [String]
nwmOrientation =  Maybe String -> [String] -> [String]
nwmEnum (forall a. a -> Maybe a
Just String
"ORIENTATION") [String
"HORZ",String
"VERT"]

nwmOrigin :: [String]
nwmOrigin :: [String]
nwmOrigin =  Maybe String -> [String] -> [String]
nwmEnum forall a. Maybe a
Nothing [String
"TOPLEFT",String
"TOPRIGHT",String
"BOTTOMRIGHT",String
"BOTTOMLEFT"]

wmState :: [String]
wmState :: [String]
wmState =  [String
"Withdrawn",String
"Normal",String
"Zoomed (obsolete)",String
"Iconified",String
"Inactive"]

nwmEnum                  :: Maybe String
                         -> [String]
                         -> [String]
nwmEnum :: Maybe String -> [String] -> [String]
nwmEnum Maybe String
Nothing       [String]
vs =  forall a b. (a -> b) -> [a] -> [b]
map ( String
"_NET_WM_"                   forall a. [a] -> [a] -> [a]
++) [String]
vs
nwmEnum (Just String
prefix) [String]
vs =  forall a b. (a -> b) -> [a] -> [b]
map ((String
"_NET_WM_" forall a. [a] -> [a] -> [a]
++ String
prefix forall a. [a] -> [a] -> [a]
++ String
"_") forall a. [a] -> [a] -> [a]
++) [String]
vs

-- and the lowest level coercions --

-- parse and return an integral value
getInt'    :: Int -> Decoder (Maybe Integer)
-- see XSync documentation for this insanity
getInt' :: Int -> Decoder (Maybe Integer)
getInt' Int
64 =  forall r (m :: * -> *) v a.
(MonadReader r m, Eq v) =>
(r -> v) -> v -> (v -> v -> m a) -> m a -> m a
guardR Decode -> Int
width Int
32 (\Int
a Int
e -> Int -> Int -> Decoder Bool
propSizeErr Int
a Int
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
              forall a. Int -> Decoder a -> Decoder a -> Decoder a
guardSize' Int
8 (Decoder Bool
propShortErr forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
                Integer
lo <- Int -> Decoder Integer
inhale Int
32
                Integer
hi <- Int -> Decoder Integer
inhale Int
32
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer
lo forall a. Num a => a -> a -> a
+ Integer
hi forall a. Num a => a -> a -> a
* (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word32) forall a. Num a => a -> a -> a
+ Integer
1)
getInt' Int
w  =  forall r (m :: * -> *) v a.
(MonadReader r m, Eq v) =>
(r -> v) -> v -> (v -> v -> m a) -> m a -> m a
guardR Decode -> Int
width Int
w  (\Int
a Int
e -> Int -> Int -> Decoder Bool
propSizeErr Int
a Int
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
              forall a. Int -> Decoder a -> Decoder a -> Decoder a
guardSize' (Int -> Int
bytes Int
w) (Decoder Bool
propShortErr forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)       forall a b. (a -> b) -> a -> b
$
              forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Decoder Integer
inhale Int
w

-- parse an integral value and feed it to a show-er of some kind
getInt     :: Int -> (Integer -> String) -> Decoder Bool
getInt :: Int -> (Integer -> String) -> Decoder Bool
getInt Int
w Integer -> String
f =  Int -> Decoder (Maybe Integer)
getInt' Int
w forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (String -> Decoder Bool
append forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
f)

-- bottommost level:  parse an integral value out of the stream.
-- Not much in the way of error checking; it is assumed you used
-- the appropriate guards.
-- @@@@@@@@@ evil beyond evil.  there *has* to be a better way
inhale    :: Int -> Decoder Integer
inhale :: Int -> Decoder Integer
inhale  Int
8 =  do
               [CUChar
b] <- Int -> Decoder [CUChar]
eat Int
1
               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral CUChar
b
inhale Int
16 =  do
               [CUChar
b0,CUChar
b1] <- Int -> Decoder [CUChar]
eat Int
2
               forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
2 forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
p -> do
                 forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr CUChar
p [CUChar
b0,CUChar
b1]
                 [Word16
v] <- forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
1 (forall a b. Ptr a -> Ptr b
castPtr Ptr CUChar
p :: Ptr Word16)
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
v
inhale Int
32 =  do
               [CUChar
b0,CUChar
b1,CUChar
b2,CUChar
b3] <- Int -> Decoder [CUChar]
eat Int
4
               forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
4 forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
p -> do
                 forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr CUChar
p [CUChar
b0,CUChar
b1,CUChar
b2,CUChar
b3]
                 [Word32
v] <- forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
1 (forall a b. Ptr a -> Ptr b
castPtr Ptr CUChar
p :: Ptr Word32)
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
v
inhale  Int
b =  forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"inhale " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
b

eat   :: Int -> Decoder Raw
eat :: Int -> Decoder [CUChar]
eat Int
n =  do
  ([CUChar]
bs,[CUChar]
rest) <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. Int -> [a] -> ([a], [a])
splitAt Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeState -> [CUChar]
value)
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DecodeState
r -> DecodeState
r {value :: [CUChar]
value = [CUChar]
rest})
  forall (m :: * -> *) a. Monad m => a -> m a
return [CUChar]
bs

-- actually do formatting type stuffs
-- sorta stubbed for the moment
-- eventually we should do indentation foo here
append :: String -> Decoder Bool
append :: String -> Decoder Bool
append =  Bool -> String -> Decoder Bool
append' Bool
True

-- and the same but for errors
failure :: String -> Decoder Bool
failure :: String -> Decoder Bool
failure =  Bool -> String -> Decoder Bool
append' Bool
False

-- common appender
append'     :: Bool -> String -> Decoder Bool
append' :: Bool -> String -> Decoder Bool
append' Bool
b String
s =  do
  String
j <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> String
joint
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DecodeState
r -> DecodeState
r {accum :: String
accum = DecodeState -> String
accum DecodeState
r forall a. [a] -> [a] -> [a]
++ String
j forall a. [a] -> [a] -> [a]
++ String
s})
  forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b

-- consume all and output a constant string
propSimple   :: String -> Decoder Bool
propSimple :: String -> Decoder Bool
propSimple String
s =  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DecodeState
r -> DecodeState
r {value :: [CUChar]
value = []}) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Decoder Bool
append String
s

-- report various errors
propShortErr :: Decoder Bool
propShortErr :: Decoder Bool
propShortErr =  String -> Decoder Bool
failure String
"(property ended prematurely)"

propSizeErr     :: Int -> Int -> Decoder Bool
propSizeErr :: Int -> Int -> Decoder Bool
propSizeErr Int
e Int
a =  String -> Decoder Bool
failure forall a b. (a -> b) -> a -> b
$ String
"(bad bit width " forall a. [a] -> [a] -> [a]
++
                             forall a. Show a => a -> String
show Int
a            forall a. [a] -> [a] -> [a]
++
                             String
"; expected "     forall a. [a] -> [a] -> [a]
++
                             forall a. Show a => a -> String
show Int
e            forall a. [a] -> [a] -> [a]
++
                             String
")"

propTypeErr     :: Atom -> Atom -> Decoder Bool
propTypeErr :: Word32 -> Word32 -> Decoder Bool
propTypeErr Word32
a Word32
e =  do
  String
e' <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ Word32 -> X String
atomName Word32
e
  String
a' <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ Word32 -> X String
atomName Word32
a
  String -> Decoder Bool
failure forall a b. (a -> b) -> a -> b
$ String
"(bad type " forall a. [a] -> [a] -> [a]
++ String
a' forall a. [a] -> [a] -> [a]
++String
"; expected " forall a. [a] -> [a] -> [a]
++ String
e' forall a. [a] -> [a] -> [a]
++ String
")"

-- for stubs
(...) :: Decoder Bool
... :: Decoder Bool
(...) =  do
  String
fmt <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Word32
pType forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. X a -> Decoder a
inX forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> X String
atomName
  String -> Decoder Bool
propSimple forall a b. (a -> b) -> a -> b
$ String
"(unimplemented type " forall a. [a] -> [a] -> [a]
++ String
fmt forall a. [a] -> [a] -> [a]
++ String
")"

-- you like fi, I like this
twiddle :: (Enum a, Enum b) => a -> b
twiddle :: forall a b. (Enum a, Enum b) => a -> b
twiddle =  forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum