Commit 1aeb2710 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Add a Js_of_ocaml backend and a demo toplevel.

parent cf7917ed
include (Jsoo : sig end)
module Toplevel = Toplevel
\ No newline at end of file
(library
(name cduce_jsoo_backend)
(public_name cduce.lib.jsoo_backend)
(library_flags (-linkall))
(libraries cduce-types cduce.lib.core)
(preprocess (pps js_of_ocaml-ppx))
)
open Js_of_ocaml
open Cduce_core
let load_xml open_cb close_cb text_cb txt =
let _DOMParser : (unit -> < .. > Js.t) Js.constr Js.optdef =
Js.Unsafe.(get global (Js.string "DOMParser"))
in
let _DOMParser =
Js.Optdef.get _DOMParser (fun () ->
Value.failwith' "DOMParser not available")
in
let parser = new%js _DOMParser () in
let txt = Js.string txt in
let mime_type = Js.string "text/xml" in
let dom : Dom.element Dom.document Js.t =
Js.Unsafe.(
meth_call parser "parseFromString" [| inject txt; inject mime_type |])
in
let root = dom##.documentElement in
let name = Js.to_string root##.tagName in
if name = "parsererror" then Value.failwith' "Invalid document element"
else
let rec loop node =
match Js.Opt.to_option node with
| None -> ()
| Some n -> (
let fs = n##.firstChild in
let ns = n##.nextSibling in
match Dom.nodeType n with
| Dom.Text text_node ->
text_cb (Js.to_string text_node##.data);
loop fs;
loop ns
| Dom.Element elem_node ->
let alist = ref [] in
for i = 0 to elem_node##.attributes##.length - 1 do
let an =
Js.Opt.get
(elem_node##.attributes##item i)
(fun () -> assert false)
in
alist :=
(Js.to_string an##.name, Js.to_string an##.value) :: !alist
done;
open_cb (Js.to_string elem_node##.tagName) !alist;
loop fs;
loop ns;
close_cb (Js.to_string elem_node##.tagName)
| _ ->
loop fs;
loop ns )
in
loop (Js.Opt.return (root :> Dom.node Js.t))
let get_fun = function Value.Abstraction (_, f) -> f | _ -> assert false
let load_url_async url cb_ok cb_err =
let xhr = XmlHttpRequest.create () in
xhr##.onreadystatechange :=
Js.wrap_callback (fun () ->
if xhr##.readyState == DONE then
let text =
match Js.Opt.to_option xhr##.responseText with
| None -> ""
| Some s -> Js.to_string s
in
let cb_ok = get_fun cb_ok in
let cb_err = get_fun cb_err in
let text = Value.string_utf8 (Encodings.Utf8.mk text) in
if xhr##.status == 200 then ignore (cb_ok text)
else ignore (cb_err text));
xhr##_open
(Js.string "get")
(Js.string (Value.cduce2ocaml_string url))
Js._true;
xhr##send Js.null;
Value.nil
let use () =
Load_xml.xml_parser :=
load_xml Load_xml.start_element_handler Load_xml.end_element_handler
Load_xml.text_handler;
Stats.gettimeofday := Sys.time;
let open Cduce_types in
let tstr = Builtin_defs.string in
let nil = Builtin_defs.nil in
Operators.register_fun3 "load_url_async" Builtin_defs.string
(Types.arrow (Types.cons tstr) (Types.cons nil))
(Types.arrow (Types.cons tstr) (Types.cons nil))
nil load_url_async
let () =
Cduce_config.register
"jsoo"
"Js_of_ocaml bindings"
use
\ No newline at end of file
open Cduce_core
let init_top ppf =
let () = Cduce_config.init_all () in
Format.fprintf ppf " CDuce version %s\n@." Version.cduce_version
let eval_top ppf ppf_err input =
let () = Cduce_loc.push_source (`String input) in
let _ =
try Cduce_driver.topinput ppf ppf_err (Stream.of_string input)
with Cduce_driver.Escape _ -> false
in
Cduce_loc.pop_source ()
open Cduce_core
let () = Stats.gettimeofday := Unix.gettimeofday
let out_dir = ref [] (* directory of the output file *)
let src = ref []
......
open Js_of_ocaml
type history = { mutable after : string list; mutable before : string list }
let add_substring buff s i l =
for k = 0 to l - 1 do
match s.[i + k] with
| '<' -> Buffer.add_string buff "&lt;"
| '>' -> Buffer.add_string buff "&gt;"
| c -> Buffer.add_char buff c
done
let dump_buffer kind (div : Dom_html.divElement Js.t) buff =
let s = Buffer.contents buff in
let () = Buffer.reset buff in
if s <> "" then
let otag = "<span class='cduce-top-" ^ kind ^ "'>" in
div##.innerHTML :=
div##.innerHTML##concat_3
(Js.string otag) (Js.string s) (Js.string "</span>")
let relt = new%js Js.regExp_withFlags (Js.string "[&]lt;") (Js.string "g")
let regt = new%js Js.regExp_withFlags (Js.string "[&]gt;") (Js.string "g")
let retag = new%js Js.regExp_withFlags (Js.string "<[^>]*>") (Js.string "g")
let rebr = new%js Js.regExp_withFlags (Js.string "<[bB][rR]/?>") (Js.string "g")
let display_divs (console : Dom_html.divElement Js.t)
(input : Dom_html.divElement Js.t) (container : Dom_html.divElement Js.t) =
if container##.clientHeight <= input##.offsetHeight + console##.scrollHeight
then begin
console##.style##.bottom
:= Js.string (Format.sprintf "%dpx" input##.offsetHeight);
input##.style##.bottom := Js.string "0";
console##.style##.top := Js.string "";
input##.style##.top := Js.string ""
end
else begin
console##.style##.top := Js.string "0";
input##.style##.top
:= Js.string (Format.sprintf "%dpx" console##.scrollHeight);
console##.style##.bottom := Js.string "";
input##.style##.bottom := Js.string ""
end
let install id =
let id = Js.to_string id in
match Dom_html.getElementById_coerce id Dom_html.CoerceTo.div with
| None -> failwith ("Expecting a div element with id : " ^ id)
| Some div ->
let history = { after = []; before = []} in
let lineHeight = ref 0 in
let container = Dom_html.createDiv Dom_html.document in
container##.id := Js.string "cduce-top-container";
let console = Dom_html.createDiv Dom_html.document in
console##.id := Js.string "cduce-top-console";
let input = Dom_html.createDiv Dom_html.document in
input##.id := Js.string "cduce-top-input";
input##setAttribute (Js.string "tabindex") (Js.string "0");
input##.innerHTML := Js.string " ";
input##setAttribute (Js.string "contenteditable") (Js.string "true");
input##setAttribute (Js.string "role") (Js.string "textbox");
let out_buff = Buffer.create 16 in
let err_buff = Buffer.create 16 in
let out_fmt = Format.make_formatter (add_substring out_buff) ignore in
let err_fmt = Format.make_formatter (add_substring err_buff) ignore in
(input :> Dom_html.eventTarget Js.t)##.onkeydown
:= Dom.handler (fun e ->
let res =
match Js.Optdef.to_option e##.key with
| None -> Js._true
| Some s -> let key = Js.to_string s in
match key with
"Enter" ->
let s = input##.innerHTML in
let fields = Js.str_array (s##split (Js.string ";;")) in
if fields##.length > 1 || Js.to_bool e##.ctrlKey then begin
input##.textContent := Js.null;
input##.innerHTML := Js.string " ";
input##.style##.height
:= (Js.string (string_of_int !lineHeight))##concat
(Js.string "px");
history.before <- List.rev_append history.after history.before;
history.after <- [];
let phrase = Js.array_get fields 0 in
match Js.Optdef.to_option phrase with
| None -> Js._true
| Some phrase ->
let phrase =
((((phrase##replace rebr (Js.string "\n"))##replace
retag (Js.string ""))##replace
relt (Js.string "<"))##replace
regt (Js.string ">"))##trim
in
let phrase = Js.to_string phrase ^ ";;"in
if phrase <> ";;" then begin
Format.fprintf out_fmt "%s\n%!" phrase;
history.before <- phrase :: history.before;
Cduce_lib_js.Toplevel.eval_top out_fmt err_fmt phrase;
dump_buffer "out" console out_buff;
dump_buffer "err" console err_buff;
console##.scrollTop := console##.scrollHeight;
end;
Js._false
end
else begin
input##.style##.height
:= Js.string
(Format.sprintf "%dpx"
(input##.clientHeight + !lineHeight));
Js._true
end
| ("ArrowUp" | "Up") when Js.to_bool (e ##.ctrlKey) && history.before <> [] ->
let l = List.hd history.before in
history.after <- l :: history.after;
history.before <- List.tl history.before;
input ##. innerHTML := Js.string l;
Js._false
| ("ArrowDown" | "Down") when Js.to_bool (e ##.ctrlKey) && history.after <> [] ->
let l = List.hd history.after in
history.before <- l :: history.before;
history.after <- List.tl history.after;
input ##. innerHTML := Js.string l;
Js._false
| _ -> Js._true
in
display_divs console input container;
res);
Cduce_lib_js.Toplevel.init_top out_fmt;
dump_buffer "out" console out_buff;
ignore (container##appendChild (console :> Dom.node Js.t));
ignore (container##appendChild (input :> Dom.node Js.t));
ignore (div##appendChild (container :> Dom.node Js.t));
display_divs console input container;
lineHeight := input##.clientHeight;
input##focus
let () =
let install = Js.wrap_callback install in
Js.export "cduce_top_install" install
......@@ -2,7 +2,14 @@
(name cduce)
(public_name cduce)
(package cduce)
(modules cduce)
(libraries cduce-types cduce.lib)
(modes byte native)
)
(modes byte native))
(executable
(name cduce_js_top)
(modules cduce_js_top)
(libraries cduce-types cduce.lib.js)
(modes js)
(preprocess
(pps js_of_ocaml-ppx)))
<!DOCTYPE html>
<html lang="en:US">
<head>
<title>CDuce Toplevel</title>
<meta charset="utf-8" />
<style>
#toplevel {
width: 100vw;
height: 50vh;
overflow: hidden;
padding: 0;
margin: 0;
}
body {
padding: 0;
margin: 0;
}
#cduce-top-container {
position: relative;
height: 50vh;
width: 90vw;
background: black;
padding: 0;
margin: 0;
}
#cduce-top-console,
#cduce-top-input {
position: absolute;
margin: 0;
padding: 0.5vh;
/*background: black;*/
font-family: monospace;
white-space: pre;
font-size: 2vh;
box-sizing: border-box;
width: 100%;
}
#cduce-top-console {
overflow-x: hidden;
overflow-y: auto;
color: gray;
}
#cduce-top-input {
color: white;
white-space: pre-wrap;
overflow: auto;
max-height: 12vh;
line-height: 3vh;
min-height: 3vh;
}
#cduce-top-input::before {
content: ">";
}
#cduce-top-console .cduce-top-out:last-child {
font-weight: bold;
color: white;
}
#cduce-top-console .cduce-top-err:last-child {
font-weight: bold;
color: red;
}
#cduce-top-console .cduce-top-err {
color: firebrick;
}
</style>
</head>
<body>
<div id="toplevel">
</div>
<div id="info">
You can use CTRL-Enter or end your sentence with <tt>;;</tt> to evaluate
it. <br />
CTRL-&uarr; and CTRL-&darr; allow you to navigate your history.
</div>
<script type="text/javascript" src="cduce_js_top.bc.js"></script>
<script type="text/javascript">
cduce_top_install("toplevel");
</script>
</body>
</html>
\ No newline at end of file
......@@ -3,6 +3,7 @@
(public_name cduce.lib)
(library_flags (-linkall))
(modes byte native)
(modules cduce_lib)
(libraries
cduce-types
cduce.lib.core
......@@ -20,7 +21,20 @@
(action
(write-file %{target} "include Cduce_core\ninclude Cduce_native_backend")))
(library
(name cduce_lib_js)
(public_name cduce.lib.js)
(library_flags (-linkall))
(modules cduce_lib_js)
(modes byte)
(libraries
cduce-types
cduce.lib.core
cduce.lib.jsoo_backend
))
(rule
(alias configure)
(deps)
(target cduce_lib_js.ml)
(action
(echo "Build configuration:\n OCaml compiler: %{ocaml_version}\n")))
(write-file %{target} "include Cduce_core\ninclude Cduce_jsoo_backend")))
open Cduce_loc
type type_fun = Types.t -> bool -> Types.t
let register op arity typ eval =
......@@ -8,60 +9,66 @@ let register op arity typ eval =
let register_unary op typ eval =
register op 1
(function
| [ tf ] ->
typ tf
| _ ->
raise (Typer.Error (
("Built-in operator " ^ op ^ " needs exactly one argument")))
)
(function
| [ v ] -> eval v
| _ -> assert false
)
| [ tf ] -> typ tf
| _ ->
raise
(Typer.Error
("Built-in operator " ^ op ^ " needs exactly one argument")))
(function [ v ] -> eval v | _ -> assert false)
let register_binary op typ eval =
register op 2
(function
| [ tf1; tf2 ] ->
typ tf1 tf2
| _ ->
raise (Typer.Error (
("Built-in operator " ^ op ^ " needs exactly two arguments")))
)
(function
| [ v1; v2 ] -> eval v1 v2
| _ -> assert false
)
| [ tf1; tf2 ] -> typ tf1 tf2
| _ ->
raise
(Typer.Error
("Built-in operator " ^ op ^ " needs exactly two arguments")))
(function [ v1; v2 ] -> eval v1 v2 | _ -> assert false)
let register_cst op t v =
register op 0
(function
| [ ] -> fun _ _ -> t
| _ -> assert false)
(function
| [ ] -> v
| _ -> assert false
)
(function [] -> fun _ _ -> t | _ -> assert false)
(function [] -> v | _ -> assert false)
let register_fun op dom codom eval =
register_cst op
(Types.arrow (Types.cons dom) (Types.cons codom))
(Value.Abstraction (Some [(dom,codom)],eval))
(Value.Abstraction (Some [ (dom, codom) ], eval))
let register_fun2 op dom1 dom2 codom eval =
let t2 = Types.arrow (Types.cons dom2) (Types.cons codom) in
let iface2 = Some [(dom2,codom)] in
let iface2 = Some [ (dom2, codom) ] in
register_cst op
(Types.arrow (Types.cons dom1) (Types.cons t2))
(Value.Abstraction (Some [(dom1,t2)],(fun v1 ->
Value.Abstraction (iface2,
eval v1))))
let register_op op ?(expect=Types.any) typ eval =
register_unary op
(fun tf _ _ -> let t = tf expect true in typ t)
(Value.Abstraction
(Some [ (dom1, t2) ], fun v1 -> Value.Abstraction (iface2, eval v1)))
let register_fun3 op dom1 dom2 dom3 codom eval =
let t3 = Types.arrow (Types.cons dom3) (Types.cons codom) in
let t2 = Types.arrow (Types.cons dom2) (Types.cons t3) in
let t1 = Types.arrow (Types.cons dom1) (Types.cons t2) in
let iface3 = Some [ (dom3, codom) ] in
let iface2 = Some [ (dom2, t3) ] in
let iface1 = Some [ (dom1, t2) ] in
register_cst op t1
(Value.Abstraction
( iface1,
fun x1 ->
Value.Abstraction
(iface2, fun x2 -> Value.Abstraction (iface3, eval x1 x2)) ))
let register_op op ?(expect = Types.any) typ eval =
register_unary op
(fun tf _ _ ->
let t = tf expect true in
typ t)
eval
let register_op2 op t1 t2 s eval =
register_binary op
(fun tf1 tf2 _ _ -> ignore (tf1 t1 false); ignore (tf2 t2 false); s)
(fun tf1 tf2 _ _ ->
ignore (tf1 t1 false);
ignore (tf2 t2 false);
s)
eval
......@@ -11,6 +11,8 @@ val register_binary:
val register_fun: string -> Types.t -> Types.t -> (Value.t -> Value.t) -> unit
val register_fun2: string -> Types.t -> Types.t -> Types.t -> (Value.t -> Value.t -> Value.t) -> unit
val register_fun3: string -> Types.t -> Types.t -> Types.t -> Types.t ->
(Value.t -> Value.t -> Value.t -> Value.t) -> unit
val register_op:
string -> ?expect:Types.t -> (Types.t -> Types.t) -> (Value.t -> Value.t) -> unit
......
......@@ -54,7 +54,7 @@ let mk name descr typing compile code ext_info depends =
status = `Unevaluated;
}
let magic = "CDUCE:compunit:00008"
let magic = "CDUCE:compunit:00009"
let has_obj n =
let base = U.to_string n ^ ".cdo" in
......@@ -112,7 +112,7 @@ let compile verbose name src =
mk name descr ty_env c_env code ext depends
let set_hash c =
let h = Hashtbl.hash_param 1000 10000 (c.typing, c.name) in
let h = Hashtbl.hash_param 128 256 (c.typing, c.name) in
let max_rank =
Tbl.fold (fun _ c accu -> max accu (fst (Compunit.get_hash c.descr))) tbl 0
in
......
......@@ -11,7 +11,7 @@
(progn
(system "mkdir doc")
(run %{bin:cduce} --run site.cdo --arg doc.xml -o doc)
)))
)))
(rule
(deps site.cd siteTypes.cdo xhtml.cdo)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment