FocusMgr.hs

module FocusMgr(focusMgr) where
import Data.List((\\),sortBy)
import Data.Maybe(listToMaybe)
import Command
--import Direction
import Dlayout(invisibleGroupF)
import Event
--import Font(FontStruct)
import Fudget
import FRequest
--import Geometry(origin) --Line(..), Point(..), Rect(..), Size(..), origin)
--import LayoutRequest(LayoutRequest)
import LoopLow
import HbcUtils(union)
--import Message(Message(..))
import Path
import PathTree hiding (pos)
--import SP
import Spops
import CompSP
import Utils
import CmdLineEnv(argKey,argReadKey)
import WindowF(kernelTag,autumnize)
import Xtypes
--import List2(sort)

import Maptrace

getEventMask [] = Nothing
getEventMask (CWEventMask m : _) = Just m
getEventMask (_ : l) = getEventMask l

setEventMask em [] = [CWEventMask em]
setEventMask em (CWEventMask m : l) = CWEventMask em : l
setEventMask em (wa : l) = wa : setEventMask em l

focusBtn = Button 1
focusMods = [] --rotMods
rotMods = argReadKey "rotmods" [] :: ModState
rotKs = argKey "rotkey" "Tab" :: KeySym

entrymask = [KeyPressMask, EnterWindowMask, LeaveWindowMask]
mask = [KeyPressMask, KeyReleaseMask, EnterWindowMask, LeaveWindowMask]

mkFocusEvent io = io NotifyNonlinearVirtual NotifyNormal

