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

module XMonad.Hooks.DebugEvents (debugEventsHook) where

import           Prelude

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

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

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

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

-- | Event hook to dump all received events.  You should probably not use this
--   unconditionally; it will produce massive amounts of output.
debugEventsHook   :: Event -> X All
debugEventsHook :: Event -> X All
debugEventsHook Event
e =  Event -> X ()
debugEventsHook' Event
e X () -> X All -> X All
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> All -> X All
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 -> Window
ev_window       = Window
w
                                      ,ev_parent :: Event -> Window
ev_parent       = Window
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 -> Window
ev_above        = Window
above
                                      ,ev_detail :: Event -> CInt
ev_detail       = CInt
place
                                      ,ev_value_mask :: Event -> CULong
ev_value_mask   = CULong
msk
                                      } = do
  String -> Window -> X ()
windowEvent String
"ConfigureRequest" Window
w
  String -> Window -> X ()
windowEvent String
"  parent"         Window
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.
(Storable i, Integral i) =>
[i] -> Decoder Bool -> X String
quickFormat [CInt
x,CInt
y,CInt
wid,CInt
ht,CInt
bw,Window -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Window
above,CInt
place] (Decoder Bool -> X String) -> Decoder Bool -> X String
forall a b. (a -> b) -> a -> b
$
       CULong -> [(String, Decoder Bool, Window)] -> Decoder Bool
dumpListByMask' CULong
msk [(String
"x"           ,Decoder Bool
dump32              ,Window
cARDINAL)
                           ,(String
"y"           ,Decoder Bool
dump32              ,Window
cARDINAL)
                           ,(String
"width"       ,Decoder Bool
dump32              ,Window
cARDINAL)
                           ,(String
"height"      ,Decoder Bool
dump32              ,Window
cARDINAL)
                           ,(String
"border_width",Decoder Bool
dump32              ,Window
cARDINAL)
                           ,(String
"sibling"     ,Decoder Bool
dumpWindow          ,Window
wINDOW  )
                           ,(String
"detail"      ,[String] -> Decoder Bool
dumpEnum [String]
wmPlacement,Window
cARDINAL)
                           ]
  String -> String -> X ()
say String
"  requested" String
s

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

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

debugEventsHook' e :: Event
e@KeyEvent {ev_event_type :: Event -> EventType
ev_event_type = EventType
t}
    | EventType
t EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  Event -> X All
debugKeyEvents Event
e X All -> X () -> X ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

debugEventsHook' ButtonEvent           {ev_window :: Event -> Window
ev_window = Window
w
                                       ,ev_state :: Event -> KeyMask
ev_state  = KeyMask
s
                                       ,ev_button :: Event -> EventType
ev_button = EventType
b
                                       } = do
  String -> Window -> X ()
windowEvent String
"Button" Window
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
vmask KeyMask
nl KeyMask
s
  String -> String -> X ()
say String
"  button" (String -> X ()) -> String -> X ()
forall a b. (a -> b) -> a -> b
$ EventType -> String
forall a. Show a => a -> String
show EventType
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msk

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

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

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

{- way too much output; suppressed.

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

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

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

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

-- | Emit information about an atom.
atomName   :: Atom -> X String
atomName :: Window -> X String
atomName Window
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]
++ Window -> String
forall a. Show a => a -> String
show Window
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 -> Window -> IO (Maybe String)
getAtomName Display
d Window
a

-- | Emit an atom with respect to the current event.
atomEvent     :: String -> Atom -> X ()
atomEvent :: String -> Window -> X ()
atomEvent String
l Window
a =  Window -> X String
atomName Window
a X String -> (String -> X ()) -> X ()
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 -> Window -> X ()
windowEvent String
l Window
w =  Window -> X String
debugWindow Window
w X String -> (String -> X ()) -> X ()
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 ()
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 (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))
                  ]

