well this is a toplevel, now to add a ppx ast printer?
This commit is contained in:
cqc
120
dune
120
dune
@ -1,20 +1,22 @@
|
||||
(env
|
||||
(dev (flags (:standard -warn-error -A))
|
||||
(js_of_ocaml (flags --no-inline --pretty --source-map-inline --debug-info)
|
||||
(build_runtime_flags --no-inline --pretty --source-map-inline --debug-info)
|
||||
(link_flags --source-map-inline))))
|
||||
(js_of_ocaml (flags :standard --no-inline --debug-info --target-env browser --disable shortvar)
|
||||
(build_runtime_flags :standard --no-inline --debug-info)
|
||||
(link_flags :standard))))
|
||||
|
||||
(executable
|
||||
(name boot_js)
|
||||
(modes byte js)
|
||||
(preprocess (pps js_of_ocaml-ppx))
|
||||
|
||||
(flags (:standard -rectypes -linkall))
|
||||
(modules boot_js human)
|
||||
(libraries
|
||||
fmt
|
||||
logs
|
||||
graphv_webgl
|
||||
js_of_ocaml-lwt
|
||||
js_of_ocaml-compiler
|
||||
js_of_ocaml-toplevel
|
||||
digestif.ocaml
|
||||
checkseum.ocaml
|
||||
irmin.mem
|
||||
@ -23,8 +25,116 @@
|
||||
cohttp-lwt-jsoo
|
||||
mimic
|
||||
uri
|
||||
zed
|
||||
gg
|
||||
lwd
|
||||
))
|
||||
|
||||
(executables
|
||||
(names toplevel)
|
||||
(modules
|
||||
(:standard \ human boot_js test_dynlink examples))
|
||||
(libraries
|
||||
js_of_ocaml-compiler
|
||||
js_of_ocaml-tyxml
|
||||
js_of_ocaml-toplevel
|
||||
lwt
|
||||
js_of_ocaml-lwt
|
||||
;; not used directly
|
||||
graphics
|
||||
js_of_ocaml.deriving
|
||||
react
|
||||
reactiveData
|
||||
str
|
||||
(select
|
||||
ocp_indent.ml
|
||||
from
|
||||
(ocp-indent.lib -> ocp_indent.ok.ml)
|
||||
(-> ocp_indent.fake.ml))
|
||||
(select
|
||||
colorize.ml
|
||||
from
|
||||
(higlo -> colorize.higlo.ml)
|
||||
(!higlo -> colorize.fake.ml))
|
||||
(select
|
||||
graphics_support.ml
|
||||
from
|
||||
(js_of_ocaml-lwt.graphics -> graphics_support.enabled.ml)
|
||||
(-> graphics_support.disabled.ml))
|
||||
(select
|
||||
ppx_support.ml
|
||||
from
|
||||
(js_of_ocaml-ppx -> ppx_support.enabled.ml)
|
||||
(-> ppx_support.disabled.ml)))
|
||||
(flags
|
||||
(:standard -rectypes -linkall))
|
||||
(modes byte)
|
||||
(preprocess
|
||||
(pps js_of_ocaml-ppx)))
|
||||
|
||||
(rule
|
||||
(targets test_dynlink.cmo test_dynlink.cmi)
|
||||
(action
|
||||
(run ocamlc -c %{dep:test_dynlink.ml})))
|
||||
|
||||
(rule
|
||||
(targets test_dynlink.js)
|
||||
(action
|
||||
(run %{bin:js_of_ocaml} --pretty --toplevel %{dep:test_dynlink.cmo})))
|
||||
|
||||
(rule
|
||||
(targets export.txt)
|
||||
(deps
|
||||
(package js_of_ocaml-ppx)
|
||||
(package js_of_ocaml)
|
||||
(package js_of_ocaml-compiler)
|
||||
(package js_of_ocaml-lwt)
|
||||
(package js_of_ocaml-tyxml)
|
||||
(package js_of_ocaml-toplevel))
|
||||
(action
|
||||
(run
|
||||
jsoo_listunits
|
||||
-o
|
||||
%{targets}
|
||||
stdlib
|
||||
graphics
|
||||
str
|
||||
dynlink
|
||||
js_of_ocaml-compiler.runtime
|
||||
js_of_ocaml-lwt.graphics
|
||||
js_of_ocaml-ppx.as-lib
|
||||
js_of_ocaml.deriving
|
||||
lwt
|
||||
tyxml.functor
|
||||
tyxml.functor:html_types.cmi
|
||||
react
|
||||
reactiveData
|
||||
js_of_ocaml
|
||||
js_of_ocaml-lwt
|
||||
js_of_ocaml-tyxml
|
||||
js_of_ocaml-toplevel
|
||||
dynlink)))
|
||||
|
||||
(rule
|
||||
(targets toplevel.js)
|
||||
(action
|
||||
(run
|
||||
%{bin:js_of_ocaml}
|
||||
compile
|
||||
--pretty
|
||||
--Werror
|
||||
--target-env
|
||||
browser
|
||||
--export
|
||||
%{dep:export.txt}
|
||||
--toplevel
|
||||
--disable
|
||||
shortvar
|
||||
+toplevel.js
|
||||
+dynlink.js
|
||||
%{dep:toplevel.bc}
|
||||
-o
|
||||
%{targets})))
|
||||
|
||||
(alias
|
||||
(name default)
|
||||
(deps toplevel.js index.html))
|
||||
|
||||
1
human.ml
1
human.ml
@ -1,3 +1,4 @@
|
||||
(* ok it's monad time *)
|
||||
(*
|
||||
|
||||
1. implement toplevel eval of git repo content
|
||||
|
||||
230
toplevel.html
Normal file
230
toplevel.html
Normal file
@ -0,0 +1,230 @@
|
||||
<?xml version="1.0" encoding="utf-8"?>
|
||||
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
|
||||
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
|
||||
<html xmlns="http://www.w3.org/1999/xhtml">
|
||||
<head>
|
||||
<title>OCaml toplevel</title>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
|
||||
<link rel="stylesheet" href="//maxcdn.bootstrapcdn.com/bootstrap/3.3.5/css/bootstrap.min.css" />
|
||||
<link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.5/css/bootstrap.min.css" />
|
||||
<style>
|
||||
|
||||
code, kbd, pre, samp {
|
||||
font-family: Menlo,Monaco,Consolas,monospace;
|
||||
}
|
||||
body,html {
|
||||
height: 100%;
|
||||
background-color:#eee;
|
||||
}
|
||||
|
||||
#toplevel-container {
|
||||
width: 50%;
|
||||
background-color: black;
|
||||
color: #ccc;
|
||||
overflow: auto;
|
||||
overflow-x: hidden;
|
||||
height: 100%;
|
||||
float:left;
|
||||
padding:10px;
|
||||
padding-top: 20px;
|
||||
}
|
||||
|
||||
#toplevel-container pre#output {
|
||||
padding: 0px;
|
||||
}
|
||||
|
||||
#toplevel-container #output {
|
||||
background-color:transparent;
|
||||
color: #ccc;
|
||||
border: none;
|
||||
line-height:18px;
|
||||
font-size: 12px;
|
||||
margin-bottom: 0px;
|
||||
}
|
||||
|
||||
#toplevel-container textarea {
|
||||
width:90%;
|
||||
line-height:18px;
|
||||
font-size: 12px;
|
||||
background-color: transparent;
|
||||
color: #fff;
|
||||
border: 0;
|
||||
resize: none;
|
||||
outline: none;
|
||||
font-family: Menlo,Monaco,Consolas,monospace;
|
||||
font-weight: bold;
|
||||
float:left;
|
||||
margin: 0px;
|
||||
padding:0px;
|
||||
}
|
||||
#toplevel-container #sharp {
|
||||
float: left;
|
||||
line-height:18px;
|
||||
font-size: 12px;
|
||||
font-family: Menlo,Monaco,Consolas,monospace;
|
||||
white-space: pre;
|
||||
}
|
||||
.sharp:before{
|
||||
content:"# ";
|
||||
line-height:18px;
|
||||
font-size: 12px;
|
||||
font-family: Menlo,Monaco,Consolas,monospace;
|
||||
}
|
||||
.caml{
|
||||
color:rgb(110, 110, 201);
|
||||
}
|
||||
#toplevel-side{
|
||||
position:relative;
|
||||
width:45%;
|
||||
height: 100%;
|
||||
overflow: auto;
|
||||
text-align:justify;
|
||||
float:left;
|
||||
margin-left:30px;
|
||||
}
|
||||
#toplevel-side ul{
|
||||
padding: 0px;
|
||||
list-style-type: none;
|
||||
}
|
||||
|
||||
.stderr {
|
||||
color: #d9534f;
|
||||
}
|
||||
.stdout {
|
||||
|
||||
}
|
||||
.errorloc{
|
||||
border-bottom-width: 3px;
|
||||
border-bottom-style: solid;
|
||||
border-bottom-color: red;
|
||||
}
|
||||
canvas {
|
||||
border: 1px dashed black;
|
||||
float: left;
|
||||
margin: 7px;
|
||||
}
|
||||
#output canvas {
|
||||
background-color: #464646;
|
||||
float: none;
|
||||
display: block;
|
||||
border: 1px dashed while;
|
||||
margin: 7px;
|
||||
}
|
||||
#output img {
|
||||
display:block;
|
||||
}
|
||||
#toplevel-examples {
|
||||
width: 270px;
|
||||
float: left;
|
||||
}
|
||||
#toplevel-examples .list-group-item{
|
||||
padding: 5px 15px;
|
||||
}
|
||||
#btn-share {
|
||||
float:right;
|
||||
margin-top:-20px;
|
||||
background-color:rgb(92, 129, 184);
|
||||
border-color: rgb(70, 75, 128);
|
||||
padding: 1px 5px;
|
||||
display:none;
|
||||
}
|
||||
.clear { clear:both; }
|
||||
|
||||
.sharp .id { color: #59B65C ; font-style: italic }
|
||||
.sharp .kw0 { color: rgb(64, 75, 190); font-weight: bold ;}
|
||||
.sharp .kw1 { color: rgb(150, 0, 108); font-weight: bold ;}
|
||||
.sharp .kw2 { color: rgb(23, 100, 42); font-weight: bold ;}
|
||||
.sharp .kw3 { color: #59B65C; font-weight: bold ;}
|
||||
.sharp .kw4 { color: #59B65C; font-weight: bold ;}
|
||||
.sharp .comment { color: green ; font-style: italic ; }
|
||||
.sharp .string { color: #6B6B6B; font-weight: bold ; }
|
||||
.sharp .text { }
|
||||
.sharp .numeric { color: #729AAF; }
|
||||
.sharp .directive { font-style: italic ; color : #EB00FF; } ;
|
||||
.sharp .escape { color: #409290 ; }
|
||||
.sharp .symbol0 { color: orange ; font-weight: bold ; }
|
||||
.sharp .symbol1 { color: #993300 ; font-weight: bold ; }
|
||||
.sharp .constant { color: rgb(0, 152, 255); }
|
||||
</style>
|
||||
<script type="text/javascript">
|
||||
|
||||
window.onhashchange = function() { window.location.reload() }
|
||||
var hash = window.location.hash.replace(/^#/,"");
|
||||
var fields = hash.split(/&/);
|
||||
var prefix = "";
|
||||
var version = "";
|
||||
for(var f in fields){
|
||||
var data = fields[f].split(/=/);
|
||||
if(data[0] == "version"){
|
||||
version = data[1].replace(/%20|%2B/g,"+");
|
||||
break;
|
||||
}
|
||||
}
|
||||
function load_script(url){
|
||||
var fileref=document.createElement('script');
|
||||
fileref.setAttribute("type","text/javascript");
|
||||
fileref.setAttribute("src", prefix+(version==""?"":(version+"/"))+url);
|
||||
document.getElementsByTagName("head")[0].appendChild(fileref);
|
||||
}
|
||||
load_script("_build/default/exported-unit.cmis.js");
|
||||
load_script("_build/default/toplevel.js");
|
||||
|
||||
</script>
|
||||
</head>
|
||||
<body>
|
||||
<div id="toplevel-container">
|
||||
<pre id="output"></pre>
|
||||
<div>
|
||||
<div id="sharp" class="sharp"></div>
|
||||
<textarea id="userinput">Loading ...</textarea>
|
||||
<button type="button" class="btn btn-default"
|
||||
id="btn-share">Share</button>
|
||||
</div>
|
||||
</div>
|
||||
<div id="toplevel-side">
|
||||
<h3>Js_of_ocaml</h3>
|
||||
<h4>A compiler from OCaml bytecode to Javascript.</h4>
|
||||
<p>It makes OCaml programs that run on Web browsers. It is
|
||||
easy to install as it works with an existing installation of OCaml,
|
||||
with no need to recompile any library. It comes with bindings for a
|
||||
large part of the browser APIs.</p>
|
||||
<p>This web-based OCaml toplevel is compiled using Js_of_ocaml.</p>
|
||||
<h4>Command</h4>
|
||||
<table class="table table-striped table-condensed">
|
||||
<tbody class>
|
||||
<tr>
|
||||
<td>Enter/Return</td>
|
||||
<td>Submit code</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>Ctrl + Enter</td>
|
||||
<td>Newline</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>Up / Down</td>
|
||||
<td>Browse history</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>Ctrl + l</td>
|
||||
<td>Clear display</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>Ctrl + k</td>
|
||||
<td>Reset toplevel</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>Tab</td>
|
||||
<td>Indent code</td>
|
||||
</tr>
|
||||
|
||||
</tbody>
|
||||
</table>
|
||||
<h4>Try to execute samples</h4>
|
||||
<div id="toplevel-examples" class="list-group"></div>
|
||||
<canvas width=200 height=200 id="test-canvas"></canvas>
|
||||
<h4 class="clear">See the generated javascript code</h4>
|
||||
<pre id="last-js">
|
||||
</pre>
|
||||
</div>
|
||||
</body>
|
||||
</html>
|
||||
628
toplevel.ml
Normal file
628
toplevel.ml
Normal file
@ -0,0 +1,628 @@
|
||||
(* Js_of_ocaml toplevel
|
||||
* http://www.ocsigen.org/js_of_ocaml/
|
||||
* Copyright (C) 2011 Jérôme Vouillon
|
||||
* Laboratoire PPS - CNRS Université Paris Diderot
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, with linking exception;
|
||||
* either version 2.1 of the License, or (at your option) any later version.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU Lesser General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* along with this program; if not, write to the Free Software
|
||||
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
*)
|
||||
|
||||
open Js_of_ocaml
|
||||
open Js_of_ocaml_lwt
|
||||
open Js_of_ocaml_tyxml
|
||||
open Js_of_ocaml_toplevel
|
||||
open Lwt
|
||||
|
||||
module Graphics_support = struct
|
||||
let init elt = Graphics_js.open_canvas elt
|
||||
end
|
||||
|
||||
module Ppx_support = struct
|
||||
let init () =
|
||||
Ast_mapper.register "js_of_ocaml" (fun _ -> Ppx_js.mapper)
|
||||
end
|
||||
|
||||
module Colorize = struct
|
||||
open Js_of_ocaml
|
||||
open Js_of_ocaml_tyxml
|
||||
|
||||
let text ~a_class:cl s =
|
||||
Tyxml_js.Html.(span ~a:[ a_class [ cl ] ] [ txt s ])
|
||||
|
||||
let ocaml = text
|
||||
|
||||
let highlight from_ to_ e =
|
||||
match Js.Opt.to_option e##.textContent with
|
||||
| None -> assert false
|
||||
| Some x ->
|
||||
let x = Js.to_string x in
|
||||
let (`Pos from_) = from_ in
|
||||
let to_ =
|
||||
match to_ with `Pos n -> n | `Last -> String.length x - 1
|
||||
in
|
||||
e##.innerHTML := Js.string "";
|
||||
let span kind s =
|
||||
if s <> "" then
|
||||
let span =
|
||||
Tyxml_js.Html.(span ~a:[ a_class [ kind ] ] [ txt s ])
|
||||
in
|
||||
Dom.appendChild e (Tyxml_js.To_dom.of_element span)
|
||||
in
|
||||
span "normal" (String.sub x 0 from_);
|
||||
span "errorloc" (String.sub x from_ (to_ - from_));
|
||||
span "normal" (String.sub x to_ (String.length x - to_))
|
||||
end
|
||||
|
||||
module Indent : sig
|
||||
val textarea : Dom_html.textAreaElement Js.t -> unit
|
||||
end = struct
|
||||
let _ = Approx_lexer.enable_extension "lwt"
|
||||
|
||||
let indent 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);
|
||||
}
|
||||
in
|
||||
let stream = Nstream.of_string s in
|
||||
IndentPrinter.proceed output stream IndentBlock.empty ""
|
||||
|
||||
let textarea (textbox : Dom_html.textAreaElement Js.t) : unit =
|
||||
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 =
|
||||
match l with
|
||||
| [] -> assert false
|
||||
| (i, (lo, up)) :: _ when up >= c -> (c, i, lo, up)
|
||||
| (_, (_lo, _up)) :: rem -> find rem c
|
||||
in
|
||||
let v = textbox##.value in
|
||||
let pos =
|
||||
let c1 = textbox##.selectionStart
|
||||
and c2 = textbox##.selectionEnd in
|
||||
if
|
||||
Js.Opt.test (Js.Opt.return c1)
|
||||
&& Js.Opt.test (Js.Opt.return 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 ((_c1, line1, _lo1, _up1), (_c2, line2, _lo2, _up2)) ->
|
||||
fun l -> l >= line1 + 1 && l <= line2 + 1
|
||||
in
|
||||
let v = indent (Js.to_string v) f in
|
||||
textbox##.value := Js.string v;
|
||||
match pos with
|
||||
| Some ((c1, line1, _lo1, up1), (c2, line2, _lo2, 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 compiler_name = "OCaml"
|
||||
let by_id s = Dom_html.getElementById s
|
||||
|
||||
let by_id_coerce s f =
|
||||
Js.Opt.get
|
||||
(f (Dom_html.getElementById s))
|
||||
(fun () -> raise Not_found)
|
||||
|
||||
let do_by_id s f =
|
||||
try f (Dom_html.getElementById s) with Not_found -> ()
|
||||
|
||||
(* load file using a synchronous XMLHttpRequest *)
|
||||
let load_resource_aux filename url =
|
||||
Js_of_ocaml_lwt.XmlHttpRequest.perform_raw
|
||||
~response_type:XmlHttpRequest.ArrayBuffer url
|
||||
>|= fun frame ->
|
||||
if frame.Js_of_ocaml_lwt.XmlHttpRequest.code = 200 then
|
||||
Js.Opt.case frame.Js_of_ocaml_lwt.XmlHttpRequest.content
|
||||
(fun () -> Printf.eprintf "Could not load %s\n" filename)
|
||||
(fun b ->
|
||||
Sys_js.update_file ~name:filename
|
||||
~content:(Typed_array.String.of_arrayBuffer b))
|
||||
else ()
|
||||
|
||||
let load_resource scheme ~prefix ~path:suffix =
|
||||
let url = scheme ^ suffix in
|
||||
let filename = Filename.concat prefix suffix in
|
||||
Lwt.async (fun () -> load_resource_aux filename url);
|
||||
Some ""
|
||||
|
||||
let setup_pseudo_fs () =
|
||||
Sys_js.mount ~path:"/dev/" (fun ~prefix:_ ~path:_ -> None);
|
||||
Sys_js.mount ~path:"/http/" (load_resource "http://");
|
||||
Sys_js.mount ~path:"/https/" (load_resource "https://");
|
||||
Sys_js.mount ~path:"/ftp/" (load_resource "ftp://");
|
||||
Sys_js.mount ~path:"/home/" (load_resource "filesys/")
|
||||
|
||||
let exec' s =
|
||||
let res : bool = JsooTop.use Format.std_formatter s in
|
||||
if not res then Format.eprintf "error while evaluating %s@." s
|
||||
|
||||
module Version = struct
|
||||
type t = int list
|
||||
|
||||
let split_char ~sep p =
|
||||
let len = String.length p in
|
||||
let rec split beg cur =
|
||||
if cur >= len then
|
||||
if cur - beg > 0 then [ String.sub p beg (cur - beg) ] else []
|
||||
else if sep p.[cur] then
|
||||
String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
|
||||
else split beg (cur + 1)
|
||||
in
|
||||
split 0 0
|
||||
|
||||
let split v =
|
||||
match
|
||||
split_char
|
||||
~sep:(function '+' | '-' | '~' -> true | _ -> false)
|
||||
v
|
||||
with
|
||||
| [] -> assert false
|
||||
| x :: _ ->
|
||||
List.map int_of_string
|
||||
(split_char ~sep:(function '.' -> true | _ -> false) x)
|
||||
|
||||
let current : t = split Sys.ocaml_version
|
||||
let compint (a : int) b = compare a b
|
||||
|
||||
let rec compare v v' =
|
||||
match (v, v') with
|
||||
| [ x ], [ y ] -> compint x y
|
||||
| [], [] -> 0
|
||||
| [], y :: _ -> compint 0 y
|
||||
| x :: _, [] -> compint x 0
|
||||
| x :: xs, y :: ys -> (
|
||||
match compint x y with 0 -> compare xs ys | n -> n)
|
||||
end
|
||||
|
||||
let setup_toplevel () =
|
||||
JsooTop.initialize ();
|
||||
Sys.interactive := false;
|
||||
if Version.compare Version.current [ 4; 07 ] >= 0 then
|
||||
exec' "open Stdlib";
|
||||
exec'
|
||||
"module Lwt_main = struct\n\
|
||||
\ let run t = match Lwt.state t with\n\
|
||||
\ | Lwt.Return x -> x\n\
|
||||
\ | Lwt.Fail e -> raise e\n\
|
||||
\ | Lwt.Sleep -> failwith \"Lwt_main.run: thread \
|
||||
didn't return\"\n\
|
||||
\ end";
|
||||
let header1 =
|
||||
Printf.sprintf " %s version %%s" compiler_name
|
||||
in
|
||||
let header2 =
|
||||
Printf.sprintf " Compiled with Js_of_ocaml version %s"
|
||||
Sys_js.js_of_ocaml_version
|
||||
in
|
||||
exec'
|
||||
(Printf.sprintf "Format.printf \"%s@.\" Sys.ocaml_version;;"
|
||||
header1);
|
||||
exec' (Printf.sprintf "Format.printf \"%s@.\";;" header2);
|
||||
exec' "#enable \"pretty\";;";
|
||||
exec' "#disable \"shortvar\";;";
|
||||
Ppx_support.init ();
|
||||
let[@alert "-deprecated"] new_directive n k =
|
||||
Hashtbl.add Toploop.directive_table n k
|
||||
in
|
||||
new_directive "load_js"
|
||||
(Toploop.Directive_string
|
||||
(fun name -> Js.Unsafe.global##load_script_ name));
|
||||
Sys.interactive := true;
|
||||
()
|
||||
|
||||
let resize ~container ~textbox () =
|
||||
Lwt.pause () >>= fun () ->
|
||||
textbox##.style##.height := Js.string "auto";
|
||||
textbox##.style##.height
|
||||
:= Js.string (Printf.sprintf "%dpx" (max 18 textbox##.scrollHeight));
|
||||
container##.scrollTop := container##.scrollHeight;
|
||||
Lwt.return ()
|
||||
|
||||
let setup_printers () =
|
||||
exec'
|
||||
"let _print_error fmt e = Format.pp_print_string fmt \
|
||||
(Js_of_ocaml.Js_error.to_string e)";
|
||||
Topdirs.dir_install_printer Format.std_formatter
|
||||
Longident.(Lident "_print_error");
|
||||
exec'
|
||||
"let _print_unit fmt (_ : 'a) : 'a = Format.pp_print_string fmt \
|
||||
\"()\"";
|
||||
Topdirs.dir_install_printer Format.std_formatter
|
||||
Longident.(Lident "_print_unit")
|
||||
|
||||
let setup_examples ~container ~textbox =
|
||||
let r = Regexp.regexp "^\\(\\*+(.*)\\*+\\)$" in
|
||||
let all = ref [] in
|
||||
(try
|
||||
let ic = open_in "/static/examples.ml" in
|
||||
while true do
|
||||
let line = input_line ic in
|
||||
match Regexp.string_match r line 0 with
|
||||
| Some res ->
|
||||
let name =
|
||||
match Regexp.matched_group res 1 with
|
||||
| Some s -> s
|
||||
| None -> assert false
|
||||
in
|
||||
all := `Title name :: !all
|
||||
| None -> all := `Content line :: !all
|
||||
done;
|
||||
assert false
|
||||
with _ -> ());
|
||||
let example_container = by_id "toplevel-examples" in
|
||||
let _ =
|
||||
List.fold_left
|
||||
(fun acc tok ->
|
||||
match tok with
|
||||
| `Content line -> line ^ "\n" ^ acc
|
||||
| `Title name ->
|
||||
let a =
|
||||
Tyxml_js.Html.(
|
||||
a
|
||||
~a:
|
||||
[
|
||||
a_class [ "list-group-item" ];
|
||||
a_onclick (fun _ ->
|
||||
textbox##.value := (Js.string acc)##trim;
|
||||
Lwt.async (fun () ->
|
||||
resize ~container ~textbox ()
|
||||
>>= fun () ->
|
||||
textbox##focus;
|
||||
Lwt.return_unit);
|
||||
true);
|
||||
]
|
||||
[ txt name ])
|
||||
in
|
||||
Dom.appendChild example_container (Tyxml_js.To_dom.of_a a);
|
||||
"")
|
||||
"" !all
|
||||
in
|
||||
()
|
||||
|
||||
(* we need to compute the hash form href to avoid different encoding behavior
|
||||
across browser. see Url.get_fragment *)
|
||||
let parse_hash () =
|
||||
let frag = Url.Current.get_fragment () in
|
||||
Url.decode_arguments frag
|
||||
|
||||
let rec iter_on_sharp ~f x =
|
||||
Js.Opt.iter (Dom_html.CoerceTo.element x) (fun e ->
|
||||
if Js.to_bool (e##.classList##contains (Js.string "sharp")) then
|
||||
f e);
|
||||
match Js.Opt.to_option x##.nextSibling with
|
||||
| None -> ()
|
||||
| Some n -> iter_on_sharp ~f n
|
||||
|
||||
let setup_share_button ~output =
|
||||
do_by_id "btn-share" (fun e ->
|
||||
e##.style##.display := Js.string "block";
|
||||
e##.onclick :=
|
||||
Dom_html.handler (fun _ ->
|
||||
(* get all ocaml code *)
|
||||
let code = ref [] in
|
||||
Js.Opt.iter output##.firstChild
|
||||
(iter_on_sharp ~f:(fun e ->
|
||||
code :=
|
||||
Js.Opt.case e##.textContent
|
||||
(fun () -> "")
|
||||
Js.to_string
|
||||
:: !code));
|
||||
let code_encoded = String.concat "" (List.rev !code) in
|
||||
let url, is_file =
|
||||
match Url.Current.get () with
|
||||
| Some (Url.Http url) ->
|
||||
(Url.Http { url with Url.hu_fragment = "" }, false)
|
||||
| Some (Url.Https url) ->
|
||||
(Url.Https { url with Url.hu_fragment = "" }, false)
|
||||
| Some (Url.File url) ->
|
||||
(Url.File { url with Url.fu_fragment = "" }, true)
|
||||
| _ -> assert false
|
||||
in
|
||||
let frag =
|
||||
let frags = parse_hash () in
|
||||
let frags =
|
||||
List.remove_assoc "code" frags
|
||||
@ [ ("code", code_encoded) ]
|
||||
in
|
||||
Url.encode_arguments frags
|
||||
in
|
||||
let uri = Url.string_of_url url ^ "#" ^ frag in
|
||||
let append_url str =
|
||||
let dom =
|
||||
Tyxml_js.Html.(
|
||||
p
|
||||
[
|
||||
txt "Share this url : ";
|
||||
a ~a:[ a_href str ] [ txt str ];
|
||||
])
|
||||
in
|
||||
Dom.appendChild output (Tyxml_js.To_dom.of_element dom)
|
||||
in
|
||||
Lwt.async (fun () ->
|
||||
Lwt.catch
|
||||
(fun () ->
|
||||
if is_file then
|
||||
failwith "Cannot shorten url with file scheme"
|
||||
else
|
||||
let uri =
|
||||
Printf.sprintf
|
||||
"http://is.gd/create.php?format=json&url=%s"
|
||||
(Url.urlencode uri)
|
||||
in
|
||||
Lwt.bind (Js_of_ocaml_lwt.Jsonp.call uri)
|
||||
(fun o ->
|
||||
let str = Js.to_string o##.shorturl in
|
||||
append_url str;
|
||||
Lwt.return_unit))
|
||||
(fun exn ->
|
||||
Format.eprintf
|
||||
"Could not generate short url. reason: %s@."
|
||||
(Printexc.to_string exn);
|
||||
append_url uri;
|
||||
Lwt.return_unit));
|
||||
Js._false))
|
||||
|
||||
let setup_js_preview () =
|
||||
let ph = by_id "last-js" in
|
||||
let runcode : string -> 'a = Js.Unsafe.global##.toplevelEval in
|
||||
Js.Unsafe.global##.toplevelEval := fun bc ->
|
||||
ph##.innerHTML := Js.string bc;
|
||||
runcode bc
|
||||
|
||||
let current_position = ref 0
|
||||
|
||||
let highlight_location loc =
|
||||
let x = ref 0 in
|
||||
let output = by_id "output" in
|
||||
let first =
|
||||
Js.Opt.get
|
||||
(output##.childNodes##item !current_position)
|
||||
(fun _ -> assert false)
|
||||
in
|
||||
iter_on_sharp first ~f:(fun e ->
|
||||
incr x;
|
||||
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
|
||||
if !x >= line1 && !x <= line2 then
|
||||
let from_ = if !x = line1 then `Pos col1 else `Pos 0 in
|
||||
let to_ = if !x = line2 then `Pos col2 else `Last in
|
||||
Colorize.highlight from_ to_ e)
|
||||
|
||||
let append colorize output cl s =
|
||||
Dom.appendChild output
|
||||
(Tyxml_js.To_dom.of_element (colorize ~a_class:cl s))
|
||||
|
||||
module History = struct
|
||||
let data = ref [| "" |]
|
||||
let idx = ref 0
|
||||
|
||||
let get_storage () =
|
||||
match Js.Optdef.to_option Dom_html.window##.localStorage with
|
||||
| exception _ -> raise Not_found
|
||||
| None -> raise Not_found
|
||||
| Some t -> t
|
||||
|
||||
let setup () =
|
||||
try
|
||||
let s = get_storage () in
|
||||
match Js.Opt.to_option (s##getItem (Js.string "history")) with
|
||||
| None -> raise Not_found
|
||||
| Some s ->
|
||||
let a = Json.unsafe_input s in
|
||||
data := a;
|
||||
idx := Array.length a - 1
|
||||
with _ -> ()
|
||||
|
||||
let push text =
|
||||
let l = Array.length !data in
|
||||
let n = Array.make (l + 1) "" in
|
||||
!data.(l - 1) <- text;
|
||||
Array.blit !data 0 n 0 l;
|
||||
data := n;
|
||||
idx := l;
|
||||
try
|
||||
let s = get_storage () in
|
||||
let str = Json.output !data in
|
||||
s##setItem (Js.string "history") str
|
||||
with Not_found -> ()
|
||||
|
||||
let current text = !data.(!idx) <- text
|
||||
|
||||
let previous textbox =
|
||||
if !idx > 0 then (
|
||||
decr idx;
|
||||
textbox##.value := Js.string !data.(!idx))
|
||||
|
||||
let next textbox =
|
||||
if !idx < Array.length !data - 1 then (
|
||||
incr idx;
|
||||
textbox##.value := Js.string !data.(!idx))
|
||||
end
|
||||
|
||||
let run _ =
|
||||
let container = by_id "toplevel-container" in
|
||||
let output = by_id "output" in
|
||||
let textbox : 'a Js.t =
|
||||
by_id_coerce "userinput" Dom_html.CoerceTo.textarea
|
||||
in
|
||||
let sharp_chan = open_out "/dev/null0" in
|
||||
let sharp_ppf = Format.formatter_of_out_channel sharp_chan in
|
||||
let caml_chan = open_out "/dev/null1" in
|
||||
let caml_ppf = Format.formatter_of_out_channel caml_chan in
|
||||
let execute () =
|
||||
let content = Js.to_string textbox##.value##trim in
|
||||
let content' =
|
||||
let len = String.length content in
|
||||
if
|
||||
try
|
||||
content <> ""
|
||||
&& content.[len - 1] <> ';'
|
||||
&& content.[len - 2] <> ';'
|
||||
with _ -> true
|
||||
then content ^ ";;"
|
||||
else content
|
||||
in
|
||||
current_position := output##.childNodes##.length;
|
||||
textbox##.value := Js.string "";
|
||||
History.push content;
|
||||
JsooTop.execute true ~pp_code:sharp_ppf ~highlight_location
|
||||
caml_ppf content';
|
||||
resize ~container ~textbox () >>= fun () ->
|
||||
container##.scrollTop := container##.scrollHeight;
|
||||
textbox##focus;
|
||||
Lwt.return_unit
|
||||
in
|
||||
let history_down _e =
|
||||
let txt = Js.to_string textbox##.value in
|
||||
let pos = textbox##.selectionStart in
|
||||
try
|
||||
if String.length txt = pos then raise Not_found;
|
||||
let _ = String.index_from txt pos '\n' in
|
||||
Js._true
|
||||
with Not_found ->
|
||||
History.current txt;
|
||||
History.next textbox;
|
||||
Js._false
|
||||
in
|
||||
let history_up _e =
|
||||
let txt = Js.to_string textbox##.value in
|
||||
let pos = textbox##.selectionStart - 1 in
|
||||
try
|
||||
if pos < 0 then raise Not_found;
|
||||
let _ = String.rindex_from txt pos '\n' in
|
||||
Js._true
|
||||
with Not_found ->
|
||||
History.current txt;
|
||||
History.previous textbox;
|
||||
Js._false
|
||||
in
|
||||
let meta e =
|
||||
let b = Js.to_bool in
|
||||
b e##.ctrlKey || b e##.altKey || b e##.metaKey
|
||||
in
|
||||
let shift e = Js.to_bool e##.shiftKey in
|
||||
(* setup handlers *)
|
||||
textbox##.onkeyup :=
|
||||
Dom_html.handler (fun _ ->
|
||||
Lwt.async (resize ~container ~textbox);
|
||||
Js._true);
|
||||
textbox##.onchange :=
|
||||
Dom_html.handler (fun _ ->
|
||||
Lwt.async (resize ~container ~textbox);
|
||||
Js._true);
|
||||
textbox##.onkeydown :=
|
||||
Dom_html.handler (fun e ->
|
||||
match e##.keyCode with
|
||||
| 13 when not (meta e || shift e) ->
|
||||
Lwt.async execute;
|
||||
Js._false
|
||||
| 13 ->
|
||||
Lwt.async (resize ~container ~textbox);
|
||||
Js._true
|
||||
| 09 ->
|
||||
Indent.textarea textbox;
|
||||
Js._false
|
||||
| 76 when meta e ->
|
||||
output##.innerHTML := Js.string "";
|
||||
Js._true
|
||||
| 75 when meta e ->
|
||||
setup_toplevel ();
|
||||
Js._false
|
||||
| 38 -> history_up e
|
||||
| 40 -> history_down e
|
||||
| _ -> Js._true);
|
||||
(Lwt.async_exception_hook :=
|
||||
fun exc ->
|
||||
Format.eprintf "exc during Lwt.async: %s@."
|
||||
(Printexc.to_string exc);
|
||||
match exc with
|
||||
| Js_error.Exn e ->
|
||||
let e = Js_error.to_error e in
|
||||
Firebug.console##log e##.stack
|
||||
| _ -> ());
|
||||
Lwt.async (fun () ->
|
||||
resize ~container ~textbox () >>= fun () ->
|
||||
textbox##focus;
|
||||
Lwt.return_unit);
|
||||
Graphics_support.init
|
||||
(by_id_coerce "test-canvas" Dom_html.CoerceTo.canvas);
|
||||
Sys_js.set_channel_flusher caml_chan
|
||||
(append Colorize.ocaml output "caml");
|
||||
Sys_js.set_channel_flusher sharp_chan
|
||||
(append Colorize.ocaml output "sharp");
|
||||
Sys_js.set_channel_flusher stdout
|
||||
(append Colorize.text output "stdout");
|
||||
Sys_js.set_channel_flusher stderr
|
||||
(append Colorize.text output "stderr");
|
||||
let readline () =
|
||||
Js.Opt.case
|
||||
(Dom_html.window##prompt
|
||||
(Js.string "The toplevel expects inputs:")
|
||||
(Js.string ""))
|
||||
(fun () -> "")
|
||||
(fun s -> Js.to_string s ^ "\n")
|
||||
in
|
||||
Sys_js.set_channel_filler stdin readline;
|
||||
setup_share_button ~output;
|
||||
setup_examples ~container ~textbox;
|
||||
setup_pseudo_fs ();
|
||||
setup_toplevel ();
|
||||
setup_js_preview ();
|
||||
setup_printers ();
|
||||
History.setup ();
|
||||
textbox##.value := Js.string "";
|
||||
(* Run initial code if any *)
|
||||
try
|
||||
let code = List.assoc "code" (parse_hash ()) in
|
||||
textbox##.value := Js.string code;
|
||||
Lwt.async execute
|
||||
with
|
||||
| Not_found -> ()
|
||||
| exc ->
|
||||
Firebug.console##log_3 (Js.string "exception")
|
||||
(Js.string (Printexc.to_string exc))
|
||||
exc
|
||||
|
||||
let _ =
|
||||
Dom_html.window##.onload
|
||||
:= Dom_html.handler (fun _ ->
|
||||
run ();
|
||||
Js._false)
|
||||
Reference in New Issue
Block a user