module SelectionF where 
import FudUTF8(decodeUTF8,encodeUTF8)
import Command
import CompOps((>=^<), (>^=<))
import Cont(conts,cmdContK')
import Shells(unmappedShellF)
import Event
import Fudget
import FRequest
import Xcommand
import GetWindowProperty
import InternAtom
--import Message(Message(..))
import NullF
import LayoutF(nullLF)
import Spops(putSP,getSP)
import Loops(loopThroughRightF)
import EitherUtils(stripEither)
import SerCompF(absF)
import Xtypes

{- 
Supports cut/paste of UTF-8 encoded Unicode Strings.
Cut/paste of Unicode strings between two fudgets program works.
Cut/paste between a fudget program and xterm -u8 from XFree86 4.0 works.
/TH 2000-04-02
-}

data SelCmd a = Sel a | ClearSel | PasteSel  deriving (SelCmd a -> SelCmd a -> Bool
forall a. Eq a => SelCmd a -> SelCmd a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SelCmd a -> SelCmd a -> Bool
$c/= :: forall a. Eq a => SelCmd a -> SelCmd a -> Bool
== :: SelCmd a -> SelCmd a -> Bool
$c== :: forall a. Eq a => SelCmd a -> SelCmd a -> Bool
Eq, SelCmd a -> SelCmd a -> Bool
SelCmd a -> SelCmd a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (SelCmd a)
forall a. Ord a => SelCmd a -> SelCmd a -> Bool
forall a. Ord a => SelCmd a -> SelCmd a -> Ordering
forall a. Ord a => SelCmd a -> SelCmd a -> SelCmd a
min :: SelCmd a -> SelCmd a -> SelCmd a
$cmin :: forall a. Ord a => SelCmd a -> SelCmd a -> SelCmd a
max :: SelCmd a -> SelCmd a -> SelCmd a
$cmax :: forall a. Ord a => SelCmd a -> SelCmd a -> SelCmd a
>= :: SelCmd a -> SelCmd a -> Bool
$c>= :: forall a. Ord a => SelCmd a -> SelCmd a -> Bool
> :: SelCmd a -> SelCmd a -> Bool
$c> :: forall a. Ord a => SelCmd a -> SelCmd a -> Bool
<= :: SelCmd a -> SelCmd a -> Bool
$c<= :: forall a. Ord a => SelCmd a -> SelCmd a -> Bool
< :: SelCmd a -> SelCmd a -> Bool
$c< :: forall a. Ord a => SelCmd a -> SelCmd a -> Bool
compare :: SelCmd a -> SelCmd a -> Ordering
$ccompare :: forall a. Ord a => SelCmd a -> SelCmd a -> Ordering
Ord)
data SelEvt a = LostSel | SelNotify a  deriving (SelEvt a -> SelEvt a -> Bool
forall a. Eq a => SelEvt a -> SelEvt a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SelEvt a -> SelEvt a -> Bool
$c/= :: forall a. Eq a => SelEvt a -> SelEvt a -> Bool
== :: SelEvt a -> SelEvt a -> Bool
$c== :: forall a. Eq a => SelEvt a -> SelEvt a -> Bool
Eq, SelEvt a -> SelEvt a -> Bool
SelEvt a -> SelEvt a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (SelEvt a)
forall a. Ord a => SelEvt a -> SelEvt a -> Bool
forall a. Ord a => SelEvt a -> SelEvt a -> Ordering
forall a. Ord a => SelEvt a -> SelEvt a -> SelEvt a
min :: SelEvt a -> SelEvt a -> SelEvt a
$cmin :: forall a. Ord a => SelEvt a -> SelEvt a -> SelEvt a
max :: SelEvt a -> SelEvt a -> SelEvt a
$cmax :: forall a. Ord a => SelEvt a -> SelEvt a -> SelEvt a
>= :: SelEvt a -> SelEvt a -> Bool
$c>= :: forall a. Ord a => SelEvt a -> SelEvt a -> Bool
> :: SelEvt a -> SelEvt a -> Bool
$c> :: forall a. Ord a => SelEvt a -> SelEvt a -> Bool
<= :: SelEvt a -> SelEvt a -> Bool
$c<= :: forall a. Ord a => SelEvt a -> SelEvt a -> Bool
< :: SelEvt a -> SelEvt a -> Bool
$c< :: forall a. Ord a => SelEvt a -> SelEvt a -> Bool
compare :: SelEvt a -> SelEvt a -> Ordering
$ccompare :: forall a. Ord a => SelEvt a -> SelEvt a -> Ordering
Ord)

data ESelCmd a = OwnSel | SelCmd (SelCmd a) deriving (ESelCmd a -> ESelCmd a -> Bool
forall a. Eq a => ESelCmd a -> ESelCmd a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ESelCmd a -> ESelCmd a -> Bool
$c/= :: forall a. Eq a => ESelCmd a -> ESelCmd a -> Bool
== :: ESelCmd a -> ESelCmd a -> Bool
$c== :: forall a. Eq a => ESelCmd a -> ESelCmd a -> Bool
Eq, ESelCmd a -> ESelCmd a -> Bool
ESelCmd a -> ESelCmd a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (ESelCmd a)
forall a. Ord a => ESelCmd a -> ESelCmd a -> Bool
forall a. Ord a => ESelCmd a -> ESelCmd a -> Ordering
forall a. Ord a => ESelCmd a -> ESelCmd a -> ESelCmd a
min :: ESelCmd a -> ESelCmd a -> ESelCmd a
$cmin :: forall a. Ord a => ESelCmd a -> ESelCmd a -> ESelCmd a
max :: ESelCmd a -> ESelCmd a -> ESelCmd a
$cmax :: forall a. Ord a => ESelCmd a -> ESelCmd a -> ESelCmd a
>= :: ESelCmd a -> ESelCmd a -> Bool
$c>= :: forall a. Ord a => ESelCmd a -> ESelCmd a -> Bool
> :: ESelCmd a -> ESelCmd a -> Bool
$c> :: forall a. Ord a => ESelCmd a -> ESelCmd a -> Bool
<= :: ESelCmd a -> ESelCmd a -> Bool
$c<= :: forall a. Ord a => ESelCmd a -> ESelCmd a -> Bool
< :: ESelCmd a -> ESelCmd a -> Bool
$c< :: forall a. Ord a => ESelCmd a -> ESelCmd a -> Bool
compare :: ESelCmd a -> ESelCmd a -> Ordering
$ccompare :: forall a. Ord a => ESelCmd a -> ESelCmd a -> Ordering
Ord)
data ESelEvt a =  WantSel | SelEvt (SelEvt a) deriving (ESelEvt a -> ESelEvt a -> Bool
forall a. Eq a => ESelEvt a -> ESelEvt a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ESelEvt a -> ESelEvt a -> Bool
$c/= :: forall a. Eq a => ESelEvt a -> ESelEvt a -> Bool
== :: ESelEvt a -> ESelEvt a -> Bool
$c== :: forall a. Eq a => ESelEvt a -> ESelEvt a -> Bool
Eq, ESelEvt a -> ESelEvt a -> Bool
ESelEvt a -> ESelEvt a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (ESelEvt a)
forall a. Ord a => ESelEvt a -> ESelEvt a -> Bool
forall a. Ord a => ESelEvt a -> ESelEvt a -> Ordering
forall a. Ord a => ESelEvt a -> ESelEvt a -> ESelEvt a
min :: ESelEvt a -> ESelEvt a -> ESelEvt a
$cmin :: forall a. Ord a => ESelEvt a -> ESelEvt a -> ESelEvt a
max :: ESelEvt a -> ESelEvt a -> ESelEvt a
$cmax :: forall a. Ord a => ESelEvt a -> ESelEvt a -> ESelEvt a
>= :: ESelEvt a -> ESelEvt a -> Bool
$c>= :: forall a. Ord a => ESelEvt a -> ESelEvt a -> Bool
> :: ESelEvt a -> ESelEvt a -> Bool
$c> :: forall a. Ord a => ESelEvt a -> ESelEvt a -> Bool
<= :: ESelEvt a -> ESelEvt a -> Bool
$c<= :: forall a. Ord a => ESelEvt a -> ESelEvt a -> Bool
< :: ESelEvt a -> ESelEvt a -> Bool
$c< :: forall a. Ord a => ESelEvt a -> ESelEvt a -> Bool
compare :: ESelEvt a -> ESelEvt a -> Ordering
$ccompare :: forall a. Ord a => ESelEvt a -> ESelEvt a -> Ordering
Ord)

eselectionF :: F (ESelCmd String) (ESelEvt String)
eselectionF :: F (ESelCmd String) (ESelEvt String)
eselectionF =
    (forall {a}. Either a a -> a
stripEither forall a b e. (a -> b) -> F e a -> F e b
>^=< forall {t :: * -> *} {a} {b} {c} {d}.
Foldable t =>
t FRequest -> K a b -> F c d -> F (Either a c) (Either b d)
unmappedShellF [] K (ESelCmd String) (ESelEvt String)
selK forall {hi} {ho}. F hi ho
nullLF) forall c d e. F c d -> (e -> c) -> F e d
>=^<
    forall a b. a -> Either a b
Left where
 selK :: K (ESelCmd String) (ESelEvt String)
selK =
    forall a c b. (a -> Cont c b) -> [a] -> Cont c [b]
conts (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall {b} {c}. String -> Bool -> Cont (K b c) Atom
internAtomK Bool
True) 
      [String
"PRIMARY", String
"STRING", String
"NONE", String
"ATOM"] forall a b. (a -> b) -> a -> b
$ 
      \ [Atom
primaryA, Atom
stringA, Atom
noneA, Atom
atomA] ->
    forall a c b. (a -> Cont c b) -> [a] -> Cont c [b]
conts (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall {b} {c}. String -> Bool -> Cont (K b c) Atom
internAtomK Bool
False) [String
"FUDGETS_UTF8",String
"UTF8_STRING"] forall a b. (a -> b) -> a -> b
$
      \ [Atom
fudgetsA, Atom
utf8A] -> let
      sevt :: SelEvt a -> Message a (ESelEvt a)
sevt = forall a b. b -> Message a b
Highforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SelEvt a -> ESelEvt a
SelEvt
      l :: K (ESelCmd String) (ESelEvt String)
l =
	  forall {hi} {ho}. Cont (K hi ho) (KEvent hi)
getK forall a b. (a -> b) -> a -> b
$ \KEvent (ESelCmd String)
ev ->
	  case KEvent (ESelCmd String)
ev of
	    High ESelCmd String
esc -> case ESelCmd String
esc of
	      SelCmd SelCmd String
sc -> case SelCmd String
sc of
		 Sel String
t -> K (ESelCmd String) (ESelEvt String)
l -- select t
		 SelCmd String
ClearSel -> K (ESelCmd String) (ESelEvt String)
deselect
		 SelCmd String
PasteSel -> K (ESelCmd String) (ESelEvt String)
paste_utf8string -- try UTF-8 first...
	      ESelCmd String
OwnSel -> K (ESelCmd String) (ESelEvt String)
select
	    Low (XEvt XEvent
ev) -> case XEvent
ev of
	      SelectionClear Atom
s | Atom
s forall a. Eq a => a -> a -> Bool
== Atom
primaryA -> forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK (forall {a} {a}. SelEvt a -> Message a (ESelEvt a)
sevt forall a. SelEvt a
LostSel) K (ESelCmd String) (ESelEvt String)
l
	      SelectionRequest Time
t Window
w Selection
s -> Time -> Window -> Selection -> K (ESelCmd String) (ESelEvt String)
selectionrequest Time
t Window
w Selection
s
	      SelectionNotify Time
t Selection
s -> Selection -> K (ESelCmd String) (ESelEvt String)
selectionnotify Selection
s
	      XEvent
_ -> K (ESelCmd String) (ESelEvt String)
l
	    Low FResponse
_ -> K (ESelCmd String) (ESelEvt String)
l
      selectionrequest :: Time -> Window -> Selection -> K (ESelCmd String) (ESelEvt String)
selectionrequest Time
time Window
w sel :: Selection
sel@(Selection Atom
s Atom
t Atom
p) =
	if Atom
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Atom
stringA,Atom
utf8A]
	then forall {i} {o}. Time -> Window -> Selection -> K i o -> K i o
