Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Loading…

Updates and fix #107

Merged
merged 4 commits into from

1 participant

Çagdas Bozman
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Dec 13, 2012
  1. Çagdas Bozman

    Update js_of_ocaml

    cago authored
  2. Çagdas Bozman
Commits on Jan 30, 2013
  1. Çagdas Bozman
  2. Çagdas Bozman

    Fix issue #104

    cago authored
This page is out of date. Refresh to see the latest.
2  js_of_ocaml/compiler/generate.ml
View
@@ -1502,7 +1502,7 @@ let f ch ?(standalone=true) ((pc, blocks, _) as p) dl live_vars =
if !compact then Pretty_print.set_compact ch true;
if standalone then begin
Pretty_print.string ch
- "// This program was compiled from OCaml by js_of_ocaml 1.0";
+ "// This program was compiled from OCaml by js_of_ocaml 1.3";
Pretty_print.newline ch;
let missing = Linker.resolve_deps !compact ch (Primitives.get_used ()) in
list_missing missing
2  js_of_ocaml/compiler/js_parse.ml
View
@@ -1778,7 +1778,7 @@ let from_channel ~paths ic =
if !is_toplevel then begin
Tbl.iter (fun _ n -> globals.is_exported.(n) <- true) symbols.num_tbl;
List.iter Primitives.mark_used
- [ "caml_string_greaterthan"; "caml_js_meth_call" ]
+ [ "caml_string_greaterthan"; "caml_js_meth_call"; "caml_string_lessequal"; "caml_string_greaterequal"]
end;
fix_min_max_int code;
9 js_of_ocaml/lib/deriving_json/deriving_Json.ml
View
@@ -125,12 +125,12 @@ module Json_bool = Defaults(struct
type a = bool
let write buffer b =
Buffer.add_char buffer (if b then '1' else '0')
- let read buf = 1 = Deriving_Json_lexer.read_bounded_int ~max:1 buf
+ let read buf = 1 = Deriving_Json_lexer.read_tag_2 0 1 buf
end)
module Json_unit = Defaults(struct
type a = unit
let write buffer () = Buffer.add_char buffer '0'
- let read buf = ignore(Deriving_Json_lexer.read_bounded_int ~max:0buf)
+ let read buf = ignore(Deriving_Json_lexer.read_tag_1 0 buf)
end)
module Json_int = Defaults(struct
type a = int
@@ -153,7 +153,7 @@ module Json_int64 = Defaults(struct
(Int64.logand (Int64.shift_right i 48) mask16)
let read buf =
Deriving_Json_lexer.read_lbracket buf;
- ignore(Deriving_Json_lexer.read_bounded_int ~min:255 ~max:255 buf);
+ ignore(Deriving_Json_lexer.read_tag_1 255 buf);
Deriving_Json_lexer.read_comma buf;
let h1 = Deriving_Json_lexer.read_int64 buf in
Deriving_Json_lexer.read_comma buf;
@@ -285,6 +285,7 @@ module Json_array(A : Json) = Defaults(struct
read_list (x :: acc) buf
let read buf =
match Deriving_Json_lexer.read_case buf with
- | `NCst 0 -> Array.of_list (List.rev (read_list [] buf))
+ (* We allow the tag 254 in case of float array *)
+ | `NCst 0 | `NCst 254 -> Array.of_list (List.rev (read_list [] buf))
| _ -> failwith "Json_array.read: unexpected constructor."
end)
2  js_of_ocaml/lib/deriving_json/deriving_Json_lexer.mli
View
@@ -36,6 +36,8 @@ val init_lexer:
val read_int: lexbuf -> int
val read_bounded_int: ?min:int -> max:int -> lexbuf -> int
+val read_tag_1 : int -> lexbuf -> int
+val read_tag_2 : int -> int -> lexbuf -> int
val read_int32: lexbuf -> int32
val read_int64: lexbuf -> int64
val read_number: lexbuf -> float
20 js_of_ocaml/lib/deriving_json/deriving_Json_lexer.mll
View
@@ -319,6 +319,8 @@ and read_case v = parse
and read_vcase v = parse
| positive_int { try `Cst (extract_positive_int lexbuf)
with Int_overflow -> lexer_error "Int overflow" v lexbuf }
+ | '-'? positive_int { try `Cst (extract_negative_int lexbuf)
+ with Int_overflow -> lexer_error "Int overflow" v lexbuf }
| '[' { read_space v lexbuf;
let zero = read_positive_int v lexbuf in
if (zero <> 0) then
@@ -353,10 +355,28 @@ and read_vcase v = parse
else
n
+ let read_tag_1 n v lexbuf =
+ if n = read_int v lexbuf
+ then n
+ else lexer_error "Int outside of bounds" v lexbuf
+
+ let read_tag_2 n1 n2 v lexbuf =
+ let n = read_int v lexbuf in
+ if n = n1
+ then n1
+ else if n = n2
+ then n2
+ else lexer_error "Int outside of bounds" v lexbuf
+
+
let read_bool v = read_space v v.lexbuf; read_bool v v.lexbuf
let read_int v = read_space v v.lexbuf; read_int v v.lexbuf
let read_bounded_int ?(min = 0) ~max v =
read_space v v.lexbuf; read_bounded_int min max v v.lexbuf
+ let read_tag_1 n v =
+ read_space v v.lexbuf; read_tag_1 n v v.lexbuf
+ let read_tag_2 n1 n2 v =
+ read_space v v.lexbuf; read_tag_2 n1 n2 v v.lexbuf
let read_int32 v = read_space v v.lexbuf; read_int32 v v.lexbuf
let read_int64 v = read_space v v.lexbuf; read_int64 v v.lexbuf
let read_number v = read_space v v.lexbuf; read_number v v.lexbuf
58 js_of_ocaml/lib/lwt_js_events.ml
View
@@ -43,11 +43,11 @@ let make_event event_kind ?(use_capture = false) target =
);
t
-let seq_loop evh ?use_capture target handler =
+let seq_loop ?(cancel_handler = false) evh ?use_capture target handler =
let cancelled = ref false in
let cur = ref (fst (Lwt.task ())) in
- let t, w = Lwt.task () in
- Lwt.on_cancel t (fun () -> Lwt.cancel !cur; cancelled := true);
+ let lt, lw = Lwt.task () in
+ Lwt.on_cancel lt (fun () -> if cancel_handler then Lwt.cancel !cur; cancelled := true);
let rec aux () =
if not !cancelled (* In the case it has been cancelled
during the previous handler,
@@ -55,13 +55,59 @@ let seq_loop evh ?use_capture target handler =
then
let t = evh ?use_capture target in
cur := t;
- t >>=
- handler >>= fun () ->
+ t >>= (fun e ->
+ handler e lt) >>= fun () ->
aux ()
else Lwt.return ()
in
Lwt.async aux;
- t
+ lt
+
+let async_loop evh ?use_capture target handler =
+ let cancelled = ref false in
+ let lt, lw = Lwt.task () in
+ Lwt.on_cancel lt (fun () -> cancelled := true);
+ let rec aux () =
+ if not !cancelled then
+ evh ?use_capture target
+ >>= (fun e -> Lwt.async (fun () -> handler e lt) ; Lwt.return ())
+ >>= aux
+ else Lwt.return ()
+ in
+ Lwt.async aux;
+ lt
+
+let buffered_loop ?(cancel_handler = false) ?(cancel_queue = true) evh ?use_capture target handler =
+ let cancelled = ref false in
+ let queue = ref [] in
+ let cur = ref (fst (Lwt.task ())) in
+ let lt, lw = Lwt.task () in
+ let spawn = Lwt_condition.create () in
+ Lwt.on_cancel lt (fun () ->
+ if cancel_handler then Lwt.cancel !cur ;
+ if cancel_queue then queue := [] ;
+ cancelled := true);
+ let rec spawner () =
+ if not !cancelled then
+ evh ?use_capture target
+ >>= (fun e -> queue := e :: !queue ; Lwt_condition.signal spawn () ; Lwt.return ())
+ >>= spawner
+ else Lwt.return ()
+ in
+ let rec runner () =
+ if not !cancelled then
+ match !queue with
+ | [] -> Lwt_condition.wait spawn >>= runner
+ | e :: tl ->
+ queue := tl ;
+ cur := handler e lt ;
+ !cur >>= runner
+ else Lwt.return ()
+ in
+ Lwt.async spawner ;
+ Lwt.async runner ;
+ lt
+
let click ?use_capture target =
make_event Dom_html.Event.click ?use_capture target
102 js_of_ocaml/lib/lwt_js_events.mli
View
@@ -53,22 +53,62 @@ val make_event :
(#Dom_html.event as 'a) Js.t Dom_html.Event.typ ->
?use_capture:bool -> #Dom_html.eventTarget Js.t -> 'a Js.t Lwt.t
-(** [seq_loop (make_event ev) target handler]
- creates a looping Lwt thread that waits
- for the event [ev] to happen on [target], then execute handler,
- and start again waiting for the event.
+(** [seq_loop (make_event ev) target handler] creates a looping Lwt
+ thread that waits for the event [ev] to happen on [target], then
+ execute handler, and start again waiting for the event. Events
+ happening during the execution of the handler are ignored. See
+ [async_loop] and [buffered_loop] for alternative semantics.
For example, the [clicks] function below is defined by:
-[let clicks ?use_capture t = seq_loop click ?use_capture t]
+ [let clicks ?use_capture t = seq_loop click ?use_capture t]
The thread returned is cancellable using
{% <<a_api project="lwt" | val Lwt.cancel>> %}.
+ In order for the loop thread to be canceled from within the handler,
+ the later receives the former as its second parameter.
+ By default, cancelling the loop will not cancel the potential
+ currently running handler. This behaviour can be changed by
+ setting the [cancel_handler] parameter to true.
*)
val seq_loop :
- (?use_capture:'a -> 'b -> 'c Lwt.t) ->
- ?use_capture:'a -> 'b -> ('c -> unit Lwt.t) -> 'd Lwt.t
+ ?cancel_handler:bool ->
+ (?use_capture:bool -> 'target -> 'event Lwt.t) ->
+ ?use_capture:bool -> 'target -> ('event -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
+
+(** [async_loop] is similar to [seq_loop], but each handler runs
+ independently. No event is thus missed, but since several
+ instances of the handler can be run concurrently, it is up to the
+ programmer to ensure that they interact correctly.
+
+ Cancelling the loop will not cancel the potential currently running
+ handlers.
+*)
+val async_loop :
+ (?use_capture:bool -> 'target -> 'event Lwt.t) ->
+ ?use_capture:bool -> 'target -> ('event -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
+
+(** [buffered_loop] is similar to [seq_loop], but any event that
+ occurs during an execution of the handler is queued instead of
+ being ingnored.
+
+ No event is thus missed, but there can be a non predictible delay
+ between its trigger and its treatment. It is thus a good idea to
+ use this loop with handlers whose running time is short, so the
+ memorized event still makes sense when the handler is eventually
+ executed. It is also up to the programmer to ensure that event
+ handlers terminate so the queue will eventually be emptied.
+
+ By default, cancelling the loop will not cancel the potential
+ currently running handler, but any other queued event will be
+ dropped. This behaviour can be customized using the two optional
+ parameters [cancel_handler] and [cancel_queue].
+*)
+val buffered_loop :
+ ?cancel_handler:bool -> ?cancel_queue:bool ->
+ (?use_capture:bool -> 'target -> 'event Lwt.t) ->
+ ?use_capture:bool -> 'target -> ('event -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
(** [async t] records a thread to be executed later.
@@ -172,103 +212,103 @@ val transitionend : #Dom_html.eventTarget Js.t -> unit Lwt.t
val clicks :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.mouseEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.mouseEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val dblclicks :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.mouseEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.mouseEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val mousedowns :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.mouseEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.mouseEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val mouseups :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.mouseEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.mouseEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val mouseovers :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.mouseEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.mouseEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val mousemoves :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.mouseEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.mouseEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val mouseouts :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.mouseEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.mouseEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val keypresses :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.keyboardEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.keyboardEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val keydowns :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.keyboardEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.keyboardEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val keyups :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.keyboardEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.keyboardEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val inputs :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.event Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val changes :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.event Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val dragstarts :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.dragEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.dragEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val dragends :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.dragEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.dragEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val dragenters :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.dragEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.dragEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val dragovers :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.dragEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.dragEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val dragleaves :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.dragEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.dragEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val drags :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.dragEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.dragEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val drops :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.dragEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.dragEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val mousewheels :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- ((Dom_html.mouseEvent Js.t * (int * int)) -> unit Lwt.t) -> 'a Lwt.t
+ ((Dom_html.mouseEvent Js.t * (int * int)) -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val touchstarts :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.touchEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.touchEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val touchmoves :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.touchEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.touchEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val touchends :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.touchEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.touchEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
val touchcancels :
?use_capture:bool ->
#Dom_html.eventTarget Js.t ->
- (Dom_html.touchEvent Js.t -> unit Lwt.t) -> 'a Lwt.t
+ (Dom_html.touchEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t
(** Returns when a repaint of the window by the browser starts.
(see JS method [window.requestAnimationFrame]) *)
5 js_of_ocaml/lib/syntax/pa_deriving_Json.ml
View
@@ -109,7 +109,7 @@ module Builder(Loc : Defs.Loc) = struct
$expr$ >> in
let read = <:expr<
Deriving_Json_lexer.read_lbracket buf;
- ignore(Deriving_Json_lexer.read_bounded_int buf ~min:0 ~max:0);
+ ignore(Deriving_Json_lexer.read_tag_1 0 buf);
$readers$ >> in
wrap ~write:[dumper] ~read ()
@@ -171,7 +171,8 @@ module Builder(Loc : Defs.Loc) = struct
$Helpers.record_expression fields$ >> in
let read = <:expr<
Deriving_Json_lexer.read_lbracket buf;
- ignore(Deriving_Json_lexer.read_bounded_int buf ~min:0 ~max:0);
+ (* We allow the tag 254 in case of float record *)
+ ignore(Deriving_Json_lexer.read_tag_2 0 254 buf);
$readers$ >> in
wrap ~write:[dumper] ~read ()
5 toplevel/toplevel.ml
View
@@ -481,13 +481,16 @@ let run () =
Html.document##onkeydown <-
(Html.handler
(fun e -> match e##keyCode with
+ | 09 -> (* Tabulation key*)
+ textbox##value <- textbox##value##concat (_s " ");
+ Js._false
| 13 -> (* ENTER key *)
let keyEv = match Js.Opt.to_option (Html.CoerceTo.keyboardEvent e) with
| None -> assert false
| Some t -> t in
(* Special handling of ctrl key *)
if keyEv##ctrlKey = Js._true then
- textbox##value <- _s ((Js.to_string textbox##value) ^ "\n");
+ textbox##value <- textbox##value##concat (_s "\n");
if keyEv##ctrlKey = Js._true || keyEv##shiftKey = Js._true then
let rows_height = textbox##scrollHeight / (textbox##rows + 1) in
let h = string_of_int (rows_height * (textbox##rows + 1) + 20) ^ "px" in
Something went wrong with that request. Please try again.