{-# 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                                     hiding (void)
import           Foreign.C.Types
import           Numeric                                     (showHex)
import           System.Exit
import           System.IO
import           System.Process
import           GHC.Stack                                   (HasCallStack, prettyCallStack, callStack)

-- | 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 -> Atom
ev_window       = Atom
w
                                      ,ev_parent :: Event -> Atom
ev_parent       = Atom
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 -> Atom
ev_above        = Atom
above
                                      ,ev_detail :: Event -> CInt
ev_detail       = CInt
place
                                      ,ev_value_mask :: Event -> CULong
ev_value_mask   = CULong
msk
                                      } = do
  String -> Atom -> X ()
windowEvent String
"ConfigureRequest" Atom
w
  String -> Atom -> X ()
windowEvent String
"  parent"         Atom
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.
(HasCallStack, 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 Atom
above,CInt
place] forall a b. (a -> b) -> a -> b
$
       HasCallStack =>
CULong -> [(String, Decoder Bool, Atom)] -> Decoder Bool
dumpListByMask' CULong
msk [(String
"x"           ,HasCallStack => Decoder Bool
dump32              ,Atom
cARDINAL)
                           ,(String
"y"           ,HasCallStack => Decoder Bool
dump32              ,Atom
cARDINAL)
                           ,(String
"width"       ,HasCallStack => Decoder Bool
dump32              ,Atom
cARDINAL)
                           ,(String
"height"      ,HasCallStack => Decoder Bool
dump32              ,Atom
cARDINAL)
                           ,(String
"border_width",HasCallStack => Decoder Bool
dump32              ,Atom
cARDINAL)
                           ,(String
"sibling"     ,HasCallStack => Decoder Bool
dumpWindow          ,Atom
wINDOW  )
                           ,(String
"detail"      ,HasCallStack => [String] -> Decoder Bool
dumpEnum [String]
wmPlacement,Atom
cARDINAL)
                           ]
  String -> String -> X ()
say String
"  requested" String
s

debugEventsHook' ConfigureEvent        {ev_window :: Event -> Atom
ev_window = Atom
w
                                       ,ev_above :: Event -> Atom
ev_above  = Atom
above
                                       } = do
  String -> Atom -> X ()
windowEvent String
"Configure" Atom
w
  -- most of the content is covered by debugWindow
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Atom
above forall a. Eq a => a -> a -> Bool
/= Atom
none) forall a b. (a -> b) -> a -> b
$ Atom -> X String
debugWindow Atom
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 -> Atom
ev_window     = Atom
w
                                       ,ev_parent :: Event -> Atom
ev_parent     = Atom
p
                                       } =
  String -> Atom -> X ()
windowEvent String
"MapRequest" Atom
w forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  String -> Atom -> X ()
windowEvent String
"  parent"   Atom
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 -> Atom
ev_window = Atom
w
                                       ,ev_state :: Event -> KeyMask
ev_state  = KeyMask
s
                                       ,ev_button :: Event -> Word32
ev_button = Word32
b
                                       } = do
  String -> Atom -> X ()
windowEvent String
"Button" Atom
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 -> Atom
ev_window = Atom
w
                                        } =
  String -> Atom -> X ()
windowEvent String
"DestroyWindow" Atom
w

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

debugEventsHook' MapNotifyEvent        {ev_window :: Event -> Atom
ev_window = Atom
w
                                       } =
  String -> Atom -> X ()
windowEvent String
"MapNotify" Atom
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 -> Atom
ev_requestor = Atom
rw
                                       ,ev_owner :: Event -> Atom
ev_owner     = Atom
ow
                                       ,ev_selection :: Event -> Atom
ev_selection = Atom
a
                                       } =
  String -> Atom -> X ()
windowEvent String
"SelectionRequest" Atom
rw forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  String -> Atom -> X ()
windowEvent String
"  owner"          Atom
ow forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  String -> Atom -> X ()
atomEvent   String
"  atom"           Atom
a

debugEventsHook' PropertyEvent         {ev_window :: Event -> Atom
ev_window    = Atom
w
                                       ,ev_atom :: Event -> Atom
ev_atom      = Atom
a
                                       ,ev_propstate :: Event -> CInt
ev_propstate = CInt
s
                                       } = do
  String
a' <- Atom -> X String
atomName Atom
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 -> Atom -> X ()
windowEvent String
"Property on" Atom
w
    String
s' <- case CInt
s of
            CInt
1 -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"deleted"
            CInt
0 -> HasCallStack => Atom -> String -> Atom -> Int -> X String
dumpProperty Atom
a String
a' Atom
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 -> Atom
ev_window = Atom
w
                                       } =
  String -> Atom -> X ()
windowEvent String
"Expose" Atom
w

debugEventsHook' ClientMessageEvent    {ev_window :: Event -> Atom
ev_window       = Atom
w
                                       ,ev_message_type :: Event -> Atom
ev_message_type = Atom
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 -> Atom -> X ()
windowEvent String
"ClientMessage on" Atom
w
  String
n <- Atom -> X String
atomName Atom
a
  -- this is a sort of custom property
  -- @@@ this likely won't work as is; type information varies, I think
  (Atom
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 (Atom
a,Int
32,forall (t :: * -> *) a. Foldable t => t a -> Int
length [CInt]
vs')
                Just (String
ta',Int
b,Int
l) -> do
                  Atom
ta <- String -> X Atom
getAtom String
ta'
                  forall (m :: * -> *) a. Monad m => a -> m a
return (Atom
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 <- HasCallStack =>
Atom
-> Atom
-> String
-> Atom
-> Int
-> [CUChar]
-> CULong
-> Int
-> X String
dumpProperty' Atom
w Atom
a String
n Atom
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 :: Atom -> X String
atomName Atom
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 Atom
a forall a. [a] -> [a] -> [a]
++ String
")") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> Atom -> IO (Maybe String)
getAtomName Display
d Atom
a

-- | Emit an atom with respect to the current event.
atomEvent     :: String -> Atom -> X ()
atomEvent :: String -> Atom -> X ()
atomEvent String
l Atom
a =  Atom -> X String
atomName Atom
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 -> Atom -> X ()
windowEvent String
l Atom
w =  Atom -> X String
debugWindow Atom
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 ()
XMonad.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 -> Atom
property :: Atom          -- original property atom
                     ,Decode -> String
pName    :: String        -- its name
                     ,Decode -> Atom
pType    :: Atom          -- base property type atom
                     ,Decode -> Int
width    :: Int           -- declared data width
                     ,Decode -> Atom
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)

    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
             )