notify Time
time Window
w (Atom -> Atom -> Atom -> Selection
Selection Atom
s Atom
noneA Atom
p) K (ESelCmd String) (ESelEvt String)
l
	else
	  let p' :: Atom
p' = if Atom
p forall a. Eq a => a -> a -> Bool
== Atom
noneA then Atom
t else Atom
p
	      wait :: Message a (ESelCmd a) -> Maybe a
wait (High (SelCmd (Sel a
t))) = forall a. a -> Maybe a
Just a
t
	      wait Message a (ESelCmd a)
_ = forall a. Maybe a
Nothing
	  in forall {ho} {hi} {a}.
KCommand ho -> (KEvent hi -> Maybe a) -> Cont (K hi ho) a
cmdContK' (forall a b. b -> Message a b
High forall a. ESelEvt a
WantSel) forall {a} {a}. Message a (ESelCmd a) -> Maybe a
wait forall a b. (a -> b) -> a -> b
$ \String
rawtext ->
	     let text :: String
text = if Atom
tforall a. Eq a => a -> a -> Bool
==Atom
utf8A
	                then String -> String
encodeUTF8 String
rawtext
			else String
rawtext in
	     forall {i} {o}. XCommand -> K i o -> K i o
xcommandK (Window
-> Atom -> Atom -> Time -> PropertyMode -> String -> XCommand
ChangeProperty Window
w Atom
p' Atom
t Time
8 PropertyMode
propModeReplace String
text) forall a b. (a -> b) -> a -> b
$
	     forall {i} {o}. Time -> Window -> Selection -> K i o -> K i o