-- | Convert a modifier mask into a useful string
vmask                 :: KeyMask -> KeyMask -> String
vmask :: KeyMask -> KeyMask -> String
vmask KeyMask
numLockMask KeyMask
msk =  [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                         [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
                         ([String], KeyMask) -> [String]
forall a b. (a, b) -> a
fst     (([String], KeyMask) -> [String])
-> ([String], KeyMask) -> [String]
forall a b. (a -> b) -> a -> b
$
                         ((KeyMask, String) -> ([String], KeyMask) -> ([String], KeyMask))
-> ([String], KeyMask)
-> [(KeyMask, String)]
-> ([String], KeyMask)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (KeyMask, String) -> ([String], KeyMask) -> ([String], KeyMask)
forall a a. (Num a, Bits a) => (a, a) -> ([a], a) -> ([a], a)
vmask' ([],KeyMask
msk) [(KeyMask, String)]
masks
    where
      masks :: [(KeyMask, String)]
masks = (KeyMask -> (KeyMask, String)) -> [KeyMask] -> [(KeyMask, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\KeyMask
m -> (KeyMask
m,KeyMask -> String
forall a. Show a => a -> String
show KeyMask
m)) [KeyMask
0..Int -> KeyMask
forall a. Enum a => Int -> a
toEnum (KeyMask -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize KeyMask
msk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)] [(KeyMask, String)] -> [(KeyMask, String)] -> [(KeyMask, String)]
forall a. [a] -> [a] -> [a]
++
              [(KeyMask
numLockMask,String
"num"  )
              ,(   KeyMask
lockMask,String
"lock" )
              ,(KeyMask
controlMask,String
"ctrl" )
              ,(  KeyMask
shiftMask,String
"shift")
              ,(   KeyMask
mod5Mask,String
"mod5" )
              ,(   KeyMask
mod4Mask,String
"mod4" )
              ,(   KeyMask
mod3Mask,String
"mod3" )
              ,(   KeyMask
mod2Mask,String
"mod2" )
              ,(   KeyMask
mod1Mask,String
"mod1" )
              ]
      vmask' :: (a, a) -> ([a], a) -> ([a], a)
vmask'   (a, a)
_   a :: ([a], a)
a@( [a]
_,a
0)                = ([a], a)
a
      vmask' (a
m,a
s)   ([a]
ss,a
v) | a
v a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
m a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
m = (a
s a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ss,a
v a -> a -> a
forall a. Bits a => a -> a -> a
.&. a -> a
forall a. Bits a => a -> a
complement a
m)
      vmask'   (a, a)
_        ([a], a)
r                  = ([a], a)
r

-- formatting properties.  ick. --

-- @@@ Document the parser.  Someday.

type Raw     = [CUChar]

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

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

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

-- | Retrive, parse, and dump a window property.  As all the high-level property
--   interfaces lose information necessary to decode properties correctly, we
--   work at the lowest level available.
dumpProperty          :: Atom -> String -> Window -> Int -> X String
dumpProperty :: Window -> String -> Window -> Int -> X String
dumpProperty Window
a String
n Window
w Int
i  =  do
  Either String (Window, Int, CULong, [CUChar])
prop <- (Display -> X (Either String (Window, Int, CULong, [CUChar])))
-> X (Either String (Window, Int, CULong, [CUChar]))
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X (Either String (Window, Int, CULong, [CUChar])))
 -> X (Either String (Window, Int, CULong, [CUChar])))
-> (Display -> X (Either String (Window, Int, CULong, [CUChar])))
-> X (Either String (Window, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$ \Display
d ->
    IO (Either String (Window, Int, CULong, [CUChar]))
-> X (Either String (Window, Int, CULong, [CUChar]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io     (IO (Either String (Window, Int, CULong, [CUChar]))
 -> X (Either String (Window, Int, CULong, [CUChar])))
-> IO (Either String (Window, Int, CULong, [CUChar]))
-> X (Either String (Window, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$
    (Ptr Window -> IO (Either String (Window, Int, CULong, [CUChar])))
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Window -> IO (Either String (Window, Int, CULong, [CUChar])))
 -> IO (Either String (Window, Int, CULong, [CUChar])))
-> (Ptr Window
    -> IO (Either String (Window, Int, CULong, [CUChar])))
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$ \Ptr Window
fmtp ->
    (Ptr CInt -> IO (Either String (Window, Int, CULong, [CUChar])))
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO (Either String (Window, Int, CULong, [CUChar])))
 -> IO (Either String (Window, Int, CULong, [CUChar])))
-> (Ptr CInt -> IO (Either String (Window, Int, CULong, [CUChar])))
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
szp  ->
    (Ptr CULong -> IO (Either String (Window, Int, CULong, [CUChar])))
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CULong -> IO (Either String (Window, Int, CULong, [CUChar])))
 -> IO (Either String (Window, Int, CULong, [CUChar])))
-> (Ptr CULong
    -> IO (Either String (Window, Int, CULong, [CUChar])))
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$ \Ptr CULong
lenp ->
    (Ptr CULong -> IO (Either String (Window, Int, CULong, [CUChar])))
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CULong -> IO (Either String (Window, Int, CULong, [CUChar])))
 -> IO (Either String (Window, Int, CULong, [CUChar])))
-> (Ptr CULong
    -> IO (Either String (Window, Int, CULong, [CUChar])))
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$ \Ptr CULong
ackp ->
    (Ptr (Ptr CUChar)
 -> IO (Either String (Window, Int, CULong, [CUChar])))
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr CUChar)
  -> IO (Either String (Window, Int, CULong, [CUChar])))
 -> IO (Either String (Window, Int, CULong, [CUChar])))
-> (Ptr (Ptr CUChar)
    -> IO (Either String (Window, Int, CULong, [CUChar])))
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CUChar)
vsp  -> do
    CInt
rc   <- Display
-> Window
-> Window
-> CLong
-> CLong
-> Bool
-> Window
-> Ptr Window
-> Ptr CInt
-> Ptr CULong
-> Ptr CULong
-> Ptr (Ptr CUChar)
-> IO CInt
xGetWindowProperty
              Display
d
              Window
w
              Window
a
              CLong
0
              CLong
forall a. Bounded a => a
maxBound
              Bool
False
              Window
anyPropertyType
              Ptr Window
fmtp
              Ptr CInt
szp
              Ptr CULong
lenp
              Ptr CULong
ackp
              Ptr (Ptr CUChar)
vsp
    case CInt
rc of
      CInt
0 -> do
        Window