-- | 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          :: HasCallStack => Atom -> String -> Window -> Int -> X String
dumpProperty :: HasCallStack => Atom -> String -> Atom -> Int -> X String
dumpProperty Atom
a String
n Atom
w Int
i  =  do
  Either String (Atom, 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 Atom
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
-> Atom
-> Atom
-> CLong
-> CLong
-> Bool
-> Atom
-> Ptr Atom
-> Ptr CInt
-> Ptr CULong
-> Ptr CULong
-> Ptr (Ptr CUChar)
-> IO CInt
xGetWindowProperty
              Display
d
              Atom
w
              Atom
a
              CLong
0
              forall a. Bounded a => a
maxBound
              Bool
False
              Atom
anyPropertyType
              Ptr Atom
fmtp
              Ptr CInt
szp
              Ptr CULong
lenp
              Ptr CULong
ackp
              Ptr (Ptr CUChar)
vsp
    case CInt
rc of
      CInt
0 -> do
        Atom
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 Atom
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
          () | Atom
fmt forall a. Eq a => a -> a -> Bool
== Atom
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 (Atom
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 (Atom, Int, CULong, [CUChar])
prop of
    Left  String
_               -> forall (m :: * -> *) a. Monad m => a -> m a
return String
""
    Right (Atom
fmt,Int
sz,CULong
ack,[CUChar]
vs) -> HasCallStack =>
Atom
-> Atom
-> String
-> Atom
-> Int
-> [CUChar]
-> CULong
-> Int
-> X String
dumpProperty' Atom
w Atom
a String
n Atom
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'                             :: HasCallStack
                                          => 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' :: HasCallStack =>
Atom
-> Atom
-> String
-> Atom
-> Int
-> [CUChar]
-> CULong
-> Int
-> X String
dumpProperty' Atom
w Atom
a String
n Atom
fmt Int
sz [CUChar]
vs CULong
ack Int
i =  do
  String
ptn <- Atom -> X String
atomName Atom
fmt
  let dec :: Decode
dec  = Decode {property :: Atom
property = Atom
a
                    ,pName :: String
pName    = String
n
                    ,pType :: Atom
pType    = Atom
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 :: Atom
window   = Atom
w
                    ,limit :: Int
limit    = Int
96
                    }
      dec' :: Decode
dec' = Decode
dec    {pType :: Atom
pType    = Atom
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
$ HasCallStack => Atom -> String -> Decoder Bool
dumpProp Atom
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
$ HasCallStack => Decoder Bool -> Decoder Bool
dumpArray HasCallStack => 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     :: (HasCallStack, Storable i, Integral i) => [i] -> Decoder Bool -> X String
quickFormat :: forall i.
(HasCallStack, 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 :: Atom
property = Atom
none
                   ,pName :: String
pName    = String
""
                   ,pType :: Atom
pType    = Atom
cARDINAL
                   ,width :: Int
width    = Int
32
                   ,indent :: Int
indent   = Int
0
                   ,window :: Atom
window   = Atom
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                                              :: HasCallStack => Atom -> String -> Decoder Bool

dumpProp :: HasCallStack => Atom -> String -> Decoder Bool
dumpProp Atom
_ String
"CLIPBOARD"                                =  HasCallStack => Decoder Bool
dumpSelection
dumpProp Atom
_ String
"_NET_SUPPORTED"                           =  HasCallStack => Decoder Bool -> Decoder Bool
dumpArray HasCallStack => Decoder Bool
dumpAtom
dumpProp Atom
_ String
"_NET_CLIENT_LIST"                         =  HasCallStack => Decoder Bool -> Decoder Bool
dumpArray HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
_ String
"_NET_CLIENT_LIST_STACKING"                =  HasCallStack => Decoder Bool -> Decoder Bool
dumpArray HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
_ String
"_NET_NUMBER_OF_DESKTOPS"                  =  HasCallStack => Decoder Bool
dump32
dumpProp Atom
_ String
"_NET_VIRTUAL_ROOTS"                       =  HasCallStack => Decoder Bool -> Decoder Bool
dumpArray HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
_ String
"_NET_DESKTOP_GEOMETRY"                    =  HasCallStack => Decoder Bool -> Decoder Bool
dumpArray HasCallStack => Decoder Bool
dump32
dumpProp Atom
_ String
"_NET_DESKTOP_VIEWPORT"                    =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"w",HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"h",HasCallStack => Decoder Bool
dump32)
                                                                  ]
dumpProp Atom
_ String
"_NET_CURRENT_DESKTOP"                     =  HasCallStack => Decoder Bool
dump32
dumpProp Atom
_ String
"_NET_DESKTOP_NAMES"                       =  HasCallStack => Decoder Bool -> Decoder Bool
dumpArray HasCallStack => Decoder Bool
dumpUTF
dumpProp Atom
_ String
"_NET_ACTIVE_WINDOW"                       =  HasCallStack => Decoder Bool
dumpActiveWindow
dumpProp Atom
_ String
"_NET_WORKAREA"                            =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"start"
                                                                   ,HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"x",HasCallStack => Decoder Bool
dump32)
                                                                             ,(String
"y",HasCallStack => Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ,(String
"size"
                                                                   ,HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"w",HasCallStack => Decoder Bool
dump32)
                                                                             ,(String
"h",HasCallStack => Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ]
dumpProp Atom
_ String
"_NET_SUPPORTING_WM_CHECK"                 =  HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
_ String
"_NET_DESKTOP_LAYOUT"                      =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"orientation"
                                                                   ,HasCallStack => [String] -> Decoder Bool
dumpEnum [String]
nwmOrientation
                                                                   )
                                                                  ,(String
"size"
                                                                   ,HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"cols",HasCallStack => Decoder Bool
dump32)
                                                                             ,(String
"rows",HasCallStack => Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ,(String
"origin"
                                                                   ,HasCallStack => [String] -> Decoder Bool
dumpEnum [String]
nwmOrigin
                                                                   )
                                                                  ]
dumpProp Atom
_ String
"_NET_SHOWING_DESKTOP"                     =  HasCallStack => Decoder Bool
dump32
dumpProp Atom
_ String
"_NET_WM_NAME"                             =  HasCallStack => Decoder Bool
dumpUTF
dumpProp Atom
_ String
"_NET_WM_VISIBLE_NAME"                     =  HasCallStack => Decoder Bool
dumpUTF
dumpProp Atom
_ String
"_NET_WM_ICON_NAME"                        =  HasCallStack => Decoder Bool
dumpUTF
dumpProp Atom
_ String
"_NET_WM_VISIBLE_ICON_NAME"                =  HasCallStack => Decoder Bool
dumpUTF
-- @@@ the property is CARDINAL; the message is _NET_WM_DESKTOP of 5 dump32s
--     [desktop/all, source indication, 3 zeroes]
-- dumpProp _ "_NET_WM_DESKTOP"                          =  dumpExcept [(0xFFFFFFFF,"all")]
--                                                                     dump32
dumpProp Atom
_ String
"_NET_WM_DESKTOP"                          =  HasCallStack => Decoder Bool
dumpSetDesktop
dumpProp Atom
_ String
"_NET_WM_WINDOW_TYPE"                      =  HasCallStack => Decoder Bool -> Decoder Bool
dumpArray HasCallStack => Decoder Bool
dumpAtom
dumpProp Atom
_ String
"_NET_WM_STATE"                            =  HasCallStack => Decoder Bool
dumpNWState
dumpProp Atom
_ String
"_NET_WM_ALLOWED_ACTIONS"                  =  HasCallStack => Decoder Bool -> Decoder Bool
dumpArray HasCallStack => Decoder Bool
dumpAtom
dumpProp Atom
_ String
"_NET_WM_STRUT"                            =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"left gap"  ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"right gap" ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"top gap"   ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"bottom gap",HasCallStack => Decoder Bool
dump32)
                                                                  ]
