{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}------------------------------------------------------------------------------- |-- Module : XMonad.Hooks.DebugEvents-- 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.-------------------------------------------------------------------------------moduleXMonad.Hooks.DebugEvents(debugEventsHook)whereimportPreludeimportXMonadhiding(windowEvent,(-->))importXMonad.Hooks.DebugKeyEvents(debugKeyEvents)importXMonad.Util.DebugWindow(debugWindow)-- import Graphics.X11.Xlib.Extras.GetAtomName (getAtomName)importControl.Exception.ExtensibleasEimportControl.Monad.StateimportControl.Monad.ReaderimportData.Char(isDigit)importData.List(genericIndex,genericLength,unfoldr)importCodec.Binary.UTF8.StringimportData.Maybe(fromMaybe)importData.MonoidimportForeignimportForeign.C.TypesimportNumeric(showHex)importSystem.ExitimportSystem.IOimportSystem.Process-- | Event hook to dump all received events. You should probably not use this-- unconditionally; it will produce massive amounts of output.debugEventsHook::Event->XAlldebugEventsHooke=debugEventsHook'e>>return(AllTrue)-- | Dump an X11 event. Can't be used directly as a 'handleEventHook'.debugEventsHook'::Event->X()debugEventsHook'(ConfigureRequestEvent{ev_window=w,ev_parent=p,ev_x=x,ev_y=y,ev_width=wid,ev_height=ht,ev_border_width=bw,ev_above=above,ev_detail=place,ev_value_mask=msk})=dowindowEvent"ConfigureRequest"wwindowEvent" parent"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-- ]s<-quickFormat[x,y,wid,ht,bw,fromIntegralabove,place]$dumpListByMask'msk[("x",dump32,cARDINAL),("y",dump32,cARDINAL),("width",dump32,cARDINAL),("height",dump32,cARDINAL),("border_width",dump32,cARDINAL),("sibling",dumpWindow,wINDOW),("detail",dumpEnumwmPlacement,cARDINAL)]say" requested"sdebugEventsHook'(ConfigureEvent{ev_window=w,ev_above=above})=dowindowEvent"Configure"w-- most of the content is covered by debugWindowwhen(above/=none)$debugWindowabove>>=say" above"debugEventsHook'(MapRequestEvent{ev_window=w,ev_parent=p})=windowEvent"MapRequest"w>>windowEvent" parent"pdebugEventsHook'e@(KeyEvent{ev_event_type=t})|t==keyPress=io(hPutStrstderr"KeyPress ")>>debugKeyEventse>>return()debugEventsHook'(ButtonEvent{ev_window=w,ev_state=s,ev_button=b})=dowindowEvent"Button"wnl<-getsnumberlockMaskletmsk|s==0=""|otherwise="modifiers "++vmasknlssay" button"$showb++mskdebugEventsHook'(DestroyWindowEvent{ev_window=w})=windowEvent"DestroyWindow"wdebugEventsHook'(UnmapEvent{ev_window=w})=windowEvent"Unmap"wdebugEventsHook'(MapNotifyEvent{ev_window=w})=windowEvent"MapNotify"w{- way too much output; suppressed.
debugEventsHook' (CrossingEvent {ev_window = w
,ev_subwindow = s
}) =
windowEvent "Crossing" w >>
windowEvent " subwindow" s
-}debugEventsHook'(CrossingEvent{})=return()debugEventsHook'(SelectionRequest{ev_requestor=rw,ev_owner=ow,ev_selection=a})=windowEvent"SelectionRequest"rw>>windowEvent" owner"ow>>atomEvent" atom"adebugEventsHook'(PropertyEvent{ev_window=w,ev_atom=a,ev_propstate=s})=doa'<-atomNamea-- too many of these, and they're not real usefulifa'`elem`["_NET_WM_USER_TIME"-- ,"_NET_WM_WINDOW_OPACITY"]thenreturn()elsedowindowEvent"Property on"ws'<-casesof1->return"deleted"0->dumpPropertyaa'w(7+lengtha')_->error"Illegal propState; Xlib corrupted?"say" atom"$a'++s'debugEventsHook'(ExposeEvent{ev_window=w})=windowEvent"Expose"wdebugEventsHook'(ClientMessageEvent{ev_window=w,ev_message_type=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=vs'})=dowindowEvent"ClientMessage on"wn<-atomNamea-- this is a sort of custom property-- @@@ this likely won't work as is; type information varies, I think(ta,b,l)<-caselookupnclientMessagesofNothing->return(a,32,lengthvs')Just(ta',b,l)->dota<-getAtomta'return(ta,b,l)letwl=bytesbvs<-io$take(l*wl)`fmap`splitCIntvs's<-dumpProperty'wantabvs0(10+lengthn)say" message"$n++sdebugEventsHook'_=return()-- | Emit information about an atom.atomName::Atom->XStringatomNamea=withDisplay$\d->io$fromMaybe("(unknown atom "++showa++")")`fmap`getAtomNameda-- | Emit an atom with respect to the current event.atomEvent::String->Atom->X()atomEventla=atomNamea>>=sayl-- | Emit a window with respect to the current event.windowEvent::String->Window->X()windowEventlw=debugWindoww>>=sayl-- | Helper to emit tagged event information.say::String->String->X()sayls=trace$l++' ':s-- | Deconstuct a list of 'CInt's into raw bytessplitCInt::[CInt]->IORawsplitCIntvs=io$withArrayvs$\p->peekArray(4*lengthvs)(castPtrp::PtrCUChar)-- | Specify how to decode some common client messages.clientMessages::[(String,(String,Int,Int))]clientMessages=[("_NET_ACTIVE_WINDOW",("_NET_ACTIVE_WINDOW",32,1)),("WM_CHANGE_STATE",("WM_STATE",32,2)),("WM_COMMAND",("STRING",8,0)),("WM_SAVE_YOURSELF",("STRING",8,0))]-- | Convert a modifier mask into a useful stringvmask::KeyMask->KeyMask->StringvmasknumLockMaskmsk=unwords$reverse$fst$foldrvmask'([],msk)maskswheremasks=map(\m->(m,showm))[0..toEnum(bitSizemsk-1)]++[(numLockMask,"num"),(lockMask,"lock"),(controlMask,"ctrl"),(shiftMask,"shift"),(mod5Mask,"mod5"),(mod4Mask,"mod4"),(mod3Mask,"mod3"),(mod2Mask,"mod2"),(mod1Mask,"mod1")]vmask'_a@(_,0)=avmask'(m,s)(ss,v)|v.&.m==m=(s:ss,v.&.complementm)vmask'_r=r-- formatting properties. ick. ---- @@@ Document the parser. Someday.typeRaw=[CUChar]dataDecode=Decode{property::Atom-- original property atom,pName::String-- its name,pType::Atom-- base property type atom,width::Int-- declared data width,window::Window-- source window,indent::Int-- current indent (via local),limit::Int-- line length}-- the result accumulates here mainly for the benefit of the indenterdataDecodeState=DecS{value::Raw-- unconsumed raw property value,accum::String-- output accumulator,joint::String-- separator when adding to accumulator}newtypeDecodera=Decoder(ReaderTDecode(StateTDecodeStateX)a)#ifndef __HADDOCK__deriving(Functor,Monad,MonadIO,MonadStateDecodeState,MonadReaderDecode)#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->XStringdumpPropertyanwi=doprop<-withDisplay$\d->io$alloca$\fmtp->alloca$\szp->alloca$\lenp->alloca$\ackp->alloca$\vsp->dorc<-xGetWindowPropertydwa0maxBoundFalseanyPropertyTypefmtpszplenpackpvspcasercof0->dofmt<-fromIntegral`fmap`peekfmtpvs'<-peekvspsz<-fromIntegral`fmap`peekszpcase()of()|fmt==none->xFreevs'>>return(Left"(property deleted)")|sz<0->xFreevs'>>return(Left$"(illegal bit size "++showsz++")")|sz`mod`8/=0->xFreevs'>>return(Left$"(illegal bit size "++showsz++")")|otherwise->dolen<-fromIntegral`fmap`peeklenp-- that's as in "ack! it's fugged!"ack<-fromIntegral`fmap`peekackpvs<-peekArray(len*bytessz)vs'_<-xFreevs'return$Right(fmt,sz,ack,vs)e->return$Left$"getWindowProperty failed: "++showecasepropofLeft_->return""Right(fmt,sz,ack,vs)->dumpProperty'wanfmtszvsacki-- @@@ 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->XStringdumpProperty'wanfmtszvsacki=doptn<-atomNamefmtletdec=Decode{property=a,pName=n,pType=fmt,width=sz,indent=i+lengthptn+6,window=w,limit=96}dec'=dec{pType=cARDINAL,width=8}ds=DecS{value=vs-- @@@ probably should push this outside, since it doesn't-- make sense for ClientMessage,accum=" ("++ptn++") ",joint="= "}(_,ds')<-runDecodedecds$dumpPropanletfin=length(valueds')len=lengthvslost=ifack==0then""else"and "++showack++" lost bytes"unk=case()of()|fin==len->"undecodeable "|fin==0->"."|otherwise->"and remainder ("++show(len-fin)++'/':showlen++")"(_,ds'')<-iffin==0thenreturn(True,ds')elserunDecodedec'(withJoint'unkds')$dumpArraydump8(_,ds''')<-ifack==0thenreturn(True,ds'')elserunDecodedec'(withJoint'" "ds'')$propSimplelost-- @@@return$accumds'''-- | A simplified version of 'dumpProperty\'', to format random values from-- events.quickFormat::(Storablei,Integrali)=>[i]->DecoderBool->XStringquickFormatvf=doletvl=lengthvvs<-io$allocaArrayvl$\p->pokeArrayp(mapfromIntegralv::[CULong])>>peekArray(4*vl)(castPtrp::PtrCUChar)letdec=Decode{property=none,pName="",pType=cARDINAL,width=32,indent=0,window=none,limit=maxBound}ds=DecS{value=vs,accum="",joint=""}(r,ds')<-runDecodedecdsfreturn$accumds'++ifrthen""else"?"-- | Launch a decoding parser, returning success and final state.runDecode::Decode->DecodeState->DecoderBool->X(Bool,DecodeState)runDecodecs(Decoderp)=runStateT(runReaderTpc)s-- Coerce bit size to bytes.bytes::Int->Intbytesw=w`div`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->DecoderBooldumpProp_"CLIPBOARD"=dumpSelectiondumpProp_"_NET_SUPPORTED"=dumpArraydumpAtomdumpProp_"_NET_CLIENT_LIST"=dumpArraydumpWindowdumpProp_"_NET_CLIENT_LIST_STACKING"=dumpArraydumpWindowdumpProp_"_NET_NUMBER_OF_DESKTOPS"=dump32dumpProp_"_NET_VIRTUAL_ROOTS"=dumpArraydumpWindowdumpProp_"_NET_DESKTOP_GEOMETRY"=dumpArraydump32dumpProp_"_NET_DESKTOP_VIEWPORT"=dumpList[("w",dump32),("h",dump32)]dumpProp_"_NET_CURRENT_DESKTOP"=dump32dumpProp_"_NET_DESKTOP_NAMES"=dumpArraydumpUTFdumpProp_"_NET_ACTIVE_WINDOW"=dumpActiveWindowdumpProp_"_NET_WORKAREA"=dumpList[("start",dumpList[("x",dump32),("y",dump32)]),("size",dumpList[("w",dump32),("h",dump32)])]dumpProp_"_NET_SUPPORTING_WM_CHECK"=dumpWindowdumpProp_"_NET_DESKTOP_LAYOUT"=dumpList[("orientation",dumpEnumnwmOrientation),("size",dumpList[("cols",dump32),("rows",dump32)]),("origin",dumpEnumnwmOrigin)]dumpProp_"_NET_SHOWING_DESKTOP"=dump32dumpProp_"_NET_WM_NAME"=dumpUTFdumpProp_"_NET_WM_VISIBLE_NAME"=dumpUTFdumpProp_"_NET_WM_ICON_NAME"=dumpUTFdumpProp_"_NET_WM_VISIBLE_ICON_NAME"=dumpUTFdumpProp_"_NET_WM_DESKTOP"=dumpExcept[(0xFFFFFFFF,"all")]dump32dumpProp_"_NET_WM_WINDOW_TYPE"=dumpArraydumpAtomdumpProp_"_NET_WM_STATE"=dumpArraydumpAtomdumpProp_"_NET_WM_ALLOWED_ACTIONS"=dumpArraydumpAtomdumpProp_"_NET_WM_STRUT"=dumpList[("left gap",dump32),("right gap",dump32),("top gap",dump32),("bottom gap",dump32)]dumpProp_"_NET_WM_STRUT_PARTIAL"=dumpList[("left gap",dump32),("right gap",dump32),("top gap",dump32),("bottom gap",dump32),("left start",dump32),("left end",dump32),("right start",dump32),("right end",dump32),("top start",dump32),("top end",dump32),("bottom start",dump32),("bottom end",dump32)]dumpProp_"_NET_WM_ICON_GEOMETRY"=dumpList[("x",dump32),("y",dump32),("w",dump32),("h",dump32)]-- no, I'm not going to duplicate xprop *completely*!dumpProp_"_NET_WM_ICON"=propSimple"(icon)"dumpProp_"_NET_WM_PID"=dumpPiddumpProp_"_NET_WM_HANDLED_ICONS"=propSimple"(defined)"dumpProp_"_NET_WM_USER_TIME"=dumpExcept[(0,"do not map initially")]dumpTimedumpProp_"_NET_FRAME_EXTENTS"=dumpList[("left",dump32),("right",dump32),("top",dump32),("bottom",dump32)]dumpProp_"_NET_WM_SYNC_REQUEST_COUNTER"=dumpExcept[(0,"illegal value 0")]dump64dumpProp_"_NET_STARTUP_ID"=dumpUTFdumpProp_"WM_PROTOCOLS"=dumpArraydumpAtomdumpProp_"WM_COLORMAP_WINDOWS"=dumpArraydumpWindowdumpProp_"WM_STATE"=dumpStatedumpProp_"WM_LOCALE_NAME"=dumpStringdumpProp_"WM_CLIENT_LEADER"=dumpWindowdumpProp_"_NET_WM_WINDOW_OPACITY"=dumpPercentdumpProp_"XdndAware"=dumpArraydumpAtomdumpProp_"_XKLAVIER_TRANSPARENT"=dumpInteger32dumpProp_"_XKLAVIER_STATE"=dumpList[("state",dumpInteger32),("indicators",dumpXKlInds)]dumpProp_"_MOTIF_DRAG_RECEIVER_INFO"=dumpMotifDragReceiverdumpProp_"_OL_WIN_ATTR"=dumpOLAttrsdumpProp_"_OL_DECOR_ADD"=dumpArraydumpAtomdumpProp_"_OL_DECOR_DEL"=dumpArraydumpAtomdumpProp_"_MOTIF_WM_HINTS"=dumpMwmHintsdumpProp_"_MOTIF_WM_INFO"=dumpMwmInfodumpProp_"_XMONAD_DECORATED_BY"=dumpWindowdumpProp_"_XMONAD_DECORATION_FOR"=dumpWindowdumpPropa_|a==wM_NAME=dumpString|a==pRIMARY=dumpSelection|a==sECONDARY=dumpSelection-- this is gross|a==wM_TRANSIENT_FOR=doroot<-fromIntegral`fmap`inX(askstheRoot)w<-askswindowWMHints{wmh_window_group=group}<-inX$asksdisplay>>=io.flipgetWMHintswdumpExcept[(0,"window group "++showgroup),(root,"window group "++showgroup)]dumpWindow|a==rESOURCE_MANAGER=dumpString|a==wM_COMMAND=dumpString|a==wM_HINTS=dumpWmHints|a==wM_CLIENT_MACHINE=dumpString|a==wM_ICON_NAME=dumpString|a==wM_ICON_SIZE=dumpList[("min size",dumpList[("w",dump32),("h",dump32)]),("max size",dumpList[("w",dump32),("h",dump32)]),("increment",dumpList[("w",dump32),("h",dump32)])]|a==wM_NORMAL_HINTS=(...)|a==wM_ZOOM_HINTS=(...)-- same as previous|a==rGB_DEFAULT_MAP=(...)-- XStandardColormap|a==rGB_BEST_MAP=(...)-- "|a==rGB_RED_MAP=(...)-- "|a==rGB_GREEN_MAP=(...)-- "|a==rGB_BLUE_MAP=(...)-- "|a==rGB_GRAY_MAP=(...)-- "|a==wM_CLASS=dumpList[("name",dumpString),("class",dumpString)]dumpProp_s|s`isCountOf`"WM_S"=dumpSelection|s`isCountOf`"_NET_WM_CM_S"=dumpSelection|s`isCountOf`"_NET_DESKTOP_LAYOUT_S"=dumpSelection|s`isCountOf`"CUT_BUFFER"=dumpString-- and dumpProperties does the rest|otherwise=returnFalse-- lower level decoders ---- alter the current jointwithJoint::String->Decodera->DecoderawithJointj=((modify$withJoint'j)>>)withJoint'::String->DecodeState->DecodeStatewithJoint'js=s{joint=j}-- lift an X into a DecoderinX::Xa->DecoderainX=Decoder.lift.lift-- flip isPrefixOf, but the remainder must be all digitsisCountOf::String->String->Bool-- note that \NUL is safe because atom names have to be C stringss`isCountOf`pfx=null$dropWhileisDigit$mapfst$dropWhile(uncurry(==))$zips$pfx++repeat'\NUL'-- localize an increased indentwithIndent::Int->Decodera->DecoderawithIndentw=local(\r->r{indent=indentr+w})-- dump an array of items. this dumps the entire propertydumpArray::DecoderBool->DecoderBooldumpArrayitem=dowithIndent1$append"[">>withJoint""(dumpArray'item"")-- step through values as an array, ending on parse error or end of listdumpArray'::DecoderBool->String->DecoderBooldumpArray'itempfx=dovs<-getsvalueifvs==[]thenappend"]"elseappendpfx>>whenDitem(dumpArray'item",")-- 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. ISAGNwhenD::Monadm=>mBool->mBool->mBoolwhenDpf=p>>=\b->ifbthenfelsereturnFalse-- verify a decoder parameter, else call error reporter-- once again, it's more general than I originally wroteguardR::(MonadReaderrm,Eqv)=>(r->v)-- value selector->v-- expected value->(v->v->ma)-- error reporter->ma-- continuation (hush)->maguardRselvalerrgood=dov<-asksselifv==valthengoodelseerrvval-- this is kinda dumbfi::Bool->a->a->afipny=ifpthenyelsen-- flip (if' p), if that existed-- verify we have the expected word sizeguardSize::Int->DecoderBool->DecoderBool-- see XSync documentation for this insanityguardSize64=guardRwidth32propSizeErr.guardSize'8propShortErrguardSizew=guardRwidthwpropSizeErr.guardSize'(bytesw)propShortErrguardSize'::Int->Decodera->Decodera->DecoderaguardSize'lny=getsvalue>>=\vs->fi(lengthvs>=l)ny-- verify we have the expected property typeguardType::Atom->DecoderBool->DecoderBoolguardTypet=guardRpTypetpropTypeErr-- dump a structure as a named tupledumpList::[(String,DecoderBool)]->DecoderBooldumpListproto=doa<-askspTypedumpList''(maxBound::CULong)(map(\(s,d)->(s,d,a))proto)"("-- same but elements have their own distinct typesdumpList'::[(String,DecoderBool,Atom)]->DecoderBooldumpList'proto=dumpList''(maxBound::CULong)proto"("-- same but only dump elements identified by provided maskdumpListByMask::CULong->[(String,DecoderBool)]->DecoderBooldumpListByMaskmp=doa<-askspTypedumpList''m(map(\(s,d)->(s,d,a))p)"("-- and the previous two combineddumpListByMask'::CULong->[(String,DecoderBool,Atom)]->DecoderBooldumpListByMask'mp=dumpList''mp"("dumpList''::CULong->[(String,DecoderBool,Atom)]->String->DecoderBooldumpList''_[]_=append")">>returnTruedumpList''0__=append")">>returnTruedumpList''m((l,p,t):ps)sep=do(e,sep')<-ifm.&.1==0thendo-- @@@ ewst<-gete<-local(\r->r{pType=t})pv'<-getsvalueput$st{value=v'}return(e,sep)elsedoletlabel=sep++l++" = "appendlabele<-withJoint""$dolocal(\r->r{pType=t,indent=indentr+lengthlabel})preturn(e,",")ifethendumpList''(m`shiftR`1)pssep'elsereturne-- do the getTextProperty dance, the hard way.-- @@@ @COMPOUND_TEXT@ not supported yet.dumpString::DecoderBooldumpString=dofmt<-askspType[cOMPOUND_TEXT,uTF8_STRING]<-inX$mapMgetAtom["COMPOUND_TEXT","UTF8_STRING"]case()of()|fmt==cOMPOUND_TEXT->guardSize16(...)|fmt==sTRING->guardSize8$dovs<-getsvaluemodify(\r->r{value=[]})letss=flipunfoldr(maptwiddlevs)$\s->ifnullsthenNothingelselet(w,s'')=break(=='\NUL')ss'=ifnulls''thens''elsetails''inJust(w,s')casessof[s]->append$showsss'->letgo(s:ss'')c=appendc>>append(shows)>>goss''","go[]_=append"]"inappend"[">>goss'""|fmt==uTF8_STRING->dumpUTF-- duplicate type test instead of code :)|otherwise->(inX$atomNamefmt)>>=failure.("unrecognized string type "++)-- show who owns a selectiondumpSelection::DecoderBooldumpSelection=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 ownera<-askspropertyowner<-inX$withDisplay$\d->io$xGetSelectionOwnerdaifowner==nonethenappend"unowned"elsedow<-inX$debugWindowownerappend$"owned by "++w-- for now, not querying XkbdumpXKlInds::DecoderBooldumpXKlInds=guardTypeiNTEGER$don<-fmapfromIntegral`fmap`getInt'32casenofNothing->propShortErrJustis->append$"indicators "++unwords(dumpIndsis11[])wheredumpInds::Word32->Word32->Int->[String]->[String]dumpIndsnbtcbs|n==0&&c==1=["none"]|n==0=bs|n.&.bt/=0=dumpInds(n.&.complementbt)(bt`shiftL`1)(c+1)((showc):bs)|otherwise=dumpIndsn(bt`shiftL`1)(c+1)bs-- decode an AtomdumpAtom::DecoderBooldumpAtom=guardTypeaTOM$doa<-getInt'32caseaofNothing->returnFalseJusta'->doan<-inX$atomName$fromIntegrala'appendandumpWindow::DecoderBooldumpWindow=guardSize32$guardTypewINDOW$dow<-getInt'32casewofNothing->returnFalseJustw'->inX(debugWindow(fromIntegralw'))>>=append-- a bit of a hack; as a Property it's a wINDOW, as a ClientMessage it's a listdumpActiveWindow::DecoderBooldumpActiveWindow=guardSize32$dot<-askspTypenAW<-inX$getAtom"_NET_ACTIVE_WINDOW"case()of()|t==wINDOW->dumpWindow|t==nAW->dumpList'[("source",dumpEnumawSource,cARDINAL),("timestamp",dumpTime,cARDINAL),("active window",dumpWindow,wINDOW)]_->dot'<-inX$atomNametfailure$concat["(bad type ",t',"; expected WINDOW or _NET_ACTIVE_WINDOW"]-- dump a generic CARDINAL valuedumpInt::Int->DecoderBooldumpIntw=guardSizew$guardTypecARDINAL$getIntwshow-- INTEGER is the signed version of CARDINALdumpInteger::Int->DecoderBooldumpIntegerw=guardSizew$guardTypeiNTEGER$getIntw(show.signedw)-- reinterpret an unsigned as a signedsigned::Int->Integer->Integersignedwi=bit(w+1)-i-- and wrappers to keep the parse list in boundsdump64::DecoderBooldump64=dumpInt64dump32::DecoderBooldump32=dumpInt32{- not used in standard properties
dump16 :: Decoder Bool
dump16 = dumpInt 16
-}dump8::DecoderBooldump8=dumpInt8-- 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::DecoderBooldumpUTF=douTF8_STRING<-inX$getAtom"UTF8_STRING"guardTypeuTF8_STRING$guardSize8$dos<-getsvaluemodify(\r->r{value=[]})append.show.decode.mapfromIntegral$sreturnTrue-- dump an enumerated value using a translation tabledumpEnum'::[String]->Atom->DecoderBooldumpEnum'ssfmt=guardTypefmt$getInt32$\r->case()of()|r<0->"undefined value "++showr|r>=genericLengthss->"undefined value "++showr|otherwise->genericIndexssr-- we do not, unlike @xev@, try to ascii-art pixmaps.dumpPixmap::DecoderBooldumpPixmap=guardTypepIXMAP$dop'<-getInt'32casep'ofNothing->returnFalseJustp->doappend$"pixmap "++showHexp""g'<-inX$withDisplay$\d->io$Just`fmap`getGeometryd(fromIntegralp)`E.catch`\e->casefromExceptioneofJustx->throwe`const`(x`asTypeOf`ExitSuccess)_->returnNothingcaseg'ofNothing->append" (deleted)"Just(_,x,y,wid,ht,bw,dp)->append$concat[" (",showwid,'x':showht,'x':showdp,')':ifbw==0then""else'+':showbw,"@(",showx,',':showy,")"]dumpOLAttrs::DecoderBooldumpOLAttrs=dopt<-inX$getAtom"_OL_WIN_ATTR"guardTypept$domsk<-getInt'32casemskofNothing->propShortErrJustmsk'->dumpListByMask(fromIntegralmsk')[("window type",dumpAtom),("menu",dump32)-- @@@ unk,("pushpin",dumpEnumbool),("limited menu",dump32)-- @@@ unk]dumpMwmHints::DecoderBooldumpMwmHints=dota<-askspropertyguardTypeta$domsk<-getInt'32casemskofNothing->propShortErrJustmsk'->dumpListByMask(fromIntegralmsk')[("functions",dumpBitsmwmFuncs),("decorations",dumpBitsmwmDecos),("input mode",dumpEnummwmInputMode),("status",dumpBitsmwmState)]dumpMwmInfo::DecoderBooldumpMwmInfo=dota<-askspropertyguardTypeta$dumpList'[("flags",dumpBitsmwmHints,cARDINAL),("window",dumpWindow,wINDOW)]-- the most common casedumpEnum::[String]->DecoderBooldumpEnumss=dumpEnum'sscARDINAL-- implement exceptional cases atop a normal dumper-- @@@ there's gotta be a better waydumpExcept::[(Integer,String)]->DecoderBool->DecoderBooldumpExceptxsitem=do-- this horror brought to you by reparsing to get the right value for our usesp<-getrc<-itemifnotrcthenreturnFalseelsedothat<-get-- if none match then we just restore the value parsevs<-getsvalueletw=(length(valuesp)-lengthvs)*8-- now we get to reparse again so we get our copy of itputspJustv<-getInt'w-- and after all that, we can process the exception listdumpExcept'xsthatvdumpExcept'::[(Integer,String)]->DecodeState->Integer->DecoderBooldumpExcept'[]that_=putthat>>returnTruedumpExcept'((exc,str):xs)thatval|exc==val=appendstr|otherwise=dumpExcept'xsthatval-- use @ps@ to get process information.-- @@@@ assumes a POSIX @ps@, not a BSDish one.dumpPid::DecoderBooldumpPid=guardTypecARDINAL$don<-getInt'32casenofNothing->returnFalseJustpid'->doletpid=showpid'ps=(proc"/bin/ps"["-fp"++pid]){std_out=CreatePipe}(_,o,_,_)<-io$createProcesspscaseoofNothing->append$"pid "++pidJustp'->doprc<-io$lines`fmap`hGetContentsp'-- deliberately forcing itappend$iflengthprc<2then"pid "++pidelseprc!!1dumpTime::DecoderBooldumpTime=append"server event # ">>dump32dumpState::DecoderBooldumpState=dowM_STATE<-inX$getAtom"WM_STATE"guardTypewM_STATE$dumpList'[("state",dumpEnumwmState,cARDINAL),("icon window",dumpWindow,wINDOW)]dumpMotifDragReceiver::DecoderBooldumpMotifDragReceiver=dota<-inX$getAtom"_MOTIF_DRAG_RECEIVER_INFO"guardTypeta$dumpList'[("endian",dumpMotifEndian,cARDINAL),("version",dump8,cARDINAL),("style",dumpMDropStyle,cARDINAL)-- @@@ dummy]dumpMDropStyle::DecoderBooldumpMDropStyle=dod<-getInt'8pad1$casedofNothing->propShortErrJustps|ps==0->pad12$append"none"|ps==1->pad12$append"drop only"|ps==2->append"prefer preregister ">>dumpMDPrereg|ps==3->append"preregister ">>dumpMDPrereg|ps==4->pad12$append"prefer dynamic"|ps==5->pad12$append"dynamic"|ps==6->pad12$append"prefer receiver"|otherwise->failure$"unknown drop style "++showpsdumpMDPrereg::DecoderBooldumpMDPrereg=do-- this is a bit ugly; we pretend to be extending the above dumpList'append","append"proxy window = "withIndent15dumpWindowappend","append"drop sites = "dsc'<-getInt'16casedsc'ofNothing->propShortErrJustdsc->dowithIndent13$append(showdsc)pad2$doappend","append"total size = "withIndent13dump32dumpMDBlocks$fromIntegraldscdumpMDBlocks::Int->DecoderBooldumpMDBlocks_=propSimple"(drop site info)"-- @@@ maybe later if neededdumpMotifEndian::DecoderBooldumpMotifEndian=guardTypecARDINAL$guardSize8$doc<-maptwiddle`fmap`eat1casecof['l']->append"little"['B']->append"big"_->failure"bad endian flag"pad::Int->DecoderBool->DecoderBoolpadnp=dovs<-getsvalueiflengthvs<nthenpropShortErrelsemodify(\r->r{value=dropnvs})>>pdumpPercent::DecoderBooldumpPercent=guardTypecARDINAL$don<-getInt'32casenofNothing->returnFalseJustn'->letpct=100*fromIntegraln'/fromIntegral(maxBound::Word32)pct::Doubleinappend$show(roundpct::Integer)++"%"dumpWmHints::DecoderBooldumpWmHints=guardTypewM_HINTS$domsk<-getInt'32casemskofNothing->returnFalseJustmsk'->dumpListByMask'(fromIntegralmsk')[("input",dumpEnumbool,cARDINAL),("initial_state",dumpEnumwmState,cARDINAL),("icon_pixmap",dumpPixmap,pIXMAP),("icon_window",dumpWindow,wINDOW),("icon_x",dump32,cARDINAL),("icon_y",dump32,cARDINAL),("icon_mask",dumpPixmap,pIXMAP),("window_group",dumpWindow,wINDOW)]dumpBits::[String]->DecoderBooldumpBitsbs=guardTypecARDINAL$don<-getInt'32casenofNothing->returnFalseJustn'->dumpBits'bs1(fromIntegraln')""dumpBits'::[String]->Int->Int->String->DecoderBooldumpBits'[]_np=ifn==0thenreturnTrueelseappend(p++shown)dumpBits'(s:ss)bnp=dop'<-ifn.&.b/=0thenappend(p++s)>>return"|"elsereturnpdumpBits'ss(b`shiftL`1)(n.&.complementb)p'-- enum definitions --mwmFuncs::[String]mwmFuncs=["all except","resize","move","minimize","maximize","close"]mwmDecos::[String]mwmDecos=["all except","border","resize handle","title","menu button","maximize button","minimize button"]mwmInputMode::[String]mwmInputMode=["modeless","application modal","system model","full application modal"]mwmState::[String]mwmState=["tearoff window"]mwmHints::[String]mwmHints=["standard startup","custom startup"]awSource::[String]awSource=["unspecified","application","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=["Above","Below","TopIf","BottomIf","Opposite"]bool::[String]bool=["False","True"]nwmOrientation::[String]nwmOrientation=nwmEnum(Just"ORIENTATION")["HORZ","VERT"]nwmOrigin::[String]nwmOrigin=nwmEnumNothing["TOPLEFT","TOPRIGHT","BOTTOMRIGHT","BOTTOMLEFT"]wmState::[String]wmState=["Withdrawn","Normal","Zoomed (obsolete)","Iconified","Inactive"]nwmEnum::MaybeString->[String]->[String]nwmEnumNothingvs=map("_NET_WM_"++)vsnwmEnum(Justprefix)vs=map(("_NET_WM_"++prefix++"_")++)vs-- and the lowest level coercions ---- parse and return an integral valuegetInt'::Int->Decoder(MaybeInteger)-- see XSync documentation for this insanitygetInt'64=guardRwidth32(\ae->propSizeErrae>>returnNothing)$guardSize'8(propShortErr>>returnNothing)$dolo<-inhale32hi<-inhale32return$Just$lo+hi*(fromIntegral(maxBound::Word32)+1)getInt'w=guardRwidthw(\ae->propSizeErrae>>returnNothing)$guardSize'(bytesw)(propShortErr>>returnNothing)$Just`fmap`inhalew-- parse an integral value and feed it to a show-er of some kindgetInt::Int->(Integer->String)->DecoderBoolgetIntwf=getInt'w>>=maybe(returnFalse)(append.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 wayinhale::Int->DecoderIntegerinhale8=do[b]<-eat1return$fromIntegralbinhale16=do[b0,b1]<-eat2io$allocaArray2$\p->dopokeArrayp[b0,b1][v]<-peekArray1(castPtrp::PtrWord16)return$fromIntegralvinhale32=do[b0,b1,b2,b3]<-eat4io$allocaArray4$\p->dopokeArrayp[b0,b1,b2,b3][v]<-peekArray1(castPtrp::PtrWord32)return$fromIntegralvinhaleb=error$"inhale "++showbeat::Int->DecoderRaweatn=do(bs,rest)<-splitAtn`fmap`getsvaluemodify(\r->r{value=rest})returnbs-- actually do formatting type stuffs-- sorta stubbed for the moment-- eventually we should do indentation foo hereappend::String->DecoderBoolappend=append'True-- and the same but for errorsfailure::String->DecoderBoolfailure=append'False-- common appenderappend'::Bool->String->DecoderBoolappend'bs=doj<-getsjointmodify(\r->r{accum=accumr++j++s})returnb-- consume all and output a constant stringpropSimple::String->DecoderBoolpropSimples=modify(\r->r{value=[]})>>appends-- report various errorspropShortErr::DecoderBoolpropShortErr=failure"(property ended prematurely)"propSizeErr::Int->Int->DecoderBoolpropSizeErrea=failure$"(bad bit width "++showa++"; expected "++showe++")"propTypeErr::Atom->Atom->DecoderBoolpropTypeErrae=doe'<-inX$atomNameea'<-inX$atomNameafailure$"(bad type "++a'++"; expected "++e'++")"-- for stubs(...)::DecoderBool(...)=dofmt<-askspType>>=inX.atomNamepropSimple$"(unimplemented type "++fmt++")"-- you like fi, I like thistwiddle::(Enuma,Enumb)=>a->btwiddle=toEnum.fromEnum