module QuitK where
import Command
import Event
import Fudget
--import FudgetIO
import FRequest
import Xcommand
import HaskellIO(haskellIO)
import InternAtom
--import Message(Message(..))
import NullF
import Spops(nullSP)
import CompFfun(postProcessHighK,preProcessHighK)
--import Sockets
import Xtypes
import DialogueIO hiding (IOError)

quitK :: (K (Either String Bool) a -> K (Either String Bool) a) -> K hi ho
quitK K (Either String Bool) a -> K (Either String Bool) a
action =
   SP a ho
forall a b. SP a b
nullSP SP a ho -> K (Either String Bool) a -> K (Either String Bool) ho
forall a ho hi. SP a ho -> K hi a -> K hi ho
`postProcessHighK`
   Maybe (K (Either String Bool) a -> K (Either String Bool) a)
-> K (Either String Bool) a
forall c.
Maybe (K (Either String Bool) c -> K (Either String Bool) c)
-> K (Either String Bool) c
wmK ((K (Either String Bool) a -> K (Either String Bool) a)
-> Maybe (K (Either String Bool) a -> K (Either String Bool) a)
forall a. a -> Maybe a
Just K (Either String Bool) a -> K (Either String Bool) a
action)
   K (Either String Bool) ho -> SP hi (Either String Bool) -> K hi ho
forall c ho hi. K c ho -> SP hi c -> K hi ho
`preProcessHighK` SP hi (Either String Bool)
forall a b. SP a b
nullSP

-- (*) wmK always enables the WM_DELETE_WINDOW protocol, since some window
-- managers provide a close button that destroy the window if the protocol
-- is disabled. Sigh.

wmK :: Maybe (K (Either String Bool) c -> K (Either String Bool) c)
-> K (Either String Bool) c
wmK Maybe (K (Either String Bool) c -> K (Either String Bool) c)
optAction =
    (Atom -> K (Either String Bool) c) -> K (Either String Bool) c
forall b c. (Atom -> K b c) -> K b c
wmDeleteWindowK ((Atom -> K (Either String Bool) c) -> K (Either String Bool) c)
-> (Atom -> K (Either String Bool) c) -> K (Either String Bool) c
forall a b. (a -> b) -> a -> b
$ \Atom
dw -> -- (*)
    case Maybe (K (Either String Bool) c -> K (Either String Bool) c)
optAction of
      Just K (Either String Bool) c -> K (Either String Bool) c
action ->
        -- wmDeleteWindowK $ \dw -> -- (*)
    	String
-> Bool
-> (Atom -> K (Either String Bool) c)
-> K (Either String Bool) c
forall b c. String -> Bool -> Cont (K b c) Atom
internAtomK String
"WM_PROTOCOLS" Bool
False ((Atom -> K (Either String Bool) c) -> K (Either String Bool) c)
-> (Atom -> K (Either String Bool) c) -> K (Either String Bool) c
forall a b. (a -> b) -> a -> b
$ \ Atom
pr ->
    	(FResponse -> K (Either String Bool) c -> K (Either String Bool) c)
-> K (Either String Bool) c
forall o.
(FResponse -> K (Either String Bool) o -> K (Either String Bool) o)
-> K (Either String Bool) o
wmK' ((K (Either String Bool) c -> K (Either String Bool) c)
-> Atom
-> Atom
-> FResponse
-> K (Either String Bool) c
-> K (Either String Bool) c
forall a. (a -> a) -> Atom -> Atom -> FResponse -> a -> a
lowHandler K (Either String Bool) c -> K (Either String Bool) c
action Atom
pr Atom
dw)
      Maybe (K (Either String Bool) c -> K (Either String Bool) c)