dumpProp Atom
_ String
"_NET_WM_STRUT_PARTIAL"                    =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"left gap"    ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"right gap"   ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"top gap"     ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"bottom gap"  ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"left start"  ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"left end"    ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"right start" ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"right end"   ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"top start"   ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"top end"     ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"bottom start",HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"bottom end"  ,HasCallStack => Decoder Bool
dump32)
                                                                  ]
dumpProp Atom
_ String
"_NET_WM_ICON_GEOMETRY"                    =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"x",HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"y",HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"w",HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"h",HasCallStack => Decoder Bool
dump32)
                                                                  ]
-- no, I'm not going to duplicate xprop *completely*!
dumpProp Atom
_ String
"_NET_WM_ICON"                             =  String -> Decoder Bool
propSimple String
"(icon)"
dumpProp Atom
_ String
"_NET_WM_PID"                              =  HasCallStack => Decoder Bool
dumpPid
dumpProp Atom
_ String
"_NET_WM_HANDLED_ICONS"                    =  String -> Decoder Bool
propSimple String
"(defined)"
dumpProp Atom
_ String
"_NET_WM_USER_TIME"                        =  HasCallStack => [(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer
0,String
"do not map initially")]
                                                                    HasCallStack => Decoder Bool
dumpTime
dumpProp Atom
_ String
"_NET_FRAME_EXTENTS"                       =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"left"  ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"right" ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"top"   ,HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"bottom",HasCallStack => Decoder Bool
dump32)
                                                                  ]
dumpProp Atom
_ String
"_NET_WM_SYNC_REQUEST_COUNTER"             =  HasCallStack => [(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer
0,String
"illegal value 0")]
                                                                    HasCallStack => Decoder Bool
dump64
dumpProp Atom
_ String
"_NET_WM_OPAQUE_REGION"                    =  HasCallStack => Decoder Bool -> Decoder Bool
dumpArray forall a b. (a -> b) -> a -> b
$ HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"x",HasCallStack => Decoder Bool
dump32)
                                                                              ,(String
"y",HasCallStack => Decoder Bool
dump32)
                                                                              ,(String
"w",HasCallStack => Decoder Bool
dump32)
                                                                              ,(String
"h",HasCallStack => Decoder Bool
dump32)
                                                                              ]
dumpProp Atom
_ String
"_NET_WM_BYPASS_COMPOSITOR"                =  HasCallStack => [String] -> Decoder Bool
dumpEnum [String]
cpState
dumpProp Atom
_ String
"_NET_STARTUP_ID"                          =  HasCallStack => Decoder Bool
dumpUTF
dumpProp Atom
_ String
"WM_PROTOCOLS"                             =  HasCallStack => Decoder Bool -> Decoder Bool
dumpArray HasCallStack => Decoder Bool
dumpAtom
dumpProp Atom
_ String
"WM_COLORMAP_WINDOWS"                      =  HasCallStack => Decoder Bool -> Decoder Bool
dumpArray HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
_ String
"WM_STATE"                                 =  HasCallStack => Decoder Bool
dumpState
dumpProp Atom
_ String
"WM_LOCALE_NAME"                           =  HasCallStack => Decoder Bool
dumpString
dumpProp Atom
_ String
"WM_CLIENT_LEADER"                         =  HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
_ String
"_NET_WM_WINDOW_OPACITY"                   =  HasCallStack => Decoder Bool
dumpPercent
dumpProp Atom
_ String
"XdndAware"                                =  HasCallStack => Decoder Bool -> Decoder Bool
dumpArray HasCallStack => Decoder Bool
dumpAtom
dumpProp Atom
_ String
"_XKLAVIER_TRANSPARENT"                    =  HasCallStack => Int -> Decoder Bool
dumpInteger Int
32
dumpProp Atom
_ String
"_XKLAVIER_STATE"                          =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"state"     ,HasCallStack => Int -> Decoder Bool
dumpInteger Int
32)
                                                                  ,(String
"indicators",HasCallStack => Decoder Bool
dumpXKlInds)
                                                                  ]
