oplevel/toplevel.ml

(* 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

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 ~load_cmis_from_server =
  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://");
  if load_cmis_from_server then
    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 () =
  Clflags.debug := true;
  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 ();
  Toploop.add_directive "load_js"
    (Toploop.Directive_string
       (fun name -> Js.Unsafe.global##load_script_ name))
    {
      section = "js_of_ocaml-toplevel-example";
      doc = "Load the given javascript file";
    };
  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 =
              B64.encode (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 ~init ~output () =
  Firebug.console##log "run";

  let container = by_id "toplevel-container" 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 ?(pp_code = sharp_ppf) content () =
    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 ~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 (fun () ->
                execute (Js.to_string textbox##.value##trim) ());
            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 ~load_cmis_from_server:false;
  setup_toplevel ();
  setup_js_preview ();
  setup_printers ();
  History.setup ();
  textbox##.value := Js.string "";
  (* Run initial code if any *)
  (try
     textbox##.value := Js.string init;
     Lwt.async (fun () ->
         execute (Js.to_string textbox##.value##trim) ())
   with
  | Not_found -> ()
  | exc ->
      Firebug.console##log_3
        (Js.string ".config/init.ml exception")
        (Js.string (Printexc.to_string exc))
        exc);
  try
    let code = List.assoc "code" (parse_hash ()) in
    textbox##.value := Js.string (B64.decode code);
    Lwt.async (fun () ->
        execute (Js.to_string textbox##.value##trim) ())
  with
  | Not_found -> ()
  | exc ->
      Firebug.console##log_3 (Js.string "exception")
        (Js.string (Printexc.to_string exc))
        exc