notify Time
time Window
w (Atom -> Atom -> Atom -> Selection
Selection Atom
s Atom
t Atom
p') K (ESelCmd String) (ESelEvt String)
l
      notify :: Time -> Window -> Selection -> K i o -> K i o
notify Time
t Window
w Selection
sel = forall {i} {o}. XCommand -> K i o -> K i o
xcommandK (Window -> Bool -> [EventMask] -> XEvent -> XCommand
SendEvent Window
w Bool
False [] (Time -> Selection -> XEvent
SelectionNotify Time
t Selection
sel))
      paste_string :: K (ESelCmd String) (ESelEvt String)
paste_string = Atom -> K (ESelCmd String) (ESelEvt String)
paste' Atom
stringA
      paste_utf8string :: K (ESelCmd String) (ESelEvt String)
paste_utf8string = Atom -> K (ESelCmd String) (ESelEvt String)
paste' Atom
utf8A
      paste' :: Atom -> K (ESelCmd String) (ESelEvt String)
paste' Atom
typ =
	  forall {i} {o}. XCommand -> K i o -> K i o
xcommandK (Selection -> XCommand
ConvertSelection (Atom -> Atom -> Atom -> Selection
Selection Atom
primaryA Atom
typ Atom
fudgetsA)) K (ESelCmd String) (ESelEvt String)
l
      paste_failed :: K (ESelCmd String) (ESelEvt String)
paste_failed = forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK (forall {a} {a}. SelEvt a -> Message a (ESelEvt a)
sevt (forall a. a -> SelEvt a
SelNotify String
"")) K (ESelCmd String) (ESelEvt String)
l
      selectionnotify :: Selection -> K (ESelCmd String) (ESelEvt String)
selectionnotify sel :: Selection
sel@(Selection Atom
s Atom
t Atom
p) =
          if Atom
pforall a. Eq a => a -> a -> Bool
==Atom
noneA
	  then if Atom
tforall a. Eq a => a -> a -> Bool
==Atom
utf8A  -- UTF8_STRING wasn't supported, try STRING
	       then K (ESelCmd String) (ESelEvt String)
paste_string
	       else K (ESelCmd String) (ESelEvt String)
paste_failed
	  else if Atom
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Atom
stringA,Atom
utf8A]
	       then K (ESelCmd String) (ESelEvt String)
