{-# 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 X () -> X All -> X All
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> All -> X All
forall a. a -> X a
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 <- [CInt] -> Decoder Bool -> X String
forall i.
(HasCallStack, Storable i, Integral i) =>
[i] -> Decoder Bool -> X String
quickFormat [CInt
x,CInt
y,CInt
wid,CInt
ht,CInt
bw,Atom -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Atom
above,CInt
place] (Decoder Bool -> X String) -> Decoder Bool -> X String
forall a b. (a -> b) -> a -> b
$
       HasCallStack =>
CULong -> [(String, Decoder Bool, Atom)] -> Decoder Bool
CULong -> [(String, Decoder Bool, Atom)] -> Decoder Bool
dumpListByMask' CULong
msk [(String
"x"           ,Decoder Bool
HasCallStack => Decoder Bool
dump32              ,Atom
cARDINAL)
                           ,(String
"y"           ,Decoder Bool
HasCallStack => Decoder Bool
dump32              ,Atom
cARDINAL)
                           ,(String
"width"       ,Decoder Bool
HasCallStack => Decoder Bool
dump32              ,Atom
cARDINAL)
                           ,(String
"height"      ,Decoder Bool
HasCallStack => Decoder Bool
dump32              ,Atom
cARDINAL)
                           ,(String
"border_width",Decoder Bool
HasCallStack => Decoder Bool
dump32              ,Atom
cARDINAL)
                           ,(String
"sibling"     ,Decoder Bool
HasCallStack => Decoder Bool
dumpWindow          ,Atom
wINDOW  )
                           ,(String
"detail"      ,HasCallStack => [String] -> Decoder Bool
[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
  Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Atom
above Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
/= Atom
none) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ Atom -> X String
debugWindow Atom
above X String -> (String -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
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 X () -> X () -> X ()
forall a b. X a -> X b -> X b
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 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
keyPress =
  IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Handle -> String -> IO ()
hPutStr Handle
stderr String
"KeyPress ") X () -> X All -> X All
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  Event -> X All
debugKeyEvents Event
e X All -> X () -> X ()
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  () -> X ()
forall a. a -> X a
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 <- (XState -> KeyMask) -> X KeyMask
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> KeyMask
numberlockMask
  let msk :: String
msk | KeyMask
s KeyMask -> KeyMask -> Bool
forall a. Eq a => a -> a -> Bool
== KeyMask
0    = String
""
          | Bool
otherwise = String
"modifiers " String -> String -> String
forall a. [a] -> [a] -> [a]
++ KeyMask -> KeyMask -> String
keymaskToString KeyMask
nl KeyMask
s
  String -> String -> X ()
say String
"  button" (String -> X ()) -> String -> X ()
forall a b. (a -> b) -> a -> b
$ Word32 -> String
forall a. Show a => a -> String
show Word32
b String -> String -> String
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         {} =
  () -> X ()
forall a. a -> X a
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 X () -> X () -> X ()
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  String -> Atom -> X ()
windowEvent String
"  owner"          Atom
ow X () -> X () -> X ()
forall a b. X a -> X b -> X b
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' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"_NET_WM_USER_TIME" then () -> X ()
forall a. a -> X a
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 -> String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"deleted"
            CInt
0 -> HasCallStack => Atom -> String -> Atom -> Int -> X String
Atom -> String -> Atom -> Int -> X String
dumpProperty Atom
a String
a' Atom
w (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
a')
            CInt
_ -> String -> X String
forall a. HasCallStack => String -> a
error String
"Illegal propState; Xlib corrupted?"
    String -> String -> X ()
say String
"  atom" (String -> X ()) -> String -> X ()
forall a b. (a -> b) -> a -> b
$ String
a' String -> String -> String
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 String
-> [(String, (String, Int, Int))] -> Maybe (String, Int, Int)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
n [(String, (String, Int, Int))]
clientMessages of
                Maybe (String, Int, Int)
Nothing        -> (Atom, Int, Int) -> X (Atom, Int, Int)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Atom
a,Int
32,[CInt] -> Int
forall a. [a] -> Int
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'
                  (Atom, Int, Int) -> X (Atom, Int, Int)
forall a. a -> X a
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 <- IO [CUChar] -> X [CUChar]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [CUChar] -> X [CUChar]) -> IO [CUChar] -> X [CUChar]
forall a b. (a -> b) -> a -> b
$ Int -> [CUChar] -> [CUChar]
forall a. Int -> [a] -> [a]
take (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
wl) ([CUChar] -> [CUChar]) -> IO [CUChar] -> IO [CUChar]
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
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
n)
  String -> String -> X ()
say String
"  message" (String -> X ()) -> String -> X ()
forall a b. (a -> b) -> a -> b
$ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s

debugEventsHook' Event
_                      = () -> X ()
forall a. a -> X a
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 =  (Display -> X String) -> X String
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X String) -> X String)
-> (Display -> X String) -> X String
forall a b. (a -> b) -> a -> b
$ \Display
d ->
  IO String -> X String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO String -> X String) -> IO String -> X String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String
"(unknown atom " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Atom -> String
forall a. Show a => a -> String
show Atom
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") (Maybe String -> String) -> IO (Maybe String) -> IO 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 X String -> (String -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
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 X String -> (String -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
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 =  String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
XMonad.trace (String -> X ()) -> String -> X ()
forall a b. (a -> b) -> a -> b
$ String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
' 'Char -> String -> String
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 =  IO [CUChar] -> IO [CUChar]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [CUChar] -> IO [CUChar]) -> IO [CUChar] -> IO [CUChar]
forall a b. (a -> b) -> a -> b
$ [CInt] -> (Ptr CInt -> IO [CUChar]) -> IO [CUChar]
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [CInt]
vs ((Ptr CInt -> IO [CUChar]) -> IO [CUChar])
-> (Ptr CInt -> IO [CUChar]) -> IO [CUChar]
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
p ->
                Int -> Ptr CUChar -> IO [CUChar]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [CInt] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CInt]
vs) (Ptr CInt -> Ptr CUChar
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 -> b) -> Decoder a -> Decoder b)
-> (forall a b. a -> Decoder b -> Decoder a) -> Functor Decoder
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
$cfmap :: forall a b. (a -> b) -> Decoder a -> Decoder b
fmap :: forall a b. (a -> b) -> Decoder a -> Decoder b
$c<$ :: forall a b. a -> Decoder b -> Decoder a
<$ :: forall a b. a -> Decoder b -> Decoder a
Functor
             ,Functor Decoder
Functor Decoder =>
(forall a. a -> Decoder a)
-> (forall a b. Decoder (a -> b) -> Decoder a -> Decoder b)
-> (forall a b c.
    (a -> b -> c) -> Decoder a -> Decoder b -> Decoder c)
-> (forall a b. Decoder a -> Decoder b -> Decoder b)
-> (forall a b. Decoder a -> Decoder b -> Decoder a)
-> Applicative 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
$cpure :: forall a. a -> Decoder a
pure :: forall a. a -> Decoder a
$c<*> :: forall a b. Decoder (a -> b) -> Decoder a -> Decoder b
<*> :: forall a b. Decoder (a -> b) -> Decoder a -> Decoder b
$cliftA2 :: forall a b c. (a -> b -> c) -> Decoder a -> Decoder b -> Decoder c
liftA2 :: forall a b c. (a -> b -> c) -> Decoder a -> Decoder b -> Decoder c
$c*> :: forall a b. Decoder a -> Decoder b -> Decoder b
*> :: forall a b. Decoder a -> Decoder b -> Decoder b
$c<* :: forall a b. Decoder a -> Decoder b -> Decoder a
<* :: forall a b. Decoder a -> Decoder b -> Decoder a
Applicative
             ,Applicative Decoder
Applicative Decoder =>
(forall a b. Decoder a -> (a -> Decoder b) -> Decoder b)
-> (forall a b. Decoder a -> Decoder b -> Decoder b)
-> (forall a. a -> Decoder a)
-> Monad 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
$c>>= :: forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
>>= :: forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
$c>> :: forall a b. Decoder a -> Decoder b -> Decoder b
>> :: forall a b. Decoder a -> Decoder b -> Decoder b
$creturn :: forall a. a -> Decoder a
return :: forall a. a -> Decoder a
Monad
             ,Monad Decoder
Monad Decoder => (forall a. IO a -> Decoder a) -> MonadIO Decoder
forall a. IO a -> Decoder a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> Decoder a
liftIO :: forall a. IO a -> Decoder a
MonadIO
             ,Monad Decoder
Monad Decoder =>
(forall a. String -> Decoder a) -> MonadFail Decoder
forall a. String -> Decoder a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall a. String -> Decoder a
fail :: 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 <- (Display -> X (Either String (Atom, Int, CULong, [CUChar])))
-> X (Either String (Atom, Int, CULong, [CUChar]))
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X (Either String (Atom, Int, CULong, [CUChar])))
 -> X (Either String (Atom, Int, CULong, [CUChar])))
