markup expects either \
- one data-math, one data-run or zero attribute"
+ | `Elt (("code" | "quote"), [("data-run", _)], children) :: rest ->
+ parse_code [] children
+ >>= fun code ->
+ let code =
+ String.trim
+ (Str.(global_replace (regexp "\\( *\n[ \t]*\\)+")) " " code)
+ in
+ parse_text (Code {code; runnable = true} :: acc) rest
+ | `Elt (("code" | "quote"), _, _) :: _ ->
+ fail
+ "the markup expects either one data-math, one data-run or \
+ zero attribute"
| `Elt (("strong" | "em" | "b"), _, children) :: rest ->
- parse_text [] children >>= fun contents ->
- parse_text (Emph contents :: acc) rest
- | `Elt (tag, _, _) :: _ ->
- fail "unsupported markup <%s> in text" tag in
+ parse_text [] children
+ >>= fun contents -> parse_text (Emph contents :: acc) rest
+ | `Elt (tag, _, _) :: _ -> fail "unsupported markup <%s> in text" tag
+ in
let rec parse_contents ?(require_p = true) acc = function
| `Elt ("p", _, children) :: rest ->
- parse_text [] children >>= fun contents ->
+ parse_text [] children
+ >>= fun contents ->
parse_contents ~require_p (Paragraph contents :: acc) rest
- | `Elt ("ul" | "ol" as tag, _, children) :: rest ->
+ | `Elt ((("ul" | "ol") as tag), _, children) :: rest ->
let rec parse_items tag acc = function
| [] -> Lwt.return (List.rev acc)
| `Elt ("li", _, children) :: rest ->
- parse_contents ~require_p: false [] children >>= fun contents ->
- parse_items tag (contents :: acc) rest
- | _ -> fail "unexpected non element in <%s>" tag in
- parse_items tag [] children >>= fun items ->
- parse_contents ~require_p (Enum items :: acc) rest
+ parse_contents ~require_p:false [] children
+ >>= fun contents -> parse_items tag (contents :: acc) rest
+ | _ -> fail "unexpected non element in <%s>" tag
+ in
+ parse_items tag [] children
+ >>= fun items -> parse_contents ~require_p (Enum items :: acc) rest
| `Elt ("pre", [], children) :: rest ->
- parse_code [] children >>= fun code ->
+ parse_code [] children
+ >>= fun code ->
let code = reshape_code_block code in
- let code_block = Code_block { code ; runnable = false } in
+ let code_block = Code_block {code; runnable = false} in
parse_contents ~require_p (code_block :: acc) rest
- | `Elt ("pre", [ "data-run", _ ], children) :: rest ->
- parse_code [] children >>= fun code ->
+ | `Elt ("pre", [("data-run", _)], children) :: rest ->
+ parse_code [] children
+ >>= fun code ->
let code = reshape_code_block code in
- let code_block = Code_block { code ; runnable = true } in
+ let code_block = Code_block {code; runnable = true} in
parse_contents ~require_p (code_block :: acc) rest
- | `Elt ("pre", [ "data-math", _ ], children) :: rest ->
- parse_code [] children >>= fun code ->
+ | `Elt ("pre", [("data-math", _)], children) :: rest ->
+ parse_code [] children
+ >>= fun code ->
let code = reshape_code_block code in
- let contents = [ Math code ] in
+ let contents = [Math code] in
parse_contents ~require_p (Paragraph contents :: acc) rest
- | `Elt ("pre", _ , _) :: _ ->
- fail "the markup expects either \
- one data-math, one data-run or zero attribute"
+ | `Elt ("pre", _, _) :: _ ->
+ fail
+ "the markup expects either one data-math, one data-run or \
+ zero attribute"
| `Elt (tag, _, _) :: _ as l ->
if require_p || acc <> [] then
- fail "the only markups supported at toplevel are \
- ,
,
and
, <%s> is not allowed" tag
- else
- parse_text [] l >>= fun text ->
- Lwt.return [ Paragraph text ]
+ fail
+ "the only markups supported at toplevel are ,
,
and \
+
, <%s> is not allowed"
+ tag
+ else parse_text [] l >>= fun text -> Lwt.return [Paragraph text]
| `Text _ :: _ as l ->
if require_p || acc <> [] then
- fail "text is not allowed at the toplevel, \
- wrap it in a markup"
- else
- parse_text [] l >>= fun text ->
- Lwt.return [ Paragraph text ]
- | [] -> Lwt.return (List.rev acc) in
+ fail "text is not allowed at the toplevel, wrap it in a
markup"
+ else parse_text [] l >>= fun text -> Lwt.return [Paragraph text]
+ | [] -> Lwt.return (List.rev acc)
+ in
let rec parse_steps = function
- | acc, None, [] ->
- Lwt.return (List.rev acc)
+ | acc, None, [] -> Lwt.return (List.rev acc)
| acc, Some (step_title, sacc), [] ->
- parse_contents [] (List.rev sacc) >>= fun step_contents ->
- let acc = { step_title ; step_contents } :: acc in
+ parse_contents [] (List.rev sacc)
+ >>= fun step_contents ->
+ let acc = {step_title; step_contents} :: acc in
Lwt.return (List.rev acc)
| acc, None, `Elt ("h2", _, title) :: rest ->
- parse_text [] title >>= fun step_title ->
- parse_steps (acc, Some (step_title, []), rest)
+ parse_text [] title
+ >>= fun step_title -> parse_steps (acc, Some (step_title, []), rest)
| _, None, _ :: _ ->
- fail "step title (
markup) expected \
- after the tutorial title ( markup)"
+ fail
+ "step title ( markup) expected after the tutorial title ( \
+ markup)"
| acc, Some (step_title, sacc), (`Elt ("h2", _, _) :: _ as rest) ->
- parse_contents [] (List.rev sacc) >>= fun step_contents ->
- let acc = { step_title ; step_contents } :: acc in
+ parse_contents [] (List.rev sacc)
+ >>= fun step_contents ->
+ let acc = {step_title; step_contents} :: acc in
parse_steps (acc, None, rest)
| acc, Some (step_title, sacc), elt :: rest ->
- parse_steps (acc, Some (step_title, elt :: sacc), rest) in
+ parse_steps (acc, Some (step_title, elt :: sacc), rest)
+ in
match tree with
| None -> fail "unparsable HTML file"
- | Some tree -> match strip tree with
- | `Elt ("html", _, [ `Elt ("head", _, _) ; `Elt ("body", _, contents) ])
- | `Elt ("html", _, [ `Elt ("body", _, contents) ]) ->
- begin match contents with
- | `Elt ("h1", _, title) :: rest ->
- parse_text [] title >>= fun title ->
- parse_steps ([], None, rest) >>= fun steps ->
- Lwt.return
- (Index.{ title ; name = tutorial_name },
- { title ; steps })
- | _ ->
- fail "tutorial title ( markup) expected \
- at the beginning of the "
- end
- | _ -> fail "wrong HTML structure, \
- expecting a standard with a "
+ | Some tree -> (
+ match strip tree with
+ | `Elt ("html", _, [`Elt ("head", _, _); `Elt ("body", _, contents)])
+ |`Elt ("html", _, [`Elt ("body", _, contents)]) -> (
+ match contents with
+ | `Elt ("h1", _, title) :: rest ->
+ parse_text [] title
+ >>= fun title ->
+ parse_steps ([], None, rest)
+ >>= fun steps ->
+ Lwt.return (Index.{title; name = tutorial_name}, {title; steps})
+ | _ ->
+ fail
+ "tutorial title ( markup) expected at the beginning of the \
+ " )
+ | _ ->
+ fail "wrong HTML structure, expecting a standard with a "
+ )
let parse_md_tutorial ~tutorial_name ~file_name =
let fail fmt =
Format.kasprintf
(fun res -> Lwt.fail_with (Format.sprintf "in file %s, %s" file_name res))
- fmt in
- Lwt_io.(with_file ~mode: Input) file_name @@ fun chan ->
- Lwt_io.read chan >>= fun str ->
+ fmt
+ in
+ Lwt_io.(with_file ~mode:Input) file_name
+ @@ fun chan ->
+ Lwt_io.read chan
+ >>= fun str ->
let strip md =
let rec strip acc = function
| [] -> List.rev acc
| Omd.NL :: rest -> strip acc rest
- | oth :: rest -> strip (oth :: acc) rest in
- strip [] md in
+ | oth :: rest -> strip (oth :: acc) rest
+ in
+ strip [] md
+ in
let rec parse_text acc = function
| [] -> Lwt.return (List.rev acc)
| Omd.NL :: rest -> parse_text acc rest
@@ -275,60 +306,63 @@ let parse_md_tutorial ~tutorial_name ~file_name =
parse_text acc (Omd.Text (t1 ^ " " ^ t2) :: rest)
| Omd.Text t1 :: Omd.Text t2 :: rest ->
parse_text acc (Omd.Text (t1 ^ t2) :: rest)
- | Omd.Text text :: rest ->
- parse_text (Text text :: acc) rest
+ | Omd.Text text :: rest -> parse_text (Text text :: acc) rest
| Omd.Emph t :: rest | Omd.Bold t :: rest ->
- parse_text [] t >>= fun text ->
- parse_text (Emph text :: acc) rest
- | elt :: _ ->
- fail "unexpected content in text (%s)"
- (Omd.to_markdown [ elt ]) in
+ parse_text [] t >>= fun text -> parse_text (Emph text :: acc) rest
+ | elt :: _ ->
+ fail "unexpected content in text (%s)" (Omd.to_markdown [elt])
+ in
let rec parse_contents acc = function
| (Omd.Ul l | Omd.Ol l | Omd.Ulp l | Omd.Olp l) :: rest ->
- Lwt_list.map_p (parse_contents []) l >>= fun items ->
- parse_contents (Enum items :: acc) rest
+ Lwt_list.map_p (parse_contents []) l
+ >>= fun items -> parse_contents (Enum items :: acc) rest
| Omd.Paragraph children :: rest ->
- parse_text [] children >>= fun contents ->
- parse_contents (Paragraph contents :: acc) rest
+ parse_text [] children
+ >>= fun contents -> parse_contents (Paragraph contents :: acc) rest
| Omd.Code_block (_, code) :: rest ->
- let blocks = List.map (fun code ->
- match parse_md_code_notation (code ^ "\n") with
- | Code code -> Code_block code
- | contents -> Paragraph [ contents ])
- (Re.split (Re.compile (Re.str "\n\n")) code) in
+ let blocks =
+ List.map
+ (fun code ->
+ match parse_md_code_notation (code ^ "\n") with
+ | Code code -> Code_block code
+ | contents -> Paragraph [contents] )
+ (Re.split (Re.compile (Re.str "\n\n")) code)
+ in
parse_contents (List.rev blocks @ acc) rest
| elt :: _ ->
- fail "unexpected content at toplevel (%s)"
- (Omd.to_markdown [ elt ])
- | [] -> Lwt.return (List.rev acc) in
+ fail "unexpected content at toplevel (%s)" (Omd.to_markdown [elt])
+ | [] -> Lwt.return (List.rev acc)
+ in
let rec parse_steps = function
- | acc, None, [] ->
- Lwt.return (List.rev acc)
+ | acc, None, [] -> Lwt.return (List.rev acc)
| acc, Some (step_title, sacc), [] ->
- parse_contents [] (List.rev sacc) >>= fun step_contents ->
- let acc = { step_title ; step_contents } :: acc in
+ parse_contents [] (List.rev sacc)
+ >>= fun step_contents ->
+ let acc = {step_title; step_contents} :: acc in
Lwt.return (List.rev acc)
| acc, None, Omd.H2 title :: rest ->
- parse_text [] title >>= fun step_title ->
- parse_steps (acc, Some (step_title, []), rest)
+ parse_text [] title
+ >>= fun step_title -> parse_steps (acc, Some (step_title, []), rest)
| _, None, _ :: _ ->
- fail "step title ( markup) expected \
- after the tutorial title ( markup)"
+ fail
+ "step title ( markup) expected after the tutorial title ( \
+ markup)"
| acc, Some (step_title, sacc), (Omd.H2 _ :: _ as rest) ->
- parse_contents [] (List.rev sacc) >>= fun step_contents ->
- let acc = { step_title ; step_contents } :: acc in
+ parse_contents [] (List.rev sacc)
+ >>= fun step_contents ->
+ let acc = {step_title; step_contents} :: acc in
parse_steps (acc, None, rest)
| acc, Some (step_title, sacc), elt :: rest ->
- parse_steps (acc, Some (step_title, elt :: sacc), rest) in
+ parse_steps (acc, Some (step_title, elt :: sacc), rest)
+ in
match Omd.of_string str |> strip with
| Omd.H1 title :: rest ->
- parse_text [] title >>= fun title ->
- parse_steps ([], None, rest) >>= fun steps ->
- Lwt.return
- (Index.{ title ; name = tutorial_name },
- { title ; steps })
- | _ ->
- fail "expecting a level 1 title at file beginning"
+ parse_text [] title
+ >>= fun title ->
+ parse_steps ([], None, rest)
+ >>= fun steps ->
+ Lwt.return (Index.{title; name = tutorial_name}, {title; steps})
+ | _ -> fail "expecting a level 1 title at file beginning"
let print_html_tutorial ~tutorial_name tutorial =
let buffer = Buffer.create 10000 in
@@ -336,86 +370,91 @@ let print_html_tutorial ~tutorial_name tutorial =
let utf8_of_cp =
let tmp = Buffer.create 513 in
fun cp ->
- Buffer.clear tmp ;
- Uutf.Buffer.add_utf_8 tmp cp ;
- Buffer.contents tmp in
+ Buffer.clear tmp;
+ Uutf.Buffer.add_utf_8 tmp cp;
+ Buffer.contents tmp
+ in
let pp_escaped ppf t =
- Uutf.String.fold_utf_8 (fun () _ cp ->
+ Uutf.String.fold_utf_8
+ (fun () _ cp ->
match cp with
- | `Uchar c ->
- begin match Uchar.to_int c with
- | 0x20 -> Format.fprintf ppf "@ "
- | 0x26 -> Format.fprintf ppf "&"
- | 0x3C -> Format.fprintf ppf "<"
- | 0x3E -> Format.fprintf ppf ">"
- | 0xA0 -> Format.fprintf ppf " "
- | _ -> Format.fprintf ppf "%s" (utf8_of_cp c)
- end
- | `Malformed _ -> ())() t in
+ | `Uchar c -> (
+ match Uchar.to_int c with
+ | 0x20 -> Format.fprintf ppf "@ "
+ | 0x26 -> Format.fprintf ppf "&"
+ | 0x3C -> Format.fprintf ppf "<"
+ | 0x3E -> Format.fprintf ppf ">"
+ | 0xA0 -> Format.fprintf ppf " "
+ | _ -> Format.fprintf ppf "%s" (utf8_of_cp c) )
+ | `Malformed _ -> () )
+ () t
+ in
let rec pp_text ppf = function
| [] -> ()
- | Code { code ; runnable = false} :: rest ->
- Format.fprintf ppf "%a" pp_escaped code ;
- if rest <> [] then Format.fprintf ppf "@ " ;
+ | Code {code; runnable = false} :: rest ->
+ Format.fprintf ppf "%a" pp_escaped code;
+ if rest <> [] then Format.fprintf ppf "@ ";
pp_text ppf rest
- | Code { code ; runnable = true} :: rest ->
- Format.fprintf ppf "%a" pp_escaped code ;
- if rest <> [] then Format.fprintf ppf "@ " ;
+ | Code {code; runnable = true} :: rest ->
+ Format.fprintf ppf "%a" pp_escaped code;
+ if rest <> [] then Format.fprintf ppf "@ ";
pp_text ppf rest
- | Math code :: rest ->
- Format.fprintf ppf "" pp_escaped code ;
- if rest <> [] then Format.fprintf ppf "@ " ;
+ | Math code :: rest ->
+ Format.fprintf ppf ""
+ pp_escaped code;
+ if rest <> [] then Format.fprintf ppf "@ ";
pp_text ppf rest
- | Emph text :: rest ->
- Format.fprintf ppf "%a" pp_text text ;
- if rest <> [] then Format.fprintf ppf "@ " ;
+ | Emph text :: rest ->
+ Format.fprintf ppf "%a" pp_text text;
+ if rest <> [] then Format.fprintf ppf "@ ";
pp_text ppf rest
| Text t :: rest ->
- pp_escaped ppf t ;
- if rest <> [] then Format.fprintf ppf "@ " ;
- pp_text ppf rest
- | _ -> assert false in
+ pp_escaped ppf t;
+ if rest <> [] then Format.fprintf ppf "@ ";
+ pp_text ppf rest
+ | _ -> assert false
+ in
let rec pp_content ppf = function
- | Code_block { code ; runnable } ->
- Format.fprintf ppf "@[@," (if runnable then " data-run" else "") ;
- let code = reshape_code_block code in
- Uutf.String.fold_utf_8 (fun () _ cp ->
- match cp with
- | `Uchar c ->
- begin match Uchar.to_int c with
+ | Code_block {code; runnable} ->
+ Format.fprintf ppf "@[@,"
+ (if runnable then " data-run" else "");
+ let code = reshape_code_block code in
+ Uutf.String.fold_utf_8
+ (fun () _ cp ->
+ match cp with
+ | `Uchar c -> (
+ match Uchar.to_int c with
| 0x26 -> Format.fprintf ppf "&"
| 0x3C -> Format.fprintf ppf "<"
| 0x3E -> Format.fprintf ppf ">"
| 0xA0 -> Format.fprintf ppf " "
- | _ -> Format.fprintf ppf "%s" (utf8_of_cp c)
- end
- | `Malformed _ -> ()) () code ;
- Format.fprintf ppf "@]@,
"
- | Paragraph text ->
- Format.fprintf ppf "@[%a@]
" pp_text text
+ | _ -> Format.fprintf ppf "%s" (utf8_of_cp c) )
+ | `Malformed _ -> () )
+ () code;
+ Format.fprintf ppf "@]@,"
+ | Paragraph text -> Format.fprintf ppf "@[%a@]
" pp_text text
| Enum items ->
- let pp_item ppf contents =
- Format.fprintf ppf "@[%a@] "
- (Format.pp_print_list pp_content) contents in
- Format.fprintf ppf "@[%a@]
"
- (Format.pp_print_list pp_item) items in
- let pp_step ppf { step_title ; step_contents } =
- Format.fprintf ppf "@[%a
@]@,%a"
- pp_text step_title
- (Format.pp_print_list pp_content) step_contents in
- Format.fprintf ppf "@[@,\
- @[@,\
- @,\
- %s @]@,\
- @,\
- @[@,\
- @[%a
@]@,\
- %a@]@,\
- @]@,\
- @."
- tutorial_name
- pp_text tutorial.title
- (Format.pp_print_list pp_step) tutorial.steps ;
+ let pp_item ppf contents =
+ Format.fprintf ppf "@[%a@] "
+ (Format.pp_print_list pp_content)
+ contents
+ in
+ Format.fprintf ppf "@[%a@]
"
+ (Format.pp_print_list pp_item)
+ items
+ in
+ let pp_step ppf {step_title; step_contents} =
+ Format.fprintf ppf "@[%a
@]@,%a" pp_text step_title
+ (Format.pp_print_list pp_content)
+ step_contents
+ in
+ Format.fprintf ppf
+ "@[@,@[@,@,%s @]@,@,@[@,@[%a
@]@,%a@]@,@]@,@."
+ tutorial_name pp_text tutorial.title
+ (Format.pp_print_list pp_step)
+ tutorial.steps;
Buffer.contents buffer
let print_md_tutorial tutorial =
@@ -423,62 +462,67 @@ let print_md_tutorial tutorial =
let ppf = Format.formatter_of_buffer buffer in
let pp_sep ppf () = Format.fprintf ppf "@,@," in
let drop_newlines code =
- Stringext.split ~on:'\n' code
- |> List.map String.trim
- |> String.concat " " in
+ Stringext.split ~on:'\n' code |> List.map String.trim |> String.concat " "
+ in
let rec pp_text ppf = function
| [] -> ()
- | Code { code ; runnable = false} :: rest ->
+ | Code {code; runnable = false} :: rest ->
let code = drop_newlines code in
- let code = Omd_backend.markdown_of_md [ Omd.Code ("", code) ] in
- Format.fprintf ppf "%s" code ;
- if rest <> [] then Format.fprintf ppf "@ " ;
+ let code = Omd_backend.markdown_of_md [Omd.Code ("", code)] in
+ Format.fprintf ppf "%s" code;
+ if rest <> [] then Format.fprintf ppf "@ ";
pp_text ppf rest
- | Code { code ; runnable = true} :: rest ->
+ | Code {code; runnable = true} :: rest ->
let code = drop_newlines code in
- let code = Omd_backend.markdown_of_md [ Omd.Code ("", "| " ^ code ^ " |") ] in
- Format.fprintf ppf "%s" code ;
+ let code =
+ Omd_backend.markdown_of_md [Omd.Code ("", "| " ^ code ^ " |")]
+ in
+ Format.fprintf ppf "%s" code;
pp_text ppf rest
- | Math code :: rest ->
+ | Math code :: rest ->
let code = drop_newlines code in
- let code = Omd_backend.markdown_of_md [ Omd.Code ("", "$ " ^ code ^ " $") ] in
- Format.fprintf ppf "%s" code ;
- if rest <> [] then Format.fprintf ppf "@ " ;
+ let code =
+ Omd_backend.markdown_of_md [Omd.Code ("", "$ " ^ code ^ " $")]
+ in
+ Format.fprintf ppf "%s" code;
+ if rest <> [] then Format.fprintf ppf "@ ";
pp_text ppf rest
- | Emph text :: rest ->
- Format.fprintf ppf "*%a*@," pp_text text ;
- if rest <> [] then Format.fprintf ppf "@ " ;
+ | Emph text :: rest ->
+ Format.fprintf ppf "*%a*@," pp_text text;
+ if rest <> [] then Format.fprintf ppf "@ ";
pp_text ppf rest
| Text t :: rest ->
- Format.pp_print_text ppf
- (Omd_backend.escape_markdown_characters t) ;
- if rest <> [] then Format.fprintf ppf "@ " ;
+ Format.pp_print_text ppf (Omd_backend.escape_markdown_characters t);
+ if rest <> [] then Format.fprintf ppf "@ ";
pp_text ppf rest
- | _ -> assert false in
+ | _ -> assert false
+ in
let rec pp_content ppf = function
- | Code_block { code ; runnable} ->
+ | Code_block {code; runnable} ->
let prefix = if runnable then "| " else "" in
let lines = Stringext.split ~on:'\n' code in
Format.pp_print_list
(fun ppf -> Format.fprintf ppf " %s%s" prefix)
ppf lines
- | Paragraph text ->
- Format.fprintf ppf "@[%a@]" pp_text text
+ | Paragraph text -> Format.fprintf ppf "@[%a@]" pp_text text
| Enum items ->
Format.pp_print_list ~pp_sep
(fun ppf item ->
- Format.fprintf ppf "@[ * %a@]"
- (Format.pp_print_list ~pp_sep pp_content) item)
- ppf items in
- let pp_step ppf { step_title ; step_contents } =
+ Format.fprintf ppf "@[ * %a@]"
+ (Format.pp_print_list ~pp_sep pp_content)
+ item )
+ ppf items
+ in
+ let pp_step ppf {step_title; step_contents} =
let title = Format.asprintf "@[%a@]" pp_text step_title in
- Format.fprintf ppf "%s@,%s@,@,%a"
- title (String.make (String.length title) '-')
- (Format.pp_print_list ~pp_sep pp_content) step_contents in
+ Format.fprintf ppf "%s@,%s@,@,%a" title
+ (String.make (String.length title) '-')
+ (Format.pp_print_list ~pp_sep pp_content)
+ step_contents
+ in
let title = Format.asprintf "@[%a@]" pp_text tutorial.title in
- Format.fprintf ppf "@[\
- %s@,%s@,@,\
- %a@."
- title (String.make (String.length title) '=')
- (Format.pp_print_list ~pp_sep pp_step) tutorial.steps ;
+ Format.fprintf ppf "@[%s@,%s@,@,%a@." title
+ (String.make (String.length title) '=')
+ (Format.pp_print_list ~pp_sep pp_step)
+ tutorial.steps;
Buffer.contents buffer
diff --git a/src/repo/learnocaml_tutorial_parser.mli b/src/repo/learnocaml_tutorial_parser.mli
index 24052d52e..0ad983b5a 100644
--- a/src/repo/learnocaml_tutorial_parser.mli
+++ b/src/repo/learnocaml_tutorial_parser.mli
@@ -9,20 +9,15 @@
open Learnocaml_data
val parse_md_tutorial :
- tutorial_name: string ->
- file_name: string ->
- (Tutorial.Index.entry * Tutorial.t) Lwt.t
+ tutorial_name:string
+ -> file_name:string
+ -> (Tutorial.Index.entry * Tutorial.t) Lwt.t
val parse_html_tutorial :
- tutorial_name: string ->
- file_name: string ->
- (Tutorial.Index.entry * Tutorial.t) Lwt.t
+ tutorial_name:string
+ -> file_name:string
+ -> (Tutorial.Index.entry * Tutorial.t) Lwt.t
-val print_html_tutorial :
- tutorial_name: string ->
- Tutorial.t ->
- string
+val print_html_tutorial : tutorial_name:string -> Tutorial.t -> string
-val print_md_tutorial :
- Tutorial.t ->
- string
+val print_md_tutorial : Tutorial.t -> string
diff --git a/src/repo/learnocaml_tutorial_reader_main.ml b/src/repo/learnocaml_tutorial_reader_main.ml
index 3e034fda6..b68ac6996 100644
--- a/src/repo/learnocaml_tutorial_reader_main.ml
+++ b/src/repo/learnocaml_tutorial_reader_main.ml
@@ -17,13 +17,17 @@ let output_html = ref None
(* If and where to export the tutorial as Markdown. *)
let output_md = ref None
-let args = Arg.align @@
- [ "-output-json", Arg.String (fun s -> output_json := Some s),
- "PATH export the tutorial in JSON format in the given file" ;
- "-output-html", Arg.String (fun s -> output_html := Some s),
- "PATH export the tutorial in HTML format in the given file" ;
- "-output-md", Arg.String (fun s -> output_md := Some s),
- "PATH export the tutorial in Markdown format in the given file" ]
+let args =
+ Arg.align
+ @@ [ ( "-output-json"
+ , Arg.String (fun s -> output_json := Some s)
+ , "PATH export the tutorial in JSON format in the given file" )
+ ; ( "-output-html"
+ , Arg.String (fun s -> output_html := Some s)
+ , "PATH export the tutorial in HTML format in the given file" )
+ ; ( "-output-md"
+ , Arg.String (fun s -> output_md := Some s)
+ , "PATH export the tutorial in Markdown format in the given file" ) ]
open Lwt.Infix
@@ -31,75 +35,87 @@ let main () =
let tutos = ref [] in
let anon_fun tuto = tutos := tuto :: !tutos in
let usage_msg =
- "Usage: ./learnocaml-tutorial-reader [options] " in
- Arg.parse args anon_fun usage_msg ;
+ "Usage: ./learnocaml-tutorial-reader [options] "
+ in
+ Arg.parse args anon_fun usage_msg;
exit
(Lwt_main.run
(Lwt.catch
(fun () ->
- match !tutos with
- | [] ->
- Format.eprintf "A tutorial file is expected.@." ;
- Lwt.return 1
- | _ :: _ :: _ ->
- Format.eprintf "A single tutorial file is expected.@." ;
- Lwt.return 1
- | [ file_name ] ->
- let tutorial_name =
- Filename.basename (Filename.chop_extension file_name) in
- begin if Filename.check_suffix file_name ".html" then
- Learnocaml_tutorial_parser.parse_html_tutorial ~tutorial_name ~file_name
- else if Filename.check_suffix file_name ".md" then
- Learnocaml_tutorial_parser.parse_md_tutorial ~tutorial_name ~file_name
- else if Filename.check_suffix file_name ".json" then
- Lwt_io.with_file ~mode: Lwt_io.Input file_name @@ fun chan ->
- Lwt_io.read chan >>= fun text ->
- let json =
- Ezjsonm.from_string text in
- let tutorial =
- Json_encoding.destruct Tutorial.enc json in
- let title = tutorial.Tutorial.title in
- Lwt.return
- (Tutorial.Index.{ name = tutorial_name ; title }, tutorial)
- else
- Lwt.fail_with "unrecognized file extension, expecting .md, .html or .json"
- end >>= fun (_, tutorial) ->
- Lwt.join
- [ begin match !output_html with
- | None -> Lwt.return ()
- | Some file_name ->
- let text =
- Learnocaml_tutorial_parser.print_html_tutorial
- ~tutorial_name tutorial in
- Lwt_io.with_file ~mode: Lwt_io.Output file_name @@ fun chan ->
- Lwt_io.write chan text
- end ;
- begin match !output_md with
- | None -> Lwt.return ()
- | Some file_name ->
- let text = Learnocaml_tutorial_parser.print_md_tutorial tutorial in
- Lwt_io.with_file ~mode: Lwt_io.Output file_name @@ fun chan ->
- Lwt_io.write chan text
- end ;
- begin match !output_json with
- | None -> Lwt.return ()
- | Some file_name ->
- let json =
- Json_encoding.construct Tutorial.enc tutorial in
- match json with
- | `O _ | `A _ as json ->
- Lwt_io.with_file ~mode: Lwt_io.Output file_name @@ fun chan ->
- let text = Ezjsonm.to_string json in
- Lwt_io.write chan text
- | _ -> assert false
- end ] >>= fun () ->
- Lwt.return 0)
+ match !tutos with
+ | [] ->
+ Format.eprintf "A tutorial file is expected.@.";
+ Lwt.return 1
+ | _ :: _ :: _ ->
+ Format.eprintf "A single tutorial file is expected.@.";
+ Lwt.return 1
+ | [file_name] ->
+ let tutorial_name =
+ Filename.basename (Filename.chop_extension file_name)
+ in
+ ( if Filename.check_suffix file_name ".html" then
+ Learnocaml_tutorial_parser.parse_html_tutorial ~tutorial_name
+ ~file_name
+ else if Filename.check_suffix file_name ".md" then
+ Learnocaml_tutorial_parser.parse_md_tutorial ~tutorial_name
+ ~file_name
+ else if Filename.check_suffix file_name ".json" then
+ Lwt_io.with_file ~mode:Lwt_io.Input file_name
+ @@ fun chan ->
+ Lwt_io.read chan
+ >>= fun text ->
+ let json = Ezjsonm.from_string text in
+ let tutorial = Json_encoding.destruct Tutorial.enc json in
+ let title = tutorial.Tutorial.title in
+ Lwt.return
+ (Tutorial.Index.{name = tutorial_name; title}, tutorial)
+ else
+ Lwt.fail_with
+ "unrecognized file extension, expecting .md, .html or .json"
+ )
+ >>= fun (_, tutorial) ->
+ Lwt.join
+ [ ( match !output_html with
+ | None -> Lwt.return ()
+ | Some file_name ->
+ let text =
+ Learnocaml_tutorial_parser.print_html_tutorial
+ ~tutorial_name tutorial
+ in
+ Lwt_io.with_file ~mode:Lwt_io.Output file_name
+ @@ fun chan -> Lwt_io.write chan text )
+ ; ( match !output_md with
+ | None -> Lwt.return ()
+ | Some file_name ->
+ let text =
+ Learnocaml_tutorial_parser.print_md_tutorial tutorial
+ in
+ Lwt_io.with_file ~mode:Lwt_io.Output file_name
+ @@ fun chan -> Lwt_io.write chan text )
+ ; ( match !output_json with
+ | None -> Lwt.return ()
+ | Some file_name -> (
+ let json =
+ Json_encoding.construct Tutorial.enc tutorial
+ in
+ match json with
+ | (`O _ | `A _) as json ->
+ Lwt_io.with_file ~mode:Lwt_io.Output file_name
+ @@ fun chan ->
+ let text = Ezjsonm.to_string json in
+ Lwt_io.write chan text
+ | _ -> assert false ) ) ]
+ >>= fun () -> Lwt.return 0 )
(fun exn ->
- let print_unknown ppf = function
- | Failure msg -> Format.fprintf ppf "Cannot process tutorial: %s" msg
- | exn -> Format.fprintf ppf "Cannot process tutorial: %s" (Printexc.to_string exn) in
- Json_encoding.print_error ~print_unknown Format.err_formatter exn ;
- Format.eprintf "@." ;
- Lwt.return 1)))
+ let print_unknown ppf = function
+ | Failure msg ->
+ Format.fprintf ppf "Cannot process tutorial: %s" msg
+ | exn ->
+ Format.fprintf ppf "Cannot process tutorial: %s"
+ (Printexc.to_string exn)
+ in
+ Json_encoding.print_error ~print_unknown Format.err_formatter exn;
+ Format.eprintf "@.";
+ Lwt.return 1 )))
let () = main ()
diff --git a/src/server/learnocaml_server.ml b/src/server/learnocaml_server.ml
index bcb01291d..82c94cd61 100644
--- a/src/server/learnocaml_server.ml
+++ b/src/server/learnocaml_server.ml
@@ -17,24 +17,26 @@ let log_channel = ref (Some stdout)
let base_url = ref ""
-let args = Arg.align @@
- [ "-static-dir", Arg.Set_string static_dir,
- "PATH where static files should be found (./www)" ;
- "-sync-dir", Arg.Set_string sync_dir,
- "PATH where sync tokens are stored (./sync)" ;
- "-base-url", Arg.Set_string base_url,
- "BASE_URL of the website. \
- Should not end with a trailing slash. \
- Currently, this has no effect on the native backend. \
- Mandatory for 'learn-ocaml build' if the site is not hosted in path '/', \
- which typically occurs for static deployment." ;
- "-port", Arg.Set_int port,
- "PORT the TCP port (8080)" ]
+let args =
+ Arg.align
+ @@ [ ( "-static-dir"
+ , Arg.Set_string static_dir
+ , "PATH where static files should be found (./www)" )
+ ; ( "-sync-dir"
+ , Arg.Set_string sync_dir
+ , "PATH where sync tokens are stored (./sync)" )
+ ; ( "-base-url"
+ , Arg.Set_string base_url
+ , "BASE_URL of the website. Should not end with a trailing slash. \
+ Currently, this has no effect on the native backend. Mandatory for \
+ 'learn-ocaml build' if the site is not hosted in path '/', which \
+ typically occurs for static deployment." )
+ ; ("-port", Arg.Set_int port, "PORT the TCP port (8080)") ]
open Lwt.Infix
let read_static_file path =
- Lwt_io.(with_file ~mode: Input (sanitise_path !static_dir path) read)
+ Lwt_io.(with_file ~mode:Input (sanitise_path !static_dir path) read)
exception Too_long_body
@@ -43,23 +45,17 @@ let string_of_stream ?(max_size = 1024 * 1024) s =
let pos = ref 0 in
let add_string s =
pos := !pos + String.length s;
- if !pos > max_size then
- Lwt.fail Too_long_body
- else begin
- Buffer.add_string b s;
- Lwt.return_unit
- end
+ if !pos > max_size then Lwt.fail Too_long_body
+ else ( Buffer.add_string b s; Lwt.return_unit )
in
- Lwt.catch begin function () ->
- Lwt_stream.iter_s add_string s >>= fun () ->
- Lwt.return (Some (Buffer.contents b))
- end begin function
- | Too_long_body -> Lwt.return None
- | e -> Lwt.fail e
- end
+ Lwt.catch
+ (function
+ | () ->
+ Lwt_stream.iter_s add_string s
+ >>= fun () -> Lwt.return (Some (Buffer.contents b)))
+ (function Too_long_body -> Lwt.return None | e -> Lwt.fail e)
module Api = Learnocaml_api
-
open Cohttp_lwt_unix
type cache_request_hash = string list
@@ -67,88 +63,79 @@ type cache_request_hash = string list
(** nocache, shortcache, longcache indicates the client-side caching. The
associated key is used for server-side caching *)
type caching =
- | Nocache (* dynamic resources *)
- | Shortcache of cache_request_hash option (* valid for the server lifetime *)
- | Longcache of cache_request_hash (* static resources *)
+ | Nocache
+ (* dynamic resources *)
+ | Shortcache of cache_request_hash option
+ (* valid for the server lifetime *)
+ | Longcache of cache_request_hash
+
+(* static resources *)
-type cached_response = {
- body: string;
- deflated_body: string option;
- content_type: string;
- caching: caching;
-}
+type cached_response =
+ { body : string
+ ; deflated_body : string option
+ ; content_type : string
+ ; caching : caching }
type 'a response =
- | Response of { contents: 'a;
- content_type: string;
- caching: caching }
+ | Response of {contents : 'a; content_type : string; caching : caching}
| Cached of cached_response
-type error = (Cohttp.Code.status_code * string)
+type error = Cohttp.Code.status_code * string
-let caching: type resp. resp Api.request -> caching = function
+let caching : type resp. resp Api.request -> caching = function
| Api.Version () -> Shortcache (Some ["version"; "server_id"])
- | Api.Static ("fonts"::_ | "icons"::_ | "js"::_::_::_ as p) -> Longcache p
- | Api.Static ("css"::_ | "js"::_ | _ as p) -> Shortcache (Some p)
-
+ | Api.Static (("fonts" :: _ | "icons" :: _ | "js" :: _ :: _ :: _) as p) ->
+ Longcache p
+ | Api.Static (("css" :: _ | "js" :: _ | _) as p) -> Shortcache (Some p)
| Api.Exercise _ -> Nocache
-
| Api.Lesson_index () -> Shortcache (Some ["lessons"])
- | Api.Lesson id -> Shortcache (Some ["lesson";id])
+ | Api.Lesson id -> Shortcache (Some ["lesson"; id])
| Api.Tutorial_index () -> Shortcache (Some ["tutorials"])
- | Api.Tutorial id -> Shortcache (Some ["tutorial";id])
-
+ | Api.Tutorial id -> Shortcache (Some ["tutorial"; id])
| _ -> Nocache
let lwt_ok r = Lwt.return (Ok r)
+
let lwt_fail e = Lwt.return (Error e)
-let ( >?= ) x f =
- x >>= function
- | Ok x -> f x
- | Error x -> lwt_fail x
+let ( >?= ) x f = x >>= function Ok x -> f x | Error x -> lwt_fail x
-let lwt_catch_fail f e =
- Lwt.catch f (fun exn -> lwt_fail @@ e exn)
+let lwt_catch_fail f e = Lwt.catch f (fun exn -> lwt_fail @@ e exn)
-let lwt_option_fail x e f =
- match x with
- | Some x -> f x
- | None -> lwt_fail e
+let lwt_option_fail x e f = match x with Some x -> f x | None -> lwt_fail e
let respond_static caching path =
lwt_catch_fail
(fun () ->
- read_static_file path >>= fun contents ->
- let content_type =
- Magic_mime.lookup (List.fold_left (fun _ r -> r) "" path)
- in
- lwt_ok @@ Response { contents; content_type; caching })
+ read_static_file path
+ >>= fun contents ->
+ let content_type =
+ Magic_mime.lookup (List.fold_left (fun _ r -> r) "" path)
+ in
+ lwt_ok @@ Response {contents; content_type; caching} )
(fun e -> (`Not_found, Printexc.to_string e))
let respond_json caching contents =
- lwt_ok @@
- Response { contents;
- content_type = "application/json";
- caching }
+ lwt_ok @@ Response {contents; content_type = "application/json"; caching}
let verify_teacher_token token =
- Token.check_teacher token >>= function
- | true -> lwt_ok ()
- | false -> lwt_fail (`Forbidden,"Access restricted")
+ Token.check_teacher token
+ >>= function
+ | true -> lwt_ok () | false -> lwt_fail (`Forbidden, "Access restricted")
let string_of_date ts =
let open Unix in
let tm = gmtime ts in
- Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ"
- (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
- tm.tm_hour tm.tm_min tm.tm_sec
+ Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ" (tm.tm_year + 1900)
+ (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec
let log conn api_req =
match !log_channel with
| None -> ()
| Some oc ->
- let src_addr = match conn with
+ let src_addr =
+ match conn with
| Conduit_lwt_unix.TCP tcp, _ ->
Ipaddr.to_string tcp.Conduit_lwt_unix.ip
| _ -> ""
@@ -158,18 +145,17 @@ let log conn api_req =
output_string oc src_addr;
output_char oc '\t';
output_string oc
- (match api_req.Api.meth with
- | `GET -> "GET "
- | `POST _ -> "POST");
+ (match api_req.Api.meth with `GET -> "GET " | `POST _ -> "POST");
output_char oc '\t';
output_char oc '/';
output_string oc (String.concat "/" api_req.Api.path);
- (match api_req.Api.args with | [] -> () | l ->
+ ( match api_req.Api.args with
+ | [] -> ()
+ | l ->
output_char oc '?';
output_string oc
- (String.concat "&" (List.map (fun (a, b) -> a ^"="^ b) l)));
- output_char oc '\n';
- flush oc
+ (String.concat "&" (List.map (fun (a, b) -> a ^ "=" ^ b) l)) );
+ output_char oc '\n'; flush oc
let check_report exo report grade =
let max_grade = Learnocaml_exercise.(access File.max_score) exo in
@@ -177,151 +163,156 @@ let check_report exo report grade =
score * 100 / max_grade = grade
module Memory_cache = struct
-
- let (tbl: (cache_request_hash, cached_response) Hashtbl.t) =
+ let (tbl : (cache_request_hash, cached_response) Hashtbl.t) =
Hashtbl.create 533
- let get key =
- try Some (Hashtbl.find tbl key) with Not_found -> None
-
- let add key entry =
- Hashtbl.replace tbl key entry
+ let get key = try Some (Hashtbl.find tbl key) with Not_found -> None
+ let add key entry = Hashtbl.replace tbl key entry
end
module Request_handler = struct
-
type 'a ret = ('a response, error) result Lwt.t
let map_ret f r =
- r >?= function
- | Response ({contents; _} as r) -> lwt_ok @@ Response {r with contents = f contents}
- | (Cached _) as r -> lwt_ok r
+ r
+ >?= function
+ | Response ({contents; _} as r) ->
+ lwt_ok @@ Response {r with contents = f contents}
+ | Cached _ as r -> lwt_ok r
+
+ let alphanum =
+ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
- let alphanum = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
let alphanum_len = String.length alphanum
let nonce_req : (string, string) Hashtbl.t = Hashtbl.create 533
let token_save_mutex = Lwt_utils.gen_mutex_table ()
- let rec string_of_endp =
- function
- | `TCP (i,_) -> Some (Ipaddr.to_string i)
+ let rec string_of_endp = function
+ | `TCP (i, _) -> Some (Ipaddr.to_string i)
| `Unix_domain_socket s -> Some s
- | `Vchan_direct (i,_) -> Some (string_of_int i)
- | `Vchan_domain_socket (u,v) -> Some (u ^ v)
- | `TLS (s,e) ->
- begin
- match string_of_endp e with
- | Some s' -> Some (s ^ s')
- | None -> None
- end
+ | `Vchan_direct (i, _) -> Some (string_of_int i)
+ | `Vchan_domain_socket (u, v) -> Some (u ^ v)
+ | `TLS (s, e) -> (
+ match string_of_endp e with Some s' -> Some (s ^ s') | None -> None )
| `Unknown _ -> None
let valid_string_of_endp e =
- lwt_option_fail
- (string_of_endp e)
+ lwt_option_fail (string_of_endp e)
(`Forbidden, "No address information avaible")
lwt_ok
- let callback_raw: type resp. Conduit.endp -> Learnocaml_data.Server.config ->
- caching -> resp Api.request ->
- (resp response, error) result Lwt.t
- = let module ServerData = Learnocaml_data.Server in
- fun conn config cache -> function
+ let callback_raw : type resp.
+ Conduit.endp
+ -> Learnocaml_data.Server.config
+ -> caching
+ -> resp Api.request
+ -> (resp response, error) result Lwt.t =
+ let module ServerData = Learnocaml_data.Server in
+ fun conn config cache -> function
| Api.Version () ->
- respond_json cache (Api.version, config.ServerData.server_id)
- | Api.Static path ->
- respond_static cache path
+ respond_json cache (Api.version, config.ServerData.server_id)
+ | Api.Static path -> respond_static cache path
| Api.Nonce () ->
- valid_string_of_endp conn
- >?= fun conn ->
- let nonce =
- match Hashtbl.find_opt nonce_req conn with
- | Some old -> old
- | None ->
- let nonce = String.init 20 (fun _ -> alphanum.[Random.int alphanum_len]) in
- Hashtbl.add nonce_req conn nonce;
- nonce
- in respond_json cache nonce
+ valid_string_of_endp conn
+ >?= fun conn ->
+ let nonce =
+ match Hashtbl.find_opt nonce_req conn with
+ | Some old -> old
+ | None ->
+ let nonce =
+ String.init 20 (fun _ -> alphanum.[Random.int alphanum_len])
+ in
+ Hashtbl.add nonce_req conn nonce;
+ nonce
+ in
+ respond_json cache nonce
| Api.Create_token (secret_candidate, None, nick) ->
- valid_string_of_endp conn
- >?= fun conn ->
- lwt_option_fail
- (Hashtbl.find_opt nonce_req conn)
- (`Forbidden, "No registered token for your address")
- @@ fun nonce ->
- Hashtbl.remove nonce_req conn;
- let know_secret =
- match config.ServerData.secret with
- | None -> true
- | Some x -> Sha.sha512 (nonce ^ x) = secret_candidate in
- if not know_secret
- then lwt_fail (`Forbidden, "Bad secret")
- else
- Token.create_student ()
- >>= fun tok ->
- (match nick with | None -> Lwt.return_unit
- | Some nickname ->
- Save.set tok Save.{empty with nickname})
- >>= fun () -> respond_json cache tok
+ valid_string_of_endp conn
+ >?= fun conn ->
+ lwt_option_fail
+ (Hashtbl.find_opt nonce_req conn)
+ (`Forbidden, "No registered token for your address")
+ @@ fun nonce ->
+ Hashtbl.remove nonce_req conn;
+ let know_secret =
+ match config.ServerData.secret with
+ | None -> true
+ | Some x -> Sha.sha512 (nonce ^ x) = secret_candidate
+ in
+ if not know_secret then lwt_fail (`Forbidden, "Bad secret")
+ else
+ Token.create_student ()
+ >>= fun tok ->
+ ( match nick with
+ | None -> Lwt.return_unit
+ | Some nickname -> Save.set tok Save.{empty with nickname} )
+ >>= fun () -> respond_json cache tok
| Api.Create_token (_secret_candidate, Some token, _nick) ->
- lwt_catch_fail
- (fun () -> Token.register token >>= fun () -> respond_json cache token)
+ lwt_catch_fail
+ (fun () ->
+ Token.register token >>= fun () -> respond_json cache token )
(function
- | Failure body -> (`Bad_request, body)
- | exn -> (`Internal_server_error, Printexc.to_string exn))
+ | Failure body -> (`Bad_request, body)
+ | exn -> (`Internal_server_error, Printexc.to_string exn))
| Api.Create_teacher_token token ->
- verify_teacher_token token
- >?= fun () ->
- Token.create_teacher ()
- >>= respond_json cache
-
+ verify_teacher_token token
+ >?= fun () -> Token.create_teacher () >>= respond_json cache
| Api.Fetch_save token ->
- lwt_catch_fail
- (fun () ->
- Save.get token >>= fun tokopt ->
- lwt_option_fail
- tokopt
- (`Not_found, "token not found")
- (respond_json cache))
- (fun exn -> (`Internal_server_error, Printexc.to_string exn))
+ lwt_catch_fail
+ (fun () ->
+ Save.get token
+ >>= fun tokopt ->
+ lwt_option_fail tokopt
+ (`Not_found, "token not found")
+ (respond_json cache) )
+ (fun exn -> (`Internal_server_error, Printexc.to_string exn))
| Api.Archive_zip token ->
let open Lwt_process in
- let path = Filename.concat !sync_dir (Token.to_path token) in
- let cmd = shell ("git archive master --format=zip -0 --remote="^path)
+ let path = Filename.concat !sync_dir (Token.to_path token) in
+ let cmd =
+ shell ("git archive master --format=zip -0 --remote=" ^ path)
and stdout = `FD_copy Unix.stdout in
- Lwt_process.pread ~stdin:stdout cmd >>= fun contents ->
- lwt_ok @@ Response { contents = contents;
- content_type = "application/zip";
- caching = Nocache }
+ Lwt_process.pread ~stdin:stdout cmd
+ >>= fun contents ->
+ lwt_ok
+ @@ Response
+ {contents; content_type = "application/zip"; caching = Nocache}
| Api.Update_save (token, save) ->
let save = Save.fix_mtimes save in
let exercise_states = SMap.bindings save.Save.all_exercise_states in
- (Token.check_teacher token >>= function
- | true -> Lwt.return exercise_states
- | false ->
- Lwt_list.filter_s (fun (id, _) ->
- Exercise.Status.is_open id token >|= function
- | `Open -> true
- | `Closed -> false
- | `Deadline t -> t >= -300. (* Grace period! *))
- exercise_states)
+ Token.check_teacher token
+ >>= (function
+ | true -> Lwt.return exercise_states
+ | false ->
+ Lwt_list.filter_s
+ (fun (id, _) ->
+ Exercise.Status.is_open id token
+ >|= function
+ | `Open -> true
+ | `Closed -> false
+ | `Deadline t -> t >= -300.
+ (* Grace period! *) )
+ exercise_states)
>>= fun valid_exercise_states ->
let save =
{ save with
Save.all_exercise_states =
- List.fold_left (fun m (id,save) -> SMap.add id save m)
+ List.fold_left
+ (fun m (id, save) -> SMap.add id save m)
SMap.empty valid_exercise_states }
in
- token_save_mutex.Lwt_utils.with_lock (token :> Token.t) (fun () ->
- Save.get token >>= fun x ->
- lwt_option_fail x
- (`Not_found, Token.to_string token)
+ token_save_mutex.Lwt_utils.with_lock
+ (token :> Token.t)
+ (fun () ->
+ Save.get token
+ >>= fun x ->
+ lwt_option_fail x (`Not_found, Token.to_string token)
@@ fun prev_save ->
- let save = Save.sync prev_save save in
- Save.set token save >>= fun () -> respond_json cache save)
+ let save = Save.sync prev_save save in
+ Save.set token save >>= fun () -> respond_json cache save )
| Api.Git (token, path) ->
let prefix =
let ( / ) = Filename.concat in
@@ -330,296 +321,319 @@ module Request_handler = struct
let path = sanitise_path prefix path in
lwt_catch_fail
(fun () ->
- Lwt_io.(with_file ~mode:Input path read) >>= fun contents ->
- lwt_ok @@
- Response { contents;
- content_type = "application/octet-stream";
- caching = Nocache })
+ Lwt_io.(with_file ~mode:Input path read)
+ >>= fun contents ->
+ lwt_ok
+ @@ Response
+ { contents
+ ; content_type = "application/octet-stream"
+ ; caching = Nocache } )
(fun e -> (`Not_found, Printexc.to_string e))
-
| Api.Students_list token ->
- verify_teacher_token token >?= fun () ->
- Student.Index.get ()
- >>= respond_json cache
+ verify_teacher_token token
+ >?= fun () -> Student.Index.get () >>= respond_json cache
| Api.Set_students_list (token, students) ->
- verify_teacher_token token >?= fun () ->
+ verify_teacher_token token
+ >?= fun () ->
Lwt_list.map_s
(fun (ancestor, ours) ->
- let token = ancestor.Student.token in
- Student.get token >|= fun theirs ->
- let theirs = match theirs with
- | None -> Student.default token
- | Some std -> std
- in
- Student.three_way_merge ~ancestor ~theirs ~ours)
- students >>=
- Student.Index.set
- >>= respond_json cache
+ let token = ancestor.Student.token in
+ Student.get token
+ >|= fun theirs ->
+ let theirs =
+ match theirs with
+ | None -> Student.default token
+ | Some std -> std
+ in
+ Student.three_way_merge ~ancestor ~theirs ~ours )
+ students
+ >>= Student.Index.set >>= respond_json cache
| Api.Students_csv (token, exercises, students) ->
- verify_teacher_token token >?= fun () ->
- (match students with
- | [] -> Token.Index.get () >|= List.filter Token.is_student
- | l -> Lwt.return l)
+ verify_teacher_token token
+ >?= fun () ->
+ ( match students with
+ | [] -> Token.Index.get () >|= List.filter Token.is_student
+ | l -> Lwt.return l )
>>= Lwt_list.map_p (fun token ->
- Save.get token >|= fun save -> token, save)
+ Save.get token >|= fun save -> (token, save) )
>>= fun tok_saves ->
let all_exercises =
match exercises with
| [] ->
- List.fold_left (fun acc (_tok, save) ->
+ List.fold_left
+ (fun acc (_tok, save) ->
match save with
| None -> acc
| Some save ->
- SMap.fold (fun ex_id _ans acc -> SSet.add ex_id acc)
- save.Save.all_exercise_states
- acc)
+ SMap.fold
+ (fun ex_id _ans acc -> SSet.add ex_id acc)
+ save.Save.all_exercise_states acc )
SSet.empty tok_saves
|> SSet.elements
| exercises -> exercises
in
let columns =
- "token" :: "nickname" ::
- (List.fold_left (fun acc ex_id ->
- (ex_id ^ " grade") ::
- (ex_id ^ " date") ::
- acc)
- [] (List.rev all_exercises))
+ "token" :: "nickname"
+ :: List.fold_left
+ (fun acc ex_id ->
+ (ex_id ^ " grade") :: (ex_id ^ " date") :: acc )
+ [] (List.rev all_exercises)
in
let buf = Buffer.create 3497 in
let sep () = Buffer.add_char buf ',' in
let line () = Buffer.add_char buf '\n' in
Buffer.add_string buf (String.concat "," columns);
line ();
- Lwt_list.iter_s (fun (tok, save) ->
- match save with None -> Lwt.return_unit | Some save ->
- Buffer.add_string buf (Token.to_string tok);
- sep ();
- Buffer.add_string buf save.Save.nickname;
- Lwt_list.iter_s (fun ex_id ->
- Lwt.catch (fun () ->
- sep ();
- Exercise.get ex_id >>= fun exo ->
- Lwt.wrap2 SMap.find ex_id save.Save.all_exercise_states
- >|= fun st ->
- (match st.Answer.grade with
- | None -> ()
- | Some grade ->
- if match st.Answer.report with
- | None -> false
- | Some rep -> check_report exo rep grade
- then Buffer.add_string buf (string_of_int grade)
- else Printf.bprintf buf "CHEAT(%d)" grade);
- sep ();
- Buffer.add_string buf (string_of_date st.Answer.mtime))
- (function
- | Not_found -> sep (); Lwt.return_unit
- | e -> raise e))
- all_exercises
- >|= line)
+ Lwt_list.iter_s
+ (fun (tok, save) ->
+ match save with
+ | None -> Lwt.return_unit
+ | Some save ->
+ Buffer.add_string buf (Token.to_string tok);
+ sep ();
+ Buffer.add_string buf save.Save.nickname;
+ Lwt_list.iter_s
+ (fun ex_id ->
+ Lwt.catch
+ (fun () ->
+ sep ();
+ Exercise.get ex_id
+ >>= fun exo ->
+ Lwt.wrap2 SMap.find ex_id
+ save.Save.all_exercise_states
+ >|= fun st ->
+ ( match st.Answer.grade with
+ | None -> ()
+ | Some grade ->
+ if
+ match st.Answer.report with
+ | None -> false
+ | Some rep -> check_report exo rep grade
+ then Buffer.add_string buf (string_of_int grade)
+ else Printf.bprintf buf "CHEAT(%d)" grade );
+ sep ();
+ Buffer.add_string buf
+ (string_of_date st.Answer.mtime) )
+ (function
+ | Not_found -> sep (); Lwt.return_unit | e -> raise e)
+ )
+ all_exercises
+ >|= line )
tok_saves
>>= fun () ->
- lwt_ok @@
- Response {contents = Buffer.contents buf;
- content_type = "text/csv";
- caching = Nocache}
-
+ lwt_ok
+ @@ Response
+ { contents = Buffer.contents buf
+ ; content_type = "text/csv"
+ ; caching = Nocache }
| Api.Exercise_index (Some token) ->
- Exercise.Index.get () >>= fun index ->
- Token.check_teacher token >>= (function
- | true -> Lwt.return (index, [])
- | false ->
- let deadlines = ref [] in
- Exercise.Index.filterk
- (fun id _ k ->
- Exercise.Status.is_open id token >>= function
- | `Open -> k true
- | `Closed -> k false
- | `Deadline t ->
- deadlines := (id, max t 0.) :: !deadlines;
- k true)
- index (fun index -> Lwt.return (index, !deadlines)))
+ Exercise.Index.get ()
+ >>= fun index ->
+ Token.check_teacher token
+ >>= (function
+ | true -> Lwt.return (index, [])
+ | false ->
+ let deadlines = ref [] in
+ Exercise.Index.filterk
+ (fun id _ k ->
+ Exercise.Status.is_open id token
+ >>= function
+ | `Open -> k true
+ | `Closed -> k false
+ | `Deadline t ->
+ deadlines := (id, max t 0.) :: !deadlines;
+ k true )
+ index
+ (fun index -> Lwt.return (index, !deadlines)))
>>= respond_json cache
- | Api.Exercise_index None ->
- lwt_fail (`Forbidden, "Forbidden")
-
- | Api.Exercise (Some token, id) ->
- (Exercise.Status.is_open id token >>= function
- | `Open | `Deadline _ as o ->
- Exercise.Meta.get id >>= fun meta ->
- Exercise.get id >>= fun ex ->
+ | Api.Exercise_index None -> lwt_fail (`Forbidden, "Forbidden")
+ | Api.Exercise (Some token, id) -> (
+ Exercise.Status.is_open id token
+ >>= function
+ | (`Open | `Deadline _) as o ->
+ Exercise.Meta.get id
+ >>= fun meta ->
+ Exercise.get id
+ >>= fun ex ->
respond_json cache
- (meta, ex,
- match o with `Deadline t -> Some (max t 0.) | `Open -> None)
- | `Closed ->
- lwt_fail (`Forbidden, "Exercise closed"))
- | Api.Exercise (None, _) ->
- lwt_fail (`Forbidden, "Forbidden")
-
- | Api.Lesson_index () ->
- Lesson.Index.get () >>= respond_json cache
- | Api.Lesson id ->
- Lesson.get id >>= respond_json cache
-
- | Api.Tutorial_index () ->
- Tutorial.Index.get () >>= respond_json cache
- | Api.Tutorial id ->
- Tutorial.get id >>= respond_json cache
-
+ ( meta
+ , ex
+ , match o with `Deadline t -> Some (max t 0.) | `Open -> None
+ )
+ | `Closed -> lwt_fail (`Forbidden, "Exercise closed") )
+ | Api.Exercise (None, _) -> lwt_fail (`Forbidden, "Forbidden")
+ | Api.Lesson_index () -> Lesson.Index.get () >>= respond_json cache
+ | Api.Lesson id -> Lesson.get id >>= respond_json cache
+ | Api.Tutorial_index () -> Tutorial.Index.get () >>= respond_json cache
+ | Api.Tutorial id -> Tutorial.get id >>= respond_json cache
| Api.Playground_index () ->
Playground.Index.get () >>= respond_json cache
- | Api.Playground id ->
- Playground.get id >>= respond_json cache
-
+ | Api.Playground id -> Playground.get id >>= respond_json cache
| Api.Exercise_status_index token ->
- verify_teacher_token token >?= fun () ->
- Exercise.Status.all () >>= respond_json cache
+ verify_teacher_token token
+ >?= fun () -> Exercise.Status.all () >>= respond_json cache
| Api.Exercise_status (token, id) ->
- verify_teacher_token token >?= fun () ->
- Exercise.Status.get id >>= respond_json cache
+ verify_teacher_token token
+ >?= fun () -> Exercise.Status.get id >>= respond_json cache
| Api.Set_exercise_status (token, status) ->
- verify_teacher_token token >?= fun () ->
+ verify_teacher_token token
+ >?= fun () ->
Lwt_list.iter_s
- Exercise.Status.(fun (ancestor, ours) ->
- get ancestor.id >>= fun theirs ->
- set (three_way_merge ~ancestor ~theirs ~ours))
+ Exercise.Status.(
+ fun (ancestor, ours) ->
+ get ancestor.id
+ >>= fun theirs -> set (three_way_merge ~ancestor ~theirs ~ours))
status
>>= respond_json cache
-
| Api.Partition (token, eid, fid, prof) ->
- lwt_catch_fail (fun () ->
- verify_teacher_token token
- >?= fun () ->
- Learnocaml_partition_create.partition eid fid prof
- >>= respond_json cache
- )
- (fun exn -> (`Not_found, Printexc.to_string exn))
-
- | Api.Invalid_request body ->
- lwt_fail (`Bad_request, body)
-
- let callback: type resp. Conduit.endp ->
- Learnocaml_data.Server.config ->
- resp Api.request -> resp ret
- = fun conn config req ->
+ lwt_catch_fail
+ (fun () ->
+ verify_teacher_token token
+ >?= fun () ->
+ Learnocaml_partition_create.partition eid fid prof
+ >>= respond_json cache )
+ (fun exn -> (`Not_found, Printexc.to_string exn))
+ | Api.Invalid_request body -> lwt_fail (`Bad_request, body)
+
+ let callback : type resp.
+ Conduit.endp
+ -> Learnocaml_data.Server.config
+ -> resp Api.request
+ -> resp ret =
+ fun conn config req ->
let cache = caching req in
let respond () =
Lwt.catch
(fun () -> callback_raw conn config cache req)
(function
- | Not_found ->
- lwt_fail (`Not_found, "Component not found")
+ | Not_found -> lwt_fail (`Not_found, "Component not found")
| e -> raise e)
in
match cache with
| Nocache | Shortcache None -> respond ()
- | Longcache key | Shortcache (Some key) ->
- match Memory_cache.get key with
- | Some c -> lwt_ok (Cached c)
- | None -> respond ()
-
+ | Longcache key | Shortcache (Some key) -> (
+ match Memory_cache.get key with
+ | Some c -> lwt_ok (Cached c)
+ | None -> respond () )
end
module Api_server = Api.Server (Json_codec) (Request_handler)
let init_teacher_token () =
- Token.Index.get () >>= function tokens ->
+ Token.Index.get ()
+ >>= function
+ | tokens -> (
match List.filter Token.is_teacher tokens with
| [] ->
- Token.create_teacher () >|= fun token ->
+ Token.create_teacher ()
+ >|= fun token ->
Printf.printf "Initial teacher token created: %s\n%!"
(Token.to_string token)
| teachers ->
Printf.printf "Found the following teacher tokens:\n - %s\n%!"
(String.concat "\n - " (List.map Token.to_string teachers));
- Lwt.return_unit
+ Lwt.return_unit )
-let last_modified = (* server startup time *)
+let last_modified =
+ (* server startup time *)
let open Unix in
let tm = gmtime (gettimeofday ()) in
Printf.sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT"
- (match tm.tm_wday with
- | 0 -> "Sun" | 1 -> "Mon" | 2 -> "Tue" | 3 -> "Wed"
- | 4 -> "Thu" | 5 -> "Fri" | 6 -> "Sat"
- | _ -> assert false)
+ ( match tm.tm_wday with
+ | 0 -> "Sun"
+ | 1 -> "Mon"
+ | 2 -> "Tue"
+ | 3 -> "Wed"
+ | 4 -> "Thu"
+ | 5 -> "Fri"
+ | 6 -> "Sat"
+ | _ -> assert false )
tm.tm_mday
- (match tm.tm_mon with
- | 0 -> "Jan" | 1 -> "Feb" | 2 -> "Mar" | 3 -> "Apr" | 4 -> "May"
- | 5 -> "Jun" | 6 -> "Jul" | 7 -> "Aug" | 8 -> "Sep" | 9 -> "Oct"
- | 10 -> "Nov" | 11 -> "Dec" | _ -> assert false)
- (tm.tm_year + 1900)
- tm.tm_hour tm.tm_min tm.tm_sec
+ ( match tm.tm_mon with
+ | 0 -> "Jan"
+ | 1 -> "Feb"
+ | 2 -> "Mar"
+ | 3 -> "Apr"
+ | 4 -> "May"
+ | 5 -> "Jun"
+ | 6 -> "Jul"
+ | 7 -> "Aug"
+ | 8 -> "Sep"
+ | 9 -> "Oct"
+ | 10 -> "Nov"
+ | 11 -> "Dec"
+ | _ -> assert false )
+ (tm.tm_year + 1900) tm.tm_hour tm.tm_min tm.tm_sec
(* Taken from the source of "decompress", from bin/easy.ml *)
let compress ?(level = 4) data =
let input_buffer = Bytes.create 0xFFFF in
let output_buffer = Bytes.create 0xFFFF in
-
let pos = ref 0 in
let res = Buffer.create (String.length data) in
-
Lwt_preemptive.detach
- (Decompress.Zlib_deflate.bytes
- input_buffer
- output_buffer
+ (Decompress.Zlib_deflate.bytes input_buffer output_buffer
(fun input_buffer -> function
- | Some max ->
- let n = min max (min 0xFFFF (String.length data - !pos)) in
- Bytes.blit_string data !pos input_buffer 0 n;
- pos := !pos + n;
- n
- | None ->
- let n = min 0xFFFF (String.length data - !pos) in
- Bytes.blit_string data !pos input_buffer 0 n;
- pos := !pos + n;
- n)
+ | Some max ->
+ let n = min max (min 0xFFFF (String.length data - !pos)) in
+ Bytes.blit_string data !pos input_buffer 0 n;
+ pos := !pos + n;
+ n
+ | None ->
+ let n = min 0xFFFF (String.length data - !pos) in
+ Bytes.blit_string data !pos input_buffer 0 n;
+ pos := !pos + n;
+ n )
(fun output_buffer len ->
- Buffer.add_subbytes res output_buffer 0 len;
- 0xFFFF))
+ Buffer.add_subbytes res output_buffer 0 len;
+ 0xFFFF ))
(Decompress.Zlib_deflate.default ~witness:Decompress.B.bytes level)
>>= function
| Ok _ -> Lwt.return (Buffer.contents res)
| Error _ -> Lwt.fail_with "Could not compress"
let launch () =
- Random.self_init () ;
- Learnocaml_store.Server.get () >>= fun config ->
+ Random.self_init ();
+ Learnocaml_store.Server.get ()
+ >>= fun config ->
let callback conn req body =
let uri = Request.uri req in
let path = Uri.path uri in
let path = Stringext.split ~on:'/' path in
let path =
let rec clean = function
- | [] | [_] as l -> l
- | ""::l -> clean l
- | s::l -> s::clean l
+ | ([] | [_]) as l -> l
+ | "" :: l -> clean l
+ | s :: l -> s :: clean l
in
clean path
in
let path = List.map Uri.pct_decode path in
let query = Uri.query uri in
- let args = List.map (fun (s, l) -> s, String.concat "," l) query in
+ let args = List.map (fun (s, l) -> (s, String.concat "," l)) query in
let use_compression =
- List.exists (function _, Cohttp.Accept.Deflate -> true | _ -> false)
+ List.exists
+ (function _, Cohttp.Accept.Deflate -> true | _ -> false)
(Cohttp.Header.get_acceptable_encodings req.Request.headers)
in
let respond = function
- | Response {contents=body; content_type; caching; _}
- | Cached {body; content_type; caching; _} as resp ->
+ | ( Response {contents = body; content_type; caching; _}
+ | Cached {body; content_type; caching; _} ) as resp ->
let headers = Cohttp.Header.init_with "Content-Type" content_type in
- let headers = match caching with
+ let headers =
+ match caching with
| Longcache _ ->
- Cohttp.Header.add headers
- "Cache-Control" "public, immutable, max-age=2592000"
- (* 1 month *)
+ Cohttp.Header.add headers "Cache-Control"
+ "public, immutable, max-age=2592000"
+ (* 1 month *)
| Shortcache _ ->
- Cohttp.Header.add_list headers [
- "Last-Modified", last_modified;
- "Cache-Control", "private, must-revalidate";
- ]
- | Nocache ->
- Cohttp.Header.add headers "Cache-Control" "no-cache"
+ Cohttp.Header.add_list headers
+ [ ("Last-Modified", last_modified)
+ ; ("Cache-Control", "private, must-revalidate") ]
+ | Nocache -> Cohttp.Header.add headers "Cache-Control" "no-cache"
in
- let resp = match resp, caching with
+ let resp =
+ match (resp, caching) with
| Response _, (Longcache key | Shortcache (Some key)) ->
let cached =
{body; deflated_body = None; content_type; caching}
@@ -628,72 +642,77 @@ let launch () =
Cached cached
| _ -> resp
in
- Lwt.try_bind (fun () ->
- if use_compression && String.length body >= 1024 &&
- match String.split_on_char '/' content_type with
- | "text"::_
- | "application" :: ("javascript" | "json") :: _
- | "image" :: ("gif" | "svg+xml") :: _ -> true
- | _ -> false
+ Lwt.try_bind
+ (fun () ->
+ if
+ use_compression
+ && String.length body >= 1024
+ &&
+ match String.split_on_char '/' content_type with
+ | "text" :: _
+ |"application" :: ("javascript" | "json") :: _
+ |"image" :: ("gif" | "svg+xml") :: _ ->
+ true
+ | _ -> false
then
- (match resp with
- | Cached {deflated_body = Some s; _} -> Lwt.return s
- | Cached
- ({deflated_body = None;
- caching = Longcache key | Shortcache Some key;
- _ } as c) ->
- compress body >|= fun s ->
- Memory_cache.add key {c with deflated_body = Some s};
- s
- | _ -> compress body) >|= fun s ->
- Cohttp.Header.add headers "Content-Encoding" "deflate", s
- else
- Lwt.return (headers, body))
+ ( match resp with
+ | Cached {deflated_body = Some s; _} -> Lwt.return s
+ | Cached
+ ( { deflated_body = None
+ ; caching = Longcache key | Shortcache (Some key); _ } as
+ c ) ->
+ compress body
+ >|= fun s ->
+ Memory_cache.add key {c with deflated_body = Some s};
+ s
+ | _ -> compress body )
+ >|= fun s ->
+ (Cohttp.Header.add headers "Content-Encoding" "deflate", s)
+ else Lwt.return (headers, body) )
(fun (headers, str) ->
- Server.respond_string ~headers ~status:`OK ~body:str ())
+ Server.respond_string ~headers ~status:`OK ~body:str () )
(fun e ->
Server.respond_error ~status:`Internal_server_error
- ~body:(Printexc.to_string e) ())
+ ~body:(Printexc.to_string e) () )
in
- if Cohttp.Header.get req.Request.headers "If-Modified-Since" =
- Some last_modified
+ if
+ Cohttp.Header.get req.Request.headers "If-Modified-Since"
+ = Some last_modified
then Server.respond ~status:`Not_modified ~body:Cohttp_lwt.Body.empty ()
else
- (match req.Request.meth with
- | `GET -> lwt_ok {Api.meth = `GET; path; args}
- | `POST ->
- begin
+ ( match req.Request.meth with
+ | `GET -> lwt_ok {Api.meth = `GET; path; args}
+ | `POST -> (
string_of_stream (Cohttp_lwt.Body.to_stream body)
>>= function
| Some s -> lwt_ok {Api.meth = `POST s; path; args}
- | None -> lwt_fail (`Bad_request, "Missing POST body")
- end
- | _ -> lwt_fail (`Bad_request, "Unsupported method"))
- >?= (fun req ->
- log conn req;
- Api_server.handler (Conduit_lwt_unix.endp_of_flow (fst conn)) config req)
- >>= function
- | Error (code,body) ->
- Server.respond_error ~status:code ~body ()
- | Ok response -> respond response
+ | None -> lwt_fail (`Bad_request, "Missing POST body") )
+ | _ -> lwt_fail (`Bad_request, "Unsupported method") )
+ >?= (fun req ->
+ log conn req;
+ Api_server.handler
+ (Conduit_lwt_unix.endp_of_flow (fst conn))
+ config req )
+ >>= function
+ | Error (code, body) -> Server.respond_error ~status:code ~body ()
+ | Ok response -> respond response
in
let mode =
match !cert_key_files with
- | None -> (`TCP (`Port !port))
+ | None -> `TCP (`Port !port)
| Some (crt, key) ->
`TLS (`Crt_file_path crt, `Key_file_path key, `No_password, `Port !port)
in
- init_teacher_token () >>= fun () ->
+ init_teacher_token ()
+ >>= fun () ->
Lwt.catch (fun () ->
Server.create
- ~on_exn: (function
- | Unix.Unix_error(Unix.EPIPE, "write", "") -> ()
- | exn -> raise exn)
- ~mode (Server.make ~callback ()) >>= fun () ->
- Lwt.return true)
+ ~on_exn:(function
+ | Unix.Unix_error (Unix.EPIPE, "write", "") -> () | exn -> raise exn)
+ ~mode (Server.make ~callback ())
+ >>= fun () -> Lwt.return true )
@@ function
- | Sys.Break ->
- Lwt.return true
+ | Sys.Break -> Lwt.return true
| Unix.Unix_error (Unix.EADDRINUSE, _, _) ->
Printf.eprintf
"Could not bind port %d, another instance may still be running?\n%!"
diff --git a/src/server/learnocaml_server.mli b/src/server/learnocaml_server.mli
index a1b79c7c0..ac254c09a 100644
--- a/src/server/learnocaml_server.mli
+++ b/src/server/learnocaml_server.mli
@@ -8,13 +8,15 @@
(** Configuration options *)
-val port: int ref
-val cert_key_files: (string * string) option ref
-val base_url: string ref
+val port : int ref
-val args: (Arg.key * Arg.spec * Arg.doc) list
+val cert_key_files : (string * string) option ref
+
+val base_url : string ref
+
+val args : (Arg.key * Arg.spec * Arg.doc) list
(** Main *)
(* Returns [false] if interrupted prematurely due to an error *)
-val launch: unit -> bool Lwt.t
+val launch : unit -> bool Lwt.t
diff --git a/src/state/learnocaml_api.ml b/src/state/learnocaml_api.ml
index 63043e4c3..fd85cb4bd 100644
--- a/src/state/learnocaml_api.ml
+++ b/src/state/learnocaml_api.ml
@@ -11,184 +11,130 @@ open Learnocaml_data
let version = Learnocaml_version.v
type _ request =
- | Static:
- string list -> string request
- | Version:
- unit -> (string * int) request
- | Nonce:
- unit -> string request
- | Create_token:
- string * student token option * string option -> student token request
- | Create_teacher_token:
- teacher token -> teacher token request
- | Fetch_save:
- 'a token -> Save.t request
- | Archive_zip:
- 'a token -> string request
- | Update_save:
- 'a token * Save.t -> Save.t request
- | Git: 'a token * string list -> string request
-
- | Students_list:
- teacher token -> Student.t list request
- | Set_students_list:
- teacher token * (Student.t * Student.t) list -> unit request
- | Students_csv:
- teacher token * Exercise.id list * Token.t list -> string request
-
- | Exercise_index:
- 'a token option -> (Exercise.Index.t * (Exercise.id * float) list) request
- | Exercise:
- 'a token option * string -> (Exercise.Meta.t * Exercise.t * float option) request
-
- | Lesson_index:
- unit -> (string * string) list request
- | Lesson:
- string -> Lesson.t request
-
- | Tutorial_index:
- unit -> Tutorial.Index.t request
- | Tutorial:
- string -> Tutorial.t request
-
- | Playground_index:
- unit -> Playground.Index.t request
- | Playground:
- string -> Playground.t request
-
- | Exercise_status_index:
- teacher token -> Exercise.Status.t list request
- | Exercise_status:
- teacher token * Exercise.id -> Exercise.Status.t request
- | Set_exercise_status:
- teacher token * (Exercise.Status.t * Exercise.Status.t) list -> unit request
-
- | Partition:
- teacher token * Exercise.id * string * int -> Partition.t request
-
- | Invalid_request:
- string -> string request
-
-
-type http_request = {
- meth: [ `GET | `POST of string];
- path: string list;
- args: (string * string) list;
-}
+ | Static : string list -> string request
+ | Version : unit -> (string * int) request
+ | Nonce : unit -> string request
+ | Create_token :
+ string * student token option * string option
+ -> student token request
+ | Create_teacher_token : teacher token -> teacher token request
+ | Fetch_save : 'a token -> Save.t request
+ | Archive_zip : 'a token -> string request
+ | Update_save : 'a token * Save.t -> Save.t request
+ | Git : 'a token * string list -> string request
+ | Students_list : teacher token -> Student.t list request
+ | Set_students_list :
+ teacher token * (Student.t * Student.t) list
+ -> unit request
+ | Students_csv :
+ teacher token * Exercise.id list * Token.t list
+ -> string request
+ | Exercise_index :
+ 'a token option
+ -> (Exercise.Index.t * (Exercise.id * float) list) request
+ | Exercise :
+ 'a token option * string
+ -> (Exercise.Meta.t * Exercise.t * float option) request
+ | Lesson_index : unit -> (string * string) list request
+ | Lesson : string -> Lesson.t request
+ | Tutorial_index : unit -> Tutorial.Index.t request
+ | Tutorial : string -> Tutorial.t request
+ | Playground_index : unit -> Playground.Index.t request
+ | Playground : string -> Playground.t request
+ | Exercise_status_index : teacher token -> Exercise.Status.t list request
+ | Exercise_status : teacher token * Exercise.id -> Exercise.Status.t request
+ | Set_exercise_status :
+ teacher token * (Exercise.Status.t * Exercise.Status.t) list
+ -> unit request
+ | Partition :
+ teacher token * Exercise.id * string * int
+ -> Partition.t request
+ | Invalid_request : string -> string request
+
+type http_request =
+ { meth : [`GET | `POST of string]
+ ; path : string list
+ ; args : (string * string) list }
module J = Json_encoding
module type JSON_CODEC = sig
- val decode: 'a J.encoding -> string -> 'a
- val encode: ?minify:bool -> 'a J.encoding -> 'a -> string
-end
-
-module Conversions (Json: JSON_CODEC) = struct
-
- let response_codec
- : type resp.
- resp request -> (resp -> string) * (string -> resp)
- = fun req ->
- let str = (fun x -> x), (fun x -> x) in
- let json enc = (Json.encode enc), (Json.decode enc) in
- let ( +> ) (cod, decod) (cod', decod') =
- (fun x -> cod (cod' x)),
- (fun s -> decod' (decod s))
- in
- match req with
- | Static _ -> str
- | Version _ -> json J.(obj2 (req "version" string) (req "server_id" int))
- | Nonce _ -> json J.(obj1 (req "nonce" string))
- | Create_token _ ->
- json J.(obj1 (req "token" string)) +>
- Token.(to_string, parse)
- | Create_teacher_token _ ->
- json J.(obj1 (req "token" string)) +>
- Token.(to_string, parse)
- | Fetch_save _ ->
- json Save.enc
- | Archive_zip _ ->
- str
- | Update_save _ ->
- json Save.enc
- | Git _ -> str
- | Students_list _ ->
- json (J.list Student.enc)
- | Set_students_list _ ->
- json J.unit
- | Students_csv _ ->
- str
- | Exercise_index _ ->
- json (J.tup2 Exercise.Index.enc (J.assoc J.float))
- | Exercise _ ->
- json (J.tup3 Exercise.Meta.enc Exercise.enc (J.option J.float))
- | Lesson_index _ ->
- json Lesson.Index.enc
- | Lesson _ ->
- json Lesson.enc
- | Tutorial_index _ ->
- json Tutorial.Index.enc
- | Tutorial _ ->
- json Tutorial.enc
- | Playground_index _ ->
- json Playground.Index.enc
- | Playground _ ->
- json Playground.enc
+ val decode : 'a J.encoding -> string -> 'a
- | Exercise_status_index _ ->
- json (J.list Exercise.Status.enc)
- | Exercise_status _ ->
- json Exercise.Status.enc
- | Set_exercise_status _ ->
- json J.unit
-
- | Partition _ ->
- json Partition.enc
+ val encode : ?minify:bool -> 'a J.encoding -> 'a -> string
+end
- | Invalid_request _ ->
- str
+module Conversions (Json : JSON_CODEC) = struct
+ let response_codec : type resp.
+ resp request -> (resp -> string) * (string -> resp) =
+ fun req ->
+ let str = ((fun x -> x), fun x -> x) in
+ let json enc = (Json.encode enc, Json.decode enc) in
+ let ( +> ) (cod, decod) (cod', decod') =
+ ((fun x -> cod (cod' x)), fun s -> decod' (decod s))
+ in
+ match req with
+ | Static _ -> str
+ | Version _ -> json J.(obj2 (req "version" string) (req "server_id" int))
+ | Nonce _ -> json J.(obj1 (req "nonce" string))
+ | Create_token _ ->
+ json J.(obj1 (req "token" string)) +> Token.(to_string, parse)
+ | Create_teacher_token _ ->
+ json J.(obj1 (req "token" string)) +> Token.(to_string, parse)
+ | Fetch_save _ -> json Save.enc
+ | Archive_zip _ -> str
+ | Update_save _ -> json Save.enc
+ | Git _ -> str
+ | Students_list _ -> json (J.list Student.enc)
+ | Set_students_list _ -> json J.unit
+ | Students_csv _ -> str
+ | Exercise_index _ -> json (J.tup2 Exercise.Index.enc (J.assoc J.float))
+ | Exercise _ ->
+ json (J.tup3 Exercise.Meta.enc Exercise.enc (J.option J.float))
+ | Lesson_index _ -> json Lesson.Index.enc
+ | Lesson _ -> json Lesson.enc
+ | Tutorial_index _ -> json Tutorial.Index.enc
+ | Tutorial _ -> json Tutorial.enc
+ | Playground_index _ -> json Playground.Index.enc
+ | Playground _ -> json Playground.enc
+ | Exercise_status_index _ -> json (J.list Exercise.Status.enc)
+ | Exercise_status _ -> json Exercise.Status.enc
+ | Set_exercise_status _ -> json J.unit
+ | Partition _ -> json Partition.enc
+ | Invalid_request _ -> str
let response_encode r = fst (response_codec r)
- let response_decode r = snd (response_codec r)
+ let response_decode r = snd (response_codec r)
- let to_http_request
- : type resp. resp request -> http_request
- =
- let get ?token path = {
- meth = `GET;
- path;
- args = match token with None -> [] | Some t -> ["token", Token.to_string t];
- } in
- let post ~token path body = {
- meth = `POST body;
- path;
- args = ["token", Token.to_string token];
- } in
+ let to_http_request : type resp. resp request -> http_request =
+ let get ?token path =
+ { meth = `GET
+ ; path
+ ; args =
+ ( match token with
+ | None -> []
+ | Some t -> [("token", Token.to_string t)] ) }
+ in
+ let post ~token path body =
+ {meth = `POST body; path; args = [("token", Token.to_string token)]}
+ in
function
- | Static path ->
- get path
- | Version () ->
- get ["version"]
-
- | Nonce () ->
- get ["nonce"]
+ | Static path -> get path
+ | Version () -> get ["version"]
+ | Nonce () -> get ["nonce"]
| Create_token (secret_candiate, token, nick) ->
- get ?token (["sync"; "new"; secret_candiate] @
- (match nick with None -> [] | Some n -> [n]))
+ get ?token
+ ( ["sync"; "new"; secret_candiate]
+ @ match nick with None -> [] | Some n -> [n] )
| Create_teacher_token token ->
assert (Token.is_teacher token);
get ~token ["teacher"; "new"]
-
- | Fetch_save token ->
- get ~token ["save.json"]
- | Archive_zip token ->
- get ~token ["archive.zip"]
+ | Fetch_save token -> get ~token ["save.json"]
+ | Archive_zip token -> get ~token ["archive.zip"]
| Update_save (token, save) ->
post ~token ["sync"] (Json.encode Save.enc save)
- | Git _ ->
- assert false (* Reserved for the [git] client *)
-
+ | Git _ -> assert false (* Reserved for the [git] client *)
| Students_list token ->
assert (Token.is_teacher token);
get ~token ["teacher"; "students.json"]
@@ -199,38 +145,25 @@ module Conversions (Json: JSON_CODEC) = struct
(Json.encode (J.list (J.tup2 Student.enc Student.enc)) students)
| Students_csv (token, exercises, students) ->
assert (Token.is_teacher token);
- post ~token ["teacher"; "students.csv"]
+ post ~token
+ ["teacher"; "students.csv"]
(Json.encode
(J.obj2
(J.dft "exercises" (J.list J.string) [])
(J.dft "students" (J.list Token.enc) []))
(exercises, students))
-
- | Exercise_index (Some token) ->
- get ~token ["exercise-index.json"]
- | Exercise_index None ->
- get ["exercise-index.json"]
-
+ | Exercise_index (Some token) -> get ~token ["exercise-index.json"]
+ | Exercise_index None -> get ["exercise-index.json"]
| Exercise (Some token, id) ->
- get ~token ("exercises" :: String.split_on_char '/' (id^".json"))
+ get ~token ("exercises" :: String.split_on_char '/' (id ^ ".json"))
| Exercise (None, id) ->
- get ("exercises" :: String.split_on_char '/' (id^".json"))
-
- | Lesson_index () ->
- get ["lessons.json"]
- | Lesson id ->
- get ["lessons"; id^".json"]
-
- | Playground_index () ->
- get ["playgrounds.json"]
- | Playground id ->
- get ["playgrounds"; id^".json"]
-
- | Tutorial_index () ->
- get ["tutorials.json"]
- | Tutorial id ->
- get ["tutorials"; id^".json"]
-
+ get ("exercises" :: String.split_on_char '/' (id ^ ".json"))
+ | Lesson_index () -> get ["lessons.json"]
+ | Lesson id -> get ["lessons"; id ^ ".json"]
+ | Playground_index () -> get ["playgrounds.json"]
+ | Playground id -> get ["playgrounds"; id ^ ".json"]
+ | Tutorial_index () -> get ["tutorials.json"]
+ | Tutorial id -> get ["tutorials"; id ^ ".json"]
| Exercise_status_index token ->
assert (Token.is_teacher token);
get ~token ["teacher"; "exercise-status.json"]
@@ -243,199 +176,164 @@ module Conversions (Json: JSON_CODEC) = struct
(Json.encode
(J.list (J.tup2 Exercise.Status.enc Exercise.Status.enc))
status)
-
| Partition (token, eid, fid, prof) ->
- get ~token
- ["partition"; eid; fid; string_of_int prof]
-
- | Invalid_request s ->
- failwith ("Error request "^s)
-
+ get ~token ["partition"; eid; fid; string_of_int prof]
+ | Invalid_request s -> failwith ("Error request " ^ s)
end
module type REQUEST_HANDLER = sig
type 'resp ret
- val map_ret: ('a -> 'b) -> 'a ret -> 'b ret
- val callback: Conduit.endp ->
- Learnocaml_data.Server.config -> 'resp request -> 'resp ret
-end
+ val map_ret : ('a -> 'b) -> 'a ret -> 'b ret
-module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct
+ val callback :
+ Conduit.endp -> Learnocaml_data.Server.config -> 'resp request -> 'resp ret
+end
- module C = Conversions(Json)
+module Server (Json : JSON_CODEC) (Rh : REQUEST_HANDLER) = struct
+ module C = Conversions (Json)
- let rec last =
- function [f] -> Some f | [] -> None | _::r -> last r
+ let rec last = function [f] -> Some f | [] -> None | _ :: r -> last r
let handler conn config request =
- let k req =
- Rh.callback conn config req |> Rh.map_ret (C.response_encode req)
- in
- let token =
- match List.assoc_opt "token" request.args with
- | None -> None
- | Some stoken ->
- try Some (Token.parse stoken)
- with Failure _ -> None
- in
- match request.meth, request.path, token with
- | `GET, ([] | [""]), _ ->
- Static ["index.html"] |> k
- | `GET, ["version"], _ ->
- Version () |> k
-
- | `GET, ["nonce"], _ ->
- Nonce () |> k
- | `GET, ["sync"; "new"; secret_candidate], token ->
- Create_token (secret_candidate, token, None) |> k
- | `GET, ["sync"; "new"; secret_candidate; nick], token ->
- Create_token (secret_candidate, token, Some nick) |> k
- | `GET, ["teacher"; "new"], Some token when Token.is_teacher token ->
- Create_teacher_token token |> k
-
- | `GET, ["save.json"], Some token ->
- Fetch_save token |> k
- | `GET, ["archive.zip"], Some token ->
- Archive_zip token |> k
- | `POST body, ["sync"], Some token ->
- (match Json.decode Save.enc body with
- | save -> Update_save (token, save) |> k
- | exception e -> Invalid_request (Printexc.to_string e) |> k)
- | `GET, (stoken::"learnocaml-workspace.git"::p), None ->
- (match Token.parse stoken with
- | token -> Git (token, p) |> k
- | exception Failure e -> Invalid_request e |> k)
-
- | `GET, ["teacher"; "students.json"], Some token
- when Token.is_teacher token ->
- Students_list token |> k
- | `POST body, ["teacher"; "students.json"], Some token
- when Token.is_teacher token ->
- (match Json.decode (J.list (J.tup2 Student.enc Student.enc)) body with
- | students -> Set_students_list (token, students) |> k
- | exception e -> Invalid_request (Printexc.to_string e) |> k)
- | `GET, ["teacher"; "students.csv"], Some token
- when Token.is_teacher token ->
- Students_csv (token, [], []) |> k
- | `POST body, ["teacher"; "students.csv"], Some token
- when Token.is_teacher token ->
- (match Json.decode
- (J.obj2
- (J.dft "exercises" (J.list J.string) [])
- (J.dft "students" (J.list Token.enc) []))
- body
- with
- | exercises, students ->
- Students_csv (token, exercises, students) |> k
- | exception e -> Invalid_request (Printexc.to_string e) |> k)
-
- | `GET, ["exercise-index.json"], token ->
- Exercise_index token |> k
- | `GET, ("exercises"::path), token ->
- (match last path with
- | Some s when String.lowercase_ascii (Filename.extension s) = ".json" ->
- (match token with
- | Some token ->
- let id = Filename.chop_suffix (String.concat "/" path) ".json" in
- Exercise (Some token, id) |> k
- | None -> Invalid_request "Missing token" |> k)
- | Some "" ->
- Static ["exercise.html"] |> k
- | _ ->
- Static ("static"::path) |> k)
- | `GET, ("description"::_), _token ->
- (* match token with
+ let k req =
+ Rh.callback conn config req |> Rh.map_ret (C.response_encode req)
+ in
+ let token =
+ match List.assoc_opt "token" request.args with
+ | None -> None
+ | Some stoken -> (
+ try Some (Token.parse stoken) with Failure _ -> None )
+ in
+ match (request.meth, request.path, token) with
+ | `GET, ([] | [""]), _ -> Static ["index.html"] |> k
+ | `GET, ["version"], _ -> Version () |> k
+ | `GET, ["nonce"], _ -> Nonce () |> k
+ | `GET, ["sync"; "new"; secret_candidate], token ->
+ Create_token (secret_candidate, token, None) |> k
+ | `GET, ["sync"; "new"; secret_candidate; nick], token ->
+ Create_token (secret_candidate, token, Some nick) |> k
+ | `GET, ["teacher"; "new"], Some token when Token.is_teacher token ->
+ Create_teacher_token token |> k
+ | `GET, ["save.json"], Some token -> Fetch_save token |> k
+ | `GET, ["archive.zip"], Some token -> Archive_zip token |> k
+ | `POST body, ["sync"], Some token -> (
+ match Json.decode Save.enc body with
+ | save -> Update_save (token, save) |> k
+ | exception e -> Invalid_request (Printexc.to_string e) |> k )
+ | `GET, stoken :: "learnocaml-workspace.git" :: p, None -> (
+ match Token.parse stoken with
+ | token -> Git (token, p) |> k
+ | exception Failure e -> Invalid_request e |> k )
+ | `GET, ["teacher"; "students.json"], Some token
+ when Token.is_teacher token ->
+ Students_list token |> k
+ | `POST body, ["teacher"; "students.json"], Some token
+ when Token.is_teacher token -> (
+ match Json.decode (J.list (J.tup2 Student.enc Student.enc)) body with
+ | students -> Set_students_list (token, students) |> k
+ | exception e -> Invalid_request (Printexc.to_string e) |> k )
+ | `GET, ["teacher"; "students.csv"], Some token when Token.is_teacher token
+ ->
+ Students_csv (token, [], []) |> k
+ | `POST body, ["teacher"; "students.csv"], Some token
+ when Token.is_teacher token -> (
+ match
+ Json.decode
+ (J.obj2
+ (J.dft "exercises" (J.list J.string) [])
+ (J.dft "students" (J.list Token.enc) []))
+ body
+ with
+ | exercises, students -> Students_csv (token, exercises, students) |> k
+ | exception e -> Invalid_request (Printexc.to_string e) |> k )
+ | `GET, ["exercise-index.json"], token -> Exercise_index token |> k
+ | `GET, "exercises" :: path, token -> (
+ match last path with
+ | Some s when String.lowercase_ascii (Filename.extension s) = ".json" -> (
+ match token with
+ | Some token ->
+ let id = Filename.chop_suffix (String.concat "/" path) ".json" in
+ Exercise (Some token, id) |> k
+ | None -> Invalid_request "Missing token" |> k )
+ | Some "" -> Static ["exercise.html"] |> k
+ | _ -> Static ("static" :: path) |> k )
+ | `GET, "description" :: _, _token ->
+ (* match token with
| None -> Invalid_request "Missing token" |> k *)
- Static ["description.html"] |> k
- | `GET, ("playground"::path), _token ->
- begin
- match last path with
- | Some s when String.lowercase_ascii (Filename.extension s) = ".json" ->
- let id = Filename.chop_suffix (String.concat "/" path) ".json" in
- Playground id |> k
- | Some "" ->
- Static ["playground.html"] |> k
- | _ ->
- Static ("static"::path) |> k
- end
- | `GET, ["lessons.json"], _ ->
- Lesson_index () |> k
- | `GET, ["lessons"; f], _ when Filename.check_suffix f ".json" ->
- Lesson (Filename.chop_suffix f ".json") |> k
-
- | `GET, ["tutorials.json"], _ ->
- Tutorial_index () |> k
- | `GET, ["tutorials"; f], _ when Filename.check_suffix f ".json" ->
- Tutorial (Filename.chop_suffix f ".json") |> k
-
- | `GET, ["playgrounds.json"], _ ->
- Playground_index () |> k
- | `GET, ["playgrounds"; f], _ when Filename.check_suffix f ".json" ->
- Playground (Filename.chop_suffix f ".json") |> k
-
- | `GET, ["partition"; eid; fid; prof], Some token
- when Token.is_teacher token ->
- Partition (token, eid, fid, int_of_string prof) |> k
-
- | `GET, ["teacher"; "exercise-status.json"], Some token
- when Token.is_teacher token ->
- Exercise_status_index token |> k
- | `GET, ("teacher" :: "exercise-status" :: id), Some token
- when Token.is_teacher token ->
- Exercise_status (token, String.concat "/" id) |> k
- | `POST body, ["teacher"; "exercise-status"], Some token
- when Token.is_teacher token ->
- (match Json.decode
- (J.list (J.tup2 Exercise.Status.enc Exercise.Status.enc))
- body
- with
- | status ->
- Set_exercise_status (token, status) |> k
- | exception e -> Invalid_request (Printexc.to_string e) |> k)
-
- | `GET,
- ( ["index.html"]
+ Static ["description.html"] |> k
+ | `GET, "playground" :: path, _token -> (
+ match last path with
+ | Some s when String.lowercase_ascii (Filename.extension s) = ".json" ->
+ let id = Filename.chop_suffix (String.concat "/" path) ".json" in
+ Playground id |> k
+ | Some "" -> Static ["playground.html"] |> k
+ | _ -> Static ("static" :: path) |> k )
+ | `GET, ["lessons.json"], _ -> Lesson_index () |> k
+ | `GET, ["lessons"; f], _ when Filename.check_suffix f ".json" ->
+ Lesson (Filename.chop_suffix f ".json") |> k
+ | `GET, ["tutorials.json"], _ -> Tutorial_index () |> k
+ | `GET, ["tutorials"; f], _ when Filename.check_suffix f ".json" ->
+ Tutorial (Filename.chop_suffix f ".json") |> k
+ | `GET, ["playgrounds.json"], _ -> Playground_index () |> k
+ | `GET, ["playgrounds"; f], _ when Filename.check_suffix f ".json" ->
+ Playground (Filename.chop_suffix f ".json") |> k
+ | `GET, ["partition"; eid; fid; prof], Some token
+ when Token.is_teacher token ->
+ Partition (token, eid, fid, int_of_string prof) |> k
+ | `GET, ["teacher"; "exercise-status.json"], Some token
+ when Token.is_teacher token ->
+ Exercise_status_index token |> k
+ | `GET, "teacher" :: "exercise-status" :: id, Some token
+ when Token.is_teacher token ->
+ Exercise_status (token, String.concat "/" id) |> k
+ | `POST body, ["teacher"; "exercise-status"], Some token
+ when Token.is_teacher token -> (
+ match
+ Json.decode
+ (J.list (J.tup2 Exercise.Status.enc Exercise.Status.enc))
+ body
+ with
+ | status -> Set_exercise_status (token, status) |> k
+ | exception e -> Invalid_request (Printexc.to_string e) |> k )
+ | ( `GET
+ , ( ( ["index.html"]
| ["exercise.html"]
- | ["playground.html"]
- | ["student-view.html"]
- | ["description.html"]
- | ["partition-view.html"]
- | ("js"|"fonts"|"icons"|"css"|"static") :: _ as path),
- _ ->
- Static path |> k
-
- | `GET, ["favicon.ico"], _ ->
- Static ["icons"; "favicon.ico"] |> k
-
- | meth, path, _ ->
- Invalid_request
- (Printf.sprintf "%s /%s%s"
- (match meth with `GET -> "GET" | `POST _ -> "POST")
- (String.concat "/" path)
- (match request.args with [] -> "" | l ->
- "?" ^ String.concat "&"
- (List.map (fun (k, v) -> k ^"="^ v) l)))
- |> k
-
+ | ["playground.html"]
+ | ["student-view.html"]
+ | ["description.html"]
+ | ["partition-view.html"]
+ | ("js" | "fonts" | "icons" | "css" | "static") :: _ ) as path )
+ , _ ) ->
+ Static path |> k
+ | `GET, ["favicon.ico"], _ -> Static ["icons"; "favicon.ico"] |> k
+ | meth, path, _ ->
+ Invalid_request
+ (Printf.sprintf "%s /%s%s"
+ (match meth with `GET -> "GET" | `POST _ -> "POST")
+ (String.concat "/" path)
+ ( match request.args with
+ | [] -> ""
+ | l ->
+ "?"
+ ^ String.concat "&" (List.map (fun (k, v) -> k ^ "=" ^ v) l)
+ ))
+ |> k
end
-module Client (Json: JSON_CODEC) = struct
-
+module Client (Json : JSON_CODEC) = struct
open Lwt.Infix
-
- module C = Conversions(Json)
-
- let make_request
- : type resp.
- (http_request -> (string, 'b) result Lwt.t) ->
- resp request -> (resp, 'b) result Lwt.t
- = fun send req ->
- let http_request = C.to_http_request req in
- send http_request >|= function
- | Ok str -> Ok (C.response_decode req str)
- | Error e -> Error e
-
+ module C = Conversions (Json)
+
+ let make_request : type resp.
+ (http_request -> (string, 'b) result Lwt.t)
+ -> resp request
+ -> (resp, 'b) result Lwt.t =
+ fun send req ->
+ let http_request = C.to_http_request req in
+ send http_request
+ >|= function
+ | Ok str -> Ok (C.response_decode req str) | Error e -> Error e
end
(*
diff --git a/src/state/learnocaml_api.mli b/src/state/learnocaml_api.mli
index b51db4eb2..5f3139553 100644
--- a/src/state/learnocaml_api.mli
+++ b/src/state/learnocaml_api.mli
@@ -21,110 +21,90 @@
open Learnocaml_data
-val version: string
+val version : string
type _ request =
- | Static:
- string list -> string request
- | Version:
- unit -> (string * int) request
- | Nonce:
- unit -> string request
- | Create_token:
- string * student token option * string option -> student token request
- | Create_teacher_token:
- teacher token -> teacher token request
- | Fetch_save:
- 'a token -> Save.t request
- | Archive_zip:
- 'a token -> string request
- | Update_save:
- 'a token * Save.t -> Save.t request
- | Git:
- 'a token * string list -> string request
-
- | Students_list:
- teacher token -> Student.t list request
- | Set_students_list:
- teacher token * (Student.t * Student.t) list -> unit request
- (** Does not affect the students absent from the list. the pairs are the
+ | Static : string list -> string request
+ | Version : unit -> (string * int) request
+ | Nonce : unit -> string request
+ | Create_token :
+ string * student token option * string option
+ -> student token request
+ | Create_teacher_token : teacher token -> teacher token request
+ | Fetch_save : 'a token -> Save.t request
+ | Archive_zip : 'a token -> string request
+ | Update_save : 'a token * Save.t -> Save.t request
+ | Git : 'a token * string list -> string request
+ | Students_list : teacher token -> Student.t list request
+ | Set_students_list :
+ teacher token * (Student.t * Student.t) list
+ -> unit request
+ (** Does not affect the students absent from the list. the pairs are the
before/after states, used for merging *)
- | Students_csv:
- teacher token * Exercise.id list * Token.t list -> string request
-
- | Exercise_index:
- 'a token option -> (Exercise.Index.t * (Exercise.id * float) list) request
- | Exercise:
- 'a token option * string -> (Exercise.Meta.t * Exercise.t * float option) request
-
- | Lesson_index:
- unit -> (string * string) list request
- | Lesson:
- string -> Lesson.t request
-
- | Tutorial_index:
- unit -> Tutorial.Index.t request
- | Tutorial:
- string -> Tutorial.t request
-
- | Playground_index:
- unit -> Playground.Index.t request
- | Playground:
- string -> Playground.t request
-
- | Exercise_status_index:
- teacher token -> Exercise.Status.t list request
- | Exercise_status:
- teacher token * Exercise.id -> Exercise.Status.t request
- | Set_exercise_status:
- teacher token * (Exercise.Status.t * Exercise.Status.t) list ->
- unit request
- (** The two Status.t correspond to the states before and after changes, used
+ | Students_csv :
+ teacher token * Exercise.id list * Token.t list
+ -> string request
+ | Exercise_index :
+ 'a token option
+ -> (Exercise.Index.t * (Exercise.id * float) list) request
+ | Exercise :
+ 'a token option * string
+ -> (Exercise.Meta.t * Exercise.t * float option) request
+ | Lesson_index : unit -> (string * string) list request
+ | Lesson : string -> Lesson.t request
+ | Tutorial_index : unit -> Tutorial.Index.t request
+ | Tutorial : string -> Tutorial.t request
+ | Playground_index : unit -> Playground.Index.t request
+ | Playground : string -> Playground.t request
+ | Exercise_status_index : teacher token -> Exercise.Status.t list request
+ | Exercise_status : teacher token * Exercise.id -> Exercise.Status.t request
+ | Set_exercise_status :
+ teacher token * (Exercise.Status.t * Exercise.Status.t) list
+ -> unit request
+ (** The two Status.t correspond to the states before and after changes, used
for three-way merge *)
-
- | Partition:
- teacher token * Exercise.id * string * int -> Partition.t request
-
- | Invalid_request:
- string -> string request
- (** Only for server-side handling: bound to requests not matching any case
+ | Partition :
+ teacher token * Exercise.id * string * int
+ -> Partition.t request
+ | Invalid_request : string -> string request
+ (** Only for server-side handling: bound to requests not matching any case
above *)
-type http_request = {
- meth: [ `GET | `POST of string];
- path: string list;
- args: (string * string) list;
-}
+type http_request =
+ { meth : [`GET | `POST of string]
+ ; path : string list
+ ; args : (string * string) list }
module type JSON_CODEC = sig
- val decode: 'a Json_encoding.encoding -> string -> 'a
- val encode: ?minify:bool -> 'a Json_encoding.encoding -> 'a -> string
+ val decode : 'a Json_encoding.encoding -> string -> 'a
+
+ val encode : ?minify:bool -> 'a Json_encoding.encoding -> 'a -> string
end
module type REQUEST_HANDLER = sig
type 'resp ret
- val map_ret: ('a -> 'b) -> 'a ret -> 'b ret
+ val map_ret : ('a -> 'b) -> 'a ret -> 'b ret
- val callback: Conduit.endp ->
- Learnocaml_data.Server.config -> 'resp request -> 'resp ret
+ val callback :
+ Conduit.endp -> Learnocaml_data.Server.config -> 'resp request -> 'resp ret
end
-module Server: functor (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) -> sig
-
+module Server (Json : JSON_CODEC) (Rh : REQUEST_HANDLER) : sig
+ val handler :
+ Conduit.endp
+ -> Learnocaml_data.Server.config
+ -> http_request
+ -> string Rh.ret
(** Helper to define a server: handles recognition of the incoming request, and
encoding of the response. *)
- val handler: Conduit.endp ->
- Learnocaml_data.Server.config -> http_request -> string Rh.ret
-
end
-module Client: functor (Json: JSON_CODEC) -> sig
-
+module Client (Json : JSON_CODEC) : sig
+ val make_request :
+ (http_request -> (string, 'a) result Lwt.t)
+ -> 'resp request
+ -> ('resp, 'a) result Lwt.t
(** Helper to make a client request: handles encoding of the request and
decoding of the response. *)
- val make_request:
- (http_request -> (string, 'a) result Lwt.t) ->
- 'resp request -> ('resp, 'a) result Lwt.t
-
end
diff --git a/src/state/learnocaml_data.ml b/src/state/learnocaml_data.ml
index 39ce6f6d0..d93f14f2b 100644
--- a/src/state/learnocaml_data.ml
+++ b/src/state/learnocaml_data.ml
@@ -9,342 +9,309 @@
module J = Json_encoding
module SMap = struct
-
include Map.Make (String)
let enc val_enc =
- J.conv
- bindings
- (List.fold_left
- (fun acc (n, v) -> add n v acc)
- empty)
+ J.conv bindings
+ (List.fold_left (fun acc (n, v) -> add n v acc) empty)
(J.assoc val_enc)
-
end
module SSet = struct
-
include Set.Make (String)
let enc = J.conv elements of_list (J.list J.string)
let merge3 ~ancestor ~theirs ~ours =
- let (++), (--), (%%) = union, diff, inter in
+ let ( ++ ), ( -- ), ( %% ) = (union, diff, inter) in
(ancestor %% theirs %% ours) ++ (theirs -- ancestor) ++ (ours -- ancestor)
-
end
module Answer = struct
-
type t =
- { solution : string ;
- grade : int (* \in [0, 100] *) option ;
- report : Learnocaml_report.t option ;
- mtime : float }
+ { solution : string
+ ; grade : int (* \in [0, 100] *) option
+ ; report : Learnocaml_report.t option
+ ; mtime : float }
let enc =
let grade_enc =
J.conv
+ (function Some n when n < 0 || n > 100 -> None | g -> g)
(function
- | Some n when n < 0 || n > 100 -> None
- | g -> g)
- (function
- | Some s when s < 0 || s > 100 -> failwith "grade overflow"
- | g -> g)
- J.(option int) in
+ | Some s when s < 0 || s > 100 -> failwith "grade overflow" | g -> g)
+ J.(option int)
+ in
J.conv
- (fun { grade ; solution ; report ; mtime } ->
- (grade, solution, report, mtime))
- (fun (grade, solution, report, mtime) ->
- { grade ; solution ; report ; mtime })
+ (fun {grade; solution; report; mtime} -> (grade, solution, report, mtime))
+ (fun (grade, solution, report, mtime) -> {grade; solution; report; mtime})
(J.obj4
(J.dft "grade" grade_enc None)
(J.req "solution" J.string)
(J.opt "report" Learnocaml_report.enc)
(J.dft "mtime" J.float 0.))
-
end
module Report = Learnocaml_report
module Save = struct
-
type t =
- { nickname : string ;
- all_exercise_editors : (float * string) SMap.t ;
- all_exercise_states : Answer.t SMap.t ;
- all_toplevel_histories :
- Learnocaml_toplevel_history.snapshot SMap.t ;
- all_exercise_toplevel_histories :
+ { nickname : string
+ ; all_exercise_editors : (float * string) SMap.t
+ ; all_exercise_states : Answer.t SMap.t
+ ; all_toplevel_histories : Learnocaml_toplevel_history.snapshot SMap.t
+ ; all_exercise_toplevel_histories :
Learnocaml_toplevel_history.snapshot SMap.t }
let enc =
J.conv
(fun t ->
- t.nickname,
- t.all_exercise_editors,
- t.all_exercise_states,
- t.all_toplevel_histories,
- t.all_exercise_toplevel_histories)
- (fun (nickname,
- all_exercise_editors,
- all_exercise_states,
- all_toplevel_histories,
- all_exercise_toplevel_histories) ->
- { nickname ;
- all_exercise_editors ;
- all_exercise_states ;
- all_toplevel_histories ;
- all_exercise_toplevel_histories }) @@
- J.obj5
- (J.dft "nickname" J.string "")
- (J.dft "exercises-editors"
- (SMap.enc (J.tup2 J.float J.string)) SMap.empty)
- (J.dft "exercises"
- (SMap.enc Answer.enc) SMap.empty)
- (J.dft "toplevel-histories"
- (SMap.enc Learnocaml_toplevel_history.snapshot_enc) SMap.empty)
- (J.dft "exercise-toplevel-histories"
- (SMap.enc Learnocaml_toplevel_history.snapshot_enc) SMap.empty)
+ ( t.nickname
+ , t.all_exercise_editors
+ , t.all_exercise_states
+ , t.all_toplevel_histories
+ , t.all_exercise_toplevel_histories ) )
+ (fun ( nickname
+ , all_exercise_editors
+ , all_exercise_states
+ , all_toplevel_histories
+ , all_exercise_toplevel_histories ) ->
+ { nickname
+ ; all_exercise_editors
+ ; all_exercise_states
+ ; all_toplevel_histories
+ ; all_exercise_toplevel_histories } )
+ @@ J.obj5
+ (J.dft "nickname" J.string "")
+ (J.dft "exercises-editors"
+ (SMap.enc (J.tup2 J.float J.string))
+ SMap.empty)
+ (J.dft "exercises" (SMap.enc Answer.enc) SMap.empty)
+ (J.dft "toplevel-histories"
+ (SMap.enc Learnocaml_toplevel_history.snapshot_enc)
+ SMap.empty)
+ (J.dft "exercise-toplevel-histories"
+ (SMap.enc Learnocaml_toplevel_history.snapshot_enc)
+ SMap.empty)
let sync a b =
let sync_snapshot snapshot_a snapshot_b =
let open Learnocaml_toplevel_history in
- if snapshot_a.mtime > snapshot_b.mtime then
- snapshot_a
- else
- snapshot_b in
- let sync_exercise_edits (ts_a, _ as a) (ts_b, _ as b) =
+ if snapshot_a.mtime > snapshot_b.mtime then snapshot_a else snapshot_b
+ in
+ let sync_exercise_edits ((ts_a, _) as a) ((ts_b, _) as b) =
if ts_a > ts_b then a else b
in
let sync_exercise_state state_a state_b =
let open Answer in
- if state_a.mtime > state_b.mtime then
- state_a
- else
- state_b in
+ if state_a.mtime > state_b.mtime then state_a else state_b
+ in
let sync_map sync_item index_a index_b =
SMap.merge
- (fun _id a b -> match a, b with
- | None, None -> assert false
- | None, Some i | Some i, None -> Some i
- | Some a, Some b -> Some (sync_item a b))
- index_a index_b in
+ (fun _id a b ->
+ match (a, b) with
+ | None, None -> assert false
+ | None, Some i | Some i, None -> Some i
+ | Some a, Some b -> Some (sync_item a b) )
+ index_a index_b
+ in
let all_exercise_states =
- sync_map sync_exercise_state
- a.all_exercise_states
- b.all_exercise_states
+ sync_map sync_exercise_state a.all_exercise_states b.all_exercise_states
in
let all_exercise_editors =
- sync_map sync_exercise_edits
- a.all_exercise_editors
+ sync_map sync_exercise_edits a.all_exercise_editors
b.all_exercise_editors
|> SMap.filter (fun id (ts, _) ->
- match SMap.find_opt id all_exercise_states with
- | Some {Answer.mtime; _} when mtime > ts -> false
- | _ -> true)
+ match SMap.find_opt id all_exercise_states with
+ | Some {Answer.mtime; _} when mtime > ts -> false
+ | _ -> true )
in
- { nickname = if b.nickname = "" then a.nickname else b.nickname;
- all_exercise_editors;
- all_exercise_states;
- all_toplevel_histories =
- sync_map sync_snapshot
- a.all_toplevel_histories
- b.all_toplevel_histories ;
- all_exercise_toplevel_histories =
- sync_map sync_snapshot
- a.all_exercise_toplevel_histories
+ { nickname = (if b.nickname = "" then a.nickname else b.nickname)
+ ; all_exercise_editors
+ ; all_exercise_states
+ ; all_toplevel_histories =
+ sync_map sync_snapshot a.all_toplevel_histories
+ b.all_toplevel_histories
+ ; all_exercise_toplevel_histories =
+ sync_map sync_snapshot a.all_exercise_toplevel_histories
b.all_exercise_toplevel_histories }
let fix_mtimes save =
let now = Unix.gettimeofday () in
let fix t = min t now in
let fix_snapshot s =
- Learnocaml_toplevel_history.{ s with mtime = fix s.mtime }
- in
- let fix_exercise_edits (ts, e) = fix ts, e in
- let fix_exercise_state s =
- Answer.{ s with mtime = fix s.mtime }
+ Learnocaml_toplevel_history.{s with mtime = fix s.mtime}
in
- {
- save with
+ let fix_exercise_edits (ts, e) = (fix ts, e) in
+ let fix_exercise_state s = Answer.{s with mtime = fix s.mtime} in
+ { save with
all_exercise_editors =
- SMap.map fix_exercise_edits save.all_exercise_editors;
- all_exercise_states =
- SMap.map fix_exercise_state save.all_exercise_states;
- all_toplevel_histories =
- SMap.map fix_snapshot save.all_toplevel_histories;
- all_exercise_toplevel_histories =
- SMap.map fix_snapshot save.all_exercise_toplevel_histories;
- }
-
- let empty = {
- all_exercise_editors = SMap.empty;
- all_exercise_states = SMap.empty;
- all_toplevel_histories = SMap.empty;
- all_exercise_toplevel_histories = SMap.empty;
- nickname = "";
- }
-
+ SMap.map fix_exercise_edits save.all_exercise_editors
+ ; all_exercise_states =
+ SMap.map fix_exercise_state save.all_exercise_states
+ ; all_toplevel_histories =
+ SMap.map fix_snapshot save.all_toplevel_histories
+ ; all_exercise_toplevel_histories =
+ SMap.map fix_snapshot save.all_exercise_toplevel_histories }
+
+ let empty =
+ { all_exercise_editors = SMap.empty
+ ; all_exercise_states = SMap.empty
+ ; all_toplevel_histories = SMap.empty
+ ; all_exercise_toplevel_histories = SMap.empty
+ ; nickname = "" }
end
module Token = struct
-
type t = string list
let teacher_token_prefix = "X"
let to_string = String.concat "-"
- let to_path = String.concat (Filename.dir_sep)
+
+ let to_path = String.concat Filename.dir_sep
+
let teacher_tokens_path = teacher_token_prefix
- let alphabet =
- "ABCDEFGH1JKLMNOPORSTUVWXYZO1Z34SG1B9"
- let visually_equivalent_alphabet =
- "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
+ let alphabet = "ABCDEFGH1JKLMNOPORSTUVWXYZO1Z34SG1B9"
+
+ let visually_equivalent_alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
let parse =
let table = Array.make 256 None in
String.iteri
- (fun i c -> Array.set table (Char.code c) (Some alphabet.[i]))
- visually_equivalent_alphabet ;
+ (fun i c -> table.(Char.code c) <- Some alphabet.[i])
+ visually_equivalent_alphabet;
let translate part =
- String.map (fun c ->
- match Array.get table (Char.code c) with
+ String.map
+ (fun c ->
+ match table.(Char.code c) with
| None -> failwith "bad token character"
- | Some c -> c)
- part in
+ | Some c -> c )
+ part
+ in
fun token ->
let token = String.trim token in
let translate_base_token token =
if String.length token = 15 then
- if String.get token 3 <> '-'
- || String.get token 7 <> '-'
- || String.get token 11 <> '-' then
+ if token.[3] <> '-' || token.[7] <> '-' || token.[11] <> '-' then
failwith "bad token format"
else
List.map translate
- [ String.sub token 0 3 ;
- String.sub token 4 3 ;
- String.sub token 8 3 ;
- String.sub token 12 3 ]
- else
- failwith "bad token length"
+ [ String.sub token 0 3
+ ; String.sub token 4 3
+ ; String.sub token 8 3
+ ; String.sub token 12 3 ]
+ else failwith "bad token length"
in
- if String.length token >= 2 &&
- String.sub token 0 2 = teacher_token_prefix ^ "-"
+ if
+ String.length token >= 2
+ && String.sub token 0 2 = teacher_token_prefix ^ "-"
then
- teacher_token_prefix ::
- translate_base_token (String.sub token 2 (String.length token - 2))
- else
- translate_base_token token
+ teacher_token_prefix
+ :: translate_base_token (String.sub token 2 (String.length token - 2))
+ else translate_base_token token
let enc = J.conv to_string parse J.string
let check token =
- try ignore (parse token) ; true
+ try
+ ignore (parse token);
+ true
with _ -> false
let random () =
- let rand () = String.get alphabet (Random.int (String.length alphabet)) in
+ let rand () = alphabet.[Random.int (String.length alphabet)] in
let part () = String.init 3 (fun _ -> rand ()) in
- [ part () ; part () ; part () ; part () ]
+ [part (); part (); part (); part ()]
let random_teacher () = teacher_token_prefix :: random ()
let is_teacher = function
- | x::_ when x = teacher_token_prefix -> true
+ | x :: _ when x = teacher_token_prefix -> true
| _ -> false
let is_student t = not (is_teacher t)
module T = struct
type nonrec t = t
+
let compare = Pervasives.compare
end
- module Set = Set.Make(T)
- module Map = Map.Make(T)
+ module Set = Set.Make (T)
+ module Map = Map.Make (T)
end
type 'a token = Token.t
type student
+
type teacher
module Student = struct
-
- type t = {
- token: student token;
- nickname: string option;
- results: (float * int option) SMap.t;
- creation_date: float;
- tags: SSet.t;
- }
+ type t =
+ { token : student token
+ ; nickname : string option
+ ; results : (float * int option) SMap.t
+ ; creation_date : float
+ ; tags : SSet.t }
let enc =
let open Json_encoding in
- obj5
- (req "token" string)
- (opt "nickname" string)
+ obj5 (req "token" string) (opt "nickname" string)
(dft "results" (assoc (tup2 float (option int))) [])
(dft "creation_date" float 0.)
(dft "tags" (list string) [])
|> conv
- (fun t ->
- Token.to_string t.token,
- t.nickname, SMap.bindings t.results, t.creation_date,
- SSet.elements t.tags)
- (fun (token, nickname, results, creation_date, tags) -> {
- token = Token.parse token;
- nickname;
- results =
- List.fold_left (fun m (s, r) -> SMap.add s r m)
- SMap.empty
- results;
- creation_date;
- tags = SSet.of_list tags;
- })
-
- let default token = {
- token;
- nickname = None;
- results = SMap.empty;
- creation_date = Unix.gettimeofday ();
- tags = SSet.empty;
- }
+ (fun t ->
+ ( Token.to_string t.token
+ , t.nickname
+ , SMap.bindings t.results
+ , t.creation_date
+ , SSet.elements t.tags ) )
+ (fun (token, nickname, results, creation_date, tags) ->
+ { token = Token.parse token
+ ; nickname
+ ; results =
+ List.fold_left
+ (fun m (s, r) -> SMap.add s r m)
+ SMap.empty results
+ ; creation_date
+ ; tags = SSet.of_list tags } )
+
+ let default token =
+ { token
+ ; nickname = None
+ ; results = SMap.empty
+ ; creation_date = Unix.gettimeofday ()
+ ; tags = SSet.empty }
let three_way_merge ~ancestor ~theirs ~ours =
let token = ancestor.token in
if token <> theirs.token || token <> ours.token then
invalid_arg "three_way_merge";
- let tags = SSet.merge3
- ~ancestor:ancestor.tags
- ~theirs:theirs.tags
- ~ours:ours.tags
+ let tags =
+ SSet.merge3 ~ancestor:ancestor.tags ~theirs:theirs.tags ~ours:ours.tags
in
let nickname =
- if ours.nickname <> ancestor.nickname
- then ours.nickname
+ if ours.nickname <> ancestor.nickname then ours.nickname
else theirs.nickname
in
let results =
- SMap.merge (fun id a o ->
- if a <> o then o else
- SMap.find_opt id theirs.results)
+ SMap.merge
+ (fun id a o -> if a <> o then o else SMap.find_opt id theirs.results)
ancestor.results ours.results
in
let creation_date =
min ancestor.creation_date (min theirs.creation_date ours.creation_date)
in
- { token; tags; nickname; creation_date; results }
+ {token; tags; nickname; creation_date; results}
module Index = struct
-
type nonrec t = t list
let enc = J.(list enc)
-
end
end
@@ -352,63 +319,54 @@ let enc_check_version_1 enc =
J.conv
(fun exercise -> ("1", exercise))
(fun (version, exercise) ->
- if version <> "1" then begin
- let msg = Format.asprintf "unknown version %s" version in
- raise (J.Cannot_destruct ([], Failure msg))
- end ;
- exercise)
+ ( if version <> "1" then
+ let msg = Format.asprintf "unknown version %s" version in
+ raise (J.Cannot_destruct ([], Failure msg)) );
+ exercise )
(J.merge_objs (J.obj1 (J.req "learnocaml_version" J.string)) enc)
let enc_check_version_2 enc =
J.conv
(fun exercise -> ("2", exercise))
(fun (version, exercise) ->
- begin
- match version with
- | "1" | "2" -> ()
- | _ ->
- let msg = Format.asprintf "unknown version %s" version in
- raise (J.Cannot_destruct ([], Failure msg))
- end ;
- exercise)
+ ( match version with
+ | "1" | "2" -> ()
+ | _ ->
+ let msg = Format.asprintf "unknown version %s" version in
+ raise (J.Cannot_destruct ([], Failure msg)) );
+ exercise )
(J.merge_objs (J.obj1 (J.req "learnocaml_version" J.string)) enc)
module Server = struct
- type preconfig = {
- secret : string option;
- }
- let empty_preconfig = {
- secret = None;
- }
+ type preconfig = {secret : string option}
+
+ let empty_preconfig = {secret = None}
let preconfig_enc =
- J.conv (fun (c : preconfig) -> c.secret)
- (fun secret : preconfig -> {secret}) @@
- J.obj1 (J.opt "secret" J.string)
+ J.conv
+ (fun (c : preconfig) -> c.secret)
+ (fun secret -> ({secret} : preconfig))
+ @@ J.obj1 (J.opt "secret" J.string)
- type config = {
- secret : string option;
- server_id : int;
- }
+ type config = {secret : string option; server_id : int}
let build_config (preconf : preconfig) : config =
- let secret = match preconf.secret with
+ let secret =
+ match preconf.secret with
| None -> None
- | Some secret_in_clear -> Some (Sha.sha512 secret_in_clear) in
+ | Some secret_in_clear -> Some (Sha.sha512 secret_in_clear)
+ in
let server_id = Random.bits () in
- {
- secret;
- server_id;
- }
+ {secret; server_id}
let config_enc =
- J.conv (fun (c : config) -> (c.secret,c.server_id))
- (fun (secret,server_id) : config -> {secret; server_id}) @@
- J.obj2 (J.opt "secret" J.string) (J.req "server_id" J.int)
+ J.conv
+ (fun (c : config) -> (c.secret, c.server_id))
+ (fun (secret, server_id) -> ({secret; server_id} : config))
+ @@ J.obj2 (J.opt "secret" J.string) (J.req "server_id" J.int)
end
module Exercise = struct
-
type id = string
type t = Learnocaml_exercise.t
@@ -416,93 +374,91 @@ module Exercise = struct
let enc = Learnocaml_exercise.encoding
module Meta = struct
+ type kind = Project | Problem | Exercise
- type kind =
- | Project
- | Problem
- | Exercise
-
- type t = {
- kind: kind;
- title: string;
- short_description: string option;
- stars: float (* \in [0.,4.] *);
- id: id option;
- author: (string * string) list;
- focus: string list;
- requirements: string list;
- forward: id list;
- backward: id list;
- }
+ type t =
+ { kind : kind
+ ; title : string
+ ; short_description : string option
+ ; stars : float (* \in [0.,4.] *)
+ ; id : id option
+ ; author : (string * string) list
+ ; focus : string list
+ ; requirements : string list
+ ; forward : id list
+ ; backward : id list }
let enc =
let kind_enc =
J.string_enum
- [ "problem", Problem ;
- "project", Project ;
- "exercise", Exercise ]
+ [("problem", Problem); ("project", Project); ("exercise", Exercise)]
in
let exercise_enc_v1 =
- J.(obj10
- (req "kind" kind_enc)
- (dft "title" string "")
- (opt "short_description" string)
- (req "stars" float)
- (opt "identifier" string)
- (dft "authors" (list (tup2 string string)) [])
- (dft "focus" (list string) [])
- (dft "requirements" (list string) [])
- (dft "forward_exercises" (list string) [])
- (dft "backward_exercises" (list string) []))
+ J.(
+ obj10 (req "kind" kind_enc) (dft "title" string "")
+ (opt "short_description" string)
+ (req "stars" float) (opt "identifier" string)
+ (dft "authors" (list (tup2 string string)) [])
+ (dft "focus" (list string) [])
+ (dft "requirements" (list string) [])
+ (dft "forward_exercises" (list string) [])
+ (dft "backward_exercises" (list string) []))
in
let exercise_enc_v2 =
- J.(obj1
- (opt "max_score" int))
+ J.(obj1 (opt "max_score" int))
(* deprecated & ignored *)
in
J.conv
(fun t ->
- ((t.kind, t.title, t.short_description, t.stars, t.id,
- t.author, t.focus, t.requirements, t.forward, t.backward),
- None))
- (fun ((kind, title, short_description, stars, id,
- author, focus, requirements, forward, backward),
- _max_score) ->
- { kind; title; short_description; stars; id;
- author; focus; requirements; forward; backward;
- })
- (enc_check_version_2
- (J.merge_objs
- exercise_enc_v1
- exercise_enc_v2))
-
+ ( ( t.kind
+ , t.title
+ , t.short_description
+ , t.stars
+ , t.id
+ , t.author
+ , t.focus
+ , t.requirements
+ , t.forward
+ , t.backward )
+ , None ) )
+ (fun ( ( kind
+ , title
+ , short_description
+ , stars
+ , id
+ , author
+ , focus
+ , requirements
+ , forward
+ , backward )
+ , _max_score ) ->
+ { kind
+ ; title
+ ; short_description
+ ; stars
+ ; id
+ ; author
+ ; focus
+ ; requirements
+ ; forward
+ ; backward } )
+ (enc_check_version_2 (J.merge_objs exercise_enc_v1 exercise_enc_v2))
end
module Status = struct
-
type skill = [`Plus | `Minus] * string
- type status =
- | Open
- | Closed
- | Assigned of {start: float; stop: float}
+ type status = Open | Closed | Assigned of {start : float; stop : float}
- type assignments = {
- token_map: status Token.Map.t;
- default: status;
- }
+ type assignments = {token_map : status Token.Map.t; default : status}
- type t = {
- id: id;
- skills_prereq: skill list;
- skills_focus: skill list;
- assignments: assignments;
- }
+ type t =
+ { id : id
+ ; skills_prereq : skill list
+ ; skills_focus : skill list
+ ; assignments : assignments }
- let empty_assignments = {
- token_map = Token.Map.empty;
- default = Open;
- }
+ let empty_assignments = {token_map = Token.Map.empty; default = Open}
let default_assignment a = a.default
@@ -516,34 +472,32 @@ module Exercise = struct
let is_open_assignment token a =
match get_status token a with
| Assigned a ->
- let t = Unix.gettimeofday () in
- if t < a.start then `Closed
- else `Deadline (a.stop -. t)
+ let t = Unix.gettimeofday () in
+ if t < a.start then `Closed else `Deadline (a.stop -. t)
| Open -> `Open
| Closed -> `Closed
let get_skills ~base skills =
- SSet.elements @@
- List.fold_left (fun acc (op, sk) ->
- match op with
- | `Plus -> SSet.add sk acc
- | `Minus -> SSet.remove sk acc)
- (SSet.of_list base) skills
+ SSet.elements
+ @@ List.fold_left
+ (fun acc (op, sk) ->
+ match op with
+ | `Plus -> SSet.add sk acc
+ | `Minus -> SSet.remove sk acc )
+ (SSet.of_list base) skills
let skills_base ~current skills =
- get_skills ~base:current (List.map (function
- | `Plus, x -> `Minus, x
- | `Minus, x -> `Plus, x)
- skills)
+ get_skills ~base:current
+ (List.map
+ (function `Plus, x -> (`Minus, x) | `Minus, x -> (`Plus, x))
+ skills)
let make_skills ~base current =
- let base = SSet.of_list base in
- let current = SSet.of_list current in
- SSet.fold (fun sk acc -> (`Plus, sk) :: acc)
- (SSet.diff current base) @@
- SSet.fold (fun sk acc -> (`Minus, sk) :: acc)
- (SSet.diff base current) @@
- []
+ let base = SSet.of_list base in
+ let current = SSet.of_list current in
+ SSet.fold (fun sk acc -> (`Plus, sk) :: acc) (SSet.diff current base)
+ @@ SSet.fold (fun sk acc -> (`Minus, sk) :: acc) (SSet.diff base current)
+ @@ []
let skills_prereq meta status =
get_skills ~base:meta.Meta.requirements status.skills_prereq
@@ -551,22 +505,25 @@ module Exercise = struct
let skills_focus meta status =
get_skills ~base:meta.Meta.focus status.skills_focus
- module STM = Map.Make(struct
- type t = status
- let compare = compare
- end)
+ module STM = Map.Make (struct
+ type t = status
+
+ let compare = compare
+ end)
let by_status_explicit base a =
- Token.Map.fold (fun tok st sm ->
+ Token.Map.fold
+ (fun tok st sm ->
match STM.find_opt st sm with
| None -> STM.add st (Token.Set.singleton tok) sm
- | Some toks -> STM.add st (Token.Set.add tok toks) sm)
- a.token_map
- base
+ | Some toks -> STM.add st (Token.Set.add tok toks) sm )
+ a.token_map base
let by_status tokens a =
let rem_tokens =
- Token.Set.filter (fun tok -> not (Token.Map.mem tok a.token_map)) tokens
+ Token.Set.filter
+ (fun tok -> not (Token.Map.mem tok a.token_map))
+ tokens
in
let base =
if Token.Set.is_empty rem_tokens then STM.empty
@@ -576,41 +533,39 @@ module Exercise = struct
let three_way_merge ~ancestor ~theirs ~ours =
let id = ancestor.id in
- if id <> theirs.id || id <> ours.id then
- invalid_arg "three_way_merge";
+ if id <> theirs.id || id <> ours.id then invalid_arg "three_way_merge";
let skills_merge3 field =
let aux filter =
- SSet.merge3
- ~ancestor:(filter ancestor)
- ~theirs:(filter theirs)
+ SSet.merge3 ~ancestor:(filter ancestor) ~theirs:(filter theirs)
~ours:(filter ours)
|> SSet.elements
in
- List.map (fun sk -> `Plus, sk)
- (aux (fun a ->
- List.fold_left (fun acc -> function
- |`Plus, sk -> SSet.add sk acc
- | _ -> acc) SSet.empty (field a))) @
- List.map (fun sk -> `Minus, sk)
+ List.map
+ (fun sk -> (`Plus, sk))
(aux (fun a ->
- List.fold_left (fun acc -> function
- |`Minus, sk -> SSet.add sk acc
- | _ -> acc) SSet.empty (field a)))
- in
- let skills_prereq =
- skills_merge3 (fun a -> a.skills_prereq)
- in
- let skills_focus =
- skills_merge3 (fun a -> a.skills_focus)
+ List.fold_left
+ (fun acc -> function `Plus, sk -> SSet.add sk acc | _ -> acc)
+ SSet.empty (field a) ))
+ @ List.map
+ (fun sk -> (`Minus, sk))
+ (aux (fun a ->
+ List.fold_left
+ (fun acc -> function `Minus, sk -> SSet.add sk acc
+ | _ -> acc )
+ SSet.empty (field a) ))
in
+ let skills_prereq = skills_merge3 (fun a -> a.skills_prereq) in
+ let skills_focus = skills_merge3 (fun a -> a.skills_focus) in
let default =
- if ours.assignments.default <> ancestor.assignments.default
- then ours.assignments.default
+ if ours.assignments.default <> ancestor.assignments.default then
+ ours.assignments.default
else theirs.assignments.default
in
let token_map =
- Token.Map.merge (fun tok a o ->
- let a = match a with
+ Token.Map.merge
+ (fun tok a o ->
+ let a =
+ match a with
| None -> ancestor.assignments.default
| Some st -> st
in
@@ -619,161 +574,141 @@ module Exercise = struct
| None -> theirs.assignments.default
| Some st -> st
in
- let o = match o with
- | None -> ours.assignments.default
- | Some st -> st
+ let o =
+ match o with None -> ours.assignments.default | Some st -> st
in
- if o <> a then Some o else Some t)
- ancestor.assignments.token_map
- ours.assignments.token_map
+ if o <> a then Some o else Some t )
+ ancestor.assignments.token_map ours.assignments.token_map
in
let token_map =
- Token.Map.merge (fun _ t o -> match t, o with
+ Token.Map.merge
+ (fun _ t o ->
+ match (t, o) with
| _, (Some st as s) | (Some st as s), _ ->
if st = default then None else s
- | None, None -> assert false)
- theirs.assignments.token_map
- token_map
+ | None, None -> assert false )
+ theirs.assignments.token_map token_map
in
- { id;
- skills_prereq;
- skills_focus;
- assignments = { default; token_map } }
+ {id; skills_prereq; skills_focus; assignments = {default; token_map}}
- let make_assignments token_map default =
- { token_map; default }
+ let make_assignments token_map default = {token_map; default}
let enc =
let status_enc =
- J.union [
- J.case (J.constant "Open")
- (function Open -> Some () | _ -> None) (fun () -> Open);
- J.case (J.constant "Closed")
- (function Closed -> Some () | _ -> None) (fun () -> Closed);
- J.case
- (J.obj2 (J.req "start" J.float) (J.req "stop" J.float))
- (function Assigned a -> Some (a.start, a.stop) | _ -> None)
- (fun (start, stop) -> Assigned {start; stop})
- ]
+ J.union
+ [ J.case (J.constant "Open")
+ (function Open -> Some () | _ -> None)
+ (fun () -> Open)
+ ; J.case (J.constant "Closed")
+ (function Closed -> Some () | _ -> None)
+ (fun () -> Closed)
+ ; J.case
+ (J.obj2 (J.req "start" J.float) (J.req "stop" J.float))
+ (function Assigned a -> Some (a.start, a.stop) | _ -> None)
+ (fun (start, stop) -> Assigned {start; stop}) ]
in
let assignments_enc =
J.conv
(fun t ->
- t.default,
- List.map (fun (tk, st) -> Token.to_string tk, st)
- (Token.Map.bindings t.token_map))
- (fun (default, token_assoc) -> {
- default;
- token_map =
- (List.fold_left (fun acc (tok, st) ->
- Token.Map.add (Token.parse tok) st acc)
- Token.Map.empty token_assoc)
- })
- @@
- J.obj2
- (J.dft "default" status_enc empty_assignments.default)
- (J.dft "token_map" (J.assoc status_enc) [])
+ ( t.default
+ , List.map
+ (fun (tk, st) -> (Token.to_string tk, st))
+ (Token.Map.bindings t.token_map) ) )
+ (fun (default, token_assoc) ->
+ { default
+ ; token_map =
+ List.fold_left
+ (fun acc (tok, st) -> Token.Map.add (Token.parse tok) st acc)
+ Token.Map.empty token_assoc } )
+ @@ J.obj2
+ (J.dft "default" status_enc empty_assignments.default)
+ (J.dft "token_map" (J.assoc status_enc) [])
in
let skill_enc =
- J.union [
- J.case (J.obj1 (J.req "plus" J.string))
- (function `Plus, sk -> Some sk | _ -> None)
- (fun sk -> `Plus, sk);
- J.case (J.obj1 (J.req "minus" J.string))
- (function `Minus, sk -> Some sk | _ -> None)
- (fun sk -> `Minus, sk);
- ]
+ J.union
+ [ J.case
+ (J.obj1 (J.req "plus" J.string))
+ (function `Plus, sk -> Some sk | _ -> None)
+ (fun sk -> (`Plus, sk))
+ ; J.case
+ (J.obj1 (J.req "minus" J.string))
+ (function `Minus, sk -> Some sk | _ -> None)
+ (fun sk -> (`Minus, sk)) ]
in
- enc_check_version_2 @@
- J.conv
- (fun t -> t.id, t.skills_prereq, t.skills_focus, t.assignments)
- (fun (id, skills_prereq, skills_focus, assignments) ->
- {id; skills_prereq; skills_focus; assignments})
- @@
- J.obj4
- (J.req "id" J.string)
- (J.dft "skills_prereq" (J.list skill_enc) [])
- (J.dft "skills_focus" (J.list skill_enc) [])
- (J.dft "assignments" assignments_enc empty_assignments)
-
- let default id = {
- id;
- skills_prereq = [];
- skills_focus = [];
- assignments = {
- token_map = Token.Map.empty;
- default = Open;
- }
- }
-
+ enc_check_version_2
+ @@ J.conv
+ (fun t -> (t.id, t.skills_prereq, t.skills_focus, t.assignments))
+ (fun (id, skills_prereq, skills_focus, assignments) ->
+ {id; skills_prereq; skills_focus; assignments} )
+ @@ J.obj4 (J.req "id" J.string)
+ (J.dft "skills_prereq" (J.list skill_enc) [])
+ (J.dft "skills_focus" (J.list skill_enc) [])
+ (J.dft "assignments" assignments_enc empty_assignments)
+
+ let default id =
+ { id
+ ; skills_prereq = []
+ ; skills_focus = []
+ ; assignments = {token_map = Token.Map.empty; default = Open} }
end
module Index = struct
-
type t =
| Exercises of (id * Meta.t option) list
| Groups of (string * group) list
- and group =
- { title : string;
- contents : t }
+
+ and group = {title : string; contents : t}
let enc =
let exercise_enc =
- J.union [
- J.case J.string
- (function id, None -> Some id | _ -> None)
- (fun id -> id, None);
- J.case J.(tup2 string Meta.enc)
- (function id, Some meta -> Some (id, meta) | _ -> None)
- (fun (id, meta) -> id, Some meta);
- ]
+ J.union
+ [ J.case J.string
+ (function id, None -> Some id | _ -> None)
+ (fun id -> (id, None))
+ ; J.case
+ J.(tup2 string Meta.enc)
+ (function id, Some meta -> Some (id, meta) | _ -> None)
+ (fun (id, meta) -> (id, Some meta)) ]
in
let group_enc =
- J.mu "group" @@ fun group_enc ->
+ J.mu "group"
+ @@ fun group_enc ->
J.conv
- (fun (g : group) -> g.title, g.contents)
- (fun (title, contents) -> { title; contents }) @@
- J.union
- [ J.case
- J.(obj2
- (req "title" string)
- (req "exercises" (list exercise_enc)))
- (function
- | (title, Exercises map) -> Some (title, map)
- | _ -> None)
- (fun (title, map) -> (title, Exercises map)) ;
- J.case
- J.(obj2
- (req "title" string)
- (req "groups" (assoc group_enc)))
- (function
- | (title, Groups map) -> Some (title, map)
- | _ -> None)
- (fun (title, map) -> (title, Groups map)) ]
+ (fun (g : group) -> (g.title, g.contents))
+ (fun (title, contents) -> {title; contents})
+ @@ J.union
+ [ J.case
+ J.(
+ obj2 (req "title" string)
+ (req "exercises" (list exercise_enc)))
+ (function
+ | title, Exercises map -> Some (title, map) | _ -> None)
+ (fun (title, map) -> (title, Exercises map))
+ ; J.case
+ J.(obj2 (req "title" string) (req "groups" (assoc group_enc)))
+ (function
+ | title, Groups map -> Some (title, map) | _ -> None)
+ (fun (title, map) -> (title, Groups map)) ]
in
- enc_check_version_2 @@
- J.union
- [ J.case
- J.(obj1 (req "exercises" (list exercise_enc)))
- (function
- | Exercises map -> Some map
- | _ -> None)
- (fun map -> Exercises map) ;
- J.case
- J.(obj1 (req "groups" (assoc group_enc)))
- (function
- | Groups map -> Some map
- | _ -> None)
- (fun map -> Groups map) ]
+ enc_check_version_2
+ @@ J.union
+ [ J.case
+ J.(obj1 (req "exercises" (list exercise_enc)))
+ (function Exercises map -> Some map | _ -> None)
+ (fun map -> Exercises map)
+ ; J.case
+ J.(obj1 (req "groups" (assoc group_enc)))
+ (function Groups map -> Some map | _ -> None)
+ (fun map -> Groups map) ]
let find t id =
- let rec aux t = match t with
- | Groups ((_, g)::r) ->
- (try aux g.contents with Not_found -> aux (Groups r))
+ let rec aux t =
+ match t with
+ | Groups ((_, g) :: r) -> (
+ try aux g.contents with Not_found -> aux (Groups r) )
| Groups [] -> raise Not_found
- | Exercises l -> (match List.assoc id l with
- | None -> raise Not_found
- | Some e -> e)
+ | Exercises l -> (
+ match List.assoc id l with None -> raise Not_found | Some e -> e )
in
aux t
@@ -782,66 +717,70 @@ module Exercise = struct
let rec map_exercises f = function
| Groups gs ->
Groups
- (List.map (fun (id, (g: group)) ->
- (id, {g with contents = map_exercises f g.contents}))
- gs)
+ (List.map
+ (fun (id, (g : group)) ->
+ (id, {g with contents = map_exercises f g.contents}) )
+ gs)
| Exercises l ->
Exercises
- (List.map (function
- | (id, Some ex) -> (id, Some (f id ex))
- | x -> x)
- l)
+ (List.map
+ (function id, Some ex -> (id, Some (f id ex)) | x -> x)
+ l)
let rec mapk_exercises f t k =
- let rec mapk_list acc f l k = match l with
- | x::r -> f x (fun y -> mapk_list (y::acc) f r @@ k)
+ let rec mapk_list acc f l k =
+ match l with
+ | x :: r -> f x (fun y -> mapk_list (y :: acc) f r @@ k)
| [] -> List.rev acc |> k
in
match t with
| Groups gs ->
- mapk_list [] (fun (id, (g: group)) k ->
+ mapk_list []
+ (fun (id, (g : group)) k ->
mapk_exercises f g.contents
- @@ fun contents -> (id, {g with contents}) |> k)
+ @@ fun contents -> (id, {g with contents}) |> k )
gs
@@ fun gs -> Groups gs |> k
| Exercises l ->
- mapk_list [] (fun e k -> match e with
- | (id, Some ex) ->
- f id ex @@ fun ex -> (id, Some ex) |> k
- | x -> x |> k)
+ mapk_list []
+ (fun e k ->
+ match e with
+ | id, Some ex -> f id ex @@ fun ex -> (id, Some ex) |> k
+ | x -> x |> k )
l
@@ fun l -> Exercises l |> k
let rec fold_exercises f acc = function
| Groups gs ->
List.fold_left
- (fun acc (_, (g: group)) -> fold_exercises f acc g.contents)
+ (fun acc (_, (g : group)) -> fold_exercises f acc g.contents)
acc gs
| Exercises l ->
- List.fold_left (fun acc -> function
- | (id, Some ex) -> f acc id ex
- | _ -> acc)
+ List.fold_left
+ (fun acc -> function id, Some ex -> f acc id ex | _ -> acc)
acc l
let rec filterk f g k =
match g with
| Groups gs ->
let rec aux acc = function
- | (id, (g: group)) :: r ->
- (filterk f g.contents @@ function
- | Exercises [] -> aux acc r
- | contents -> aux ((id, { g with contents }) :: acc) r)
- | [] -> match acc with
+ | (id, (g : group)) :: r -> (
+ filterk f g.contents
+ @@ function
+ | Exercises [] -> aux acc r
+ | contents -> aux ((id, {g with contents}) :: acc) r )
+ | [] -> (
+ match acc with
| [] -> k (Exercises [])
- | l -> k (Groups (List.rev l))
+ | l -> k (Groups (List.rev l)) )
in
aux [] gs
| Exercises l ->
let rec aux acc = function
- | (id, Some ex) :: r ->
- (f id ex @@ function
- | true -> aux ((id, Some ex) :: acc) r
- | false -> aux acc r)
+ | (id, Some ex) :: r -> (
+ f id ex
+ @@ function
+ | true -> aux ((id, Some ex) :: acc) r | false -> aux acc r )
| (_, None) :: r -> aux acc r
| [] -> k (Exercises (List.rev acc))
in
@@ -864,50 +803,46 @@ module Exercise = struct
* | _ -> acc)
* [] (List.rev l)
* |> (function l -> Exercises l) *)
-
end
module Graph = struct
-
type relation = Skill of string | Exercise of id
- type node =
- { name : id;
- mutable children : (node * relation list) list }
+ type node = {name : id; mutable children : (node * relation list) list}
+
+ let node_exercise {name; _} = name
- let node_exercise { name; _ } = name
- let node_children { children; _ } = children
+ let node_children {children; _} = children
let ex_node exs id =
- try Hashtbl.find exs id
- with Not_found ->
- let node = { name = id; children = [] } in
- Hashtbl.add exs id node;
- node
+ try Hashtbl.find exs id with Not_found ->
+ let node = {name = id; children = []} in
+ Hashtbl.add exs id node; node
let merge_children ch =
let rec merge acc = function
| [] -> acc
- | (n, ks) :: [] -> (n, ks) :: acc
- | (n, ks) :: (((n', ks') :: rem) as ch') ->
+ | [(n, ks)] -> (n, ks) :: acc
+ | (n, ks) :: ((n', ks') :: rem as ch') ->
if n.name = n'.name then merge acc ((n, ks @ ks') :: rem)
else merge ((n, ks) :: acc) ch'
in
List.fast_sort (fun (n1, _) (n2, _) -> compare n1.name n2.name) ch
|> merge []
-
let compute_node ex_id ex_meta focus exercises =
let exs =
- List.map (fun id -> ex_node exercises id, [Exercise ex_id])
+ List.map
+ (fun id -> (ex_node exercises id, [Exercise ex_id]))
ex_meta.Meta.backward
in
let exs =
- List.fold_left (fun exs skill ->
- List.fold_left (fun exs id ->
- (ex_node exercises id, [Skill skill]) :: exs)
- exs (SMap.find skill focus)
- ) exs ex_meta.Meta.requirements
+ List.fold_left
+ (fun exs skill ->
+ List.fold_left
+ (fun exs id -> (ex_node exercises id, [Skill skill]) :: exs)
+ exs (SMap.find skill focus) )
+ exs ex_meta.Meta.requirements
in
let exs = merge_children exs in
let node = ex_node exercises ex_id in
@@ -916,52 +851,55 @@ module Exercise = struct
let focus_map exercises =
let add_ex focus (id, skill) =
- let exs =
- try SMap.find skill focus
- with Not_found -> [] in
+ let exs = try SMap.find skill focus with Not_found -> [] in
SMap.add skill (id :: exs) focus
in
Index.fold_exercises
(fun focus id meta ->
- List.fold_left add_ex focus
- @@ List.map (fun s -> id, s) meta.Meta.focus)
+ List.fold_left add_ex focus
+ @@ List.map (fun s -> (id, s)) meta.Meta.focus )
SMap.empty exercises
let apply_filters filters exercises =
- Index.filter (fun id _ ->
- not (List.mem (Exercise id) filters)) exercises |>
- Index.map_exercises (fun _ meta ->
- let requirements =
- List.filter (fun s -> not (List.mem (Skill s) filters))
- meta.Meta.requirements in
- let focus =
- List.filter (fun s -> not (List.mem (Skill s) filters))
- meta.Meta.focus in
- let backward =
- List.filter (fun s -> not (List.mem (Exercise s) filters))
- meta.Meta.backward in
- { meta with Meta.requirements; Meta.focus; Meta.backward })
-
- let compute_graph ?(filters=[]) exercises =
+ Index.filter (fun id _ -> not (List.mem (Exercise id) filters)) exercises
+ |> Index.map_exercises (fun _ meta ->
+ let requirements =
+ List.filter
+ (fun s -> not (List.mem (Skill s) filters))
+ meta.Meta.requirements
+ in
+ let focus =
+ List.filter
+ (fun s -> not (List.mem (Skill s) filters))
+ meta.Meta.focus
+ in
+ let backward =
+ List.filter
+ (fun s -> not (List.mem (Exercise s) filters))
+ meta.Meta.backward
+ in
+ {meta with Meta.requirements; Meta.focus; Meta.backward} )
+
+ let compute_graph ?(filters = []) exercises =
let exercises_nodes = Hashtbl.create 17 in
let ex_filtered = apply_filters filters exercises in
let focus = focus_map ex_filtered in
let compute acc ex_id ex_meta =
compute_node ex_id ex_meta focus exercises_nodes :: acc
in
- Index.fold_exercises (fun acc id meta -> compute acc id meta) [] ex_filtered
+ Index.fold_exercises
+ (fun acc id meta -> compute acc id meta)
+ [] ex_filtered
let compute_exercise_set graph =
let seen = ref SSet.empty in
let rec compute acc node =
if SSet.mem node.name !seen then acc
- else begin
+ else (
seen := SSet.add node.name !seen;
- List.fold_right (fun (node, _kinds) acc ->
- compute acc node)
- node.children
- (node.name :: acc)
- end
+ List.fold_right
+ (fun (node, _kinds) acc -> compute acc node)
+ node.children (node.name :: acc) )
in
compute [] graph
@@ -971,326 +909,265 @@ module Exercise = struct
| Exercise s -> Format.fprintf fmt "(E %s)" s
in
let print_child fmt ex child kinds =
- Format.fprintf fmt "%s -> %s [label=\"%a\"];\n"
- ex
- child.name
- (fun fmt -> List.iter (print_kind fmt)) kinds
+ Format.fprintf fmt "%s -> %s [label=\"%a\"];\n" ex child.name
+ (fun fmt -> List.iter (print_kind fmt))
+ kinds
in
let print_node fmt n =
- List.iter (fun (child, kinds) ->
- print_child fmt n.name child kinds)
+ List.iter
+ (fun (child, kinds) -> print_child fmt n.name child kinds)
n.children
in
- Format.fprintf fmt
- "digraph exercises {\n\
- %a\n\
- }"
- (fun fmt -> List.iter (print_node fmt)) nodes
-
+ Format.fprintf fmt "digraph exercises {\n%a\n}"
+ (fun fmt -> List.iter (print_node fmt))
+ nodes
end
-
end
module Lesson = struct
-
type id = string
- type phrase =
- | Text of string
- | Code of string
+ type phrase = Text of string | Code of string
- type step = {
- step_title: string;
- step_phrases: phrase list;
- }
+ type step = {step_title : string; step_phrases : phrase list}
- type t = {
- title: string;
- steps: step list;
- }
+ type t = {title : string; steps : step list}
let enc =
- enc_check_version_2 @@
- J.conv
- (fun t -> (t.title, t.steps))
- (fun (title, steps) -> { title; steps }) @@
- J.obj2
- J.(req "title" string)
- J.(req "steps"
- (list @@
- conv
- (fun s -> (s.step_title, s.step_phrases))
- (fun (step_title, step_phrases) -> {step_title; step_phrases}) @@
- (obj2
- (req "title" string)
- (req "contents"
- (list @@ union
- [ case
- (obj1 (req "html" string))
- (function Text text -> Some text | Code _ -> None)
- (fun text -> Text text) ;
- case
- (obj1 (req "code" string))
- (function Code code -> Some code | Text _ -> None)
- (fun code -> Code code) ])))))
+ enc_check_version_2
+ @@ J.conv
+ (fun t -> (t.title, t.steps))
+ (fun (title, steps) -> {title; steps})
+ @@ J.obj2
+ J.(req "title" string)
+ J.(
+ req "steps"
+ ( list
+ @@ conv
+ (fun s -> (s.step_title, s.step_phrases))
+ (fun (step_title, step_phrases) -> {step_title; step_phrases})
+ @@ obj2 (req "title" string)
+ (req "contents"
+ ( list
+ @@ union
+ [ case
+ (obj1 (req "html" string))
+ (function
+ | Text text -> Some text | Code _ -> None)
+ (fun text -> Text text)
+ ; case
+ (obj1 (req "code" string))
+ (function
+ | Code code -> Some code | Text _ -> None)
+ (fun code -> Code code) ] )) ))
module Index = struct
-
type t = (id * string) list
let enc =
- enc_check_version_2 @@
- J.(obj1 (req "lessons" (list @@ tup2 string string)))
-
+ enc_check_version_2
+ @@ J.(obj1 (req "lessons" (list @@ tup2 string string)))
end
-
end
module Tutorial = struct
-
type id = string
- type code = {
- code: string;
- runnable: bool;
- }
+ type code = {code : string; runnable : bool}
type word =
| Text of string
| Code of code
| Emph of text
- | Image of { alt : string ; mime : string ; contents : bytes }
+ | Image of {alt : string; mime : string; contents : bytes}
| Math of string
- and text =
- word list
+ and text = word list
type phrase =
| Paragraph of text
| Enum of phrase list list
| Code_block of code
- type step = {
- step_title: text;
- step_contents: phrase list;
- }
+ type step = {step_title : text; step_contents : phrase list}
- type t = {
- title: text;
- steps: step list;
- }
+ type t = {title : text; steps : step list}
let text_enc =
- J.mu "text" @@ fun content_enc ->
+ J.mu "text"
+ @@ fun content_enc ->
let word_enc =
J.union
[ J.case J.string
(function Text text -> Some text | _ -> None)
- (fun text -> Text text) ;
- J.case
+ (fun text -> Text text)
+ ; J.case
J.(obj1 (req "text" string))
(function Text text -> Some text | _ -> None)
- (fun text -> Text text) ;
- J.case
+ (fun text -> Text text)
+ ; J.case
J.(obj1 (req "emph" content_enc))
(function Emph content -> Some content | _ -> None)
- (fun content -> Emph content) ;
- J.case
+ (fun content -> Emph content)
+ ; J.case
J.(obj2 (req "code" string) (dft "runnable" bool false))
- (function Code { code ; runnable } -> Some (code, runnable)
- | _ -> None)
- (fun (code, runnable) -> Code { code ; runnable }) ;
- J.case
+ (function
+ | Code {code; runnable} -> Some (code, runnable) | _ -> None)
+ (fun (code, runnable) -> Code {code; runnable})
+ ; J.case
J.(obj1 (req "math" string))
- (function Math math-> Some math | _ -> None)
- (fun math -> Math math) ;
- J.case
+ (function Math math -> Some math | _ -> None)
+ (fun math -> Math math)
+ ; J.case
J.(obj3 (req "image" bytes) (req "alt" string) (req "mime" string))
(function
- | Image { alt ; mime ; contents = image } ->
- Some (image, alt, mime)
+ | Image {alt; mime; contents = image} -> Some (image, alt, mime)
| _ -> None)
- (fun (image, alt, mime) ->
- Image { alt ; mime ; contents = image }) ] in
+ (fun (image, alt, mime) -> Image {alt; mime; contents = image}) ]
+ in
J.union
- [ J.case
- word_enc
- (function [ ctns ] -> Some ctns | _ -> None) (fun ctns -> [ ctns ]) ;
- J.case
- (J.list @@ word_enc)
- (fun ctns -> Some ctns) (fun ctns -> ctns) ]
+ [ J.case word_enc
+ (function [ctns] -> Some ctns | _ -> None)
+ (fun ctns -> [ctns])
+ ; J.case (J.list @@ word_enc) (fun ctns -> Some ctns) (fun ctns -> ctns)
+ ]
let phrase_enc =
- J.mu "phrase" @@ fun phrase_enc ->
+ J.mu "phrase"
+ @@ fun phrase_enc ->
J.union
[ J.case
J.(obj1 (req "paragraph" text_enc))
(function Paragraph phrase -> Some phrase | _ -> None)
- (fun phrase -> Paragraph phrase) ;
- J.case
+ (fun phrase -> Paragraph phrase)
+ ; J.case
J.(obj1 (req "enum" (list (list phrase_enc))))
(function Enum items -> Some items | _ -> None)
- (fun items -> Enum items) ;
- J.case
+ (fun items -> Enum items)
+ ; J.case
J.(obj2 (req "code" string) (dft "runnable" bool false))
- (function Code_block { code ; runnable } ->
- Some (code, runnable) | _ -> None)
- (fun (code, runnable) ->
- Code_block { code ; runnable }) ;
- J.case
- text_enc
+ (function
+ | Code_block {code; runnable} -> Some (code, runnable) | _ -> None)
+ (fun (code, runnable) -> Code_block {code; runnable})
+ ; J.case text_enc
(function Paragraph phrase -> Some phrase | _ -> None)
(fun phrase -> Paragraph phrase) ]
let enc =
- enc_check_version_2 @@
- J.conv
- (fun t -> t.title, t.steps)
- (fun (title, steps) -> {title; steps}) @@
- J.obj2
- (J.req "title" text_enc)
- (J.req "steps"
- (J.list @@
- J.conv
- (fun t -> t.step_title, t.step_contents)
- (fun (step_title, step_contents) -> {step_title; step_contents}) @@
- J.(obj2
- (req "title" text_enc)
- (req "contents" (list phrase_enc)))))
+ enc_check_version_2
+ @@ J.conv
+ (fun t -> (t.title, t.steps))
+ (fun (title, steps) -> {title; steps})
+ @@ J.obj2 (J.req "title" text_enc)
+ (J.req "steps"
+ ( J.list
+ @@ J.conv
+ (fun t -> (t.step_title, t.step_contents))
+ (fun (step_title, step_contents) ->
+ {step_title; step_contents} )
+ @@ J.(
+ obj2 (req "title" text_enc) (req "contents" (list phrase_enc)))
+ ))
module Index = struct
+ type entry = {name : string; title : text}
- type entry = {
- name: string;
- title: text;
- }
-
- type series = {
- series_title: string;
- series_tutorials: entry list;
- }
+ type series = {series_title : string; series_tutorials : entry list}
type t = (id * series) list
let enc =
let entry_enc =
- J.union [
- J.case
- J.(tup2 string text_enc)
- (function ({title = []; _}: entry) -> None
- | {name; title} -> Some (name, title))
- (fun (name, title) -> {name; title});
- J.case
- J.string
- (function {name; title = []} -> Some name
- | _ -> None)
- (fun name -> {name; title = []});
- ]
+ J.union
+ [ J.case
+ J.(tup2 string text_enc)
+ (function
+ | ({title = []; _} : entry) -> None
+ | {name; title} -> Some (name, title))
+ (fun (name, title) -> {name; title})
+ ; J.case J.string
+ (function {name; title = []} -> Some name | _ -> None)
+ (fun name -> {name; title = []}) ]
in
let series_enc =
J.conv
- (fun t ->
- (t.series_title, t.series_tutorials))
+ (fun t -> (t.series_title, t.series_tutorials))
(fun (series_title, series_tutorials) ->
- {series_title; series_tutorials}) @@
- J.obj2
- J.(req "title" string)
- J.(req "tutorials" (list entry_enc)) in
- enc_check_version_1 @@
- J.(obj1 (req "series" (assoc series_enc)))
-
+ {series_title; series_tutorials} )
+ @@ J.obj2 J.(req "title" string) J.(req "tutorials" (list entry_enc))
+ in
+ enc_check_version_1 @@ J.(obj1 (req "series" (assoc series_enc)))
end
end
module Partition = struct
type t =
- {
- not_graded : Token.t list;
- bad_type : Token.t list;
- partition_by_grade :
- (int *
- (((Token.t * string) list) Asak.Wtree.wtree list))
- list;
- }
+ { not_graded : Token.t list
+ ; bad_type : Token.t list
+ ; partition_by_grade :
+ (int * (Token.t * string) list Asak.Wtree.wtree list) list }
let token_list = J.list Token.enc
let tree_enc leaf_enc =
let open Asak.Wtree in
- J.mu "tree" @@ fun self ->
- J.union
- [ J.case (J.obj1 (J.req "leaf" leaf_enc))
- (function Leaf x -> Some x | Node _ -> None)
- (fun x -> Leaf x) ;
- J.case (J.obj3 (J.req "coef" J.int) (J.req "left" self) (J.req "right" self))
- (function Node (t,l,r) -> Some (t,l,r) | Leaf _ -> None)
- (fun (t,l,r) -> Node (t,l,r)) ]
-
- let leaf_enc =
- J.list (J.tup2 Token.enc J.string)
+ J.mu "tree"
+ @@ fun self ->
+ J.union
+ [ J.case
+ (J.obj1 (J.req "leaf" leaf_enc))
+ (function Leaf x -> Some x | Node _ -> None)
+ (fun x -> Leaf x)
+ ; J.case
+ (J.obj3 (J.req "coef" J.int) (J.req "left" self) (J.req "right" self))
+ (function Node (t, l, r) -> Some (t, l, r) | Leaf _ -> None)
+ (fun (t, l, r) -> Node (t, l, r)) ]
+
+ let leaf_enc = J.list (J.tup2 Token.enc J.string)
let innerlist = J.list (tree_enc leaf_enc)
- let int_assoc =
- J.tup2 J.int innerlist
+ let int_assoc = J.tup2 J.int innerlist
let enc =
J.conv
- (fun t ->
- (t.not_graded, t.bad_type, t.partition_by_grade))
+ (fun t -> (t.not_graded, t.bad_type, t.partition_by_grade))
(fun (not_graded, bad_type, partition_by_grade) ->
- {not_graded; bad_type; partition_by_grade}) @@
- J.obj3
- J.(req "not_graded" token_list)
- J.(req "bad_type" token_list)
- J.(req "patition_by_grade" (J.list int_assoc))
+ {not_graded; bad_type; partition_by_grade} )
+ @@ J.obj3
+ J.(req "not_graded" token_list)
+ J.(req "bad_type" token_list)
+ J.(req "patition_by_grade" (J.list int_assoc))
end
module Playground = struct
type id = string
- type t =
- { id : id ;
- prelude : string ;
- template : string ;
- }
+ type t = {id : id; prelude : string; template : string}
let enc =
J.conv
- (fun { id; prelude; template } ->
- id, prelude, template)
- (fun (id, prelude, template) ->
- { id ; prelude ; template })
- (J.obj3
- (J.req "id" J.string)
- (J.req "prelude" J.string)
- (J.req "template" J.string))
+ (fun {id; prelude; template} -> (id, prelude, template))
+ (fun (id, prelude, template) -> {id; prelude; template})
+ (J.obj3 (J.req "id" J.string) (J.req "prelude" J.string)
+ (J.req "template" J.string))
module Meta = struct
- type t =
- {
- title: string;
- short_description: string option;
- }
+ type t = {title : string; short_description : string option}
- let default id = {title=id; short_description=None}
+ let default id = {title = id; short_description = None}
let enc =
- J.conv
- (fun { title; short_description } ->
- title, short_description)
- (fun (title, short_description) ->
- { title; short_description })
- (J.obj2
- (J.req "title" J.string)
- (J.req "short_description" (J.option J.string)))
+ J.conv
+ (fun {title; short_description} -> (title, short_description))
+ (fun (title, short_description) -> {title; short_description})
+ (J.obj2 (J.req "title" J.string)
+ (J.req "short_description" (J.option J.string)))
end
module Index = struct
-
type t = (id * Meta.t) list
let enc = J.list (J.tup2 J.string Meta.enc)
-
end
end
diff --git a/src/state/learnocaml_data.mli b/src/state/learnocaml_data.mli
index 2408c5eec..f97d12c89 100644
--- a/src/state/learnocaml_data.mli
+++ b/src/state/learnocaml_data.mli
@@ -5,281 +5,248 @@
*
* Learn-OCaml is distributed under the terms of the MIT license. See the
* included LICENSE file for details. *)
-
-module SMap: sig
-
+module SMap : sig
include Map.S with type key = string
- val enc: 'a Json_encoding.encoding -> 'a t Json_encoding.encoding
-
+ val enc : 'a Json_encoding.encoding -> 'a t Json_encoding.encoding
end
-module SSet: sig
-
+module SSet : sig
include Set.S with type elt = string
- val enc: t Json_encoding.encoding
+ val enc : t Json_encoding.encoding
+ val merge3 : ancestor:t -> theirs:t -> ours:t -> t
(** Three-way merge. [ours] always wins if it was modified from [ancestor] *)
- val merge3: ancestor:t -> theirs:t -> ours:t -> t
-
end
module Report = Learnocaml_report
-module Answer: sig
-
- type t = {
- solution: string ;
- grade: int (* \in [0, 100] *) option ;
- report: Report.t option ;
- mtime: float
- }
-
- val enc: t Json_encoding.encoding
+module Answer : sig
+ type t =
+ { solution : string
+ ; grade : int (* \in [0, 100] *) option
+ ; report : Report.t option
+ ; mtime : float }
+ val enc : t Json_encoding.encoding
end
-module Save: sig
-
- type t = {
- nickname: string ;
- all_exercise_editors: (float * string) SMap.t;
- all_exercise_states: Answer.t SMap.t;
- all_toplevel_histories: Learnocaml_toplevel_history.snapshot SMap.t;
- all_exercise_toplevel_histories:
- Learnocaml_toplevel_history.snapshot SMap.t;
- }
+module Save : sig
+ type t =
+ { nickname : string
+ ; all_exercise_editors : (float * string) SMap.t
+ ; all_exercise_states : Answer.t SMap.t
+ ; all_toplevel_histories : Learnocaml_toplevel_history.snapshot SMap.t
+ ; all_exercise_toplevel_histories :
+ Learnocaml_toplevel_history.snapshot SMap.t }
- val enc: t Json_encoding.encoding
+ val enc : t Json_encoding.encoding
+ val sync : t -> t -> t
(** Merges two save files, trusting the [mtime] fields to take the most recent
versions of every item. All other things equal, the fields from the second
argument are preferred. *)
- val sync: t -> t -> t
+ val fix_mtimes : t -> t
(** Checks all [mtime] fields to get them back to now in case they are in the
future. Needed for save files that come from clients with possibly bad
clocks. *)
- val fix_mtimes: t -> t
-
- val empty: t
+ val empty : t
end
-module Token: sig
+module Token : sig
type t
- val enc: t Json_encoding.encoding
+ val enc : t Json_encoding.encoding
+
+ val to_path : t -> string
+
+ val to_string : t -> string
+
+ val parse : string -> t
+
+ val check : string -> bool
+
+ val random : unit -> t
- val to_path: t -> string
- val to_string: t -> string
- val parse: string -> t
- val check: string -> bool
- val random: unit -> t
- val random_teacher: unit -> t
- val is_teacher: t -> bool
- val is_student: t -> bool
+ val random_teacher : unit -> t
+ val is_teacher : t -> bool
+
+ val is_student : t -> bool
+
+ val teacher_tokens_path : string
(** The relative path containing teacher tokens *)
- val teacher_tokens_path: string
- module Set: Set.S with type elt = t
+ module Set : Set.S with type elt = t
- module Map: Map.S with type key = t
+ module Map : Map.S with type key = t
end
type 'a token = Token.t
type student
-type teacher
-
-module Student: sig
- type t = {
- token: student token;
- nickname: string option;
- results: (float * int option) SMap.t;
- creation_date: float;
- tags: SSet.t;
- }
+type teacher
- val enc: t Json_encoding.encoding
+module Student : sig
+ type t =
+ { token : student token
+ ; nickname : string option
+ ; results : (float * int option) SMap.t
+ ; creation_date : float
+ ; tags : SSet.t }
- val default: student token -> t
+ val enc : t Json_encoding.encoding
- val three_way_merge: ancestor:t -> theirs:t -> ours:t -> t
+ val default : student token -> t
- module Index: sig
+ val three_way_merge : ancestor:t -> theirs:t -> ours:t -> t
+ module Index : sig
type nonrec t = t list
- val enc: t Json_encoding.encoding
-
+ val enc : t Json_encoding.encoding
end
-
end
module Server : sig
(* preconfig: the type of configuration files in the corpus repository,
where users can pre-set some of the server settings. *)
- type preconfig = {
- secret : string option;
- }
+ type preconfig = {secret : string option}
+
val empty_preconfig : preconfig
(* config: the type of configuration of a running server, generated
from the preconfig during the 'build' stage. *)
- type config = {
- secret : string option; (* maybe a secret *)
- server_id : int; (* random integer generated each building time *)
- }
+ type config =
+ { secret : string option
+ ; (* maybe a secret *)
+ server_id : int
+ (* random integer generated each building time *) }
val build_config : preconfig -> config
- val preconfig_enc: preconfig Json_encoding.encoding
- val config_enc: config Json_encoding.encoding
-end
+ val preconfig_enc : preconfig Json_encoding.encoding
-module Exercise: sig
+ val config_enc : config Json_encoding.encoding
+end
+module Exercise : sig
type id = string
type t = Learnocaml_exercise.t
- val enc: t Json_encoding.encoding
-
- module Meta: sig
+ val enc : t Json_encoding.encoding
- type kind =
- | Project
- | Problem
- | Exercise
-
- type t = {
- kind: kind;
- title: string;
- short_description: string option;
- stars: float (** \in [0.,4.] *);
- id: id option;
- author: (string * string) list;
- focus: string list;
- requirements: string list;
- forward: id list;
- backward: id list;
- }
-
- val enc: t Json_encoding.encoding
+ module Meta : sig
+ type kind = Project | Problem | Exercise
+ type t =
+ { kind : kind
+ ; title : string
+ ; short_description : string option
+ ; stars : float (** \in [0.,4.] *)
+ ; id : id option
+ ; author : (string * string) list
+ ; focus : string list
+ ; requirements : string list
+ ; forward : id list
+ ; backward : id list }
+
+ val enc : t Json_encoding.encoding
end
- module Status: sig
-
+ module Status : sig
type skill
- type status =
- | Open
- | Closed
- | Assigned of {start: float; stop: float}
+ type status = Open | Closed | Assigned of {start : float; stop : float}
- type assignments = {
- token_map: status Token.Map.t;
- default: status;
- }
+ type assignments = {token_map : status Token.Map.t; default : status}
- type t = {
- id: id;
- skills_prereq: skill list;
- skills_focus: skill list;
- assignments: assignments;
- }
+ type t =
+ { id : id
+ ; skills_prereq : skill list
+ ; skills_focus : skill list
+ ; assignments : assignments }
- val default: id -> t
+ val default : id -> t
- val default_assignment: assignments -> status
+ val default_assignment : assignments -> status
- val set_default_assignment: assignments -> status -> assignments
+ val set_default_assignment : assignments -> status -> assignments
- val get_status:
- Token.t -> assignments -> status
+ val get_status : Token.t -> assignments -> status
- val is_open_assignment:
+ val is_open_assignment :
Token.t -> assignments -> [> `Open | `Closed | `Deadline of float]
- val by_status:
- Token.Set.t -> assignments -> (status * Token.Set.t) list
+ val by_status : Token.Set.t -> assignments -> (status * Token.Set.t) list
+ val get_skills : base:string list -> skill list -> string list
(** Computes the current set of skills from the base list (from Meta.t),
using the mutable changes in the Status.skill list. E.g. {[
get_skills ~base:meta.Meta.requirements st.skills_prereq
]} *)
- val get_skills: base:string list -> skill list -> string list
+ val skills_base : current:string list -> skill list -> string list
(** The opposite of [get_skills]: retrieves the base from the already
updated version and the skill list that has been applied to it. Since the
server provides [skills] (= [get_skills meta_base status_skills]), this
is useful to recover [meta_base]. *)
- val skills_base: current:string list -> skill list -> string list
- val skills_prereq: Meta.t -> t -> string list
+ val skills_prereq : Meta.t -> t -> string list
- val skills_focus: Meta.t -> t -> string list
+ val skills_focus : Meta.t -> t -> string list
+ val make_skills : base:string list -> string list -> skill list
(** Generates a skill list that can be saved, such that
{[get_skills ~base (make_skills ~base l) = l]}.
Remember to call [skills_base] first on the base if you got the
skills from the meta returned by the server. *)
- val make_skills: base:string list -> string list -> skill list
+ val three_way_merge : ancestor:t -> theirs:t -> ours:t -> t
(** Merges all changes from [theirs] and [ours], based on [ancestor]. [ours]
is privileged in case of any conflict (e.g. different affectation of the
same student) *)
- val three_way_merge:
- ancestor:t -> theirs:t -> ours:t -> t
- val make_assignments:
- status Token.Map.t -> status -> assignments
-
- val enc: t Json_encoding.encoding
+ val make_assignments : status Token.Map.t -> status -> assignments
+ val enc : t Json_encoding.encoding
end
- module Index: sig
-
+ module Index : sig
type t =
| Exercises of (id * Meta.t option) list
| Groups of (string * group) list
- and group =
- { title : string;
- contents : t }
- val enc: t Json_encoding.encoding
+ and group = {title : string; contents : t}
- val find: t -> id -> Meta.t
+ val enc : t Json_encoding.encoding
- val find_opt: t -> id -> Meta.t option
+ val find : t -> id -> Meta.t
- val map_exercises: (id -> Meta.t -> Meta.t) -> t -> t
+ val find_opt : t -> id -> Meta.t option
- val fold_exercises: ('a -> id -> Meta.t -> 'a) -> 'a -> t -> 'a
+ val map_exercises : (id -> Meta.t -> Meta.t) -> t -> t
- val filter: (id -> Meta.t -> bool) -> t -> t
+ val fold_exercises : ('a -> id -> Meta.t -> 'a) -> 'a -> t -> 'a
+ val filter : (id -> Meta.t -> bool) -> t -> t
+
+ val mapk_exercises :
+ (id -> Meta.t -> (Meta.t -> 'a) -> 'a) -> t -> (t -> 'a) -> 'a
(** CPS version of [map_exercises] *)
- val mapk_exercises:
- (id -> Meta.t -> (Meta.t -> 'a) -> 'a) ->
- t ->
- (t -> 'a) -> 'a
+ val filterk : (id -> Meta.t -> (bool -> 'a) -> 'a) -> t -> (t -> 'a) -> 'a
(** CPS version of [filter] *)
- val filterk: (id -> Meta.t -> (bool -> 'a) -> 'a) -> t -> (t -> 'a) -> 'a
-
end
(** Dependency graph of exercises *)
module Graph : sig
-
(** Two exercises can be related either by a skill dependency, or backward
relationship *)
type relation = Skill of string | Exercise of id
@@ -290,151 +257,104 @@ module Exercise: sig
type node
val node_exercise : node -> id
+
val node_children : node -> (node * relation list) list
+ val compute_graph : ?filters:relation list -> Index.t -> node list
(** Computes the dependency graph of exercises, and filters out exercises
or skills if any are given. *)
- val compute_graph : ?filters:relation list -> Index.t -> node list
+ val compute_exercise_set : node -> string list
(** Computes a set of exercises that appear as dependencies of the given
exercise. *)
- val compute_exercise_set : node -> string list
- (** Dumps the graph as a `dot` representation, into the given formatter. *)
val dump_dot : Format.formatter -> node list -> unit
-
+ (** Dumps the graph as a `dot` representation, into the given formatter. *)
end
-
end
-module Lesson: sig
-
+module Lesson : sig
type id = string
- type phrase =
- | Text of string
- | Code of string
-
- type step = {
- step_title: string;
- step_phrases: phrase list;
- }
+ type phrase = Text of string | Code of string
- type t = {
- title: string;
- steps: step list;
- }
+ type step = {step_title : string; step_phrases : phrase list}
- val enc: t Json_encoding.encoding
+ type t = {title : string; steps : step list}
- module Index: sig
+ val enc : t Json_encoding.encoding
+ module Index : sig
type t = (id * string) list
- val enc: t Json_encoding.encoding
-
+ val enc : t Json_encoding.encoding
end
-
end
-module Tutorial: sig
-
+module Tutorial : sig
type id = string
- type code = {
- code: string;
- runnable: bool;
- }
+ type code = {code : string; runnable : bool}
type word =
| Text of string
| Code of code
| Emph of text
- | Image of { alt : string ; mime : string ; contents : bytes }
+ | Image of {alt : string; mime : string; contents : bytes}
| Math of string
- and text =
- word list
+ and text = word list
type phrase =
| Paragraph of text
| Enum of phrase list list
| Code_block of code
- type step = {
- step_title: text;
- step_contents: phrase list;
- }
-
- type t = {
- title: text;
- steps: step list;
- }
+ type step = {step_title : text; step_contents : phrase list}
- val enc: t Json_encoding.encoding
+ type t = {title : text; steps : step list}
- module Index: sig
+ val enc : t Json_encoding.encoding
- type entry = {
- name: string;
- title: text;
- }
+ module Index : sig
+ type entry = {name : string; title : text}
- type series = {
- series_title: string;
- series_tutorials: entry list;
- }
+ type series = {series_title : string; series_tutorials : entry list}
type t = (id * series) list
- val enc: t Json_encoding.encoding
-
+ val enc : t Json_encoding.encoding
end
-
end
module Partition : sig
type t =
- {
- not_graded : Token.t list;
- bad_type : Token.t list;
- partition_by_grade :
- (int *
- (((Token.t * string) list) Asak.Wtree.wtree list))
- list;
- }
-
- val enc: t Json_encoding.encoding
+ { not_graded : Token.t list
+ ; bad_type : Token.t list
+ ; partition_by_grade :
+ (int * (Token.t * string) list Asak.Wtree.wtree list) list }
+
+ val enc : t Json_encoding.encoding
end
module Playground : sig
type id = string
- type t =
- { id : id ;
- prelude : string ;
- template : string ;
- }
+ type t = {id : id; prelude : string; template : string}
- val enc: t Json_encoding.encoding
+ val enc : t Json_encoding.encoding
module Meta : sig
- type t =
- {
- title: string;
- short_description: string option;
- }
+ type t = {title : string; short_description : string option}
val default : string -> t
- val enc: t Json_encoding.encoding
+ val enc : t Json_encoding.encoding
end
- module Index: sig
-
+ module Index : sig
type t = (id * Meta.t) list
- val enc: t Json_encoding.encoding
-
+ val enc : t Json_encoding.encoding
end
end
diff --git a/src/state/learnocaml_store.ml b/src/state/learnocaml_store.ml
index 06635abcb..eb2a254cd 100644
--- a/src/state/learnocaml_store.ml
+++ b/src/state/learnocaml_store.ml
@@ -8,7 +8,6 @@
open Lwt.Infix
open Learnocaml_data
-
module J = Json_encoding
let static_dir = ref (Filename.concat (Sys.getcwd ()) "www")
@@ -17,20 +16,17 @@ let sync_dir = ref (Filename.concat (Sys.getcwd ()) "sync")
module Json_codec = struct
let decode enc s =
- (match s with
- | "" -> `O []
- | s -> Ezjsonm.from_string s)
- |> J.destruct enc
+ (match s with "" -> `O [] | s -> Ezjsonm.from_string s) |> J.destruct enc
let encode ?minify enc x =
match J.construct enc x with
- | `A _ | `O _ as json -> Ezjsonm.to_string ?minify json
+ | (`A _ | `O _) as json -> Ezjsonm.to_string ?minify json
| `Null -> ""
| _ -> assert false
end
+
let get_from_file enc p =
- Lwt_io.(with_file ~mode: Input p read) >|=
- Json_codec.decode enc
+ Lwt_io.(with_file ~mode:Input p read) >|= Json_codec.decode enc
let write_to_file enc s p =
let open Lwt_io in
@@ -42,10 +38,8 @@ let sanitise_path prefix subpath =
| [] -> List.rev acc
| "" :: rest -> resolve acc rest
| "." :: rest -> resolve acc rest
- | ".." :: rest ->
- begin match acc with
- | [] -> resolve [] rest
- | _ :: acc -> resolve acc rest end
+ | ".." :: rest -> (
+ match acc with [] -> resolve [] rest | _ :: acc -> resolve acc rest )
| name :: rest -> resolve (name :: acc) rest
in
String.concat Filename.dir_sep (prefix :: resolve [] subpath)
@@ -56,133 +50,132 @@ let read_static_file path enc =
let with_git_register =
let dir_mutex = Lwt_utils.gen_mutex_table () in
- fun dir (f: unit -> string list Lwt.t) ->
+ fun dir (f : unit -> string list Lwt.t) ->
let git args () =
- Lwt_process.exec ("", Array.of_list ("git"::"-C"::dir::args)) >>= function
+ Lwt_process.exec ("", Array.of_list ("git" :: "-C" :: dir :: args))
+ >>= function
| Unix.WEXITED 0 -> Lwt.return_unit
| _ -> Lwt.fail_with ("git command failed: " ^ String.concat " " args)
in
- dir_mutex.Lwt_utils.with_lock dir @@ fun () ->
- (if Sys.file_exists (Filename.concat dir ".git") then
- git ["reset";"--hard"] ()
- else
- git ["init"] () >>=
- git ["config";"--local";"user.name";"Learn-OCaml user"] >>=
- git ["config";"--local";"user.email";"none@learn-ocaml.org"]) >>=
- f >>= fun files ->
- git ("add"::"--"::files) () >>=
- git ["commit";"--allow-empty";"-m";"Update"] >>=
- git ["update-server-info"]
-
-let write ?(no_create=false) file ?(extra=[]) contents =
+ dir_mutex.Lwt_utils.with_lock dir
+ @@ fun () ->
+ ( if Sys.file_exists (Filename.concat dir ".git") then
+ git ["reset"; "--hard"] ()
+ else
+ git ["init"] ()
+ >>= git ["config"; "--local"; "user.name"; "Learn-OCaml user"]
+ >>= git ["config"; "--local"; "user.email"; "none@learn-ocaml.org"] )
+ >>= f
+ >>= fun files ->
+ git ("add" :: "--" :: files) ()
+ >>= git ["commit"; "--allow-empty"; "-m"; "Update"]
+ >>= git ["update-server-info"]
+
+let write ?(no_create = false) file ?(extra = []) contents =
let dir = Filename.dirname file in
- (if not (Sys.file_exists file) then
- if no_create then Lwt.fail Not_found
- else Lwt_utils.mkdir_p ~perm:0o700 dir
- else Lwt.return_unit)
+ ( if not (Sys.file_exists file) then
+ if no_create then Lwt.fail Not_found else Lwt_utils.mkdir_p ~perm:0o700 dir
+ else Lwt.return_unit )
>>= fun () ->
let file = Filename.basename file in
- let write_file ?(flags=[Unix.O_TRUNC]) (fname, contents) =
+ let write_file ?(flags = [Unix.O_TRUNC]) (fname, contents) =
let file = sanitise_path dir (String.split_on_char '/' fname) in
- Lwt_utils.mkdir_p ~perm:0o700 (Filename.dirname file) >>= fun () ->
- Lwt_io.(with_file file
- ~flags:Unix.(O_WRONLY::O_NONBLOCK::O_CREAT::flags)
- ~mode:Output
- (fun chan -> write chan contents)) >|= fun () ->
- fname
+ Lwt_utils.mkdir_p ~perm:0o700 (Filename.dirname file)
+ >>= fun () ->
+ Lwt_io.(
+ with_file file
+ ~flags:Unix.(O_WRONLY :: O_NONBLOCK :: O_CREAT :: flags)
+ ~mode:Output
+ (fun chan -> write chan contents))
+ >|= fun () -> fname
in
let rec write_tmp () =
let tmpfile = Printf.sprintf "%s.%07x.tmp" file (Random.int 0x0fffffff) in
Lwt.catch
(fun () -> write_file ~flags:[Unix.O_EXCL] (tmpfile, contents))
- (function Unix.Unix_error (Unix.EEXIST, _, _) -> write_tmp ()
- | e -> Lwt.fail e)
+ (function
+ | Unix.Unix_error (Unix.EEXIST, _, _) -> write_tmp () | e -> Lwt.fail e)
in
- with_git_register dir @@ fun () ->
- write_tmp () >>= fun tmpfile ->
+ with_git_register dir
+ @@ fun () ->
+ write_tmp ()
+ >>= fun tmpfile ->
Lwt_unix.rename (Filename.concat dir tmpfile) (Filename.concat dir file)
>>= fun () ->
- Lwt_list.map_s write_file extra >>= fun extra ->
- Lwt.return (file :: extra)
-
+ Lwt_list.map_s write_file extra >>= fun extra -> Lwt.return (file :: extra)
module Lesson = struct
-
module Index = struct
-
include Lesson.Index
- let get () =
- read_static_file Learnocaml_index.lesson_index_path enc
-
+ let get () = read_static_file Learnocaml_index.lesson_index_path enc
end
- include (Lesson: module type of struct include Lesson end
- with module Index := Index)
-
- let get id =
- read_static_file (Learnocaml_index.lesson_path id) enc
+ include (
+ Lesson :
+ module type of struct
+ include Lesson
+ end
+ with module Index := Index )
+ let get id = read_static_file (Learnocaml_index.lesson_path id) enc
end
module Playground = struct
-
module Index = struct
-
include Playground.Index
- let get () =
- read_static_file Learnocaml_index.playground_index_path enc
-
+ let get () = read_static_file Learnocaml_index.playground_index_path enc
end
- include (Playground: module type of struct include Playground end
- with module Index := Index)
-
- let get id =
- read_static_file (Learnocaml_index.playground_path id) enc
+ include (
+ Playground :
+ module type of struct
+ include Playground
+ end
+ with module Index := Index )
+ let get id = read_static_file (Learnocaml_index.playground_path id) enc
end
module Server = struct
let get () =
Lwt.catch
- (fun () -> read_static_file Learnocaml_index.server_config_path Server.config_enc)
+ (fun () ->
+ read_static_file Learnocaml_index.server_config_path Server.config_enc
+ )
(fun e ->
match e with
- | Unix.Unix_error (Unix.ENOENT,_,_) ->
- Lwt.return @@ Server.build_config Server.empty_preconfig
- | e -> raise e
- )
+ | Unix.Unix_error (Unix.ENOENT, _, _) ->
+ Lwt.return @@ Server.build_config Server.empty_preconfig
+ | e -> raise e )
end
module Tutorial = struct
-
module Index = struct
-
include Tutorial.Index
- let get () =
- read_static_file Learnocaml_index.tutorial_index_path enc
-
+ let get () = read_static_file Learnocaml_index.tutorial_index_path enc
end
- include (Tutorial: module type of struct include Tutorial end
- with module Index := Index)
-
- let get id =
- read_static_file (Learnocaml_index.tutorial_path id) enc
+ include (
+ Tutorial :
+ module type of struct
+ include Tutorial
+ end
+ with module Index := Index )
+ let get id = read_static_file (Learnocaml_index.tutorial_path id) enc
end
module Exercise = struct
-
type id = Exercise.id
let index =
- ref (lazy (
- read_static_file Learnocaml_index.exercise_index_path Exercise.Index.enc
- ))
+ ref
+ ( lazy
+ (read_static_file Learnocaml_index.exercise_index_path
+ Exercise.Index.enc) )
module Meta0 = struct
include Exercise.Meta
@@ -196,185 +189,189 @@ module Exercise = struct
let store_file () = Filename.concat !sync_dir "exercises.json"
- let tbl = lazy (
- let tbl = Hashtbl.create 223 in
- Lwt.catch (fun () ->
- get_from_file (J.list enc) (store_file ()) >|= fun l ->
- List.iter (fun st -> Hashtbl.add tbl st.id st) l;
- tbl)
- @@ function
- | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return tbl
- | e -> Lwt.fail e
- )
+ let tbl =
+ lazy
+ (let tbl = Hashtbl.create 223 in
+ Lwt.catch (fun () ->
+ get_from_file (J.list enc) (store_file ())
+ >|= fun l ->
+ List.iter (fun st -> Hashtbl.add tbl st.id st) l;
+ tbl )
+ @@ function
+ | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return tbl
+ | e -> Lwt.fail e)
let save () =
- Lazy.force tbl >>= fun tbl ->
- let l = Hashtbl.fold (fun _ s acc -> s::acc) tbl [] in
+ Lazy.force tbl
+ >>= fun tbl ->
+ let l = Hashtbl.fold (fun _ s acc -> s :: acc) tbl [] in
let s = Json_codec.encode (J.list enc) l in
write (store_file ()) s
let get id =
- Lazy.force tbl >>= fun tbl ->
- try Lwt.return (Hashtbl.find tbl id)
- with Not_found -> Meta0.get id >|= fun _ -> default id
+ Lazy.force tbl
+ >>= fun tbl ->
+ try Lwt.return (Hashtbl.find tbl id) with Not_found ->
+ Meta0.get id >|= fun _ -> default id
let set =
let mutex = Lwt_mutex.create () in
fun x ->
- Lwt_mutex.with_lock mutex @@ fun () ->
- Lazy.force tbl >>= fun tbl ->
- Hashtbl.replace tbl x.id x;
- save ()
+ Lwt_mutex.with_lock mutex
+ @@ fun () ->
+ Lazy.force tbl >>= fun tbl -> Hashtbl.replace tbl x.id x; save ()
let all () =
- Lazy.force tbl >|= fun tbl ->
- Hashtbl.fold (fun _ t acc -> t::acc) tbl []
+ Lazy.force tbl
+ >|= fun tbl -> Hashtbl.fold (fun _ t acc -> t :: acc) tbl []
let is_open id token =
- if Token.is_teacher token then Lwt.return `Open else
- Lazy.force tbl >|= fun tbl ->
- let assignments =
- match Hashtbl.find_opt tbl id with
- | None -> (default id).assignments
- | Some ex -> ex.assignments
- in
- is_open_assignment token assignments
-
+ if Token.is_teacher token then Lwt.return `Open
+ else
+ Lazy.force tbl
+ >|= fun tbl ->
+ let assignments =
+ match Hashtbl.find_opt tbl id with
+ | None -> (default id).assignments
+ | Some ex -> ex.assignments
+ in
+ is_open_assignment token assignments
end
module Meta = struct
include Meta0
let get id =
- get id >>= fun m ->
- Status.get id >|= fun s ->
+ get id
+ >>= fun m ->
+ Status.get id
+ >|= fun s ->
{ m with
- requirements = Status.skills_prereq m s;
- focus = Status.skills_focus m s }
-
+ requirements = Status.skills_prereq m s
+ ; focus = Status.skills_focus m s }
end
module Index = struct
include Exercise.Index
let get_from_index index =
- Exercise.Index.mapk_exercises (fun id m k ->
- Status.get id >>= fun s ->
- { m with Meta.requirements = Status.skills_prereq m s;
- Meta.focus = Status.skills_focus m s }
- |> k)
- index
- Lwt.return
-
- let get () =
- Lazy.force !index >>= get_from_index
+ Exercise.Index.mapk_exercises
+ (fun id m k ->
+ Status.get id
+ >>= fun s ->
+ { m with
+ Meta.requirements = Status.skills_prereq m s
+ ; Meta.focus = Status.skills_focus m s }
+ |> k )
+ index Lwt.return
+
+ let get () = Lazy.force !index >>= get_from_index
let reload () =
read_static_file Learnocaml_index.exercise_index_path Exercise.Index.enc
>|= fun i -> index := lazy (Lwt.return i)
-
end
- include (Exercise: module type of struct include Exercise end
- with type id := id
- and module Meta := Meta
- and module Status := Status
- and module Index := Index)
+ include (
+ Exercise :
+ module type of struct
+ include Exercise
+ end
+ with type id := id
+ and module Meta := Meta
+ and module Status := Status
+ and module Index := Index )
let get id =
Lwt.catch
- (fun () -> read_static_file (Learnocaml_index.exercise_path id)
- J.(tup3 Meta.enc enc (option float)) >>= fun (_, ex, _) ->
- Lwt.return ex)
- (function
- | Unix.Unix_error _ -> Lwt.fail Not_found
- | e -> Lwt.fail e)
-
+ (fun () ->
+ read_static_file
+ (Learnocaml_index.exercise_path id)
+ J.(tup3 Meta.enc enc (option float))
+ >>= fun (_, ex, _) -> Lwt.return ex )
+ (function Unix.Unix_error _ -> Lwt.fail Not_found | e -> Lwt.fail e)
end
module Token = struct
-
include Token
- let path token =
- Filename.concat !sync_dir (Token.to_path token)
+ let path token = Filename.concat !sync_dir (Token.to_path token)
let save_path token = Filename.concat (path token) "save.json"
let find_save token =
let save = save_path token in
- Lwt_unix.file_exists save >>= function
+ Lwt_unix.file_exists save
+ >>= function
| true -> Lwt.return_some save
| false ->
(* old layout: json stored directly as [path] instead of
[path/save.json] *)
let old_save = path token in
- Lwt_unix.file_exists old_save >>= fun ex ->
- if ex && not (Sys.is_directory old_save) then
- Lwt.return_some old_save
- else
- Lwt.return_none
+ Lwt_unix.file_exists old_save
+ >>= fun ex ->
+ if ex && not (Sys.is_directory old_save) then Lwt.return_some old_save
+ else Lwt.return_none
let exists token =
find_save token >|= function None -> false | Some _ -> true
let check_teacher token =
- if is_teacher token then exists token
- else Lwt.return_false
+ if is_teacher token then exists token else Lwt.return_false
let create_gen rnd =
let rec aux () =
let token = rnd () in
let file = save_path token in
- Lwt_utils.mkdir_p ~perm:0o700 (Filename.dirname file) >>= fun () ->
+ Lwt_utils.mkdir_p ~perm:0o700 (Filename.dirname file)
+ >>= fun () ->
Lwt.catch (fun () ->
Lwt_io.with_file ~mode:Lwt_io.Output ~perm:0o700 file
- ~flags:Unix.([O_WRONLY; O_NONBLOCK; O_CREAT; O_EXCL])
- (fun _chan -> Lwt.return token))
+ ~flags:Unix.[O_WRONLY; O_NONBLOCK; O_CREAT; O_EXCL]
+ (fun _chan -> Lwt.return token) )
@@ function
- | Unix.Unix_error (Unix.EEXIST, _, _) -> aux ()
- | e -> Lwt.fail e
+ | Unix.Unix_error (Unix.EEXIST, _, _) -> aux () | e -> Lwt.fail e
in
aux ()
- let register ?(allow_teacher=false) token =
- if not allow_teacher && is_teacher token then
+ let register ?(allow_teacher = false) token =
+ if (not allow_teacher) && is_teacher token then
Lwt.fail
- (Invalid_argument "Registration of teacher token forbidden. \
- Logout and use a new teacher token?")
+ (Invalid_argument
+ "Registration of teacher token forbidden. Logout and use a new \
+ teacher token?")
else
Lwt.catch (fun () ->
Lwt_io.with_file ~mode:Lwt_io.Output ~perm:0o700 (save_path token)
- ~flags:Unix.([O_WRONLY; O_NONBLOCK; O_CREAT; O_EXCL])
- (fun _chan -> Lwt.return_unit))
+ ~flags:Unix.[O_WRONLY; O_NONBLOCK; O_CREAT; O_EXCL]
+ (fun _chan -> Lwt.return_unit) )
@@ function
| Unix.Unix_error (Unix.EEXIST, _, _) ->
Lwt.fail_with "token already exists"
| e -> Lwt.fail e
- let create_student () =
- create_gen random
+ let create_student () = create_gen random
let create_teacher () = create_gen random_teacher
let delete token =
let rec rec_rmdir d =
- Lwt.catch (fun () ->
- Lwt_unix.rmdir d >>= fun () ->
+ Lwt.catch
+ (fun () ->
+ Lwt_unix.rmdir d
+ >>= fun () ->
let parent = Filename.dirname d in
- if parent = d then Lwt.return_unit else rec_rmdir parent)
+ if parent = d then Lwt.return_unit else rec_rmdir parent )
(function
| Unix.Unix_error (Unix.EINVAL, _, _) -> Lwt.return_unit
| e -> Lwt.fail e)
in
- find_save token >>= function
+ find_save token
+ >>= function
| None -> Lwt.return_unit
- | Some f ->
- Lwt_unix.unlink f >>= fun () ->
- rec_rmdir (Filename.dirname f)
+ | Some f -> Lwt_unix.unlink f >>= fun () -> rec_rmdir (Filename.dirname f)
module Index = struct
-
type nonrec t = t list
let enc = J.(list enc)
@@ -385,10 +382,11 @@ module Token = struct
let rec scan f d acc =
let rec aux s acc =
Lwt.catch (fun () ->
- Lwt_stream.get s >>= function
+ Lwt_stream.get s
+ >>= function
| Some ("." | "..") -> aux s acc
| Some x -> scan f (d / x) acc >>= aux s
- | None -> Lwt.return acc)
+ | None -> Lwt.return acc )
@@ function
| Unix.Unix_error (Unix.ENOTDIR, _, _) -> f d acc
| Unix.Unix_error _ -> Lwt.return acc
@@ -396,76 +394,72 @@ module Token = struct
in
aux (Lwt_unix.files_of_directory (base / d)) acc
in
- scan (fun d acc ->
+ scan
+ (fun d acc ->
let d =
- if Filename.basename d = "save.json" then Filename.dirname d
- else d
+ if Filename.basename d = "save.json" then Filename.dirname d else d
in
let stok = String.map (function '/' | '\\' -> '-' | c -> c) d in
- try Lwt.return (Token.parse stok :: acc)
- with Failure _ -> Lwt.return acc
- ) "" []
-
+ try Lwt.return (Token.parse stok :: acc) with Failure _ ->
+ Lwt.return acc )
+ "" []
end
-
end
module Save = struct
-
include Save
let get token =
- Token.find_save token >>= function
- | Some save -> get_from_file (J.option enc) save
- | None -> Lwt.return_none
+ Token.find_save token
+ >>= function
+ | Some save -> get_from_file (J.option enc) save | None -> Lwt.return_none
let set token save =
let file = Token.save_path token in
- (Token.find_save token >>= function
- | Some f when f <> file ->
- (* save file uses an old layout, move it to preserve attrs *)
- let tmp = f ^ ".tmp" in
- Lwt_unix.rename f tmp >>= fun () ->
- Lwt_utils.mkdir_p (Filename.dirname file) >>= fun () ->
- Lwt_unix.rename tmp file
- | _ -> Lwt.return_unit)
+ Token.find_save token
+ >>= (function
+ | Some f when f <> file ->
+ (* save file uses an old layout, move it to preserve attrs *)
+ let tmp = f ^ ".tmp" in
+ Lwt_unix.rename f tmp
+ >>= fun () ->
+ Lwt_utils.mkdir_p (Filename.dirname file)
+ >>= fun () -> Lwt_unix.rename tmp file
+ | _ -> Lwt.return_unit)
>>= fun () ->
let extra =
- SMap.fold (fun ex ans acc ->
+ SMap.fold
+ (fun ex ans acc ->
let filename = ex ^ ".ml" in
let contents =
- String.concat "\n" [
- Printf.sprintf "(* GRADE: % 02d%% *)"
- (match ans.Answer.grade with Some g -> g | None -> 0);
- ans.Answer.solution;
- ""
- ]
+ String.concat "\n"
+ [ Printf.sprintf "(* GRADE: % 02d%% *)"
+ (match ans.Answer.grade with Some g -> g | None -> 0)
+ ; ans.Answer.solution
+ ; "" ]
in
- (filename, contents) :: acc)
- save.all_exercise_states
- []
+ (filename, contents) :: acc )
+ save.all_exercise_states []
in
- Lwt.catch (fun () ->
+ Lwt.catch
+ (fun () ->
write ~no_create:(Token.is_teacher token) ~extra file
- (Json_codec.encode ~minify:false enc save))
+ (Json_codec.encode ~minify:false enc save) )
(function
| Not_found -> Lwt.fail_with "Unregistered teacher token"
| e -> Lwt.fail e)
-
end
module Student = struct
-
open Student
let get_saved token =
- Save.get token >>= function
- | None ->
- Lwt.return (default token)
+ Save.get token
+ >>= function
+ | None -> Lwt.return (default token)
| Some save ->
- let nickname = match save.Save.nickname with
- | "" -> None
- | n -> Some n
+ let nickname =
+ match save.Save.nickname with "" -> None | n -> Some n
in
let results =
SMap.map
@@ -473,14 +467,13 @@ module Student = struct
save.Save.all_exercise_states
in
let tags = SSet.empty in
- (Token.find_save token >>= function
- | None -> Lwt.return 0.
- | Some f -> Lwt_unix.stat f >|= fun st -> st.Unix.st_ctime)
- >|= fun creation_date ->
- {token; nickname; results; creation_date; tags}
+ Token.find_save token
+ >>= (function
+ | None -> Lwt.return 0.
+ | Some f -> Lwt_unix.stat f >|= fun st -> st.Unix.st_ctime)
+ >|= fun creation_date -> {token; nickname; results; creation_date; tags}
module Index = struct
-
include Index
(* Results and nickname are stored as part of the student's save, only the
@@ -488,14 +481,16 @@ module Student = struct
let store_enc =
J.(assoc (obj1 (dft "tags" (list string) [])))
|> J.conv
- (fun ttmap ->
- Token.Map.fold (fun tok tags l ->
- (Token.to_string tok, SSet.elements tags) :: l)
- ttmap [])
- (fun ttl ->
- List.fold_left (fun map (tok, tags) ->
- Token.Map.add (Token.parse tok) (SSet.of_list tags) map)
- Token.Map.empty ttl)
+ (fun ttmap ->
+ Token.Map.fold
+ (fun tok tags l ->
+ (Token.to_string tok, SSet.elements tags) :: l )
+ ttmap [] )
+ (fun ttl ->
+ List.fold_left
+ (fun map (tok, tags) ->
+ Token.Map.add (Token.parse tok) (SSet.of_list tags) map )
+ Token.Map.empty ttl )
let store_file () = Filename.concat !sync_dir "students.json"
@@ -509,24 +504,26 @@ module Student = struct
let map = lazy (load () >|= fun m -> ref m)
let save () =
- Lazy.force map >>= fun map ->
+ Lazy.force map
+ >>= fun map ->
let s = Json_codec.encode store_enc !map in
write (store_file ()) s
let get_student map token =
- Lwt.try_bind (fun () -> get_saved token)
+ Lwt.try_bind
+ (fun () -> get_saved token)
(fun std ->
- match Token.Map.find_opt token map with
- | Some tags -> Lwt.return_some {std with tags}
- | None -> Lwt.return_some std)
+ match Token.Map.find_opt token map with
+ | Some tags -> Lwt.return_some {std with tags}
+ | None -> Lwt.return_some std )
(fun e ->
- Format.eprintf "[ERROR] Corrupt save, cannot load %s: %s@."
- (Token.to_string token)
- (Printexc.to_string e);
- Lwt.return_none)
+ Format.eprintf "[ERROR] Corrupt save, cannot load %s: %s@."
+ (Token.to_string token) (Printexc.to_string e);
+ Lwt.return_none )
let get () =
- Lazy.force map >>= fun map ->
+ Lazy.force map
+ >>= fun map ->
Token.Index.get ()
>|= List.filter Token.is_student
>>= Lwt_list.filter_map_p (get_student !map)
@@ -534,22 +531,26 @@ module Student = struct
let set =
let map_mutex = Lwt_mutex.create () in
fun l ->
- Lwt_mutex.with_lock map_mutex @@ fun () ->
- Lazy.force map >>= fun map ->
- map := List.fold_left
+ Lwt_mutex.with_lock map_mutex
+ @@ fun () ->
+ Lazy.force map
+ >>= fun map ->
+ map :=
+ List.fold_left
(fun map std -> Token.Map.add std.token std.tags map)
!map l;
save ()
-
end
let get token =
- Lazy.force Index.map >>= fun map ->
- Index.get_student !map token
+ Lazy.force Index.map >>= fun map -> Index.get_student !map token
let set std = Index.set [std]
- include (Student: module type of struct include Student end
- with module Index := Index)
-
+ include (
+ Student :
+ module type of struct
+ include Student
+ end
+ with module Index := Index )
end
diff --git a/src/state/learnocaml_store.mli b/src/state/learnocaml_store.mli
index f6bbd440b..6105cd49c 100644
--- a/src/state/learnocaml_store.mli
+++ b/src/state/learnocaml_store.mli
@@ -10,173 +10,204 @@ open Learnocaml_data
(** {2 Configuration options} *)
+val static_dir : string ref
(** All static data accesses will be made relative to this directory *)
-val static_dir: string ref
+val sync_dir : string ref
(** All mutable data access will be made relative to this directory *)
-val sync_dir: string ref
(** {2 Utility server-side conversion functions} *)
(** Used both for file i/o and request handling *)
-module Json_codec: Learnocaml_api.JSON_CODEC
+module Json_codec : Learnocaml_api.JSON_CODEC
+
val get_from_file : 'a Json_encoding.encoding -> string -> 'a Lwt.t
+
val write_to_file : 'a Json_encoding.encoding -> 'a -> string -> unit Lwt.t
(* [sanitise_path prefix subdir] simplifies "." and ".." references in [subdir],
and returns the concatenation, but guaranteeing the result remains below
[prefix] (not accounting for symlinks of course, this is purely syntaxical)
*)
-val sanitise_path: string -> string list -> string
+val sanitise_path : string -> string list -> string
(** {2 Static data} *)
-module Lesson: sig
+module Lesson : sig
+ module Index : sig
+ include module type of struct
+ include Lesson.Index
+ end
- module Index: sig
- include module type of struct include Lesson.Index end
- val get: unit -> t Lwt.t
+ val get : unit -> t Lwt.t
end
- include module type of struct include Lesson end with module Index := Index
-
- val get: id -> t Lwt.t
+ include
+ module type of struct
+ include Lesson
+ end
+ with module Index := Index
+ val get : id -> t Lwt.t
end
-module Playground: sig
+module Playground : sig
+ module Index : sig
+ include module type of struct
+ include Playground.Index
+ end
- module Index: sig
- include module type of struct include Playground.Index end
- val get: unit -> t Lwt.t
+ val get : unit -> t Lwt.t
end
- include module type of struct include Playground end with module Index := Index
-
- val get: id -> t Lwt.t
+ include
+ module type of struct
+ include Playground
+ end
+ with module Index := Index
+ val get : id -> t Lwt.t
end
module Server : sig
val get : unit -> Server.config Lwt.t
end
-module Tutorial: sig
+module Tutorial : sig
+ module Index : sig
+ include module type of struct
+ include Tutorial.Index
+ end
- module Index: sig
- include module type of struct include Tutorial.Index end
- val get: unit -> t Lwt.t
+ val get : unit -> t Lwt.t
end
- include module type of struct include Tutorial end with module Index := Index
-
- val get: id -> t Lwt.t
+ include
+ module type of struct
+ include Tutorial
+ end
+ with module Index := Index
+ val get : id -> t Lwt.t
end
-module Exercise: sig
+module Exercise : sig
+ module Meta : sig
+ include module type of struct
+ include Exercise.Meta
+ end
- module Meta: sig
- include module type of struct include Exercise.Meta end
- val get: Exercise.id -> t Lwt.t
+ val get : Exercise.id -> t Lwt.t
end
- module Index: sig
- include module type of struct include Exercise.Index end
- val get_from_index: t -> t Lwt.t
- val get: unit -> t Lwt.t
- val reload: unit -> unit Lwt.t
- end
+ module Index : sig
+ include module type of struct
+ include Exercise.Index
+ end
- module Status: sig
- include module type of struct include Exercise.Status end
+ val get_from_index : t -> t Lwt.t
- val is_open:
- Exercise.id -> Token.t ->
- [`Open | `Closed | `Deadline of float] Lwt.t
- val get: Exercise.id -> t Lwt.t
- val set: t -> unit Lwt.t
- val all: unit -> t list Lwt.t
+ val get : unit -> t Lwt.t
+
+ val reload : unit -> unit Lwt.t
end
- include module type of struct include Exercise end
- with module Meta := Meta
- and module Status := Status
- and module Index := Index
+ module Status : sig
+ include module type of struct
+ include Exercise.Status
+ end
- val get: id -> t Lwt.t
+ val is_open :
+ Exercise.id -> Token.t -> [`Open | `Closed | `Deadline of float] Lwt.t
-end
+ val get : Exercise.id -> t Lwt.t
+ val set : t -> unit Lwt.t
+ val all : unit -> t list Lwt.t
+ end
-(** {2 Dynamic data} *)
+ include
+ module type of struct
+ include Exercise
+ end
+ with module Meta := Meta
+ and module Status := Status
+ and module Index := Index
-module Token: sig
+ val get : id -> t Lwt.t
+end
- include module type of struct include Token end
+(** {2 Dynamic data} *)
+
+module Token : sig
+ include module type of struct
+ include Token
+ end
+ val create_student : unit -> t Lwt.t
(** Initialise and register a new student token *)
- val create_student: unit -> t Lwt.t
+ val create_teacher : unit -> t Lwt.t
(** Initialise and register a new student token *)
- val create_teacher: unit -> t Lwt.t
+ val register : ?allow_teacher:bool -> t -> unit Lwt.t
(** Registers the given token. By default, only registration of student tokens
is allowed. [Failure] is raised if the token exists already. *)
- val register: ?allow_teacher:bool -> t -> unit Lwt.t
+ val exists : t -> bool Lwt.t
(** Check if the token has been registered *)
- val exists: t -> bool Lwt.t
- val delete: t -> unit Lwt.t
+ val delete : t -> unit Lwt.t
+ val check_teacher : t -> bool Lwt.t
(** True for registered teacher tokens only *)
- val check_teacher: t -> bool Lwt.t
-
- module Index: sig
+ module Index : sig
type nonrec t = t list
- val enc: t Json_encoding.encoding
-
- val get: unit -> t Lwt.t
+ val enc : t Json_encoding.encoding
+ val get : unit -> t Lwt.t
end
-
end
-module Save: sig
-
- include module type of struct include Save end
+module Save : sig
+ include module type of struct
+ include Save
+ end
- val get: Token.t -> t option Lwt.t
+ val get : Token.t -> t option Lwt.t
+ val set : Token.t -> t -> unit Lwt.t
(** Writes the given save to disk. Note: writing to an unregistered teacher
token will be rejected with [Failure], writing to an unregistered student
token registers it. *)
- val set: Token.t -> t -> unit Lwt.t
-
end
-module Student: sig
+module Student : sig
+ module Index : sig
+ include module type of struct
+ include Student.Index
+ end
- module Index: sig
- include module type of struct include Student.Index end
- val get: unit -> t Lwt.t
+ val get : unit -> t Lwt.t
+ val set : Student.t list -> unit Lwt.t
(** Does not affect the registered students absent from the list. Only the
tags can be updated this way, the rest needs to be set through
[Save.set] *)
- val set: Student.t list -> unit Lwt.t
end
- include module type of struct include Student end with module Index := Index
+ include
+ module type of struct
+ include Student
+ end
+ with module Index := Index
- val get: student token -> t option Lwt.t
+ val get : student token -> t option Lwt.t
+ val set : t -> unit Lwt.t
(** Only updates the tags at the moment, the rest is stored with [Save.set].
Use [Index.set] to set multiple students at once. *)
- val set: t -> unit Lwt.t
-
end
diff --git a/src/toplevel/learnocaml_toplevel.ml b/src/toplevel/learnocaml_toplevel.ml
index 20fdfa239..14cc04d8a 100644
--- a/src/toplevel/learnocaml_toplevel.ml
+++ b/src/toplevel/learnocaml_toplevel.ml
@@ -9,7 +9,8 @@
open Js_utils
open Tyxml_js
-let (>>=) = Lwt.(>>=)
+let ( >>= ) = Lwt.( >>= )
+
(* let (>|=) = Lwt.(>|=)
*
* let map_option f = function
@@ -19,24 +20,25 @@ let (>>=) = Lwt.(>>=)
*
* type 'a result = Success of 'a | Timeout of float *)
-type t = {
- timeout_delay: float;
- mutable timeout_prompt: t -> unit Lwt.t;
- mutable current_timeout_prompt: unit Lwt.t;
- flood_limit: int;
- mutable flood_prompt: t -> Html_types.nmtoken -> (unit -> int) -> bool Lwt.t;
- mutable current_flood_prompt: unit Lwt.t;
- flood_reset: t -> unit;
- worker: Learnocaml_toplevel_worker_caller.t;
- container: [ `Div ] Html5.elt;
- oldify: bool;
- mutable status: [ `Reset of (unit Lwt.t * unit Lwt.u) | `Execute of unit Lwt.t | `Idle ] ;
- mutable on_enable_input: t -> unit;
- mutable on_disable_input: t -> unit;
- mutable disabled : int;
- output: Learnocaml_toplevel_output.output;
- input: Learnocaml_toplevel_input.input;
-}
+type t =
+ { timeout_delay : float
+ ; mutable timeout_prompt : t -> unit Lwt.t
+ ; mutable current_timeout_prompt : unit Lwt.t
+ ; flood_limit : int
+ ; mutable flood_prompt :
+ t -> Html_types.nmtoken -> (unit -> int) -> bool Lwt.t
+ ; mutable current_flood_prompt : unit Lwt.t
+ ; flood_reset : t -> unit
+ ; worker : Learnocaml_toplevel_worker_caller.t
+ ; container : [`Div] Html5.elt
+ ; oldify : bool
+ ; mutable status :
+ [`Reset of unit Lwt.t * unit Lwt.u | `Execute of unit Lwt.t | `Idle]
+ ; mutable on_enable_input : t -> unit
+ ; mutable on_disable_input : t -> unit
+ ; mutable disabled : int
+ ; output : Learnocaml_toplevel_output.output
+ ; input : Learnocaml_toplevel_input.input }
(* let set_timeout_prompt t f = t.timeout_prompt <- f
* let set_flood_prompt t f = t.flood_prompt <- f
@@ -55,26 +57,23 @@ type t = {
* String.sub s !start (!stop - !start + 1) *)
let disable_input top =
- top.disabled <- top.disabled + 1 ;
- if top.disabled = 1 then begin
- top.on_disable_input top ;
- Learnocaml_toplevel_input.disable top.input
- end
+ top.disabled <- top.disabled + 1;
+ if top.disabled = 1 then (
+ top.on_disable_input top;
+ Learnocaml_toplevel_input.disable top.input )
let enable_input top =
- top.disabled <- top.disabled - 1 ;
- if top.disabled = 0 then begin
- top.on_enable_input top ;
- Learnocaml_toplevel_input.enable top.input
- end
+ top.disabled <- top.disabled - 1;
+ if top.disabled = 0 then (
+ top.on_enable_input top;
+ Learnocaml_toplevel_input.enable top.input )
-let scroll { output; _ } =
- Learnocaml_toplevel_output.scroll output
+let scroll {output; _} = Learnocaml_toplevel_output.scroll output
-let clear { output; _ } =
- Learnocaml_toplevel_output.clear output ;
+let clear {output; _} =
+ Learnocaml_toplevel_output.clear output;
Learnocaml_toplevel_output.output_stdout output
- [%i"The toplevel has been cleared.\n"]
+ [%i "The toplevel has been cleared.\n"]
(* let never_ending =
* let t = fst (Lwt.wait ()) in
@@ -84,301 +83,324 @@ let wait_for_prompts top =
Lwt.join
[ Lwt.catch
(fun () -> top.current_timeout_prompt)
- Lwt.(function Canceled -> return () | exn -> fail exn) ;
- Lwt.catch
+ Lwt.(function Canceled -> return () | exn -> fail exn)
+ ; Lwt.catch
(fun () -> top.current_flood_prompt)
Lwt.(function Canceled -> return () | exn -> fail exn) ]
let start_timeout top _name timeout =
- Lwt.cancel top.current_timeout_prompt ;
+ Lwt.cancel top.current_timeout_prompt;
match timeout with
| Some timeout -> timeout top
| None ->
- Lwt_js.sleep top.timeout_delay >>= fun () ->
- wait_for_prompts top >>= fun () ->
- top.current_timeout_prompt <- top.timeout_prompt top ;
+ Lwt_js.sleep top.timeout_delay
+ >>= fun () ->
+ wait_for_prompts top
+ >>= fun () ->
+ top.current_timeout_prompt <- top.timeout_prompt top;
top.current_timeout_prompt
let input_focus top f =
- f () >>= fun r -> Learnocaml_toplevel_input.focus top.input; Lwt.return r
+ f ()
+ >>= fun r ->
+ Learnocaml_toplevel_input.focus top.input;
+ Lwt.return r
let reset_with_timeout top ?timeout () =
- input_focus top @@ fun () ->
+ input_focus top
+ @@ fun () ->
match top.status with
| `Reset (t, _) -> t
| `Idle ->
let t, u = Lwt.wait () in
- Lwt.cancel top.current_timeout_prompt ;
- Lwt.cancel top.current_flood_prompt ;
- wait_for_prompts top >>= fun () ->
- top.status <- `Reset (t, u) ;
+ Lwt.cancel top.current_timeout_prompt;
+ Lwt.cancel top.current_flood_prompt;
+ wait_for_prompts top
+ >>= fun () ->
+ top.status <- `Reset (t, u);
let timeout () = start_timeout top "reset" timeout in
disable_input top;
- Learnocaml_toplevel_worker_caller.reset ~timeout top.worker () >>= fun () ->
- t
+ Learnocaml_toplevel_worker_caller.reset ~timeout top.worker ()
+ >>= fun () -> t
| `Execute task ->
let t, u = Lwt.wait () in
- Lwt.cancel top.current_timeout_prompt ;
- Lwt.cancel top.current_flood_prompt ;
- wait_for_prompts top >>= fun () ->
- top.status <- `Reset (t, u) ;
+ Lwt.cancel top.current_timeout_prompt;
+ Lwt.cancel top.current_flood_prompt;
+ wait_for_prompts top
+ >>= fun () ->
+ top.status <- `Reset (t, u);
let timeout () = start_timeout top "reset" timeout in
disable_input top;
- Learnocaml_toplevel_worker_caller.reset ~timeout top.worker () >>= fun () ->
- t >>= fun () ->
- Lwt.cancel task ;
- Lwt.return ()
+ Learnocaml_toplevel_worker_caller.reset ~timeout top.worker ()
+ >>= fun () -> t >>= fun () -> Lwt.cancel task; Lwt.return ()
let reset top =
let timeout _ = Lwt_js.sleep 2. in
reset_with_timeout top ~timeout ()
let protect_execution top exec =
- input_focus top @@ fun () ->
- wait_for_prompts top >>= fun () ->
+ input_focus top
+ @@ fun () ->
+ wait_for_prompts top
+ >>= fun () ->
match top.status with
| `Reset _ | `Execute _ ->
Lwt.fail_invalid_arg "Learnocaml_toplevel.protect_execution"
| `Idle ->
let t, u = Lwt.task () in
- top.status <- `Execute t ;
+ top.status <- `Execute t;
disable_input top;
- top.flood_reset top ;
- let thread = t >>= fun () ->
+ top.flood_reset top;
+ let thread =
+ t
+ >>= fun () ->
Lwt.catch
(fun () ->
- exec () >>= fun res ->
- match top.status with
- | `Execute t' ->
- assert (t == t') ;
- top.status <- `Idle;
- wait_for_prompts top >>= fun () ->
- enable_input top;
- Lwt.return res
- | `Idle | `Reset _ ->
- (* The task successfully ended between a reset order
+ exec ()
+ >>= fun res ->
+ match top.status with
+ | `Execute t' ->
+ assert (t == t');
+ top.status <- `Idle;
+ wait_for_prompts top
+ >>= fun () -> enable_input top; Lwt.return res
+ | `Idle | `Reset _ ->
+ (* The task successfully ended between a reset order
and its ack, we fake its cancellation. *)
- Lwt.fail Lwt.Canceled)
+ Lwt.fail Lwt.Canceled )
(function
| Lwt.Canceled ->
enable_input top;
- begin match top.status with
- | `Reset (t, _) -> t
- | _ -> Lwt.return ()
- end >>= fun () -> Lwt.fail Lwt.Canceled
- | exn ->
- enable_input top;
- Lwt.fail exn) in
- Lwt.wakeup u () ;
- thread
+ ( match top.status with
+ | `Reset (t, _) -> t
+ | _ -> Lwt.return () )
+ >>= fun () -> Lwt.fail Lwt.Canceled
+ | exn -> enable_input top; Lwt.fail exn)
+ in
+ Lwt.wakeup u (); thread
let execute_phrase top ?timeout content =
- input_focus top @@ fun () ->
+ input_focus top
+ @@ fun () ->
let phrase = Learnocaml_toplevel_output.phrase () in
let pp_code = Learnocaml_toplevel_output.output_code ~phrase top.output in
- let pp_answer = Learnocaml_toplevel_output.output_answer ~phrase top.output in
+ let pp_answer =
+ Learnocaml_toplevel_output.output_answer ~phrase top.output
+ in
let t =
- Learnocaml_toplevel_worker_caller.execute
- top.worker ~pp_code ~pp_answer ~print_outcome:true content in
- Lwt.pick [
- (Lwt.protected t >>= fun _ -> Lwt.return_unit) ;
- (start_timeout top "execute" timeout >>= fun () ->
- let timeout _ = Lwt.return () in
- reset_with_timeout top ~timeout ());
- ] >>= fun () ->
- t >>= fun result ->
- let warnings, result = match result with
- | Toploop_results.Ok (result, warnings) -> warnings, result
+ Learnocaml_toplevel_worker_caller.execute top.worker ~pp_code ~pp_answer
+ ~print_outcome:true content
+ in
+ Lwt.pick
+ [ (Lwt.protected t >>= fun _ -> Lwt.return_unit)
+ ; ( start_timeout top "execute" timeout
+ >>= fun () ->
+ let timeout _ = Lwt.return () in
+ reset_with_timeout top ~timeout () ) ]
+ >>= fun () ->
+ t
+ >>= fun result ->
+ let warnings, result =
+ match result with
+ | Toploop_results.Ok (result, warnings) -> (warnings, result)
| Toploop_results.Error (error, warnings) ->
- Learnocaml_toplevel_output.output_error ~phrase top.output error ;
- warnings, false in
+ Learnocaml_toplevel_output.output_error ~phrase top.output error;
+ (warnings, false)
+ in
List.iter
(Learnocaml_toplevel_output.output_warning ~phrase top.output)
- warnings ;
+ warnings;
Lwt.return result
-let execute top =
- Learnocaml_toplevel_input.execute top.input
+let execute top = Learnocaml_toplevel_input.execute top.input
-let go_backward top =
- Learnocaml_toplevel_input.go_backward top.input
+let go_backward top = Learnocaml_toplevel_input.go_backward top.input
-let go_forward top =
- Learnocaml_toplevel_input.go_forward top.input
+let go_forward top = Learnocaml_toplevel_input.go_forward top.input
let check top code =
- protect_execution top @@ fun () ->
- Learnocaml_toplevel_worker_caller.check top.worker code
+ protect_execution top
+ @@ fun () -> Learnocaml_toplevel_worker_caller.check top.worker code
let set_checking_environment top =
- protect_execution top @@ fun () ->
- Learnocaml_toplevel_worker_caller.set_checking_environment top.worker >>= fun _ ->
- Lwt.return ()
+ protect_execution top
+ @@ fun () ->
+ Learnocaml_toplevel_worker_caller.set_checking_environment top.worker
+ >>= fun _ -> Lwt.return ()
let execute_phrase top ?timeout content =
- protect_execution top @@ fun () ->
- execute_phrase top ?timeout content
+ protect_execution top @@ fun () -> execute_phrase top ?timeout content
let load top ?(print_outcome = true) ?timeout ?message content =
let phrase = Learnocaml_toplevel_output.phrase () in
- protect_execution top @@ fun () ->
- begin match message with
- | None -> ()
- | Some message ->
- Learnocaml_toplevel_output.output_code ~phrase top.output
- ("(* " ^ message ^ "*)")
- end ;
+ protect_execution top
+ @@ fun () ->
+ ( match message with
+ | None -> ()
+ | Some message ->
+ Learnocaml_toplevel_output.output_code ~phrase top.output
+ ("(* " ^ message ^ "*)") );
let pp_answer =
if print_outcome then
Learnocaml_toplevel_output.output_answer ~phrase top.output
- else
- ignore in
+ else ignore
+ in
let t =
- Learnocaml_toplevel_worker_caller.use_string
- top.worker ~pp_answer ~print_outcome content in
- Lwt.pick [
- (Lwt.protected t >>= fun _ -> Lwt.return_unit) ;
- (start_timeout top "load" timeout >>= fun () ->
- reset top);
- ] >>= fun () ->
- t >>= fun result ->
- let warnings, result = match result with
- | Toploop_results.Ok (result, warnings) -> warnings, result
+ Learnocaml_toplevel_worker_caller.use_string top.worker ~pp_answer
+ ~print_outcome content
+ in
+ Lwt.pick
+ [ (Lwt.protected t >>= fun _ -> Lwt.return_unit)
+ ; (start_timeout top "load" timeout >>= fun () -> reset top) ]
+ >>= fun () ->
+ t
+ >>= fun result ->
+ let warnings, result =
+ match result with
+ | Toploop_results.Ok (result, warnings) -> (warnings, result)
| Toploop_results.Error (error, warnings) ->
- Learnocaml_toplevel_output.output_error top.output error ;
- warnings, false in
- List.iter
- (Learnocaml_toplevel_output.output_warning top.output)
- warnings ;
+ Learnocaml_toplevel_output.output_error top.output error;
+ (warnings, false)
+ in
+ List.iter (Learnocaml_toplevel_output.output_warning top.output) warnings;
Lwt.return result
-let make_timeout_popup
- ?(countdown = 10)
- ?(refill_step = 10)
- ?(on_show = (fun () -> ()))
- () { container; _ } =
+let make_timeout_popup ?(countdown = 10) ?(refill_step = 10)
+ ?(on_show = fun () -> ()) () {container; _} =
let open Tyxml_js.Html5 in
let t0 = Sys.time () in
let countdown = ref countdown in
let btn_continue =
- let label = Format.asprintf [%if"%d seconds!"] refill_step in
- button [ txt label ] in
- let btn_stop =
- button [ txt [%i"Kill it!"] ] in
- Manip.Ev.onclick btn_continue
- (fun _ -> countdown := !countdown + refill_step ; true) ;
- Manip.Ev.onclick btn_stop
- (fun _ -> countdown := 0 ; true) ;
+ let label = Format.asprintf [%if "%d seconds!"] refill_step in
+ button [txt label]
+ in
+ let btn_stop = button [txt [%i "Kill it!"]] in
+ Manip.Ev.onclick btn_continue (fun _ ->
+ countdown := !countdown + refill_step;
+ true );
+ Manip.Ev.onclick btn_stop (fun _ ->
+ countdown := 0;
+ true );
let clock_span = span [] in
let countdown_span = span [] in
let dialog =
- div ~a: [ a_class [ "dialog-container" ] ]
- [ div ~a: [ a_class [ "dialog" ] ]
- [ h1 [ txt [%i"Infinite loop?"] ] ;
- div ~a: [ a_class [ "message" ] ]
- [ txt [%i"The toplevel has not been responding for "] ;
- clock_span ;
- txt [%i" seconds."] ;
- br () ;
- txt [%i"It will be killed in "] ;
- countdown_span ;
- txt [%i" seconds."] ] ;
- div ~a: [ a_class [ "buttons" ] ]
- [ btn_continue ; btn_stop ] ] ] in
+ div
+ ~a:[a_class ["dialog-container"]]
+ [ div
+ ~a:[a_class ["dialog"]]
+ [ h1 [txt [%i "Infinite loop?"]]
+ ; div
+ ~a:[a_class ["message"]]
+ [ txt [%i "The toplevel has not been responding for "]
+ ; clock_span
+ ; txt [%i " seconds."]
+ ; br ()
+ ; txt [%i "It will be killed in "]
+ ; countdown_span
+ ; txt [%i " seconds."] ]
+ ; div ~a:[a_class ["buttons"]] [btn_continue; btn_stop] ] ]
+ in
Lwt.catch
(fun () ->
- Manip.appendChild container dialog ;
- on_show () ;
- let rec loop () =
- let elapsed = int_of_float (Sys.time () -. t0) in
- Manip.replaceChildren clock_span
- [ txt (string_of_int elapsed) ] ;
- Manip.replaceChildren countdown_span
- [ txt (string_of_int (!countdown - elapsed)) ] ;
- if elapsed >= !countdown then begin
- Manip.removeChild container dialog ;
- Lwt.return ()
- end else
- Lwt_js.sleep 0.2 >>= loop in
- loop ())
+ Manip.appendChild container dialog;
+ on_show ();
+ let rec loop () =
+ let elapsed = int_of_float (Sys.time () -. t0) in
+ Manip.replaceChildren clock_span [txt (string_of_int elapsed)];
+ Manip.replaceChildren countdown_span
+ [txt (string_of_int (!countdown - elapsed))];
+ if elapsed >= !countdown then (
+ Manip.removeChild container dialog;
+ Lwt.return () )
+ else Lwt_js.sleep 0.2 >>= loop
+ in
+ loop () )
(fun exn ->
- (try Manip.removeChild container dialog with _ -> ()) ;
- Lwt.fail exn)
+ (try Manip.removeChild container dialog with _ -> ());
+ Lwt.fail exn )
-let make_flood_popup
- ?(on_show = (fun () -> ()))
- () { container; _ } name amount =
+let make_flood_popup ?(on_show = fun () -> ()) () {container; _} name amount =
let open Tyxml_js.Html5 in
let answer = ref None in
- let btn_continue =
- button [ txt [%i"Show anyway!"] ] in
- let btn_stop =
- button [ txt [%i"Hide output!"] ] in
- Manip.Ev.onclick btn_continue
- (fun _ -> answer := Some false ; true) ;
- Manip.Ev.onclick btn_stop
- (fun _ -> answer := Some true ; true) ;
+ let btn_continue = button [txt [%i "Show anyway!"]] in
+ let btn_stop = button [txt [%i "Hide output!"]] in
+ Manip.Ev.onclick btn_continue (fun _ ->
+ answer := Some false;
+ true );
+ Manip.Ev.onclick btn_stop (fun _ ->
+ answer := Some true;
+ true );
let qty_span = span [] in
let dialog =
- div ~a: [ a_class [ "dialog-container" ] ]
- [ div ~a: [ a_class [ "dialog" ] ]
- [ h1 [ txt [%i"Flooded output!"] ] ;
- div ~a: [ a_class [ "message" ] ]
- [ txt (Printf.sprintf
- [%if"Your code is flooding the %s channel."] name) ;
- br ();
- txt [%i"It has already printed "] ;
- qty_span ;
- txt [%i" bytes."] ] ;
- div ~a: [ a_class [ "buttons" ] ]
- [ btn_continue ; btn_stop ] ] ] in
- Manip.appendChild container dialog ;
- on_show () ;
+ div
+ ~a:[a_class ["dialog-container"]]
+ [ div
+ ~a:[a_class ["dialog"]]
+ [ h1 [txt [%i "Flooded output!"]]
+ ; div
+ ~a:[a_class ["message"]]
+ [ txt
+ (Printf.sprintf [%if "Your code is flooding the %s channel."]
+ name)
+ ; br ()
+ ; txt [%i "It has already printed "]
+ ; qty_span
+ ; txt [%i " bytes."] ]
+ ; div ~a:[a_class ["buttons"]] [btn_continue; btn_stop] ] ]
+ in
+ Manip.appendChild container dialog;
+ on_show ();
let rec loop () =
- Manip.replaceChildren qty_span
- [ txt (string_of_int (amount ())) ] ;
+ Manip.replaceChildren qty_span [txt (string_of_int (amount ()))];
match !answer with
| Some ans ->
- Manip.removeChild container dialog ;
+ Manip.removeChild container dialog;
Lwt.return ans
- | None ->
- Lwt_js.sleep 0.2 >>= loop in
- Lwt.catch
- loop
- (fun exn ->
- Manip.removeChild container dialog ;
- Lwt.fail exn)
+ | None -> Lwt_js.sleep 0.2 >>= loop
+ in
+ Lwt.catch loop (fun exn ->
+ Manip.removeChild container dialog;
+ Lwt.fail exn )
let wrap_flusher_to_prevent_flood top name hook real =
let flooded = ref 0 in
- hook := fun s ->
- real s ;
- let total = !flooded + String.length s in
- if total >= top.flood_limit then begin
- let buf = Buffer.create top.flood_limit in
- hook := (fun s -> try flooded := !flooded + String.length s ; Buffer.add_string buf s with _ -> ()) ;
- flooded := total ;
- Lwt.async @@ fun () ->
- Lwt.catch
- (fun () ->
- wait_for_prompts top >>= fun () ->
- top.current_flood_prompt <-
- (top.flood_prompt top name (fun () -> !flooded) >>= function
+ hook :=
+ fun s ->
+ real s;
+ let total = !flooded + String.length s in
+ if total >= top.flood_limit then (
+ let buf = Buffer.create top.flood_limit in
+ (hook :=
+ fun s ->
+ try
+ flooded := !flooded + String.length s;
+ Buffer.add_string buf s
+ with _ -> ());
+ flooded := total;
+ Lwt.async
+ @@ fun () ->
+ Lwt.catch
+ (fun () ->
+ wait_for_prompts top
+ >>= fun () ->
+ top.current_flood_prompt
+ <- ( top.flood_prompt top name (fun () -> !flooded)
+ >>= function
| true ->
- real (Printf.sprintf [%if"\nInterrupted output channel %s.\n"] name) ;
- hook := ignore ;
+ real
+ (Printf.sprintf [%if "\nInterrupted output channel %s.\n"]
+ name);
+ hook := ignore;
Lwt.return ()
| false ->
- real (Buffer.contents buf) ;
- hook := real ;
- Lwt.return ()) ;
- top.current_flood_prompt)
- (fun _exn ->
- hook := ignore ;
- Lwt.return ())
- end else begin
- flooded := total
- end
+ real (Buffer.contents buf);
+ hook := real;
+ Lwt.return () );
+ top.current_flood_prompt )
+ (fun _exn ->
+ hook := ignore;
+ Lwt.return () ) )
+ else flooded := total
let load_pp err top pps =
let prelude_pp =
@@ -387,146 +409,129 @@ let load_pp err top pps =
in
let rec loading = function
| [] -> Lwt.return_unit
- | code :: cs ->
- load ~print_outcome:false top code
- >>= (fun _ -> loading cs)
+ | code :: cs -> load ~print_outcome:false top code >>= fun _ -> loading cs
in
let pps =
List.map (fun pp -> Format.sprintf "#install_printer %s;;" pp) pps
in
- err >>= (fun _ -> loading (prelude_pp::pps))
+ err >>= fun _ -> loading (prelude_pp :: pps)
let welcome_phrase () =
- [%i"Printf.printf \"Welcome to OCaml %s\\n%!\" (Sys.ocaml_version);\n\
- print_endline \" - type your OCaml phrase in the box below and press [Enter]\";\n\
- print_endline \" - use [Shift-Enter] to break lines without triggering execution\";\n\
- print_endline \" - use [Ctrl-\\xe2\\x86\\x91] once to reuse the previous entry\";\n\
- print_endline \" - use [Ctrl-\\xe2\\x86\\x91] / [Ctrl-\\xe2\\x86\\x93] \
- to navigate through history\" ;;"]
- (* U+2191 upwards arrow, U+2193 downwards arrow*)
-
-let create
- ?worker_js_file
- ?(timeout_delay = 5.)
- ~timeout_prompt
- ?(flood_limit = 8000)
- ~flood_prompt
- ?after_init
+ [%i
+ "Printf.printf \"Welcome to OCaml %s\\n%!\" (Sys.ocaml_version);\n\
+ print_endline \" - type your OCaml phrase in the box below and press \
+ [Enter]\";\n\
+ print_endline \" - use [Shift-Enter] to break lines without triggering \
+ execution\";\n\
+ print_endline \" - use [Ctrl-\\xe2\\x86\\x91] once to reuse the previous \
+ entry\";\n\
+ print_endline \" - use [Ctrl-\\xe2\\x86\\x91] / [Ctrl-\\xe2\\x86\\x93] \
+ to navigate through history\" ;;"]
+
+(* U+2191 upwards arrow, U+2193 downwards arrow*)
+
+let create ?worker_js_file ?(timeout_delay = 5.) ~timeout_prompt
+ ?(flood_limit = 8000) ~flood_prompt ?after_init
?(input_sizing =
- { Learnocaml_toplevel_input.line_height = 18 ;
- min_lines = 1 ; max_lines = 6 })
- ?on_resize
- ?(on_disable_input = fun _ -> ())
- ?(on_enable_input = fun _ -> ())
- ?history
- ?(oldify = true)
- ?(display_welcome = true)
- ~container () =
- (match get_lang() with Some l -> Ocplib_i18n.set_lang l | None -> ());
+ {Learnocaml_toplevel_input.line_height = 18; min_lines = 1; max_lines = 6})
+ ?on_resize ?(on_disable_input = fun _ -> ())
+ ?(on_enable_input = fun _ -> ()) ?history ?(oldify = true)
+ ?(display_welcome = true) ~container () =
+ (match get_lang () with Some l -> Ocplib_i18n.set_lang l | None -> ());
let output_div = Html5.div [] in
let input_div = Html5.div [] in
Manip.appendChild container output_div;
Manip.appendChild container input_div;
let output =
- Learnocaml_toplevel_output.setup
- ?on_resize
- ~container:output_div
- () in
+ Learnocaml_toplevel_output.setup ?on_resize ~container:output_div ()
+ in
let execute_hook = ref (fun _code -> assert false) in
let input =
- Learnocaml_toplevel_input.setup
- ~sizing: input_sizing
- ~execute: (fun code -> !execute_hook code)
- ~container:input_div
- ?on_resize
- ?history
- () in
+ Learnocaml_toplevel_input.setup ~sizing:input_sizing
+ ~execute:(fun code -> !execute_hook code)
+ ~container:input_div ?on_resize ?history ()
+ in
let pp_stdout_hook = ref ignore in
let pp_stdout s = !pp_stdout_hook s in
let pp_stderr_hook = ref ignore in
let pp_stderr s = !pp_stderr_hook s in
let flood_reset top =
let phrase = Learnocaml_toplevel_output.phrase () in
- Lwt.cancel top.current_flood_prompt ;
- wrap_flusher_to_prevent_flood top
- "stdout" pp_stdout_hook
- (Learnocaml_toplevel_output.output_stdout ~phrase output) ;
- wrap_flusher_to_prevent_flood top
- "stderr" pp_stderr_hook
- (Learnocaml_toplevel_output.output_stderr ~phrase output) in
- Learnocaml_toplevel_worker_caller.create
- ?js_file:worker_js_file
- ~pp_stdout ~pp_stderr () >>= fun worker ->
- let top = {
- timeout_prompt;
- current_timeout_prompt = Lwt.return ();
- timeout_delay;
- flood_prompt;
- current_flood_prompt = Lwt.return ();
- flood_limit;
- flood_reset;
- worker;
- container;
- oldify;
- status = `Reset (Lwt.wait ());
- on_enable_input;
- on_disable_input;
- disabled = 1;
- input;
- output;
- } in
- flood_reset top ;
- execute_hook :=
- (fun code -> Lwt.async @@ fun () ->
- Lwt.catch
- (fun () -> execute_phrase top code)
- (function
- | Lwt.Canceled -> Lwt.return true
- | exn -> Lwt.fail exn )) ;
+ Lwt.cancel top.current_flood_prompt;
+ wrap_flusher_to_prevent_flood top "stdout" pp_stdout_hook
+ (Learnocaml_toplevel_output.output_stdout ~phrase output);
+ wrap_flusher_to_prevent_flood top "stderr" pp_stderr_hook
+ (Learnocaml_toplevel_output.output_stderr ~phrase output)
+ in
+ Learnocaml_toplevel_worker_caller.create ?js_file:worker_js_file ~pp_stdout
+ ~pp_stderr ()
+ >>= fun worker ->
+ let top =
+ { timeout_prompt
+ ; current_timeout_prompt = Lwt.return ()
+ ; timeout_delay
+ ; flood_prompt
+ ; current_flood_prompt = Lwt.return ()
+ ; flood_limit
+ ; flood_reset
+ ; worker
+ ; container
+ ; oldify
+ ; status = `Reset (Lwt.wait ())
+ ; on_enable_input
+ ; on_disable_input
+ ; disabled = 1
+ ; input
+ ; output }
+ in
+ flood_reset top;
+ (execute_hook :=
+ fun code ->
+ Lwt.async
+ @@ fun () ->
+ Lwt.catch
+ (fun () -> execute_phrase top code)
+ (function Lwt.Canceled -> Lwt.return true | exn -> Lwt.fail exn));
let first_time = ref true in
let after_init top =
- if !first_time || not oldify then
- Learnocaml_toplevel_output.clear output
- else
- Learnocaml_toplevel_output.oldify output;
- enable_input top ;
+ if !first_time || not oldify then Learnocaml_toplevel_output.clear output
+ else Learnocaml_toplevel_output.oldify output;
+ enable_input top;
top.flood_reset top;
- begin match top.status with
- | `Reset (_, u) -> Lwt.wakeup u ()
- | `Idle | `Execute _ -> assert false
- end ;
+ ( match top.status with
+ | `Reset (_, u) -> Lwt.wakeup u ()
+ | `Idle | `Execute _ -> assert false );
top.status <- `Idle;
- begin if display_welcome && (!first_time || not oldify) then
- Learnocaml_toplevel_worker_caller.execute
- ~pp_answer: (fun _ -> ())
- ~print_outcome: false
- worker (welcome_phrase ()) >>= fun _ ->
- Lwt.return ()
- else Lwt.return ()
- end >>= fun _ ->
+ ( if display_welcome && (!first_time || not oldify) then
+ Learnocaml_toplevel_worker_caller.execute
+ ~pp_answer:(fun _ -> ())
+ ~print_outcome:false worker (welcome_phrase ())
+ >>= fun _ -> Lwt.return ()
+ else Lwt.return () )
+ >>= fun _ ->
if not !first_time then
let phrase = Learnocaml_toplevel_output.phrase () in
Learnocaml_toplevel_output.output_stdout output ~phrase
- [%i"The toplevel has been reset.\n"]
- else
- first_time := false ;
+ [%i "The toplevel has been reset.\n"]
+ else first_time := false;
Learnocaml_toplevel_worker_caller.register_callback worker "print_html"
(Learnocaml_toplevel_output.output_html output)
>>= fun _ ->
- Learnocaml_toplevel_worker_caller.register_callback worker "print_svg"
- (Learnocaml_toplevel_output.output_svg output)
- >>= fun err -> load_pp (Lwt.return err) top Learnocaml_toplevel_pp.pp_list
+ Learnocaml_toplevel_worker_caller.register_callback worker "print_svg"
+ (Learnocaml_toplevel_output.output_svg output)
+ >>= fun err ->
+ load_pp (Lwt.return err) top Learnocaml_toplevel_pp.pp_list
>>= fun _ ->
- match after_init with
- | None -> Lwt.return_unit
- | Some f -> f top
+ match after_init with None -> Lwt.return_unit | Some f -> f top
in
- after_init top >>= fun () ->
- Learnocaml_toplevel_worker_caller.set_after_init top.worker (fun _ -> after_init top);
+ after_init top
+ >>= fun () ->
+ Learnocaml_toplevel_worker_caller.set_after_init top.worker (fun _ ->
+ after_init top );
Lwt.return top
-let print_string { output; _ } = Learnocaml_toplevel_output.output_stdout output
+let print_string {output; _} = Learnocaml_toplevel_output.output_stdout output
-let prerr_string { output; _ } = Learnocaml_toplevel_output.output_stderr output
+let prerr_string {output; _} = Learnocaml_toplevel_output.output_stderr output
-let print_html { output; _ } = Learnocaml_toplevel_output.output_html output
+let print_html {output; _} = Learnocaml_toplevel_output.output_html output
diff --git a/src/toplevel/learnocaml_toplevel.mli b/src/toplevel/learnocaml_toplevel.mli
index f2cb5a8f2..b29b1b8e9 100644
--- a/src/toplevel/learnocaml_toplevel.mli
+++ b/src/toplevel/learnocaml_toplevel.mli
@@ -13,6 +13,23 @@ open Tyxml_js
(** An abstract type representing a toplevel instance. *)
type t
+val create :
+ ?worker_js_file:string
+ -> ?timeout_delay:float
+ -> timeout_prompt:(t -> unit Lwt.t)
+ -> ?flood_limit:int
+ -> flood_prompt:(t -> string -> (unit -> int) -> bool Lwt.t)
+ -> ?after_init:(t -> unit Lwt.t)
+ -> ?input_sizing:Learnocaml_toplevel_input.sizing
+ -> ?on_resize:(unit -> unit)
+ -> ?on_disable_input:(t -> unit)
+ -> ?on_enable_input:(t -> unit)
+ -> ?history:Learnocaml_toplevel_history.history
+ -> ?oldify:bool
+ -> ?display_welcome:bool
+ -> container:[`Div] Html5.elt
+ -> unit
+ -> t Lwt.t
(** Create a toplevel instance in a given container [div].
@param container
@@ -59,41 +76,25 @@ type t
@param display_welcome
Tells if the welcome message with some help and the version of OCaml
is to be displayed or not. *)
-val create:
- ?worker_js_file:string ->
- ?timeout_delay: float ->
- timeout_prompt:(t -> unit Lwt.t) ->
- ?flood_limit: int ->
- flood_prompt: (t -> string -> (unit -> int) -> bool Lwt.t) ->
- ?after_init:(t -> unit Lwt.t) ->
- ?input_sizing: Learnocaml_toplevel_input.sizing ->
- ?on_resize:(unit -> unit) ->
- ?on_disable_input:(t -> unit) ->
- ?on_enable_input:(t -> unit) ->
- ?history:Learnocaml_toplevel_history.history ->
- ?oldify:bool ->
- ?display_welcome: bool ->
- container:[`Div] Html5.elt ->
- unit -> t Lwt.t
+val make_timeout_popup :
+ ?countdown:int
+ -> ?refill_step:int
+ -> ?on_show:(unit -> unit)
+ -> unit
+ -> t
+ -> unit Lwt.t
(** Creates a thread that displays a popup over the toplevel container
with a countdown and a button to augment it manually, and
terminates after the countdown. *)
-val make_timeout_popup:
- ?countdown: int ->
- ?refill_step: int ->
- ?on_show: (unit -> unit) ->
- unit ->
- t -> unit Lwt.t
+val make_flood_popup :
+ ?on_show:(unit -> unit) -> unit -> t -> string -> (unit -> int) -> bool Lwt.t
(** Create a thread that displays a popup over the toplevel
container displaying the flood amount in real time, and
asking if the display should be hidden or not. *)
-val make_flood_popup:
- ?on_show: (unit -> unit) ->
- unit ->
- (t -> string -> (unit -> int) -> bool Lwt.t)
+val execute_phrase : t -> ?timeout:(t -> unit Lwt.t) -> string -> bool Lwt.t
(** Execute a given piece of code.
@param timeout
@@ -102,10 +103,14 @@ val make_flood_popup:
Returns [Success true] whenever the code was correctly
typechecked and its evaluation did not raise an exception nor
timeouted and [false] otherwise. *)
-val execute_phrase: t ->
- ?timeout:(t -> unit Lwt.t) ->
- string -> bool Lwt.t
+val load :
+ t
+ -> ?print_outcome:bool
+ -> ?timeout:(t -> unit Lwt.t)
+ -> ?message:string
+ -> string
+ -> bool Lwt.t
(** Execute a given piece of code without displaying it.
@param timeout
@@ -118,51 +123,45 @@ val execute_phrase: t ->
Returns [Success true] whenever the code was correctly
typechecked and its evaluation did not raise an exception nor
timeouted and [false] otherwise. *)
-val load:
- t ->
- ?print_outcome:bool ->
- ?timeout:(t -> unit Lwt.t) ->
- ?message: string ->
- string -> bool Lwt.t
+val check : t -> string -> unit Toploop_results.toplevel_result Lwt.t
(** Parse and typecheck a given source code. *)
-val check: t -> string -> unit Toploop_results.toplevel_result Lwt.t
+val set_checking_environment : t -> unit Lwt.t
(** Freezes the environment for future calls to {!check}. *)
-val set_checking_environment: t -> unit Lwt.t
+val clear : t -> unit
(** Empty the toplevel container content. *)
-val clear: t -> unit
+val reset : t -> unit Lwt.t
(** Reset the toplevel environment. *)
-val reset: t -> unit Lwt.t
+val print_string : t -> string -> unit
(** Print a message in the toplevel standard output. This is equivalent
to calling [Pervasives.print_string] in the toplevel session.
Calls {!Learnocaml_toplevel_output.output_stdout}. *)
-val print_string: t -> string -> unit
+val prerr_string : t -> string -> unit
(** Print a message in the toplevel standard error output. This is
equivalent to calling [Pervasives.prerr_string] in the toplevel
session. Calls {!Learnocaml_toplevel_output.output_stderr}. *)
-val prerr_string: t -> string -> unit
+val print_html : t -> string -> unit
(** Print a block of HTML in the toplevel output.
Calls {!Learnocaml_toplevel_output.output_html}. *)
-val print_html: t -> string -> unit
+val scroll : t -> unit
(** scroll the view to show the last phrase.
Calls {!Learnocaml_toplevel_output.scroll. *)
-val scroll: t -> unit
+val execute : t -> unit
(** Execute the content of the input [textarea].
This is equivalent to pressing [Enter] when the toplevel is focused. *)
-val execute: t -> unit
+val go_backward : t -> unit
(** Go backward in the input's history.
This is equivalent to pressing [Up] when the toplevel is focused. *)
-val go_backward: t -> unit
+val go_forward : t -> unit
(** Go forward in the input's history.
This is equivalent to pressing [Down] when the toplevel is focused. *)
-val go_forward: t -> unit
diff --git a/src/toplevel/learnocaml_toplevel_history.ml b/src/toplevel/learnocaml_toplevel_history.ml
index a75507333..9e3470334 100644
--- a/src/toplevel/learnocaml_toplevel_history.ml
+++ b/src/toplevel/learnocaml_toplevel_history.ml
@@ -7,146 +7,131 @@
* included LICENSE file for details. *)
type history =
- { mutable storage : string array ;
- mutable updated : string array ;
- mutable first : int ;
- mutable stored : int ;
- mutable current : [ `Floating | `Index of int ] ;
- mutable floating : string ;
- on_update : (history -> unit) option ;
- mutable mtime : float ;
- gettimeofday : unit -> float }
+ { mutable storage : string array
+ ; mutable updated : string array
+ ; mutable first : int
+ ; mutable stored : int
+ ; mutable current : [`Floating | `Index of int]
+ ; mutable floating : string
+ ; on_update : (history -> unit) option
+ ; mutable mtime : float
+ ; gettimeofday : unit -> float }
-type snapshot =
- { phrases : string list ;
- mtime : float }
+type snapshot = {phrases : string list; mtime : float}
-let empty_snapshot =
- { phrases = [] ; mtime = 0. }
+let empty_snapshot = {phrases = []; mtime = 0.}
let snapshot_enc =
let open Json_encoding in
union
[ case (list string)
- (function { phrases ; mtime = 0. } -> Some phrases | _ -> None)
- (fun phrases -> { phrases ; mtime = 0. }) ;
- case (obj2 (req "phrases" (list string)) (req "mtime" float))
- (function { phrases ; mtime } -> Some (phrases, mtime))
- (fun (phrases, mtime) -> { phrases ; mtime }) ]
+ (function {phrases; mtime = 0.} -> Some phrases | _ -> None)
+ (fun phrases -> {phrases; mtime = 0.})
+ ; case
+ (obj2 (req "phrases" (list string)) (req "mtime" float))
+ (function {phrases; mtime} -> Some (phrases, mtime))
+ (fun (phrases, mtime) -> {phrases; mtime}) ]
-let snapshot { storage ; first ; stored ; mtime ; _} =
+let snapshot {storage; first; stored; mtime; _} =
let rec to_list acc i n =
- if n = 0 then
- List.rev acc
- else
- to_list
- (storage.(i) :: acc)
- ((i + 1) mod Array.length storage)
- (n - 1) in
- { phrases = to_list [] first stored ;
- mtime }
+ if n = 0 then List.rev acc
+ else to_list (storage.(i) :: acc) ((i + 1) mod Array.length storage) (n - 1)
+ in
+ {phrases = to_list [] first stored; mtime}
let call_on_update (self : history) =
- self.mtime <- self.gettimeofday () ;
- match self.on_update with
- | None -> ()
- | Some callback -> callback self
+ self.mtime <- self.gettimeofday ();
+ match self.on_update with None -> () | Some callback -> callback self
let create ~gettimeofday ?on_update ?(max_size = 0) ?snapshot () =
let history =
- { storage = Array.make max_size "" ;
- updated = Array.make max_size "" ;
- first = 0 ;
- stored = 0 ;
- current = `Floating ;
- floating = "" ;
- on_update ;
- mtime = 0. ;
- gettimeofday } in
- begin match snapshot with
- | None -> ()
- | Some { phrases ; mtime } ->
- history.mtime <- mtime ;
- List.iteri (fun i code ->
- if i >= max_size then () else begin
- history.storage.(i) <- code ;
- history.updated.(i) <- code ;
- history.stored <- history.stored + 1
- end)
- phrases
- end ;
+ { storage = Array.make max_size ""
+ ; updated = Array.make max_size ""
+ ; first = 0
+ ; stored = 0
+ ; current = `Floating
+ ; floating = ""
+ ; on_update
+ ; mtime = 0.
+ ; gettimeofday }
+ in
+ ( match snapshot with
+ | None -> ()
+ | Some {phrases; mtime} ->
+ history.mtime <- mtime;
+ List.iteri
+ (fun i code ->
+ if i >= max_size then ()
+ else (
+ history.storage.(i) <- code;
+ history.updated.(i) <- code;
+ history.stored <- history.stored + 1 ) )
+ phrases );
history
let current history =
match history with
- | { current = `Floating ; floating ; _ } -> floating
- | { current = `Index i ; updated ; _ } -> updated.(i)
+ | {current = `Floating; floating; _} -> floating
+ | {current = `Index i; updated; _} -> updated.(i)
let update history text =
match history with
- | { current = `Floating ; _ } ->
- history.floating <- text
- | { current = `Index i ; updated ; _ } ->
- updated.(i) <- text ;
- call_on_update history
+ | {current = `Floating; _} -> history.floating <- text
+ | {current = `Index i; updated; _} ->
+ updated.(i) <- text; call_on_update history
let go_forward history =
match history with
- | { current = `Floating ; _ } -> ()
- | { current = `Index i ; _ } ->
+ | {current = `Floating; _} -> ()
+ | {current = `Index i; _} ->
let size = Array.length history.storage in
let last = (history.first + history.stored - 1) mod size in
- if i = last then
- history.current <- `Floating
- else
- history.current <- `Index ((i + 1) mod size)
+ if i = last then history.current <- `Floating
+ else history.current <- `Index ((i + 1) mod size)
let go_backward history =
match history with
- | { current = `Floating ; _ } ->
- if history.stored > 0 then begin
+ | {current = `Floating; _} ->
+ if history.stored > 0 then
let size = Array.length history.storage in
let last = (history.first + history.stored - 1) mod size in
history.current <- `Index last
- end
- | { current = `Index i ; first ; _ } ->
+ | {current = `Index i; first; _} ->
let size = Array.length history.storage in
- if i <> first then
- history.current <- `Index ((i + size - 1) mod size)
+ if i <> first then history.current <- `Index ((i + size - 1) mod size)
let push history =
let text =
match history with
- | { current = `Floating ; _ } -> history.floating
- | { current = `Index i ; _ } ->
+ | {current = `Floating; _} -> history.floating
+ | {current = `Index i; _} ->
let updated = history.updated.(i) in
- history.updated.(i) <- history.storage.(i) ;
- updated in
- history.floating <- "" ;
- history.current <- `Floating ;
+ history.updated.(i) <- history.storage.(i);
+ updated
+ in
+ history.floating <- "";
+ history.current <- `Floating;
let size = Array.length history.storage in
- if history.stored = 0
- || (let last = (history.stored + history.first - 1) mod size in
- (* don't insert duplicates *)
- history.storage.(last) <> text) then begin
- if text <> "" then begin
- if history.stored < size then begin
- history.stored <- history.stored + 1
- end else begin
- history.first <- (history.first + 1) mod size
- end ;
+ if
+ history.stored = 0
+ ||
+ let last = (history.stored + history.first - 1) mod size in
+ (* don't insert duplicates *)
+ history.storage.(last) <> text
+ then
+ if text <> "" then (
+ if history.stored < size then history.stored <- history.stored + 1
+ else history.first <- (history.first + 1) mod size;
let i = (history.stored + history.first - 1) mod size in
- history.storage.(i) <- text ;
- call_on_update history ;
- history.updated.(i) <- text
- end
- end
+ history.storage.(i) <- text;
+ call_on_update history;
+ history.updated.(i) <- text )
let discard history =
match history with
- | { current = `Floating ; _ } ->
- history.floating <- "" ;
+ | {current = `Floating; _} ->
+ history.floating <- "";
history.current <- `Floating
- | { current = `Index i ; _ } ->
- history.updated.(i) <- history.storage.(i) ;
+ | {current = `Index i; _} ->
+ history.updated.(i) <- history.storage.(i);
history.current <- `Floating
diff --git a/src/toplevel/learnocaml_toplevel_history.mli b/src/toplevel/learnocaml_toplevel_history.mli
index 72807cd5f..b5ca8ad77 100644
--- a/src/toplevel/learnocaml_toplevel_history.mli
+++ b/src/toplevel/learnocaml_toplevel_history.mli
@@ -8,20 +8,19 @@
type history
-type snapshot =
- { phrases : string list ;
- mtime : float }
+type snapshot = {phrases : string list; mtime : float}
val snapshot_enc : snapshot Json_encoding.encoding
val empty_snapshot : snapshot
-val create:
- gettimeofday: (unit -> float) ->
- ?on_update: (history -> unit) ->
- ?max_size: int ->
- ?snapshot: snapshot ->
- unit -> history
+val create :
+ gettimeofday:(unit -> float)
+ -> ?on_update:(history -> unit)
+ -> ?max_size:int
+ -> ?snapshot:snapshot
+ -> unit
+ -> history
val current : history -> string
diff --git a/src/toplevel/learnocaml_toplevel_input.ml b/src/toplevel/learnocaml_toplevel_input.ml
index d27ca008f..89f96ac33 100644
--- a/src/toplevel/learnocaml_toplevel_input.ml
+++ b/src/toplevel/learnocaml_toplevel_input.ml
@@ -9,179 +9,173 @@
open Js_of_ocaml
let indent_caml s in_lines =
- let output = {
- IndentPrinter.debug = false;
- config = IndentConfig.default;
- in_lines;
- indent_empty = true;
- adaptive = true;
- kind = IndentPrinter.Print (fun s acc -> acc ^ s)
- }
+ let output =
+ { IndentPrinter.debug = false
+ ; config = IndentConfig.default
+ ; in_lines
+ ; indent_empty = true
+ ; adaptive = true
+ ; kind = IndentPrinter.Print (fun s acc -> acc ^ s) }
in
let stream = Nstream.of_string s in
IndentPrinter.proceed output stream IndentBlock.empty ""
let indent_ocaml_textarea textbox =
- let rec loop s acc (i,pos') =
+ let rec loop s acc (i, pos') =
try
let pos = String.index_from s pos' '\n' in
- loop s ((i,(pos',pos))::acc) (succ i,succ pos)
- with _ -> List.rev ((i,(pos',String.length s)) :: acc) in
- let rec find (l : (int * (int * int)) list ) c =
+ loop s ((i, (pos', pos)) :: acc) (succ i, succ pos)
+ with _ -> List.rev ((i, (pos', String.length s)) :: acc)
+ in
+ let rec find (l : (int * (int * int)) list) c =
match l with
| [] -> assert false
- | (i,(lo,up))::_ when up >= c -> c,i,lo,up
- | _::rem -> find rem c in
+ | (i, (lo, up)) :: _ when up >= c -> (c, i, lo, up)
+ | _ :: rem -> find rem c
+ in
let v = textbox##.value in
let pos =
let c1 = (Obj.magic textbox)##.selectionStart
and c2 = (Obj.magic textbox)##.selectionEnd in
- if Js.Opt.test (Obj.magic c1) && Js.Opt.test (Obj.magic c2)
- then begin
- let l = loop (Js.to_string v) [] (0,0) in
- Some (find l c1,find l c2)
- end
- else None in
- let f = match pos with
- | None -> (fun _ -> true)
- | Some ((_,line1,_,_),(_,line2,_,_)) -> (fun l -> l>=(line1+1) && l<=(line2+1)) in
+ if Js.Opt.test (Obj.magic c1) && Js.Opt.test (Obj.magic c2) then
+ let l = loop (Js.to_string v) [] (0, 0) in
+ Some (find l c1, find l c2)
+ else None
+ in
+ let f =
+ match pos with
+ | None -> fun _ -> true
+ | Some ((_, line1, _, _), (_, line2, _, _)) ->
+ fun l -> l >= line1 + 1 && l <= line2 + 1
+ in
let v = indent_caml (Js.to_string v) f in
- textbox##.value:=Js.string v;
- begin match pos with
- | Some ((c1,line1,_,up1),(c2,line2,_,up2)) ->
- let l = loop v [] (0,0) in
- let (lo1'',up1'') = List.assoc line1 l in
- let (lo2'',up2'') = List.assoc line2 l in
+ textbox##.value := Js.string v;
+ match pos with
+ | Some ((c1, line1, _, up1), (c2, line2, _, up2)) ->
+ let l = loop v [] (0, 0) in
+ let lo1'', up1'' = List.assoc line1 l in
+ let lo2'', up2'' = List.assoc line2 l in
let n1 = max (c1 + up1'' - up1) lo1'' in
let n2 = max (c2 + up2'' - up2) lo2'' in
- let () = (Obj.magic textbox)##(setSelectionRange n1 n2) in
- textbox##focus;
- ()
- | None -> () end
+ let () = (Obj.magic textbox) ## (setSelectionRange n1 n2) in
+ textbox##focus; ()
+ | None -> ()
-type sizing =
- { line_height : int ;
- min_lines : int ;
- max_lines : int }
+type sizing = {line_height : int; min_lines : int; max_lines : int}
type input =
- { textbox : Dom_html.textAreaElement Js.t ;
- sizing : sizing option ;
- container : [ `Div ] Tyxml_js.Html5.elt ;
- mutable focused : bool ;
- mutable disabled : bool ;
- history : Learnocaml_toplevel_history.history ;
- on_resize : unit -> unit ;
- execute : string -> unit }
+ { textbox : Dom_html.textAreaElement Js.t
+ ; sizing : sizing option
+ ; container : [`Div] Tyxml_js.Html5.elt
+ ; mutable focused : bool
+ ; mutable disabled : bool
+ ; history : Learnocaml_toplevel_history.history
+ ; on_resize : unit -> unit
+ ; execute : string -> unit }
-let disable ({ textbox ; container } as input) =
- textbox##.disabled := Js._true ;
- Js_utils.Manip.addClass container "disabled" ;
+let disable ({textbox; container} as input) =
+ textbox##.disabled := Js._true;
+ Js_utils.Manip.addClass container "disabled";
input.disabled <- true
-let enable ({ textbox ; container } as input) =
- textbox##.disabled := Js._false ;
- Js_utils.Manip.removeClass container "disabled" ;
- if input.focused then textbox##focus ;
+let enable ({textbox; container} as input) =
+ textbox##.disabled := Js._false;
+ Js_utils.Manip.removeClass container "disabled";
+ if input.focused then textbox##focus;
input.disabled <- false
-let set { textbox } text =
- textbox##.value := Js.string text
+let set {textbox} text = textbox##.value := Js.string text
-let get { textbox } =
- Js.to_string textbox##.value
+let get {textbox} = Js.to_string textbox##.value
-let resize { textbox ; sizing ; on_resize } =
+let resize {textbox; sizing; on_resize} =
match sizing with
| None -> ()
- | Some { line_height ; min_lines ; max_lines } ->
- on_resize () ;
+ | Some {line_height; min_lines; max_lines} ->
+ on_resize ();
let lines =
let text = textbox##.value in
let res = ref 1 in
for i = 0 to text##.length - 1 do
- if text##(charAt i) = Js.string "\n" then incr res
- done ;
- !res |> min max_lines |> max min_lines in
- textbox##.style##.fontSize := (Js.string (string_of_int line_height ^ "px")) ;
- textbox##.style##.height := Js.string (Printf.sprintf "%dpx" (line_height * lines))
+ if text ## (charAt i) = Js.string "\n" then incr res
+ done;
+ !res |> min max_lines |> max min_lines
+ in
+ textbox##.style##.fontSize := Js.string (string_of_int line_height ^ "px");
+ textbox##.style##.height
+ := Js.string (Printf.sprintf "%dpx" (line_height * lines))
-let execute ({ history ; textbox ; execute } as input) =
+let execute ({history; textbox; execute} as input) =
let code = Js.to_string textbox##.value in
- Learnocaml_toplevel_history.update history code ;
- Learnocaml_toplevel_history.push history ;
- textbox##.value := Js.string (Learnocaml_toplevel_history.current history) ;
- resize input ;
+ Learnocaml_toplevel_history.update history code;
+ Learnocaml_toplevel_history.push history;
+ textbox##.value := Js.string (Learnocaml_toplevel_history.current history);
+ resize input;
execute code
-let go_backward ({ history ; textbox } as input) =
- Learnocaml_toplevel_history.update history (Js.to_string textbox##.value) ;
- Learnocaml_toplevel_history.go_backward history ;
- textbox##.value := Js.string (Learnocaml_toplevel_history.current history) ;
+let go_backward ({history; textbox} as input) =
+ Learnocaml_toplevel_history.update history (Js.to_string textbox##.value);
+ Learnocaml_toplevel_history.go_backward history;
+ textbox##.value := Js.string (Learnocaml_toplevel_history.current history);
resize input
-let go_forward ({ history ; textbox } as input) =
- Learnocaml_toplevel_history.update history (Js.to_string textbox##.value) ;
- Learnocaml_toplevel_history.go_forward history ;
- textbox##.value := Js.string (Learnocaml_toplevel_history.current history) ;
- resize input
+let go_forward ({history; textbox} as input) =
+ Learnocaml_toplevel_history.update history (Js.to_string textbox##.value);
+ Learnocaml_toplevel_history.go_forward history;
+ textbox##.value := Js.string (Learnocaml_toplevel_history.current history);
+ resize input
-let focus input = input.textbox##focus
+let focus input = (input.textbox)##focus
-let setup
- ?sizing ?history
- ?(on_resize = (fun () -> ()))
+let setup ?sizing ?history ?(on_resize = fun () -> ())
~execute:execute_callback ~container () =
- let textbox =
- Dom_html.createTextarea Dom_html.document in
- Js_utils.Manip.addClass container "toplevel-input" ;
- let history = match history with
+ let textbox = Dom_html.createTextarea Dom_html.document in
+ Js_utils.Manip.addClass container "toplevel-input";
+ let history =
+ match history with
| None ->
let gettimeofday () = 0. (* unsaved history *) in
- Learnocaml_toplevel_history.create ~gettimeofday ~max_size: 99 ()
- | Some history -> history in
+ Learnocaml_toplevel_history.create ~gettimeofday ~max_size:99 ()
+ | Some history -> history
+ in
let input =
- { textbox ; sizing ; container ; history ; on_resize ;
- focused = false ; disabled = false ; execute = execute_callback } in
- textbox##.onkeydown := Dom_html.handler (fun e ->
- let ctrl = Js.to_bool e##.ctrlKey || Js.to_bool e##.metaKey in
- let shift = Js.to_bool e##.shiftKey in
- match e##.keyCode with
- (* Enter *)
- | 13 when not (shift || ctrl) ->
- execute input ;
- Js._false
- (* Tab *)
- | 09 when not shift ->
- indent_ocaml_textarea textbox ;
- Js._false
- (* Up arrow *)
- | 38 when ctrl ->
- go_backward input ;
- Js._false
- (* Down arrow *)
- | 40 when ctrl ->
- go_forward input ;
- Js._false
- (* Defaults *)
- | 13 ->
- resize input ;
- Js._true
- | _ -> Js._true
- );
+ { textbox
+ ; sizing
+ ; container
+ ; history
+ ; on_resize
+ ; focused = false
+ ; disabled = false
+ ; execute = execute_callback }
+ in
+ textbox##.onkeydown :=
+ Dom_html.handler (fun e ->
+ let ctrl = Js.to_bool e##.ctrlKey || Js.to_bool e##.metaKey in
+ let shift = Js.to_bool e##.shiftKey in
+ match e##.keyCode with
+ (* Enter *)
+ | 13 when not (shift || ctrl) -> execute input; Js._false
+ (* Tab *)
+ | 09 when not shift ->
+ indent_ocaml_textarea textbox;
+ Js._false
+ (* Up arrow *)
+ | 38 when ctrl -> go_backward input; Js._false
+ (* Down arrow *)
+ | 40 when ctrl -> go_forward input; Js._false
+ (* Defaults *)
+ | 13 -> resize input; Js._true
+ | _ -> Js._true );
textbox##.onfocus :=
Dom_html.handler (fun _ ->
- if not (input.disabled) then input.focused <- true ;
- Js._true);
+ if not input.disabled then input.focused <- true;
+ Js._true );
textbox##.onblur :=
Dom_html.handler (fun _ ->
- if not (input.disabled) then input.focused <- false ;
- Js._true);
- textbox##.onkeyup :=
- Dom_html.handler (fun _ -> resize input ; Js._true);
- textbox##.onchange :=
- Dom_html.handler (fun _ -> resize input ; Js._true);
- Js_utils.Manip.replaceChildren container
- [ Tyxml_js.Of_dom.of_textArea textbox ] ;
- resize input ;
+ if not input.disabled then input.focused <- false;
+ Js._true );
+ textbox##.onkeyup := Dom_html.handler (fun _ -> resize input; Js._true);
+ textbox##.onchange := Dom_html.handler (fun _ -> resize input; Js._true);
+ Js_utils.Manip.replaceChildren container [Tyxml_js.Of_dom.of_textArea textbox];
+ resize input;
input
diff --git a/src/toplevel/learnocaml_toplevel_input.mli b/src/toplevel/learnocaml_toplevel_input.mli
index 8d3bd3e66..e44a6fec6 100644
--- a/src/toplevel/learnocaml_toplevel_input.mli
+++ b/src/toplevel/learnocaml_toplevel_input.mli
@@ -13,10 +13,19 @@ type input
(** Size parameters for the input box. *)
type sizing =
- { line_height : int (** The height of ta line in pixels. *) ;
- min_lines : int (** The minimum assigned height in terms of of lines. *) ;
- max_lines : int (** The maximum assigned height in terms of of lines. *) }
+ { line_height : int (** The height of ta line in pixels. *)
+ ; min_lines : int (** The minimum assigned height in terms of of lines. *)
+ ; max_lines : int (** The maximum assigned height in terms of of lines. *)
+ }
+val setup :
+ ?sizing:sizing
+ -> ?history:Learnocaml_toplevel_history.history
+ -> ?on_resize:(unit -> unit)
+ -> execute:(string -> unit)
+ -> container:[`Div] Tyxml_js.Html5.elt
+ -> unit
+ -> input
(** Use a given div as an input box.
Inserts a textarea in it and gives it the class [toplevel-input].
@@ -29,35 +38,28 @@ type sizing =
@param execute
The callback called whenever the [Enter] key is pressed, or the
{!execute} function is called. *)
-val setup :
- ?sizing: sizing ->
- ?history:Learnocaml_toplevel_history.history ->
- ?on_resize:(unit -> unit) ->
- execute: (string -> unit) ->
- container: [ `Div ] Tyxml_js.Html5.elt ->
- unit -> input
-(** Disable the input box. *)
val disable : input -> unit
+(** Disable the input box. *)
-(** Enable the input box. *)
val enable : input -> unit
+(** Enable the input box. *)
+val set : input -> string -> unit
(** Updates the contents of the field.
Discards its current contents. *)
-val set : input -> string -> unit
-(** Gives the content of the input box. *)
val get : input -> string
+(** Gives the content of the input box. *)
-(** Simulates a hit on the [Enter] key *)
val execute : input -> unit
+(** Simulates a hit on the [Enter] key *)
-(** Simulates a hit on the [Up] key *)
val go_backward : input -> unit
+(** Simulates a hit on the [Up] key *)
-(** Simulates a hit on the [Down] key *)
val go_forward : input -> unit
+(** Simulates a hit on the [Down] key *)
-(** Sets focus to the text input field *)
val focus : input -> unit
+(** Sets focus to the text input field *)
diff --git a/src/toplevel/learnocaml_toplevel_output.ml b/src/toplevel/learnocaml_toplevel_output.ml
index 642300e43..efeebe68e 100644
--- a/src/toplevel/learnocaml_toplevel_output.ml
+++ b/src/toplevel/learnocaml_toplevel_output.ml
@@ -9,180 +9,185 @@
open Js_of_ocaml
type block =
- | Html of string * [ `Div ] Tyxml_js.Html5.elt
- | Std of (string * [ `Out | `Err ]) list ref * [ `Pre ] Tyxml_js.Html5.elt
- | Code of string * pretty list ref * [ `Pre ] Tyxml_js.Html5.elt * Nstream.snapshot option
- | Answer of string * pretty list ref * [ `Pre ] Tyxml_js.Html5.elt * Nstream.snapshot option
- | Error of Toploop_results.error * [ `Pre ] Tyxml_js.Html5.elt
- | Warning of int * Toploop_results.warning * [ `Pre ] Tyxml_js.Html5.elt
+ | Html of string * [`Div] Tyxml_js.Html5.elt
+ | Std of (string * [`Out | `Err]) list ref * [`Pre] Tyxml_js.Html5.elt
+ | Code of
+ string
+ * pretty list ref
+ * [`Pre] Tyxml_js.Html5.elt
+ * Nstream.snapshot option
+ | Answer of
+ string
+ * pretty list ref
+ * [`Pre] Tyxml_js.Html5.elt
+ * Nstream.snapshot option
+ | Error of Toploop_results.error * [`Pre] Tyxml_js.Html5.elt
+ | Warning of int * Toploop_results.warning * [`Pre] Tyxml_js.Html5.elt
| Phrase of phrase * block list ref
-and pretty =
- | String of string
- | Ref of int
- | Class of string * pretty list
+and pretty = String of string | Ref of int | Class of string * pretty list
-and phrase =
- { mutable warnings : int }
+and phrase = {mutable warnings : int}
-let phrase () =
- { warnings = 0 }
+let phrase () = {warnings = 0}
type output =
- { limit : int ;
- container : [ `Div ] Tyxml_js.Html5.elt ;
- mutable blocks : block list ;
- on_resize : unit -> unit }
-
-let setup
- ?(limit = max_int)
- ?(on_resize = (fun () -> ()))
- ~container () =
- Js_utils.Manip.addClass container "toplevel-output" ;
- { container ; limit ; blocks = [] ; on_resize }
-
-let enforce_limit { limit ; container } =
+ { limit : int
+ ; container : [`Div] Tyxml_js.Html5.elt
+ ; mutable blocks : block list
+ ; on_resize : unit -> unit }
+
+let setup ?(limit = max_int) ?(on_resize = fun () -> ()) ~container () =
+ Js_utils.Manip.addClass container "toplevel-output";
+ {container; limit; blocks = []; on_resize}
+
+let enforce_limit {limit; container} =
let container = Tyxml_js.To_dom.of_div container in
while container##.childNodes##.length > limit do
- Js.Opt.case
- (container##.firstChild)
+ Js.Opt.case container##.firstChild
(fun () -> ())
- (fun child -> ignore (container##(removeChild child)))
+ (fun child -> ignore container ## (removeChild child))
done
-let scroll { container ; on_resize } =
+let scroll {container; on_resize} =
let container = Tyxml_js.To_dom.of_div container in
- Lwt.async @@ fun () ->
- Lwt.bind (Lwt_js.yield ()) @@ fun () ->
- container##.scrollTop := container##.scrollHeight - container##.clientHeight ;
- on_resize () ;
+ Lwt.async
+ @@ fun () ->
+ Lwt.bind (Lwt_js.yield ())
+ @@ fun () ->
+ container##.scrollTop := container##.scrollHeight - container##.clientHeight;
+ on_resize ();
Lwt.return_unit
-let rec pretty_html
- : 'a. pretty list -> ([> `Span | `PCDATA ] as 'a) Tyxml_js.Html5.elt list
- = fun pretty ->
+let rec pretty_html :
+ 'a. pretty list
+ -> ([> `Span | `PCDATA] as 'a) Tyxml_js.Html5.elt list =
+ fun pretty ->
let open Tyxml_js.Html5 in
List.map
(function
- | String text ->
- txt text
- | Ref n ->
- span ~a: [ a_class [ "ref" ] ] [ txt (string_of_int n) ]
- | Class (cls, [ Class (cls', [ Class (cls'', toks) ]) ]) ->
- span ~a: [ a_class [ cls ; cls' ; cls'' ] ] (pretty_html toks)
- | Class (cls, [ Class (cls', toks) ]) ->
- span ~a: [ a_class [ cls ; cls' ] ] (pretty_html toks)
- | Class (cls, toks) ->
- span ~a: [ a_class [ cls ] ] (pretty_html toks))
+ | String text -> txt text
+ | Ref n -> span ~a:[a_class ["ref"]] [txt (string_of_int n)]
+ | Class (cls, [Class (cls', [Class (cls'', toks)])]) ->
+ span ~a:[a_class [cls; cls'; cls'']] (pretty_html toks)
+ | Class (cls, [Class (cls', toks)]) ->
+ span ~a:[a_class [cls; cls']] (pretty_html toks)
+ | Class (cls, toks) -> span ~a:[a_class [cls]] (pretty_html toks))
pretty
let initial_state =
- { Approx_lexer.initial_state with Approx_lexer.eof_closing = false },
- Nstream.Region.zero
+ ( {Approx_lexer.initial_state with Approx_lexer.eof_closing = false}
+ , Nstream.Region.zero )
let prettify_ocaml ?(snapshot = initial_state) code =
- let stream = Nstream.of_string ~st: snapshot code in
+ let stream = Nstream.of_string ~st:snapshot code in
let rec format snapshot stream acc =
let open Approx_tokens in
let open Nstream in
match Nstream.next_full stream with
- | None -> List.rev acc, snapshot
- | Some ({token = EOF}, _snapshot, _) -> List.rev acc, snapshot
+ | None -> (List.rev acc, snapshot)
+ | Some ({token = EOF}, _snapshot, _) -> (List.rev acc, snapshot)
| Some (tok, snapshot, stream) ->
let this =
let kind = Ocaml_mode.token_type tok.token in
- Class (kind, [ String tok.substr ]) ::
- if tok.between = "" then [] else [ String tok.between ] in
- format (Some snapshot) stream (this @ acc) in
+ Class (kind, [String tok.substr])
+ :: (if tok.between = "" then [] else [String tok.between])
+ in
+ format (Some snapshot) stream (this @ acc)
+ in
format (Some snapshot) stream []
let rec last_elt = function
| [] -> raise Not_found
- | Html (_, div) :: _ -> (div :> [ `Div | `Pre ] Tyxml_js.Html5.elt)
+ | Html (_, div) :: _ -> (div :> [`Div | `Pre] Tyxml_js.Html5.elt)
| Std (_, pre) :: _
- | Code (_, _, pre, _) :: _
- | Answer (_, _, pre, _) :: _
- | Error (_, pre) :: _
- | Warning (_, _, pre) :: _ -> (pre :> [ `Div | `Pre ] Tyxml_js.Html5.elt)
- | Phrase (_, { contents }) :: rest ->
- try last_elt contents with Not_found -> last_elt rest
+ |Code (_, _, pre, _) :: _
+ |Answer (_, _, pre, _) :: _
+ |Error (_, pre) :: _
+ |Warning (_, _, pre) :: _ ->
+ (pre :> [`Div | `Pre] Tyxml_js.Html5.elt)
+ | Phrase (_, {contents}) :: rest -> (
+ try last_elt contents with Not_found -> last_elt rest )
let find_phrase output u =
List.fold_left
- (fun acc block -> match acc, block with
- | None, Phrase (u', l) when u == u' -> Some l
- | _ -> acc)
+ (fun acc block ->
+ match (acc, block) with
+ | None, Phrase (u', l) when u == u' -> Some l
+ | _ -> acc )
None output.blocks
let insert output ?phrase block elt =
let hr = Tyxml_js.Html5.hr () in
match phrase with
| None ->
- output.blocks <- block :: output.blocks ;
- Js_utils.Manip.appendChild output.container hr ;
- Js_utils.Manip.appendChild output.container elt ;
+ output.blocks <- block :: output.blocks;
+ Js_utils.Manip.appendChild output.container hr;
+ Js_utils.Manip.appendChild output.container elt;
scroll output
- | Some u ->
- match find_phrase output u with
- | Some l ->
- Js_utils.Manip.insertChildAfter output.container (last_elt !l) elt ;
- l := block :: !l ;
- scroll output
- | None ->
- output.blocks <- Phrase (u, ref [ block ]) :: output.blocks ;
- Js_utils.Manip.appendChild output.container hr ;
- Js_utils.Manip.appendChild output.container elt ;
- scroll output
+ | Some u -> (
+ match find_phrase output u with
+ | Some l ->
+ Js_utils.Manip.insertChildAfter output.container (last_elt !l) elt;
+ l := block :: !l;
+ scroll output
+ | None ->
+ output.blocks <- Phrase (u, ref [block]) :: output.blocks;
+ Js_utils.Manip.appendChild output.container hr;
+ Js_utils.Manip.appendChild output.container elt;
+ scroll output )
let output_std ?phrase output (str, chan) =
- enforce_limit output ;
+ enforce_limit output;
let buf, pre =
match output.blocks with
- | Phrase (u, l) :: _ when (Some u) = phrase ->
+ | Phrase (u, l) :: _ when Some u = phrase ->
let rec find = function
- | Std (buf, pre) :: _ -> buf, pre
+ | Std (buf, pre) :: _ -> (buf, pre)
| _ :: rest -> find rest
| [] ->
let buf, pre =
- ref [],
- Tyxml_js.Html5.(pre ~a: [ a_class [ "toplevel-output" ] ]) [] in
- Js_utils.Manip.insertChildAfter output.container (last_elt !l) pre ;
- l := Std (buf, pre) :: !l ;
- Js_utils.Manip.appendChild output.container pre ;
- buf, pre in
+ ( ref []
+ , Tyxml_js.Html5.(pre ~a:[a_class ["toplevel-output"]]) [] )
+ in
+ Js_utils.Manip.insertChildAfter output.container (last_elt !l)
+ pre;
+ l := Std (buf, pre) :: !l;
+ Js_utils.Manip.appendChild output.container pre;
+ (buf, pre)
+ in
find !l
- | Std (buf, pre) :: _ -> buf, pre
+ | Std (buf, pre) :: _ -> (buf, pre)
| _ ->
let hr = Tyxml_js.Html5.hr () in
let buf, pre =
- ref [],
- Tyxml_js.Html5.(pre ~a: [ a_class [ "toplevel-output" ] ]) [] in
- output.blocks <- Std (buf, pre) :: output.blocks ;
- Js_utils.Manip.appendChild output.container hr ;
- Js_utils.Manip.appendChild output.container pre ;
- buf, pre in
+ (ref [], Tyxml_js.Html5.(pre ~a:[a_class ["toplevel-output"]]) [])
+ in
+ output.blocks <- Std (buf, pre) :: output.blocks;
+ Js_utils.Manip.appendChild output.container hr;
+ Js_utils.Manip.appendChild output.container pre;
+ (buf, pre)
+ in
let cls = match chan with `Err -> "stderr" | `Out -> "stdout" in
Js_utils.Manip.appendChild pre
- (Tyxml_js.Html5.(span ~a: [ a_class [ cls ] ] [ txt str ])) ;
- buf := (str, chan) :: !buf ;
+ Tyxml_js.Html5.(span ~a:[a_class [cls]] [txt str]);
+ buf := (str, chan) :: !buf;
scroll output
-let output_stdout ?phrase output str =
- output_std ?phrase output (str, `Out)
+let output_stdout ?phrase output str = output_std ?phrase output (str, `Out)
-let output_stderr ?phrase output str =
- output_std ?phrase output (str, `Err)
+let output_stderr ?phrase output str = output_std ?phrase output (str, `Err)
let output_html ?phrase output html =
- enforce_limit output ;
- let div = Tyxml_js.Html5.(div ~a: [ a_class [ "toplevel-html-block" ] ]) [] in
- Js_utils.Manip.setInnerHtml div html ;
- Js_utils.Manip.appendChild output.container div ;
+ enforce_limit output;
+ let div = Tyxml_js.Html5.(div ~a:[a_class ["toplevel-html-block"]]) [] in
+ Js_utils.Manip.setInnerHtml div html;
+ Js_utils.Manip.appendChild output.container div;
insert output ?phrase (Html (html, div)) div
let get_fresh_id =
let r = ref 0 in
- fun () -> incr r ; !r
+ fun () -> incr r; !r
(* It replaces markup field id by "id-" to avoid interferences
between svg images when they are inserted in the same DOM.
@@ -203,106 +208,103 @@ let replace_link svg =
(* It cleans the svg string to be readable in the web app. *)
let rewrite_svg svg =
let idx = get_fresh_id () in
- replace_markup idx "id" svg
- |> replace_markup idx "l:href"
- |> replace_link
+ replace_markup idx "id" svg |> replace_markup idx "l:href" |> replace_link
let output_svg ?phrase output svg =
- let svg = rewrite_svg svg in
+ let svg = rewrite_svg svg in
output_html ?phrase output svg
let output_code ?phrase output code =
let snapshot =
- let blocks = match phrase with
+ let blocks =
+ match phrase with
| None -> output.blocks
- | Some u ->
- match find_phrase output u with
- | None -> []
- | Some l -> !l in
+ | Some u -> (
+ match find_phrase output u with None -> [] | Some l -> !l )
+ in
match blocks with
| Code (_, _, _, snapshot) :: _ -> snapshot
- | [] | _ -> None in
- enforce_limit output ;
+ | [] | _ -> None
+ in
+ enforce_limit output;
let pretty, snapshot = prettify_ocaml ?snapshot code in
let pre =
- Tyxml_js.Html5.(pre ~a: [ a_class [ "toplevel-code" ] ])
- (pretty_html pretty) in
+ Tyxml_js.Html5.(pre ~a:[a_class ["toplevel-code"]]) (pretty_html pretty)
+ in
insert output ?phrase (Code (code, ref pretty, pre, snapshot)) pre
let output_answer ?phrase output answer =
let snapshot =
- let blocks = match phrase with
+ let blocks =
+ match phrase with
| None -> output.blocks
- | Some u ->
- match find_phrase output u with
- | None -> []
- | Some l -> !l in
+ | Some u -> (
+ match find_phrase output u with None -> [] | Some l -> !l )
+ in
match blocks with
| Answer (_, _, _, snapshot) :: _ -> snapshot
- | [] | _ -> None in
- enforce_limit output ;
+ | [] | _ -> None
+ in
+ enforce_limit output;
let pretty, snapshot = prettify_ocaml ?snapshot answer in
let pre =
- Tyxml_js.Html5.(pre ~a: [ a_class [ "toplevel-answer" ] ])
- (pretty_html pretty) in
+ Tyxml_js.Html5.(pre ~a:[a_class ["toplevel-answer"]]) (pretty_html pretty)
+ in
insert output ?phrase (Answer (answer, ref pretty, pre, snapshot)) pre
open Toploop_results
-let inside (l, c) { loc_start = (sl, sc) ; loc_end = (el, ec) } =
- ((l > sl) || (l = sl && c >= sc))
- && ((l < el) || (l = el && c < ec))
+let inside (l, c) {loc_start = sl, sc; loc_end = el, ec} =
+ (l > sl || (l = sl && c >= sc)) && (l < el || (l = el && c < ec))
-let last (l, c) { loc_end = (el, ec) } =
- l = el && c = ec - 1
+let last (l, c) {loc_end = el, ec} = l = el && c = ec - 1
let hilight_pretty cls pretty locs lbl =
let hilight_one pretty loc =
- let rec hilight_one pretty pos acc = match pretty with
- | [] -> List.rev acc, pos
+ let rec hilight_one pretty pos acc =
+ match pretty with
+ | [] -> (List.rev acc, pos)
| Class (cls, toks) :: rest ->
let toks, pos = hilight_one toks pos [] in
hilight_one rest pos (Class (cls, toks) :: acc)
- | String "" :: rest ->
- hilight_one rest pos acc
- | Ref n :: rest ->
- hilight_one rest pos (Ref n :: acc)
+ | String "" :: rest -> hilight_one rest pos acc
+ | Ref n :: rest -> hilight_one rest pos (Ref n :: acc)
| String s :: rest ->
let next (l, c) = function '\n' -> (l + 1, 0) | _ -> (l, c + 1) in
let rec loop was_inside was_last p i acc pos =
let tok p i =
if was_inside then
(if was_last then lbl else [])
- @ [ Class (cls, [ String (String.sub s p (i - p)) ]) ]
- else
- [ String (String.sub s p (i - p)) ] in
- if i = String.length s then
- tok p i @ acc, pos
- else if was_inside <> (inside pos loc) then
+ @ [Class (cls, [String (String.sub s p (i - p))])]
+ else [String (String.sub s p (i - p))]
+ in
+ if i = String.length s then (tok p i @ acc, pos)
+ else if was_inside <> inside pos loc then
let acc = if p < i then tok p i @ acc else acc in
loop (not was_inside) was_last i i acc pos
- else
- loop was_inside (last pos loc) p (i + 1) acc (next pos (String.get s i)) in
+ else loop was_inside (last pos loc) p (i + 1) acc (next pos s.[i])
+ in
let toks, pos = loop false false 0 0 [] pos in
- hilight_one rest pos (toks @ acc) in
- fst (hilight_one pretty (1, 0) []) in
+ hilight_one rest pos (toks @ acc)
+ in
+ fst (hilight_one pretty (1, 0) [])
+ in
List.fold_left hilight_one pretty locs
let advance_loc code loc =
let rec loop i sl sc el ec =
- if i >= String.length code then
- { loc_start = (sl, sc) ; loc_end = (el, ec) }
+ if i >= String.length code then {loc_start = (sl, sc); loc_end = (el, ec)}
else
let next l c =
(* should work even with ignored '\n's *)
- if l > 1 then
- (if String.get code i = '\n' then l - 1 else l), c
- else
- 1, max 0 (c - 1) in
+ if l > 1 then ((if code.[i] = '\n' then l - 1 else l), c)
+ else (1, max 0 (c - 1))
+ in
let sl, sc = next sl sc in
let el, ec = next el ec in
- loop (i + 1) sl sc el ec in
- let { loc_start = (sl, sc) ; loc_end = (el, ec) } = loc in
+ loop (i + 1) sl sc el ec
+ in
+ let {loc_start = sl, sc; loc_end = el, ec} = loc in
loop 0 sl sc el ec
let hilight cls output u locs lbl =
@@ -311,56 +313,57 @@ let hilight cls output u locs lbl =
| Some l ->
let rec loop locs = function
| Code (code, pretty, pre, _) :: rest ->
- pretty := hilight_pretty cls !pretty locs lbl ;
- Js_utils.Manip.replaceChildren pre (pretty_html !pretty) ;
+ pretty := hilight_pretty cls !pretty locs lbl;
+ Js_utils.Manip.replaceChildren pre (pretty_html !pretty);
let locs = List.map (advance_loc code) locs in
loop locs rest
| _ :: rest -> loop locs rest
- | [] -> () in
+ | [] -> ()
+ in
loop locs (List.rev !l)
let output_error ?phrase output error =
- let { Toploop_results.locs ; msg ; if_highlight } = error in
+ let {Toploop_results.locs; msg; if_highlight} = error in
let content =
[ Tyxml_js.Html5.txt
- (match phrase with None -> msg | Some _ -> if_highlight) ] in
- let pre =
- Tyxml_js.Html5.(pre ~a: [ a_class [ "toplevel-error" ] ]) content in
- begin match phrase, locs with
- | None, _ | _, [] -> ()
- | Some u, _ -> hilight "toplevel-hilighted-error" output u locs []
- end ;
+ (match phrase with None -> msg | Some _ -> if_highlight) ]
+ in
+ let pre = Tyxml_js.Html5.(pre ~a:[a_class ["toplevel-error"]]) content in
+ ( match (phrase, locs) with
+ | None, _ | _, [] -> ()
+ | Some u, _ -> hilight "toplevel-hilighted-error" output u locs [] );
insert output ?phrase (Error (error, pre)) pre
let output_warning ?phrase output warning =
- let { Toploop_results.locs ; msg ; if_highlight } = warning in
- match phrase, locs with
+ let {Toploop_results.locs; msg; if_highlight} = warning in
+ match (phrase, locs) with
| None, _ | _, [] ->
let pre =
- Tyxml_js.Html5.(pre ~a: [ a_class [ "toplevel-warning" ] ]
- [ txt msg ]) in
+ Tyxml_js.Html5.(pre ~a:[a_class ["toplevel-warning"]] [txt msg])
+ in
insert output ?phrase (Warning (0, warning, pre)) pre
| Some phrase, _ ->
- phrase.warnings <- phrase.warnings + 1 ;
+ phrase.warnings <- phrase.warnings + 1;
hilight "toplevel-hilighted-warning" output phrase locs
- [ Ref phrase.warnings ] ;
+ [Ref phrase.warnings];
let pre =
- Tyxml_js.Html5.(pre ~a: [ a_class [ "toplevel-warning" ] ]
- [ span ~a: [ a_class [ "ref" ] ]
- [ txt (string_of_int phrase.warnings) ] ;
- txt ":" ;
- txt if_highlight ]) in
+ Tyxml_js.Html5.(
+ pre
+ ~a:[a_class ["toplevel-warning"]]
+ [ span ~a:[a_class ["ref"]] [txt (string_of_int phrase.warnings)]
+ ; txt ":"
+ ; txt if_highlight ])
+ in
insert output ~phrase (Warning (phrase.warnings, warning, pre)) pre
let clear output =
- Js_utils.Manip.removeChildren output.container ;
+ Js_utils.Manip.removeChildren output.container;
output.blocks <- []
let oldify output =
List.iter
(fun elt -> Js_utils.Manip.addClass elt "old")
- (Js_utils.Manip.children output.container) ;
+ (Js_utils.Manip.children output.container);
output.blocks <- []
-let format_ocaml_code code =
- pretty_html (fst (prettify_ocaml code))
+let format_ocaml_code code = pretty_html (fst (prettify_ocaml code))
diff --git a/src/toplevel/learnocaml_toplevel_output.mli b/src/toplevel/learnocaml_toplevel_output.mli
index e30d7bff7..c8f9049e9 100644
--- a/src/toplevel/learnocaml_toplevel_output.mli
+++ b/src/toplevel/learnocaml_toplevel_output.mli
@@ -11,6 +11,12 @@
(** A toplevel output console handle. *)
type output
+val setup :
+ ?limit:int
+ -> ?on_resize:(unit -> unit)
+ -> container:[`Div] Tyxml_js.Html5.elt
+ -> unit
+ -> output
(** Use a given div as an output console.
Gives it the class [toplevel-output].
@@ -18,28 +24,24 @@ type output
A callback, called every time the contents of the console is updated.
@param limit
The maximum number of blocks displayed. *)
-val setup :
- ?limit: int ->
- ?on_resize:(unit -> unit) ->
- container: [ `Div ] Tyxml_js.Html5.elt ->
- unit -> output
-(** Empty the console. *)
val clear : output -> unit
+(** Empty the console. *)
+val scroll : output -> unit
(** Make the last element of the console visible on the screen.
This works if the div itself is scrollable (CSS attribute [overflow-y]).
If not, the [on_resize] parameter of {!setup} can be used to scroll
a parent scrollable area.
The console is automatically scrolled after each output.*)
-val scroll : output -> unit
-(** Make the current elements of the console greyed and unselectable. *)
val oldify : output -> unit
+(** Make the current elements of the console greyed and unselectable. *)
(** Represents a sequence of unseparated output blocks. *)
type phrase
+val phrase : unit -> phrase
(** Forges a new phrase identifier.
Phrases are subsequences of outputs in the console, separated by
@@ -61,43 +63,43 @@ type phrase
is specified, it is considered only if it is the last one in the
console. Otherwise, it is appended to the console, as if no phrase
was specified. *)
-val phrase : unit -> phrase
+val output_stdout : ?phrase:phrase -> output -> string -> unit
(** Output verbatim text to the console. Successive outputs are
grouped, mixing {!output_stdout} and {!output_stderr}. The output
block is a direct child of the console, a [pre] element with class
[toplevel-output]. The text is wrapped in a [span] element with
class [stdout]. *)
-val output_stdout : ?phrase: phrase -> output -> string -> unit
+val output_stderr : ?phrase:phrase -> output -> string -> unit
(** Output verbatim error text. See {!output_stdout}. The text is
wrapped in a [span] element with class [stdout]. *)
-val output_stderr : ?phrase: phrase -> output -> string -> unit
+val output_html : ?phrase:phrase -> output -> string -> unit
(** Output HTML in a [div] element with class [toplevel-html-block]. *)
-val output_html : ?phrase: phrase -> output -> string -> unit
-val output_svg : ?phrase: phrase -> output -> string -> unit
+val output_svg : ?phrase:phrase -> output -> string -> unit
+val output_code : ?phrase:phrase -> output -> string -> unit
(** Output ocaml code in a [pre] element with class [toplevel-code].
Code tokens are wrapped in [span] elements with classes as
documented in {!Ocaml_mode.token_type}. An intermediate level of
[span] elements with classes [toplevel-hilighted-error] and
[toplevel-hilighted-warning] are used for errors and warnings. A
[span] with class [ref] is used for location labels. *)
-val output_code : ?phrase: phrase -> output -> string -> unit
+val output_answer : ?phrase:phrase -> output -> string -> unit
(** Output an ocaml toplevel answer in a [pre] element with class
[toplevel-answer]. *)
-val output_answer : ?phrase: phrase -> output -> string -> unit
+val output_error : ?phrase:phrase -> output -> Toploop_results.error -> unit
(** Output an error in a [pre] element with class [toplevel-error].
A [span] with class [ref] is used for location labels. *)
-val output_error : ?phrase: phrase -> output -> Toploop_results.error -> unit
+val output_warning :
+ ?phrase:phrase -> output -> Toploop_results.warning -> unit
(** Output a warning in a [pre] element with class [toplevel-warning].
A [span] with class [ref] is used for location labels. *)
-val output_warning : ?phrase: phrase -> output -> Toploop_results.warning -> unit
+val format_ocaml_code : string -> [> `Span | `PCDATA] Tyxml_js.Html5.elt list
(** Format OCaml code in the style of {!output_code}. *)
-val format_ocaml_code : string -> [> `Span | `PCDATA ] Tyxml_js.Html5.elt list
diff --git a/src/toplevel/learnocaml_toplevel_pp.ml b/src/toplevel/learnocaml_toplevel_pp.ml
index 8ee1bd6af..0eeb8fe35 100644
--- a/src/toplevel/learnocaml_toplevel_pp.ml
+++ b/src/toplevel/learnocaml_toplevel_pp.ml
@@ -6,7 +6,6 @@
* Learn-OCaml is distributed under the terms of the MIT license. See the
* included LICENSE file for details. *)
-
(** [construct_image img] renders an image as a svg code string. This code is
used to display the image in the toplevel, using the toplevel directive
"#install_printer".
@@ -26,8 +25,5 @@ let construct_image i =
(* Prelude for pretty printers *)
let prelude_pp = "let pp_svg _ i = construct_image i |> print_svg;;"
-
(* List of pretty printers to deploy in toplevel *)
-let pp_list = [
- "pp_svg";
-]
+let pp_list = ["pp_svg"]
diff --git a/src/toplevel/learnocaml_toplevel_worker_caller.ml b/src/toplevel/learnocaml_toplevel_worker_caller.ml
index a39e7d82a..d0dc3b01d 100644
--- a/src/toplevel/learnocaml_toplevel_worker_caller.ml
+++ b/src/toplevel/learnocaml_toplevel_worker_caller.ml
@@ -10,64 +10,68 @@ open Js_of_ocaml
let debug = ref false
-let (>>=) = Lwt.bind
-let (>>?) o f =
+let ( >>= ) = Lwt.bind
+
+let ( >>? ) o f =
let open Toploop_results in
- o >>= function
+ o
+ >>= function
| Error (err, w) -> Lwt.return (Error (err, w))
- | Ok (x, w) ->
- f x >>= function
+ | Ok (x, w) -> (
+ f x
+ >>= function
| Error (err, w') -> Lwt.return (Error (err, w @ w'))
- | Ok (x, w') -> Lwt.return (Ok (x, w @ w'))
+ | Ok (x, w') -> Lwt.return (Ok (x, w @ w')) )
let return_success e = Lwt.return (Toploop_results.Ok (e, []))
+
let return_unit_success = return_success ()
let wrap pp =
let buf = Buffer.create 503 in
let flush () =
let s = Buffer.contents buf in
- if s <> "" then begin
- Buffer.reset buf;
- pp s
- end in
+ if s <> "" then ( Buffer.reset buf; pp s )
+ in
Format.make_formatter (Buffer.add_substring buf) flush
-module IntMap = Map.Make(struct
- type t = int
- let compare (x:int) (y:int) = Pervasives.compare x y
- end)
-let map_option f o = match o with | None -> None | Some o -> Some (f o)
-let iter_option f o = match o with | None -> () | Some o -> f o
+module IntMap = Map.Make (struct
+ type t = int
+
+ let compare (x : int) (y : int) = Pervasives.compare x y
+end)
+let map_option f o = match o with None -> None | Some o -> Some (f o)
+
+let iter_option f o = match o with None -> () | Some o -> f o
open Worker
open Learnocaml_toplevel_worker_messages
type u =
- U : 'a msg_ty * 'a Toploop_results.toplevel_result Lwt.u
- * 'a Toploop_results.toplevel_result Lwt.t -> u
-
-type t = {
- js_file: string;
- mutable worker: (Js.js_string Js.t, Js.js_string Js.t) worker Js.t;
- mutable wakeners: u IntMap.t;
- mutable counter: int;
- mutable fds: (string -> unit) IntMap.t;
- mutable fd_counter: int;
- mutable reset_worker: t -> unit Lwt.t;
- mutable after_init: t -> unit Lwt.t;
- pp_stdout: string -> unit;
- pp_stderr: string -> unit;
-}
+ | U :
+ 'a msg_ty
+ * 'a Toploop_results.toplevel_result Lwt.u
+ * 'a Toploop_results.toplevel_result Lwt.t
+ -> u
+type t =
+ { js_file : string
+ ; mutable worker : (Js.js_string Js.t, Js.js_string Js.t) worker Js.t
+ ; mutable wakeners : u IntMap.t
+ ; mutable counter : int
+ ; mutable fds : (string -> unit) IntMap.t
+ ; mutable fd_counter : int
+ ; mutable reset_worker : t -> unit Lwt.t
+ ; mutable after_init : t -> unit Lwt.t
+ ; pp_stdout : string -> unit
+ ; pp_stderr : string -> unit }
exception Not_equal
-let check_equal
- : type t1 t2.
- t1 msg_ty ->
- t2 msg_ty -> (t1, t2) eq = fun ty1 ty2 ->
- match ty1, ty2 with
+
+let check_equal : type t1 t2. t1 msg_ty -> t2 msg_ty -> (t1, t2) eq =
+ fun ty1 ty2 ->
+ match (ty1, ty2) with
| Unit, Unit -> Eq
| Bool, Bool -> Eq
| Int, Int -> Eq
@@ -79,58 +83,54 @@ let check_equal
let onmessage worker (ev : _ Worker.messageEvent Js.t) =
match Json.unsafe_input ev##.data with
- | Write (fd, s) -> begin
+ | Write (fd, s) -> (
if !debug then Js_utils.debug "Host: Write %d %S" fd s;
try
- IntMap.find fd worker.fds s ;
+ IntMap.find fd worker.fds s;
Js._false
- with
- | Not_found ->
- Firebug.console##(warn
- (Js.string (Printf.sprintf "Missing channels (%d)" fd)));
- Js._false
- end
- | ReturnSuccess (id, ty_v, v, w) -> begin
+ with Not_found ->
+ Firebug.console
+ ## (warn (Js.string (Printf.sprintf "Missing channels (%d)" fd)));
+ Js._false )
+ | ReturnSuccess (id, ty_v, v, w) -> (
if !debug then Js_utils.debug "Host: ReturnOk %d" id;
try
- let U (ty_u, u, _) = IntMap.find id worker.wakeners in
+ let (U (ty_u, u, _)) = IntMap.find id worker.wakeners in
let Eq = check_equal ty_u ty_v in
worker.wakeners <- IntMap.remove id worker.wakeners;
Lwt.wakeup u (Toploop_results.Ok (v, w));
Js._false
with
| Not_found ->
- Firebug.console##(warn
- (Js.string (Printf.sprintf "Missing wakeners (%d)" id)));
+ Firebug.console
+ ## (warn (Js.string (Printf.sprintf "Missing wakeners (%d)" id)));
Js._false
| Not_equal ->
- Firebug.console##(warn
- (Js.string (Printf.sprintf "Unexpected wakeners (%d)" id)));
- Js._false
- end
- | ReturnError (id, e, w) -> begin
+ Firebug.console
+ ## (warn (Js.string (Printf.sprintf "Unexpected wakeners (%d)" id)));
+ Js._false )
+ | ReturnError (id, e, w) -> (
if !debug then Js_utils.debug "Host: Error %d" worker.counter;
try
- let U (_, u, _) = IntMap.find id worker.wakeners in
+ let (U (_, u, _)) = IntMap.find id worker.wakeners in
worker.wakeners <- IntMap.remove id worker.wakeners;
Lwt.wakeup u (Toploop_results.Error (e, w));
Js._false
with Not_found ->
- Firebug.console##(warn
- (Js.string (Printf.sprintf "Missing wakeners (%d)" id)));
- Js._false
- end
+ Firebug.console
+ ## (warn (Js.string (Printf.sprintf "Missing wakeners (%d)" id)));
+ Js._false )
let terminate worker =
- (worker.worker)##terminate ;
+ (worker.worker)##terminate;
IntMap.iter
(fun id (U (_, _, t)) ->
- worker.wakeners <- IntMap.remove id worker.wakeners;
- Lwt.cancel t)
+ worker.wakeners <- IntMap.remove id worker.wakeners;
+ Lwt.cancel t )
worker.wakeners
-
-let never_ending = (* and not cancellable. *)
+let never_ending =
+ (* and not cancellable. *)
fst (Lwt.wait ())
let ty_of_host_msg : type t. t host_msg -> t msg_ty = function
@@ -148,68 +148,66 @@ let ty_of_host_msg : type t. t host_msg -> t msg_ty = function
[onmessage] by calling [Lwt.wakeup]. They should never end with
an exception, unless canceled. When canceled, the worker is
killed and a new one is spawned. *)
-let rec post : type a. t -> a host_msg -> a Toploop_results.toplevel_result Lwt.t =
- fun worker msg ->
- let msg_id = worker.counter in
- let msg_ty = ty_of_host_msg msg in
- if !debug then Js_utils.debug "Host: queuing %d" msg_id;
- let (t, u) = Lwt.task () in
- Lwt.on_cancel t
- (fun () -> Lwt.async (fun () -> worker.reset_worker worker));
- worker.wakeners <- IntMap.add msg_id (U (msg_ty, u, t)) worker.wakeners;
- worker.counter <- msg_id + 1;
- worker.worker##(postMessage (Json.output (msg_id, msg)));
- t
+let rec post : type a.
+ t -> a host_msg -> a Toploop_results.toplevel_result Lwt.t =
+ fun worker msg ->
+ let msg_id = worker.counter in
+ let msg_ty = ty_of_host_msg msg in
+ if !debug then Js_utils.debug "Host: queuing %d" msg_id;
+ let t, u = Lwt.task () in
+ Lwt.on_cancel t (fun () -> Lwt.async (fun () -> worker.reset_worker worker));
+ worker.wakeners <- IntMap.add msg_id (U (msg_ty, u, t)) worker.wakeners;
+ worker.counter <- msg_id + 1;
+ (worker.worker) ## (postMessage (Json.output (msg_id, msg)));
+ t
and do_reset_worker () =
let running = ref true in
fun worker ->
- if !running then begin
+ if !running then (
if !debug then Js_utils.debug "Host: do_reset_worker";
running := false;
terminate worker;
IntMap.iter
(* GRGR: Peut-on 'cancel' directement le Lwt.u ? *)
- (fun _ (U (_, _, t)) -> Lwt.cancel t)
+ (fun _ (U (_, _, t)) -> Lwt.cancel t )
worker.wakeners;
- worker.worker <- Worker.create (worker.js_file);
- worker.fds <-
- IntMap.empty |>
- IntMap.add 0 (IntMap.find 0 worker.fds) |>
- IntMap.add 1 (IntMap.find 1 worker.fds);
+ worker.worker <- Worker.create worker.js_file;
+ worker.fds
+ <- IntMap.empty
+ |> IntMap.add 0 (IntMap.find 0 worker.fds)
+ |> IntMap.add 1 (IntMap.find 1 worker.fds);
worker.fd_counter <- 2;
worker.wakeners <- IntMap.empty;
worker.counter <- 0;
worker.reset_worker <- do_reset_worker ();
- (Obj.magic worker.worker)##.onmessage :=
- Js.wrap_callback (onmessage worker);
- post worker @@ Init >>= fun _ ->
- worker.after_init worker >>= fun _ ->
- Lwt.return_unit
- end else
- Lwt.return_unit
-
-let create
- ?(js_file = "/js/learnocaml-toplevel-worker.js")
+ (Obj.magic worker.worker)##.onmessage
+ := Js.wrap_callback (onmessage worker);
+ post worker @@ Init
+ >>= fun _ -> worker.after_init worker >>= fun _ -> Lwt.return_unit )
+ else Lwt.return_unit
+
+let create ?(js_file = "/js/learnocaml-toplevel-worker.js")
?(after_init = fun _ -> Lwt.return_unit)
- ?(pp_stdout = (fun text -> Firebug.console##(log (Js.string text))))
- ?(pp_stderr = (fun text -> Firebug.console##(log (Js.string text))))
- () =
+ ?(pp_stdout = fun text -> Firebug.console ## (log (Js.string text)))
+ ?(pp_stderr = fun text -> Firebug.console ## (log (Js.string text))) () =
let worker = Worker.create js_file in
- let fds =
- IntMap.empty |>
- IntMap.add 0 pp_stdout |>
- IntMap.add 1 pp_stderr in
+ let fds = IntMap.empty |> IntMap.add 0 pp_stdout |> IntMap.add 1 pp_stderr in
let worker =
- { worker; js_file;
- wakeners = IntMap.empty; counter = 0; fds; fd_counter = 2;
- reset_worker = do_reset_worker ();
- after_init; pp_stdout; pp_stderr;
- } in
+ { worker
+ ; js_file
+ ; wakeners = IntMap.empty
+ ; counter = 0
+ ; fds
+ ; fd_counter = 2
+ ; reset_worker = do_reset_worker ()
+ ; after_init
+ ; pp_stdout
+ ; pp_stderr }
+ in
(Obj.magic worker.worker)##.onmessage := Js.wrap_callback (onmessage worker);
- post worker @@ Init >>= fun _ ->
- worker.after_init worker >>= fun () ->
- Lwt.return worker
+ post worker @@ Init
+ >>= fun _ -> worker.after_init worker >>= fun () -> Lwt.return worker
let create_fd worker pp =
worker.fds <- IntMap.add worker.fd_counter pp worker.fds;
@@ -217,20 +215,18 @@ let create_fd worker pp =
worker.fd_counter <- fd + 1;
fd
-let close_fd worker fd =
- worker.fds <- IntMap.remove fd worker.fds
+let close_fd worker fd = worker.fds <- IntMap.remove fd worker.fds
let reset worker ?(timeout = fun () -> never_ending) () =
if !debug then Js_utils.debug "Host: reset";
let timeout = timeout () in
- Lwt.choose [
- ( post worker Reset >>= fun res -> Lwt.return (`Reset res) );
- ( timeout >>= fun () -> Lwt.return `Timeout );
- ] >>= function
- | `Reset Toploop_results.Ok ((), _) ->
- Lwt.cancel timeout;
- worker.after_init worker
- | `Reset Toploop_results.Error (err, _) ->
+ Lwt.choose
+ [ (post worker Reset >>= fun res -> Lwt.return (`Reset res))
+ ; (timeout >>= fun () -> Lwt.return `Timeout) ]
+ >>= function
+ | `Reset (Toploop_results.Ok ((), _)) ->
+ Lwt.cancel timeout; worker.after_init worker
+ | `Reset (Toploop_results.Error (err, _)) ->
Lwt.cancel timeout;
worker.pp_stderr err.Toploop_results.msg;
worker.reset_worker worker
@@ -238,40 +234,33 @@ let reset worker ?(timeout = fun () -> never_ending) () =
(* Not canceling the Reset thread, but manually resetting. *)
worker.reset_worker worker
-let check worker code =
- post worker @@ Check code
+let check worker code = post worker @@ Check code
-let set_checking_environment worker =
- post worker @@ Set_checking_environment
+let set_checking_environment worker = post worker @@ Set_checking_environment
let execute worker ?pp_code ~pp_answer ~print_outcome code =
let pp_code = map_option (create_fd worker) pp_code in
let pp_answer = create_fd worker pp_answer in
- post worker @@
- Execute (pp_code, print_outcome, pp_answer, code) >>= fun result ->
+ post worker @@ Execute (pp_code, print_outcome, pp_answer, code)
+ >>= fun result ->
iter_option (close_fd worker) pp_code;
close_fd worker pp_answer;
Lwt.return result
let use_string worker ?filename ~pp_answer ~print_outcome code =
let pp_answer = create_fd worker pp_answer in
- post worker @@
- Use_string (filename, print_outcome, pp_answer, code) >>= fun result ->
- close_fd worker pp_answer;
- Lwt.return result
+ post worker @@ Use_string (filename, print_outcome, pp_answer, code)
+ >>= fun result -> close_fd worker pp_answer; Lwt.return result
-let use_mod_string worker
- ~pp_answer ~print_outcome ~modname ?sig_code impl_code =
+let use_mod_string worker ~pp_answer ~print_outcome ~modname ?sig_code
+ impl_code =
let pp_answer = create_fd worker pp_answer in
- post worker @@
- Use_mod_string (pp_answer, print_outcome, modname, sig_code, impl_code)
- >>= fun result ->
- close_fd worker pp_answer;
- Lwt.return result
+ post worker
+ @@ Use_mod_string (pp_answer, print_outcome, modname, sig_code, impl_code)
+ >>= fun result -> close_fd worker pp_answer; Lwt.return result
let set_after_init w after_init = w.after_init <- after_init
let register_callback worker name callback =
let fd = create_fd worker callback in
- post worker (Register_callback (name, fd)) >>? fun () ->
- return_unit_success
+ post worker (Register_callback (name, fd)) >>? fun () -> return_unit_success
diff --git a/src/toplevel/learnocaml_toplevel_worker_caller.mli b/src/toplevel/learnocaml_toplevel_worker_caller.mli
index 6a4f24692..24b90dd51 100644
--- a/src/toplevel/learnocaml_toplevel_worker_caller.mli
+++ b/src/toplevel/learnocaml_toplevel_worker_caller.mli
@@ -18,7 +18,13 @@ open Toploop_results
(** An abstract type representing a toplevel instance. *)
type t
-
+val create :
+ ?js_file:string
+ -> ?after_init:(t -> unit Lwt.t)
+ -> ?pp_stdout:(string -> unit)
+ -> ?pp_stderr:(string -> unit)
+ -> unit
+ -> t Lwt.t
(** Create a toplevel instance.
@param after_init a function that will be called whenever the
@@ -33,23 +39,22 @@ type t
@param js_file the web worker [.js] file.
(default: ["/js/learnocaml-toplevel-worker.js"]). *)
-val create:
- ?js_file: string ->
- ?after_init:(t -> unit Lwt.t) ->
- ?pp_stdout:(string -> unit) ->
- ?pp_stderr:(string -> unit) ->
- unit -> t Lwt.t
-
+val check : t -> string -> unit toplevel_result Lwt.t
(** Parse and typecheck a given source code
@return [Success ()] in case of success and [Error err]
where [err] contains the error message otherwise.
*)
-val check: t -> string -> unit toplevel_result Lwt.t
-
+val execute :
+ t
+ -> ?pp_code:(string -> unit)
+ -> pp_answer:(string -> unit)
+ -> print_outcome:bool
+ -> string
+ -> bool toplevel_result Lwt.t
(** Execute a given source code. The evaluation stops after the first
toplevel phrase (as terminated by ";;") that fails to compile or
for which the evaluation raises an uncaught exception.
@@ -71,17 +76,17 @@ val check: t -> string -> unit toplevel_result Lwt.t
exception, and [Success false] otherwise.
*)
-val execute:
- t ->
- ?pp_code:(string -> unit) ->
- pp_answer:(string -> unit) ->
- print_outcome:bool ->
- string -> bool toplevel_result Lwt.t
+val set_checking_environment : t -> unit toplevel_result Lwt.t
(** Freezes the environment for future calls to {!check}. *)
-val set_checking_environment:
- t -> unit toplevel_result Lwt.t
+val use_string :
+ t
+ -> ?filename:string
+ -> pp_answer:(string -> unit)
+ -> print_outcome:bool
+ -> string
+ -> bool toplevel_result Lwt.t
(** Execute a given source code. The code is parsed and
typechecked all at once before to start the evaluation.
@@ -92,14 +97,15 @@ val set_checking_environment:
@return as {!val:execute}.
*)
-val use_string:
- t ->
- ?filename: string ->
- pp_answer:(string -> unit) ->
- print_outcome:bool ->
- string -> bool toplevel_result Lwt.t
-
+val use_mod_string :
+ t
+ -> pp_answer:(string -> unit)
+ -> print_outcome:bool
+ -> modname:string
+ -> ?sig_code:string
+ -> string
+ -> bool toplevel_result Lwt.t
(** Wrap a given source code into a module and bind it with a given name.
@param pp_answer see {!val:execute}.
@@ -114,29 +120,23 @@ val use_string:
@return as {!val:execute}.
*)
-val use_mod_string:
- t ->
- pp_answer:(string -> unit) ->
- print_outcome:bool ->
- modname:string ->
- ?sig_code:string ->
- string -> bool toplevel_result Lwt.t
+val register_callback :
+ t -> string -> (string -> unit) -> unit toplevel_result Lwt.t
(** Insert a callback in the toplevel environment. *)
-val register_callback : t -> string -> (string -> unit) -> unit toplevel_result Lwt.t
+val reset : t -> ?timeout:(unit -> unit Lwt.t) -> unit -> unit Lwt.t
(** Reset the current toplevel environment to the initial
environment. *)
-val reset: t -> ?timeout:(unit -> unit Lwt.t) -> unit -> unit Lwt.t
-
+val terminate : t -> unit
(** Terminate the toplevel, i.e. destroy the Web Worker. It does
nothing if the toplevel as been created with [async=false]. *)
-val terminate: t -> unit
-val set_after_init: t -> (t -> unit Lwt.t) -> unit
+val set_after_init : t -> (t -> unit Lwt.t) -> unit
(**/**)
-val debug: bool ref
-val wrap: (string -> unit) -> Format.formatter
+val debug : bool ref
+
+val wrap : (string -> unit) -> Format.formatter
diff --git a/src/toplevel/learnocaml_toplevel_worker_main.ml b/src/toplevel/learnocaml_toplevel_worker_main.ml
index 03d0eeacc..3d8fc4671 100644
--- a/src/toplevel/learnocaml_toplevel_worker_main.ml
+++ b/src/toplevel/learnocaml_toplevel_worker_main.ml
@@ -11,7 +11,7 @@ open Learnocaml_toplevel_worker_messages
let debug = ref false
-let (>>=) = Lwt.bind
+let ( >>= ) = Lwt.bind
let is_success = function
| Toploop_ext.Ok _ -> true
@@ -22,21 +22,23 @@ type 'a return =
| ReturnError of Toploop_ext.error * Toploop_ext.warning list
let return_success v w = Lwt.return (ReturnSuccess (v, w))
+
let return_unit_success = return_success () []
+
let return_error e w = Lwt.return (ReturnError (e, w))
let unwrap_result =
let open Toploop_ext in
function
- | Ok (b, w) -> return_success b w
- | Error (err, w) -> return_error err w
+ | Ok (b, w) -> return_success b w | Error (err, w) -> return_error err w
(** File descriptors *)
-module IntMap = Map.Make(struct
- type t = int
- let compare (x:int) (y:int) = Pervasives.compare x y
- end)
+module IntMap = Map.Make (struct
+ type t = int
+
+ let compare (x : int) (y : int) = Pervasives.compare x y
+end)
(* Limit the frequency of sent messages to one per ms, using an active
loop (yuck) because, well, there is no other concurrency primitive
@@ -55,77 +57,74 @@ module IntMap = Map.Make(struct
still need some kind of active waiting to limit throughput. All in
all this spinwait is not that ugly. *)
let last = ref 0.
+
let rec wait () =
let now = Sys.time () (* let's hope this yields a bit *) in
- if now -. !last > 0.001 then
- last := now
- else wait ()
+ if now -. !last > 0.001 then last := now else wait ()
-let post_message (m: toploop_msg) =
- wait () ;
+let post_message (m : toploop_msg) =
+ wait ();
Worker.post_message (Json.output m)
-let (wrap_fd, close_fd, clear_fds) =
+let wrap_fd, close_fd, clear_fds =
let fds = ref IntMap.empty in
let wrap_fd fd =
- try IntMap.find fd !fds
- with Not_found ->
+ try IntMap.find fd !fds with Not_found ->
let buf = Buffer.create 503 in
let flush () =
let s = Buffer.contents buf in
- if s <> "" then begin
+ if s <> "" then (
Buffer.reset buf;
if !debug then Js_utils.debug "Worker: <- Write %d %S" fd s;
- post_message (Write (fd, s))
- end in
+ post_message (Write (fd, s)) )
+ in
let ppf = Format.make_formatter (Buffer.add_substring buf) flush in
fds := IntMap.add fd ppf !fds;
- ppf in
+ ppf
+ in
let close_fd fd =
- if IntMap.mem fd !fds then (Format.pp_print_flush (IntMap.find fd !fds) ());
- fds := IntMap.remove fd !fds in
+ if IntMap.mem fd !fds then Format.pp_print_flush (IntMap.find fd !fds) ();
+ fds := IntMap.remove fd !fds
+ in
let clear_fds () =
fds :=
IntMap.fold
(fun id ppf fds ->
- Format.pp_print_flush ppf ();
- if id = 0 || id = 1 then
- IntMap.add id ppf fds
- else
- fds)
- !fds
- IntMap.empty in
+ Format.pp_print_flush ppf ();
+ if id = 0 || id = 1 then IntMap.add id ppf fds else fds )
+ !fds IntMap.empty
+ in
(wrap_fd, close_fd, clear_fds)
let stdout_ppf = wrap_fd 0
+
let stderr_ppf = wrap_fd 1
let () =
- Sys_js.set_channel_flusher stdout
- (fun s ->
- Format.pp_print_string stdout_ppf s;
- Format.pp_print_flush stdout_ppf ());
- Sys_js.set_channel_flusher stderr
- (fun s ->
- Format.pp_print_string stderr_ppf s;
- Format.pp_print_flush stderr_ppf ())
+ Sys_js.set_channel_flusher stdout (fun s ->
+ Format.pp_print_string stdout_ppf s;
+ Format.pp_print_flush stdout_ppf () );
+ Sys_js.set_channel_flusher stderr (fun s ->
+ Format.pp_print_string stderr_ppf s;
+ Format.pp_print_flush stderr_ppf () )
let make_answer_ppf fd_answer =
let orig_print_string, orig_flush =
- Format.pp_get_formatter_output_functions (wrap_fd fd_answer) () in
+ Format.pp_get_formatter_output_functions (wrap_fd fd_answer) ()
+ in
let check_first_call =
let first_call = ref true in
fun () ->
- if !first_call then begin
- flush stdout ;
- flush stderr ;
- Format.(pp_print_flush std_formatter ()) ;
- Format.(pp_print_flush err_formatter ()) ;
- first_call := false ;
- end in
+ if !first_call then (
+ flush stdout;
+ flush stderr;
+ Format.(pp_print_flush std_formatter ());
+ Format.(pp_print_flush err_formatter ());
+ first_call := false )
+ in
Format.make_formatter
- (fun str -> check_first_call () ; orig_print_string str)
- (fun () -> check_first_call () ; orig_flush ())
+ (fun str -> check_first_call (); orig_print_string str)
+ (fun () -> check_first_call (); orig_flush ())
(** Code compilation and execution *)
@@ -133,17 +132,17 @@ let make_answer_ppf fd_answer =
(** Message dispatcher *)
-let map_option f o = match o with | None -> None | Some o -> Some (f o)
-let iter_option f o = match o with | None -> () | Some o -> f o
+let map_option f o = match o with None -> None | Some o -> Some (f o)
+
+let iter_option f o = match o with None -> () | Some o -> f o
let checking_environment = ref !Toploop.toplevel_env
let handler : type a. a host_msg -> a return Lwt.t = function
| Set_checking_environment ->
- checking_environment := !Toploop.toplevel_env ;
- return_unit_success
- | Init ->
+ checking_environment := !Toploop.toplevel_env;
return_unit_success
+ | Init -> return_unit_success
| Reset ->
if !debug then Js_utils.debug "Worker: -> Reset";
clear_fds ();
@@ -154,16 +153,20 @@ let handler : type a. a host_msg -> a return Lwt.t = function
let ppf_code = map_option wrap_fd fd_code in
let ppf_answer = make_answer_ppf fd_answer in
if !debug then Js_utils.debug "Worker: -> Execute (%S)" code;
- let result = Toploop_ext.execute ?ppf_code ~print_outcome ~ppf_answer code in
- if !debug then Js_utils.debug "Worker: <- Execute (%B)" (is_success result);
+ let result =
+ Toploop_ext.execute ?ppf_code ~print_outcome ~ppf_answer code
+ in
+ if !debug then
+ Js_utils.debug "Worker: <- Execute (%B)" (is_success result);
iter_option close_fd fd_code;
close_fd fd_answer;
unwrap_result result
| Use_string (filename, print_outcome, fd_answer, code) ->
let ppf_answer = make_answer_ppf fd_answer in
- if !debug then
- Js_utils.debug "Worker: -> Use_string (%S)" code;
- let result = Toploop_ext.use_string ?filename ~print_outcome ~ppf_answer code in
+ if !debug then Js_utils.debug "Worker: -> Use_string (%S)" code;
+ let result =
+ Toploop_ext.use_string ?filename ~print_outcome ~ppf_answer code
+ in
if !debug then
Js_utils.debug "Worker: <- Use_string (%B)" (is_success result);
close_fd fd_answer;
@@ -171,13 +174,14 @@ let handler : type a. a host_msg -> a return Lwt.t = function
| Use_mod_string (fd_answer, print_outcome, modname, sig_code, impl_code) ->
let ppf_answer = make_answer_ppf fd_answer in
if !debug then
- Js_utils.debug
- "Worker: -> Use_mod_string %s (%S)" modname impl_code;
- let result = Toploop_ext.use_mod_string
- ~ppf_answer ~print_outcome ~modname ?sig_code impl_code in
+ Js_utils.debug "Worker: -> Use_mod_string %s (%S)" modname impl_code;
+ let result =
+ Toploop_ext.use_mod_string ~ppf_answer ~print_outcome ~modname
+ ?sig_code impl_code
+ in
if !debug then
- Js_utils.debug
- "Worker: <- Use_mod_string %s (%B)" modname (is_success result);
+ Js_utils.debug "Worker: <- Use_mod_string %s (%B)" modname
+ (is_success result);
close_fd fd_answer;
unwrap_result result
| Set_debug b ->
@@ -185,33 +189,40 @@ let handler : type a. a host_msg -> a return Lwt.t = function
return_unit_success
| Register_callback (name, fd) ->
let callback text =
- post_message (Write (fd, text)) ; () in
+ post_message (Write (fd, text));
+ ()
+ in
let ty =
let ast =
let arg =
- Ast_helper.(Typ.constr (Location.mknoloc (Longident.Lident "string")) []) in
+ Ast_helper.(
+ Typ.constr (Location.mknoloc (Longident.Lident "string")) [])
+ in
let ret =
- Ast_helper.(Typ.constr (Location.mknoloc (Longident.Lident "unit")) []) in
- { Parsetree.ptyp_desc = Parsetree.Ptyp_arrow (Asttypes.Nolabel, arg, ret) ;
- ptyp_loc = Location.none ;
- ptyp_attributes = [] } in
- Typetexp.transl_type_scheme !Toploop.toplevel_env ast in
+ Ast_helper.(
+ Typ.constr (Location.mknoloc (Longident.Lident "unit")) [])
+ in
+ { Parsetree.ptyp_desc =
+ Parsetree.Ptyp_arrow (Asttypes.Nolabel, arg, ret)
+ ; ptyp_loc = Location.none
+ ; ptyp_attributes = [] }
+ in
+ Typetexp.transl_type_scheme !Toploop.toplevel_env ast
+ in
Toploop.toplevel_env :=
- Env.add_value
- (Ident.create name)
- { Types.
- val_type = ty.Typedtree.ctyp_type;
- val_kind = Types.Val_reg;
- val_attributes = [];
- val_loc = Location.none }
- !Toploop.toplevel_env ;
- Toploop.setvalue name (Obj.repr callback) ;
+ Env.add_value (Ident.create name)
+ { Types.val_type = ty.Typedtree.ctyp_type
+ ; val_kind = Types.Val_reg
+ ; val_attributes = []
+ ; val_loc = Location.none }
+ !Toploop.toplevel_env;
+ Toploop.setvalue name (Obj.repr callback);
return_unit_success
| Check code ->
let saved = !Toploop.toplevel_env in
- Toploop.toplevel_env := !checking_environment ;
+ Toploop.toplevel_env := !checking_environment;
let result = Toploop_ext.check code in
- Toploop.toplevel_env := saved ;
+ Toploop.toplevel_env := saved;
unwrap_result result
let ty_of_host_msg : type t. t host_msg -> t msg_ty = function
@@ -227,29 +238,30 @@ let ty_of_host_msg : type t. t host_msg -> t msg_ty = function
let () =
let handler (type t) data =
- let (id, data) : (int * t host_msg) = Json.unsafe_input data in
+ let (id, data) : int * t host_msg = Json.unsafe_input data in
let ty = ty_of_host_msg data in
- handler data >>= function
+ handler data
+ >>= function
| ReturnSuccess (v, w) ->
post_message (ReturnSuccess (id, ty, v, w));
Lwt.return_unit
| ReturnError (res, w) ->
- if !debug then
- Js_utils.debug "Worker: <- ReturnError %d" id;
+ if !debug then Js_utils.debug "Worker: <- ReturnError %d" id;
post_message (ReturnError (id, res, w));
Lwt.return_unit
in
let path = "/worker_cmis" in
- Sys_js.mount ~path
- (fun ~prefix:_ ~path ->
- match OCamlRes.Res.find (OCamlRes.Path.of_string path) Embedded_cmis.root with
- | cmi ->
- Js.Unsafe.set cmi (Js.string "t") 9 ; (* XXX hack *)
- Some cmi
- | exception Not_found -> None) ;
- Config.load_path := [ path ] ;
+ Sys_js.mount ~path (fun ~prefix:_ ~path ->
+ match
+ OCamlRes.Res.find (OCamlRes.Path.of_string path) Embedded_cmis.root
+ with
+ | cmi ->
+ Js.Unsafe.set cmi (Js.string "t") 9;
+ (* XXX hack *)
+ Some cmi
+ | exception Not_found -> None );
+ Config.load_path := [path];
Toploop_jsoo.initialize ();
- Hashtbl.add Toploop.directive_table
- "debug_worker"
+ Hashtbl.add Toploop.directive_table "debug_worker"
(Toploop.Directive_bool (fun b -> debug := b));
Worker.set_onmessage (fun s -> Lwt.async (fun () -> handler s))
diff --git a/src/toplevel/learnocaml_toplevel_worker_main.mli b/src/toplevel/learnocaml_toplevel_worker_main.mli
index f53cf8310..a753a5d70 100644
--- a/src/toplevel/learnocaml_toplevel_worker_main.mli
+++ b/src/toplevel/learnocaml_toplevel_worker_main.mli
@@ -7,5 +7,4 @@
* included LICENSE file for details. *)
(** Events loop for the toplevel's Web Worker. *)
-
(* Empty *)
diff --git a/src/toplevel/learnocaml_toplevel_worker_messages.mli b/src/toplevel/learnocaml_toplevel_worker_messages.mli
index 1906d2520..a748a5c73 100644
--- a/src/toplevel/learnocaml_toplevel_worker_messages.mli
+++ b/src/toplevel/learnocaml_toplevel_worker_messages.mli
@@ -15,7 +15,9 @@ type _ host_msg =
| Reset : unit host_msg
| Execute : int option * bool * int * string -> bool host_msg
| Use_string : string option * bool * int * string -> bool host_msg
- | Use_mod_string : int * bool * string * string option * string -> bool host_msg
+ | Use_mod_string :
+ int * bool * string * string option * string
+ -> bool host_msg
| Set_debug : bool -> unit host_msg
| Register_callback : string * int -> unit host_msg
| Set_checking_environment : unit host_msg
@@ -30,8 +32,11 @@ type _ msg_ty =
type (_, _) eq = Eq : ('a, 'a) eq
type toploop_msg =
- | Write : int * string -> toploop_msg (* pseudo file descriptor * content *)
+ | Write : int * string -> toploop_msg
+ (* pseudo file descriptor * content *)
| ReturnSuccess :
- int * 'a msg_ty * 'a * Toploop_results.warning list -> toploop_msg
+ int * 'a msg_ty * 'a * Toploop_results.warning list
+ -> toploop_msg
| ReturnError :
- int * Toploop_results.error * Toploop_results.warning list -> toploop_msg
+ int * Toploop_results.error * Toploop_results.warning list
+ -> toploop_msg
diff --git a/src/toploop/toploop_ext.ml b/src/toploop/toploop_ext.ml
index f8c2084ab..006c604e8 100644
--- a/src/toploop/toploop_ext.ml
+++ b/src/toploop/toploop_ext.ml
@@ -12,76 +12,68 @@ type 'a toplevel_result = 'a Toploop_results.toplevel_result =
| Error of error * warning list
and error = Toploop_results.error =
- { msg: string;
- locs: loc list;
- if_highlight: string; }
+ {msg : string; locs : loc list; if_highlight : string}
and warning = error
-and loc = Toploop_results.loc = {
- loc_start: int * int;
- loc_end: int * int;
-}
+and loc = Toploop_results.loc = {loc_start : int * int; loc_end : int * int}
module Ppx = struct
-
let ppx_rewriters = ref []
let () =
Ast_mapper.register_function :=
- (fun _ f -> ppx_rewriters := f :: !ppx_rewriters)
+ fun _ f -> ppx_rewriters := f :: !ppx_rewriters
let preprocess_structure str =
let open Ast_mapper in
List.fold_right
(fun ppx_rewriter str ->
- let mapper = ppx_rewriter [] in
- mapper.structure mapper str)
- !ppx_rewriters
- str
+ let mapper = ppx_rewriter [] in
+ mapper.structure mapper str )
+ !ppx_rewriters str
let preprocess_signature str =
let open Ast_mapper in
List.fold_right
(fun ppx_rewriter str ->
- let mapper = ppx_rewriter [] in
- mapper.signature mapper str)
- !ppx_rewriters
- str
+ let mapper = ppx_rewriter [] in
+ mapper.signature mapper str )
+ !ppx_rewriters str
let preprocess_phrase phrase =
let open Parsetree in
match phrase with
| Ptop_def str -> Ptop_def (preprocess_structure str)
| Ptop_dir _ as x -> x
-
end
let warnings = ref []
let convert_loc loc =
- let _file1,line1,col1 = Location.get_pos_info (loc.Location.loc_start) in
- let _file2,line2,col2 = Location.get_pos_info (loc.Location.loc_end) in
- { loc_start = (line1, col1) ; loc_end = (line2, col2) }
+ let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
+ let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
+ {loc_start = (line1, col1); loc_end = (line2, col2)}
let () =
Location.warning_printer :=
- (fun loc _fmt w ->
- if Warnings.is_active w then begin
- let buf = Buffer.create 503 in
- let ppf = Format.formatter_of_buffer buf in
- Location.print ppf loc;
- Format.fprintf ppf "Warning %a@." Warnings.print w;
- let msg = Buffer.contents buf in
- Buffer.reset buf;
- Format.fprintf ppf "Warning %a@." Warnings.print w;
- let if_highlight = Buffer.contents buf in
- let loc = convert_loc loc in
- warnings := { msg; locs = [loc]; if_highlight } :: !warnings
- end)
-
-let return_success (e: 'a) : 'a toplevel_result = Ok (e, !warnings)
-let return_error e : 'a toplevel_result = Error (e, !warnings)
+ fun loc _fmt w ->
+ if Warnings.is_active w then (
+ let buf = Buffer.create 503 in
+ let ppf = Format.formatter_of_buffer buf in
+ Location.print ppf loc;
+ Format.fprintf ppf "Warning %a@." Warnings.print w;
+ let msg = Buffer.contents buf in
+ Buffer.reset buf;
+ Format.fprintf ppf "Warning %a@." Warnings.print w;
+ let if_highlight = Buffer.contents buf in
+ let loc = convert_loc loc in
+ warnings := {msg; locs = [loc]; if_highlight} :: !warnings )
+
+let return_success (e : 'a) : 'a toplevel_result = Ok (e, !warnings)
+
+let return_error e : 'a toplevel_result = Error (e, !warnings)
+
(* let return_unit_success = return_success () *)
(** Error handling *)
@@ -91,20 +83,23 @@ let rec report_error_rec hg_ppf ppf {Location.loc; msg; sub; if_highlight} =
Location.print ppf loc;
Format.pp_print_string ppf msg;
let hg_ppf =
- if if_highlight <> "" then
- (Format.pp_print_string hg_ppf if_highlight; dummy_ppf)
- else
- (Format.pp_print_string hg_ppf msg; hg_ppf) in
+ if if_highlight <> "" then (
+ Format.pp_print_string hg_ppf if_highlight;
+ dummy_ppf )
+ else (
+ Format.pp_print_string hg_ppf msg;
+ hg_ppf )
+ in
let locs =
- List.concat @@
- List.map
- (fun err ->
- Format.pp_force_newline ppf ();
- Format.pp_open_box ppf 2;
- let locs = report_error_rec hg_ppf ppf err in
- Format.pp_close_box ppf ();
- locs)
- sub in
+ List.concat
+ @@ List.map
+ (fun err ->
+ Format.pp_force_newline ppf ();
+ Format.pp_open_box ppf 2;
+ let locs = report_error_rec hg_ppf ppf err in
+ Format.pp_close_box ppf (); locs )
+ sub
+ in
convert_loc loc :: locs
let report_error err =
@@ -117,16 +112,15 @@ let report_error err =
Format.pp_print_flush hg_ppf ();
let msg = Buffer.contents buf in
let if_highlight = Buffer.contents hg_buf in
- { msg; locs; if_highlight; }
+ {msg; locs; if_highlight}
let error_of_exn exn =
match Location.error_of_exn exn with
| None ->
- let msg = match exn with
- | Failure msg -> msg
- | exn -> Printexc.to_string exn
+ let msg =
+ match exn with Failure msg -> msg | exn -> Printexc.to_string exn
in
- { msg; locs = []; if_highlight = msg }
+ {msg; locs = []; if_highlight = msg}
| Some error -> report_error error
let return_exn exn = return_error (error_of_exn exn)
@@ -137,38 +131,34 @@ let trim_end s =
let ws c = c = ' ' || c = '\t' || c = '\n' in
let len = String.length s in
let stop = ref (len - 1) in
- while !stop > 0 && (ws s.[!stop])
- do decr stop done;
+ while !stop > 0 && ws s.[!stop] do
+ decr stop
+ done;
String.sub s 0 (!stop + 1)
let normalize code =
let content = trim_end code in
let len = String.length content in
- if content = "" then
- content
- else if (len > 2
- && content.[len - 2] = ';'
- && content.[len - 1] = ';') then
+ if content = "" then content
+ else if len > 2 && content.[len - 2] = ';' && content.[len - 1] = ';' then
content ^ "\n"
- else
- content ^ " ;;\n"
+ else content ^ " ;;\n"
let refill_lexbuf src ppf =
let i = ref 0 in
let max_i = String.length src in
fun buf len ->
- if max_i <= !i then
- 0
+ if max_i <= !i then 0
else
- let (len, nl) =
- try min len (String.index_from src !i '\n' - !i + 1), false
- with Not_found | Invalid_argument _ ->
- min len (max_i - !i), true in
- String.blit src !i buf 0 len ;
- Format.pp_print_string ppf (Bytes.sub_string buf 0 len) ;
- if nl then Format.pp_print_newline ppf () ;
- Format.pp_print_flush ppf () ;
- i := !i + len ;
+ let len, nl =
+ try (min len (String.index_from src !i '\n' - !i + 1), false) with
+ | Not_found | Invalid_argument _ -> (min len (max_i - !i), true)
+ in
+ String.blit src !i buf 0 len;
+ Format.pp_print_string ppf (Bytes.sub_string buf 0 len);
+ if nl then Format.pp_print_newline ppf ();
+ Format.pp_print_flush ppf ();
+ i := !i + len;
len
let init_loc lb filename =
@@ -178,12 +168,13 @@ let init_loc lb filename =
(** *)
-let execute ?ppf_code ?(print_outcome = true) ~ppf_answer code =
+let execute ?ppf_code ?(print_outcome = true) ~ppf_answer code =
let code = normalize code in
let lb =
match ppf_code with
| Some ppf_code -> Lexing.from_function (refill_lexbuf code ppf_code)
- | None -> Lexing.from_string code in
+ | None -> Lexing.from_string code
+ in
init_loc lb "//toplevel//";
warnings := [];
let rec loop () =
@@ -191,29 +182,29 @@ let execute ?ppf_code ?(print_outcome = true) ~ppf_answer code =
let phr = Ppx.preprocess_phrase phr in
let success = Toploop.execute_phrase print_outcome ppf_answer phr in
Format.pp_print_flush ppf_answer ();
- if success then loop () else return_success false in
- try let res = loop () in flush_all () ; res
+ if success then loop () else return_success false
+ in
+ try
+ let res = loop () in
+ flush_all (); res
with
- | End_of_file ->
- flush_all ();
- return_success true
+ | End_of_file -> flush_all (); return_success true
| exn ->
flush_all ();
return_error (error_of_exn exn)
-let use_string
- ?(filename = "//toplevel//") ?(print_outcome = true) ~ppf_answer code =
+let use_string ?(filename = "//toplevel//") ?(print_outcome = true) ~ppf_answer
+ code =
let lb = Lexing.from_string code in
init_loc lb filename;
warnings := [];
try
List.iter
(fun phr ->
- if not (Toploop.execute_phrase print_outcome ppf_answer phr) then
- raise Exit
- else
- Format.pp_print_flush ppf_answer ())
- (List.map Ppx.preprocess_phrase (!Toploop.parse_use_file lb)) ;
+ if not (Toploop.execute_phrase print_outcome ppf_answer phr) then
+ raise Exit
+ else Format.pp_print_flush ppf_answer () )
+ (List.map Ppx.preprocess_phrase (!Toploop.parse_use_file lb));
flush_all ();
return_success true
with
@@ -231,33 +222,34 @@ let parse_mod_string ?filename modname sig_code impl_code =
let str =
let impl_lb = Lexing.from_string impl_code in
init_loc impl_lb
- (match filename with
- | None -> String.uncapitalize_ascii modname ^ ".ml"
- | Some f -> f);
- Parse.implementation impl_lb in
+ ( match filename with
+ | None -> String.uncapitalize_ascii modname ^ ".ml"
+ | Some f -> f );
+ Parse.implementation impl_lb
+ in
let m =
match sig_code with
- | None -> (Mod.structure str)
+ | None -> Mod.structure str
| Some sig_code ->
let sig_lb = Lexing.from_string sig_code in
init_loc sig_lb (String.uncapitalize_ascii modname ^ ".mli");
let s = Parse.interface sig_lb in
- Mod.constraint_ (Mod.structure str) (Mty.signature s) in
- Ptop_def [ Str.module_ (Mb.mk (Location.mknoloc modname) m) ]
+ Mod.constraint_ (Mod.structure str) (Mty.signature s)
+ in
+ Ptop_def [Str.module_ (Mb.mk (Location.mknoloc modname) m)]
-let use_mod_string
- ?filename
- ?(print_outcome = true) ~ppf_answer ~modname ?sig_code
- impl_code =
+let use_mod_string ?filename ?(print_outcome = true) ~ppf_answer ~modname
+ ?sig_code impl_code =
if String.capitalize_ascii modname <> modname then
invalid_arg
- "Learnocaml_toplevel_toploop.use_mod_string: \
- the module name must start with a capital letter.";
+ "Learnocaml_toplevel_toploop.use_mod_string: the module name must start \
+ with a capital letter.";
warnings := [];
try
let phr =
- Ppx.preprocess_phrase @@
- parse_mod_string ?filename modname sig_code impl_code in
+ Ppx.preprocess_phrase
+ @@ parse_mod_string ?filename modname sig_code impl_code
+ in
let res = Toploop.execute_phrase print_outcome ppf_answer phr in
Format.pp_print_flush ppf_answer ();
flush_all ();
@@ -270,13 +262,12 @@ let use_mod_string
let check_phrase env = function
| Parsetree.Ptop_def sstr ->
Typecore.reset_delayed_checks ();
- let (str, sg, newenv) = Typemod.type_toplevel_phrase env sstr in
+ let str, sg, newenv = Typemod.type_toplevel_phrase env sstr in
let sg' = Typemod.simplify_signature sg in
ignore (Includemod.signatures env sg sg');
Typecore.force_delayed_checks ();
let _lam = Translmod.transl_toplevel_definition str in
- Warnings.check_fatal ();
- newenv
+ Warnings.check_fatal (); newenv
| Parsetree.Ptop_dir _ -> env
let check ?(setenv = false) code =
@@ -285,15 +276,11 @@ let check ?(setenv = false) code =
warnings := [];
try
let env =
- List.fold_left
- check_phrase
- !Toploop.toplevel_env
- (List.map
- Ppx.preprocess_phrase
- (!Toploop.parse_use_file lb)) in
+ List.fold_left check_phrase !Toploop.toplevel_env
+ (List.map Ppx.preprocess_phrase (!Toploop.parse_use_file lb))
+ in
if setenv then Toploop.toplevel_env := env;
return_success ()
with
| End_of_file -> return_success ()
| exn -> return_exn exn
-
diff --git a/src/toploop/toploop_ext.mli b/src/toploop/toploop_ext.mli
index c6903d57b..22f176443 100644
--- a/src/toploop/toploop_ext.mli
+++ b/src/toploop/toploop_ext.mli
@@ -12,17 +12,13 @@ type 'a toplevel_result = 'a Toploop_results.toplevel_result =
| Error of error * warning list
and error = Toploop_results.error =
- { msg: string;
- locs: loc list;
- if_highlight: string; }
+ {msg : string; locs : loc list; if_highlight : string}
and warning = error
-and loc = Toploop_results.loc = {
- loc_start: int * int;
- loc_end: int * int;
-}
+and loc = Toploop_results.loc = {loc_start : int * int; loc_end : int * int}
+val check : ?setenv:bool -> string -> unit toplevel_result
(** Parse and typecheck a given source code.
@param setenv should the resulting environment replace the current
@@ -32,9 +28,13 @@ and loc = Toploop_results.loc = {
where [err] contains the error message otherwise.
*)
-val check: ?setenv:bool -> string -> unit toplevel_result
-
+val execute :
+ ?ppf_code:Format.formatter
+ -> ?print_outcome:bool
+ -> ppf_answer:Format.formatter
+ -> string
+ -> bool toplevel_result
(** Execute a given source code. The evaluation stops after the
first toplevel phrase (as terminated by ";;") that fails to
parse/typecheck/compile or for which the evaluation raises an
@@ -56,13 +56,13 @@ val check: ?setenv:bool -> string -> unit toplevel_result
exception, and [Ok false] otherwise. In the last case,
the exception has been pretty-printed in [ppf_answer].
*)
-val execute:
- ?ppf_code:Format.formatter ->
- ?print_outcome:bool ->
- ppf_answer:Format.formatter ->
- string -> bool toplevel_result
-
+val use_string :
+ ?filename:string
+ -> ?print_outcome:bool
+ -> ppf_answer:Format.formatter
+ -> string
+ -> bool toplevel_result
(** Execute a given source code. The code is parsed all at once
before to typecheck/compile/evaluate phrase by phrase.
@@ -75,12 +75,15 @@ val execute:
@return as {!val:execute}.
*)
-val use_string:
- ?filename:string ->
- ?print_outcome:bool ->
- ppf_answer:Format.formatter ->
- string -> bool toplevel_result
+val use_mod_string :
+ ?filename:string
+ -> ?print_outcome:bool
+ -> ppf_answer:Format.formatter
+ -> modname:string
+ -> ?sig_code:string
+ -> string
+ -> bool toplevel_result
(** Wrap a given source code into a module and bind it with a given
name.
@@ -98,17 +101,13 @@ val use_string:
@return as {!val:execute}.
*)
-val use_mod_string:
- ?filename:string ->
- ?print_outcome:bool ->
- ppf_answer:Format.formatter ->
- modname:string ->
- ?sig_code:string ->
- string -> bool toplevel_result
(** Helpers to embed PPX into the toplevel. *)
module Ppx : sig
- val preprocess_structure: Parsetree.structure -> Parsetree.structure
- val preprocess_signature: Parsetree.signature -> Parsetree.signature
- val preprocess_phrase: Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase
+ val preprocess_structure : Parsetree.structure -> Parsetree.structure
+
+ val preprocess_signature : Parsetree.signature -> Parsetree.signature
+
+ val preprocess_phrase :
+ Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase
end
diff --git a/src/toploop/toploop_jsoo.ml b/src/toploop/toploop_jsoo.ml
index 497bf39a1..ff758a9f1 100644
--- a/src/toploop/toploop_jsoo.ml
+++ b/src/toploop/toploop_jsoo.ml
@@ -15,108 +15,112 @@ let split_primitives p =
if cur >= len then []
else if p.[cur] = '\000' then
String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
- else
- split beg (cur + 1) in
- Array.of_list(split 0 0)
-
-let setup = lazy (
- Hashtbl.add Toploop.directive_table "enable"
- (Toploop.Directive_string Option.Optim.enable);
- Hashtbl.add Toploop.directive_table "disable"
- (Toploop.Directive_string Option.Optim.disable);
- Hashtbl.add Toploop.directive_table "debug_on"
- (Toploop.Directive_string Option.Debug.enable);
- Hashtbl.add Toploop.directive_table "debug_off"
- (Toploop.Directive_string Option.Debug.disable);
- Hashtbl.add Toploop.directive_table "tailcall"
- (Toploop.Directive_string (Option.Param.set "tc"));
- (* Workaround Marshal bug triggered by includemod.ml:607 *)
- Clflags.error_size := 0 ;
- (* Disable inlining of JSOO which may blow the JS stack *)
- Option.Optim.disable "inline" ;
- Topdirs.dir_directory "/cmis";
- let initial_primitive_count =
- Array.length (split_primitives (Symtable.data_primitive_names ())) in
-
- let compile s =
- let prims =
- split_primitives (Symtable.data_primitive_names ()) in
- let unbound_primitive p =
- try ignore (Js.Unsafe.eval_string p); false with _ -> true in
- let stubs = ref [] in
- Array.iteri
- (fun i p ->
- if i >= initial_primitive_count && unbound_primitive p then
- stubs :=
- Format.sprintf
- "function %s(){caml_failwith(\"%s not implemented\")}" p p
- :: !stubs)
- prims;
- let output_program = Driver.from_string prims s in
- let b = Buffer.create 100 in
- output_program (Pretty_print.to_buffer b);
- Format.(pp_print_flush std_formatter ());
- Format.(pp_print_flush err_formatter ());
- flush stdout; flush stderr;
- let res = Buffer.contents b in
- let res = String.concat "" !stubs ^ res in
- Js.Unsafe.global##(toplevelEval res)
+ else split beg (cur + 1)
in
- Js.Unsafe.global##.toplevelCompile := compile (*XXX HACK!*);
- Js.Unsafe.global##.toplevelEval := (fun x ->
+ Array.of_list (split 0 0)
+
+let setup =
+ lazy
+ ( Hashtbl.add Toploop.directive_table "enable"
+ (Toploop.Directive_string Option.Optim.enable);
+ Hashtbl.add Toploop.directive_table "disable"
+ (Toploop.Directive_string Option.Optim.disable);
+ Hashtbl.add Toploop.directive_table "debug_on"
+ (Toploop.Directive_string Option.Debug.enable);
+ Hashtbl.add Toploop.directive_table "debug_off"
+ (Toploop.Directive_string Option.Debug.disable);
+ Hashtbl.add Toploop.directive_table "tailcall"
+ (Toploop.Directive_string (Option.Param.set "tc"));
+ (* Workaround Marshal bug triggered by includemod.ml:607 *)
+ Clflags.error_size := 0;
+ (* Disable inlining of JSOO which may blow the JS stack *)
+ Option.Optim.disable "inline";
+ Topdirs.dir_directory "/cmis";
+ let initial_primitive_count =
+ Array.length (split_primitives (Symtable.data_primitive_names ()))
+ in
+ let compile s =
+ let prims = split_primitives (Symtable.data_primitive_names ()) in
+ let unbound_primitive p =
+ try
+ ignore (Js.Unsafe.eval_string p);
+ false
+ with _ -> true
+ in
+ let stubs = ref [] in
+ Array.iteri
+ (fun i p ->
+ if i >= initial_primitive_count && unbound_primitive p then
+ stubs :=
+ Format.sprintf
+ "function %s(){caml_failwith(\"%s not implemented\")}" p p
+ :: !stubs )
+ prims;
+ let output_program = Driver.from_string prims s in
+ let b = Buffer.create 100 in
+ output_program (Pretty_print.to_buffer b);
+ Format.(pp_print_flush std_formatter ());
+ Format.(pp_print_flush err_formatter ());
+ flush stdout;
+ flush stderr;
+ let res = Buffer.contents b in
+ let res = String.concat "" !stubs ^ res in
+ Js.Unsafe.global ## (toplevelEval res)
+ in
+ Js.Unsafe.global##.toplevelCompile := compile (*XXX HACK!*);
+ Js.Unsafe.global##.toplevelEval
+ := fun x ->
let f : < .. > Js.t -> < .. > Js.t = Js.Unsafe.eval_string x in
- (fun () ->
- let res = f Js.Unsafe.global in
- Format.(pp_print_flush std_formatter ());
- Format.(pp_print_flush err_formatter ());
- flush stdout; flush stderr;
- res)))
+ fun () ->
+ let res = f Js.Unsafe.global in
+ Format.(pp_print_flush std_formatter ());
+ Format.(pp_print_flush err_formatter ());
+ flush stdout; flush stderr; res )
let initialize () =
- Lazy.force setup ;
+ Lazy.force setup;
Toploop.initialize_toplevel_env ()
type redirection =
- { channel : out_channel ;
- name : string ;
- tee : string -> string -> unit ;
- callback : string -> unit ;
- prev : redirection option }
+ { channel : out_channel
+ ; name : string
+ ; tee : string -> string -> unit
+ ; callback : string -> unit
+ ; prev : redirection option }
let redirections : (out_channel * redirection ref) list ref = ref []
-let redirect_channel ?(tee = (fun _ _ -> ())) name channel callback =
+let redirect_channel ?(tee = fun _ _ -> ()) name channel callback =
try
- flush channel ;
+ flush channel;
let cur = List.assq channel !redirections in
- cur := { channel ; name ; tee ; callback ; prev = Some !cur } ;
+ cur := {channel; name; tee; callback; prev = Some !cur};
!cur
with Not_found ->
- let cur = ref { channel ; name ; tee ; callback ; prev = None } in
- redirections := (channel, cur) :: !redirections ;
+ let cur = ref {channel; name; tee; callback; prev = None} in
+ redirections := (channel, cur) :: !redirections;
let append text =
- let { tee ; name ; callback ; _ } = !cur in
- tee name text ;
- callback text in
- Sys_js.set_channel_flusher channel append ;
+ let {tee; name; callback; _} = !cur in
+ tee name text; callback text
+ in
+ Sys_js.set_channel_flusher channel append;
!cur
-let flush_redirected_channel redir =
- flush redir.channel (* [Sys_js] should do the rest *)
+let flush_redirected_channel redir = flush redir.channel
+
+(* [Sys_js] should do the rest *)
let stop_channel_redirection redir =
let fail () = invalid_arg "Toploop_jsoo.stop_channel_redirection" in
try
let cur = List.assq redir.channel !redirections in
- if !cur != redir then fail () ;
- flush_redirected_channel redir ;
+ if !cur != redir then fail ();
+ flush_redirected_channel redir;
match redir.prev with
| Some prev -> cur := prev
| None ->
redirections :=
- List.filter (fun (ch, _) -> ch != redir.channel) !redirections ;
- let append text =
- Firebug.console##(log (Js.string text)) in
- Sys_js.set_channel_flusher redir.channel append ;
- with Not_found ->
- fail ()
+ List.filter (fun (ch, _) -> ch != redir.channel) !redirections;
+ let append text = Firebug.console ## (log (Js.string text)) in
+ Sys_js.set_channel_flusher redir.channel append
+ with Not_found -> fail ()
diff --git a/src/toploop/toploop_jsoo.mli b/src/toploop/toploop_jsoo.mli
index 88fb2a428..324b8bbd6 100644
--- a/src/toploop/toploop_jsoo.mli
+++ b/src/toploop/toploop_jsoo.mli
@@ -6,12 +6,18 @@
* Learn-OCaml is distributed under the terms of the MIT license. See the
* included LICENSE file for details. *)
+val initialize : unit -> unit
(** To be called before using any [Toploop] function. *)
-val initialize: unit -> unit
(** Materializes an output channel redirection. *)
type redirection
+val redirect_channel :
+ ?tee:(string -> string -> unit)
+ -> string
+ -> out_channel
+ -> (string -> unit)
+ -> redirection
(** Redirects a channel.
Instead of being output to the file underlying file descriptor,
any data output to this channel will be passed to the callback
@@ -19,18 +25,14 @@ type redirection
The string parameter is an identifier, that is passed back to the
secondary callback [tee]. This is useful to use the same [tee]
callback for several channels. *)
-val redirect_channel:
- ?tee:(string -> string -> unit) ->
- string -> out_channel -> (string -> unit) ->
- redirection
-(** Flushes the channel, calling the callbacks if necessary. *)
val flush_redirected_channel : redirection -> unit
+(** Flushes the channel, calling the callbacks if necessary. *)
+val stop_channel_redirection : redirection -> unit
(** Flushes the channel and then cancel the redirection.
The redirection must be the last one performed, otherwise an
[Invalid_argument] will be raised.
A stack of redirections is maintained for all fire descriptors. So
the channel is then restored to either the previous redirection or
to the original file descriptor. *)
-val stop_channel_redirection : redirection -> unit
diff --git a/src/toploop/toploop_results.ml b/src/toploop/toploop_results.ml
index 0fe6b7328..04ad7bd84 100644
--- a/src/toploop/toploop_results.ml
+++ b/src/toploop/toploop_results.ml
@@ -11,14 +11,8 @@ type 'a toplevel_result =
| Ok of 'a * warning list
| Error of error * warning list
-and error =
- { msg: string;
- locs: loc list;
- if_highlight: string; }
+and error = {msg : string; locs : loc list; if_highlight : string}
and warning = error
-and loc = {
- loc_start: int * int;
- loc_end: int * int;
-}
+and loc = {loc_start : int * int; loc_end : int * int}
diff --git a/src/toploop/toploop_results.mli b/src/toploop/toploop_results.mli
index 0fe6b7328..04ad7bd84 100644
--- a/src/toploop/toploop_results.mli
+++ b/src/toploop/toploop_results.mli
@@ -11,14 +11,8 @@ type 'a toplevel_result =
| Ok of 'a * warning list
| Error of error * warning list
-and error =
- { msg: string;
- locs: loc list;
- if_highlight: string; }
+and error = {msg : string; locs : loc list; if_highlight : string}
and warning = error
-and loc = {
- loc_start: int * int;
- loc_end: int * int;
-}
+and loc = {loc_start : int * int; loc_end : int * int}
diff --git a/src/toploop/toploop_unix.ml b/src/toploop/toploop_unix.ml
index c5168b2e7..2a1d9a93d 100644
--- a/src/toploop/toploop_unix.ml
+++ b/src/toploop/toploop_unix.ml
@@ -6,67 +6,62 @@
* Learn-OCaml is distributed under the terms of the MIT license. See the
* included LICENSE file for details. *)
-let map_opt f = function
- | None -> None
- | Some x -> Some (f x)
-let iter_opt f = function
- | None -> ()
- | Some x -> f x
+let map_opt f = function None -> None | Some x -> Some (f x)
+
+let iter_opt f = function None -> () | Some x -> f x
type redirection =
- { channel : out_channel ;
- target_fd : Unix.file_descr ;
- backup_fd : Unix.file_descr ;
- read_fd : Unix.file_descr ;
- append : string -> unit }
+ { channel : out_channel
+ ; target_fd : Unix.file_descr
+ ; backup_fd : Unix.file_descr
+ ; read_fd : Unix.file_descr
+ ; append : string -> unit }
let redirections = ref []
let redirect_channel ?tee name channel append =
- flush channel ;
+ flush channel;
let append data =
let tee = map_opt (fun tee -> tee name) tee in
- iter_opt (fun tee -> tee data) tee ;
- append data in
+ iter_opt (fun tee -> tee data) tee;
+ append data
+ in
let target_fd = Unix.descr_of_out_channel channel in
let backup_fd = Unix.dup target_fd in
let stack = try List.assq target_fd !redirections with Not_found -> [] in
let read_fd, write_fd = Unix.pipe () in
- Unix.dup2 write_fd target_fd ;
- Unix.close write_fd ;
- Unix.set_nonblock read_fd ;
- let redirected_channel =
- { target_fd ; backup_fd ; read_fd ; append ; channel } in
- redirections :=
- List.filter (fun (fd, _) -> fd != target_fd) !redirections ;
- redirections :=
- (target_fd, redirected_channel :: stack) :: !redirections ;
+ Unix.dup2 write_fd target_fd;
+ Unix.close write_fd;
+ Unix.set_nonblock read_fd;
+ let redirected_channel = {target_fd; backup_fd; read_fd; append; channel} in
+ redirections := List.filter (fun (fd, _) -> fd != target_fd) !redirections;
+ redirections := (target_fd, redirected_channel :: stack) :: !redirections;
redirected_channel
-let flush_redirected_channel { read_fd ; append ; channel ; _ } =
+let flush_redirected_channel {read_fd; append; channel; _} =
let buf = Bytes.create 503 in
let rec loop () =
let len = Unix.read read_fd buf 0 (Bytes.length buf) in
let data = Bytes.sub_string buf 0 len in
- append data ;
- loop () in
- flush channel ; try loop () with _ -> ()
+ append data; loop ()
+ in
+ flush channel;
+ try loop () with _ -> ()
-let stop_channel_redirection ({ target_fd ; read_fd ; backup_fd ; _ } as redirection) =
+let stop_channel_redirection ({target_fd; read_fd; backup_fd; _} as redirection)
+ =
let fail () = invalid_arg "Toploop_unix.stop_channel_redirection" in
match List.assq target_fd !redirections with
| exception Not_found -> fail ()
| [] -> fail ()
| redirection' :: rest ->
- if redirection' != redirection then fail () ;
- flush_redirected_channel redirection ;
- Unix.dup2 backup_fd target_fd ;
- Unix.close backup_fd ;
- Unix.close read_fd ;
+ if redirection' != redirection then fail ();
+ flush_redirected_channel redirection;
+ Unix.dup2 backup_fd target_fd;
+ Unix.close backup_fd;
+ Unix.close read_fd;
redirections :=
- List.filter (fun (fd, _) -> fd != target_fd) !redirections ;
- if rest <> [] then
- redirections := (target_fd, rest) :: !redirections
+ List.filter (fun (fd, _) -> fd != target_fd) !redirections;
+ if rest <> [] then redirections := (target_fd, rest) :: !redirections
-let initialize () =
- Toploop.initialize_toplevel_env ()
+let initialize () = Toploop.initialize_toplevel_env ()
diff --git a/src/toploop/toploop_unix.mli b/src/toploop/toploop_unix.mli
index 88fb2a428..324b8bbd6 100644
--- a/src/toploop/toploop_unix.mli
+++ b/src/toploop/toploop_unix.mli
@@ -6,12 +6,18 @@
* Learn-OCaml is distributed under the terms of the MIT license. See the
* included LICENSE file for details. *)
+val initialize : unit -> unit
(** To be called before using any [Toploop] function. *)
-val initialize: unit -> unit
(** Materializes an output channel redirection. *)
type redirection
+val redirect_channel :
+ ?tee:(string -> string -> unit)
+ -> string
+ -> out_channel
+ -> (string -> unit)
+ -> redirection
(** Redirects a channel.
Instead of being output to the file underlying file descriptor,
any data output to this channel will be passed to the callback
@@ -19,18 +25,14 @@ type redirection
The string parameter is an identifier, that is passed back to the
secondary callback [tee]. This is useful to use the same [tee]
callback for several channels. *)
-val redirect_channel:
- ?tee:(string -> string -> unit) ->
- string -> out_channel -> (string -> unit) ->
- redirection
-(** Flushes the channel, calling the callbacks if necessary. *)
val flush_redirected_channel : redirection -> unit
+(** Flushes the channel, calling the callbacks if necessary. *)
+val stop_channel_redirection : redirection -> unit
(** Flushes the channel and then cancel the redirection.
The redirection must be the last one performed, otherwise an
[Invalid_argument] will be raised.
A stack of redirections is maintained for all fire descriptors. So
the channel is then restored to either the previous redirection or
to the original file descriptor. *)
-val stop_channel_redirection : redirection -> unit
diff --git a/src/utils/js_utils.ml b/src/utils/js_utils.ml
index ea6d9be6e..c6f2c7af6 100644
--- a/src/utils/js_utils.ml
+++ b/src/utils/js_utils.ml
@@ -19,60 +19,64 @@
open Js_of_ocaml
let doc = Dom_html.document
+
let window = Dom_html.window
+
(* let loc = Js.Unsafe.variable "location" *)
-let alert s = window##(alert (Js.string s))
-let confirm s = Js.to_bool (window##(confirm (Js.string s)))
+let alert s = window ## (alert (Js.string s))
+
+let confirm s = Js.to_bool window ## (confirm (Js.string s))
+
+let js_log obj = Firebug.console ## (log obj)
+
+let js_debug obj = Firebug.console ## (debug obj)
-let js_log obj = Firebug.console##(log obj)
-let js_debug obj = Firebug.console##(debug obj)
-let js_warn obj = Firebug.console##(warn obj)
-let js_error obj = Firebug.console##(error obj)
+let js_warn obj = Firebug.console ## (warn obj)
+
+let js_error obj = Firebug.console ## (error obj)
let log fmt =
Format.kfprintf
- (fun _ -> Firebug.console##(log (Js.string (Format.flush_str_formatter ()))))
- Format.str_formatter
- fmt
+ (fun _ ->
+ Firebug.console ## (log (Js.string (Format.flush_str_formatter ()))) )
+ Format.str_formatter fmt
+
let debug fmt =
Format.kfprintf
- (fun _ -> Firebug.console##(debug (Js.string (Format.flush_str_formatter ()))))
- Format.str_formatter
- fmt
+ (fun _ ->
+ Firebug.console ## (debug (Js.string (Format.flush_str_formatter ()))) )
+ Format.str_formatter fmt
+
let warn fmt =
Format.kfprintf
- (fun _ -> Firebug.console##(warn (Js.string (Format.flush_str_formatter ()))))
- Format.str_formatter
- fmt
+ (fun _ ->
+ Firebug.console ## (warn (Js.string (Format.flush_str_formatter ()))) )
+ Format.str_formatter fmt
+
let error fmt =
Format.kfprintf
- (fun _ -> Firebug.console##(error (Js.string (Format.flush_str_formatter ()))))
- Format.str_formatter
- fmt
+ (fun _ ->
+ Firebug.console ## (error (Js.string (Format.flush_str_formatter ()))) )
+ Format.str_formatter fmt
let reload () = window##.location##reload
let get_lang () =
- match Js.Optdef. to_option (Dom_html.window##.navigator##.language) with
+ match Js.Optdef.to_option Dom_html.window##.navigator##.language with
| Some l -> Some (Js.to_string l)
- | None ->
- match Js.Optdef.to_option (Dom_html.window##.navigator##.userLanguage)
- with
- | Some l -> Some (Js.to_string l)
- | None -> None
-
+ | None -> (
+ match Js.Optdef.to_option Dom_html.window##.navigator##.userLanguage with
+ | Some l -> Some (Js.to_string l)
+ | None -> None )
module Manip = struct
-
let option_map f = function None -> None | Some x -> Some (f x)
exception Error of string
let manip_error fmt =
- Format.ksprintf
- (fun s -> debug "%s" s; raise (Error s))
- fmt
+ Format.ksprintf (fun s -> debug "%s" s; raise (Error s)) fmt
open Tyxml_js
@@ -84,21 +88,19 @@ module Manip = struct
Js.Opt.case
(Dom_html.CoerceTo.element (Html5.toelt elt))
(fun () ->
- manip_error
- "Cannot call %s on a node which is not an element"
- name)
+ manip_error "Cannot call %s on a node which is not an element" name )
id
+
let html_doc_constr : Dom_html.document Js.constr =
Js.Unsafe.global##._HTMLDocument
let document elt =
let elt = get_elt "document" elt in
- let rec loop (elt : Dom.node Js.t) =
- if Js.instanceof elt html_doc_constr
- then (Obj.magic elt : Dom_html.document Js.t)
+ let rec loop (elt : Dom.node Js.t) =
+ if Js.instanceof elt html_doc_constr then
+ (Obj.magic elt : Dom_html.document Js.t)
else
- Js.Opt.case
- (elt##.parentNode)
+ Js.Opt.case elt##.parentNode
(fun () -> (Obj.magic elt : Dom_html.document Js.t))
loop
in
@@ -108,9 +110,9 @@ module Manip = struct
let doc = document elt in
(Obj.magic doc)##.defaultView
- let clone ?(deep=false) elt =
+ let clone ?(deep = false) elt =
let elt = get_elt "clone" elt in
- Obj.magic (elt##(cloneNode (Js.bool deep)))
+ Obj.magic elt ## (cloneNode (Js.bool deep))
let setInnerHtml elt s =
let elt = get_elt "setInnerHtml" elt in
@@ -122,92 +124,99 @@ module Manip = struct
let hasClass elt s =
let elt = get_elt "addClass" elt in
- Js.to_bool
- elt##.classList##(contains (Js.string s))
+ Js.to_bool elt ##. classList ## (contains (Js.string s))
+
let addClass elt s =
let elt = get_elt "addClass" elt in
- elt##.classList##(add (Js.string s))
+ elt ##. classList ## (add (Js.string s))
+
let removeClass elt s =
let elt = get_elt "removeClass" elt in
- elt##.classList##(remove (Js.string s))
+ elt ##. classList ## (remove (Js.string s))
+
let toggleClass elt s =
let elt = get_elt "toggleClass" elt in
- Js.to_bool
- elt##.classList##(toggle (Js.string s))
-
+ Js.to_bool elt ##. classList ## (toggle (Js.string s))
let raw_appendChild ?before node elt2 =
match before with
- | None -> ignore(node##(appendChild (get_node elt2)))
+ | None -> ignore node ## (appendChild (get_node elt2))
| Some elt3 ->
- let node3 = get_node elt3 in
- ignore(node##(insertBefore (get_node elt2) (Js.some node3)))
+ let node3 = get_node elt3 in
+ ignore node ## (insertBefore (get_node elt2) (Js.some node3))
let raw_appendChildren ?before node elts =
match before with
| None ->
- List.iter (fun elt2 -> ignore(node##(appendChild (get_node elt2)))) elts
+ List.iter
+ (fun elt2 -> ignore node ## (appendChild (get_node elt2)))
+ elts
| Some elt3 ->
- let node3 = get_node elt3 in
- List.iter (fun elt2 -> ignore(node##(insertBefore (get_node elt2) (Js.some node3)))) elts
+ let node3 = get_node elt3 in
+ List.iter
+ (fun elt2 ->
+ ignore node ## (insertBefore (get_node elt2) (Js.some node3)) )
+ elts
let raw_insertChildAfter node1 node2 elt3 =
- Js.Opt.case
- (node2##.nextSibling)
- (fun () ->
- ignore(node1##(appendChild (get_node elt3))))
+ Js.Opt.case node2##.nextSibling
+ (fun () -> ignore node1 ## (appendChild (get_node elt3)))
(fun node2 ->
- ignore(node1##(insertBefore (get_node elt3) (Js.some node2))))
+ ignore node1 ## (insertBefore (get_node elt3) (Js.some node2)) )
let raw_insertChildrenAfter node1 node2 elts =
- Js.Opt.case
- (node2##.nextSibling)
+ Js.Opt.case node2##.nextSibling
(fun () ->
- List.iter (fun elt3 ->
- ignore(node1##(appendChild (get_node elt3)))))
+ List.iter (fun elt3 -> ignore node1 ## (appendChild (get_node elt3)))
+ )
(fun node2 ->
- List.iter (fun elt3 ->
- ignore(node1##(insertBefore (get_node elt3) (Js.some node2)))))
+ List.iter (fun elt3 ->
+ ignore node1 ## (insertBefore (get_node elt3) (Js.some node2)) ) )
elts
let raw_removeChild node1 elt2 =
let node2 = get_node elt2 in
- ignore(node1##(removeChild node2))
+ ignore node1 ## (removeChild node2)
let raw_replaceChild node1 elt2 elt3 =
let node2 = get_node elt2 in
- ignore(node1##replaceChild node2 (get_node elt3))
+ ignore (node1##replaceChild node2 (get_node elt3))
let raw_removeChildren node =
- let childrens = Dom.list_of_nodeList (node##.childNodes) in
- List.iter (fun c -> ignore(node##(removeChild c))) childrens
+ let childrens = Dom.list_of_nodeList node##.childNodes in
+ List.iter (fun c -> ignore node ## (removeChild c)) childrens
let raw_replaceChildren node elts =
raw_removeChildren node;
- List.iter (fun elt -> ignore(node##(appendChild (get_node elt)))) elts
+ List.iter (fun elt -> ignore node ## (appendChild (get_node elt))) elts
let nth elt n =
let node = get_node elt in
- let res = Js.Opt.bind (node##.childNodes##(item n)) (fun node ->
- Js.Opt.map (Dom.CoerceTo.element node) (fun node ->
- Of_dom.of_element (Dom_html.element node)
- )
- ) in
+ let res =
+ Js.Opt.bind
+ node ##. childNodes ## (item n)
+ (fun node ->
+ Js.Opt.map (Dom.CoerceTo.element node) (fun node ->
+ Of_dom.of_element (Dom_html.element node) ) )
+ in
Js.Opt.to_option res
let by_id n =
- let res = Js.Opt.bind (Dom_html.window##.document##(getElementById (Js.string n))) (fun node ->
- Js.Opt.map (Dom.CoerceTo.element node) (fun node ->
- Of_dom.of_element (Dom_html.element node)
- )
- ) in
+ let res =
+ Js.Opt.bind
+ Dom_html.window ##. document ## (getElementById (Js.string n))
+ (fun node ->
+ Js.Opt.map (Dom.CoerceTo.element node) (fun node ->
+ Of_dom.of_element (Dom_html.element node) ) )
+ in
Js.Opt.to_option res
let by_classname n =
Dom.list_of_nodeList
- (Dom_html.window##.document##(getElementsByClassName (Js.string n)))
+ Dom_html.window ##. document ## (getElementsByClassName (Js.string n))
|> List.map (fun n -> Of_dom.of_element (Dom_html.element n))
- (* let rec tolist acc n =
+
+ (* let rec tolist acc n =
* if n < 0 then acc
* else
* let acc =
@@ -247,12 +256,12 @@ module Manip = struct
let removeSelf elt =
let node = get_node elt in
- let res = Js.Opt.bind (node##.parentNode) (fun node ->
- Js.Opt.map (Dom.CoerceTo.element node) (fun node ->
- Of_dom.of_element (Dom_html.element node)
- )
- ) in
- Js.Opt.iter res (fun p -> removeChild p elt)
+ let res =
+ Js.Opt.bind node##.parentNode (fun node ->
+ Js.Opt.map (Dom.CoerceTo.element node) (fun node ->
+ Of_dom.of_element (Dom_html.element node) ) )
+ in
+ Js.Opt.iter res (fun p -> removeChild p elt)
let appendChildFirst p c =
let before = nth p 0 in
@@ -263,8 +272,8 @@ module Manip = struct
raw_replaceChild node1 elt2 elt3
let replaceSelf elt1 elt2 =
- Js.Opt.iter (get_node elt1)##.parentNode @@ fun parent ->
- raw_replaceChild parent elt2 elt1
+ Js.Opt.iter (get_node elt1)##.parentNode
+ @@ fun parent -> raw_replaceChild parent elt2 elt1
let removeChildren elt =
let node = get_node elt in
@@ -276,14 +285,14 @@ module Manip = struct
let children elt =
let node = get_node elt in
- List.map Html5.tot (Dom.list_of_nodeList (node##.childNodes))
+ List.map Html5.tot (Dom.list_of_nodeList node##.childNodes)
let appendToBody ?before elt2 =
- let body = (Of_dom.of_body Dom_html.window##.document##.body) in
+ let body = Of_dom.of_body Dom_html.window##.document##.body in
appendChild ?before body elt2
let appendToHead ?before elt2 =
- let head = (Of_dom.of_head Dom_html.window##.document##.head) in
+ let head = Of_dom.of_head Dom_html.window##.document##.head in
appendChild ?before head elt2
let get_elt_input name elt : Dom_html.inputElement Js.t =
@@ -312,51 +321,50 @@ module Manip = struct
let scrollIntoView ?(bottom = false) elt =
let elt = get_elt "Css.background" elt in
- elt##(scrollIntoView (Js.bool (not bottom)))
+ elt ## (scrollIntoView (Js.bool (not bottom)))
+
+ type disable = < disabled : bool Js.t Js.prop >
- type disable = < disabled: bool Js.t Js.prop >
let get_disable_elt name elt : disable Js.t =
if Js.undefined == (Js.Unsafe.coerce @@ Html5.toelt elt)##.disabled then
- manip_error
- "Cannot call %s on a node without a 'disable' property"
- name;
+ manip_error "Cannot call %s on a node without a 'disable' property" name;
Js.Unsafe.coerce @@ Html5.toelt elt
let disable elt =
let elt = get_disable_elt "disable" elt in
elt##.disabled := Js._true
+
let enable elt =
let elt = get_disable_elt "enable" elt in
elt##.disabled := Js._false
- type focus = < focus: unit Js.meth >
+ type focus = < focus : unit Js.meth >
+
let get_focus_elt name elt : focus Js.t =
if Js.undefined == (Js.Unsafe.coerce @@ Html5.toelt elt)##.focus then
- manip_error
- "Cannot call %s on a node without a 'focus' property"
- name;
+ manip_error "Cannot call %s on a node without a 'focus' property" name;
Js.Unsafe.coerce @@ Html5.toelt elt
+
let focus elt =
let elt = get_focus_elt "focus" elt in
elt##focus
- type blur = < blur: unit Js.meth >
+ type blur = < blur : unit Js.meth >
+
let get_blur_elt name elt : blur Js.t =
if Js.undefined == (Js.Unsafe.coerce @@ Html5.toelt elt)##.blur then
- manip_error
- "Cannot call %s on a node without a 'blur' property"
- name;
+ manip_error "Cannot call %s on a node without a 'blur' property" name;
Js.Unsafe.coerce @@ Html5.toelt elt
+
let blur elt =
let elt = get_blur_elt "blur" elt in
elt##blur
- type value = < value: Js.js_string Js.t Js.prop >
+ type value = < value : Js.js_string Js.t Js.prop >
+
let get_value_elt name elt : value Js.t =
if Js.undefined == (Js.Unsafe.coerce @@ Html5.toelt elt)##.value then
- manip_error
- "Cannot call %s on a node without a 'value' property"
- name;
+ manip_error "Cannot call %s on a node without a 'value' property" name;
Js.Unsafe.coerce @@ Html5.toelt elt
let value elt =
@@ -365,97 +373,127 @@ module Manip = struct
module Elt = struct
let body =
- try Of_dom.of_body (Dom_html.window##.document##.body)
- with _ -> Obj.magic Js.undefined (* For workers... *)
+ try Of_dom.of_body Dom_html.window##.document##.body with _ ->
+ Obj.magic Js.undefined
+
+ (* For workers... *)
let active () =
(Js.Unsafe.coerce Dom_html.window##.document)##.activeElement
end
module Ev = struct
type ('a, 'b) ev = 'a Html5.elt -> ('b Js.t -> bool) -> unit
- type ('a,'b) ev_unit = 'a Html5.elt -> ('b Js.t -> unit) -> unit
+
+ type ('a, 'b) ev_unit = 'a Html5.elt -> ('b Js.t -> unit) -> unit
+
let bool_cb f = Dom_html.handler (fun e -> Js.bool (f e))
+
let onkeyup elt f =
let elt = get_elt "Ev.onkeyup" elt in
- elt##.onkeyup := (bool_cb f)
+ elt##.onkeyup := bool_cb f
+
let onkeydown elt f =
let elt = get_elt "Ev.onkeydown" elt in
- elt##.onkeydown := (bool_cb f)
+ elt##.onkeydown := bool_cb f
+
let onmouseup elt f =
let elt = get_elt "Ev.onmouseup" elt in
- elt##.onmouseup := (bool_cb f)
+ elt##.onmouseup := bool_cb f
+
let onmousedown elt f =
let elt = get_elt "Ev.onmousedown" elt in
- elt##.onmousedown := (bool_cb f)
+ elt##.onmousedown := bool_cb f
+
let onmouseout elt f =
let elt = get_elt "Ev.onmouseout" elt in
- elt##.onmouseout := (bool_cb f)
+ elt##.onmouseout := bool_cb f
+
let onmouseover elt f =
let elt = get_elt "Ev.onmouseover" elt in
- elt##.onmouseover := (bool_cb f)
+ elt##.onmouseover := bool_cb f
+
let onclick elt f =
let elt = get_elt "Ev.onclick" elt in
- elt##.onclick := (bool_cb f)
+ elt##.onclick := bool_cb f
+
let ondblclick elt f =
let elt = get_elt "Ev.ondblclick" elt in
- elt##.ondblclick := (bool_cb f)
+ elt##.ondblclick := bool_cb f
+
let onload elt f =
let elt = get_elt_img "Ev.onload" elt in
- elt##.onload := (bool_cb f)
+ elt##.onload := bool_cb f
+
let onerror elt f =
let elt = get_elt_img "Ev.onerror" elt in
- elt##.onerror := (bool_cb f)
+ elt##.onerror := bool_cb f
+
let onabort elt f =
let elt = get_elt_img "Ev.onabort" elt in
- elt##.onabort := (bool_cb f)
+ elt##.onabort := bool_cb f
+
let onfocus elt f =
let elt = get_elt_input "Ev.onfocus" elt in
- elt##.onfocus := (bool_cb f)
+ elt##.onfocus := bool_cb f
+
let onblur elt f =
let elt = get_elt_input "Ev.onblur" elt in
- elt##.onblur := (bool_cb f)
+ elt##.onblur := bool_cb f
+
let onfocus_textarea elt f =
let elt = get_elt_textarea "Ev.onfocus" elt in
- elt##.onfocus := (bool_cb f)
+ elt##.onfocus := bool_cb f
+
let onblur_textarea elt f =
let elt = get_elt_textarea "Ev.onblur" elt in
- elt##.onblur := (bool_cb f)
+ elt##.onblur := bool_cb f
+
let onscroll elt f =
let elt = get_elt "Ev.onscroll" elt in
- elt##.onscroll := (bool_cb f)
+ elt##.onscroll := bool_cb f
+
let onreturn elt f =
let f ev =
- let key = ev##.keyCode in
- if key = 13 then f ev;
- true in
+ let key = ev##.keyCode in
+ if key = 13 then f ev;
+ true
+ in
onkeydown elt f
+
let onchange elt f =
let elt = get_elt_input "Ev.onchange" elt in
- elt##.onchange := (bool_cb f)
+ elt##.onchange := bool_cb f
+
let onchange_select elt f =
let elt = get_elt_select "Ev.onchange_select" elt in
- elt##.onchange := (bool_cb f)
+ elt##.onchange := bool_cb f
+
let oninput elt f =
let elt = get_elt_input "Ev.oninput" elt in
- elt##.oninput := (bool_cb f)
+ elt##.oninput := bool_cb f
end
module Attr = struct
let clientWidth elt =
let elt = get_elt "Attr.clientWidth" elt in
elt##.clientWidth
+
let clientHeight elt =
let elt = get_elt "Attr.clientHeight" elt in
elt##.clientHeight
+
let offsetWidth elt =
let elt = get_elt "Attr.offsetWidth" elt in
elt##.offsetWidth
+
let offsetHeight elt =
let elt = get_elt "Attr.offsetHeight" elt in
elt##.offsetHeight
+
let clientLeft elt =
let elt = get_elt "Attr.clientLeft" elt in
elt##.clientLeft
+
let clientTop elt =
let elt = get_elt "Attr.clientTop" elt in
elt##.clientTop
@@ -464,667 +502,902 @@ module Manip = struct
module Css = struct
let background elt =
let elt = get_elt "Css.background" elt in
- Js.to_bytestring (elt##.style##.background)
+ Js.to_bytestring elt##.style##.background
+
let backgroundAttachment elt =
let elt = get_elt "Css.backgroundAttachment" elt in
- Js.to_bytestring (elt##.style##.backgroundAttachment)
+ Js.to_bytestring elt##.style##.backgroundAttachment
+
let backgroundColor elt =
let elt = get_elt "Css.backgroundColor" elt in
- Js.to_bytestring (elt##.style##.backgroundColor)
+ Js.to_bytestring elt##.style##.backgroundColor
+
let backgroundImage elt =
let elt = get_elt "Css.backgroundImage" elt in
- Js.to_bytestring (elt##.style##.backgroundImage)
+ Js.to_bytestring elt##.style##.backgroundImage
+
let backgroundPosition elt =
let elt = get_elt "Css.backgroundPosition" elt in
- Js.to_bytestring (elt##.style##.backgroundPosition)
+ Js.to_bytestring elt##.style##.backgroundPosition
+
let backgroundRepeat elt =
let elt = get_elt "Css.backgroundRepeat" elt in
- Js.to_bytestring (elt##.style##.backgroundRepeat)
+ Js.to_bytestring elt##.style##.backgroundRepeat
+
let border elt =
let elt = get_elt "Css.border" elt in
- Js.to_bytestring (elt##.style##.border)
+ Js.to_bytestring elt##.style##.border
+
let borderBottom elt =
let elt = get_elt "Css.borderBottom" elt in
- Js.to_bytestring (elt##.style##.borderBottom)
+ Js.to_bytestring elt##.style##.borderBottom
+
let borderBottomColor elt =
let elt = get_elt "Css.borderBottomColor" elt in
- Js.to_bytestring (elt##.style##.borderBottomColor)
+ Js.to_bytestring elt##.style##.borderBottomColor
+
let borderBottomStyle elt =
let elt = get_elt "Css.borderBottomStyle" elt in
- Js.to_bytestring (elt##.style##.borderBottomStyle)
+ Js.to_bytestring elt##.style##.borderBottomStyle
+
let borderBottomWidth elt =
let elt = get_elt "Css.borderBottomWidth" elt in
- Js.to_bytestring (elt##.style##.borderBottomWidth)
+ Js.to_bytestring elt##.style##.borderBottomWidth
+
let borderBottomWidthPx elt =
let elt = get_elt "Css.borderBottomWidthPx" elt in
- Js.parseInt (elt##.style##.borderBottomWidth)
+ Js.parseInt elt##.style##.borderBottomWidth
+
let borderCollapse elt =
let elt = get_elt "Css.borderCollapse" elt in
- Js.to_bytestring (elt##.style##.borderCollapse)
+ Js.to_bytestring elt##.style##.borderCollapse
+
let borderColor elt =
let elt = get_elt "Css.borderColor" elt in
- Js.to_bytestring (elt##.style##.borderColor)
+ Js.to_bytestring elt##.style##.borderColor
+
let borderLeft elt =
let elt = get_elt "Css.borderLeft" elt in
- Js.to_bytestring (elt##.style##.borderLeft)
+ Js.to_bytestring elt##.style##.borderLeft
+
let borderLeftColor elt =
let elt = get_elt "Css.borderLeftColor" elt in
- Js.to_bytestring (elt##.style##.borderLeftColor)
+ Js.to_bytestring elt##.style##.borderLeftColor
+
let borderLeftStyle elt =
let elt = get_elt "Css.borderLeftStyle" elt in
- Js.to_bytestring (elt##.style##.borderLeftStyle)
+ Js.to_bytestring elt##.style##.borderLeftStyle
+
let borderLeftWidth elt =
let elt = get_elt "Css.borderLeftWidth" elt in
- Js.to_bytestring (elt##.style##.borderLeftWidth)
+ Js.to_bytestring elt##.style##.borderLeftWidth
+
let borderLeftWidthPx elt =
let elt = get_elt "Css.borderLeftWidthPx" elt in
- Js.parseInt (elt##.style##.borderLeftWidth)
+ Js.parseInt elt##.style##.borderLeftWidth
+
let borderRight elt =
let elt = get_elt "Css.borderRight" elt in
- Js.to_bytestring (elt##.style##.borderRight)
+ Js.to_bytestring elt##.style##.borderRight
+
let borderRightColor elt =
let elt = get_elt "Css.borderRightColor" elt in
- Js.to_bytestring (elt##.style##.borderRightColor)
+ Js.to_bytestring elt##.style##.borderRightColor
+
let borderRightStyle elt =
let elt = get_elt "Css.borderRightStyle" elt in
- Js.to_bytestring (elt##.style##.borderRightStyle)
+ Js.to_bytestring elt##.style##.borderRightStyle
+
let borderRightWidth elt =
let elt = get_elt "Css.borderRightWidth" elt in
- Js.to_bytestring (elt##.style##.borderRightWidth)
+ Js.to_bytestring elt##.style##.borderRightWidth
+
let borderRightWidthPx elt =
let elt = get_elt "Css.borderRightWidthPx" elt in
- Js.parseInt (elt##.style##.borderRightWidth)
+ Js.parseInt elt##.style##.borderRightWidth
+
let borderSpacing elt =
let elt = get_elt "Css.borderSpacing" elt in
- Js.to_bytestring (elt##.style##.borderSpacing)
+ Js.to_bytestring elt##.style##.borderSpacing
+
let borderStyle elt =
let elt = get_elt "Css.borderStyle" elt in
- Js.to_bytestring (elt##.style##.borderStyle)
+ Js.to_bytestring elt##.style##.borderStyle
+
let borderTop elt =
let elt = get_elt "Css.borderTop" elt in
- Js.to_bytestring (elt##.style##.borderTop)
+ Js.to_bytestring elt##.style##.borderTop
+
let borderTopColor elt =
let elt = get_elt "Css.borderTopColor" elt in
- Js.to_bytestring (elt##.style##.borderTopColor)
+ Js.to_bytestring elt##.style##.borderTopColor
+
let borderTopStyle elt =
let elt = get_elt "Css.borderTopStyle" elt in
- Js.to_bytestring (elt##.style##.borderTopStyle)
+ Js.to_bytestring elt##.style##.borderTopStyle
+
let borderTopWidth elt =
let elt = get_elt "Css.borderTopWidth" elt in
- Js.to_bytestring (elt##.style##.borderTopWidth)
+ Js.to_bytestring elt##.style##.borderTopWidth
+
let borderTopWidthPx elt =
let elt = get_elt "Css.borderTopWidthPx" elt in
- Js.parseInt (elt##.style##.borderTopWidth)
+ Js.parseInt elt##.style##.borderTopWidth
+
let borderWidth elt =
let elt = get_elt "Css.borderWidth" elt in
- Js.to_bytestring (elt##.style##.borderWidth)
+ Js.to_bytestring elt##.style##.borderWidth
+
let borderWidthPx elt =
let elt = get_elt "Css.borderWidthPx" elt in
- Js.parseInt (elt##.style##.borderWidth)
+ Js.parseInt elt##.style##.borderWidth
+
let bottom elt =
let elt = get_elt "Css.bottom" elt in
- Js.to_bytestring (elt##.style##.bottom)
+ Js.to_bytestring elt##.style##.bottom
+
let captionSide elt =
let elt = get_elt "Css.captionSide" elt in
- Js.to_bytestring (elt##.style##.captionSide)
+ Js.to_bytestring elt##.style##.captionSide
+
let clear elt =
let elt = get_elt "Css.clear" elt in
- Js.to_bytestring (elt##.style##.clear)
+ Js.to_bytestring elt##.style##.clear
+
let clip elt =
let elt = get_elt "Css.clip" elt in
- Js.to_bytestring (elt##.style##.clip)
+ Js.to_bytestring elt##.style##.clip
+
let color elt =
let elt = get_elt "Css.color" elt in
- Js.to_bytestring (elt##.style##.color)
+ Js.to_bytestring elt##.style##.color
+
let content elt =
let elt = get_elt "Css.content" elt in
- Js.to_bytestring (elt##.style##.content)
+ Js.to_bytestring elt##.style##.content
+
let counterIncrement elt =
let elt = get_elt "Css.counterIncrement" elt in
- Js.to_bytestring (elt##.style##.counterIncrement)
+ Js.to_bytestring elt##.style##.counterIncrement
+
let counterReset elt =
let elt = get_elt "Css.counterReset" elt in
- Js.to_bytestring (elt##.style##.counterReset)
+ Js.to_bytestring elt##.style##.counterReset
+
let cssFloat elt =
let elt = get_elt "Css.cssFloat" elt in
- Js.to_bytestring (elt##.style##.cssFloat)
+ Js.to_bytestring elt##.style##.cssFloat
+
let cssText elt =
let elt = get_elt "Css.cssText" elt in
- Js.to_bytestring (elt##.style##.cssText)
+ Js.to_bytestring elt##.style##.cssText
+
let cursor elt =
let elt = get_elt "Css.cursor" elt in
- Js.to_bytestring (elt##.style##.cursor)
+ Js.to_bytestring elt##.style##.cursor
+
let direction elt =
let elt = get_elt "Css.direction" elt in
- Js.to_bytestring (elt##.style##.direction)
+ Js.to_bytestring elt##.style##.direction
+
let display elt =
let elt = get_elt "Css.display" elt in
- Js.to_bytestring (elt##.style##.display)
+ Js.to_bytestring elt##.style##.display
+
let emptyCells elt =
let elt = get_elt "Css.emptyCells" elt in
- Js.to_bytestring (elt##.style##.emptyCells)
+ Js.to_bytestring elt##.style##.emptyCells
+
let font elt =
let elt = get_elt "Css.font" elt in
- Js.to_bytestring (elt##.style##.font)
+ Js.to_bytestring elt##.style##.font
+
let fontFamily elt =
let elt = get_elt "Css.fontFamily" elt in
- Js.to_bytestring (elt##.style##.fontFamily)
+ Js.to_bytestring elt##.style##.fontFamily
+
let fontSize elt =
let elt = get_elt "Css.fontSize" elt in
- Js.to_bytestring (elt##.style##.fontSize)
+ Js.to_bytestring elt##.style##.fontSize
+
let fontStyle elt =
let elt = get_elt "Css.fontStyle" elt in
- Js.to_bytestring (elt##.style##.fontStyle)
+ Js.to_bytestring elt##.style##.fontStyle
+
let fontVariant elt =
let elt = get_elt "Css.fontVariant" elt in
- Js.to_bytestring (elt##.style##.fontVariant)
+ Js.to_bytestring elt##.style##.fontVariant
+
let fontWeight elt =
let elt = get_elt "Css.fontWeight" elt in
- Js.to_bytestring (elt##.style##.fontWeight)
+ Js.to_bytestring elt##.style##.fontWeight
+
let height elt =
let elt = get_elt "Css.height" elt in
- Js.to_bytestring (elt##.style##.height)
+ Js.to_bytestring elt##.style##.height
+
let heightPx elt =
let elt = get_elt "Css.heightPx" elt in
- Js.parseInt (elt##.style##.height)
+ Js.parseInt elt##.style##.height
+
let left elt =
let elt = get_elt "Css.left" elt in
- Js.to_bytestring (elt##.style##.left)
+ Js.to_bytestring elt##.style##.left
+
let leftPx elt =
let elt = get_elt "Css.leftPx" elt in
- Js.parseInt (elt##.style##.left)
+ Js.parseInt elt##.style##.left
+
let letterSpacing elt =
let elt = get_elt "Css.letterSpacing" elt in
- Js.to_bytestring (elt##.style##.letterSpacing)
+ Js.to_bytestring elt##.style##.letterSpacing
+
let lineHeight elt =
let elt = get_elt "Css.lineHeight" elt in
- Js.to_bytestring (elt##.style##.lineHeight)
+ Js.to_bytestring elt##.style##.lineHeight
+
let listStyle elt =
let elt = get_elt "Css.listStyle" elt in
- Js.to_bytestring (elt##.style##.listStyle)
+ Js.to_bytestring elt##.style##.listStyle
+
let listStyleImage elt =
let elt = get_elt "Css.listStyleImage" elt in
- Js.to_bytestring (elt##.style##.listStyleImage)
+ Js.to_bytestring elt##.style##.listStyleImage
+
let listStylePosition elt =
let elt = get_elt "Css.listStylePosition" elt in
- Js.to_bytestring (elt##.style##.listStylePosition)
+ Js.to_bytestring elt##.style##.listStylePosition
+
let listStyleType elt =
let elt = get_elt "Css.listStyleType" elt in
- Js.to_bytestring (elt##.style##.listStyleType)
+ Js.to_bytestring elt##.style##.listStyleType
+
let margin elt =
let elt = get_elt "Css.margin" elt in
- Js.to_bytestring (elt##.style##.margin)
+ Js.to_bytestring elt##.style##.margin
+
let marginBottom elt =
let elt = get_elt "Css.marginBottom" elt in
- Js.to_bytestring (elt##.style##.marginBottom)
+ Js.to_bytestring elt##.style##.marginBottom
+
let marginBottomPx elt =
let elt = get_elt "Css.marginBottomPx" elt in
- Js.parseInt (elt##.style##.marginBottom)
+ Js.parseInt elt##.style##.marginBottom
+
let marginLeft elt =
let elt = get_elt "Css.marginLeft" elt in
- Js.to_bytestring (elt##.style##.marginLeft)
+ Js.to_bytestring elt##.style##.marginLeft
+
let marginLeftPx elt =
let elt = get_elt "Css.marginLeftPx" elt in
- Js.parseInt (elt##.style##.marginLeft)
+ Js.parseInt elt##.style##.marginLeft
+
let marginRight elt =
let elt = get_elt "Css.marginRight" elt in
- Js.to_bytestring (elt##.style##.marginRight)
+ Js.to_bytestring elt##.style##.marginRight
+
let marginRightPx elt =
let elt = get_elt "Css.marginRightPx" elt in
- Js.parseInt (elt##.style##.marginRight)
+ Js.parseInt elt##.style##.marginRight
+
let marginTop elt =
let elt = get_elt "Css.marginTop" elt in
- Js.to_bytestring (elt##.style##.marginTop)
+ Js.to_bytestring elt##.style##.marginTop
+
let marginTopPx elt =
let elt = get_elt "Css.marginTopPx" elt in
- Js.parseInt (elt##.style##.marginTop)
+ Js.parseInt elt##.style##.marginTop
+
let maxHeight elt =
let elt = get_elt "Css.maxHeight" elt in
- Js.to_bytestring (elt##.style##.maxHeight)
+ Js.to_bytestring elt##.style##.maxHeight
+
let maxHeightPx elt =
let elt = get_elt "Css.maxHeightPx" elt in
- Js.parseInt (elt##.style##.maxHeight)
+ Js.parseInt elt##.style##.maxHeight
+
let maxWidth elt =
let elt = get_elt "Css.maxWidth" elt in
- Js.to_bytestring (elt##.style##.maxWidth)
+ Js.to_bytestring elt##.style##.maxWidth
+
let maxWidthPx elt =
let elt = get_elt "Css.maxWidthPx" elt in
- Js.parseInt (elt##.style##.maxWidth)
+ Js.parseInt elt##.style##.maxWidth
+
let minHeight elt =
let elt = get_elt "Css.minHeight" elt in
- Js.to_bytestring (elt##.style##.minHeight)
+ Js.to_bytestring elt##.style##.minHeight
+
let minHeightPx elt =
let elt = get_elt "Css.minHeightPx" elt in
- Js.parseInt (elt##.style##.minHeight)
+ Js.parseInt elt##.style##.minHeight
+
let minWidth elt =
let elt = get_elt "Css.minWidth" elt in
- Js.to_bytestring (elt##.style##.minWidth)
+ Js.to_bytestring elt##.style##.minWidth
+
let minWidthPx elt =
let elt = get_elt "Css.minWidthPx" elt in
- Js.parseInt (elt##.style##.minWidth)
+ Js.parseInt elt##.style##.minWidth
+
let opacity elt =
let elt = get_elt "Css.opacity" elt in
- option_map Js.to_bytestring (Js.Optdef.to_option (elt##.style##.opacity))
+ option_map Js.to_bytestring (Js.Optdef.to_option elt##.style##.opacity)
+
let outline elt =
let elt = get_elt "Css.outline" elt in
- Js.to_bytestring (elt##.style##.outline)
+ Js.to_bytestring elt##.style##.outline
+
let outlineColor elt =
let elt = get_elt "Css.outlineColor" elt in
- Js.to_bytestring (elt##.style##.outlineColor)
+ Js.to_bytestring elt##.style##.outlineColor
+
let outlineOffset elt =
let elt = get_elt "Css.outlineOffset" elt in
- Js.to_bytestring (elt##.style##.outlineOffset)
+ Js.to_bytestring elt##.style##.outlineOffset
+
let outlineStyle elt =
let elt = get_elt "Css.outlineStyle" elt in
- Js.to_bytestring (elt##.style##.outlineStyle)
+ Js.to_bytestring elt##.style##.outlineStyle
+
let outlineWidth elt =
let elt = get_elt "Css.outlineWidth" elt in
- Js.to_bytestring (elt##.style##.outlineWidth)
+ Js.to_bytestring elt##.style##.outlineWidth
+
let overflow elt =
let elt = get_elt "Css.overflow" elt in
- Js.to_bytestring (elt##.style##.overflow)
+ Js.to_bytestring elt##.style##.overflow
+
let overflowX elt =
let elt = get_elt "Css.overflowX" elt in
- Js.to_bytestring (elt##.style##.overflowX)
+ Js.to_bytestring elt##.style##.overflowX
+
let overflowY elt =
let elt = get_elt "Css.overflowY" elt in
- Js.to_bytestring (elt##.style##.overflowY)
+ Js.to_bytestring elt##.style##.overflowY
+
let padding elt =
let elt = get_elt "Css.padding" elt in
- Js.to_bytestring (elt##.style##.padding)
+ Js.to_bytestring elt##.style##.padding
+
let paddingBottom elt =
let elt = get_elt "Css.paddingBottom" elt in
- Js.to_bytestring (elt##.style##.paddingBottom)
+ Js.to_bytestring elt##.style##.paddingBottom
+
let paddingBottomPx elt =
let elt = get_elt "Css.paddingBottomPx" elt in
- Js.parseInt (elt##.style##.paddingBottom)
+ Js.parseInt elt##.style##.paddingBottom
+
let paddingLeft elt =
let elt = get_elt "Css.paddingLeft" elt in
- Js.to_bytestring (elt##.style##.paddingLeft)
+ Js.to_bytestring elt##.style##.paddingLeft
+
let paddingLeftPx elt =
let elt = get_elt "Css.paddingLeftPx" elt in
- Js.parseInt (elt##.style##.paddingLeft)
+ Js.parseInt elt##.style##.paddingLeft
+
let paddingRight elt =
let elt = get_elt "Css.paddingRight" elt in
- Js.to_bytestring (elt##.style##.paddingRight)
+ Js.to_bytestring elt##.style##.paddingRight
+
let paddingRightPx elt =
let elt = get_elt "Css.paddingRightPx" elt in
- Js.parseInt (elt##.style##.paddingRight)
+ Js.parseInt elt##.style##.paddingRight
+
let paddingTop elt =
let elt = get_elt "Css.paddingTop" elt in
- Js.to_bytestring (elt##.style##.paddingTop)
+ Js.to_bytestring elt##.style##.paddingTop
+
let paddingTopPx elt =
let elt = get_elt "Css.paddingTopPx" elt in
- Js.parseInt (elt##.style##.paddingTop)
+ Js.parseInt elt##.style##.paddingTop
+
let pageBreakAfter elt =
let elt = get_elt "Css.pageBreakAfter" elt in
- Js.to_bytestring (elt##.style##.pageBreakAfter)
+ Js.to_bytestring elt##.style##.pageBreakAfter
+
let pageBreakBefore elt =
let elt = get_elt "Css.pageBreakBefore" elt in
- Js.to_bytestring (elt##.style##.pageBreakBefore)
+ Js.to_bytestring elt##.style##.pageBreakBefore
+
let position elt =
let elt = get_elt "Css.position" elt in
- Js.to_bytestring (elt##.style##.position)
+ Js.to_bytestring elt##.style##.position
+
let right elt =
let elt = get_elt "Css.right" elt in
- Js.to_bytestring (elt##.style##.right)
+ Js.to_bytestring elt##.style##.right
+
let rightPx elt =
let elt = get_elt "Css.rightPx" elt in
- Js.parseInt (elt##.style##.right)
+ Js.parseInt elt##.style##.right
+
let tableLayout elt =
let elt = get_elt "Css.tableLayout" elt in
- Js.to_bytestring (elt##.style##.tableLayout)
+ Js.to_bytestring elt##.style##.tableLayout
+
let textAlign elt =
let elt = get_elt "Css.textAlign" elt in
- Js.to_bytestring (elt##.style##.textAlign)
+ Js.to_bytestring elt##.style##.textAlign
+
let textDecoration elt =
let elt = get_elt "Css.textDecoration" elt in
- Js.to_bytestring (elt##.style##.textDecoration)
+ Js.to_bytestring elt##.style##.textDecoration
+
let textIndent elt =
let elt = get_elt "Css.textIndent" elt in
- Js.to_bytestring (elt##.style##.textIndent)
+ Js.to_bytestring elt##.style##.textIndent
+
let textTransform elt =
let elt = get_elt "Css.textTransform" elt in
- Js.to_bytestring (elt##.style##.textTransform)
+ Js.to_bytestring elt##.style##.textTransform
+
let top elt =
let elt = get_elt "Css.top" elt in
- Js.to_bytestring (elt##.style##.top)
+ Js.to_bytestring elt##.style##.top
+
let topPx elt =
let elt = get_elt "Css.topPx" elt in
- Js.parseInt (elt##.style##.top)
+ Js.parseInt elt##.style##.top
+
let verticalAlign elt =
let elt = get_elt "Css.verticalAlign" elt in
- Js.to_bytestring (elt##.style##.verticalAlign)
+ Js.to_bytestring elt##.style##.verticalAlign
+
let visibility elt =
let elt = get_elt "Css.visibility" elt in
- Js.to_bytestring (elt##.style##.visibility)
+ Js.to_bytestring elt##.style##.visibility
+
let whiteSpace elt =
let elt = get_elt "Css.whiteSpace" elt in
- Js.to_bytestring (elt##.style##.whiteSpace)
+ Js.to_bytestring elt##.style##.whiteSpace
+
let width elt =
let elt = get_elt "Css.width" elt in
- Js.to_bytestring (elt##.style##.width)
+ Js.to_bytestring elt##.style##.width
+
let widthPx elt =
let elt = get_elt "Css.widthPx" elt in
- Js.parseInt (elt##.style##.width)
+ Js.parseInt elt##.style##.width
+
let wordSpacing elt =
let elt = get_elt "Css.wordSpacing" elt in
- Js.to_bytestring (elt##.style##.wordSpacing)
+ Js.to_bytestring elt##.style##.wordSpacing
+
let zIndex elt =
let elt = get_elt "Css.zIndex" elt in
- Js.to_bytestring (elt##.style##.zIndex)
+ Js.to_bytestring elt##.style##.zIndex
end
module SetCss = struct
let background elt v =
let elt = get_elt "SetCss.background" elt in
elt##.style##.background := Js.bytestring v
+
let backgroundAttachment elt v =
let elt = get_elt "SetCss.backgroundAttachment" elt in
elt##.style##.backgroundAttachment := Js.bytestring v
+
let backgroundColor elt v =
let elt = get_elt "SetCss.backgroundColor" elt in
elt##.style##.backgroundColor := Js.bytestring v
+
let backgroundImage elt v =
let elt = get_elt "SetCss.backgroundImage" elt in
elt##.style##.backgroundImage := Js.bytestring v
+
let backgroundPosition elt v =
let elt = get_elt "SetCss.backgroundPosition" elt in
elt##.style##.backgroundPosition := Js.bytestring v
+
let backgroundRepeat elt v =
let elt = get_elt "SetCss.backgroundRepeat" elt in
elt##.style##.backgroundRepeat := Js.bytestring v
+
let border elt v =
let elt = get_elt "SetCss.border" elt in
elt##.style##.border := Js.bytestring v
+
let borderBottom elt v =
let elt = get_elt "SetCss.borderBottom" elt in
elt##.style##.borderBottom := Js.bytestring v
+
let borderBottomColor elt v =
let elt = get_elt "SetCss.borderBottomColor" elt in
elt##.style##.borderBottomColor := Js.bytestring v
+
let borderBottomStyle elt v =
let elt = get_elt "SetCss.borderBottomStyle" elt in
elt##.style##.borderBottomStyle := Js.bytestring v
+
let borderBottomWidth elt v =
let elt = get_elt "SetCss.borderBottomWidth" elt in
elt##.style##.borderBottomWidth := Js.bytestring v
- let borderBottomWidthPx elt v = borderBottomWidth elt (Printf.sprintf "%dpx" v)
+
+ let borderBottomWidthPx elt v =
+ borderBottomWidth elt (Printf.sprintf "%dpx" v)
+
let borderCollapse elt v =
let elt = get_elt "SetCss.borderCollapse" elt in
elt##.style##.borderCollapse := Js.bytestring v
+
let borderColor elt v =
let elt = get_elt "SetCss.borderColor" elt in
elt##.style##.borderColor := Js.bytestring v
+
let borderLeft elt v =
let elt = get_elt "SetCss.borderLeft" elt in
elt##.style##.borderLeft := Js.bytestring v
+
let borderLeftColor elt v =
let elt = get_elt "SetCss.borderLeftColor" elt in
elt##.style##.borderLeftColor := Js.bytestring v
+
let borderLeftStyle elt v =
let elt = get_elt "SetCss.borderLeftStyle" elt in
elt##.style##.borderLeftStyle := Js.bytestring v
+
let borderLeftWidth elt v =
let elt = get_elt "SetCss.borderLeftWidth" elt in
elt##.style##.borderLeftWidth := Js.bytestring v
+
let borderLeftWidthPx elt v = borderLeftWidth elt (Printf.sprintf "%dpx" v)
+
let borderRight elt v =
let elt = get_elt "SetCss.borderRight" elt in
elt##.style##.borderRight := Js.bytestring v
+
let borderRightColor elt v =
let elt = get_elt "SetCss.borderRightColor" elt in
elt##.style##.borderRightColor := Js.bytestring v
+
let borderRightStyle elt v =
let elt = get_elt "SetCss.borderRightStyle" elt in
elt##.style##.borderRightStyle := Js.bytestring v
+
let borderRightWidth elt v =
let elt = get_elt "SetCss.borderRightWidth" elt in
elt##.style##.borderRightWidth := Js.bytestring v
- let borderRightWidthPx elt v = borderRightWidth elt (Printf.sprintf "%dpx" v)
+
+ let borderRightWidthPx elt v =
+ borderRightWidth elt (Printf.sprintf "%dpx" v)
+
let borderSpacing elt v =
let elt = get_elt "SetCss.borderSpacing" elt in
elt##.style##.borderSpacing := Js.bytestring v
+
let borderStyle elt v =
let elt = get_elt "SetCss.borderStyle" elt in
elt##.style##.borderStyle := Js.bytestring v
+
let borderTop elt v =
let elt = get_elt "SetCss.borderTop" elt in
elt##.style##.borderTop := Js.bytestring v
+
let borderTopColor elt v =
let elt = get_elt "SetCss.borderTopColor" elt in
elt##.style##.borderTopColor := Js.bytestring v
+
let borderTopStyle elt v =
let elt = get_elt "SetCss.borderTopStyle" elt in
elt##.style##.borderTopStyle := Js.bytestring v
+
let borderTopWidth elt v =
let elt = get_elt "SetCss.borderTopWidth" elt in
elt##.style##.borderTopWidth := Js.bytestring v
+
let borderTopWidthPx elt v = borderTopWidth elt (Printf.sprintf "%dpx" v)
+
let borderWidth elt v =
let elt = get_elt "SetCss.borderWidth" elt in
elt##.style##.borderWidth := Js.bytestring v
+
let bottom elt v =
let elt = get_elt "SetCss.bottom" elt in
elt##.style##.bottom := Js.bytestring v
+
let bottomPx elt v = bottom elt (Printf.sprintf "%dpx" v)
+
let captionSide elt v =
let elt = get_elt "SetCss.captionSide" elt in
elt##.style##.captionSide := Js.bytestring v
+
let clear elt v =
let elt = get_elt "SetCss.clear" elt in
elt##.style##.clear := Js.bytestring v
+
let clip elt v =
let elt = get_elt "SetCss.clip" elt in
elt##.style##.clip := Js.bytestring v
+
let color elt v =
let elt = get_elt "SetCss.color" elt in
elt##.style##.color := Js.bytestring v
+
let content elt v =
let elt = get_elt "SetCss.content" elt in
elt##.style##.content := Js.bytestring v
+
let counterIncrement elt v =
let elt = get_elt "SetCss.counterIncrement" elt in
elt##.style##.counterIncrement := Js.bytestring v
+
let counterReset elt v =
let elt = get_elt "SetCss.counterReset" elt in
elt##.style##.counterReset := Js.bytestring v
+
let cssFloat elt v =
let elt = get_elt "SetCss.cssFloat" elt in
elt##.style##.cssFloat := Js.bytestring v
+
let cssText elt v =
let elt = get_elt "SetCss.cssText" elt in
elt##.style##.cssText := Js.bytestring v
+
let cursor elt v =
let elt = get_elt "SetCss.cursor" elt in
elt##.style##.cursor := Js.bytestring v
+
let direction elt v =
let elt = get_elt "SetCss.direction" elt in
elt##.style##.direction := Js.bytestring v
+
let display elt v =
let elt = get_elt "SetCss.display" elt in
elt##.style##.display := Js.bytestring v
+
let emptyCells elt v =
let elt = get_elt "SetCss.emptyCells" elt in
elt##.style##.emptyCells := Js.bytestring v
+
let font elt v =
let elt = get_elt "SetCss.font" elt in
elt##.style##.font := Js.bytestring v
+
let fontFamily elt v =
let elt = get_elt "SetCss.fontFamily" elt in
elt##.style##.fontFamily := Js.bytestring v
+
let fontSize elt v =
let elt = get_elt "SetCss.fontSize" elt in
elt##.style##.fontSize := Js.bytestring v
+
let fontStyle elt v =
let elt = get_elt "SetCss.fontStyle" elt in
elt##.style##.fontStyle := Js.bytestring v
+
let fontVariant elt v =
let elt = get_elt "SetCss.fontVariant" elt in
elt##.style##.fontVariant := Js.bytestring v
+
let fontWeight elt v =
let elt = get_elt "SetCss.fontWeight" elt in
elt##.style##.fontWeight := Js.bytestring v
+
let height elt v =
let elt = get_elt "SetCss.height" elt in
elt##.style##.height := Js.bytestring v
+
let heightPx elt v = height elt (Printf.sprintf "%dpx" v)
+
let left elt v =
let elt = get_elt "SetCss.left" elt in
elt##.style##.left := Js.bytestring v
+
let leftPx elt v = left elt (Printf.sprintf "%dpx" v)
+
let letterSpacing elt v =
let elt = get_elt "SetCss.letterSpacing" elt in
elt##.style##.letterSpacing := Js.bytestring v
+
let lineHeight elt v =
let elt = get_elt "SetCss.lineHeight" elt in
elt##.style##.lineHeight := Js.bytestring v
+
let listStyle elt v =
let elt = get_elt "SetCss.listStyle" elt in
elt##.style##.listStyle := Js.bytestring v
+
let listStyleImage elt v =
let elt = get_elt "SetCss.listStyleImage" elt in
elt##.style##.listStyleImage := Js.bytestring v
+
let listStylePosition elt v =
let elt = get_elt "SetCss.listStylePosition" elt in
elt##.style##.listStylePosition := Js.bytestring v
+
let listStyleType elt v =
let elt = get_elt "SetCss.listStyleType" elt in
elt##.style##.listStyleType := Js.bytestring v
+
let margin elt v =
let elt = get_elt "SetCss.margin" elt in
elt##.style##.margin := Js.bytestring v
+
let marginBottom elt v =
let elt = get_elt "SetCss.marginBottom" elt in
elt##.style##.marginBottom := Js.bytestring v
+
let marginBottomPx elt v = marginBottom elt (Printf.sprintf "%dpx" v)
+
let marginLeft elt v =
let elt = get_elt "SetCss.marginLeft" elt in
elt##.style##.marginLeft := Js.bytestring v
+
let marginLeftPx elt v = marginLeft elt (Printf.sprintf "%dpx" v)
+
let marginRight elt v =
let elt = get_elt "SetCss.marginRight" elt in
elt##.style##.marginRight := Js.bytestring v
+
let marginRightPx elt v = marginRight elt (Printf.sprintf "%dpx" v)
+
let marginTop elt v =
let elt = get_elt "SetCss.marginTop" elt in
elt##.style##.marginTop := Js.bytestring v
+
let marginTopPx elt v = marginTop elt (Printf.sprintf "%dpx" v)
+
let maxHeight elt v =
let elt = get_elt "SetCss.maxHeight" elt in
elt##.style##.maxHeight := Js.bytestring v
+
let maxHeightPx elt v = maxHeight elt (Printf.sprintf "%dpx" v)
+
let maxWidth elt v =
let elt = get_elt "SetCss.maxWidth" elt in
elt##.style##.maxWidth := Js.bytestring v
+
let maxWidthPx elt v = maxWidth elt (Printf.sprintf "%dpx" v)
+
let minHeight elt v =
let elt = get_elt "SetCss.minHeight" elt in
elt##.style##.minHeight := Js.bytestring v
+
let minHeightPx elt v = minHeight elt (Printf.sprintf "%dpx" v)
+
let minWidth elt v =
let elt = get_elt "SetCss.minWidth" elt in
elt##.style##.minWidth := Js.bytestring v
+
let minWidthPx elt v = minWidth elt (Printf.sprintf "%dpx" v)
+
let opacity elt v =
let elt = get_elt "SetCss.opacity" elt in
- elt##.style##.opacity := match v with None -> Js.undefined | Some v -> Js.def (Js.bytestring v)
+ elt##.style##.opacity
+ :=
+ match v with None -> Js.undefined | Some v -> Js.def (Js.bytestring v)
+
let outline elt v =
let elt = get_elt "SetCss.outline" elt in
elt##.style##.outline := Js.bytestring v
+
let outlineColor elt v =
let elt = get_elt "SetCss.outlineColor" elt in
elt##.style##.outlineColor := Js.bytestring v
+
let outlineOffset elt v =
let elt = get_elt "SetCss.outlineOffset" elt in
elt##.style##.outlineOffset := Js.bytestring v
+
let outlineStyle elt v =
let elt = get_elt "SetCss.outlineStyle" elt in
elt##.style##.outlineStyle := Js.bytestring v
+
let outlineWidth elt v =
let elt = get_elt "SetCss.outlineWidth" elt in
elt##.style##.outlineWidth := Js.bytestring v
+
let overflow elt v =
let elt = get_elt "SetCss.overflow" elt in
elt##.style##.overflow := Js.bytestring v
+
let overflowX elt v =
let elt = get_elt "SetCss.overflowX" elt in
elt##.style##.overflowX := Js.bytestring v
+
let overflowY elt v =
let elt = get_elt "SetCss.overflowY" elt in
elt##.style##.overflowY := Js.bytestring v
+
let padding elt v =
let elt = get_elt "SetCss.padding" elt in
elt##.style##.padding := Js.bytestring v
+
let paddingBottom elt v =
let elt = get_elt "SetCss.paddingBottom" elt in
elt##.style##.paddingBottom := Js.bytestring v
+
let paddingBottomPx elt v = paddingBottom elt (Printf.sprintf "%dpx" v)
+
let paddingLeft elt v =
let elt = get_elt "SetCss.paddingLeft" elt in
elt##.style##.paddingLeft := Js.bytestring v
+
let paddingLeftPx elt v = paddingLeft elt (Printf.sprintf "%dpx" v)
+
let paddingRight elt v =
let elt = get_elt "SetCss.paddingRight" elt in
elt##.style##.paddingRight := Js.bytestring v
+
let paddingRightPx elt v = paddingRight elt (Printf.sprintf "%dpx" v)
+
let paddingTop elt v =
let elt = get_elt "SetCss.paddingTop" elt in
elt##.style##.paddingTop := Js.bytestring v
+
let paddingTopPx elt v = paddingTop elt (Printf.sprintf "%dpx" v)
+
let pageBreakAfter elt v =
let elt = get_elt "SetCss.pageBreakAfter" elt in
elt##.style##.pageBreakAfter := Js.bytestring v
+
let pageBreakBefore elt v =
let elt = get_elt "SetCss.pageBreakBefore" elt in
elt##.style##.pageBreakBefore := Js.bytestring v
+
let position elt v =
let elt = get_elt "SetCss.position" elt in
elt##.style##.position := Js.bytestring v
+
let right elt v =
let elt = get_elt "SetCss.right" elt in
elt##.style##.right := Js.bytestring v
+
let rightPx elt v = right elt (Printf.sprintf "%dpx" v)
+
let tableLayout elt v =
let elt = get_elt "SetCss.tableLayout" elt in
elt##.style##.tableLayout := Js.bytestring v
+
let textAlign elt v =
let elt = get_elt "SetCss.textAlign" elt in
elt##.style##.textAlign := Js.bytestring v
+
let textDecoration elt v =
let elt = get_elt "SetCss.textDecoration" elt in
elt##.style##.textDecoration := Js.bytestring v
+
let textIndent elt v =
let elt = get_elt "SetCss.textIndent" elt in
elt##.style##.textIndent := Js.bytestring v
+
let textTransform elt v =
let elt = get_elt "SetCss.textTransform" elt in
elt##.style##.textTransform := Js.bytestring v
+
let top elt v =
let elt = get_elt "SetCss.top" elt in
elt##.style##.top := Js.bytestring v
+
let topPx elt v = top elt (Printf.sprintf "%dpx" v)
+
let verticalAlign elt v =
let elt = get_elt "SetCss.verticalAlign" elt in
elt##.style##.verticalAlign := Js.bytestring v
+
let visibility elt v =
let elt = get_elt "SetCss.visibility" elt in
elt##.style##.visibility := Js.bytestring v
+
let whiteSpace elt v =
let elt = get_elt "SetCss.whiteSpace" elt in
elt##.style##.whiteSpace := Js.bytestring v
+
let width elt v =
let elt = get_elt "SetCss.width" elt in
elt##.style##.width := Js.bytestring v
+
let widthPx elt v = width elt (Printf.sprintf "%dpx" v)
+
let wordSpacing elt v =
let elt = get_elt "SetCss.wordSpacing" elt in
elt##.style##.wordSpacing := Js.bytestring v
+
let zIndex elt v =
let elt = get_elt "SetCss.zIndex" elt in
elt##.style##.zIndex := Js.bytestring v
end
-
end
let hide elt = Manip.SetCss.display elt "none"
@@ -1132,43 +1405,48 @@ let hide elt = Manip.SetCss.display elt "none"
let show elt = Manip.SetCss.display elt ""
let window_open ?features url name =
- let features = match features with
- | None -> Js.null
- | Some s -> Js.some @@ Js.string s in
- window##(open_ (Js.string url) (Js.string name) features)
+ let features =
+ match features with None -> Js.null | Some s -> Js.some @@ Js.string s
+ in
+ window ## (open_ (Js.string url) (Js.string name) features)
module Window = struct
let close win = win##close
+
let body win = Tyxml_js.Of_dom.of_body win##.document##.body
+
let head win = Tyxml_js.Of_dom.of_head win##.document##.head
+
let onunload ?(win = Dom_html.window) f =
win##.onunload := Dom_html.handler (fun ev -> Js.bool (f ev))
+
let onresize ?(win = Dom_html.window) f =
win##.onresize := Dom_html.handler (fun ev -> Js.bool (f ev))
+
let prompt ?(win = Dom_html.window) ?(value = "") msg =
Js.Opt.case
- (win##(prompt (Js.string msg) (Js.string value)))
+ win ## (prompt (Js.string msg) (Js.string value))
(fun () -> "")
Js.to_string
+
let onhashchange ?(win = Dom_html.window) f =
win##.onhashchange := Dom_html.handler (fun ev -> Js.bool (f ev))
- end
-
+end
module Document = struct
- let uri () = Js.to_string (doc##._URL)
+ let uri () = Js.to_string doc##._URL
end
let parse_fragment () =
- let elts =
- Regexp.(split (regexp "(&|%26)") (Url.Current.get_fragment ())) in
+ let elts = Regexp.(split (regexp "(&|%26)") (Url.Current.get_fragment ())) in
List.fold_right
(fun elt acc ->
- if elt = "&" || elt = "%26" || elt = "" then acc else
- match Regexp.(split (regexp "(=|%3D)") elt) with
- | [name] -> (name, "") :: acc
- | name :: _ :: value -> (name, String.concat "" value) :: acc
- | _ -> assert false)
+ if elt = "&" || elt = "%26" || elt = "" then acc
+ else
+ match Regexp.(split (regexp "(=|%3D)") elt) with
+ | [name] -> (name, "") :: acc
+ | name :: _ :: value -> (name, String.concat "" value) :: acc
+ | _ -> assert false )
elts []
let set_fragment args =
@@ -1178,13 +1456,16 @@ let set_fragment args =
let local_args = ref []
-module MakeLocal(V: sig type t val name: string end) = struct
+module MakeLocal (V : sig
+ type t
+ val name : string
+end) =
+struct
let () =
if List.mem V.name !local_args then
warn "Duplicate key in LocalStorage: %s" V.name
- else
- local_args := V.name :: !local_args
+ else local_args := V.name :: !local_args
let get_storage () =
try
@@ -1193,38 +1474,42 @@ module MakeLocal(V: sig type t val name: string end) = struct
| Some t -> t
with exn ->
let msg =
- Format.sprintf
- "Warning: can't access to localStorage.\n%s@."
- (Printexc.to_string exn) in
- Firebug.console##(log (Js.string msg));
+ Format.sprintf "Warning: can't access to localStorage.\n%s@."
+ (Printexc.to_string exn)
+ in
+ Firebug.console ## (log (Js.string msg));
raise Not_found
let name = Js.string V.name
- let get (): V.t option =
+ let get () : V.t option =
try
let s = get_storage () in
- match Js.Opt.to_option (s##(getItem name)) with
+ match Js.Opt.to_option s ## (getItem name) with
| None -> None
| Some s -> Some (Json.unsafe_input s)
with Not_found -> None
- let set: V.t -> unit = fun v ->
+ let set : V.t -> unit =
+ fun v ->
try
let s = get_storage () in
let str = Json.output v in
- s##(setItem name str)
+ s ## (setItem name str)
with Not_found -> ()
-
end
let js_code_url code =
- let blob = File.blob_from_string ~contentType:"application/javascript" code in
+ let blob =
+ File.blob_from_string ~contentType:"application/javascript" code
+ in
let url = Dom_html.window##._URL##createObjectURL blob in
Js.to_string url
let worker_with_code code =
- let blob = File.blob_from_string ~contentType:"application/javascript" code in
+ let blob =
+ File.blob_from_string ~contentType:"application/javascript" code
+ in
let url = Dom_html.window##._URL##createObjectURL blob in
Worker.create (Js.to_string url)
diff --git a/src/utils/js_utils.mli b/src/utils/js_utils.mli
index f3195027a..70c08a2a1 100644
--- a/src/utils/js_utils.mli
+++ b/src/utils/js_utils.mli
@@ -18,394 +18,693 @@
open Js_of_ocaml
-val alert: string -> unit
-val confirm: string -> bool
+val alert : string -> unit
-val log: ('a, Format.formatter, unit, unit) format4 -> 'a
-val debug: ('a, Format.formatter, unit, unit) format4 -> 'a
-val warn: ('a, Format.formatter, unit, unit) format4 -> 'a
-val error: ('a, Format.formatter, unit, unit) format4 -> 'a
+val confirm : string -> bool
-val js_log: 'a -> unit
-val js_debug: 'a -> unit
-val js_warn: 'a -> unit
-val js_error: 'a -> unit
+val log : ('a, Format.formatter, unit, unit) format4 -> 'a
-val reload: unit -> unit
+val debug : ('a, Format.formatter, unit, unit) format4 -> 'a
+val warn : ('a, Format.formatter, unit, unit) format4 -> 'a
+
+val error : ('a, Format.formatter, unit, unit) format4 -> 'a
+
+val js_log : 'a -> unit
+
+val js_debug : 'a -> unit
+
+val js_warn : 'a -> unit
+
+val js_error : 'a -> unit
+
+val reload : unit -> unit
+
+val get_lang : unit -> string option
(** Gets the language configured in the browser *)
-val get_lang: unit -> string option
module Manip : sig
-
(* à la Eliom_content.Manip ... *)
open Tyxml_js.Html5
- val window: 'a elt -> Dom_html.window Js.t
+ val window : 'a elt -> Dom_html.window Js.t
+
+ val setInnerHtml : 'a elt -> string -> unit
+
+ val setInnerText : 'a elt -> string -> unit
+
+ val clone : ?deep:bool -> 'a elt -> 'a elt
+
+ val appendChild : ?before:'a elt -> 'b elt -> 'c elt -> unit
+
+ val appendToHead : ?before:'a elt -> 'c elt -> unit
+
+ val appendToBody : ?before:'a elt -> 'c elt -> unit
+
+ val appendChildren : ?before:'a elt -> 'b elt -> 'c elt list -> unit
+
+ val appendChildFirst : 'b elt -> 'c elt -> unit
+
+ val insertChildAfter : 'a elt -> 'b elt -> 'c elt -> unit
+
+ val insertChildrenAfter : 'a elt -> 'b elt -> 'c elt list -> unit
+
+ val nth : 'a elt -> int -> 'b elt option
- val setInnerHtml: 'a elt -> string -> unit
- val setInnerText: 'a elt -> string -> unit
- val clone: ?deep:bool -> 'a elt -> 'a elt
+ val childLength : 'a elt -> int
- val appendChild: ?before:'a elt -> 'b elt -> 'c elt -> unit
- val appendToHead: ?before:'a elt -> 'c elt -> unit
- val appendToBody: ?before:'a elt -> 'c elt -> unit
- val appendChildren: ?before:'a elt -> 'b elt -> 'c elt list -> unit
- val appendChildFirst: 'b elt -> 'c elt -> unit
- val insertChildAfter: 'a elt -> 'b elt -> 'c elt -> unit
- val insertChildrenAfter: 'a elt -> 'b elt -> 'c elt list -> unit
- val nth: 'a elt -> int -> 'b elt option
- val childLength: 'a elt -> int
- val removeChild: 'a elt -> 'b elt -> unit
- val replaceChild: 'a elt -> 'b elt -> 'c elt -> unit
- val replaceChildren: 'a elt -> 'b elt list -> unit
- val removeChildren: 'a elt -> unit
- val removeSelf: 'a elt -> unit
- val replaceSelf: 'a elt -> 'a elt -> unit
+ val removeChild : 'a elt -> 'b elt -> unit
- val children: 'a elt -> 'b elt list
- val by_id: string -> 'b elt option
- val by_classname: string -> 'b elt list
+ val replaceChild : 'a elt -> 'b elt -> 'c elt -> unit
- val disable: 'a elt -> unit
- val enable: 'a elt -> unit
+ val replaceChildren : 'a elt -> 'b elt list -> unit
- val value: 'a elt -> string
+ val removeChildren : 'a elt -> unit
- val hasClass: 'a elt -> string -> bool
- val addClass: 'a elt -> string -> unit
- val removeClass: 'a elt -> string -> unit
+ val removeSelf : 'a elt -> unit
- val scrollIntoView: ?bottom:bool -> 'a elt -> unit
+ val replaceSelf : 'a elt -> 'a elt -> unit
+
+ val children : 'a elt -> 'b elt list
+
+ val by_id : string -> 'b elt option
+
+ val by_classname : string -> 'b elt list
+
+ val disable : 'a elt -> unit
+
+ val enable : 'a elt -> unit
+
+ val value : 'a elt -> string
+
+ val hasClass : 'a elt -> string -> bool
+
+ val addClass : 'a elt -> string -> unit
+
+ val removeClass : 'a elt -> string -> unit
+
+ val scrollIntoView : ?bottom:bool -> 'a elt -> unit
(* Returns [true] if the class has been set, [false] if it was unset *)
- val toggleClass: 'a elt -> string -> bool
+ val toggleClass : 'a elt -> string -> bool
- val focus: 'a elt -> unit
- val blur: 'a elt -> unit
+ val focus : 'a elt -> unit
+
+ val blur : 'a elt -> unit
module Elt : sig
val body : [`Body] elt
+
val active : unit -> 'a elt
end
module Ev : sig
type ('a, 'b) ev = 'a elt -> ('b Js.t -> bool) -> unit
- type ('a,'b) ev_unit = 'a elt -> ('b Js.t -> unit) -> unit
- val onkeyup: ('a,Dom_html.keyboardEvent) ev
- val onkeydown: ('a,Dom_html.keyboardEvent) ev
- val onmouseup: ('a,Dom_html.mouseEvent) ev
- val onmousedown: ('a,Dom_html.mouseEvent) ev
- val onmouseout: ('a,Dom_html.mouseEvent) ev
- val onmouseover: ('a,Dom_html.mouseEvent) ev
- val onclick: ('a,Dom_html.mouseEvent) ev
- val ondblclick: ('a,Dom_html.mouseEvent) ev
- val onload: ('a,Dom_html.event) ev
- val onerror: ('a,Dom_html.event) ev
- val onabort: ('a,Dom_html.event) ev
- val onfocus: ('a,Dom_html.event) ev
- val onblur: ('a,Dom_html.event) ev
- val onfocus_textarea: ('a,Dom_html.event) ev
- val onblur_textarea: ('a,Dom_html.event) ev
- val onscroll: ('a,Dom_html.event) ev
- val onreturn: ('a,Dom_html.keyboardEvent) ev_unit
- val onchange: ('a,Dom_html.event) ev
- val onchange_select: ('a,Dom_html.event) ev
- val oninput: ('a,Dom_html.event) ev
+
+ type ('a, 'b) ev_unit = 'a elt -> ('b Js.t -> unit) -> unit
+
+ val onkeyup : ('a, Dom_html.keyboardEvent) ev
+
+ val onkeydown : ('a, Dom_html.keyboardEvent) ev
+
+ val onmouseup : ('a, Dom_html.mouseEvent) ev
+
+ val onmousedown : ('a, Dom_html.mouseEvent) ev
+
+ val onmouseout : ('a, Dom_html.mouseEvent) ev
+
+ val onmouseover : ('a, Dom_html.mouseEvent) ev
+
+ val onclick : ('a, Dom_html.mouseEvent) ev
+
+ val ondblclick : ('a, Dom_html.mouseEvent) ev
+
+ val onload : ('a, Dom_html.event) ev
+
+ val onerror : ('a, Dom_html.event) ev
+
+ val onabort : ('a, Dom_html.event) ev
+
+ val onfocus : ('a, Dom_html.event) ev
+
+ val onblur : ('a, Dom_html.event) ev
+
+ val onfocus_textarea : ('a, Dom_html.event) ev
+
+ val onblur_textarea : ('a, Dom_html.event) ev
+
+ val onscroll : ('a, Dom_html.event) ev
+
+ val onreturn : ('a, Dom_html.keyboardEvent) ev_unit
+
+ val onchange : ('a, Dom_html.event) ev
+
+ val onchange_select : ('a, Dom_html.event) ev
+
+ val oninput : ('a, Dom_html.event) ev
end
module Attr : sig
- val clientWidth: 'a elt -> int
- val clientHeight: 'a elt -> int
- val offsetWidth: 'a elt -> int
- val offsetHeight: 'a elt -> int
- val clientLeft: 'a elt -> int
- val clientTop: 'a elt -> int
+ val clientWidth : 'a elt -> int
+
+ val clientHeight : 'a elt -> int
+
+ val offsetWidth : 'a elt -> int
+
+ val offsetHeight : 'a elt -> int
+
+ val clientLeft : 'a elt -> int
+
+ val clientTop : 'a elt -> int
end
(** Read the CSS properties of DOM elements. *)
module Css : sig
- val background: 'a elt -> string
- val backgroundAttachment: 'a elt -> string
- val backgroundColor: 'a elt -> string
- val backgroundImage: 'a elt -> string
- val backgroundPosition: 'a elt -> string
- val backgroundRepeat: 'a elt -> string
- val border: 'a elt -> string
- val borderBottom: 'a elt -> string
- val borderBottomColor: 'a elt -> string
- val borderBottomStyle: 'a elt -> string
- val borderBottomWidth: 'a elt -> string
- val borderBottomWidthPx: 'a elt -> int
- val borderCollapse: 'a elt -> string
- val borderColor: 'a elt -> string
- val borderLeft: 'a elt -> string
- val borderLeftColor: 'a elt -> string
- val borderLeftStyle: 'a elt -> string
- val borderLeftWidth: 'a elt -> string
- val borderLeftWidthPx: 'a elt -> int
- val borderRight: 'a elt -> string
- val borderRightColor: 'a elt -> string
- val borderRightStyle: 'a elt -> string
- val borderRightWidth: 'a elt -> string
- val borderRightWidthPx: 'a elt -> int
- val borderSpacing: 'a elt -> string
- val borderStyle: 'a elt -> string
- val borderTop: 'a elt -> string
- val borderTopColor: 'a elt -> string
- val borderTopStyle: 'a elt -> string
- val borderTopWidth: 'a elt -> string
- val borderTopWidthPx: 'a elt -> int
- val borderWidth: 'a elt -> string
- val borderWidthPx: 'a elt -> int
- val bottom: 'a elt -> string
- val captionSide: 'a elt -> string
- val clear: 'a elt -> string
- val clip: 'a elt -> string
- val color: 'a elt -> string
- val content: 'a elt -> string
- val counterIncrement: 'a elt -> string
- val counterReset: 'a elt -> string
- val cssFloat: 'a elt -> string
- val cssText: 'a elt -> string
- val cursor: 'a elt -> string
- val direction: 'a elt -> string
- val display: 'a elt -> string
- val emptyCells: 'a elt -> string
- val font: 'a elt -> string
- val fontFamily: 'a elt -> string
- val fontSize: 'a elt -> string
- val fontStyle: 'a elt -> string
- val fontVariant: 'a elt -> string
- val fontWeight: 'a elt -> string
- val height: 'a elt -> string
- val heightPx: 'a elt -> int
- val left: 'a elt -> string
- val leftPx: 'a elt -> int
- val letterSpacing: 'a elt -> string
- val lineHeight: 'a elt -> string
- val listStyle: 'a elt -> string
- val listStyleImage: 'a elt -> string
- val listStylePosition: 'a elt -> string
- val listStyleType: 'a elt -> string
- val margin: 'a elt -> string
- val marginBottom: 'a elt -> string
- val marginBottomPx: 'a elt -> int
- val marginLeft: 'a elt -> string
- val marginLeftPx: 'a elt -> int
- val marginRight: 'a elt -> string
- val marginRightPx: 'a elt -> int
- val marginTop: 'a elt -> string
- val marginTopPx: 'a elt -> int
- val maxHeight: 'a elt -> string
- val maxHeightPx: 'a elt -> int
- val maxWidth: 'a elt -> string
- val maxWidthPx: 'a elt -> int
- val minHeight: 'a elt -> string
- val minHeightPx: 'a elt -> int
- val minWidth: 'a elt -> string
- val minWidthPx: 'a elt -> int
- val opacity: 'a elt -> string option
- val outline: 'a elt -> string
- val outlineColor: 'a elt -> string
- val outlineOffset: 'a elt -> string
- val outlineStyle: 'a elt -> string
- val outlineWidth: 'a elt -> string
- val overflow: 'a elt -> string
- val overflowX: 'a elt -> string
- val overflowY: 'a elt -> string
- val padding: 'a elt -> string
- val paddingBottom: 'a elt -> string
- val paddingBottomPx: 'a elt -> int
- val paddingLeft: 'a elt -> string
- val paddingLeftPx: 'a elt -> int
- val paddingRight: 'a elt -> string
- val paddingRightPx: 'a elt -> int
- val paddingTop: 'a elt -> string
- val paddingTopPx: 'a elt -> int
- val pageBreakAfter: 'a elt -> string
- val pageBreakBefore: 'a elt -> string
- val position: 'a elt -> string
- val right: 'a elt -> string
- val rightPx: 'a elt -> int
- val tableLayout: 'a elt -> string
- val textAlign: 'a elt -> string
- val textDecoration: 'a elt -> string
- val textIndent: 'a elt -> string
- val textTransform: 'a elt -> string
- val top: 'a elt -> string
- val topPx: 'a elt -> int
- val verticalAlign: 'a elt -> string
- val visibility: 'a elt -> string
- val whiteSpace: 'a elt -> string
- val width: 'a elt -> string
- val widthPx: 'a elt -> int
- val wordSpacing: 'a elt -> string
- val zIndex: 'a elt -> string
+ val background : 'a elt -> string
+
+ val backgroundAttachment : 'a elt -> string
+
+ val backgroundColor : 'a elt -> string
+
+ val backgroundImage : 'a elt -> string
+
+ val backgroundPosition : 'a elt -> string
+
+ val backgroundRepeat : 'a elt -> string
+
+ val border : 'a elt -> string
+
+ val borderBottom : 'a elt -> string
+
+ val borderBottomColor : 'a elt -> string
+
+ val borderBottomStyle : 'a elt -> string
+
+ val borderBottomWidth : 'a elt -> string
+
+ val borderBottomWidthPx : 'a elt -> int
+
+ val borderCollapse : 'a elt -> string
+
+ val borderColor : 'a elt -> string
+
+ val borderLeft : 'a elt -> string
+
+ val borderLeftColor : 'a elt -> string
+
+ val borderLeftStyle : 'a elt -> string
+
+ val borderLeftWidth : 'a elt -> string
+
+ val borderLeftWidthPx : 'a elt -> int
+
+ val borderRight : 'a elt -> string
+
+ val borderRightColor : 'a elt -> string
+
+ val borderRightStyle : 'a elt -> string
+
+ val borderRightWidth : 'a elt -> string
+
+ val borderRightWidthPx : 'a elt -> int
+
+ val borderSpacing : 'a elt -> string
+
+ val borderStyle : 'a elt -> string
+
+ val borderTop : 'a elt -> string
+
+ val borderTopColor : 'a elt -> string
+
+ val borderTopStyle : 'a elt -> string
+
+ val borderTopWidth : 'a elt -> string
+
+ val borderTopWidthPx : 'a elt -> int
+
+ val borderWidth : 'a elt -> string
+
+ val borderWidthPx : 'a elt -> int
+
+ val bottom : 'a elt -> string
+
+ val captionSide : 'a elt -> string
+
+ val clear : 'a elt -> string
+
+ val clip : 'a elt -> string
+
+ val color : 'a elt -> string
+
+ val content : 'a elt -> string
+
+ val counterIncrement : 'a elt -> string
+
+ val counterReset : 'a elt -> string
+
+ val cssFloat : 'a elt -> string
+
+ val cssText : 'a elt -> string
+
+ val cursor : 'a elt -> string
+
+ val direction : 'a elt -> string
+
+ val display : 'a elt -> string
+
+ val emptyCells : 'a elt -> string
+
+ val font : 'a elt -> string
+
+ val fontFamily : 'a elt -> string
+
+ val fontSize : 'a elt -> string
+
+ val fontStyle : 'a elt -> string
+
+ val fontVariant : 'a elt -> string
+
+ val fontWeight : 'a elt -> string
+
+ val height : 'a elt -> string
+
+ val heightPx : 'a elt -> int
+
+ val left : 'a elt -> string
+
+ val leftPx : 'a elt -> int
+
+ val letterSpacing : 'a elt -> string
+
+ val lineHeight : 'a elt -> string
+
+ val listStyle : 'a elt -> string
+
+ val listStyleImage : 'a elt -> string
+
+ val listStylePosition : 'a elt -> string
+
+ val listStyleType : 'a elt -> string
+
+ val margin : 'a elt -> string
+
+ val marginBottom : 'a elt -> string
+
+ val marginBottomPx : 'a elt -> int
+
+ val marginLeft : 'a elt -> string
+
+ val marginLeftPx : 'a elt -> int
+
+ val marginRight : 'a elt -> string
+
+ val marginRightPx : 'a elt -> int
+
+ val marginTop : 'a elt -> string
+
+ val marginTopPx : 'a elt -> int
+
+ val maxHeight : 'a elt -> string
+
+ val maxHeightPx : 'a elt -> int
+
+ val maxWidth : 'a elt -> string
+
+ val maxWidthPx : 'a elt -> int
+
+ val minHeight : 'a elt -> string
+
+ val minHeightPx : 'a elt -> int
+
+ val minWidth : 'a elt -> string
+
+ val minWidthPx : 'a elt -> int
+
+ val opacity : 'a elt -> string option
+
+ val outline : 'a elt -> string
+
+ val outlineColor : 'a elt -> string
+
+ val outlineOffset : 'a elt -> string
+
+ val outlineStyle : 'a elt -> string
+
+ val outlineWidth : 'a elt -> string
+
+ val overflow : 'a elt -> string
+
+ val overflowX : 'a elt -> string
+
+ val overflowY : 'a elt -> string
+
+ val padding : 'a elt -> string
+
+ val paddingBottom : 'a elt -> string
+
+ val paddingBottomPx : 'a elt -> int
+
+ val paddingLeft : 'a elt -> string
+
+ val paddingLeftPx : 'a elt -> int
+
+ val paddingRight : 'a elt -> string
+
+ val paddingRightPx : 'a elt -> int
+
+ val paddingTop : 'a elt -> string
+
+ val paddingTopPx : 'a elt -> int
+
+ val pageBreakAfter : 'a elt -> string
+
+ val pageBreakBefore : 'a elt -> string
+
+ val position : 'a elt -> string
+
+ val right : 'a elt -> string
+
+ val rightPx : 'a elt -> int
+
+ val tableLayout : 'a elt -> string
+
+ val textAlign : 'a elt -> string
+
+ val textDecoration : 'a elt -> string
+
+ val textIndent : 'a elt -> string
+
+ val textTransform : 'a elt -> string
+
+ val top : 'a elt -> string
+
+ val topPx : 'a elt -> int
+
+ val verticalAlign : 'a elt -> string
+
+ val visibility : 'a elt -> string
+
+ val whiteSpace : 'a elt -> string
+
+ val width : 'a elt -> string
+
+ val widthPx : 'a elt -> int
+
+ val wordSpacing : 'a elt -> string
+
+ val zIndex : 'a elt -> string
end
(** Modify the CSS properties of DOM elements. *)
module SetCss : sig
- val background: 'a elt -> string -> unit
- val backgroundAttachment: 'a elt -> string -> unit
- val backgroundColor: 'a elt -> string -> unit
- val backgroundImage: 'a elt -> string -> unit
- val backgroundPosition: 'a elt -> string -> unit
- val backgroundRepeat: 'a elt -> string -> unit
- val border: 'a elt -> string -> unit
- val borderBottom: 'a elt -> string -> unit
- val borderBottomColor: 'a elt -> string -> unit
- val borderBottomStyle: 'a elt -> string -> unit
- val borderBottomWidth: 'a elt -> string -> unit
- val borderBottomWidthPx: 'a elt -> int -> unit
- val borderCollapse: 'a elt -> string -> unit
- val borderColor: 'a elt -> string -> unit
- val borderLeft: 'a elt -> string -> unit
- val borderLeftColor: 'a elt -> string -> unit
- val borderLeftStyle: 'a elt -> string -> unit
- val borderLeftWidth: 'a elt -> string -> unit
- val borderLeftWidthPx: 'a elt -> int -> unit
- val borderRight: 'a elt -> string -> unit
- val borderRightColor: 'a elt -> string -> unit
- val borderRightStyle: 'a elt -> string -> unit
- val borderRightWidth: 'a elt -> string -> unit
- val borderRightWidthPx: 'a elt -> int -> unit
- val borderSpacing: 'a elt -> string -> unit
- val borderStyle: 'a elt -> string -> unit
- val borderTop: 'a elt -> string -> unit
- val borderTopColor: 'a elt -> string -> unit
- val borderTopStyle: 'a elt -> string -> unit
- val borderTopWidth: 'a elt -> string -> unit
- val borderTopWidthPx: 'a elt -> int -> unit
- val borderWidth: 'a elt -> string -> unit
- val bottom: 'a elt -> string -> unit
- val bottomPx: 'a elt -> int -> unit
- val captionSide: 'a elt -> string -> unit
- val clear: 'a elt -> string -> unit
- val clip: 'a elt -> string -> unit
- val color: 'a elt -> string -> unit
- val content: 'a elt -> string -> unit
- val counterIncrement: 'a elt -> string -> unit
- val counterReset: 'a elt -> string -> unit
- val cssFloat: 'a elt -> string -> unit
- val cssText: 'a elt -> string -> unit
- val cursor: 'a elt -> string -> unit
- val direction: 'a elt -> string -> unit
- val display: 'a elt -> string -> unit
- val emptyCells: 'a elt -> string -> unit
- val font: 'a elt -> string -> unit
- val fontFamily: 'a elt -> string -> unit
- val fontSize: 'a elt -> string -> unit
- val fontStyle: 'a elt -> string -> unit
- val fontVariant: 'a elt -> string -> unit
- val fontWeight: 'a elt -> string -> unit
- val height: 'a elt -> string -> unit
- val heightPx: 'a elt -> int -> unit
- val left: 'a elt -> string -> unit
- val leftPx: 'a elt -> int -> unit
- val letterSpacing: 'a elt -> string -> unit
- val lineHeight: 'a elt -> string -> unit
- val listStyle: 'a elt -> string -> unit
- val listStyleImage: 'a elt -> string -> unit
- val listStylePosition: 'a elt -> string -> unit
- val listStyleType: 'a elt -> string -> unit
- val margin: 'a elt -> string -> unit
- val marginBottom: 'a elt -> string -> unit
- val marginBottomPx: 'a elt -> int -> unit
- val marginLeft: 'a elt -> string -> unit
- val marginLeftPx: 'a elt -> int -> unit
- val marginRight: 'a elt -> string -> unit
- val marginRightPx: 'a elt -> int -> unit
- val marginTop: 'a elt -> string -> unit
- val marginTopPx: 'a elt -> int -> unit
- val maxHeight: 'a elt -> string -> unit
- val maxHeightPx: 'a elt -> int -> unit
- val maxWidth: 'a elt -> string -> unit
- val maxWidthPx: 'a elt -> int -> unit
- val minHeight: 'a elt -> string -> unit
- val minHeightPx: 'a elt -> int -> unit
- val minWidth: 'a elt -> string -> unit
- val minWidthPx: 'a elt -> int -> unit
- val opacity: 'a elt -> string option -> unit
- val outline: 'a elt -> string -> unit
- val outlineColor: 'a elt -> string -> unit
- val outlineOffset: 'a elt -> string -> unit
- val outlineStyle: 'a elt -> string -> unit
- val outlineWidth: 'a elt -> string -> unit
- val overflow: 'a elt -> string -> unit
- val overflowX: 'a elt -> string -> unit
- val overflowY: 'a elt -> string -> unit
- val padding: 'a elt -> string -> unit
- val paddingBottom: 'a elt -> string -> unit
- val paddingBottomPx: 'a elt -> int -> unit
- val paddingLeft: 'a elt -> string -> unit
- val paddingLeftPx: 'a elt -> int -> unit
- val paddingRight: 'a elt -> string -> unit
- val paddingRightPx: 'a elt -> int -> unit
- val paddingTop: 'a elt -> string -> unit
- val paddingTopPx: 'a elt -> int -> unit
- val pageBreakAfter: 'a elt -> string -> unit
- val pageBreakBefore: 'a elt -> string -> unit
- val position: 'a elt -> string -> unit
- val right: 'a elt -> string -> unit
- val rightPx: 'a elt -> int -> unit
- val tableLayout: 'a elt -> string -> unit
- val textAlign: 'a elt -> string -> unit
- val textDecoration: 'a elt -> string -> unit
- val textIndent: 'a elt -> string -> unit
- val textTransform: 'a elt -> string -> unit
- val top: 'a elt -> string -> unit
- val topPx: 'a elt -> int -> unit
- val verticalAlign: 'a elt -> string -> unit
- val visibility: 'a elt -> string -> unit
- val whiteSpace: 'a elt -> string -> unit
- val width: 'a elt -> string -> unit
- val widthPx: 'a elt -> int -> unit
- val wordSpacing: 'a elt -> string -> unit
- val zIndex: 'a elt -> string -> unit
- end
+ val background : 'a elt -> string -> unit
+
+ val backgroundAttachment : 'a elt -> string -> unit
+
+ val backgroundColor : 'a elt -> string -> unit
+
+ val backgroundImage : 'a elt -> string -> unit
+
+ val backgroundPosition : 'a elt -> string -> unit
+
+ val backgroundRepeat : 'a elt -> string -> unit
+
+ val border : 'a elt -> string -> unit
+
+ val borderBottom : 'a elt -> string -> unit
+
+ val borderBottomColor : 'a elt -> string -> unit
+
+ val borderBottomStyle : 'a elt -> string -> unit
+
+ val borderBottomWidth : 'a elt -> string -> unit
+
+ val borderBottomWidthPx : 'a elt -> int -> unit
+
+ val borderCollapse : 'a elt -> string -> unit
+
+ val borderColor : 'a elt -> string -> unit
+
+ val borderLeft : 'a elt -> string -> unit
+
+ val borderLeftColor : 'a elt -> string -> unit
+
+ val borderLeftStyle : 'a elt -> string -> unit
+
+ val borderLeftWidth : 'a elt -> string -> unit
+
+ val borderLeftWidthPx : 'a elt -> int -> unit
+
+ val borderRight : 'a elt -> string -> unit
+
+ val borderRightColor : 'a elt -> string -> unit
+
+ val borderRightStyle : 'a elt -> string -> unit
+
+ val borderRightWidth : 'a elt -> string -> unit
+
+ val borderRightWidthPx : 'a elt -> int -> unit
+
+ val borderSpacing : 'a elt -> string -> unit
+
+ val borderStyle : 'a elt -> string -> unit
+
+ val borderTop : 'a elt -> string -> unit
+
+ val borderTopColor : 'a elt -> string -> unit
+
+ val borderTopStyle : 'a elt -> string -> unit
+
+ val borderTopWidth : 'a elt -> string -> unit
+
+ val borderTopWidthPx : 'a elt -> int -> unit
+
+ val borderWidth : 'a elt -> string -> unit
+
+ val bottom : 'a elt -> string -> unit
+
+ val bottomPx : 'a elt -> int -> unit
+
+ val captionSide : 'a elt -> string -> unit
+
+ val clear : 'a elt -> string -> unit
+
+ val clip : 'a elt -> string -> unit
+
+ val color : 'a elt -> string -> unit
+
+ val content : 'a elt -> string -> unit
+
+ val counterIncrement : 'a elt -> string -> unit
+
+ val counterReset : 'a elt -> string -> unit
+
+ val cssFloat : 'a elt -> string -> unit
+
+ val cssText : 'a elt -> string -> unit
+
+ val cursor : 'a elt -> string -> unit
+
+ val direction : 'a elt -> string -> unit
+
+ val display : 'a elt -> string -> unit
+
+ val emptyCells : 'a elt -> string -> unit
+
+ val font : 'a elt -> string -> unit
+
+ val fontFamily : 'a elt -> string -> unit
+
+ val fontSize : 'a elt -> string -> unit
+
+ val fontStyle : 'a elt -> string -> unit
+
+ val fontVariant : 'a elt -> string -> unit
+
+ val fontWeight : 'a elt -> string -> unit
+
+ val height : 'a elt -> string -> unit
+ val heightPx : 'a elt -> int -> unit
+
+ val left : 'a elt -> string -> unit
+
+ val leftPx : 'a elt -> int -> unit
+
+ val letterSpacing : 'a elt -> string -> unit
+
+ val lineHeight : 'a elt -> string -> unit
+
+ val listStyle : 'a elt -> string -> unit
+
+ val listStyleImage : 'a elt -> string -> unit
+
+ val listStylePosition : 'a elt -> string -> unit
+
+ val listStyleType : 'a elt -> string -> unit
+
+ val margin : 'a elt -> string -> unit
+
+ val marginBottom : 'a elt -> string -> unit
+
+ val marginBottomPx : 'a elt -> int -> unit
+
+ val marginLeft : 'a elt -> string -> unit
+
+ val marginLeftPx : 'a elt -> int -> unit
+
+ val marginRight : 'a elt -> string -> unit
+
+ val marginRightPx : 'a elt -> int -> unit
+
+ val marginTop : 'a elt -> string -> unit
+
+ val marginTopPx : 'a elt -> int -> unit
+
+ val maxHeight : 'a elt -> string -> unit
+
+ val maxHeightPx : 'a elt -> int -> unit
+
+ val maxWidth : 'a elt -> string -> unit
+
+ val maxWidthPx : 'a elt -> int -> unit
+
+ val minHeight : 'a elt -> string -> unit
+
+ val minHeightPx : 'a elt -> int -> unit
+
+ val minWidth : 'a elt -> string -> unit
+
+ val minWidthPx : 'a elt -> int -> unit
+
+ val opacity : 'a elt -> string option -> unit
+
+ val outline : 'a elt -> string -> unit
+
+ val outlineColor : 'a elt -> string -> unit
+
+ val outlineOffset : 'a elt -> string -> unit
+
+ val outlineStyle : 'a elt -> string -> unit
+
+ val outlineWidth : 'a elt -> string -> unit
+
+ val overflow : 'a elt -> string -> unit
+
+ val overflowX : 'a elt -> string -> unit
+
+ val overflowY : 'a elt -> string -> unit
+
+ val padding : 'a elt -> string -> unit
+
+ val paddingBottom : 'a elt -> string -> unit
+
+ val paddingBottomPx : 'a elt -> int -> unit
+
+ val paddingLeft : 'a elt -> string -> unit
+
+ val paddingLeftPx : 'a elt -> int -> unit
+
+ val paddingRight : 'a elt -> string -> unit
+
+ val paddingRightPx : 'a elt -> int -> unit
+
+ val paddingTop : 'a elt -> string -> unit
+
+ val paddingTopPx : 'a elt -> int -> unit
+
+ val pageBreakAfter : 'a elt -> string -> unit
+
+ val pageBreakBefore : 'a elt -> string -> unit
+
+ val position : 'a elt -> string -> unit
+
+ val right : 'a elt -> string -> unit
+
+ val rightPx : 'a elt -> int -> unit
+
+ val tableLayout : 'a elt -> string -> unit
+
+ val textAlign : 'a elt -> string -> unit
+
+ val textDecoration : 'a elt -> string -> unit
+
+ val textIndent : 'a elt -> string -> unit
+
+ val textTransform : 'a elt -> string -> unit
+
+ val top : 'a elt -> string -> unit
+
+ val topPx : 'a elt -> int -> unit
+
+ val verticalAlign : 'a elt -> string -> unit
+
+ val visibility : 'a elt -> string -> unit
+
+ val whiteSpace : 'a elt -> string -> unit
+
+ val width : 'a elt -> string -> unit
+
+ val widthPx : 'a elt -> int -> unit
+
+ val wordSpacing : 'a elt -> string -> unit
+
+ val zIndex : 'a elt -> string -> unit
+ end
end
val window : Dom_html.window Js.t
-val window_open: ?features:string -> string -> string -> Dom_html.window Js.t Js.opt
+
+val window_open :
+ ?features:string -> string -> string -> Dom_html.window Js.t Js.opt
module Window : sig
- val close: Dom_html.window Js.t -> unit
- val head: Dom_html.window Js.t -> [`Head] Tyxml_js.Html5.elt
- val body: Dom_html.window Js.t -> [`Body] Tyxml_js.Html5.elt
- val onresize:
- ?win:Dom_html.window Js.t ->
- (Dom_html.event Js.t -> bool) -> unit
- val onunload:
- ?win:Dom_html.window Js.t ->
- (Dom_html.event Js.t -> bool) -> unit
- val onhashchange:
- ?win:Dom_html.window Js.t ->
- (Dom_html.hashChangeEvent Js.t -> bool) -> unit
- val prompt: ?win:Dom_html.window Js.t -> ?value:string -> string -> string
+ val close : Dom_html.window Js.t -> unit
+
+ val head : Dom_html.window Js.t -> [`Head] Tyxml_js.Html5.elt
+
+ val body : Dom_html.window Js.t -> [`Body] Tyxml_js.Html5.elt
+
+ val onresize :
+ ?win:Dom_html.window Js.t -> (Dom_html.event Js.t -> bool) -> unit
+
+ val onunload :
+ ?win:Dom_html.window Js.t -> (Dom_html.event Js.t -> bool) -> unit
+
+ val onhashchange :
+ ?win:Dom_html.window Js.t
+ -> (Dom_html.hashChangeEvent Js.t -> bool)
+ -> unit
+
+ val prompt : ?win:Dom_html.window Js.t -> ?value:string -> string -> string
end
val hide : 'a Tyxml_js.Html5.elt -> unit
+
val show : 'a Tyxml_js.Html5.elt -> unit
module Document : sig
- val uri: unit -> string
+ val uri : unit -> string
end
-val parse_fragment: unit -> (string * string) list
-val set_fragment: (string * string) list -> unit
+val parse_fragment : unit -> (string * string) list
-module MakeLocal(V: sig type t val name: string end) : sig
- val get: unit -> V.t option
- val set: V.t -> unit
+val set_fragment : (string * string) list -> unit
+
+module MakeLocal (V : sig
+ type t
+
+ val name : string
+end) : sig
+ val get : unit -> V.t option
+
+ val set : V.t -> unit
end
+val js_code_url : string -> string
(** Returns an URL that can be passed to [Worker.create] from a string
containing the code *)
-val js_code_url: string -> string
-
(* (\** Wrapper for [Worker.create] that uses JS code as a string instead of a URL*\)
* val worker_with_code: string -> ('a, 'b) Worker.worker Js.t
*
diff --git a/src/utils/learnocaml_partition_create.ml b/src/utils/learnocaml_partition_create.ml
index 8358c4922..f9c41b5b9 100644
--- a/src/utils/learnocaml_partition_create.ml
+++ b/src/utils/learnocaml_partition_create.ml
@@ -8,76 +8,71 @@
open Learnocaml_data
open Learnocaml_data.Partition
-
open Learnocaml_report
-
open Lwt.Infix
-
open Asak.Monad_error
-module IntMap = Map.Make(struct type t = int let compare = compare end)
+module IntMap = Map.Make (struct
+ type t = int
+
+ let compare = compare
+end)
(* Return a list of all saves with their definition of the function *)
let get_all_saves exo_name prelude =
- Learnocaml_store.Student.Index.get () >>=
- Lwt_list.fold_left_s (* filter_map_rev *)
- (fun acc t ->
- let open ErrS in
- let t = t.Student.token in
- Learnocaml_store.Save.get t >|= fun save ->
- either (fun x -> x :: acc) (fun _ -> acc) @@ run @@
- begin
- err_of_option "" save
- >>= fun x ->
- err_of_option "" (SMap.find_opt exo_name Save.(x.all_exercise_states))
- >>= fun x ->
- ret (t,x, (prelude ^ "\n" ^ Answer.(x.solution)))
- end
- ) []
+ Learnocaml_store.Student.Index.get ()
+ >>= Lwt_list.fold_left_s
+ (* filter_map_rev *)
+ (fun acc t ->
+ let open ErrS in
+ let t = t.Student.token in
+ Learnocaml_store.Save.get t
+ >|= fun save ->
+ either (fun x -> x :: acc) (fun _ -> acc)
+ @@ run
+ @@ ( err_of_option "" save
+ >>= fun x ->
+ err_of_option ""
+ (SMap.find_opt exo_name Save.(x.all_exercise_states))
+ >>= fun x -> ret (t, x, prelude ^ "\n" ^ Answer.(x.solution)) ) )
+ []
(* Return a tuple where
- The first element contains answer without a grade
- The second the others *)
let partition_was_graded =
- let aux (nonlst,acc) (a,x,b) =
+ let aux (nonlst, acc) (a, x, b) =
match Answer.(x.report) with
- | None -> a::nonlst,acc
- | Some g -> nonlst,(a,g,b)::acc
+ | None -> (a :: nonlst, acc)
+ | Some g -> (nonlst, (a, g, b) :: acc)
in
List.fold_left aux ([], [])
let partition_by_grade funname =
let rec get_relative_section = function
| [] -> []
- | (Message _)::xs -> get_relative_section xs
- | (Section (t,res))::xs | (SectionMin (t,res, _))::xs ->
- match t with
- | Text _::Code fn::_ ->
- if fn = funname
- then res
- else get_relative_section xs
- | _ -> get_relative_section xs
+ | Message _ :: xs -> get_relative_section xs
+ | Section (t, res) :: xs | SectionMin (t, res, _) :: xs -> (
+ match t with
+ | Text _ :: Code fn :: _ ->
+ if fn = funname then res else get_relative_section xs
+ | _ -> get_relative_section xs )
in
let rec get_grade xs =
- let aux acc =
- function
- | Section (_,s) -> get_grade s
+ let aux acc = function
+ | Section (_, s) -> get_grade s
| SectionMin (_, s, min) -> max (get_grade s) min
- | Message (_,s) ->
- match s with
- | Success i -> acc + i
- | _ -> acc
+ | Message (_, s) -> ( match s with Success i -> acc + i | _ -> acc )
in
List.fold_left aux 0 xs
in
- let aux acc ((_,x,_) as e) =
+ let aux acc ((_, x, _) as e) =
let sec = get_relative_section x in
let g = get_grade sec in
let lst =
- match IntMap.find_opt g acc with
- | None -> [e]
- | Some xs -> e::xs
- in IntMap.add g lst acc
+ match IntMap.find_opt g acc with None -> [e] | Some xs -> e :: xs
+ in
+ IntMap.add g lst acc
in
List.fold_left aux IntMap.empty
@@ -85,10 +80,11 @@ let asak_partition prof fun_name sol by_grade =
let open Asak in
IntMap.fold
(fun i lst (bad_type, res) ->
- let lst = List.map (fun (a,_,b) -> (a,b)) lst in
+ let lst = List.map (fun (a, _, b) -> (a, b)) lst in
let ans = Partition.create prof fun_name sol lst in
- (ans.Partition.bad_type @ bad_type, (i,ans.Partition.clusters) :: res)
- ) by_grade ([],[])
+ (ans.Partition.bad_type @ bad_type, (i, ans.Partition.clusters) :: res)
+ )
+ by_grade ([], [])
let partition exo_name fun_name prof =
Learnocaml_store.Exercise.get exo_name
@@ -100,7 +96,9 @@ let partition exo_name fun_name prof =
let solution = prelude ^ "\n" ^ solution in
get_all_saves exo_name prelude
>|= fun saves ->
- let not_graded,lst = partition_was_graded saves in
+ let not_graded, lst = partition_was_graded saves in
let by_grade = partition_by_grade fun_name lst in
- let bad_type,partition_by_grade = asak_partition prof fun_name solution by_grade in
+ let bad_type, partition_by_grade =
+ asak_partition prof fun_name solution by_grade
+ in
{not_graded; bad_type; partition_by_grade}
diff --git a/src/utils/learnocaml_partition_create.mli b/src/utils/learnocaml_partition_create.mli
index cae9ca366..305363520 100644
--- a/src/utils/learnocaml_partition_create.mli
+++ b/src/utils/learnocaml_partition_create.mli
@@ -8,7 +8,8 @@
open Learnocaml_data
-val partition : string (* Exercise name *)
- -> string (* function name *)
- -> int (* percent of subtrees to keep *)
- -> Partition.t Lwt.t
+val partition :
+ string (* Exercise name *)
+ -> string (* function name *)
+ -> int (* percent of subtrees to keep *)
+ -> Partition.t Lwt.t
diff --git a/src/utils/learnocaml_xor.ml b/src/utils/learnocaml_xor.ml
index b76861a57..0bee5aa43 100644
--- a/src/utils/learnocaml_xor.ml
+++ b/src/utils/learnocaml_xor.ml
@@ -14,32 +14,30 @@ let () =
Bytes.set alphabet 26 '+';
Bytes.set alphabet 37 '/';
for i = 0 to 25 do
- Bytes.set alphabet i (Char.chr @@ 65 + i);
- Bytes.set alphabet (i+38) (Char.chr @@ 97 + 25 - i)
+ Bytes.set alphabet i (Char.chr @@ (65 + i));
+ Bytes.set alphabet (i + 38) (Char.chr @@ (97 + 25 - i))
done;
for i = 0 to 9 do
- Bytes.set alphabet (i+27) (Char.chr @@ 48 + i)
+ Bytes.set alphabet (i + 27) (Char.chr @@ (48 + i))
done
let xor_key =
- "Caml1999I0150\153\200\232\027\154a\029u@\251\127SX\141\140\157\
- \219\195\000\228\020\180_CR\202\130\129\127\2491\130\011\183\
- \158b\022\"qB0\166+\169\212_\205\164 D\210Qn\181o\225\147q\156\
- \028u6\248b\177\002\164`\187\250\221\240o6\156\240\020\027\243o\
- \017h\218\208\168\164f\161+5\137\132ml\169\235\174\212\029"
+ "Caml1999I0150\153\200\232\027\154a\029u@\251\127SX\141\140\157\219\195\000\228\020\180_CR\202\130\129\127\2491\130\011\183\158b\022\"qB0\166+\169\212_\205\164 \
+ D\210Qn\181o\225\147q\156\028u6\248b\177\002\164`\187\250\221\240o6\156\240\020\027\243o\017h\218\208\168\164f\161+5\137\132ml\169\235\174\212\029"
let xor ?prefix str =
let xor_key =
- match prefix with
- | None -> xor_key
- | Some prefix -> prefix ^ xor_key in
+ match prefix with None -> xor_key | Some prefix -> prefix ^ xor_key
+ in
let str' = Bytes.create (String.length str) in
for i = 0 to String.length str - 1 do
- let c = Char.code xor_key.[i mod (String.length xor_key)] in
- Bytes.set str' (i) (Char.chr (c lxor (Char.code (String.get str i))))
+ let c = Char.code xor_key.[i mod String.length xor_key] in
+ Bytes.set str' i (Char.chr (c lxor Char.code str.[i]))
done;
Bytes.to_string str'
let alphabet = Bytes.to_string alphabet
+
let decode ?prefix str = xor ?prefix @@ B64.decode ~alphabet str
+
let encode ?prefix str = B64.encode ~alphabet @@ xor ?prefix str
diff --git a/src/utils/learnocaml_xor.mli b/src/utils/learnocaml_xor.mli
index 57606cfe7..89eb6a99b 100644
--- a/src/utils/learnocaml_xor.mli
+++ b/src/utils/learnocaml_xor.mli
@@ -8,5 +8,6 @@
(* This is trivial and dummy "encryption" for the tests and the solutions. *)
-val encode: ?prefix:string -> string -> string
-val decode: ?prefix:string -> string -> string
+val encode : ?prefix:string -> string -> string
+
+val decode : ?prefix:string -> string -> string
diff --git a/src/utils/lwt_request.ml b/src/utils/lwt_request.ml
index 1401e5acd..d794e4dda 100644
--- a/src/utils/lwt_request.ml
+++ b/src/utils/lwt_request.ml
@@ -11,19 +11,23 @@ open Js_of_ocaml
exception Request_failed of (int * string)
let url_encode_list l =
- String.concat "&" (List.map (fun (name, arg) ->
- Printf.sprintf "%s=%s" name (Url.urlencode arg)) l)
+ String.concat "&"
+ (List.map
+ (fun (name, arg) -> Printf.sprintf "%s=%s" name (Url.urlencode arg))
+ l)
-let get ?(headers=[]) ~url ~args =
- let (res, w) = Lwt.task () in
+let get ?(headers = []) ~url ~args =
+ let res, w = Lwt.task () in
let req = XmlHttpRequest.create () in
- let url = match args with
- | [] -> url
- | _ -> url ^ "?" ^ (url_encode_list args) in
- req##(_open (Js.string "GET") (Js.string url) (Js._true));
- req##(setRequestHeader (Js.string "Content-type")
- (Js.string "application/x-www-form-urlencoded"));
- List.iter (fun (n, v) -> req##(setRequestHeader (Js.string n) (Js.string v)))
+ let url =
+ match args with [] -> url | _ -> url ^ "?" ^ url_encode_list args
+ in
+ req ## (_open (Js.string "GET") (Js.string url) Js._true);
+ req
+ ## (setRequestHeader (Js.string "Content-type")
+ (Js.string "application/x-www-form-urlencoded"));
+ List.iter
+ (fun (n, v) -> req ## (setRequestHeader (Js.string n) (Js.string v)))
headers;
let callback () =
match req##.status with
@@ -31,38 +35,44 @@ let get ?(headers=[]) ~url ~args =
| 204 -> Lwt.wakeup w ""
| code (* including 0 *) ->
Lwt.wakeup_exn w
- (Request_failed (code, Js.to_string req##.responseText)) in
- req##.onreadystatechange := Js.wrap_callback
- (fun _ -> (match req##.readyState with
- XmlHttpRequest.DONE -> callback ()
- | _ -> ()));
- req##(send (Js.null));
+ (Request_failed (code, Js.to_string req##.responseText))
+ in
+ req##.onreadystatechange :=
+ Js.wrap_callback (fun _ ->
+ match req##.readyState with
+ | XmlHttpRequest.DONE -> callback ()
+ | _ -> () );
+ req ## (send Js.null);
Lwt.on_cancel res (fun () -> req##abort);
res
-let post ?(headers=[]) ?(get_args=[]) ~url ~body =
- let (res, w) = Lwt.task () in
+let post ?(headers = []) ?(get_args = []) ~url ~body =
+ let res, w = Lwt.task () in
let req = XmlHttpRequest.create () in
- let url = match get_args with
- | [] -> url
- | _ -> url ^ "?" ^ (url_encode_list get_args) in
- req##(_open (Js.string "POST") (Js.string url) (Js._true));
- req##(setRequestHeader (Js.string "Content-type")
- (Js.string "application/x-www-form-urlencoded"));
- List.iter (fun (n, v) -> req##(setRequestHeader (Js.string n) (Js.string v)))
+ let url =
+ match get_args with [] -> url | _ -> url ^ "?" ^ url_encode_list get_args
+ in
+ req ## (_open (Js.string "POST") (Js.string url) Js._true);
+ req
+ ## (setRequestHeader (Js.string "Content-type")
+ (Js.string "application/x-www-form-urlencoded"));
+ List.iter
+ (fun (n, v) -> req ## (setRequestHeader (Js.string n) (Js.string v)))
headers;
let callback () =
match req##.status with
| 200 -> Lwt.wakeup w (Js.to_string req##.responseText)
| 204 -> Lwt.wakeup w ""
- | code (* including 0 *) -> Lwt.wakeup_exn w
- (Request_failed (code, Js.to_string req##.responseText))
+ | code (* including 0 *) ->
+ Lwt.wakeup_exn w
+ (Request_failed (code, Js.to_string req##.responseText))
in
- req##.onreadystatechange := Js.wrap_callback
- (fun _ -> (match req##.readyState with
- XmlHttpRequest.DONE -> callback ()
- | _ -> ()));
+ req##.onreadystatechange :=
+ Js.wrap_callback (fun _ ->
+ match req##.readyState with
+ | XmlHttpRequest.DONE -> callback ()
+ | _ -> () );
let body = Js.Opt.map (Js.Opt.option body) Js.string in
- req##(send body);
+ req ## (send body);
Lwt.on_cancel res (fun () -> req##abort);
res
diff --git a/src/utils/lwt_request.mli b/src/utils/lwt_request.mli
index 67a7012be..2c113fa56 100644
--- a/src/utils/lwt_request.mli
+++ b/src/utils/lwt_request.mli
@@ -1,18 +1,23 @@
-(* This file is part of Learn-OCaml.
+exception
+ (* This file is part of Learn-OCaml.
*
* Copyright (C) 2019 OCaml Software Foundation.
* Copyright (C) 2016-2018 OCamlPro.
*
* Learn-OCaml is distributed under the terms of the MIT license. See the
* included LICENSE file for details. *)
+ Request_failed of
+ (int * string)
-exception Request_failed of (int * string)
+val post :
+ ?headers:(string * string) list
+ -> ?get_args:(string * string) list
+ -> url:string
+ -> body:string option
+ -> string Lwt.t
-val post:
- ?headers:(string * string) list ->
- ?get_args:(string * string) list ->
- url:string -> body:string option -> string Lwt.t
-
-val get:
- ?headers:(string * string) list ->
- url:string -> args:(string * string) list -> string Lwt.t
+val get :
+ ?headers:(string * string) list
+ -> url:string
+ -> args:(string * string) list
+ -> string Lwt.t
diff --git a/src/utils/lwt_utils.ml b/src/utils/lwt_utils.ml
index 0fe27a22c..1f0b0b980 100644
--- a/src/utils/lwt_utils.ml
+++ b/src/utils/lwt_utils.ml
@@ -8,50 +8,53 @@
open Lwt.Infix
-let rec mkdir_p ?(perm=0o755) dir =
- Lwt_unix.file_exists dir >>= function
+let rec mkdir_p ?(perm = 0o755) dir =
+ Lwt_unix.file_exists dir
+ >>= function
| true ->
- if Sys.is_directory dir then
- Lwt.return ()
+ if Sys.is_directory dir then Lwt.return ()
else
Lwt.fail_with
(Printf.sprintf "Can't create dir: file %s is in the way" dir)
| false ->
- mkdir_p (Filename.dirname dir) >>= fun () ->
- Lwt_unix.mkdir dir perm
+ mkdir_p (Filename.dirname dir) >>= fun () -> Lwt_unix.mkdir dir perm
let copy_file src dst =
- Lwt.catch (fun () ->
- let cmd = [|"cp";src;dst|]in
- Lwt_process.exec ("", cmd) >>= fun r ->
+ Lwt.catch
+ (fun () ->
+ let cmd = [|"cp"; src; dst|] in
+ Lwt_process.exec ("", cmd)
+ >>= fun r ->
if r <> Unix.WEXITED 0 then Lwt.fail_with "copy_file"
- else Lwt.return_unit)
+ else Lwt.return_unit )
(function
- | Sys_error _ | Unix.Unix_error _ -> Lwt.fail_with "copy_file"
- | e -> raise e)
+ | Sys_error _ | Unix.Unix_error _ -> Lwt.fail_with "copy_file"
+ | e -> raise e)
let copy_tree src dst =
let files = Sys.readdir src in
if Array.length files = 0 then Lwt.return_unit
else
- Lwt.catch (fun () ->
- mkdir_p dst >>= fun () ->
+ Lwt.catch
+ (fun () ->
+ mkdir_p dst
+ >>= fun () ->
let cmd =
Array.concat
- [[|"cp"; "-PR"|];
- Array.map (Filename.concat src) files;
- [|dst|]]
+ [[|"cp"; "-PR"|]; Array.map (Filename.concat src) files; [|dst|]]
in
- Lwt_process.exec ("", cmd) >>= fun r ->
+ Lwt_process.exec ("", cmd)
+ >>= fun r ->
if r <> Unix.WEXITED 0 then Lwt.fail_with "copy_tree"
- else Lwt.return_unit)
+ else Lwt.return_unit )
(function
| Sys_error _ | Unix.Unix_error _ -> Lwt.fail_with "copy_tree"
| e -> raise e)
-type 'a with_lock = { with_lock: 'b. 'a -> (unit -> 'b Lwt.t) -> 'b Lwt.t }
+type 'a with_lock = {with_lock : 'b. 'a -> (unit -> 'b Lwt.t) -> 'b Lwt.t}
-let gen_mutex_table: type t. unit -> t with_lock = fun () ->
+let gen_mutex_table : type t. unit -> t with_lock =
+ fun () ->
let table = Hashtbl.create 223 in
let get_mutex key =
try Hashtbl.find table key with Not_found ->
@@ -61,11 +64,13 @@ let gen_mutex_table: type t. unit -> t with_lock = fun () ->
in
let with_lock key f =
let mutex = get_mutex key in
- Lwt_mutex.with_lock mutex @@ fun () ->
- Lwt.finalize f @@ fun () ->
+ Lwt_mutex.with_lock mutex
+ @@ fun () ->
+ Lwt.finalize f
+ @@ fun () ->
if Lwt_mutex.is_empty mutex then
(* we still hold the mutex, nobody else is waiting: drop it *)
Hashtbl.remove table key;
Lwt.return_unit
in
- { with_lock }
+ {with_lock}
diff --git a/src/utils/lwt_utils.mli b/src/utils/lwt_utils.mli
index 11eecd091..ff86d20ab 100644
--- a/src/utils/lwt_utils.mli
+++ b/src/utils/lwt_utils.mli
@@ -6,17 +6,17 @@
* Learn-OCaml is distributed under the terms of the MIT license. See the
* included LICENSE file for details. *)
-val mkdir_p: ?perm:int -> string -> unit Lwt.t
+val mkdir_p : ?perm:int -> string -> unit Lwt.t
+val copy_file : string -> string -> unit Lwt.t
(** [copy_tree src dst] copies the file [src] into file [dst] *)
-val copy_file: string -> string -> unit Lwt.t
+val copy_tree : string -> string -> unit Lwt.t
(** [copy_tree src dst] copies the contents of directory [src] into directory
[dst] *)
-val copy_tree: string -> string -> unit Lwt.t
-type 'a with_lock = { with_lock: 'b. 'a -> (unit -> 'b Lwt.t) -> 'b Lwt.t }
+type 'a with_lock = {with_lock : 'b. 'a -> (unit -> 'b Lwt.t) -> 'b Lwt.t}
+val gen_mutex_table : unit -> 'a with_lock
(** Creates a mutex hashtable when applied to [()], and returns a `with_mutex`
function that can lock with a given mutex identifier *)
-val gen_mutex_table: unit -> 'a with_lock
diff --git a/src/utils/ocplib_i18n.ml b/src/utils/ocplib_i18n.ml
index dbc2634c0..84276e344 100644
--- a/src/utils/ocplib_i18n.ml
+++ b/src/utils/ocplib_i18n.ml
@@ -19,8 +19,6 @@ let s_ arr = arr.(!lang_id)
let set_lang lang =
let lang = List.hd (String.split_on_char '-' lang) in
let rec aux i =
- if i <= 0 then 0
- else if known_lang_ids.(i) = lang then i
- else aux (i-1)
+ if i <= 0 then 0 else if known_lang_ids.(i) = lang then i else aux (i - 1)
in
lang_id := aux (Array.length known_lang_ids - 1)
diff --git a/src/utils/ocplib_i18n.mli b/src/utils/ocplib_i18n.mli
index 73b643207..465b95a42 100644
--- a/src/utils/ocplib_i18n.mli
+++ b/src/utils/ocplib_i18n.mli
@@ -10,13 +10,13 @@
* The above copyright notice and this permission notice shall be included in all
* copies or substantial portions of the Software. *)
-(** Lists all the supported languages *)
val known_lang_ids : string array
+(** Lists all the supported languages *)
+val s_ : 'a array -> 'a
(** Gets the right index from the given array for the currently selected
language (should be used by the preprocessor only) *)
-val s_ : 'a array -> 'a
+val set_lang : string -> unit
(** Select the currently active language (two-letter code, possibly with country
suffix e.g. [fr-FR]. *)
-val set_lang : string -> unit
diff --git a/src/utils/ppx_ocplib_i18n.ml b/src/utils/ppx_ocplib_i18n.ml
index 6a235b7ce..349503d24 100644
--- a/src/utils/ppx_ocplib_i18n.ml
+++ b/src/utils/ppx_ocplib_i18n.ml
@@ -12,7 +12,6 @@
open Migrate_parsetree
open OCaml_405.Ast
-
open Ast_mapper
open Ast_helper
open Asttypes
@@ -24,158 +23,169 @@ let read_translations f =
let t = Hashtbl.create 427 in
let id = ref None in
let in_id = ref false in
- try while true do
+ try
+ while true do
let l = String.trim (input_line ic) in
if String.length l = 0 then id := None
else if l.[0] = '#' then ()
else
- try Scanf.sscanf l "msgid %S" (fun s -> in_id := true; id := Some s)
- with Scanf.Scan_failure _ ->
- try Scanf.sscanf l "msgstr %S" (fun s ->
- match !id with
- | None ->
- Printf.ksprintf failwith
- "Missing 'msgid' before 'msgstr' in %s" f
- | Some id ->
- if Hashtbl.mem t id then
- Printf.ksprintf failwith
- "Duplicate definition for msgid '%s' in %s" id f;
- in_id := false;
- Hashtbl.add t id s)
- with Scanf.Scan_failure _ ->
- try Scanf.sscanf l "%S" (fun s ->
- match !id with
- | None ->
- Printf.ksprintf failwith
- "Missing 'msgid' before string in %s" f
- | Some sid ->
- if !in_id then id := Some (sid ^ s)
- else
- let s0 = Hashtbl.find t sid in
- Hashtbl.replace t sid (s0 ^ s))
- with Scanf.Scan_failure _ ->
- Printf.ksprintf failwith "Error in translation file %s at %S" f l
- done; assert false
- with End_of_file ->
- close_in ic;
- t
+ try
+ Scanf.sscanf l "msgid %S" (fun s ->
+ in_id := true;
+ id := Some s )
+ with Scanf.Scan_failure _ -> (
+ try
+ Scanf.sscanf l "msgstr %S" (fun s ->
+ match !id with
+ | None ->
+ Printf.ksprintf failwith
+ "Missing 'msgid' before 'msgstr' in %s" f
+ | Some id ->
+ if Hashtbl.mem t id then
+ Printf.ksprintf failwith
+ "Duplicate definition for msgid '%s' in %s" id f;
+ in_id := false;
+ Hashtbl.add t id s )
+ with Scanf.Scan_failure _ -> (
+ try
+ Scanf.sscanf l "%S" (fun s ->
+ match !id with
+ | None ->
+ Printf.ksprintf failwith
+ "Missing 'msgid' before string in %s" f
+ | Some sid ->
+ if !in_id then id := Some (sid ^ s)
+ else
+ let s0 = Hashtbl.find t sid in
+ Hashtbl.replace t sid (s0 ^ s) )
+ with Scanf.Scan_failure _ ->
+ Printf.ksprintf failwith "Error in translation file %s at %S" f l ) )
+ done;
+ assert false
+ with End_of_file -> close_in ic; t
let translations_dir = "../../translations"
+
let transl_file_suffix = ".po"
+
let dump_pot_file = Sys.getenv_opt "DUMP_POT" <> None
let all_ids = Hashtbl.create 23
let htbl_update ht key f create =
- try Hashtbl.replace ht key (f (Hashtbl.find ht key))
- with Not_found -> Hashtbl.add ht key (f (create ()))
+ try Hashtbl.replace ht key (f (Hashtbl.find ht key)) with Not_found ->
+ Hashtbl.add ht key (f (create ()))
let find_translation lang ht ~loc s =
if dump_pot_file then
htbl_update all_ids lang
(fun t -> Hashtbl.add t s loc; t)
(fun () -> Hashtbl.create 143);
- try Hashtbl.find ht s
- with Not_found ->
- Location.print_warning loc !Location.formatter_for_warnings @@
- Warnings.Preprocessor
- (Printf.sprintf "%s translation not found for %S" lang s);
+ try Hashtbl.find ht s with Not_found ->
+ Location.print_warning loc !Location.formatter_for_warnings
+ @@ Warnings.Preprocessor
+ (Printf.sprintf "%s translation not found for %S" lang s);
s
let dump_pot () =
- Hashtbl.iter (fun lang strs ->
+ Hashtbl.iter
+ (fun lang strs ->
let file = Filename.concat translations_dir (lang ^ ".pot") in
let oc = open_out_gen [Open_append; Open_creat] 0o644 file in
let misses =
- Hashtbl.fold (fun str loc acc -> match acc with
- | (locs, s)::acc when s = str -> (loc::locs, str)::acc
- | acc -> ([loc], str)::acc)
+ Hashtbl.fold
+ (fun str loc acc ->
+ match acc with
+ | (locs, s) :: acc when s = str -> (loc :: locs, str) :: acc
+ | acc -> ([loc], str) :: acc )
strs []
in
let misses =
List.sort compare
- (List.map (fun (locs, s) -> List.sort compare locs, s) misses)
+ (List.map (fun (locs, s) -> (List.sort compare locs, s)) misses)
in
let fmt = Format.formatter_of_out_channel oc in
- List.iter (fun (locs, s) ->
+ List.iter
+ (fun (locs, s) ->
Format.pp_print_string fmt "#:";
- List.iter (fun l ->
+ List.iter
+ (fun l ->
Format.pp_print_char fmt ' ';
- Location.print_compact fmt l)
+ Location.print_compact fmt l )
locs;
Format.fprintf fmt "\nmsgid %S\n" s;
- Format.fprintf fmt "msgstr \"\"\n\n";
- ) misses;
- close_out oc
- )
+ Format.fprintf fmt "msgstr \"\"\n\n" )
+ misses;
+ close_out oc )
all_ids
let translations =
(* default language should be first *)
- ("en", (fun ~loc:_ s -> s)) ::
- let langs = Hashtbl.create 7 in
- Array.iter (fun f ->
- if Filename.check_suffix f transl_file_suffix then
- Hashtbl.add langs
- (Filename.chop_suffix f transl_file_suffix)
- (read_translations (Filename.concat translations_dir f))
- )
- (Sys.readdir translations_dir);
- List.sort compare @@
- Hashtbl.fold (fun lang h acc ->
- (lang, find_translation lang h) :: acc) langs []
+ ("en", fun ~loc:_ s -> s)
+ ::
+ (let langs = Hashtbl.create 7 in
+ Array.iter
+ (fun f ->
+ if Filename.check_suffix f transl_file_suffix then
+ Hashtbl.add langs
+ (Filename.chop_suffix f transl_file_suffix)
+ (read_translations (Filename.concat translations_dir f)) )
+ (Sys.readdir translations_dir);
+ List.sort compare
+ @@ Hashtbl.fold
+ (fun lang h acc -> (lang, find_translation lang h) :: acc)
+ langs [])
let get_lang_expr ~loc transl_expr =
Exp.apply ~loc
- (Exp.ident { txt = Ldot (Lident "Ocplib_i18n", "s_"); loc })
- [Nolabel, transl_expr]
+ (Exp.ident {txt = Ldot (Lident "Ocplib_i18n", "s_"); loc})
+ [(Nolabel, transl_expr)]
let transl_mapper _config _cookies =
{ default_mapper with
- expr = fun mapper expr ->
- match expr with
- | { pexp_desc =
- Pexp_extension ({ txt = "lang_ids_array"; loc }, _);
- _ } ->
- Exp.array ~loc
- (List.map (fun (lang, _) ->
- Exp.constant ~loc (Pconst_string (lang,None)))
- translations)
- | { pexp_desc =
- Pexp_extension ({ txt = ("i"|"if" as tag); loc }, pstr);
- _ } ->
- (match pstr with
- | PStr [{
- pstr_desc =
- Pstr_eval ({
- pexp_loc = loc;
- pexp_desc = Pexp_constant (Pconst_string (s, _));
- _
- }, _);
- _
- }] ->
- let is_format = tag = "if" in
- let translations =
- List.map (fun (_lang, f) -> f ~loc s) translations
- in
- let translations_expr =
- Exp.array ~loc
- (List.map (fun s ->
- let e = Exp.constant ~loc (Pconst_string (s,None)) in
- if is_format then
- Exp.apply ~loc
- (Exp.ident { txt = Lident "format_of_string"; loc })
- [Nolabel, e]
- else e)
- translations)
- in
- get_lang_expr ~loc translations_expr
- | _ ->
- raise (Location.Error (
- Location.error ~loc "[%i] requires a constant string, e.g. [%i \"text\"]")))
- | x -> default_mapper.expr mapper x;
- }
+ expr =
+ (fun mapper expr ->
+ match expr with
+ | {pexp_desc = Pexp_extension ({txt = "lang_ids_array"; loc}, _); _} ->
+ Exp.array ~loc
+ (List.map
+ (fun (lang, _) ->
+ Exp.constant ~loc (Pconst_string (lang, None)) )
+ translations)
+ | { pexp_desc = Pexp_extension ({txt = ("i" | "if") as tag; loc}, pstr); _
+ } -> (
+ match pstr with
+ | PStr
+ [ { pstr_desc =
+ Pstr_eval
+ ( { pexp_loc = loc
+ ; pexp_desc = Pexp_constant (Pconst_string (s, _)); _
+ }
+ , _ ); _ } ] ->
+ let is_format = tag = "if" in
+ let translations =
+ List.map (fun (_lang, f) -> f ~loc s) translations
+ in
+ let translations_expr =
+ Exp.array ~loc
+ (List.map
+ (fun s ->
+ let e = Exp.constant ~loc (Pconst_string (s, None)) in
+ if is_format then
+ Exp.apply ~loc
+ (Exp.ident {txt = Lident "format_of_string"; loc})
+ [(Nolabel, e)]
+ else e )
+ translations)
+ in
+ get_lang_expr ~loc translations_expr
+ | _ ->
+ raise
+ (Location.Error
+ (Location.error ~loc
+ "[%i] requires a constant string, e.g. [%i \"text\"]")) )
+ | x -> default_mapper.expr mapper x ) }
let () = Driver.register ~name:"i18n" (module OCaml_405) transl_mapper
-let () =
- if Sys.getenv_opt "DUMP_POT" <> None then at_exit dump_pot
+
+let () = if Sys.getenv_opt "DUMP_POT" <> None then at_exit dump_pot
diff --git a/src/utils/sha.mli b/src/utils/sha.mli
index da2e7cd2b..890cbc715 100644
--- a/src/utils/sha.mli
+++ b/src/utils/sha.mli
@@ -1 +1 @@
-val sha512: string -> string
+val sha512 : string -> string