dumpProp Atom
_ String
"_MOTIF_DRAG_RECEIVER_INFO"                =  HasCallStack => Decoder Bool
dumpMotifDragReceiver
dumpProp Atom
_ String
"_OL_WIN_ATTR"                             =  HasCallStack => Decoder Bool
dumpOLAttrs
dumpProp Atom
_ String
"_OL_DECOR_ADD"                            =  HasCallStack => Decoder Bool -> Decoder Bool
dumpArray HasCallStack => Decoder Bool
dumpAtom
dumpProp Atom
_ String
"_OL_DECOR_DEL"                            =  HasCallStack => Decoder Bool -> Decoder Bool
dumpArray HasCallStack => Decoder Bool
dumpAtom
dumpProp Atom
_ String
"_MOTIF_WM_HINTS"                          =  HasCallStack => Decoder Bool
dumpMwmHints
dumpProp Atom
_ String
"_MOTIF_WM_INFO"                           =  HasCallStack => Decoder Bool
dumpMwmInfo
dumpProp Atom
_ String
"_XMONAD_DECORATED_BY"                     =  HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
_ String
"_XMONAD_DECORATION_FOR"                   =  HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
a String
_ | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
wM_NAME                           =  HasCallStack => Decoder Bool
dumpString
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
pRIMARY                           =  HasCallStack => Decoder Bool
dumpSelection
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
sECONDARY                         =  HasCallStack => Decoder Bool
dumpSelection
               -- this is gross
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
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 -> Atom
theRoot)
                 Atom
w <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Atom
window
                 WMHints {wmh_window_group :: WMHints -> Atom
wmh_window_group = Atom
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 -> Atom -> IO WMHints
getWMHints Atom
w
                 HasCallStack => [(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer
0   ,String
"window group " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Atom
wgroup)
                            ,(Integer
root,String
"window group " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Atom
wgroup)
                            ]
                            HasCallStack => Decoder Bool
dumpWindow
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
rESOURCE_MANAGER                  =  HasCallStack => Decoder Bool
dumpString
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
wM_COMMAND                        =  HasCallStack => Decoder Bool
dumpString
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
wM_HINTS                          =  HasCallStack => Decoder Bool
dumpWmHints
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
wM_CLIENT_MACHINE                 =  HasCallStack => Decoder Bool
dumpString
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
wM_ICON_NAME                      =  HasCallStack => Decoder Bool
dumpString
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
wM_ICON_SIZE                      =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"min size"
                                                                   ,HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"w",HasCallStack => Decoder Bool
dump32)
                                                                             ,(String
"h",HasCallStack => Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ,(String
"max size"
                                                                   ,HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"w",HasCallStack => Decoder Bool
dump32)
                                                                             ,(String
"h",HasCallStack => Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ,(String
"increment"
                                                                   ,HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"w",HasCallStack => Decoder Bool
dump32)
                                                                             ,(String
"h",HasCallStack => Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ]
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
wM_NORMAL_HINTS                   =  HasCallStack => Decoder Bool
dumpSizeHints
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
wM_ZOOM_HINTS                     =  HasCallStack => Decoder Bool
dumpSizeHints
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
rGB_DEFAULT_MAP                   =  Decoder Bool
(...) -- XStandardColormap
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
rGB_BEST_MAP                      =  Decoder Bool
(...) -- "
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
rGB_RED_MAP                       =  Decoder Bool
(...) -- "
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
rGB_GREEN_MAP                     =  Decoder Bool
(...) -- "
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
rGB_BLUE_MAP                      =  Decoder Bool
(...) -- "
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
rGB_GRAY_MAP                      =  Decoder Bool
(...) -- "
             | Atom
a forall a. Eq a => a -> a -> Bool
== Atom
wM_CLASS                          =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"name" ,HasCallStack => Decoder Bool
dumpString)
                                                                  ,(String
"class",HasCallStack => Decoder Bool
dumpString)
                                                                  ]
dumpProp Atom
_ String
s | String
s String -> String -> Bool
`isCountOf` String
"WM_S"                   =  HasCallStack => Decoder Bool
dumpSelection
             | String
s String -> String -> Bool
`isCountOf` String
"_NET_WM_CM_S"           =  HasCallStack => Decoder Bool
dumpSelection
             | String
s String -> String -> Bool
`isCountOf` String
"_NET_DESKTOP_LAYOUT_S"  =  HasCallStack => Decoder Bool
dumpSelection
             | String
s String -> String -> Bool
`isCountOf` String
"CUT_BUFFER"             =  HasCallStack => 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      :: HasCallStack => Decoder Bool -> Decoder Bool
dumpArray :: HasCallStack => 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
"" (HasCallStack => 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'          :: HasCallStack => Decoder Bool -> String -> Decoder Bool
dumpArray' :: HasCallStack => 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 :: * -> *).
(HasCallStack, Monad m) =>
m Bool -> m Bool -> m Bool
whenD Decoder Bool
item (HasCallStack => 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     :: (HasCallStack, Monad m) => m Bool -> m Bool -> m Bool
whenD :: forall (m :: * -> *).
(HasCallStack, 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                  :: (HasCallStack, 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.
(HasCallStack, 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       :: HasCallStack => Bool -> a -> a -> a
fi :: forall a. HasCallStack => 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      :: HasCallStack => Int -> Decoder Bool -> Decoder Bool
-- see XSync documentation for this insanity
guardSize :: HasCallStack => Int -> Decoder Bool -> Decoder Bool
guardSize Int
64 =  forall r (m :: * -> *) v a.
(HasCallStack, 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.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize' Int
8         (HasCallStack => Int -> Decoder Bool
propShortErr' Int
1)
guardSize  Int
w =  forall r (m :: * -> *) v a.
(HasCallStack, 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.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize' (Int -> Int
bytes Int
w) (HasCallStack => Int -> Decoder Bool
propShortErr' Int
2)

guardSize'       :: HasCallStack => Int -> Decoder a -> Decoder a -> Decoder a
guardSize' :: forall a.
HasCallStack =>
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. HasCallStack => Bool -> a -> a -> a
fi (forall (t :: * -> *) a. Foldable t => t a -> Int
length [CUChar]
vs forall a. Ord a => a -> a -> Bool
>= Int -> Int
bytes Int
l) Decoder a
n Decoder a
y

-- @guardSize@ doesn't work with empty arrays
guardSize''       :: HasCallStack => Int -> Decoder a -> Decoder a -> Decoder a
guardSize'' :: forall a.
HasCallStack =>
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. HasCallStack => Bool -> a -> a -> a
fi (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CUChar]
vs Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Int
length [CUChar]
vs forall a. Ord a => a -> a -> Bool
>= Int -> Int
bytes Int
l) Decoder a
n Decoder a
y

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

-- dump a structure as a named tuple
dumpList       :: HasCallStack => [(String,Decoder Bool)] -> Decoder Bool
dumpList :: HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
dumpList [(String, Decoder Bool)]
proto =  do
  Atom
a <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Atom
pType
  HasCallStack =>
CULong -> [(String, Decoder Bool, Atom)] -> 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,Atom
a)) [(String, Decoder Bool)]
proto) String
"("

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

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

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

dumpList''                    :: HasCallStack => CULong -> [(String,Decoder Bool,Atom)] -> String -> Decoder Bool
dumpList'' :: HasCallStack =>
CULong -> [(String, Decoder Bool, Atom)] -> 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, Atom)]
_            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,Atom
t):[(String, Decoder Bool, Atom)]
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 :: Atom
pType = Atom
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 :: Atom
pType  = Atom
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 HasCallStack =>
CULong -> [(String, Decoder Bool, Atom)] -> String -> Decoder Bool
dumpList'' (CULong
m forall a. Bits a => a -> Int -> a
`shiftR` Int
1) [(String, Decoder Bool, Atom)]
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 :: HasCallStack => Decoder Bool
dumpString :: HasCallStack => Decoder Bool
dumpString =  do
  Atom
