Source file ocamlbuild.ml

(*********************************************************************************)
(*                Chamo                                                          *)
(*                                                                               *)
(*    Copyright (C) 2003-2021 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    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 General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU 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                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(* $Id: cam_messages.ml 334 2006-10-06 07:34:42Z zoggy $ *)

(** Using ocamlbuild. *)

let commands = Hashtbl.create 17;;
let history = Minibuffer.history ();;

let default_build_command file =
  let out = Printf.sprintf "%s.byte"
    (Filename.chop_extension (Filename.basename file))
  in
  let wd = Unix.getcwd () in
  prerr_endline file;
  if Misc.is_prefix wd file then
    (
     let len_file = String.length file in
     let len_wd = String.length wd in
     let s = String.sub file (len_wd + 1) (len_file - len_wd - 1) in
     let inc = Filename.dirname s in
     Printf.sprintf "ocamlbuild -I %s %s"
       (Filename.quote inc) (Filename.quote out)
    )
  else if Filename.is_relative file then
      (
       let inc = Filename.dirname file in
       Printf.sprintf "ocamlbuild -I %s %s"
        (Filename.quote inc) (Filename.quote out)
      )
    else
      (
       let d = Filename.dirname file in
       Printf.sprintf "(cd %s && ocamlbuild %s)"
         (Filename.quote d) (Filename.quote out)
      )
;;

let output_name = "ocamlbuild";;
let ocamlbuild_output = ref None;;
let ocamlbuild_output () =
  match !ocamlbuild_output with
    None ->
      let o = new Outputs.text_output
        ~on_destroy: (fun () -> ocamlbuild_output := None)
          output_name
      in
      ocamlbuild_output := Some o ;
      o
  | Some o -> o
;;

let goto_error file ~start:(lstart,cstart) ~stop:(lstop,cstop) error =
  match !Sourceview.active_sourceview with
    None -> ()
  | Some v ->
      let com = Printf.sprintf "open_file \"%s\" %d,%d" file (lstart-1) cstart in
      Commands.eval_command com;
(*      v#set_location ((line-1), start);*)
      let (s,line2) =
        if lstop = lstart then
          "", ""
        else
          "s", Printf.sprintf "-%d" lstop
      in
      let mes = Printf.sprintf "Line%s %d%s, characters %d-%d: %s" 
        s lstart line2 cstart cstop error in
      Misc.error_message (Misc.to_utf8 mes);
      let line_offset = Misc.char_of_line file (lstart-1) in
      let line_offset2 = 
        if lstart = lstop then
          line_offset
        else
          Misc.char_of_line file (lstop-1)
      in
      v#select_range_in_file
        ~left: (line_offset + cstart)
        ~right: (line_offset2 + cstop)
        ()
;;

type problem =
  { pb_file : string ;
    pb_lstart : int ;
    pb_lstop : int ;
    pb_cstart : int ;
    pb_cstop : int ;
    pb_kind : [ `Error of string | `Warning of char * string ] ;
  }
;;

let warning_is_error c =
  let to_show = Commands.safe_get_global "warn_error" in
  let len = String.length to_show in
  let res = ref false in
  for i = 0 to len - 1 do
    if to_show.[i] = c || to_show.[i] = 'A' then
      res := true
    else if to_show.[i] = Char.lowercase_ascii c || to_show.[i] = 'a' then
        res := false
  done;
  !res
;;

let re_location =
  Re.(compile
   (seq
    [ str "File " ;
      char '"' ;
      group (rep (diff any (char '"'))) ;
      char '"' ;
      str ", line" ; opt(char 's'); char ' ' ;
      group (rep1 digit) ;
      opt (seq [char '-' ; group (rep1 digit)]) ;
      str ", characters " ;
      group (rep1 digit);
      char '-' ;
      group (rep1 digit) ;
    ]))

let analyze_ocaml_compilation on_problem text =
  let lines = Misc.split_string text ['\n'] in
  let rec iter = function
    [] | [_] -> ()
  | line1 :: line2 :: q ->
      try
        let g = Re.exec re_location line1 in
        let file = Re.Group.get g 1 in
        let lstart = int_of_string (Re.Group.get g 2) in
        let lstop = try int_of_string (Re.Group.get g 3) with _ -> lstart in
        let cstart = int_of_string (Re.Group.get g 4) in
        let cstop = int_of_string (Re.Group.get g 5) in
        let kind =
          try
            let f c =
              let line_len = String.length line2 in
              let warn_len = String.length "Warning X: " in
              let msg = String.sub line2 warn_len (line_len - warn_len) in
              `Warning (c, msg)
            in
            Scanf.sscanf line2 "Warning %c: " f
          with _ -> `Error line2
        in
        let pb =
          { pb_file = file ;
            pb_lstart = lstart ;
            pb_lstop =  lstop ;
            pb_cstart = cstart ;
            pb_cstop = cstop ;
            pb_kind = kind ;
          }
        in
        if on_problem pb then iter q else ()
      with Not_found -> iter (line2 :: q)
  in
  iter lines
;;

let run ?(output=ocamlbuild_output()) command =
  let outputs = Outputs.outputs () in
  let output' =
    try outputs#output_by_name output#name
    with Not_found ->
        outputs#add_output (output :> Outputs.output);
        outputs#output_by_name output#name
  in
  outputs#show output#name;
  output#set_label (Printf.sprintf "%s (...)" output#name) ;
  let on_end code =
    output'#set_label (Printf.sprintf "%s (%d)" output#name code);
    analyze_ocaml_compilation
      (fun pb ->
         let error = match pb.pb_kind with
           | `Error s -> Some s
           | `Warning (c, s) ->
               if warning_is_error c then
                 Some s
               else
                 None
         in
         match error with
         | None -> true
         | Some msg ->
             goto_error pb.pb_file
               ~start:(pb.pb_lstart, pb.pb_cstart)
               ~stop:(pb.pb_lstop, pb.pb_cstop) msg;
             false
      )
      output#contents
  in
  output#run ~reset: true command on_end

;;

let build (v:Sourceview.sourceview) args =
  let file = v#file#filename in
  let com =
    try Hashtbl.find commands file
    with Not_found -> default_build_command file
  in
  let on_ok com =
    Hashtbl.replace commands file com;
    Ocf.set Mode_ocaml_rc.ocamlbuild_commands
      (Hashtbl.fold
       (fun f com acc -> (f,com)::acc) commands []);
    run com
  in
  Misc.input_string ~history
    v#minibuffer
    ~title: "Command" (Misc.to_utf8 com) on_ok
;;