Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge pull request #107 from cago/master

Updates and fix
  • Loading branch information...
commit eb8c01220beaea57938052682c4780b9991709e0 2 parents 6c19676 + 602d9d6
@cago cago authored
View
2  js_of_ocaml/compiler/generate.ml
@@ -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
View
2  js_of_ocaml/compiler/js_parse.ml
@@ -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;
View
9 js_of_ocaml/lib/deriving_json/deriving_Json.ml
@@ -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)
View
2  js_of_ocaml/lib/deriving_json/deriving_Json_lexer.mli
@@ -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
View
20 js_of_ocaml/lib/deriving_json/deriving_Json_lexer.mll
@@ -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
View
58 js_of_ocaml/lib/lwt_js_events.ml
@@ -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
View
102 js_of_ocaml/lib/lwt_js_events.mli
@@ -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]) *)
View
5 js_of_ocaml/lib/syntax/pa_deriving_Json.ml
@@ -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 ()
View
5 toplevel/toplevel.ml
@@ -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
Please sign in to comment.
Something went wrong with that request. Please try again.