fmt <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Atom
pType
  [Atom
cOMPOUND_TEXT,Atom
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 Atom
getAtom [String
"COMPOUND_TEXT",String
"UTF8_STRING"]
  case () of
    () | Atom
fmt forall a. Eq a => a -> a -> Bool
== Atom
cOMPOUND_TEXT -> forall a.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize'' Int
16 (HasCallStack => Int -> Decoder Bool
propShortErr' Int
3) ( ... )
       | Atom
fmt forall a. Eq a => a -> a -> Bool
== Atom
sTRING        -> forall a.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize''  Int
8 (HasCallStack => Int -> Decoder Bool
propShortErr' Int
4) 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'      = forall a. Int -> [a] -> [a]
drop Int
1 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
""
       | Atom
fmt forall a. Eq a => a -> a -> Bool
== Atom
uTF8_STRING   -> HasCallStack => Decoder Bool
dumpUTF -- duplicate type test instead of code :)
       | Bool
otherwise            -> forall a. X a -> Decoder a
inX (Atom -> X String
atomName Atom
fmt) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                                 HasCallStack => 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 :: HasCallStack => Decoder Bool
dumpSelection :: HasCallStack => 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
  Atom
a <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Atom
property
  Atom
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 -> Atom -> IO Atom
xGetSelectionOwner Display
d Atom
a
  if Atom
owner forall a. Eq a => a -> a -> Bool
== Atom
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
$ Atom -> X String
debugWindow Atom
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 :: HasCallStack => Decoder Bool
dumpXKlInds :: HasCallStack => Decoder Bool
dumpXKlInds =  HasCallStack => Atom -> Decoder Bool -> Decoder Bool
guardType Atom
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
<$> HasCallStack => Int -> Decoder (Maybe Integer)
getInt' Int
32
                 case Maybe Word32
n of
                   Maybe Word32
Nothing -> HasCallStack => Int -> Decoder Bool
propShortErr' Int
5
                   Just Word32
is -> String -> Decoder Bool
append forall a b. (a -> b) -> a -> b
$ String
"indicators " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (HasCallStack => Word32 -> Word32 -> Int -> [String] -> [String]
dumpInds Word32
is Word32
1 Int
1 [])
  where
    dumpInds                               :: HasCallStack => Word32 -> Word32 -> Int -> [String] -> [String]
    dumpInds :: HasCallStack => 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    =  HasCallStack => 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        =  HasCallStack => 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 :: HasCallStack => Decoder Bool
dumpAtom :: HasCallStack => Decoder Bool
dumpAtom = HasCallStack => Atom -> Decoder Bool
dumpAtom'' Atom
aTOM

{-
dumpAtom' :: HasCallStack => String -> Decoder Bool
dumpAtom' t' = do
  t <- inX $ getAtom t'
  dumpAtom'' t
-}

dumpAtom'' :: HasCallStack => Atom -> Decoder Bool
dumpAtom'' :: HasCallStack => Atom -> Decoder Bool
dumpAtom'' Atom
t =
  HasCallStack => Atom -> Decoder Bool -> Decoder Bool
guardType Atom
t forall a b. (a -> b) -> a -> b
$ do
  Maybe Integer
a <- HasCallStack => 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
$ Atom -> 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 :: HasCallStack => Decoder Bool
dumpWindow :: HasCallStack => Decoder Bool
dumpWindow =  HasCallStack => Int -> Decoder Bool -> Decoder Bool
guardSize Int
32 forall a b. (a -> b) -> a -> b
$ HasCallStack => Atom -> Decoder Bool -> Decoder Bool
guardType Atom
wINDOW forall a b. (a -> b) -> a -> b
$ do
                Maybe Integer
w <- HasCallStack => 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
0  -> String -> Decoder Bool
append String
"none"
                  Just Integer
w' -> forall a. X a -> Decoder a
inX (Atom -> 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 :: HasCallStack => Decoder Bool
dumpActiveWindow :: HasCallStack => Decoder Bool
dumpActiveWindow =  HasCallStack => Int -> Decoder Bool -> Decoder Bool
guardSize Int
32 forall a b. (a -> b) -> a -> b
$ do
                      Atom
t <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Atom
pType
                      Atom
nAW <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ String -> X Atom
getAtom String
"_NET_ACTIVE_WINDOW"
                      case () of
                        () | Atom
t forall a. Eq a => a -> a -> Bool
== Atom
wINDOW -> HasCallStack => Decoder Bool
dumpWindow
                           | Atom
t forall a. Eq a => a -> a -> Bool
== Atom
nAW    -> HasCallStack => [(String, Decoder Bool, Atom)] -> Decoder Bool
dumpList' [(String
"source"       ,HasCallStack => [String] -> Decoder Bool
dumpEnum [String]
awSource,Atom
cARDINAL)
                                                      ,(String
"timestamp"    ,HasCallStack => Decoder Bool
dumpTime         ,Atom
cARDINAL)
                                                      ,(String
"active window",HasCallStack => Decoder Bool
dumpWindow       ,Atom
wINDOW  )
                                                      ]
                        ()