-> (Display -> X (Either String (Atom, Int, CULong, [CUChar])))
-> X (Either String (Atom, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$ \Display
d ->
    IO (Either String (Atom, Int, CULong, [CUChar]))
-> X (Either String (Atom, Int, CULong, [CUChar]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io     (IO (Either String (Atom, Int, CULong, [CUChar]))
 -> X (Either String (Atom, Int, CULong, [CUChar])))
-> IO (Either String (Atom, Int, CULong, [CUChar]))
-> X (Either String (Atom, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$
    (Ptr Atom -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Atom -> IO (Either String (Atom, Int, CULong, [CUChar])))
 -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> (Ptr Atom -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$ \Ptr Atom
fmtp ->
    (Ptr CInt -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Either String (Atom, Int, CULong, [CUChar])))
 -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> (Ptr CInt -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
szp  ->
    (Ptr CULong -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CULong -> IO (Either String (Atom, Int, CULong, [CUChar])))
 -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> (Ptr CULong -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$ \Ptr CULong
lenp ->
    (Ptr CULong -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CULong -> IO (Either String (Atom, Int, CULong, [CUChar])))
 -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> (Ptr CULong -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$ \Ptr CULong
ackp ->
    (Ptr (Ptr CUChar)
 -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr CUChar)
  -> IO (Either String (Atom, Int, CULong, [CUChar])))
 -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> (Ptr (Ptr CUChar)
    -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> IO (Either String (Atom, Int, CULong, [CUChar]))
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
              CLong
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 <- Atom -> Atom
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Atom -> Atom) -> IO Atom -> IO Atom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Atom -> IO Atom
forall a. Storable a => Ptr a -> IO a
peek Ptr Atom
fmtp
        Ptr CUChar
vs' <-                  Ptr (Ptr CUChar) -> IO (Ptr CUChar)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CUChar)
vsp
        Int
sz  <- CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
szp
        case () of
          () | Atom
fmt Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
none     -> Ptr CUChar -> IO CInt
forall a. Ptr a -> IO CInt
xFree Ptr CUChar
vs' IO CInt
-> IO (Either String (Atom, Int, CULong, [CUChar]))
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either String (Atom, Int, CULong, [CUChar])
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String (Atom, Int, CULong, [CUChar])
forall a b. a -> Either a b
Left   String
"(property deleted)"   )
             | Int
sz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0          -> Ptr CUChar -> IO CInt
forall a. Ptr a -> IO CInt
xFree Ptr CUChar
vs' IO CInt
-> IO (Either String (Atom, Int, CULong, [CUChar]))
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either String (Atom, Int, CULong, [CUChar])
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String (Atom, Int, CULong, [CUChar])
forall a b. a -> Either a b
Left (String -> Either String (Atom, Int, CULong, [CUChar]))
-> String -> Either String (Atom, Int, CULong, [CUChar])
forall a b. (a -> b) -> a -> b
$ String
"(illegal bit size " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                              Int -> String
forall a. Show a => a -> String
show Int
sz              String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                              String
")"                    )
             | Int
sz Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 -> Ptr CUChar -> IO CInt
forall a. Ptr a -> IO CInt
xFree Ptr CUChar
vs' IO CInt
-> IO (Either String (Atom, Int, CULong, [CUChar]))
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either String (Atom, Int, CULong, [CUChar])
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String (Atom, Int, CULong, [CUChar])
forall a b. a -> Either a b
Left (String -> Either String (Atom, Int, CULong, [CUChar]))
-> String -> Either String (Atom, Int, CULong, [CUChar])
forall a b. (a -> b) -> a -> b
$ String
"(illegal bit size " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                              Int -> String
forall a. Show a => a -> String
show Int
sz              String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                              String
")"                    )
             | Bool
otherwise       -> do
                 Int
len <- CULong -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CULong -> Int) -> IO CULong -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CULong -> IO CULong
forall a. Storable a => Ptr a -> IO a
peek Ptr CULong
lenp
                 -- that's as in "ack! it's fugged!"
                 CULong
ack <- CULong -> CULong
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CULong -> CULong) -> IO CULong -> IO CULong
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CULong -> IO CULong
forall a. Storable a => Ptr a -> IO a
peek Ptr CULong
ackp
                 [CUChar]
vs <- Int -> Ptr CUChar -> IO [CUChar]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int
bytes Int
sz) Ptr CUChar
vs'
                 CInt
_ <- Ptr CUChar -> IO CInt
forall a. Ptr a -> IO CInt
xFree Ptr CUChar
vs'
                 Either String (Atom, Int, CULong, [CUChar])
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Atom, Int, CULong, [CUChar])
 -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> Either String (Atom, Int, CULong, [CUChar])
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$ (Atom, Int, CULong, [CUChar])
-> Either String (Atom, Int, CULong, [CUChar])
forall a b. b -> Either a b
Right (Atom
fmt,Int
sz,CULong
ack,[CUChar]
vs)
      CInt
e -> Either String (Atom, Int, CULong, [CUChar])
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Atom, Int, CULong, [CUChar])
 -> IO (Either String (Atom, Int, CULong, [CUChar])))
