780 lines
27 KiB
OCaml
780 lines
27 KiB
OCaml
(**************************************************************************)
|
|
(* *)
|
|
(* OCaml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Gallium, INRIA Paris *)
|
|
(* Jacques Garrigue, Nagoya University *)
|
|
(* Florian Angeletti *)
|
|
(* *)
|
|
(* Copyright 2018 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. *)
|
|
(* *)
|
|
(* All rights reserved. This file is distributed under the terms of *)
|
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
|
(* special exception on linking described in the file LICENSE. *)
|
|
(* *)
|
|
(**************************************************************************)
|
|
|
|
[@@@warning "a-40-6"]
|
|
open StdLabels
|
|
open Str
|
|
|
|
let camlprefix = "caml"
|
|
|
|
let latex_escape s = String.concat "" ["$"; s; "$"]
|
|
let camlin = latex_escape {|\\?|} ^ {|\1|}
|
|
let camlout = latex_escape {|\\:|} ^ {|\1|}
|
|
let camlbunderline = "<<"
|
|
let camleunderline = ">>"
|
|
|
|
|
|
(** Restrict the number of latex environment *)
|
|
type env = Env of string
|
|
let main = Env "example"
|
|
let input_env = Env "input"
|
|
let ok_output = Env "output"
|
|
let error = Env "error"
|
|
let warning = Env "warn"
|
|
let phrase_env = Env ""
|
|
|
|
let start out (Env s) args =
|
|
Format.fprintf out "\\begin{%s%s}" camlprefix s;
|
|
List.iter (Format.fprintf out "{%s}") args;
|
|
Format.fprintf out "\n"
|
|
|
|
let stop out (Env s) =
|
|
Format.fprintf out "\\end{%s%s}" camlprefix s;
|
|
Format.fprintf out "\n"
|
|
|
|
let code_env env out s =
|
|
let sep = if s.[String.length s - 1] = '\n' then "" else "\n" in
|
|
Format.fprintf out "%a%s%s%a"
|
|
(fun ppf env -> start ppf env [])
|
|
env s sep stop env
|
|
|
|
|
|
type example_mode = Toplevel | Verbatim | Signature
|
|
let string_of_mode = function
|
|
| Toplevel -> "toplevel"
|
|
| Verbatim -> "verbatim"
|
|
| Signature -> "signature"
|
|
|
|
|
|
let verbose = ref true
|
|
let linelen = ref 72
|
|
let outfile = ref ""
|
|
let cut_at_blanks = ref false
|
|
let files = ref []
|
|
let repo_root = ref ""
|
|
|
|
let (~!) =
|
|
let memo = ref [] in
|
|
fun key ->
|
|
try List.assq key !memo
|
|
with Not_found ->
|
|
let data = Str.regexp key in
|
|
memo := (key, data) :: !memo;
|
|
data
|
|
|
|
exception Phrase_parsing of string
|
|
|
|
module Toplevel = struct
|
|
(** Initialize the toplevel loop, redirect stdout and stderr,
|
|
capture warnings and error messages *)
|
|
|
|
type output =
|
|
{
|
|
error : string; (** error message text *)
|
|
warnings : string list; (** warning messages text *)
|
|
values : string; (** toplevel output *)
|
|
stdout : string; (** output printed on the toplevel stdout *)
|
|
underlined : (int * int) list
|
|
(** locations to underline in input phrases *)
|
|
}
|
|
|
|
let buffer_fmt () =
|
|
let b = Buffer.create 30 in b, Format.formatter_of_buffer b
|
|
|
|
let error_fmt = buffer_fmt ()
|
|
let warning_fmt = buffer_fmt ()
|
|
|
|
let out_fmt = buffer_fmt ()
|
|
|
|
let flush_fmt (b,fmt) =
|
|
Format.pp_print_flush fmt ();
|
|
let r = Buffer.contents b in
|
|
Buffer.reset b;
|
|
r
|
|
|
|
(** Redirect the stdout *)
|
|
let stdout_out, stdout_in = Unix.pipe ~cloexec:true ()
|
|
let () = Unix.dup2 stdout_in Unix.stdout
|
|
|
|
let self_error_fmt = Format.formatter_of_out_channel stderr
|
|
let eprintf = Format.eprintf
|
|
|
|
let read_stdout =
|
|
let size = 50 in
|
|
let b = Bytes.create size in
|
|
let buffer = Buffer.create 100 in
|
|
let rec read_toplevel_stdout () =
|
|
match Unix.select[stdout_out][][] 0. with
|
|
| [a], _, _ ->
|
|
let n = Unix.read stdout_out b 0 size in
|
|
Buffer.add_subbytes buffer b 0 n;
|
|
if n = size then read_toplevel_stdout ()
|
|
| _ -> ()
|
|
in
|
|
fun () ->
|
|
let () = flush stdout; read_toplevel_stdout () in
|
|
let r = Buffer.contents buffer in
|
|
Buffer.reset buffer;
|
|
r
|
|
|
|
(** Store character intervals directly *)
|
|
let locs = ref []
|
|
let register_loc (loc : Location.t) =
|
|
let startchar = loc.loc_start.pos_cnum in
|
|
let endchar = loc.loc_end.pos_cnum in
|
|
if startchar >= 0 then
|
|
locs := (startchar, endchar) :: !locs
|
|
|
|
(** Record locations in the main error and suberrors without printing them *)
|
|
let printer_register_locs =
|
|
let base = Location.batch_mode_printer in
|
|
{ Location.pp_main_loc = (fun _ _ _ loc -> register_loc loc);
|
|
pp_submsg_loc = (fun _ _ _ loc -> register_loc loc);
|
|
|
|
(* The following fields are kept identical to [base],
|
|
listed explicitly so that future field additions result in an error
|
|
-- using (Location.batch_mode_printer with ...) would be the symmetric
|
|
problem to a fragile pattern-matching. *)
|
|
pp = base.pp;
|
|
pp_report_kind = base.pp_report_kind;
|
|
pp_main_txt = base.pp_main_txt;
|
|
pp_submsgs = base.pp_submsgs;
|
|
pp_submsg = base.pp_submsg;
|
|
pp_submsg_txt = base.pp_submsg_txt;
|
|
}
|
|
|
|
(** Capture warnings and keep them in a list *)
|
|
let warnings = ref []
|
|
let report_printer =
|
|
(* Extend [printer_register_locs] *)
|
|
let pp self ppf report =
|
|
match report.Location.kind with
|
|
| Location.Report_warning _ | Location.Report_warning_as_error _ ->
|
|
printer_register_locs.pp self (snd warning_fmt) report;
|
|
let w = flush_fmt warning_fmt in
|
|
warnings := w :: !warnings
|
|
| _ ->
|
|
printer_register_locs.pp self ppf report
|
|
in
|
|
{ printer_register_locs with pp }
|
|
|
|
let fatal ic oc fmt =
|
|
Format.kfprintf
|
|
(fun ppf -> Format.fprintf ppf "@]@."; close_in ic; close_out oc; exit 1)
|
|
self_error_fmt ("@[<hov 2> Error " ^^ fmt)
|
|
|
|
let init () =
|
|
Location.report_printer := (fun () -> report_printer);
|
|
Clflags.color := Some Misc.Color.Never;
|
|
Clflags.no_std_include := true;
|
|
Compenv.last_include_dirs := [Filename.concat !repo_root "stdlib"];
|
|
Compmisc.init_path ();
|
|
try
|
|
Toploop.initialize_toplevel_env ();
|
|
Sys.interactive := false
|
|
with _ ->
|
|
(eprintf "Invalid repo root: %s?%!" !repo_root; exit 2)
|
|
|
|
let exec (_,ppf) p =
|
|
try
|
|
ignore @@ Toploop.execute_phrase true ppf p
|
|
with exn ->
|
|
let bt = Printexc.get_raw_backtrace () in
|
|
begin try Location.report_exception (snd error_fmt) exn
|
|
with _ ->
|
|
eprintf "Uncaught exception: %s\n%s\n"
|
|
(Printexc.to_string exn)
|
|
(Printexc.raw_backtrace_to_string bt)
|
|
end
|
|
|
|
let parse fname mode s =
|
|
let lex = Lexing.from_string s in
|
|
Location.init lex fname;
|
|
Location.input_name := fname;
|
|
Location.input_lexbuf := Some lex;
|
|
try
|
|
match mode with
|
|
| Toplevel -> Parse.toplevel_phrase lex
|
|
| Verbatim -> Ptop_def (Parse.implementation lex)
|
|
| Signature ->
|
|
let sign = Parse.interface lex in
|
|
let name = Location.mknoloc "wrap" in
|
|
let str =
|
|
Ast_helper.[Str.modtype @@ Mtd.mk ~typ:(Mty.signature sign) name] in
|
|
Ptop_def str
|
|
with
|
|
| Lexer.Error _ | Syntaxerr.Error _ ->
|
|
raise (Phrase_parsing s)
|
|
|
|
let take x = let r = !x in x := []; r
|
|
|
|
let read_output () =
|
|
let warnings = take warnings in
|
|
let error = flush_fmt error_fmt in
|
|
let values =
|
|
replace_first ~!{|^#\( *\*\)* *|} "" @@ flush_fmt out_fmt in
|
|
(* the inner ( *\* )* group is here to clean the starting "*"
|
|
introduced for multiline comments *)
|
|
let underlined = take locs in
|
|
let stdout = read_stdout () in
|
|
{ values; warnings; error; stdout; underlined }
|
|
|
|
(** exec and ignore all output from the toplevel *)
|
|
let eval b =
|
|
let s = Buffer.contents b in
|
|
let ast = Parse.toplevel_phrase (Lexing.from_string s) in
|
|
exec out_fmt ast;
|
|
ignore (read_output());
|
|
Buffer.reset b
|
|
|
|
end
|
|
|
|
let () =
|
|
Arg.parse ["-n", Arg.Int (fun n -> linelen := n), "line length";
|
|
"-o", Arg.String (fun s -> outfile := s), "output";
|
|
"-repo-root", Arg.String ((:=) repo_root ), "repo root";
|
|
"-w", Arg.Set cut_at_blanks, "cut at blanks";
|
|
"-v", Arg.Bool (fun b -> verbose := b ), "output result on stderr"
|
|
]
|
|
(fun s -> files := s :: !files)
|
|
"caml-tex: ";
|
|
Toplevel.init ()
|
|
|
|
|
|
(** The Output module deals with the analysis and classification
|
|
of the interpreter output and the parsing of status-related options
|
|
or annotations for the caml_example environment *)
|
|
module Output = struct
|
|
|
|
(** Interpreter output status *)
|
|
type status =
|
|
| Ok
|
|
| Warning of int
|
|
| Error
|
|
|
|
type kind =
|
|
| Annotation (** Local annotation: [ [@@expect (*annotation*) ] ]*)
|
|
| Option (** Global environment option:
|
|
[\begin{caml_example}[option[=value]]
|
|
...
|
|
\end{caml_example}] *)
|
|
|
|
(** Pretty printer for status *)
|
|
let pp_status ppf = function
|
|
| Error -> Format.fprintf ppf "error"
|
|
| Ok -> Format.fprintf ppf "ok"
|
|
| Warning n -> Format.fprintf ppf "warning %d" n
|
|
|
|
(** Pretty printer for status preceded with an undefined determinant *)
|
|
let pp_a_status ppf = function
|
|
| Error -> Format.fprintf ppf "an error"
|
|
| Ok -> Format.fprintf ppf "an ok"
|
|
| Warning n -> Format.fprintf ppf "a warning %d" n
|
|
|
|
(** {1 Related latex environment } *)
|
|
let env = function
|
|
| Error -> error
|
|
| Warning _ -> warning
|
|
| Ok -> ok_output
|
|
|
|
(** {1 Exceptions } *)
|
|
exception Parsing_error of kind * string
|
|
|
|
type source =
|
|
{
|
|
file : string;
|
|
lines : int * int;
|
|
phrase : string;
|
|
output : string
|
|
}
|
|
type unexpected_report = {source : source; expected : status; got : status}
|
|
exception Unexpected_status of unexpected_report
|
|
|
|
let print_source ppf {file; lines = (start, stop); phrase; output} =
|
|
Format.fprintf ppf "%s, lines %d to %d:\n\"\n%s\n\"\n\"\n%s\n\"."
|
|
file start stop phrase output
|
|
|
|
let print_unexpected {source; expected; got} =
|
|
if expected = Ok then
|
|
Toplevel.eprintf
|
|
"Error when evaluating a caml_example environment in %a\n\
|
|
Unexpected %a status.\n\
|
|
If %a status was expected, add an [@@expect %a] annotation.\n"
|
|
print_source source
|
|
pp_status got
|
|
pp_a_status got
|
|
pp_status got
|
|
else
|
|
Toplevel.eprintf
|
|
"Error when evaluating a guarded caml_example environment in %a\n\
|
|
Unexpected %a status, %a status was expected.\n\
|
|
If %a status was in fact expected, change the status annotation to \
|
|
[@@expect %a].\n"
|
|
print_source source
|
|
pp_status got
|
|
pp_a_status expected
|
|
pp_a_status got
|
|
pp_status got;
|
|
flush stderr
|
|
|
|
let print_parsing_error k s =
|
|
match k with
|
|
| Option ->
|
|
Toplevel.eprintf
|
|
"Unknown caml_example option: [%s].\n\
|
|
Supported options are \"ok\",\"error\", or \"warning=n\" (with n \
|
|
a warning number).\n" s
|
|
| Annotation ->
|
|
Toplevel.eprintf
|
|
"Unknown caml_example phrase annotation: [@@expect %s].\n\
|
|
Supported annotations are [@@expect ok], [@@expect error],\n\
|
|
and [@@expect warning n] (with n a warning number).\n" s
|
|
|
|
(** {1 Output analysis} *)
|
|
let catch_error = function
|
|
| "" -> None
|
|
| _ -> Some Error
|
|
|
|
let catch_warning =
|
|
function
|
|
| [] -> None
|
|
| s :: _ when string_match ~!{|Warning \([0-9]+\)\( \[[a-z-]+\]\)?:|} s 0 ->
|
|
Some (Warning (int_of_string @@ matched_group 1 s))
|
|
| _ -> None
|
|
|
|
let status ws es =
|
|
match catch_warning ws, catch_error es with
|
|
| Some w, _ -> w
|
|
| None, Some e -> e
|
|
| None, None -> Ok
|
|
|
|
(** {1 Parsing caml_example options } *)
|
|
|
|
(** Parse [warning=n] options for caml_example options *)
|
|
let parse_warning s =
|
|
if string_match ~!{|warning=\([0-9]+\)|} s 0 then
|
|
Some (Warning (int_of_string @@ matched_group 1 s))
|
|
else
|
|
None
|
|
|
|
(** Parse [warning n] annotations *)
|
|
let parse_local_warning s =
|
|
if string_match ~!{|warning \([0-9]+\)|} s 0 then
|
|
Some (Warning (int_of_string @@ matched_group 1 s))
|
|
else
|
|
None
|
|
|
|
let parse_error s =
|
|
if s="error" then Some Error else None
|
|
|
|
let parse_ok s =
|
|
if s = "ok" then Some Ok else None
|
|
|
|
(** Parse the environment-wide expected status output *)
|
|
let expected s =
|
|
match parse_warning s, parse_error s with
|
|
| Some w, _ -> w
|
|
| None, Some e -> e
|
|
| None, None -> raise (Parsing_error (Option,s))
|
|
|
|
(** Parse the local (i.e. phrase-wide) expected status output *)
|
|
let local_expected s =
|
|
match parse_local_warning s, parse_error s, parse_ok s with
|
|
| Some w, _, _ -> w
|
|
| None, Some e, _ -> e
|
|
| None, None, Some ok -> ok
|
|
| None, None, None -> raise (Parsing_error (Annotation,s))
|
|
|
|
end
|
|
|
|
module Text_transform = struct
|
|
|
|
type kind =
|
|
| Underline
|
|
| Ellipsis
|
|
|
|
type t = { kind : kind; start : int; stop : int}
|
|
exception Intersection of
|
|
{
|
|
line : int;
|
|
file : string;
|
|
left : t;
|
|
right : t;
|
|
}
|
|
|
|
let pp ppf = function
|
|
| Underline -> Format.fprintf ppf "underline"
|
|
| Ellipsis -> Format.fprintf ppf "ellipsis"
|
|
|
|
let underline start stop = { kind = Underline; start; stop}
|
|
let ellipsis start stop = { kind = Ellipsis; start; stop }
|
|
|
|
let escape_specials s =
|
|
s
|
|
|> global_replace ~!{|\$|} {|$\textdollar$|}
|
|
|
|
let rec apply_transform input (pos,underline_stop,out) t =
|
|
if pos >= String.length input then pos, underline_stop, out
|
|
else match underline_stop with
|
|
| Some stop when stop <= t.start ->
|
|
let f = escape_specials (String.sub input ~pos ~len:(stop - pos)) in
|
|
let out = camleunderline :: f :: out in
|
|
apply_transform input (stop,None,out) t
|
|
| _ ->
|
|
let out =
|
|
escape_specials (String.sub input ~pos ~len:(t.start - pos))::out in
|
|
match t.kind with
|
|
| Ellipsis -> t.stop, underline_stop, latex_escape {|\ldots|} :: out
|
|
| Underline ->
|
|
t.start, Some t.stop, camlbunderline :: out
|
|
|
|
(** Check that all ellipsis are strictly nested inside underline transform
|
|
and that otherwise no transform starts before the end of the previous
|
|
transform in a list of transforms *)
|
|
type partition = U of t * t list | E of t
|
|
let check_partition line file l =
|
|
let init = ellipsis 0 0 in
|
|
let rec partition = function
|
|
| [] -> []
|
|
| {kind=Underline; _ } as t :: q -> underline t [] q
|
|
| {kind=Ellipsis; _ } as t :: q -> E t :: partition q
|
|
and underline u n = function
|
|
| [] -> end_underline u n []
|
|
| {kind=Underline; _ } :: _ as q -> end_underline u n q
|
|
| {kind=Ellipsis; _ } as t :: q ->
|
|
if t.stop < u.stop then underline u (t::n) q
|
|
else end_underline u n (t::q)
|
|
and end_underline u n l = U(u,List.rev n) :: partition l in
|
|
let check_elt last t =
|
|
if t.start < last.stop then
|
|
raise (Intersection {line;file; left = last; right = t})
|
|
else
|
|
t in
|
|
let check acc = function
|
|
| E t -> check_elt acc t
|
|
| U(u,n) ->
|
|
let _ = check_elt acc u in
|
|
let _ = List.fold_left ~f:check_elt ~init n in
|
|
u in
|
|
List.fold_left ~f:check ~init (partition l)
|
|
|> ignore
|
|
|
|
let apply ts file line s =
|
|
(* remove duplicated transforms that can appear due to
|
|
duplicated parse tree elements. For instance,
|
|
[let f : (_ [@ellipsis] = ()] is transformed to
|
|
[let f: (_ [@ellipsis]) = (():(_ [@ellipsis])] with the same location
|
|
for the two ellipses. *)
|
|
let ts = List.sort_uniq compare ts in
|
|
let ts = List.sort (fun x y -> compare x.start y.start) ts in
|
|
check_partition line file ts;
|
|
let last, underline, ls =
|
|
List.fold_left ~f:(apply_transform s) ~init:(0,None,[]) ts in
|
|
let last, ls = match underline with
|
|
| None -> last, ls
|
|
| Some stop ->
|
|
let f = escape_specials (String.sub s ~pos:last ~len:(stop - last)) in
|
|
stop, camleunderline :: f :: ls in
|
|
let ls =
|
|
let n = String.length s in
|
|
if last = n then ls else
|
|
escape_specials (String.sub s last (n-last)) :: ls in
|
|
String.concat "" (List.rev ls)
|
|
end
|
|
|
|
|
|
exception Missing_double_semicolon of string * int
|
|
|
|
exception Missing_mode of string * int
|
|
|
|
type incompatibility =
|
|
| Signature_with_visible_answer of string * int
|
|
exception Incompatible_options of incompatibility
|
|
|
|
|
|
module Ellipsis = struct
|
|
(** This module implements the extraction of ellipsis locations
|
|
from phrases.
|
|
|
|
An ellipsis is either an [[@ellipsis]] attribute, or a pair
|
|
of [[@@@ellipsis.start]...[@@@ellipsis.stop]] attributes. *)
|
|
|
|
exception Unmatched_ellipsis of {kind : string; start : int; stop : int}
|
|
(** raised when an [[@@@ellipsis.start]] or [[@@@ellipsis.stop]] is
|
|
not paired with another ellipsis attribute *)
|
|
|
|
exception Nested_ellipses of {first : int ; second : int}
|
|
(** raised by [[@@@ellipsis.start][@@@ellipsis.start]] *)
|
|
|
|
let extract f x =
|
|
let transforms = ref [] in
|
|
let last_loc = ref Location.none in
|
|
let left_mark = ref None (* stored position of [@@@ellipsis.start]*) in
|
|
let location _this loc =
|
|
(* we rely on the fact that the default iterator calls first
|
|
the location subiterator, then the attribute subiterator *)
|
|
last_loc := loc in
|
|
let attribute _this attr =
|
|
let module L = Location in
|
|
let module P = Parsetree in
|
|
let name = attr.P.attr_name.L.txt in
|
|
let loc = !last_loc in
|
|
let start = loc.L.loc_start.Lexing.pos_cnum in
|
|
let attr_start = attr.P.attr_loc.L.loc_start.Lexing.pos_cnum in
|
|
let attr_stop = attr.P.attr_loc.L.loc_end.Lexing.pos_cnum in
|
|
let stop = max loc.L.loc_end.Lexing.pos_cnum attr_stop in
|
|
let check_nested () = match !left_mark with
|
|
| Some (first,_) -> raise (Nested_ellipses {first; second=attr_start})
|
|
| None -> () in
|
|
match name with
|
|
| "ellipsis" ->
|
|
check_nested ();
|
|
transforms :=
|
|
{Text_transform.kind=Ellipsis; start; stop }
|
|
:: !transforms
|
|
| "ellipsis.start" ->
|
|
check_nested ();
|
|
left_mark := Some (start, stop)
|
|
| "ellipsis.stop" ->
|
|
begin match !left_mark with
|
|
| None -> raise (Unmatched_ellipsis {kind="right"; start; stop})
|
|
| Some (start', stop' ) ->
|
|
let start, stop = min start start', max stop stop' in
|
|
transforms := {kind=Ellipsis; start ; stop } :: !transforms;
|
|
left_mark := None
|
|
end
|
|
| _ -> ()
|
|
in
|
|
f {Ast_iterator.default_iterator with location; attribute} x;
|
|
(match !left_mark with
|
|
| None -> ()
|
|
| Some (start,stop) ->
|
|
raise (Unmatched_ellipsis {kind="left"; start; stop })
|
|
);
|
|
!transforms
|
|
|
|
let find = function
|
|
| Parsetree.Ptop_def ast -> extract (fun it -> it.structure it) ast
|
|
| Ptop_dir _ -> []
|
|
|
|
end
|
|
|
|
let process_file file =
|
|
let ic = try open_in file with _ -> failwith "Cannot read input file" in
|
|
let phrase_start = ref 1 and phrase_stop = ref 1 in
|
|
let incr_phrase_start () =
|
|
incr phrase_start;
|
|
phrase_stop := !phrase_start in
|
|
let oc =
|
|
try if !outfile = "-" then
|
|
stdout
|
|
else if !outfile = "" then
|
|
open_out (replace_first ~!"\\.tex$" "" file ^ ".ml.tex")
|
|
else
|
|
open_out_gen [Open_wronly; Open_creat; Open_append; Open_text]
|
|
0x666 !outfile
|
|
with _ -> failwith "Cannot open output file" in
|
|
let tex_fmt = Format.formatter_of_out_channel oc in
|
|
let fatal x = Toplevel.fatal ic oc x in
|
|
let re_spaces = "[ \t]*" in
|
|
let re_start = ~!(
|
|
{|\\begin{caml_example\(\*?\)}|} ^ re_spaces
|
|
^ {|\({toplevel}\|{verbatim}\|{signature}\)?|} ^ re_spaces
|
|
^ {|\(\[\(.*\)\]\)?|} ^ re_spaces
|
|
^ "$"
|
|
) in
|
|
try while true do
|
|
let input = ref (input_line ic) in
|
|
incr_phrase_start();
|
|
if string_match re_start !input 0
|
|
then begin
|
|
let omit_answer = matched_group 1 !input = "*" in
|
|
let mode =
|
|
match matched_group 2 !input with
|
|
| exception Not_found -> raise (Missing_mode(file, !phrase_stop))
|
|
| "{toplevel}" -> Toplevel
|
|
| "{verbatim}" -> Verbatim
|
|
| "{signature}" -> Signature
|
|
| _ -> assert false in
|
|
if mode = Signature && not omit_answer then raise
|
|
(Incompatible_options(
|
|
Signature_with_visible_answer(file,!phrase_stop))
|
|
);
|
|
let explicit_stop = match mode with
|
|
| Verbatim | Signature -> false
|
|
| Toplevel -> true in
|
|
let global_expected = try Output.expected @@ matched_group 4 !input
|
|
with Not_found -> Output.Ok in
|
|
start tex_fmt main [string_of_mode mode];
|
|
let first = ref true in
|
|
let read_phrase () =
|
|
let phrase = Buffer.create 256 in
|
|
let rec read () =
|
|
let input = incr phrase_stop; input_line ic in
|
|
let implicit_stop =
|
|
if string_match ~!"\\\\end{caml_example\\*?}[ \t]*$"
|
|
input 0
|
|
then
|
|
begin
|
|
if !phrase_stop = 1 + !phrase_start then
|
|
raise End_of_file
|
|
else if explicit_stop then
|
|
raise @@ Missing_double_semicolon (file,!phrase_stop)
|
|
else
|
|
true
|
|
end
|
|
else false in
|
|
if Buffer.length phrase > 0 then Buffer.add_char phrase '\n';
|
|
let stop =
|
|
implicit_stop ||
|
|
( not (mode = Signature)
|
|
&& string_match ~!"\\(.*\\)[ \t]*;;[ \t]*$" input 0 )
|
|
in
|
|
if not stop then (
|
|
Buffer.add_string phrase input; read ()
|
|
)
|
|
else begin
|
|
decr phrase_stop;
|
|
let last_input =
|
|
if implicit_stop then "" else matched_group 1 input in
|
|
let expected =
|
|
if string_match ~!{|\(.*\)\[@@expect \(.*\)\]|} last_input 0 then
|
|
( Buffer.add_string phrase (matched_group 1 last_input);
|
|
Output.local_expected @@ matched_group 2 last_input )
|
|
else
|
|
(Buffer.add_string phrase last_input; global_expected)
|
|
in
|
|
if not implicit_stop then Buffer.add_string phrase ";;";
|
|
implicit_stop, Buffer.contents phrase, expected
|
|
end in
|
|
read ()
|
|
in
|
|
try while true do
|
|
let implicit_stop, phrase, expected = read_phrase () in
|
|
let ast = Toplevel.parse file mode phrase in
|
|
let ellipses = Ellipsis.find ast in
|
|
let () = Toplevel.(exec out_fmt) ast in
|
|
let out = Toplevel.read_output () in
|
|
let error_msgs = String.concat "" (out.warnings @ [out.error]) in
|
|
let output = String.concat "" [error_msgs; out.stdout; out.values] in
|
|
let status = Output.status out.warnings out.error in
|
|
if status <> expected then (
|
|
let source = Output.{
|
|
file;
|
|
lines = (!phrase_start, !phrase_stop);
|
|
phrase;
|
|
output
|
|
} in
|
|
raise (Output.Unexpected_status
|
|
{Output.got=status; expected; source} ) )
|
|
else ( incr phrase_stop; phrase_start := !phrase_stop );
|
|
let phrase =
|
|
let underline =
|
|
List.map (fun (x,y) -> Text_transform.underline x y)
|
|
out.underlined in
|
|
Text_transform.apply (underline @ ellipses)
|
|
file !phrase_stop phrase in
|
|
(* Special characters may also appear in output strings -Didier *)
|
|
let output = Text_transform.escape_specials output in
|
|
let phrase = global_replace ~!{|^\(.\)|} camlin phrase
|
|
and output = global_replace ~!{|^\(.\)|} camlout output in
|
|
let final_output =
|
|
if omit_answer && String.length error_msgs > 0 then
|
|
global_replace ~!{|^\(.\)|} camlout error_msgs
|
|
else if omit_answer then ""
|
|
else output in
|
|
start tex_fmt phrase_env [];
|
|
code_env input_env tex_fmt phrase;
|
|
if String.length final_output > 0 then
|
|
code_env (Output.env status) tex_fmt final_output;
|
|
stop tex_fmt phrase_env;
|
|
flush oc;
|
|
first := false;
|
|
if implicit_stop then raise End_of_file
|
|
done
|
|
with End_of_file -> phrase_start:= !phrase_stop; stop tex_fmt main
|
|
end
|
|
else if string_match ~!"\\\\begin{caml_eval}[ \t]*$" !input 0
|
|
then begin
|
|
let eval_buffer = Buffer.create 256 in
|
|
while input := input_line ic;
|
|
not (string_match ~!"\\\\end{caml_eval}[ \t]*$" !input 0)
|
|
do
|
|
Buffer.add_string eval_buffer !input;
|
|
Buffer.add_char eval_buffer '\n';
|
|
if string_match ~!".*;;[ \t]*$" !input 0 then begin
|
|
Toplevel.eval eval_buffer
|
|
end
|
|
done;
|
|
if Buffer.length eval_buffer > 0 then
|
|
( Buffer.add_string eval_buffer ";;\n"; Toplevel.eval eval_buffer )
|
|
end else begin
|
|
Format.fprintf tex_fmt "%s\n" !input;
|
|
Format.pp_print_flush tex_fmt ()
|
|
end
|
|
done with
|
|
| End_of_file -> close_in ic; close_out oc
|
|
| Output.Unexpected_status r ->
|
|
( Output.print_unexpected r; close_in ic; close_out oc; exit 1 )
|
|
| Output.Parsing_error (k,s) ->
|
|
( Output.print_parsing_error k s;
|
|
close_in ic; close_out oc; exit 1 )
|
|
| Phrase_parsing s -> fatal "when parsing the following phrase:@ %s" s
|
|
| Missing_double_semicolon (file, line_number) ->
|
|
fatal
|
|
"when evaluating a caml_example environment in %s:@;\
|
|
missing \";;\" at line %d" file (line_number-2)
|
|
| Missing_mode (file, line_number) ->
|
|
fatal "when parsing a caml_example environment in %s:@;\
|
|
missing mode argument at line %d,@ \
|
|
available modes {toplevel,verbatim}"
|
|
file (line_number-2)
|
|
| Incompatible_options Signature_with_visible_answer (file, line_number) ->
|
|
fatal
|
|
"when parsing a caml_example environment in@ \
|
|
%s, line %d:@,\
|
|
the signature mode is only compatible with \"caml_example*\"@ \
|
|
Hint: did you forget to add \"*\"?"
|
|
file (line_number-2);
|
|
| Text_transform.Intersection {line;file;left;right} ->
|
|
fatal
|
|
"when evaluating a caml_example environment in %s, line %d:@ \
|
|
Textual transforms must be well-separated.@ The \"%a\" transform \
|
|
spanned the interval %d-%d,@ \
|
|
intersecting with another \"%a\" transform @ \
|
|
on the %d-%d interval.@ \
|
|
Hind: did you try to elide a code fragment which raised a warning?"
|
|
file (line-2)
|
|
Text_transform.pp left.kind left.start left.stop
|
|
Text_transform.pp right.kind right.start right.stop
|
|
| Ellipsis.Unmatched_ellipsis {kind;start;stop} ->
|
|
fatal "when evaluating a caml_example environment,@ \
|
|
the %s mark at position %d-%d was unmatched"
|
|
kind start stop
|
|
| Ellipsis.Nested_ellipses {first;second} ->
|
|
fatal "when evaluating a caml_example environment,@ \
|
|
there were two nested ellipsis attribute.@ The first one \
|
|
started at position %d,@ the second one at %d"
|
|
first second
|
|
|
|
let _ =
|
|
if !outfile <> "-" && !outfile <> "" then begin
|
|
try close_out (open_out !outfile)
|
|
with _ -> failwith "Cannot open output file"
|
|
end;
|
|
List.iter process_file (List.rev !files);
|