_                -> do
                                     String
t' <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ Atom -> X String
atomName Atom
t
                                     HasCallStack => 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)"
                                                      ]

-- likewise but for _NET_WM_DESKTOP
dumpSetDesktop :: HasCallStack => Decoder Bool
dumpSetDesktop :: HasCallStack => Decoder Bool
dumpSetDesktop =  HasCallStack => Int -> Decoder Bool -> Decoder Bool
guardSize Int
32 forall a b. (a -> b) -> a -> b
$ do
                    Atom
t <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Atom
pType
                    Atom
nWD <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ String -> X Atom
getAtom String
"_NET_WM_DESKTOP"
                    case () of
                      () | Atom
t forall a. Eq a => a -> a -> Bool
== Atom
cARDINAL -> HasCallStack => [(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer
0xFFFFFFFF,String
"all")]
                                                       HasCallStack => Decoder Bool
dump32
                         | Atom
t forall a. Eq a => a -> a -> Bool
== Atom
nWD      -> HasCallStack => [(String, Decoder Bool, Atom)] -> Decoder Bool
dumpList' [(String
"desktop",HasCallStack => [(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer
0xFFFFFFFF,String
"all")]
                                                                             HasCallStack => Decoder Bool
dump32              ,Atom
cARDINAL)
                                                      ,(String
"source" ,HasCallStack => [String] -> Decoder Bool
dumpEnum [String]
awSource              ,Atom
cARDINAL)
                                                      ]
                      ()
_                -> do
                                     String
t' <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ Atom -> X String
atomName Atom
t
                                     HasCallStack => 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 CARDINAL or _NET_WM_DESKTOP)"
                                                      ]

-- and again for _NET_WM_STATE
dumpNWState :: HasCallStack => Decoder Bool
dumpNWState :: HasCallStack => Decoder Bool
dumpNWState =  forall a.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize'' Int
32 HasCallStack => Decoder Bool
propShortErr forall a b. (a -> b) -> a -> b
$ do
                    Atom
t <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Atom
pType
                    Atom
nWS <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ String -> X Atom
getAtom String
"_NET_WM_STATE"
                    case () of
                      () | Atom
t forall a. Eq a => a -> a -> Bool
== Atom
aTOM -> HasCallStack => Decoder Bool -> Decoder Bool
dumpArray HasCallStack => Decoder Bool
dumpAtom
                         | Atom
t forall a. Eq a => a -> a -> Bool
== Atom
nWS  -> HasCallStack => [(String, Decoder Bool, Atom)] -> Decoder Bool
dumpList' [(String
"action",HasCallStack => [String] -> Decoder Bool
dumpEnum [String]
nwAction,Atom
cARDINAL)
                                                  ,(String
"atom1" ,HasCallStack => Decoder Bool
dumpAtom         ,Atom
aTOM)
                                                  ,(String
"atom2" ,HasCallStack => Decoder Bool
dumpAtom         ,Atom
aTOM)
                                                  ]
                      ()
_                -> do
                                     String
t' <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ Atom -> X String
atomName Atom
t
                                     HasCallStack => 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 ATOM or _NET_WM_STATE)"
                                                      ]

-- dump a generic CARDINAL value
dumpInt   :: HasCallStack => Int -> Decoder Bool
dumpInt :: HasCallStack => Int -> Decoder Bool
dumpInt Int
w =  HasCallStack => Int -> Decoder Bool -> Decoder Bool
guardSize Int
w forall a b. (a -> b) -> a -> b
$ HasCallStack => Atom -> Decoder Bool -> Decoder Bool
guardType Atom
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   :: HasCallStack => Int -> Decoder Bool
dumpInteger :: HasCallStack => Int -> Decoder Bool
dumpInteger Int
w =  HasCallStack => Int -> Decoder Bool -> Decoder Bool
guardSize Int
w forall a b. (a -> b) -> a -> b
$ HasCallStack => Atom -> Decoder Bool -> Decoder Bool
guardType Atom
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
. HasCallStack => Int -> Integer -> Integer
signed Int
w)

-- reinterpret an unsigned as a signed
signed     :: HasCallStack => Int -> Integer -> Integer
signed :: HasCallStack => 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 :: HasCallStack => Decoder Bool
dump64 :: HasCallStack => Decoder Bool
dump64 =  HasCallStack => Int -> Decoder Bool
dumpInt Int
64

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

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

dump8 :: HasCallStack => Decoder Bool
dump8 :: HasCallStack => Decoder Bool
dump8 =  HasCallStack => 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 :: HasCallStack => Decoder Bool
dumpUTF :: HasCallStack => Decoder Bool
dumpUTF =  do
  Atom
uTF8_STRING <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ String -> X Atom
getAtom String
"UTF8_STRING"
  HasCallStack => Atom -> Decoder Bool -> Decoder Bool
guardType Atom
uTF8_STRING forall a b. (a -> b) -> a -> b
$ forall a.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize'' Int
8 HasCallStack => Decoder Bool
propShortErr 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'        :: HasCallStack => [String] -> Atom -> Decoder Bool
dumpEnum' :: HasCallStack => [String] -> Atom -> Decoder Bool
dumpEnum' [String]
ss Atom
fmt =  HasCallStack => Atom -> Decoder Bool -> Decoder Bool
guardType Atom
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 :: HasCallStack => Decoder Bool
dumpPixmap :: HasCallStack => Decoder Bool
dumpPixmap =  HasCallStack => Atom -> Decoder Bool -> Decoder Bool
guardType Atom
pIXMAP forall a b. (a -> b) -> a -> b
$ do
                Maybe Integer