-> Either String (Atom, Int, CULong, [CUChar])
-> IO (Either String (Atom, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$ String -> Either String (Atom, Int, CULong, [CUChar])
forall a b. a -> Either a b
Left (String -> Either String (Atom, Int, CULong, [CUChar]))
-> String -> Either String (Atom, Int, CULong, [CUChar])
forall a b. (a -> b) -> a -> b
$ String
"getWindowProperty failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
e
  case Either String (Atom, Int, CULong, [CUChar])
prop of
    Left  String
_               -> String -> X String
forall a. a -> X a
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
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ptn Int -> Int -> Int
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    = cARDINAL
                    ,width    = 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
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ptn String -> String -> String
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 (Decoder Bool -> X (Bool, DecodeState))
-> Decoder Bool -> X (Bool, DecodeState)
forall a b. (a -> b) -> a -> b
$ HasCallStack => Atom -> String -> Decoder Bool
Atom -> String -> Decoder Bool
dumpProp Atom
a String
n
  let fin :: Int
fin = [CUChar] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DecodeState -> [CUChar]
value DecodeState
ds')
      len :: Int
len = [CUChar] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CUChar]
vs
      lost :: String
lost = if CULong
ack CULong -> CULong -> Bool
forall a. Eq a => a -> a -> Bool
== CULong
0 then String
"" else String
" and " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CULong -> String
forall a. Show a => a -> String
show CULong
ack String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" lost bytes"
      unk :: String
unk = case () of
              () | Int
fin Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len -> String
"undecodeable "
                 | Int
fin Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0   -> String
"."
                 | Bool
otherwise  -> String
" and remainder (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fin) String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
len String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  (Bool
_,DecodeState
ds'') <- if Int
fin Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
              then (Bool, DecodeState) -> X (Bool, DecodeState)
forall a. a -> X a
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' ) (Decoder Bool -> X (Bool, DecodeState))
-> Decoder Bool -> X (Bool, DecodeState)
forall a b. (a -> b) -> a -> b
$ HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
HasCallStack => Decoder Bool
dump8
  (Bool
_,DecodeState
ds''') <- if CULong
ack CULong -> CULong -> Bool
forall a. Eq a => a -> a -> Bool
== CULong
0
               then (Bool, DecodeState) -> X (Bool, DecodeState)
forall a. a -> X a
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'') (Decoder Bool -> X (Bool, DecodeState))
-> Decoder Bool -> X (Bool, DecodeState)
forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
propSimple String
lost -- @@@
  String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> X String) -> String -> X String
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 = [i] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [i]
v
  [CUChar]
vs <- IO [CUChar] -> X [CUChar]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [CUChar] -> X [CUChar]) -> IO [CUChar] -> X [CUChar]
forall a b. (a -> b) -> a -> b
$
        Int -> (Ptr CULong -> IO [CUChar]) -> IO [CUChar]
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
vl ((Ptr CULong -> IO [CUChar]) -> IO [CUChar])
-> (Ptr CULong -> IO [CUChar]) -> IO [CUChar]
forall a b. (a -> b) -> a -> b
$
        \Ptr CULong
p -> Ptr CULong -> [CULong] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr CULong
p ((i -> CULong) -> [i] -> [CULong]
forall a b. (a -> b) -> [a] -> [b]
map i -> CULong
forall a b. (Integral a, Num b) => a -> b
fromIntegral [i]
v :: [CULong]) IO () -> IO [CUChar] -> IO [CUChar]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              Int -> Ptr CUChar -> IO [CUChar]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
vl) (Ptr CULong -> Ptr CUChar
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    = Int
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
  String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> X String) -> String -> X String
forall a b. (a -> b) -> a -> b
$ DecodeState -> String
accum DecodeState
ds' String -> String -> String
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) =  StateT DecodeState X Bool -> DecodeState -> X (Bool, DecodeState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ReaderT Decode (StateT DecodeState X) Bool
-> Decode -> StateT DecodeState X Bool
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 Int -> Int -> Int
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"                                =  Decoder Bool
HasCallStack => Decoder Bool
dumpSelection
dumpProp Atom
_ String
"_NET_SUPPORTED"                           =  HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
HasCallStack => Decoder Bool
dumpAtom
dumpProp Atom
_ String
"_NET_CLIENT_LIST"                         =  HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
_ String
"_NET_CLIENT_LIST_STACKING"                =  HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
_ String
"_NET_NUMBER_OF_DESKTOPS"                  =  Decoder Bool
HasCallStack => Decoder Bool
dump32
dumpProp Atom
_ String
"_NET_VIRTUAL_ROOTS"                       =  HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
_ String
"_NET_DESKTOP_GEOMETRY"                    =  HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
HasCallStack => Decoder Bool
dump32
dumpProp Atom
_ String
"_NET_DESKTOP_VIEWPORT"                    =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"w",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"h",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ]
dumpProp Atom
_ String
"_NET_CURRENT_DESKTOP"                     =  Decoder Bool
HasCallStack => Decoder Bool
dump32
dumpProp Atom
_ String
"_NET_DESKTOP_NAMES"                       =  HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
HasCallStack => Decoder Bool
dumpUTF
dumpProp Atom
_ String
"_NET_ACTIVE_WINDOW"                       =  Decoder Bool
HasCallStack => Decoder Bool
dumpActiveWindow
dumpProp Atom
_ String
"_NET_WORKAREA"                            =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"start"
                                                                   ,HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"x",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                             ,(String
"y",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ,(String
"size"
                                                                   ,HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"w",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                             ,(String
"h",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ]
dumpProp Atom
_ String
"_NET_SUPPORTING_WM_CHECK"                 =  Decoder Bool
HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
_ String
"_NET_DESKTOP_LAYOUT"                      =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"orientation"
                                                                   ,HasCallStack => [String] -> Decoder Bool
[String] -> Decoder Bool
dumpEnum [String]
nwmOrientation
                                                                   )
                                                                  ,(String
"size"
                                                                   ,HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"cols",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                             ,(String
"rows",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ,(String
"origin"
                                                                   ,HasCallStack => [String] -> Decoder Bool
[String] -> Decoder Bool
dumpEnum [String]
nwmOrigin
                                                                   )
                                                                  ]
dumpProp Atom
_ String
"_NET_SHOWING_DESKTOP"                     =  Decoder Bool
HasCallStack => Decoder Bool
dump32
dumpProp Atom
_ String
"_NET_WM_NAME"                             =  Decoder Bool
HasCallStack => Decoder Bool
dumpUTF
dumpProp Atom
_ String
"_NET_WM_VISIBLE_NAME"                     =  Decoder Bool
HasCallStack => Decoder Bool
dumpUTF
dumpProp Atom
_ String
"_NET_WM_ICON_NAME"                        =  Decoder Bool
HasCallStack => Decoder Bool
dumpUTF
dumpProp Atom
_ String
"_NET_WM_VISIBLE_ICON_NAME"                =  Decoder Bool
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"                          =  Decoder Bool
HasCallStack => Decoder Bool
dumpSetDesktop
dumpProp Atom
_ String
"_NET_WM_WINDOW_TYPE"                      =  HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
HasCallStack => Decoder Bool
dumpAtom
dumpProp Atom
_ String
"_NET_WM_STATE"                            =  Decoder Bool
HasCallStack => Decoder Bool
dumpNWState
dumpProp Atom
_ String
"_NET_WM_ALLOWED_ACTIONS"                  =  HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
HasCallStack => Decoder Bool
dumpAtom
dumpProp Atom
_ String
"_NET_WM_STRUT"                            =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"left gap"  ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"right gap" ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"top gap"   ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"bottom gap",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ]
dumpProp Atom
_ String
"_NET_WM_STRUT_PARTIAL"                    =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"left gap"    ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"right gap"   ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"top gap"     ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"bottom gap"  ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"left start"  ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"left end"    ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"right start" ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"right end"   ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"top start"   ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"top end"     ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"bottom start",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"bottom end"  ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ]
dumpProp Atom
_ String
"_NET_WM_ICON_GEOMETRY"                    =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"x",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"y",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"w",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"h",Decoder Bool
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"                              =  Decoder Bool
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
[(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer
0,String
"do not map initially")]
                                                                    Decoder Bool
HasCallStack => Decoder Bool
dumpTime
dumpProp Atom
_ String
"_NET_FRAME_EXTENTS"                       =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"left"  ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"right" ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"top"   ,Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ,(String
"bottom",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                  ]
dumpProp Atom
_ String
"_NET_WM_SYNC_REQUEST_COUNTER"             =  HasCallStack => [(Integer, String)] -> Decoder Bool -> Decoder Bool
[(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer
0,String
"illegal value 0")]
                                                                    Decoder Bool
HasCallStack => Decoder Bool
dump64
dumpProp Atom
_ String
"_NET_WM_OPAQUE_REGION"                    =  HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"x",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                              ,(String
"y",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                              ,(String
"w",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                              ,(String
"h",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                              ]
dumpProp Atom
_ String
"_NET_WM_BYPASS_COMPOSITOR"                =  HasCallStack => [String] -> Decoder Bool
[String] -> Decoder Bool
dumpEnum [String]
cpState
dumpProp Atom
_ String
"_NET_STARTUP_ID"                          =  Decoder Bool
HasCallStack => Decoder Bool
dumpUTF
dumpProp Atom
_ String
"WM_PROTOCOLS"                             =  HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
HasCallStack => Decoder Bool
dumpAtom
dumpProp Atom
_ String
"WM_COLORMAP_WINDOWS"                      =  HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
_ String
"WM_STATE"                                 =  Decoder Bool
HasCallStack => Decoder Bool
dumpState
dumpProp Atom
_ String
"WM_LOCALE_NAME"                           =  Decoder Bool
HasCallStack => Decoder Bool
dumpString
dumpProp Atom
_ String
"WM_CLIENT_LEADER"                         =  Decoder Bool
HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
_ String
"_NET_WM_WINDOW_OPACITY"                   =  Decoder Bool
HasCallStack => Decoder Bool
dumpPercent
dumpProp Atom
_ String
"XdndAware"                                =  HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
HasCallStack => Decoder Bool
dumpAtom
dumpProp Atom
_ String
"_XKLAVIER_TRANSPARENT"                    =  HasCallStack => Int -> Decoder Bool
Int -> Decoder Bool
dumpInteger Int
32
dumpProp Atom
_ String
"_XKLAVIER_STATE"                          =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"state"     ,HasCallStack => Int -> Decoder Bool
Int -> Decoder Bool
dumpInteger Int
32)
                                                                  ,(String
"indicators",Decoder Bool
HasCallStack => Decoder Bool
dumpXKlInds)
                                                                  ]
dumpProp Atom
_ String
"_MOTIF_DRAG_RECEIVER_INFO"                =  Decoder Bool
HasCallStack => Decoder Bool
dumpMotifDragReceiver
dumpProp Atom
_ String
"_OL_WIN_ATTR"                             =  Decoder Bool
HasCallStack => Decoder Bool
dumpOLAttrs
dumpProp Atom
_ String
"_OL_DECOR_ADD"                            =  HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
HasCallStack => Decoder Bool
dumpAtom
dumpProp Atom
_ String
"_OL_DECOR_DEL"                            =  HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
HasCallStack => Decoder Bool
dumpAtom
dumpProp Atom
_ String
"_MOTIF_WM_HINTS"                          =  Decoder Bool
HasCallStack => Decoder Bool
dumpMwmHints
dumpProp Atom
_ String
"_MOTIF_WM_INFO"                           =  Decoder Bool
HasCallStack => Decoder Bool
dumpMwmInfo
dumpProp Atom
_ String
"_XMONAD_DECORATED_BY"                     =  Decoder Bool
HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
_ String
"_XMONAD_DECORATION_FOR"                   =  Decoder Bool
HasCallStack => Decoder Bool
dumpWindow
dumpProp Atom
a String
_ | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
wM_NAME                           =  Decoder Bool
HasCallStack => Decoder Bool
dumpString
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
pRIMARY                           =  Decoder Bool
HasCallStack => Decoder Bool
dumpSelection
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
sECONDARY                         =  Decoder Bool
HasCallStack => Decoder Bool
dumpSelection
               -- this is gross
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
wM_TRANSIENT_FOR                  =  do
                 Integer
root <- Atom -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Atom -> Integer) -> Decoder Atom -> Decoder Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> X Atom -> Decoder Atom
forall a. X a -> Decoder a
inX ((XConf -> Atom) -> X Atom
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Atom
theRoot)
                 Atom
w <- (Decode -> Atom) -> Decoder Atom
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} <-
                   X WMHints -> Decoder WMHints
forall a. X a -> Decoder a
inX (X WMHints -> Decoder WMHints) -> X WMHints -> Decoder WMHints
forall a b. (a -> b) -> a -> b
$ (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display X Display -> (Display -> X WMHints) -> X WMHints
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO WMHints -> X WMHints
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO WMHints -> X WMHints)
-> (Display -> IO WMHints) -> Display -> X WMHints
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Display -> Atom -> IO WMHints) -> Atom -> Display -> IO WMHints
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
[(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer
0   ,String
"window group " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Atom -> String
forall a. Show a => a -> String
show Atom
wgroup)
                            ,(Integer
root,String
"window group " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Atom -> String
forall a. Show a => a -> String
show Atom
wgroup)
                            ]
                            Decoder Bool
HasCallStack => Decoder Bool
dumpWindow
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
rESOURCE_MANAGER                  =  Decoder Bool
HasCallStack => Decoder Bool
dumpString
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
wM_COMMAND                        =  Decoder Bool
HasCallStack => Decoder Bool
dumpString
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
wM_HINTS                          =  Decoder Bool
HasCallStack => Decoder Bool
dumpWmHints
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
wM_CLIENT_MACHINE                 =  Decoder Bool
HasCallStack => Decoder Bool
dumpString
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
wM_ICON_NAME                      =  Decoder Bool
HasCallStack => Decoder Bool
dumpString
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
wM_ICON_SIZE                      =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"min size"
                                                                   ,HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"w",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                             ,(String
"h",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ,(String
"max size"
                                                                   ,HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"w",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                             ,(String
"h",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ,(String
"increment"
                                                                   ,HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"w",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                             ,(String
"h",Decoder Bool
HasCallStack => Decoder Bool
dump32)
                                                                             ]
                                                                   )
                                                                  ]
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
wM_NORMAL_HINTS                   =  Decoder Bool
HasCallStack => Decoder Bool
dumpSizeHints
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
wM_ZOOM_HINTS                     =  Decoder Bool
HasCallStack => Decoder Bool
dumpSizeHints
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
rGB_DEFAULT_MAP                   =  Decoder Bool
(...) -- XStandardColormap
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
rGB_BEST_MAP                      =  Decoder Bool
(...) -- "
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
rGB_RED_MAP                       =  Decoder Bool
(...) -- "
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
rGB_GREEN_MAP                     =  Decoder Bool
(...) -- "
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
rGB_BLUE_MAP                      =  Decoder Bool
(...) -- "
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
rGB_GRAY_MAP                      =  Decoder Bool
(...) -- "
             | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
wM_CLASS                          =  HasCallStack => [(String, Decoder Bool)] -> Decoder Bool
[(String, Decoder Bool)] -> Decoder Bool
dumpList [(String
"name" ,Decoder Bool
HasCallStack => Decoder Bool
dumpString)
                                                                  ,(String
"class",Decoder Bool
HasCallStack => Decoder Bool
dumpString)
                                                                  ]
dumpProp Atom
_ String
s | String
s String -> String -> Bool
`isCountOf` String
"WM_S"                   =  Decoder Bool
HasCallStack => Decoder Bool
dumpSelection
             | String
s String -> String -> Bool
`isCountOf` String
"_NET_WM_CM_S"           =  Decoder Bool
HasCallStack => Decoder Bool
dumpSelection
             | String
s String -> String -> Bool
`isCountOf` String
"_NET_DESKTOP_LAYOUT_S"  =  Decoder Bool
HasCallStack => Decoder Bool
dumpSelection
             | String
s String -> String -> Bool
`isCountOf` String
"CUT_BUFFER"             =  Decoder Bool
HasCallStack => Decoder Bool
dumpString
             -- and dumpProperties does the rest
             | Bool
otherwise                              =  Bool -> Decoder Bool
forall a. a -> Decoder a
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 =  (((DecodeState -> DecodeState) -> Decoder ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((DecodeState -> DecodeState) -> Decoder ())
-> (DecodeState -> DecodeState) -> Decoder ()
forall a b. (a -> b) -> a -> b
$ String -> DecodeState -> DecodeState
withJoint' String
j) Decoder () -> Decoder a -> Decoder a
forall a b. Decoder a -> Decoder b -> Decoder b
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 = j}

-- lift an X into a Decoder
inX :: X a -> Decoder a
inX :: forall a. X a -> Decoder a
inX =  ReaderT Decode (StateT DecodeState X) a -> Decoder a
forall a. ReaderT Decode (StateT DecodeState X) a -> Decoder a
Decoder (ReaderT Decode (StateT DecodeState X) a -> Decoder a)
-> (X a -> ReaderT Decode (StateT DecodeState X) a)
-> X a
-> Decoder a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT DecodeState X a -> ReaderT Decode (StateT DecodeState X) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT Decode m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT DecodeState X a -> ReaderT Decode (StateT DecodeState X) a)
-> (X a -> StateT DecodeState X a)
-> X a
-> ReaderT Decode (StateT DecodeState X) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. X a -> StateT DecodeState X a
forall (m :: * -> *) a. Monad m => m a -> StateT DecodeState m a
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 =  String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null                     (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$
                     (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isDigit        (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                     ((Char, Char) -> Char) -> [(Char, Char)] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char, Char) -> Char
forall a b. (a, b) -> a
fst                  ([(Char, Char)] -> String) -> [(Char, Char)] -> String
forall a b. (a -> b) -> a -> b
$
                     ((Char, Char) -> Bool) -> [(Char, Char)] -> [(Char, Char)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Char -> Char -> Bool) -> (Char, Char) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==)) ([(Char, Char)] -> [(Char, Char)])
-> [(Char, Char)] -> [(Char, Char)]
forall a b. (a -> b) -> a -> b
$
                     String -> String -> [(Char, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip String
s                    (String -> [(Char, Char)]) -> String -> [(Char, Char)]
forall a b. (a -> b) -> a -> b
$
                     String
pfx String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
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 =  (Decode -> Decode) -> Decoder a -> Decoder a
forall a. (Decode -> Decode) -> Decoder a -> Decoder a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Decode
r -> Decode
r {indent = indent r + 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
  Int -> Decoder Bool -> Decoder Bool
forall a. Int -> Decoder a -> Decoder a
withIndent Int
1 (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
append String
"[" Decoder Bool -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Decoder Bool -> Decoder Bool
forall a. String -> Decoder a -> Decoder a
withJoint String
"" (HasCallStack => Decoder Bool -> String -> Decoder Bool
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 <- (DecodeState -> [CUChar]) -> Decoder [CUChar]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value
  if [CUChar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CUChar]
vs
    then String -> Decoder Bool
append String
"]"
    else String -> Decoder Bool
append String
pfx Decoder Bool -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Decoder Bool -> Decoder Bool -> Decoder Bool
forall (m :: * -> *).
(HasCallStack, Monad m) =>
m Bool -> m Bool -> m Bool
whenD Decoder Bool
item (HasCallStack => Decoder Bool -> String -> Decoder Bool
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 m Bool -> (Bool -> m Bool) -> m Bool
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> if Bool
b then m Bool
f else Bool -> m Bool
forall a. a -> m a
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 <- (r -> v) -> m v
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> v
sel
  if v
v v -> v -> Bool
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 =  (Decode -> Int)
-> Int
-> (Int -> Int -> Decoder Bool)
-> Decoder Bool
-> Decoder Bool
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 (Decoder Bool -> Decoder Bool)
-> (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Decoder Bool -> Decoder Bool -> Decoder Bool
forall a.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize' Int
8         (HasCallStack => Int -> Decoder Bool
Int -> Decoder Bool
propShortErr' Int
1)
guardSize  Int
w =  (Decode -> Int)
-> Int
-> (Int -> Int -> Decoder Bool)
-> Decoder Bool
-> Decoder Bool
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 (Decoder Bool -> Decoder Bool)
-> (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Decoder Bool -> Decoder Bool -> Decoder Bool
forall a.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize' (Int -> Int
bytes Int
w) (HasCallStack => Int -> Decoder Bool
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 =  (DecodeState -> [CUChar]) -> Decoder [CUChar]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value Decoder [CUChar] -> ([CUChar] -> Decoder a) -> Decoder a
forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[CUChar]
vs -> Bool -> Decoder a -> Decoder a -> Decoder a
forall a. HasCallStack => Bool -> a -> a -> a
fi ([CUChar] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CUChar]
vs Int -> Int -> Bool
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 =  (DecodeState -> [CUChar]) -> Decoder [CUChar]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value Decoder [CUChar] -> ([CUChar] -> Decoder a) -> Decoder a
forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[CUChar]
vs -> Bool -> Decoder a -> Decoder a -> Decoder a
forall a. HasCallStack => Bool -> a -> a -> a
fi ([CUChar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CUChar]
vs Bool -> Bool -> Bool
|| [CUChar] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CUChar]
vs Int -> Int -> Bool
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 =  (Decode -> Atom)
-> Atom
-> (Atom -> Atom -> Decoder Bool)
-> Decoder Bool
-> Decoder Bool
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 <- (Decode -> Atom) -> Decoder Atom
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Atom
pType
  HasCallStack =>
CULong -> [(String, Decoder Bool, Atom)] -> String -> Decoder Bool
CULong -> [(String, Decoder Bool, Atom)] -> String -> Decoder Bool
dumpList'' (CULong
forall a. Bounded a => a
maxBound :: CULong) (((String, Decoder Bool) -> (String, Decoder Bool, Atom))
-> [(String, Decoder Bool)] -> [(String, Decoder Bool, Atom)]
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
CULong -> [(String, Decoder Bool, Atom)] -> String -> Decoder Bool
dumpList'' (CULong
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 <- (Decode -> Atom) -> Decoder Atom
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Atom
pType
  HasCallStack =>
CULong -> [(String, Decoder Bool, Atom)] -> String -> Decoder Bool
CULong -> [(String, Decoder Bool, Atom)] -> String -> Decoder Bool
dumpList'' CULong
m (((String, Decoder Bool) -> (String, Decoder Bool, Atom))
-> [(String, Decoder Bool)] -> [(String, Decoder Bool, Atom)]
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
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
")" Decoder Bool -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Decoder Bool
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
dumpList'' CULong
0 [(String, Decoder Bool, Atom)]
_            String
_   =  String -> Decoder Bool
append String
")" Decoder Bool -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Decoder Bool
forall a. a -> Decoder a
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 CULong -> CULong -> CULong
forall a. Bits a => a -> a -> a
.&. CULong
1 CULong -> CULong -> Bool
forall a. Eq a => a -> a -> Bool
== CULong
0
              then do
                -- @@@ ew
                DecodeState
st <- Decoder DecodeState
forall s (m :: * -> *). MonadState s m => m s
get
                Bool
e <- (Decode -> Decode) -> Decoder Bool -> Decoder Bool
forall a. (Decode -> Decode) -> Decoder a -> Decoder a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Decode
r -> Decode
r {pType = t}) Decoder Bool
p
                [CUChar]
v' <- (DecodeState -> [CUChar]) -> Decoder [CUChar]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value
                DecodeState -> Decoder ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (DecodeState -> Decoder ()) -> DecodeState -> Decoder ()
forall a b. (a -> b) -> a -> b
$ DecodeState
st {value = v'}
                (Bool, String) -> Decoder (Bool, String)
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
e,String
sep)
              else do
                let label :: String
label = String
sep String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = "
                String -> Decoder Bool
append String
label
                Bool
e <- String -> Decoder Bool -> Decoder Bool
forall a. String -> Decoder a -> Decoder a
withJoint String
"" (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
                       (Decode -> Decode) -> Decoder Bool -> Decoder Bool
forall a. (Decode -> Decode) -> Decoder a -> Decoder a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Decode
r -> Decode
r {pType  = t
                                      ,indent = indent r + length label
                                      })
                             Decoder Bool
p
                (Bool, String) -> Decoder (Bool, String)
forall a. a -> Decoder a
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
CULong -> [(String, Decoder Bool, Atom)] -> String -> Decoder Bool
dumpList'' (CULong
m CULong -> Int -> CULong
forall a. Bits a => a -> Int -> a
`shiftR` Int
1) [(String, Decoder Bool, Atom)]
ps String
sep' else Bool -> Decoder Bool
forall a. a -> Decoder a
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 <- (Decode -> Atom) -> Decoder Atom
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Atom
pType
  [Atom
cOMPOUND_TEXT,Atom
uTF8_STRING] <- X [Atom] -> Decoder [Atom]
forall a. X a -> Decoder a
inX (X [Atom] -> Decoder [Atom]) -> X [Atom] -> Decoder [Atom]
forall a b. (a -> b) -> a -> b
$ (String -> X Atom) -> [String] -> X [Atom]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> X Atom
getAtom [String
"COMPOUND_TEXT",String
"UTF8_STRING"]
  case () of
    () | Atom
fmt Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
cOMPOUND_TEXT -> Int -> Decoder Bool -> Decoder Bool -> Decoder Bool
forall a.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize'' Int
16 (HasCallStack => Int -> Decoder Bool
Int -> Decoder Bool
propShortErr' Int
3) ( ... )
       | Atom
fmt Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
sTRING        -> Int -> Decoder Bool -> Decoder Bool -> Decoder Bool
forall a.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize''  Int
8 (HasCallStack => Int -> Decoder Bool
Int -> Decoder Bool
propShortErr' Int
4) (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
                                   [CUChar]
vs <- (DecodeState -> [CUChar]) -> Decoder [CUChar]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value
                                   (DecodeState -> DecodeState) -> Decoder ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DecodeState
r -> DecodeState
r {value = []})
                                   let ss :: [String]
ss = ((String -> Maybe (String, String)) -> String -> [String])
-> String -> (String -> Maybe (String, String)) -> [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> Maybe (String, String)) -> String -> [String]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr ((CUChar -> Char) -> [CUChar] -> String
forall a b. (a -> b) -> [a] -> [b]
map CUChar -> Char
forall a b. (Enum a, Enum b) => a -> b
twiddle [CUChar]
vs) ((String -> Maybe (String, String)) -> [String])
-> (String -> Maybe (String, String)) -> [String]
forall a b. (a -> b) -> a -> b
$
                                            \String
s -> if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s
                                                  then Maybe (String, String)
forall a. Maybe a
Nothing
                                                  else let (String
w,String
s'') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\NUL') String
s
                                                           s' :: String
s'      = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
s''
                                                        in (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
w,String
s')
                                   case [String]
ss of
                                     [String
s] -> String -> Decoder Bool
append (String -> Decoder Bool) -> String -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String -> String
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        Decoder Bool -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                                                String -> Decoder Bool
append (a -> String
forall a. Show a => a -> String
show a
s) Decoder Bool -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
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
"[" Decoder Bool -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> String -> Decoder Bool
forall {a}. Show a => [a] -> String -> Decoder Bool
go [String]
ss' String
""
       | Atom
fmt Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
uTF8_STRING   -> Decoder Bool
HasCallStack => Decoder Bool
dumpUTF -- duplicate type test instead of code :)
       | Bool
otherwise            -> X String -> Decoder String
forall a. X a -> Decoder a
inX (Atom -> X String
atomName Atom
fmt) Decoder String -> (String -> Decoder Bool) -> Decoder Bool
forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                                 HasCallStack => String -> Decoder Bool
String -> Decoder Bool
failure (String -> Decoder Bool)
-> (String -> String) -> String -> Decoder Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"unrecognized string type " String -> String -> String
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 <- (Decode -> Atom) -> Decoder Atom
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Atom
property
  Atom
owner <- X Atom -> Decoder Atom
forall a. X a -> Decoder a
inX (X Atom -> Decoder Atom) -> X Atom -> Decoder Atom
forall a b. (a -> b) -> a -> b
$ (Display -> X Atom) -> X Atom
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X Atom) -> X Atom) -> (Display -> X Atom) -> X Atom
forall a b. (a -> b) -> a -> b
$ \Display
d -> IO Atom -> X Atom
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Atom -> X Atom) -> IO Atom -> X Atom
forall a b. (a -> b) -> a -> b
$ Display -> Atom -> IO Atom
xGetSelectionOwner Display
d Atom
a
  if Atom
owner Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
none
    then String -> Decoder Bool
append String
"unowned"
    else do
      String
w <- X String -> Decoder String
forall a. X a -> Decoder a
inX (X String -> Decoder String) -> X String -> Decoder String
forall a b. (a -> b) -> a -> b
$ Atom -> X String
debugWindow Atom
owner
      String -> Decoder Bool
append (String -> Decoder Bool) -> String -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String
"owned by " String -> String -> String
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
Atom -> Decoder Bool -> Decoder Bool
guardType Atom
iNTEGER (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
                 Maybe Word32
n <- (Integer -> Word32) -> Maybe Integer -> Maybe Word32
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Maybe Integer -> Maybe Word32)
-> Decoder (Maybe Integer) -> Decoder (Maybe Word32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => Int -> Decoder (Maybe Integer)
Int -> Decoder (Maybe Integer)
getInt' Int
32
                 case Maybe Word32
n of
                   Maybe Word32
Nothing -> HasCallStack => Int -> Decoder Bool
Int -> Decoder Bool
propShortErr' Int
5
                   Just Word32
is -> String -> Decoder Bool
append (String -> Decoder Bool) -> String -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String
"indicators " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (HasCallStack => Word32 -> Word32 -> Int -> [String] -> [String]
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 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 Bool -> Bool -> Bool
&& Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 =  [String
"none"]
                       | Word32
n Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0           =  [String]
bs
                       | Word32
n Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
bt Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0    =  HasCallStack => Word32 -> Word32 -> Int -> [String] -> [String]
Word32 -> Word32 -> Int -> [String] -> [String]
dumpInds (Word32
n Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32 -> Word32
forall a. Bits a => a -> a
complement Word32
bt)
                                                      (Word32
bt Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
1)
                                                      (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                                                      (Int -> String
forall a. Show a => a -> String
show Int
cString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
bs)
                       | Bool
otherwise        =  HasCallStack => Word32 -> Word32 -> Int -> [String] -> [String]
Word32 -> Word32 -> Int -> [String] -> [String]
dumpInds Word32
n
                                                      (Word32
bt Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
1)
                                                      (Int
c Int -> Int -> Int
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
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
Atom -> Decoder Bool -> Decoder Bool
guardType Atom
t (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
  Maybe Integer
a <- HasCallStack => Int -> Decoder (Maybe Integer)
Int -> Decoder (Maybe Integer)
getInt' Int
32
  case Maybe Integer
a of
    Maybe Integer
Nothing -> Bool -> Decoder Bool
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Just Integer
a' -> do
           String
an <- X String -> Decoder String
forall a. X a -> Decoder a
inX (X String -> Decoder String) -> X String -> Decoder String
forall a b. (a -> b) -> a -> b
$ Atom -> X String
atomName (Atom -> X String) -> Atom -> X String
forall a b. (a -> b) -> a -> b
$ Integer -> Atom
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
Int -> Decoder Bool -> Decoder Bool
guardSize Int
32 (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ HasCallStack => Atom -> Decoder Bool -> Decoder Bool
Atom -> Decoder Bool -> Decoder Bool
guardType Atom
wINDOW (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
                Maybe Integer
w <- HasCallStack => Int -> Decoder (Maybe Integer)
Int -> Decoder (Maybe Integer)
getInt' Int
32
                case Maybe Integer
w of
                  Maybe Integer
Nothing -> Bool -> Decoder Bool
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                  Just Integer
0  -> String -> Decoder Bool
append String
"none"
                  Just Integer
w' -> X String -> Decoder String
forall a. X a -> Decoder a
inX (Atom -> X String
debugWindow (Integer -> Atom
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
w')) Decoder String -> (String -> Decoder Bool) -> Decoder Bool
forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
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
Int -> Decoder Bool -> Decoder Bool
guardSize Int
32 (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
                      Atom
t <- (Decode -> Atom) -> Decoder Atom
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Atom
pType
                      Atom
nAW <- X Atom -> Decoder Atom
forall a. X a -> Decoder a
inX (X Atom -> Decoder Atom) -> X Atom -> Decoder Atom
forall a b. (a -> b) -> a -> b
$ String -> X Atom
getAtom String
"_NET_ACTIVE_WINDOW"
                      case () of
                        () | Atom
t Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
wINDOW -> Decoder Bool
HasCallStack => Decoder Bool
dumpWindow
                           | Atom
t Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
nAW    -> HasCallStack => [(String, Decoder Bool, Atom)] -> Decoder Bool
[(String, Decoder Bool, Atom)] -> Decoder Bool
dumpList' [(String
"source"       ,HasCallStack => [String] -> Decoder Bool
[String] -> Decoder Bool
dumpEnum [String]
awSource,Atom
cARDINAL)
                                                      ,(String
"timestamp"    ,Decoder Bool
HasCallStack => Decoder Bool
dumpTime         ,Atom
cARDINAL)
                                                      ,(String
"active window",Decoder Bool
HasCallStack => Decoder Bool
dumpWindow       ,Atom
wINDOW  )
                                                      ]
                        ()
_                -> do
                                     String
t' <- X String -> Decoder String
forall a. X a -> Decoder a
inX (X String -> Decoder String) -> X String -> Decoder String
forall a b. (a -> b) -> a -> b
$ Atom -> X String
atomName Atom
t
                                     HasCallStack => String -> Decoder Bool
String -> Decoder Bool
failure (String -> Decoder Bool) -> String -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ [String] -> String
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
Int -> Decoder Bool -> Decoder Bool
guardSize Int
32 (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
                    Atom
t <- (Decode -> Atom) -> Decoder Atom
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Atom
pType
                    Atom
nWD <- X Atom -> Decoder Atom
forall a. X a -> Decoder a
inX (X Atom -> Decoder Atom) -> X Atom -> Decoder Atom
forall a b. (a -> b) -> a -> b
$ String -> X Atom
getAtom String
"_NET_WM_DESKTOP"
                    case () of
                      () | Atom
t Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
cARDINAL -> HasCallStack => [(Integer, String)] -> Decoder Bool -> Decoder Bool
[(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer
0xFFFFFFFF,String
"all")]
                                                       Decoder Bool
HasCallStack => Decoder Bool
dump32
                         | Atom
t Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
nWD      -> HasCallStack => [(String, Decoder Bool, Atom)] -> Decoder Bool
[(String, Decoder Bool, Atom)] -> Decoder Bool
dumpList' [(String
"desktop",HasCallStack => [(Integer, String)] -> Decoder Bool -> Decoder Bool
[(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer
0xFFFFFFFF,String
"all")]
                                                                             Decoder Bool
HasCallStack => Decoder Bool
dump32              ,Atom
cARDINAL)
                                                      ,(String
"source" ,HasCallStack => [String] -> Decoder Bool
[String] -> Decoder Bool
dumpEnum [String]
awSource              ,Atom
cARDINAL)
                                                      ]
                      ()
_                -> do
                                     String
t' <- X String -> Decoder String
forall a. X a -> Decoder a
inX (X String -> Decoder String) -> X String -> Decoder String
forall a b. (a -> b) -> a -> b
$ Atom -> X String
atomName Atom
t
                                     HasCallStack => String -> Decoder Bool
String -> Decoder Bool
failure (String -> Decoder Bool) -> String -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ [String] -> String
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 =  Int -> Decoder Bool -> Decoder Bool -> Decoder Bool
forall a.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize'' Int
32 Decoder Bool
HasCallStack => Decoder Bool
propShortErr (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
                    Atom
t <- (Decode -> Atom) -> Decoder Atom
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Atom
pType
                    Atom
nWS <- X Atom -> Decoder Atom
forall a. X a -> Decoder a
inX (X Atom -> Decoder Atom) -> X Atom -> Decoder Atom
forall a b. (a -> b) -> a -> b
$ String -> X Atom
getAtom String
"_NET_WM_STATE"
                    case () of
                      () | Atom
t Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
aTOM -> HasCallStack => Decoder Bool -> Decoder Bool
Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
HasCallStack => Decoder Bool
dumpAtom
                         | Atom
t Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
nWS  -> HasCallStack => [(String, Decoder Bool, Atom)] -> Decoder Bool
[(String, Decoder Bool, Atom)] -> Decoder Bool
dumpList' [(String
"action",HasCallStack => [String] -> Decoder Bool
[String] -> Decoder Bool
dumpEnum [String]
nwAction,Atom
cARDINAL)
                                                  ,(String
"atom1" ,Decoder Bool
HasCallStack => Decoder Bool
dumpAtom         ,Atom
aTOM)
                                                  ,(String
"atom2" ,Decoder Bool
HasCallStack => Decoder Bool
dumpAtom         ,Atom
aTOM)
                                                  ]
                      ()
_                -> do
                                     String
t' <- X String -> Decoder String
forall a. X a -> Decoder a
inX (X String -> Decoder String) -> X String -> Decoder String
forall a b. (a -> b) -> a -> b
$ Atom -> X String
atomName Atom
t
                                     HasCallStack => String -> Decoder Bool
String -> Decoder Bool
failure (String -> Decoder Bool) -> String -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ [String] -> String
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
Int -> Decoder Bool -> Decoder Bool
guardSize Int
w (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ HasCallStack => Atom -> Decoder Bool -> Decoder Bool
Atom -> Decoder Bool -> Decoder Bool
guardType Atom
cARDINAL (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ Int -> (Integer -> String) -> Decoder Bool
getInt Int
w Integer -> String
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
Int -> Decoder Bool -> Decoder Bool
guardSize Int
w (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ HasCallStack => Atom -> Decoder Bool -> Decoder Bool
Atom -> Decoder Bool -> Decoder Bool
guardType Atom
iNTEGER (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ Int -> (Integer -> String) -> Decoder Bool
getInt Int
w (Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> (Integer -> Integer) -> Integer -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Int -> Integer -> Integer
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 =  Int -> Integer
forall a. Bits a => Int -> a
bit (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Integer -> Integer -> Integer
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
Int -> Decoder Bool
dumpInt Int
64

dump32 :: HasCallStack => Decoder Bool
dump32 :: HasCallStack => Decoder Bool
dump32 =  HasCallStack => Int -> Decoder Bool
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
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 <- X Atom -> Decoder Atom
forall a. X a -> Decoder a
inX (X Atom -> Decoder Atom) -> X Atom -> Decoder Atom
forall a b. (a -> b) -> a -> b
$ String -> X Atom
getAtom String
"UTF8_STRING"
  HasCallStack => Atom -> Decoder Bool -> Decoder Bool
Atom -> Decoder Bool -> Decoder Bool
guardType Atom
uTF8_STRING (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ Int -> Decoder Bool -> Decoder Bool -> Decoder Bool
forall a.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize'' Int
8 Decoder Bool
HasCallStack => Decoder Bool
propShortErr (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
    [CUChar]
s <- (DecodeState -> [CUChar]) -> Decoder [CUChar]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value
    (DecodeState -> DecodeState) -> Decoder ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DecodeState
r -> DecodeState
r {value = []})
    String -> Decoder Bool
append (String -> Decoder Bool)
-> ([CUChar] -> String) -> [CUChar] -> Decoder Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show (String -> String) -> ([CUChar] -> String) -> [CUChar] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> String
decode ([Word8] -> String) -> ([CUChar] -> [Word8]) -> [CUChar] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CUChar -> Word8) -> [CUChar] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map CUChar -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([CUChar] -> Decoder Bool) -> [CUChar] -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ [CUChar]
s
    Bool -> Decoder Bool
forall a. a -> Decoder a
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
Atom -> Decoder Bool -> Decoder Bool
guardType Atom
fmt (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$
                    Int -> (Integer -> String) -> Decoder Bool
getInt Int
32     ((Integer -> String) -> Decoder Bool)
-> (Integer -> String) -> Decoder Bool
forall a b. (a -> b) -> a -> b
$
                    \Integer
r -> case () of
                            () | Integer
r Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0                 -> String
"undefined value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
r
                               | Integer
r Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= [String] -> Integer
forall i a. Num i => [a] -> i
genericLength [String]
ss -> String
"undefined value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
r
                               | Bool
otherwise             -> [String] -> Integer -> String
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
Atom -> Decoder Bool -> Decoder Bool
guardType Atom
pIXMAP (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
                Maybe Integer
p' <- HasCallStack => Int -> Decoder (Maybe Integer)
Int -> Decoder (Maybe Integer)
getInt' Int
32
                case Maybe Integer
p' of
                  Maybe Integer
Nothing -> Bool -> Decoder Bool
forall a. a -> Decoder a
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 (String -> Decoder Bool) -> String -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String
"pixmap " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String -> String
forall a. Integral a => a -> String -> String
showHex Integer
p String
""
                    Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt)
g' <- X (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt))
-> Decoder
     (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt))
forall a. X a -> Decoder a
inX (X (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt))
 -> Decoder
      (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt)))
-> X (Maybe
        (Atom, Position, Position, Word32, Word32, Word32, CInt))
-> Decoder
     (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt))
forall a b. (a -> b) -> a -> b
$ (Display
 -> X (Maybe
         (Atom, Position, Position, Word32, Word32, Word32, CInt)))
-> X (Maybe
        (Atom, Position, Position, Word32, Word32, Word32, CInt))
forall a. (Display -> X a) -> X a
withDisplay ((Display
  -> X (Maybe
          (Atom, Position, Position, Word32, Word32, Word32, CInt)))
 -> X (Maybe
         (Atom, Position, Position, Word32, Word32, Word32, CInt)))
-> (Display
    -> X (Maybe
            (Atom, Position, Position, Word32, Word32, Word32, CInt)))
-> X (Maybe
        (Atom, Position, Position, Word32, Word32, Word32, CInt))
forall a b. (a -> b) -> a -> b
$ \Display
d -> IO (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt))
-> X (Maybe
        (Atom, Position, Position, Word32, Word32, Word32, CInt))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO
   (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt))
 -> X (Maybe
         (Atom, Position, Position, Word32, Word32, Word32, CInt)))
-> IO
     (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt))
-> X (Maybe
        (Atom, Position, Position, Word32, Word32, Word32, CInt))
forall a b. (a -> b) -> a -> b
$
                            ((Atom, Position, Position, Word32, Word32, Word32, CInt)
-> Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt)
forall a. a -> Maybe a
Just ((Atom, Position, Position, Word32, Word32, Word32, CInt)
 -> Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt))
-> IO (Atom, Position, Position, Word32, Word32, Word32, CInt)
-> IO
     (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt))
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 (Integer -> Atom
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
p))
                            IO (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt))
-> (SomeException
    -> IO
         (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt)))
-> IO
     (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch`
                            \SomeException
e -> case SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                                    Just ExitCode
x -> SomeException
-> IO
     (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt))
forall a e. Exception e => e -> a
throw SomeException
e IO (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt))
-> ExitCode
-> IO
     (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt))
forall a b. a -> b -> a
`const` (ExitCode
x ExitCode -> ExitCode -> ExitCode
forall a. a -> a -> a
`asTypeOf` ExitCode
ExitSuccess)
                                    Maybe ExitCode
_      -> Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt)
-> IO
     (Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Atom, Position, Position, Word32, Word32, Word32, CInt)
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 (String -> Decoder Bool) -> String -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                     [String
" ("
                                     ,Word32 -> String
forall a. Show a => a -> String
show Word32
wid
                                     ,Char
'x'Char -> String -> String
forall a. a -> [a] -> [a]
:Word32 -> String
forall a. Show a => a -> String
show Word32
ht
                                     ,Char
'x'Char -> String -> String
forall a. a -> [a] -> [a]
:CInt -> String
forall a. Show a => a -> String
show CInt
dp
                                     ,Char
')'Char -> String -> String
forall a. a -> [a] -> [a]
:if Word32
bw Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 then String
"" else Char
'+'Char -> String -> String
forall a. a -> [a] -> [a]
:Word32 -> String
forall a. Show a => a -> String
show Word32
bw
                                     ,String
"@("
                                     ,Position -> String
forall a. Show a => a -> String
show Position
x
                                     ,Char
','Char -> String -> String
forall a. a -> [a] -> [a]
:Position -> String
forall a. Show a => a -> String
show Position
y
                                     ,String
")"
                                     ]

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

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

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

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

dumpSize :: HasCallStack => Decoder Bool
dumpSize :: HasCallStack => Decoder Bool
dumpSize =  String -> Decoder Bool
append String
"(" Decoder Bool -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Decoder Bool
HasCallStack => Decoder Bool
dump32 Decoder Bool -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Decoder Bool
append String
"," Decoder Bool -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Decoder Bool
HasCallStack => Decoder Bool
dump32 Decoder Bool -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
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 = "
  Decoder Bool
HasCallStack => Decoder Bool
dump32
  String -> Decoder Bool
append String
"/"
  Decoder Bool
HasCallStack => Decoder Bool
dump32
  String -> Decoder Bool
append String
", max = "
  Decoder Bool
HasCallStack => Decoder Bool
dump32
  String -> Decoder Bool
append String
"/"
  Decoder Bool
HasCallStack => Decoder Bool
dump32

dumpGrav :: HasCallStack => Decoder Bool
dumpGrav :: HasCallStack => Decoder Bool
dumpGrav =  HasCallStack => [String] -> Decoder Bool
[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
[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 <- Decoder DecodeState
forall s (m :: * -> *). MonadState s m => m s
get
  Bool
rc <- Decoder Bool
item
  if Bool -> Bool
not Bool
rc then Bool -> Decoder Bool
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else do
    DecodeState
that <- Decoder DecodeState
forall s (m :: * -> *). MonadState s m => m s
get -- if none match then we just restore the value parse
    [CUChar]
vs <- (DecodeState -> [CUChar]) -> Decoder [CUChar]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value
    let w :: Int
w = ([CUChar] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DecodeState -> [CUChar]
value DecodeState
sp) Int -> Int -> Int
forall a. Num a => a -> a -> a
- [CUChar] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CUChar]
vs) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
    -- now we get to reparse again so we get our copy of it
    DecodeState -> Decoder ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put DecodeState
sp
    Integer
v <- (Maybe Integer -> Integer)
-> Decoder (Maybe Integer) -> Decoder Integer
forall a b. (a -> b) -> Decoder a -> Decoder b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Integer -> Integer
forall a. HasCallStack => Maybe a -> a
fromJust (HasCallStack => Int -> Decoder (Maybe Integer)
Int -> Decoder (Maybe Integer)
getInt' Int
w)
    -- and after all that, we can process the exception list
    HasCallStack =>
[(Integer, String)] -> DecodeState -> Integer -> Decoder Bool
[(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
_                =  DecodeState -> Decoder ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put DecodeState
that Decoder () -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Decoder Bool
forall a. a -> Decoder a
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 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
val =  String -> Decoder Bool
append String
str
                                    | Bool
otherwise  =  HasCallStack =>
[(Integer, String)] -> DecodeState -> Integer -> Decoder Bool
[(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
Atom -> Decoder Bool -> Decoder Bool
guardType Atom
cARDINAL (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
             Maybe Integer
n <- HasCallStack => Int -> Decoder (Maybe Integer)
Int -> Decoder (Maybe Integer)
getInt' Int
32
             case Maybe Integer
n of
               Maybe Integer
Nothing   -> Bool -> Decoder Bool
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
               Just Integer
pid' -> do
                      let pid :: String
pid = Integer -> String
forall a. Show a => a -> String
show Integer
pid'
                          ps :: CreateProcess
ps  = (String -> [String] -> CreateProcess
proc String
"/bin/ps" [String
"-fp" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pid]) {std_out = CreatePipe}
                      (Maybe Handle
_,Maybe Handle
o,Maybe Handle
_,ProcessHandle
_) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> Decoder
     (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> Decoder
      (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> Decoder
     (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
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 (String -> Decoder Bool) -> String -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String
"pid " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pid
                        Just Handle
p' -> do
                                  [String]
prc <- IO [String] -> Decoder [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [String] -> Decoder [String])
-> IO [String] -> Decoder [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
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 (String -> Decoder Bool) -> String -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ if [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
prc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
                                           then String
"pid " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pid
                                           else [String]
prc [String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!! Int
1

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

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

dumpMotifDragReceiver :: HasCallStack => Decoder Bool
dumpMotifDragReceiver :: HasCallStack => Decoder Bool
dumpMotifDragReceiver =  do
  Atom
ta <- X Atom -> Decoder Atom
forall a. X a -> Decoder a
inX (X Atom -> Decoder Atom) -> X Atom -> Decoder Atom
forall a b. (a -> b) -> a -> b
$ String -> X Atom
getAtom String
"_MOTIF_DRAG_RECEIVER_INFO"
  HasCallStack => Atom -> Decoder Bool -> Decoder Bool
Atom -> Decoder Bool -> Decoder Bool
guardType Atom
ta (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ HasCallStack => [(String, Decoder Bool, Atom)] -> Decoder Bool
[(String, Decoder Bool, Atom)] -> Decoder Bool
dumpList' [(String
"endian"    ,Decoder Bool
HasCallStack => Decoder Bool
dumpMotifEndian,Atom
cARDINAL)
                           ,(String
"version"   ,Decoder Bool
HasCallStack => Decoder Bool
dump8          ,Atom
cARDINAL)
                           ,(String
"style"     ,Decoder Bool
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)
Int -> Decoder (Maybe Integer)
getInt' Int
8
  HasCallStack => Int -> Decoder Bool -> Decoder Bool
Int -> Decoder Bool -> Decoder Bool
pad Int
1 (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ case Maybe Integer
d of
            Maybe Integer
Nothing             -> HasCallStack => Int -> Decoder Bool
Int -> Decoder Bool
propShortErr' Int
9
            Just Integer
ps | Integer
ps Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0   -> HasCallStack => Int -> Decoder Bool -> Decoder Bool
Int -> Decoder Bool -> Decoder Bool
pad Int
12 (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
append String
"none"
                    | Integer
ps Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1   -> HasCallStack => Int -> Decoder Bool -> Decoder Bool
Int -> Decoder Bool -> Decoder Bool
pad Int
12 (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
append String
"drop only"
                    | Integer
ps Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
2   ->          String -> Decoder Bool
append String
"prefer preregister " Decoder Bool -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Decoder Bool
HasCallStack => Decoder Bool
dumpMDPrereg
                    | Integer
ps Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
3   ->          String -> Decoder Bool
append String
"preregister "        Decoder Bool -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Decoder Bool
HasCallStack => Decoder Bool
dumpMDPrereg
                    | Integer
ps Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
4   -> HasCallStack => Int -> Decoder Bool -> Decoder Bool
Int -> Decoder Bool -> Decoder Bool
pad Int
12 (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
append String
"prefer dynamic"
                    | Integer
ps Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
5   -> HasCallStack => Int -> Decoder Bool -> Decoder Bool
Int -> Decoder Bool -> Decoder Bool
pad Int
12 (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
append String
"dynamic"
                    | Integer
ps Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
6   -> HasCallStack => Int -> Decoder Bool -> Decoder Bool
Int -> Decoder Bool -> Decoder Bool
pad Int
12 (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
append String
"prefer receiver"
                    | Bool
otherwise -> HasCallStack => String -> Decoder Bool
String -> Decoder Bool
failure (String -> Decoder Bool) -> String -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String
"unknown drop style " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
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 = "
  Int -> Decoder Bool -> Decoder Bool
forall a. Int -> Decoder a -> Decoder a
withIndent Int
15 Decoder Bool
HasCallStack => Decoder Bool
dumpWindow
  String -> Decoder Bool
append String
","
  String -> Decoder Bool
append String
"drop sites = "
  Maybe Integer
dsc' <- HasCallStack => Int -> Decoder (Maybe Integer)
Int -> Decoder (Maybe Integer)
getInt' Int
16
  case Maybe Integer
dsc' of
    Maybe Integer
Nothing  -> HasCallStack => Int -> Decoder Bool
Int -> Decoder Bool
propShortErr' Int
10
    Just Integer
dsc -> do
      Int -> Decoder Bool -> Decoder Bool
forall a. Int -> Decoder a -> Decoder a
withIndent Int
13 (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String -> Decoder Bool
append (Integer -> String
forall a. Show a => a -> String
show Integer
dsc)
      HasCallStack => Int -> Decoder Bool -> Decoder Bool
Int -> Decoder Bool -> Decoder Bool
pad Int
2 (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
        String -> Decoder Bool
append String
","
        String -> Decoder Bool
append String
"total size = "
        Int -> Decoder Bool -> Decoder Bool
forall a. Int -> Decoder a -> Decoder a
withIndent Int
13 Decoder Bool
HasCallStack => Decoder Bool
dump32
        Int -> Decoder Bool
dumpMDBlocks (Int -> Decoder Bool) -> Int -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ Integer -> Int
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
Atom -> Decoder Bool -> Decoder Bool
guardType Atom
cARDINAL (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ HasCallStack => Int -> Decoder Bool -> Decoder Bool
Int -> Decoder Bool -> Decoder Bool
guardSize Int
8 (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
  String
c <- (CUChar -> Char) -> [CUChar] -> String
forall a b. (a -> b) -> [a] -> [b]
map CUChar -> Char
forall a b. (Enum a, Enum b) => a -> b
twiddle ([CUChar] -> String) -> Decoder [CUChar] -> Decoder String
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
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 <- (DecodeState -> [CUChar]) -> Decoder [CUChar]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value
  if [CUChar] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CUChar]
vs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n
    then HasCallStack => Int -> Decoder Bool
Int -> Decoder Bool
propShortErr' Int
11
    else (DecodeState -> DecodeState) -> Decoder ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DecodeState
r -> DecodeState
r {value = drop n vs}) Decoder () -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
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
Atom -> Decoder Bool -> Decoder Bool
guardType Atom
cARDINAL (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
                 Maybe Integer
n <- HasCallStack => Int -> Decoder (Maybe Integer)
Int -> Decoder (Maybe Integer)
getInt' Int
32
                 case Maybe Integer
n of
                   Maybe Integer
Nothing -> Bool -> Decoder Bool
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                   Just Integer
n' ->
                       let pct :: Double
pct = Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n' Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Word32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
forall a. Bounded a => a
maxBound :: Word32)
                           pct :: Double
                        in String -> Decoder Bool
append (String -> Decoder Bool) -> String -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
pct :: Integer) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"%"

dumpWmHints :: HasCallStack => Decoder Bool
dumpWmHints :: HasCallStack => Decoder Bool
dumpWmHints =
  HasCallStack => Atom -> Decoder Bool -> Decoder Bool
Atom -> Decoder Bool -> Decoder Bool
guardType Atom
wM_HINTS (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
  Maybe Integer
msk <- HasCallStack => Int -> Decoder (Maybe Integer)
Int -> Decoder (Maybe Integer)
getInt' Int
32
  case Maybe Integer
msk of
    Maybe Integer
Nothing   -> Bool -> Decoder Bool
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Just Integer
msk' -> HasCallStack =>
CULong -> [(String, Decoder Bool, Atom)] -> Decoder Bool
CULong -> [(String, Decoder Bool, Atom)] -> Decoder Bool
dumpListByMask' (Integer -> CULong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
msk')
                                 [(String
"input"        ,HasCallStack => [String] -> Decoder Bool
[String] -> Decoder Bool
dumpEnum [String]
bool   ,Atom
cARDINAL)
                                 ,(String
"initial_state",HasCallStack => [String] -> Decoder Bool
[String] -> Decoder Bool
dumpEnum [String]
wmState,Atom
cARDINAL)
                                 ,(String
"icon_pixmap"  ,Decoder Bool
HasCallStack => Decoder Bool
dumpPixmap      ,Atom
pIXMAP  )
                                 ,(String
"icon_window"  ,Decoder Bool
HasCallStack => Decoder Bool
dumpWindow      ,Atom
wINDOW  )
                                 ,(String
"icon_x"       ,Decoder Bool
HasCallStack => Decoder Bool
dump32          ,Atom
cARDINAL)
                                 ,(String
"icon_y"       ,Decoder Bool
HasCallStack => Decoder Bool
dump32          ,Atom
cARDINAL)
                                 ,(String
"icon_mask"    ,Decoder Bool
HasCallStack => Decoder Bool
dumpPixmap      ,Atom
pIXMAP  )
                                 ,(String
"window_group" ,Decoder Bool
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
Atom -> Decoder Bool -> Decoder Bool
guardType Atom
cARDINAL (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
                 Maybe Integer
n <- HasCallStack => Int -> Decoder (Maybe Integer)
Int -> Decoder (Maybe Integer)
getInt' Int
32
                 case Maybe Integer
n of
                   Maybe Integer
Nothing -> Bool -> Decoder Bool
forall a. a -> Decoder a
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 (Integer -> Int
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Bool -> Decoder Bool
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else String -> Decoder Bool
append (String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
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 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
        then String -> Decoder Bool
append (String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) Decoder Bool -> Decoder String -> Decoder String
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Decoder String
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"|"
        else String -> Decoder String
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return String
p
  [String] -> Int -> Int -> String -> Decoder Bool
dumpBits' [String]
ss (Int
b Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
1) (Int
n Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int -> Int
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 (String -> Maybe String
forall a. a -> Maybe a
Just String
"ORIENTATION") [String
"HORZ",String
"VERT"]

nwmOrigin :: [String]
nwmOrigin :: [String]
nwmOrigin =  Maybe String -> [String] -> [String]
nwmEnum Maybe String
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 =  (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ( String
"_NET_WM_"                   String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
vs
nwmEnum (Just String
prefix) [String]
vs =  (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"_NET_WM_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_") String -> String -> 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 =  (Decode -> Int)
-> Int
-> (Int -> Int -> Decoder (Maybe Integer))
-> Decoder (Maybe Integer)
-> Decoder (Maybe Integer)
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 Decoder Bool -> Decoder (Maybe Integer) -> Decoder (Maybe Integer)
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Integer -> Decoder (Maybe Integer)
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing) (Decoder (Maybe Integer) -> Decoder (Maybe Integer))
-> Decoder (Maybe Integer) -> Decoder (Maybe Integer)
forall a b. (a -> b) -> a -> b
$
              Int
-> Decoder (Maybe Integer)
-> Decoder (Maybe Integer)
-> Decoder (Maybe Integer)
forall a.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize' Int
8 (Decoder Bool
HasCallStack => Decoder Bool
propShortErr Decoder Bool -> Decoder (Maybe Integer) -> Decoder (Maybe Integer)
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Integer -> Decoder (Maybe Integer)
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing) (Decoder (Maybe Integer) -> Decoder (Maybe Integer))
-> Decoder (Maybe Integer) -> Decoder (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ do
                Integer
lo <- Int -> Decoder Integer
inhale Int
32
                Integer
hi <- Int -> Decoder Integer
inhale Int
32
                Maybe Integer -> Decoder (Maybe Integer)
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Integer -> Decoder (Maybe Integer))
-> Maybe Integer -> Decoder (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
lo Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
hi Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
forall a. Bounded a => a
maxBound :: Word32) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)
getInt' Int
w  =  (Decode -> Int)
-> Int
-> (Int -> Int -> Decoder (Maybe Integer))
-> Decoder (Maybe Integer)
-> Decoder (Maybe Integer)
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 Decoder Bool -> Decoder (Maybe Integer) -> Decoder (Maybe Integer)
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Integer -> Decoder (Maybe Integer)
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing) (Decoder (Maybe Integer) -> Decoder (Maybe Integer))
-> Decoder (Maybe Integer) -> Decoder (Maybe Integer)
forall a b. (a -> b) -> a -> b
$
              Int
-> Decoder (Maybe Integer)
-> Decoder (Maybe Integer)
-> Decoder (Maybe Integer)
forall a.
HasCallStack =>
Int -> Decoder a -> Decoder a -> Decoder a
guardSize' (Int -> Int
bytes Int
w) (HasCallStack => Int -> Decoder Bool
Int -> Decoder Bool
propShortErr' Int
13 Decoder Bool -> Decoder (Maybe Integer) -> Decoder (Maybe Integer)
forall a b. Decoder a -> Decoder b -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Integer -> Decoder (Maybe Integer)
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing)       (Decoder (Maybe Integer) -> Decoder (Maybe Integer))
-> Decoder (Maybe Integer) -> Decoder (Maybe Integer)
forall a b. (a -> b) -> a -> b
$
              Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> Decoder Integer -> Decoder (Maybe Integer)
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)
Int -> Decoder (Maybe Integer)
getInt' Int
w Decoder (Maybe Integer)
-> (Maybe Integer -> Decoder Bool) -> Decoder Bool
forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Decoder Bool
-> (Integer -> Decoder Bool) -> Maybe Integer -> Decoder Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> Decoder Bool
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (String -> Decoder Bool
append (String -> Decoder Bool)
-> (Integer -> String) -> Integer -> Decoder Bool
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
               Integer -> Decoder Integer
forall a. a -> Decoder a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Decoder Integer) -> Integer -> Decoder Integer
forall a b. (a -> b) -> a -> b
$ CUChar -> Integer
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
               IO Integer -> Decoder Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Integer -> Decoder Integer) -> IO Integer -> Decoder Integer
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr CUChar -> IO Integer) -> IO Integer
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
2 ((Ptr CUChar -> IO Integer) -> IO Integer)
-> (Ptr CUChar -> IO Integer) -> IO Integer
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
p -> do
                 Ptr CUChar -> [CUChar] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr CUChar
p [CUChar
b0,CUChar
b1]
                 [Word16
v] <- Int -> Ptr Word16 -> IO [Word16]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
1 (Ptr CUChar -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr Ptr CUChar
p :: Ptr Word16)
                 Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> IO Integer) -> Integer -> IO Integer
forall a b. (a -> b) -> a -> b
$ Word16 -> Integer
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
               IO Integer -> Decoder Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Integer -> Decoder Integer) -> IO Integer -> Decoder Integer
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr CUChar -> IO Integer) -> IO Integer
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
4 ((Ptr CUChar -> IO Integer) -> IO Integer)
-> (Ptr CUChar -> IO Integer) -> IO Integer
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
p -> do
                 Ptr CUChar -> [CUChar] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr CUChar
p [CUChar
b0,CUChar
b1,CUChar
b2,CUChar
b3]
                 [Word32
v] <- Int -> Ptr Word32 -> IO [Word32]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
1 (Ptr CUChar -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr Ptr CUChar
p :: Ptr Word32)
                 Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> IO Integer) -> Integer -> IO Integer
forall a b. (a -> b) -> a -> b
$ Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
v
inhale  Int
b =  String -> Decoder Integer
forall a. HasCallStack => String -> a
error (String -> Decoder Integer) -> String -> Decoder Integer
forall a b. (a -> b) -> a -> b
$ String
"inhale " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
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) <- (DecodeState -> ([CUChar], [CUChar]))
-> Decoder ([CUChar], [CUChar])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Int -> [CUChar] -> ([CUChar], [CUChar])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n ([CUChar] -> ([CUChar], [CUChar]))
-> (DecodeState -> [CUChar]) -> DecodeState -> ([CUChar], [CUChar])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeState -> [CUChar]
value)
  (DecodeState -> DecodeState) -> Decoder ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DecodeState
r -> DecodeState
r {value = rest})
  [CUChar] -> Decoder [CUChar]
forall a. a -> Decoder a
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 (String -> Decoder Bool)
-> (String -> String) -> String -> Decoder Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack)

-- common appender
append'     :: Bool -> String -> Decoder Bool
append' :: Bool -> String -> Decoder Bool
append' Bool
b String
s =  do
  String
j <- (DecodeState -> String) -> Decoder String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> String
joint
  (DecodeState -> DecodeState) -> Decoder ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DecodeState
r -> DecodeState
r {accum = accum r ++ j ++ s})
  Bool -> Decoder Bool
forall a. a -> Decoder a
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 =  (DecodeState -> DecodeState) -> Decoder ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DecodeState
r -> DecodeState
r {value = []}) Decoder () -> Decoder Bool -> Decoder Bool
forall a b. Decoder a -> Decoder b -> Decoder b
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
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
String -> Decoder Bool
failure (String -> Decoder Bool) -> String -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String
"(short prop " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
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
String -> Decoder Bool
failure (String -> Decoder Bool) -> String -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String
"(bad bit width " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                             Int -> String
forall a. Show a => a -> String
show Int
a            String -> String -> String
forall a. [a] -> [a] -> [a]
++
                             String
"; expected "     String -> String -> String
forall a. [a] -> [a] -> [a]
++
                             Int -> String
forall a. Show a => a -> String
show Int
e            String -> String -> String
forall a. [a] -> [a] -> [a]
++
                             String
")"

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

-- for stubs
(...) :: Decoder Bool
... :: Decoder Bool
(...) =  do
  String
fmt <- (Decode -> Atom) -> Decoder Atom
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Atom
pType Decoder Atom -> (Atom -> Decoder String) -> Decoder String
forall a b. Decoder a -> (a -> Decoder b) -> Decoder b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= X String -> Decoder String
forall a. X a -> Decoder a
inX (X String -> Decoder String)
-> (Atom -> X String) -> Atom -> Decoder String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Atom -> X String
atomName
  String -> Decoder Bool
propSimple (String -> Decoder Bool) -> String -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ String
"(unimplemented type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fmt String -> String -> String
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 =  Int -> b
forall a. Enum a => Int -> a
toEnum (Int -> b) -> (a -> Int) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
fromEnum