wsi/osx/wsi.ml

   1 open Utils;;
   2
   3 type cursor =
   4   | CURSOR_INHERIT
   5   | CURSOR_INFO
   6   | CURSOR_CYCLE
   7   | CURSOR_FLEUR
   8   | CURSOR_TEXT
   9
  10 type winstate =
  11   | MaxVert
  12   | MaxHorz
  13   | Fullscreen
  14
  15 type visiblestate =
  16   | Unobscured
  17   | PartiallyObscured
  18   | FullyObscured
  19
  20 let onot = object
  21   method display         = ()
  22   method map _           = ()
  23   method expose          = ()
  24   method visible _       = ()
  25   method reshape _ _     = ()
  26   method mouse _ _ _ _ _ = ()
  27   method motion _ _      = ()
  28   method pmotion _ _     = ()
  29   method key _ _         = ()
  30   method enter _ _       = ()
  31   method leave           = ()
  32   method winstate _      = ()
  33   method quit : 'a. 'a   = exit 0
  34   method scroll _ _      = ()
  35   method zoom _ _ _      = ()
  36   method opendoc _       = ()
  37 end
  38
  39 class type t = object
  40   method display  : unit
  41   method map      : bool -> unit
  42   method expose   : unit
  43   method visible  : visiblestate -> unit
  44   method reshape  : int -> int -> unit
  45   method mouse    : int -> bool -> int -> int -> int -> unit
  46   method motion   : int -> int -> unit
  47   method pmotion  : int -> int -> unit
  48   method key      : int -> int -> unit
  49   method enter    : int -> int -> unit
  50   method leave    : unit
  51   method winstate : winstate list -> unit
  52   method quit     : 'a. 'a
  53   method scroll   : int -> int -> unit
  54   method zoom     : float -> int -> int -> unit
  55   method opendoc  : string -> unit
  56 end
  57
  58 type state =
  59   {
  60     mutable t: t;
  61     mutable fd: Unix.file_descr;
  62     buf: bytes;
  63     mutable off: int;
  64     path: Buffer.t;
  65   }
  66
  67 let state =
  68   {
  69     t = onot;
  70     fd = Unix.stdin;
  71     buf = Bytes.create 512;
  72     off = 0;
  73     path = Buffer.create 0;
  74   }
  75
  76 external setcursor: cursor -> unit = "ml_setcursor"
  77 external settitle: string -> unit = "ml_settitle"
  78 external swapb: unit -> unit = "ml_swapb"
  79 external reshape: int -> int -> unit = "ml_reshape"
  80 external makecurrentcontext: unit -> unit = "ml_makecurrentcontext"
  81 external getw: unit -> int = "ml_getw"
  82 external geth: unit -> int = "ml_geth"
  83 external get_server_fd: unit -> Unix.file_descr = "ml_get_server_fd"
  84 external get_backing_scale_factor: unit -> int = "ml_get_backing_scale_factor"
  85 external fullscreen: unit -> unit = "ml_fullscreen"
  86 external mapwin: unit -> unit = "ml_mapwin"
  87 external setwinbgcol: int -> unit = "ml_setwinbgcol"
  88 external nslog: string -> unit = "ml_nslog"
  89
  90 let nslog fmt =
  91   Printf.ksprintf nslog fmt
  92
  93 (* 0 -> map
  94    1 -> expose
  95    2 -> visible
  96    3 -> reshape
  97    4 -> mouse
  98    5 -> motion
  99    6 -> pmotion
 100    7 -> key
 101    8 -> enter
 102    9 -> leave
 103    10 -> winstate
 104    11 -> quit
 105    12 -> scroll
 106    13 -> zoom
 107    20 -> open *)
 108
 109 let handleresp resp =
 110   let opcode = r8 resp 0 in
 111   match opcode with
 112   | 0 ->
 113       let mapped = r8 resp 16 <> 0 in
 114       vlog "map %B" mapped;
 115       state.t#map mapped
 116   | 1 ->
 117       vlog "expose";
 118       state.t#expose
 119   | 3 ->
 120       let w = r16 resp 16 in
 121       let h = r16 resp 18 in
 122       vlog "reshape width %d height %d" w h;
 123       state.t#reshape w h
 124   | 4 ->
 125       let down = r16 resp 10 <> 0 in
 126       let b = r32 resp 12 in
 127       let x = r16s resp 16 in
 128       let y = r16s resp 20 in
 129       let m = r32 resp 24 in
 130       vlog "mouse %s b %d x %d y %d m 0x%x" (if down then "down" else "up") b x y m;
 131       state.t#mouse b down x y m
 132   | 5 ->
 133       let x = r16s resp 16 in
 134       let y = r16s resp 20 in
 135       let m = r32 resp 24 in
 136       vlog "motion x %d y %d m 0x%x" x y m;
 137       state.t#motion x y
 138   | 6 ->
 139       let x = r16s resp 16 in
 140       let y = r16s resp 20 in
 141       let m = r32 resp 24 in
 142       vlog "pmotion x %d y %d m 0x%x" x y m;
 143       state.t#pmotion x y
 144   | 7 ->
 145       let key = r32 resp 16 in
 146       let mask = r32 resp 20 in
 147       vlog "keydown key %d mask %d" key mask;
 148       state.t#key key mask
 149   | 8 ->
 150       let x = r16s resp 16 in
 151       let y = r16s resp 20 in
 152       vlog "enter x %d y %d" x y;
 153       state.t#enter x y
 154   | 9 ->
 155       vlog "leave";
 156       state.t#leave
 157   | 10 ->
 158       let x = r32 resp 16 <> 0 in
 159       vlog "winstate %B" x;
 160       state.t#winstate (if x then [Fullscreen] else []);
 161   | 11 ->
 162       vlog "quit";
 163       state.t#quit
 164   | 12 ->
 165       let dx = r32s resp 16 in
 166       let dy = r32s resp 20 in
 167       vlog "scroll dx %d dy %d" dx dy;
 168       state.t#scroll dx dy
 169   | 13 ->
 170       let z = float (r32s resp 16) /. 1000.0 in
 171       let x = r16s resp 20 in
 172       let y = r16s resp 22 in
 173       vlog "zoom z %f x %d y %d" z x y;
 174       state.t#zoom z x y
 175   | 20 ->
 176       begin match r16 resp 2 with
 177       | 0 ->
 178           let path = Buffer.contents state.path in
 179           Buffer.reset state.path;
 180           if false then nslog "open %S" path;
 181           state.t#opendoc path
 182       | chunk_len ->
 183           if false then nslog "open-append %S" (Bytes.sub_string resp 4 chunk_len);
 184           Buffer.add_subbytes state.path resp 4 chunk_len
 185       end
 186   | _ ->
 187       vlog "unknown server message %d" opcode
 188
 189 let readresp sock =
 190   let len =
 191     match Unix.read sock state.buf state.off (Bytes.length state.buf - state.off) with
 192     | exception Unix.Unix_error (Unix.EINTR, _, _) -> state.off
 193     | 0 -> state.t#quit
 194     | n -> state.off + n
 195   in
 196   let rec loop off =
 197     (* vlog "loop off=%d len=%d\n%!" off len; *)
 198     if off + 32 <= len then begin
 199       let resp = Bytes.sub state.buf off 32 in
 200       handleresp resp;
 201       loop (off + 32)
 202     end else if off < len then begin
 203       Bytes.blit state.buf off state.buf 0 (len - off);
 204       state.off <- len - state.off
 205     end else
 206       state.off <- 0
 207   in
 208   loop 0
 209
 210 let fontsizefactor () =
 211   get_backing_scale_factor ()
 212
 213 let init t _ w h _platform =
 214   let fd = get_server_fd () in
 215   state.t <- t;
 216   state.fd <- fd;
 217   makecurrentcontext ();
 218   reshape w h;
 219   fd, getw (), geth ()
 220
 221 let activatewin () = ()
 222
 223 let metamask = 1 lsl 19
 224
 225 let altmask = 1 lsl 19
 226
 227 let shiftmask = 1 lsl 17
 228
 229 let ctrlmask = 1 lsl 18
 230
 231 let withalt mask = mask land metamask != 0
 232
 233 let withctrl mask = mask land ctrlmask != 0
 234
 235 let withshift mask = mask land shiftmask != 0
 236
 237 let withmeta mask = mask land metamask != 0
 238
 239 let withnone mask = mask land (altmask + ctrlmask + shiftmask + metamask) = 0
 240
 241 let xlatt, xlatf =
 242   let t = Hashtbl.create 20
 243   and f = Hashtbl.create 20 in
 244   let add n nl k =
 245     List.iter (fun s -> Hashtbl.add t s k) (n::nl);
 246     Hashtbl.add f k n
 247   in
 248   let addc c =
 249     let s = String.make 1 c in
 250     add s [] (Char.code c)
 251   in
 252   let addcr a b =
 253     let an = Char.code a and bn = Char.code b in
 254     for i = an to bn do addc (Char.chr i) done;
 255   in
 256   addcr '0' '9';
 257   addcr 'a' 'z';
 258   addcr 'A' 'Z';
 259   String.iter addc "`~!@#$%^&*()-_=+\\|[{]};:,./<>?";
 260   for i = 0 to 29 do add ("f" ^ string_of_int (i+1)) [] (0xf704 + i) done;
 261   add "space" [] 32;
 262   add "ret" ["return"; "enter"] 13;
 263   add "tab" [] 9;
 264   add "left" [] 0xff51;
 265   add "right" [] 0xff53;
 266   add "home" [] 0xf729;
 267   add "end" [] 0xf72b;
 268   add "ins" ["insert"] 0xf729;
 269   add "del" ["delete"] 0x7f;
 270   add "esc" ["escape"] 27;
 271   add "pgup" ["pageup"] 0xf72c;
 272   add "pgdown" ["pagedown"] 0xf72d;
 273   add "backspace" [] 8;
 274   add "up" [] 0xf700;
 275   add "down" [] 0xf701;
 276   (* add "menu" [] 0xff67; *) (* ? *)
 277   t, f;
 278 ;;
 279
 280 let keyname k =
 281   try Hashtbl.find xlatf k
 282   with Not_found -> Printf.sprintf "%#x" k;
 283 ;;
 284
 285 let namekey name =
 286   try Hashtbl.find xlatt name
 287   with Not_found ->
 288     if String.length name = 1
 289     then Char.code name.[0]
 290     else int_of_string name;
 291 ;;
 292
 293 let kc2kt =
 294   let open Keys in
 295   function
 296   | 8 -> Backspace
 297   | 27 -> Escape
 298   | 13 -> Enter
 299   | 0xf727 -> Insert
 300   | 0xf729 | 0xfff04 -> Home
 301   | 0xf702 | 0xfff05 -> Left
 302   | 0xfff0b | 0xf700 -> Up
 303   | 0xfff0a | 0xF703 -> Right
 304   | 0xfff01 | 0xf701-> Down
 305   | 0xfff09 | 0xf72c -> Prior
 306   | 0xf72d | 0xfff07 -> Next
 307   | 0xfff02 | 0xf72b -> End
 308   | 0x7f -> Delete
 309   | 0xfff03 -> Enter
 310   | 0xfff08 -> Ascii '+'
 311   | 0xfff06 -> Ascii '-'
 312   | code when code > 31 && code < 128 -> Ascii (Char.unsafe_chr code)
 313   | code when code >= 0xffb0 && code <= 0xffb9 ->
 314      Ascii (Char.unsafe_chr (code - 0xffb0 + 0x30))
 315   | code when code >= 0xf704 && code <= 0xf70f -> Fn (code - 0xf704 + 1)
 316   | code when code land 0xff00 = 0xff00 -> Ctrl code
 317   | code -> Code code
 318 ;;