p' <- HasCallStack => 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
0  -> String -> Decoder Bool
append String
"none"
                  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 (Atom, 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
-> Atom
-> IO (Atom, 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 (Atom, Position, Position, Word32, Word32, Word32, CInt)
g' of
                      Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt)
Nothing                   -> String -> Decoder Bool
append String
" (deleted)"
                      Just (Atom
_,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 :: HasCallStack => Decoder Bool
dumpOLAttrs :: HasCallStack => Decoder Bool
dumpOLAttrs = do
  Atom
pt <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ String -> X Atom
getAtom String
"_OL_WIN_ATTR"
  HasCallStack => Atom -> Decoder Bool -> Decoder Bool
guardType Atom
pt forall a b. (a -> b) -> a -> b
$ do
    Maybe Integer
msk <- HasCallStack => Int -> Decoder (Maybe Integer)
getInt' Int
32
    case Maybe Integer
msk of
      Maybe Integer
Nothing   -> HasCallStack => Int -> Decoder Bool
propShortErr' Int
7
      Just Integer
msk' -> HasCallStack => CULong -> [(String, Decoder Bool)] -> Decoder Bool
dumpListByMask (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
msk') [(String
"window type" ,HasCallStack => Decoder Bool
dumpAtom     )
                                                      ,(String
"menu"        ,HasCallStack => Decoder Bool
dump32       ) -- @@@ unk
                                                      ,(String
"pushpin"     ,HasCallStack => [String] -> Decoder Bool
dumpEnum [String]
bool)
                                                      ,(String
"limited menu",HasCallStack => Decoder Bool
dump32       ) -- @@@ unk
                                                      ]

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

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

dumpSizeHints :: HasCallStack => Decoder Bool
dumpSizeHints :: HasCallStack => Decoder Bool
dumpSizeHints =  do
  HasCallStack => Atom -> Decoder Bool -> Decoder Bool
guardType Atom
wM_SIZE_HINTS forall a b. (a -> b) -> a -> b
$ do
    -- flags, 4 unused CARD32s, fields as specified by flags
    Maybe CULong
msk <- 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
<$> HasCallStack => Int -> Decoder (Maybe Integer)
getInt' Int
32
    Int -> Decoder [CUChar]
eat (Int
4 forall a. Num a => a -> a -> a
* Int
4) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    case Maybe CULong
msk of
      Maybe CULong
Nothing   -> HasCallStack => Int -> Decoder Bool
propShortErr' Int
9
      Just CULong
msk' -> HasCallStack =>
CULong -> [(String, Decoder Bool, Atom)] -> Decoder Bool
dumpListByMask' CULong
msk' [(String
"min size"    ,HasCallStack => Decoder Bool
dumpSize  ,Atom
cARDINAL)
                                        ,(String
"max size"    ,HasCallStack => Decoder Bool
dumpSize  ,Atom
cARDINAL)
                                        ,(String
"increment"   ,HasCallStack => Decoder Bool
dumpSize  ,Atom
cARDINAL)
                                        ,(String
"aspect ratio",HasCallStack => Decoder Bool
dumpAspect,Atom
cARDINAL)
                                        ,(String
"base size"   ,HasCallStack => Decoder Bool
dumpSize  ,Atom
cARDINAL)
                                        ,(String
"gravity"     ,HasCallStack => Decoder Bool
dumpGrav  ,Atom
cARDINAL)
                                        ]

dumpSize :: HasCallStack => Decoder Bool
dumpSize :: HasCallStack => Decoder Bool
dumpSize =  String -> Decoder Bool
append String
"(" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HasCallStack => Decoder Bool
dump32 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Decoder Bool
append String
"," forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HasCallStack => Decoder Bool
dump32 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Decoder Bool
append String
")"

dumpAspect :: HasCallStack => Decoder Bool
dumpAspect :: HasCallStack => Decoder Bool
dumpAspect =  do
  -- have to do this manually since it doesn't really fit
  String -> Decoder Bool
append String
"min = "
  HasCallStack => Decoder Bool
dump32
  String -> Decoder Bool
append String
"/"
  HasCallStack => Decoder Bool
dump32
  String -> Decoder Bool
append String
", max = "
  HasCallStack => Decoder Bool
dump32
  String -> Decoder Bool
append String
"/"
  HasCallStack => Decoder Bool
dump32

dumpGrav :: HasCallStack => Decoder Bool
dumpGrav :: HasCallStack => Decoder Bool
dumpGrav =  HasCallStack => [String] -> Decoder Bool
dumpEnum [String]
wmGravity

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