Nothing -> (FResponse -> K (Either String Bool) c -> K (Either String Bool) c)
-> K (Either String Bool) c
forall o.
(FResponse -> K (Either String Bool) o -> K (Either String Bool) o)
-> K (Either String Bool) o
wmK' ((K (Either String Bool) c -> K (Either String Bool) c)
-> FResponse
-> K (Either String Bool) c
-> K (Either String Bool) c
forall a b. a -> b -> a
const K (Either String Bool) c -> K (Either String Bool) c
forall a. a -> a
id)
  where
    lowHandler :: (a -> a) -> Atom -> Atom -> FResponse -> a -> a
lowHandler a -> a
action Atom
pr Atom
dw FResponse
event =
      case FResponse
event of
	XEvt (ClientMessage Atom
a (Long (Int
p : [Int]
_))) | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
pr Bool -> Bool -> Bool
&& Int -> Atom
Atom (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p) Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
dw ->
	  a -> a
action 
        FResponse
_ -> a -> a
forall a. a -> a
id

    wmK' :: (FResponse -> K (Either String Bool) o -> K (Either String Bool) o)
-> K (Either String Bool) o
wmK' FResponse -> K (Either String Bool) o -> K (Either String Bool) o
lowHandler = K (Either String Bool) o
loop
      where
	loop :: K (Either String Bool) o
loop =
	  Cont (K (Either String Bool) o) (KEvent (Either String Bool))
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont (K (Either String Bool) o) (KEvent (Either String Bool))
-> Cont (K (Either String Bool) o) (KEvent (Either String Bool))
forall a b. (a -> b) -> a -> b
$ \KEvent (Either String Bool)
msg ->
	  case KEvent (Either String Bool)
msg of
	    Low FResponse
event -> FResponse -> K (Either String Bool) o -> K (Either String Bool) o
lowHandler FResponse
event K (Either String Bool) o
loop
	    High (Left String
title) -> XCommand -> K (Either String Bool) o -> K (Either String Bool) o
forall i o. XCommand -> K i o -> K i o
xcommandK (String -> XCommand
StoreName String
title) K (Either String Bool) o
loop
	    High (Right Bool
True) -> XCommand -> K (Either String Bool) o -> K (Either String Bool) o
forall i o. XCommand -> K i o -> K i o
xcommandK XCommand
MapRaised K (Either String Bool) o
loop
	    High (Right Bool
False) -> K (Either String Bool) o -> K (Either String Bool) o
forall i o. K i o -> K i o
unmapWindowK K (Either String Bool) o
loop
	    KEvent (Either String Bool)
_ -> K (Either String Bool) o
loop

-- Some handlers:
exitK :: p -> K b ho
exitK p
cont = Request -> (Response -> K b ho) -> K b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
Request -> (Response -> f b ho) -> f b ho
haskellIO (Int -> Request
Exit Int
0) (K b ho -> Response -> K b ho
forall a b. a -> b -> a
const K b ho
forall hi ho. K hi ho
nullK)
unmapWindowK :: K i o -> K i o
unmapWindowK = XCommand -> K i o -> K i o
forall i o. XCommand -> K i o -> K i o
xcommandK XCommand
UnmapWindow
reportK :: K hi () -> K hi ()
reportK = KCommand () -> K hi () -> K hi ()
forall ho hi. KCommand ho -> K hi ho -> K hi ho
putK (() -> KCommand ()
forall a b. b -> Message a b
High ())

wmDeleteWindowK :: (Atom -> K b c) -> K b c
wmDeleteWindowK Atom -> K b c
cont =
    String -> Bool -> (Atom -> K b c) -> K b c
forall b c. String -> Bool -> Cont (K b c) Atom
internAtomK String
"WM_DELETE_WINDOW" Bool
False ((Atom -> K b c) -> K b c) -> (Atom -> K b c) -> K b c
forall a b. (a -> b) -> a -> b
$ \Atom
dw ->
    XCommand -> K b c -> K b c
forall i o. XCommand -> K i o -> K i o
xcommandK ([Atom] -> XCommand
SetWMProtocols [Atom
dw]) (K b c -> K b c) -> K b c -> K b c
forall a b. (a -> b) -> a -> b
$
    Atom -> K b c
cont Atom
dw