focusMgr sizing ctt f = loopThroughLowF focusK0 igF
  where
  igF = invisibleGroupF sizing [] [CWEventMask mask] f
  focusK0 = prepostMapSP pre post 
	       (focusK' False emptyPathTree False [] mask [] [] []) where
      pre (Left (t,m)) = (t,Left m)
      pre (Right (t,m)) = (t,Right m)
      post (t,Left m) = Left (t,m)
      post (t,Right m) = Right (t,m)

  --focusK' :: PathTree Bool ->  Bool ->  [(Bool,Path)] -> [EventMask] -> [(Path,(XEvent -> Maybe XEvent))] -> [Path] -> [(Bool,Path)] -> SP (Path,Either Command Event) (Path,Either Command Event) 
  focusK' focusin mapped inw grab mask tt shellTags etags = same where
   focusK = focusK' focusin mapped
   focusm = focusK inw grab mask tt
   modMapped tag raised = changeFocusc' mapped' id 
         [(and (spineVals mapped' t),t) | (_,t) <- etags]
      where mapped' = updateNode id True mapped (autumnize tag) (const raised)
   changeFocusc' mapped' c netags = 
       inw && listToMaybe (mappedtags etags) /= listToMaybe (mappedtags netags)
         `thenC` (leaveFocus etags . enterFocus netags) $ 
       c $
       focusK' focusin mapped' inw grab mask tt shellTags netags 
   changeFocusc = changeFocusc' mapped
   changeFocus = changeFocusc id
   rotate ts = case break fst ts of
       (unmapped,[]) -> ts
       (unmapped,t:mapped) -> mapped ++ unmapped ++ [t]
   nexttag = rotate etags
   prevtag = reverse (rotate (reverse etags))
   enterFocus et = putFocus et FocusIn `ifC` inw
   leaveFocus et = putFocus et FocusOut `ifC` inw
   putFocus et f = putFocus' et (mkFocusEvent f)
   mappedtags et = [t |(True,t)<- et]
   putFocus' et ev = case mappedtags et of 
	 [] -> id
	 (t:_) -> putSP (t, Right (XEvt ev))
   same = getSP focushandle
   focushandle tmsg@(tag,msg) = case msg of 
      Left cmd ->
        case cmd of 
	  XCmd xcmd -> case xcmd of
	    GrabEvents t -> putSP (tag, Left (XCmd $ GrabEvents (t || stag))) $
			    stag `thenC` (leaveFocus etags .
					  enterFocus [(True,tag)]) $
			    focusK inw ((not stag,tag):grab) 
					   mask tt shellTags etags
	    UngrabEvents -> null grab' && inw `thenC` enterFocus etags $
			    pass $ focusK inw grab' mask tt shellTags etags
			  where grab' = drop 1 grab
	    TranslateEvent t tmask ->  putSP (kernelTag, 
	       Left (XCmd $ ChangeWindowAttributes [CWEventMask umask])) $
		  focusK inw grab umask ((tag,t):tt) shellTags etags 
	      where umask = union mask tmask
	    ChangeWindowAttributes cwa | ctt && not ktag && not stag ->
	       case getEventMask cwa of
		  Just em -> if issubset entrymask em then
				putSP (tag, Left (XCmd $ ChangeWindowAttributes 
				       (setEventMask ((ButtonPressMask:
					      em) \\ entrymask) cwa))) $
				null etags `thenC` enterFocus etags' $
				focusm shellTags etags'
			     else passame
			where etags' = sortBy (\(_,x) (_,y)-> compare x y)
					      ((False,tag):etags)
		  Nothing -> passame
	    DestroyWindow -> pass $ 
		 -- not (null etags) && not (keep (head etags)) `thenC`
	       enterFocus etags' $
	       focusK inw grab mask tt' shellTags' (etags' :: [(Bool,Path)])
	      where keep = not . subPath tag
		    etags' = filter (keep.snd) etags
		    shellTags' = filter keep shellTags
		    tt' = filter (keep.fst) tt
	    MapRaised   -> changeMapping tag True
	    UnmapWindow -> changeMapping tag False
	    _ -> passame
	  XReq (CreateMyWindow _) -> changeMapping tag False
	  XReq (CreateRootWindow _ _) {-  | not ktag -} ->
	     pass $ focusm (autumnize tag: shellTags) etags
	  XReq (CreateSimpleWindow rchild _) -> 
	      changeMapping (absPath (autumnize tag) rchild) False
	  _ -> passame
       where changeMapping tag raised = ctrace "focus1" (raised,tag) $ pass $ modMapped tag raised
      Right (XEvt ev) ->
        if stag then passame
	else case ev of
	   ButtonEvent {state=mods,type'=Pressed,button=bno} | ctt && mods == focusMods 
	      && bno == focusBtn && etag -> changeFocusc pass (aft++bef)
 	      where (bef,aft) = break (flip subPath tag.autumnize.snd) etags
	   _ -> case flookup ev tt of
	       Just (t,e) -> putSP (t,Right (XEvt e)) same
	       Nothing -> if not ctt then passame else 
	         case ev of
		  KeyEvent {state=mods,type'=Pressed,keySym=ks} | ks == rotKs && ktag ->
		    if (Shift:rotMods) `issubset` mods then changeFocus prevtag
		    else if rotMods    `issubset` mods then changeFocus nexttag
		    else passame
		  KeyEvent {} |tag==kernelTag || gtag' -> toFocus same
		  EnterNotify {detail=d,focus=True} | tag==kernelTag -> handleEL False d True
		  LeaveNotify {detail=d,focus=True} | tag==kernelTag -> handleEL False d False
		  FocusIn  {detail=d} | tag==kernelTag || gtag' -> handleEL True d True
		  FocusOut {detail=d} | tag==kernelTag || gtag' -> handleEL True d False
		  _ -> passame
	where toFocus = putFocus' etags ev 
	      handleEL isFocusEv d e = if d == NotifyInferior 
                                       || (not isFocusEv && focusin) -- focus events have priority over crossing events
                       then passame else
		       (case grab of
			  (my,t):_ -> if my then if ktag then focusEvToFocus
						 else pass
				      else if ktag then 
					     putSP (t,Right (XEvt ev))
					    else pass
			  [] -> if ktag then focusEvToFocus else pass ) $ 
		       focusK' focusin' mapped inw' grab mask tt shellTags etags
		  where inw' = if ktag then e else inw
                        focusin' = if ktag && isFocusEv then e else focusin
                        focusEvToFocus = putFocus etags (if e then FocusIn else FocusOut)
      Right _ -> passame
    where pass = putSP tmsg
	  passame = pass same
	  ktag = tag == kernelTag || gtag
	  stag = inGroup shellTags
	  etag = inGroup (map (autumnize.snd) etags)
	  gtag = case grab of (_,t):_ -> t == tag; [] -> False
	  gtag' = case grab of (True,t):_ -> t == tag; [] -> False -- event grabbed by something in my shell
          inGroup tags = any (flip subPath tag) tags

flookup index' [] = Nothing
flookup index' ((t, p) : table') =
    case p index' of
      Nothing -> flookup index' table'
      Just e -> Just (t, e)