-- implement exceptional cases atop a normal dumper
-- @@@ there's gotta be a better way
dumpExcept           :: HasCallStack => [(Integer,String)] -> Decoder Bool -> Decoder Bool
dumpExcept :: HasCallStack => [(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 (HasCallStack => Int -> Decoder (Maybe Integer)
getInt' Int
w)
    -- and after all that, we can process the exception list
    HasCallStack =>
[(Integer, String)] -> DecodeState -> Integer -> Decoder Bool
dumpExcept' [(Integer, String)]
xs DecodeState
that Integer
v

dumpExcept'                                      :: HasCallStack
                                                 => [(Integer,String)]
                                                 -> DecodeState
                                                 -> Integer
                                                 -> Decoder Bool
dumpExcept' :: HasCallStack =>
[(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  =  HasCallStack =>
[(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 :: HasCallStack => Decoder Bool
dumpPid :: HasCallStack => Decoder Bool
dumpPid =  HasCallStack => Atom -> Decoder Bool -> Decoder Bool
guardType Atom
cARDINAL forall a b. (a -> b) -> a -> b
$ do
             Maybe Integer
n <- HasCallStack => 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 :: HasCallStack => Decoder Bool
dumpTime :: HasCallStack => Decoder Bool
dumpTime =  String -> Decoder Bool
append String
"server event # " forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HasCallStack => Decoder Bool
dump32

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

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

dumpMDropStyle :: HasCallStack => Decoder Bool
dumpMDropStyle :: HasCallStack => Decoder Bool
dumpMDropStyle =  do
  Maybe Integer
d <- HasCallStack => Int -> Decoder (Maybe Integer)
getInt' Int
8
  HasCallStack => Int -> Decoder Bool -> Decoder Bool
pad Int
1 forall a b. (a -> b) -> a -> b
$ case Maybe Integer
d of
            Maybe Integer
Nothing             -> HasCallStack => Int -> Decoder Bool
propShortErr' Int
9
            Just Integer
ps | Integer
ps forall a. Eq a => a -> a -> Bool
== Integer
0   -> HasCallStack => 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   -> HasCallStack => 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
>> HasCallStack => 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
>> HasCallStack => Decoder Bool
dumpMDPrereg
                    | Integer
ps forall a. Eq a => a -> a -> Bool
== Integer
4   -> HasCallStack => 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   -> HasCallStack => 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   -> HasCallStack => Int -> Decoder Bool -> Decoder Bool
pad Int
12 forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
append String
"prefer receiver"
                    | Bool
otherwise -> HasCallStack => 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 :: HasCallStack => Decoder Bool
dumpMDPrereg :: HasCallStack => 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 HasCallStack => Decoder Bool
dumpWindow
  String -> Decoder Bool
append String
","
  String -> Decoder Bool
append String
"drop sites = "
  Maybe Integer
dsc' <- HasCallStack => Int -> Decoder (Maybe Integer)
getInt' Int
16
  case Maybe Integer
dsc' of
    Maybe Integer
Nothing  -> HasCallStack => Int -> Decoder Bool
propShortErr' Int
10
    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)
      HasCallStack => 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 HasCallStack => 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 :: HasCallStack => Decoder Bool
dumpMotifEndian :: HasCallStack => Decoder Bool
dumpMotifEndian =  HasCallStack => Atom -> Decoder Bool -> Decoder Bool
guardType Atom
cARDINAL forall a b. (a -> b) -> a -> b
$ HasCallStack => 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
_     -> HasCallStack => String -> Decoder Bool
failure String
"bad endian flag"

pad     :: HasCallStack => Int -> Decoder Bool -> Decoder Bool
pad :: HasCallStack => 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 HasCallStack => Int -> Decoder Bool
propShortErr' Int
11
    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 :: HasCallStack => Decoder Bool
dumpPercent :: HasCallStack => Decoder Bool
dumpPercent =  HasCallStack => Atom -> Decoder Bool -> Decoder Bool
guardType Atom
cARDINAL forall a b. (a -> b) -> a -> b
$ do
                 Maybe Integer
n <- HasCallStack => 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 :: HasCallStack => Decoder Bool
dumpWmHints :: HasCallStack => Decoder Bool
dumpWmHints =
  HasCallStack => Atom -> Decoder Bool -> Decoder Bool
guardType Atom
wM_HINTS forall a b. (a -> b) -> a -> b
$ do
  Maybe Integer
msk <- HasCallStack => 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' -> HasCallStack =>
CULong -> [(String, Decoder Bool, Atom)] -> Decoder Bool
dumpListByMask' (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
msk')
                                 [(String
"input"        ,HasCallStack => [String] -> Decoder Bool
dumpEnum [String]
bool   ,Atom
cARDINAL)
                                 ,(String
"initial_state",HasCallStack => [String] -> Decoder Bool
dumpEnum [String]
wmState,Atom
cARDINAL)
                                 ,(String
"icon_pixmap"  ,HasCallStack => Decoder Bool
dumpPixmap      ,Atom
pIXMAP  )
                                 ,(String
"icon_window"  ,HasCallStack => Decoder Bool
dumpWindow      ,Atom
wINDOW  )
                                 ,(String
"icon_x"       ,HasCallStack => Decoder Bool
dump32          ,Atom
cARDINAL)
                                 ,(String
"icon_y"       ,HasCallStack => Decoder Bool
dump32          ,Atom
cARDINAL)
                                 ,(String
"icon_mask"    ,HasCallStack => Decoder Bool
dumpPixmap      ,Atom
pIXMAP  )
                                 ,(String
"window_group" ,HasCallStack => Decoder Bool
dumpWindow      ,Atom
wINDOW  )
                                 ]

dumpBits    :: HasCallStack => [String] -> Decoder Bool
dumpBits :: HasCallStack => [String] -> Decoder Bool
dumpBits [String]
bs =  HasCallStack => Atom -> Decoder Bool -> Decoder Bool
guardType Atom
cARDINAL forall a b. (a -> b) -> a -> b
$ do
                 Maybe Integer
n <- HasCallStack => 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"
            ]

cpState :: [String]
cpState :: [String]
cpState =  [String
"no preference",String
"disable compositing",String
"force compositing"]

{- 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"]

nwAction :: [String]
nwAction :: [String]
nwAction =  [String
"Clear", String
"Set", String
"Toggle"]

wmGravity :: [String]
wmGravity :: [String]
wmGravity =  [String
"forget/unmap",String
"NW",String
"N",String
"NE",String
"W",String
"C",String
"E",String
"SW",String
"S",String
"SE",String
"static"]

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'    :: HasCallStack => Int -> Decoder (Maybe Integer)
-- see XSync documentation for this insanity
getInt' :: HasCallStack => Int -> Decoder (Maybe Integer)
getInt' Int
64 =  forall r (m :: * -> *) v a.
(HasCallStack, 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.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize' Int
8 (HasCallStack => 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.
(HasCallStack, 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.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize' (Int -> Int
bytes Int
w) (HasCallStack => Int -> Decoder Bool
propShortErr' Int
13 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 =  HasCallStack => 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 :: HasCallStack => String -> Decoder Bool
failure :: HasCallStack => String -> Decoder Bool
failure =  Bool -> String -> Decoder Bool
append' Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack HasCallStack => CallStack
callStack)

-- 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 :: HasCallStack => Decoder Bool
propShortErr :: HasCallStack => Decoder Bool
propShortErr =  HasCallStack => String -> Decoder Bool
failure String
"(property ended prematurely)"

-- debug version
propShortErr'   :: HasCallStack => Int -> Decoder Bool
propShortErr' :: HasCallStack => Int -> Decoder Bool
propShortErr' Int
n =  HasCallStack => String -> Decoder Bool
failure forall a b. (a -> b) -> a -> b
$ String
"(short prop " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
")"

propSizeErr     :: Int -> Int -> Decoder Bool
propSizeErr :: Int -> Int -> Decoder Bool
propSizeErr Int
e Int
a =  HasCallStack => 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 :: Atom -> Atom -> Decoder Bool
propTypeErr Atom
a Atom
e =  do
  String
e' <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ Atom -> X String
atomName Atom
e
  String
a' <- forall a. X a -> Decoder a
inX forall a b. (a -> b) -> a -> b
$ Atom -> X String
atomName Atom
a
  HasCallStack => 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 -> Atom
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
. Atom -> 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