fmt <- Window -> Window
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Window -> Window) -> IO Window -> IO Window
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Window -> IO Window
forall a. Storable a => Ptr a -> IO a
peek Ptr Window
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
          () | Window
fmt Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
none     -> Ptr CUChar -> IO CInt
forall a. Ptr a -> IO CInt
xFree Ptr CUChar
vs' IO CInt
-> IO (Either String (Window, Int, CULong, [CUChar]))
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either String (Window, Int, CULong, [CUChar])
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String (Window, 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 (Window, Int, CULong, [CUChar]))
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either String (Window, Int, CULong, [CUChar])
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String (Window, Int, CULong, [CUChar])
forall a b. a -> Either a b
Left (String -> Either String (Window, Int, CULong, [CUChar]))
-> String -> Either String (Window, 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 (Window, Int, CULong, [CUChar]))
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either String (Window, Int, CULong, [CUChar])
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String (Window, Int, CULong, [CUChar])
forall a b. a -> Either a b
Left (String -> Either String (Window, Int, CULong, [CUChar]))
-> String -> Either String (Window, 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 (Window, Int, CULong, [CUChar])
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Window, Int, CULong, [CUChar])
 -> IO (Either String (Window, Int, CULong, [CUChar])))
-> Either String (Window, Int, CULong, [CUChar])
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$ (Window, Int, CULong, [CUChar])
-> Either String (Window, Int, CULong, [CUChar])
forall a b. b -> Either a b
Right (Window
fmt,Int
sz,CULong
ack,[CUChar]
vs)
      CInt
e -> Either String (Window, Int, CULong, [CUChar])
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Window, Int, CULong, [CUChar])
 -> IO (Either String (Window, Int, CULong, [CUChar])))