paste_failed
	       else forall {b} {c}.
Time
-> Atom
-> Bool
-> Atom
-> Cont (K b c) (Atom, Time, Time, Time, String)
getWindowPropertyK Time
0 Atom
p Bool
True Atom
t forall a b. (a -> b) -> a -> b
$ 
			  \(Atom
typ, Time
format, Time
nitems, Time
after,String
seltext) ->
		    let s' :: String
s' = if Atom
tforall a. Eq a => a -> a -> Bool
==Atom
utf8A then String -> String
decodeUTF8 String
seltext else String
seltext in
		    forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK (forall {a} {a}. SelEvt a -> Message a (ESelEvt a)
sevt (forall a. a -> SelEvt a
SelNotify String
s')) K (ESelCmd String) (ESelEvt String)
l
      select :: K (ESelCmd String) (ESelEvt String)
select = Bool -> K (ESelCmd String) (ESelEvt String)
select' Bool
True
      deselect :: K (ESelCmd String) (ESelEvt String)
deselect = Bool -> K (ESelCmd String) (ESelEvt String)
select' Bool
False
      -- should check that setselectionowner succeeded.
      select' :: Bool -> K (ESelCmd String) (ESelEvt String)
select' Bool
b = forall {i} {o}. XCommand -> K i o -> K i o
xcommandK (Bool -> Atom -> XCommand
SetSelectionOwner Bool
b Atom
primaryA) K (ESelCmd String) (ESelEvt String)
l
    in K (ESelCmd String) (ESelEvt String)
l

selectionF :: F (SelCmd String) (SelEvt String)
selectionF :: F (SelCmd String) (SelEvt String)
selectionF = forall a b c d. F (Either a b) (Either c d) -> F c a -> F b d
loopThroughRightF (forall a b. SP a b -> F a b
absF (forall {a} {a}.
a
-> SP
     (Either (ESelEvt a) (SelCmd a)) (Either (ESelCmd a) (SelEvt a))
selSP String
"")) (F (ESelCmd String) (ESelEvt String)
eselectionF) where
  selSP :: a
-> SP
     (Either (ESelEvt a) (SelCmd a)) (Either (ESelCmd a) (SelEvt a))
selSP a
text = 
    let same :: SP (Either (ESelEvt a) (SelCmd a)) (Either (ESelCmd a) (SelEvt a))
same = a
-> SP
     (Either (ESelEvt a) (SelCmd a)) (Either (ESelCmd a) (SelEvt a))
selSP a
text 
	toesel :: a -> Either a b
toesel = forall a b. a -> Either a b
Left
	toout :: b -> Either a b
toout = forall a b. b -> Either a b
Right in
    forall a b. Cont (SP a b) a
getSP forall a b. (a -> b) -> a -> b
$ \Either (ESelEvt a) (SelCmd a)
msg -> case Either (ESelEvt a) (SelCmd a)
msg of
	Right SelCmd a
ocmd -> case SelCmd a
ocmd of
	   Sel a
t -> forall b a. b -> SP a b -> SP a b
putSP (forall a b. a -> Either a b
toesel forall a. ESelCmd a
OwnSel) forall a b. (a -> b) -> a -> b
$ a
-> SP
     (Either (ESelEvt a) (SelCmd a)) (Either (ESelCmd a) (SelEvt a))
selSP a
t
	   SelCmd a
_ -> forall b a. b -> SP a b -> SP a b
putSP (forall a b. a -> Either a b
toesel (forall a. SelCmd a -> ESelCmd a
SelCmd SelCmd a
ocmd)) SP (Either (ESelEvt a) (SelCmd a)) (Either (ESelCmd a) (SelEvt a))
same
	Left ESelEvt a
esevt -> case ESelEvt a
esevt of
	   ESelEvt a
WantSel -> forall b a. b -> SP a b -> SP a b
putSP (forall a b. a -> Either a b
toesel (forall a. SelCmd a -> ESelCmd a
SelCmd (forall a. a -> SelCmd a
Sel a
text))) SP (Either (ESelEvt a) (SelCmd a)) (Either (ESelCmd a) (SelEvt a))
same
	   SelEvt SelEvt a
se -> forall b a. b -> SP a b -> SP a b
putSP (forall {b} {a}. b -> Either a b
toout SelEvt a
se) SP (Either (ESelEvt a) (SelCmd a)) (Either (ESelCmd a) (SelEvt a))
same