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 =
   forall a b. SP a b
nullSP forall {a} {ho} {hi}. SP a ho -> K hi a -> K hi ho
`postProcessHighK`
   forall {c}.
Maybe (K (Either String Bool) c -> K (Either String Bool) c)
-> K (Either String Bool) c
wmK (forall a. a -> Maybe a
Just K (Either String Bool) a -> K (Either String Bool) a
action)
   forall {c} {ho} {hi}. K c ho -> SP hi c -> K hi ho
`preProcessHighK` 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 =
    forall {b} {c}. (Atom -> K b c) -> K b c
wmDeleteWindowK 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 -> -- (*)
    	forall {b} {c}. String -> Bool -> Cont (K b c) Atom
internAtomK String
"WM_PROTOCOLS" Bool
False forall a b. (a -> b) -> a -> b
$ \ Atom
pr ->
    	forall {ho}.
(FResponse
 -> K (Either String Bool) ho -> K (Either String Bool) ho)
-> K (Either String Bool) ho
wmK' (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 -> forall {ho}.
(FResponse
 -> K (Either String Bool) ho -> K (Either String Bool) ho)
-> K (Either String Bool) ho
wmK' (forall a b. a -> b -> a
const 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 forall a. Eq a => a -> a -> Bool
== Atom
pr Bool -> Bool -> Bool
&& Int -> Atom
Atom (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p) forall a. Eq a => a -> a -> Bool
== Atom
dw ->
	  a -> a
action 
        FResponse
_ -> forall a. a -> a
id

    wmK' :: (FResponse
 -> K (Either String Bool) ho -> K (Either String Bool) ho)
-> K (Either String Bool) ho
wmK' FResponse -> K (Either String Bool) ho -> K (Either String Bool) ho
lowHandler = K (Either String Bool) ho
loop
      where
	loop :: K (Either String Bool) ho
loop =
	  forall {hi} {ho}. Cont (K hi ho) (KEvent hi)
getK 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) ho -> K (Either String Bool) ho
lowHandler FResponse
event K (Either String Bool) ho
loop
	    High (Left String
title) -> forall {i} {o}. XCommand -> K i o -> K i o
xcommandK (String -> XCommand
StoreName String
title) K (Either String Bool) ho
loop
	    High (Right Bool
True) -> forall {i} {o}. XCommand -> K i o -> K i o
xcommandK XCommand
MapRaised K (Either String Bool) ho
loop
	    High (Right Bool
False) -> forall {i} {o}. K i o -> K i o
unmapWindowK K (Either String Bool) ho
loop
	    KEvent (Either String Bool)
_ -> K (Either String Bool) ho
loop

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

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