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