-> Either String (Window, Int, CULong, [CUChar])
-> IO (Either String (Window, Int, CULong, [CUChar]))
forall a b. (a -> b) -> a -> b
$ String -> Either String (Window, Int, CULong, [CUChar])
forall a b. a -> Either a b
Left (String -> Either String (Window, Int, CULong, [CUChar]))
-> String -> Either String (Window, 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 (Window, Int, CULong, [CUChar])
prop of
    Left  String
_               -> String -> X String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
    Right (Window
fmt,Int
sz,CULong
ack,[CUChar]
vs) -> Window
-> Window
-> String
-> Window
-> Int
-> [CUChar]
-> CULong
-> Int
-> X String
dumpProperty' Window
w Window
a String
n Window
fmt Int
sz [CUChar]
vs CULong
ack Int
i

-- @@@ am I better off passing in the Decode and DecodeState?
-- | Parse and dump a property (or a 'ClientMessage').
dumpProperty'                             :: Window -- source window
                                          -> Atom   -- property id
                                          -> String -- property name
                                          -> Atom   -- property type
                                          -> Int    -- bit width
                                          -> Raw    -- raw value
                                          -> CULong -- size of un-dumped content
                                          -> Int    -- indent for output formatting
                                          -> X String
dumpProperty' :: Window
-> Window
-> String
-> Window
-> Int
-> [CUChar]
-> CULong
-> Int
-> X String
dumpProperty' Window
w Window
a String
n Window
fmt Int
sz [CUChar]
vs CULong
ack Int
i =  do
  String
ptn <- Window -> X String
atomName Window
fmt
  let dec :: Decode
dec  = Decode :: Window -> String -> Window -> Int -> Window -> Int -> Int -> Decode
Decode {property :: Window
property = Window
a
                    ,pName :: String
pName    = String
n
                    ,pType :: Window
pType    = Window
fmt
                    ,width :: Int
width    = Int
sz
                    ,indent :: Int
indent   = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> 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 :: Window
window   = Window
w
                    ,limit :: Int
limit    = Int
96
                    }
      dec' :: Decode
dec' = Decode
dec    {pType :: Window
pType    = Window
cARDINAL
                    ,width :: Int
width    = Int
8
                    }
      ds :: DecodeState
ds   = DecS :: [CUChar] -> String -> String -> DecodeState
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
$ Window -> String -> Decoder Bool
dumpProp Window
a String
n
  let fin :: Int
fin = [CUChar] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DecodeState -> [CUChar]
value DecodeState
ds')
      len :: Int
len = [CUChar] -> 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 (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
$ Decoder Bool -> Decoder Bool
dumpArray 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 (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 (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     :: (Storable i, Integral i) => [i] -> Decoder Bool -> X String
quickFormat :: [i] -> Decoder Bool -> X String
quickFormat [i]
v Decoder Bool
f =  do
  let vl :: Int
vl = [i] -> 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 (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 :: Window -> String -> Window -> Int -> Window -> Int -> Int -> Decode
Decode {property :: Window
property = Window
none
                   ,pName :: String
pName    = String
""
                   ,pType :: Window
pType    = Window
cARDINAL
                   ,width :: Int
width    = Int
32
                   ,indent :: Int
indent   = Int
0
                   ,window :: Window
window   = Window
none
                   ,limit :: Int
limit    = Int
forall a. Bounded a => a
maxBound
                   }
      ds :: DecodeState
ds  = DecS :: [CUChar] -> String -> String -> DecodeState
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 (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                                              :: Atom -> String -> Decoder Bool

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

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

-- lift an X into a Decoder
inX :: X a -> Decoder a
inX :: 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 (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 (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 (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 :: Int -> Decoder a -> Decoder a
withIndent Int
w =  (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 :: Int
indent = Decode -> Int
indent Decode
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w})

-- dump an array of items.  this dumps the entire property
dumpArray      :: Decoder Bool -> Decoder Bool
dumpArray :: Decoder Bool -> Decoder Bool
dumpArray Decoder Bool
item =  do
  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 (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
"" (Decoder Bool -> String -> Decoder Bool
dumpArray' Decoder Bool
item String
"")

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

-- keep parsing until a parse step fails
-- @@@ which points out that all my uses of @whenX (return ...)@ are actually 'when',
--     which suggests that 'whenX' is *also* the same function... yep.  ISAGN
whenD     :: Monad m => m Bool -> m Bool -> m Bool
whenD :: m Bool -> m Bool -> m Bool
whenD m Bool
p m Bool
f =  m Bool
p m Bool -> (Bool -> m Bool) -> m Bool
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 (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- verify a decoder parameter, else call error reporter
-- once again, it's more general than I originally wrote
guardR                  :: (MonadReader r m, Eq v)
                        => (r -> v)                -- value selector
                        -> v                       -- expected value
                        -> (v -> v -> m a)         -- error reporter
                        -> m a                     -- continuation (hush)
                        -> m a
guardR :: (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       :: Bool -> a -> a -> a
fi :: Bool -> a -> a -> a
fi Bool
p a
n a
y =  if Bool
p then a
y else a
n -- flip (if' p), if that existed

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

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

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

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

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

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

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

dumpList''                    :: CULong -> [(String,Decoder Bool,Atom)] -> String -> Decoder Bool
dumpList'' :: CULong
-> [(String, Decoder Bool, Window)] -> String -> Decoder Bool
dumpList'' CULong
_ []           String
_   =  String -> Decoder Bool
append String
")" Decoder Bool -> Decoder Bool -> Decoder Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Decoder Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
dumpList'' CULong
0 [(String, Decoder Bool, Window)]
_            String
_   =  String -> Decoder Bool
append String
")" Decoder Bool -> Decoder Bool -> Decoder Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Decoder Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
dumpList'' CULong
m ((String
l,Decoder Bool
p,Window
t):[(String, Decoder Bool, Window)]
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 r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Decode
r -> Decode
r {pType :: Window
pType = Window
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 :: [CUChar]
value = [CUChar]
v'}
                (Bool, String) -> Decoder (Bool, String)
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 r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Decode
r -> Decode
r {pType :: Window
pType  = Window
t
                                      ,indent :: Int
indent = Decode -> Int
indent Decode
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
label
                                      })
                             Decoder Bool
p
                (Bool, String) -> Decoder (Bool, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
e,String
",")
  if Bool
e then CULong
-> [(String, Decoder Bool, Window)] -> String -> Decoder Bool
dumpList'' (CULong
m CULong -> Int -> CULong
forall a. Bits a => a -> Int -> a
`shiftR` Int
1) [(String, Decoder Bool, Window)]
ps String
sep' else Bool -> Decoder Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
e

-- do the getTextProperty dance, the hard way.
-- @@@ @COMPOUND_TEXT@ not supported yet.
dumpString :: Decoder Bool
dumpString :: Decoder Bool
dumpString =  do
  Window
fmt <- (Decode -> Window) -> Decoder Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Window
pType
  [Window
cOMPOUND_TEXT,Window
uTF8_STRING] <- X [Window] -> Decoder [Window]
forall a. X a -> Decoder a
inX (X [Window] -> Decoder [Window]) -> X [Window] -> Decoder [Window]
forall a b. (a -> b) -> a -> b
$ (String -> X Window) -> [String] -> X [Window]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> X Window
getAtom [String
"COMPOUND_TEXT",String
"UTF8_STRING"]
  case () of
    () | Window
fmt Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
cOMPOUND_TEXT -> Int -> Decoder Bool -> Decoder Bool
guardSize Int
16 Decoder Bool
(...)
       | Window
fmt Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
sTRING        -> Int -> Decoder Bool -> Decoder Bool
guardSize  Int
8 (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 :: [CUChar]
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 (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'      = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s''
                                                                     then String
s''
                                                                     else String -> String
forall a. [a] -> [a]
tail 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 (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 (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 (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
""
       | Window
fmt Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
uTF8_STRING   -> Decoder Bool
dumpUTF -- duplicate type test instead of code :)
       | Bool
otherwise            -> X String -> Decoder String
forall a. X a -> Decoder a
inX (Window -> X String
atomName Window
fmt) Decoder String -> (String -> Decoder Bool) -> Decoder Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                                 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 :: Decoder Bool
dumpSelection :: Decoder Bool
dumpSelection =  do
  -- system selections contain a window ID; others are random
  -- note that the window ID will be the same as the owner, so
  -- we don't really care anyway.  we *do* want the selection owner
  Window
a <- (Decode -> Window) -> Decoder Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Window
property
  Window
owner <- X Window -> Decoder Window
forall a. X a -> Decoder a
inX (X Window -> Decoder Window) -> X Window -> Decoder Window
forall a b. (a -> b) -> a -> b
$ (Display -> X Window) -> X Window
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X Window) -> X Window)
-> (Display -> X Window) -> X Window
forall a b. (a -> b) -> a -> b
$ \Display
d -> IO Window -> X Window
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Window -> X Window) -> IO Window -> X Window
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO Window
xGetSelectionOwner Display
d Window
a
  if Window
owner Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
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
$ Window -> X String
debugWindow Window
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 :: Decoder Bool
dumpXKlInds :: Decoder Bool
dumpXKlInds =  Window -> Decoder Bool -> Decoder Bool
guardType Window
iNTEGER (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
                 Maybe EventType
n <- (Integer -> EventType) -> Maybe Integer -> Maybe EventType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> EventType
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Maybe Integer -> Maybe EventType)
-> Decoder (Maybe Integer) -> Decoder (Maybe EventType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Decoder (Maybe Integer)
getInt' Int
32
                 case Maybe EventType
n of
                   Maybe EventType
Nothing -> Decoder Bool
propShortErr
                   Just EventType
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 (EventType -> EventType -> Int -> [String] -> [String]
dumpInds EventType
is EventType
1 Int
1 [])
  where
    dumpInds                               :: Word32 -> Word32 -> Int -> [String] -> [String]
    dumpInds :: EventType -> EventType -> Int -> [String] -> [String]
dumpInds EventType
n EventType
bt Int
c [String]
bs | EventType
n EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
0 Bool -> Bool -> Bool
&& Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 =  [String
"none"]
                       | EventType
n EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
0           =  [String]
bs
                       | EventType
n EventType -> EventType -> EventType
forall a. Bits a => a -> a -> a
.&. EventType
bt EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
/= EventType
0    =  EventType -> EventType -> Int -> [String] -> [String]
dumpInds (EventType
n EventType -> EventType -> EventType
forall a. Bits a => a -> a -> a
.&. EventType -> EventType
forall a. Bits a => a -> a
complement EventType
bt)
                                                      (EventType
bt EventType -> Int -> EventType
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        =  EventType -> EventType -> Int -> [String] -> [String]
dumpInds EventType
n
                                                      (EventType
bt EventType -> Int -> EventType
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 :: Decoder Bool
dumpAtom :: Decoder Bool
dumpAtom =
  Window -> Decoder Bool -> Decoder Bool
guardType Window
aTOM (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
  Maybe Integer
a <- Int -> Decoder (Maybe Integer)
getInt' Int
32
  case Maybe Integer
a of
    Maybe Integer
Nothing -> Bool -> Decoder Bool
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
$ Window -> X String
atomName (Window -> X String) -> Window -> X String
forall a b. (a -> b) -> a -> b
$ Integer -> Window
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
a'
           String -> Decoder Bool
append String
an

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

-- a bit of a hack; as a Property it's a wINDOW, as a ClientMessage it's a list
dumpActiveWindow :: Decoder Bool
dumpActiveWindow :: Decoder Bool
dumpActiveWindow =  Int -> Decoder Bool -> Decoder Bool
guardSize Int
32 (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
                      Window
t <- (Decode -> Window) -> Decoder Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Window
pType
                      Window
nAW <- X Window -> Decoder Window
forall a. X a -> Decoder a
inX (X Window -> Decoder Window) -> X Window -> Decoder Window
forall a b. (a -> b) -> a -> b
$ String -> X Window
getAtom String
"_NET_ACTIVE_WINDOW"
                      case () of
                        () | Window
t Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
wINDOW -> Decoder Bool
dumpWindow
                           | Window
t Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
nAW    -> [(String, Decoder Bool, Window)] -> Decoder Bool
dumpList' [(String
"source"       ,[String] -> Decoder Bool
dumpEnum [String]
awSource,Window
cARDINAL)
                                                      ,(String
"timestamp"    ,Decoder Bool
dumpTime         ,Window
cARDINAL)
                                                      ,(String
"active window",Decoder Bool
dumpWindow       ,Window
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
$ Window -> X String
atomName Window
t
                                     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"
                                                      ]
-- dump a generic CARDINAL value
dumpInt   :: Int -> Decoder Bool
dumpInt :: Int -> Decoder Bool
dumpInt Int
w =  Int -> Decoder Bool -> Decoder Bool
guardSize Int
w (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ Window -> Decoder Bool -> Decoder Bool
guardType Window
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   :: Int -> Decoder Bool
dumpInteger :: Int -> Decoder Bool
dumpInteger Int
w =  Int -> Decoder Bool -> Decoder Bool
guardSize Int
w (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ Window -> Decoder Bool -> Decoder Bool
guardType Window
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
. Int -> Integer -> Integer
signed Int
w)

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

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

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

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

-- I am assuming for the moment that this is a single string.
-- This might be false; consider the way the STRING properties
-- handle lists.
dumpUTF :: Decoder Bool
dumpUTF :: Decoder Bool
dumpUTF =  do
  Window
uTF8_STRING <- X Window -> Decoder Window
forall a. X a -> Decoder a
inX (X Window -> Decoder Window) -> X Window -> Decoder Window
forall a b. (a -> b) -> a -> b
$ String -> X Window
getAtom String
"UTF8_STRING"
  Window -> Decoder Bool -> Decoder Bool
guardType Window
uTF8_STRING (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ Int -> Decoder Bool -> Decoder Bool
guardSize Int
8 (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 :: [CUChar]
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 (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- dump an enumerated value using a translation table
dumpEnum'        :: [String] -> Atom -> Decoder Bool
dumpEnum' :: [String] -> Window -> Decoder Bool
dumpEnum' [String]
ss Window
fmt =  Window -> Decoder Bool -> Decoder Bool
guardType Window
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 :: Decoder Bool
dumpPixmap :: Decoder Bool
dumpPixmap =  Window -> Decoder Bool -> Decoder Bool
guardType Window
pIXMAP (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
                Maybe Integer
p' <- Int -> Decoder (Maybe Integer)
getInt' Int
32
                case Maybe Integer
p' of
                  Maybe Integer
Nothing -> Bool -> Decoder Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                  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, Show a) => a -> String -> String
showHex Integer
p String
""
                    Maybe
  (Window, Position, Position, EventType, EventType, EventType, CInt)
g' <- X (Maybe
     (Window, Position, Position, EventType, EventType, EventType,
      CInt))
-> Decoder
     (Maybe
        (Window, Position, Position, EventType, EventType, EventType,
         CInt))
forall a. X a -> Decoder a
inX (X (Maybe
      (Window, Position, Position, EventType, EventType, EventType,
       CInt))
 -> Decoder
      (Maybe
         (Window, Position, Position, EventType, EventType, EventType,
          CInt)))
-> X (Maybe
        (Window, Position, Position, EventType, EventType, EventType,
         CInt))
-> Decoder
     (Maybe
        (Window, Position, Position, EventType, EventType, EventType,
         CInt))
forall a b. (a -> b) -> a -> b
$ (Display
 -> X (Maybe
         (Window, Position, Position, EventType, EventType, EventType,
          CInt)))
-> X (Maybe
        (Window, Position, Position, EventType, EventType, EventType,
         CInt))
forall a. (Display -> X a) -> X a
withDisplay ((Display
  -> X (Maybe
          (Window, Position, Position, EventType, EventType, EventType,
           CInt)))
 -> X (Maybe
         (Window, Position, Position, EventType, EventType, EventType,
          CInt)))
-> (Display
    -> X (Maybe
            (Window, Position, Position, EventType, EventType, EventType,
             CInt)))
-> X (Maybe
        (Window, Position, Position, EventType, EventType, EventType,
         CInt))
forall a b. (a -> b) -> a -> b
$ \Display
d -> IO
  (Maybe
     (Window, Position, Position, EventType, EventType, EventType,
      CInt))
-> X (Maybe
        (Window, Position, Position, EventType, EventType, EventType,
         CInt))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO
   (Maybe
      (Window, Position, Position, EventType, EventType, EventType,
       CInt))
 -> X (Maybe
         (Window, Position, Position, EventType, EventType, EventType,
          CInt)))
-> IO
     (Maybe
        (Window, Position, Position, EventType, EventType, EventType,
         CInt))
-> X (Maybe
        (Window, Position, Position, EventType, EventType, EventType,
         CInt))
forall a b. (a -> b) -> a -> b
$
                            ((Window, Position, Position, EventType, EventType, EventType, CInt)
-> Maybe
     (Window, Position, Position, EventType, EventType, EventType, CInt)
forall a. a -> Maybe a
Just ((Window, Position, Position, EventType, EventType, EventType,
  CInt)
 -> Maybe
      (Window, Position, Position, EventType, EventType, EventType,
       CInt))
-> IO
     (Window, Position, Position, EventType, EventType, EventType, CInt)
-> IO
     (Maybe
        (Window, Position, Position, EventType, EventType, EventType,
         CInt))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display
-> Window
-> IO
     (Window, Position, Position, EventType, EventType, EventType, CInt)
getGeometry Display
d (Integer -> Window
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
p))
                            IO
  (Maybe
     (Window, Position, Position, EventType, EventType, EventType,
      CInt))
-> (SomeException
    -> IO
         (Maybe
            (Window, Position, Position, EventType, EventType, EventType,
             CInt)))
-> IO
     (Maybe
        (Window, Position, Position, EventType, EventType, EventType,
         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
        (Window, Position, Position, EventType, EventType, EventType,
         CInt))
forall a e. Exception e => e -> a
throw SomeException
e IO
  (Maybe
     (Window, Position, Position, EventType, EventType, EventType,
      CInt))
-> ExitCode
-> IO
     (Maybe
        (Window, Position, Position, EventType, EventType, EventType,
         CInt))
forall a b. a -> b -> a
`const` (ExitCode
x ExitCode -> ExitCode -> ExitCode
forall a. a -> a -> a
`asTypeOf` ExitCode
ExitSuccess)
                                    Maybe ExitCode
_      -> Maybe
  (Window, Position, Position, EventType, EventType, EventType, CInt)
-> IO
     (Maybe
        (Window, Position, Position, EventType, EventType, EventType,
         CInt))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
  (Window, Position, Position, EventType, EventType, EventType, CInt)
forall a. Maybe a
Nothing
                    case Maybe
  (Window, Position, Position, EventType, EventType, EventType, CInt)
g' of
                      Maybe
  (Window, Position, Position, EventType, EventType, EventType, CInt)
Nothing                   -> String -> Decoder Bool
append String
" (deleted)"
                      Just (Window
_,Position
x,Position
y,EventType
wid,EventType
ht,EventType
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
" ("
                                     ,EventType -> String
forall a. Show a => a -> String
show EventType
wid
                                     ,Char
'x'Char -> String -> String
forall a. a -> [a] -> [a]
:EventType -> String
forall a. Show a => a -> String
show EventType
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 EventType
bw EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
0 then String
"" else Char
'+'Char -> String -> String
forall a. a -> [a] -> [a]
:EventType -> String
forall a. Show a => a -> String
show EventType
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 :: Decoder Bool
dumpOLAttrs :: Decoder Bool
dumpOLAttrs = do
  Window
pt <- X Window -> Decoder Window
forall a. X a -> Decoder a
inX (X Window -> Decoder Window) -> X Window -> Decoder Window
forall a b. (a -> b) -> a -> b
$ String -> X Window
getAtom String
"_OL_WIN_ATTR"
  Window -> Decoder Bool -> Decoder Bool
guardType Window
pt (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
    Maybe Integer
msk <- Int -> Decoder (Maybe Integer)
getInt' Int
32
    case Maybe Integer
msk of
      Maybe Integer
Nothing   -> Decoder Bool
propShortErr
      Just Integer
msk' -> CULong -> [(String, Decoder Bool)] -> Decoder Bool
dumpListByMask (Integer -> CULong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
msk') [(String
"window type" ,Decoder Bool
dumpAtom     )
                                                      ,(String
"menu"        ,Decoder Bool
dump32       ) -- @@@ unk
                                                      ,(String
"pushpin"     ,[String] -> Decoder Bool
dumpEnum [String]
bool)
                                                      ,(String
"limited menu",Decoder Bool
dump32       ) -- @@@ unk
                                                      ]

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

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

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

-- implement exceptional cases atop a normal dumper
-- @@@ there's gotta be a better way
dumpExcept           :: [(Integer,String)] -> Decoder Bool -> Decoder Bool
dumpExcept :: [(Integer, String)] -> Decoder Bool -> Decoder Bool
dumpExcept [(Integer, String)]
xs Decoder Bool
item = do
  -- this horror brought to you by reparsing to get the right value for our use
  DecodeState
sp <- 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 (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 (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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Integer -> Integer
forall a. HasCallStack => Maybe a -> a
fromJust (Int -> Decoder (Maybe Integer)
getInt' Int
w)
    -- and after all that, we can process the exception list
    [(Integer, String)] -> DecodeState -> Integer -> Decoder Bool
dumpExcept' [(Integer, String)]
xs DecodeState
that Integer
v

dumpExcept'                                      :: [(Integer,String)]
                                                 -> DecodeState
                                                 -> Integer
                                                 -> Decoder Bool
dumpExcept' :: [(Integer, String)] -> DecodeState -> Integer -> Decoder Bool
dumpExcept' []             DecodeState
that Integer
_                =  DecodeState -> Decoder ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put DecodeState
that Decoder () -> Decoder Bool -> Decoder Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Decoder Bool
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  =  [(Integer, String)] -> DecodeState -> Integer -> Decoder Bool
dumpExcept' [(Integer, String)]
xs DecodeState
that Integer
val

-- use @ps@ to get process information.
-- @@@@ assumes a POSIX @ps@, not a BSDish one.
dumpPid :: Decoder Bool
dumpPid :: Decoder Bool
dumpPid =  Window -> Decoder Bool -> Decoder Bool
guardType Window
cARDINAL (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
             Maybe Integer
n <- Int -> Decoder (Maybe Integer)
getInt' Int
32
             case Maybe Integer
n of
               Maybe Integer
Nothing   -> Bool -> Decoder Bool
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 :: StdStream
std_out = StdStream
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 (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. [a] -> Int -> a
!! Int
1

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

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

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

dumpMDropStyle :: Decoder Bool
dumpMDropStyle :: Decoder Bool
dumpMDropStyle =  do
  Maybe Integer
d <- Int -> Decoder (Maybe Integer)
getInt' Int
8
  Int -> Decoder Bool -> Decoder Bool
pad Int
1 (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ case Maybe Integer
d of
            Maybe Integer
Nothing             -> Decoder Bool
propShortErr
            Just Integer
ps | Integer
ps Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0   -> 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   -> 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Decoder Bool
dumpMDPrereg
                    | Integer
ps Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
4   -> 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   -> 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   -> 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 -> 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 :: Decoder Bool
dumpMDPrereg :: Decoder Bool
dumpMDPrereg =  do
  -- this is a bit ugly; we pretend to be extending the above dumpList'
  String -> Decoder Bool
append String
","
  String -> Decoder Bool
append String
"proxy window = "
  Int -> Decoder Bool -> Decoder Bool
forall a. Int -> Decoder a -> Decoder a
withIndent Int
15 Decoder Bool
dumpWindow
  String -> Decoder Bool
append String
","
  String -> Decoder Bool
append String
"drop sites = "
  Maybe Integer
dsc' <- Int -> Decoder (Maybe Integer)
getInt' Int
16
  case Maybe Integer
dsc' of
    Maybe Integer
Nothing  -> Decoder Bool
propShortErr
    Just Integer
dsc -> do
      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)
      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
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 :: Decoder Bool
dumpMotifEndian :: Decoder Bool
dumpMotifEndian =  Window -> Decoder Bool -> Decoder Bool
guardType Window
cARDINAL (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ 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
_     -> String -> Decoder Bool
failure String
"bad endian flag"

pad     :: Int -> Decoder Bool -> Decoder Bool
pad :: Int -> Decoder Bool -> Decoder Bool
pad Int
n Decoder Bool
p =  do
  [CUChar]
vs <- (DecodeState -> [CUChar]) -> Decoder [CUChar]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DecodeState -> [CUChar]
value
  if [CUChar] -> 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 Decoder Bool
propShortErr
    else (DecodeState -> DecodeState) -> Decoder ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DecodeState
r -> DecodeState
r {value :: [CUChar]
value = Int -> [CUChar] -> [CUChar]
forall a. Int -> [a] -> [a]
drop Int
n [CUChar]
vs}) Decoder () -> Decoder Bool -> Decoder Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Decoder Bool
p

dumpPercent :: Decoder Bool
dumpPercent :: Decoder Bool
dumpPercent =  Window -> Decoder Bool -> Decoder Bool
guardType Window
cARDINAL (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
                 Maybe Integer
n <- Int -> Decoder (Maybe Integer)
getInt' Int
32
                 case Maybe Integer
n of
                   Maybe Integer
Nothing -> Bool -> Decoder Bool
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
/ EventType -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EventType
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 a b. (RealFrac a, Integral b) => a -> b
round Double
pct :: Integer) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"%"

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

dumpBits    :: [String] -> Decoder Bool
dumpBits :: [String] -> Decoder Bool
dumpBits [String]
bs =  Window -> Decoder Bool -> Decoder Bool
guardType Window
cARDINAL (Decoder Bool -> Decoder Bool) -> Decoder Bool -> Decoder Bool
forall a b. (a -> b) -> a -> b
$ do
                 Maybe Integer
n <- Int -> Decoder (Maybe Integer)
getInt' Int
32
                 case Maybe Integer
n of
                   Maybe Integer
Nothing -> Bool -> Decoder Bool
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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Decoder String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"|"
        else String -> Decoder String
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"
            ]

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

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'    :: Int -> Decoder (Maybe Integer)
-- see XSync documentation for this insanity
getInt' :: 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.
(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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Integer -> Decoder (Maybe Integer)
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. Int -> Decoder a -> Decoder a -> Decoder a
guardSize' Int
8 (Decoder Bool
propShortErr Decoder Bool -> Decoder (Maybe Integer) -> Decoder (Maybe Integer)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Integer -> Decoder (Maybe Integer)
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 (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
* (EventType -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EventType
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.
(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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Integer -> Decoder (Maybe Integer)
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. Int -> Decoder a -> Decoder a -> Decoder a
guardSize' (Int -> Int
bytes Int
w) (Decoder Bool
propShortErr Decoder Bool -> Decoder (Maybe Integer) -> Decoder (Maybe Integer)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Integer -> Decoder (Maybe Integer)
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 =  Int -> Decoder (Maybe Integer)
getInt' Int
w Decoder (Maybe Integer)
-> (Maybe Integer -> Decoder Bool) -> Decoder Bool
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 (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 (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 (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]
                 [EventType
v] <- Int -> Ptr EventType -> IO [EventType]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
1 (Ptr CUChar -> Ptr EventType
forall a b. Ptr a -> Ptr b
castPtr Ptr CUChar
p :: Ptr Word32)
                 Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> IO Integer) -> Integer -> IO Integer
forall a b. (a -> b) -> a -> b
$ EventType -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
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 :: [CUChar]
value = [CUChar]
rest})
  [CUChar] -> Decoder [CUChar]
forall (m :: * -> *) a. Monad m => a -> m a
return [CUChar]
bs

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

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

-- common appender
append'     :: Bool -> String -> Decoder Bool
append' :: Bool -> String -> Decoder Bool
append' Bool
b String
s =  do
  String
j <- (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 :: String
accum = DecodeState -> String
accum DecodeState
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
j String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s})
  Bool -> Decoder Bool
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 :: [CUChar]
value = []}) Decoder () -> Decoder Bool -> Decoder Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Decoder Bool
append String
s

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

propSizeErr     :: Int -> Int -> Decoder Bool
propSizeErr :: Int -> Int -> Decoder Bool
propSizeErr Int
e Int
a =  String -> Decoder Bool
failure (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 :: Window -> Window -> Decoder Bool
propTypeErr Window
a Window
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
$ Window -> X String
atomName Window
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
$ Window -> X String
atomName Window
a
  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 -> Window) -> Decoder Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Decode -> Window
pType Decoder Window -> (Window -> Decoder String) -> Decoder String
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)
-> (Window -> X String) -> Window -> Decoder String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> 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 :: 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