Simon Génier pushed to branch main at Stefan / Typer

Commits: 14166a24 by Simon Génier at 2023-02-21T12:46:55-05:00 Save contents of a source file so locations can refer to it.

- - - - - 22282068 by Simon Génier at 2023-03-22T18:03:27-04:00 Merge branch 'simon--source-container'

- - - - -

11 changed files:

- debug_util.ml - src/REPL.ml - src/debug.ml - src/elab.ml - src/eval.ml - src/lexer.ml - src/sexp.ml - src/source.ml - src/string.ml - tests/lexer_test.ml - tests/sexp_test.ml

Changes:

===================================== debug_util.ml ===================================== @@ -174,7 +174,7 @@ let format_source () = print_string (make_title " ERRORS ");

let filename = List.hd (!arg_files) in - let source = new Source.source_file filename in + let source = Source.of_path filename in let pretoks = prelex source in let toks = lex default_stt pretoks in let ctx = Elab.default_ectx in @@ -218,7 +218,7 @@ let main () =

(* get pretokens*) print_string yellow; - let source = new Source.source_file filename in + let source = Source.of_path filename in let pretoks = prelex source in print_string reset;

===================================== src/REPL.ml ===================================== @@ -123,7 +123,7 @@ let eval_interactive in loop nodes [] [] in

- let source = new Source.source_string input in + let source = Source.of_string ~label:(string_of_int i) input in let pretokens = prelex source in let tokens = lex Grammar.default_stt pretokens in (* FIXME: This is too eager: it prevents one declaration from changing the

===================================== src/debug.ml ===================================== @@ -119,10 +119,10 @@ let debug_pexp_print ptop = let debug_lexp_decls decls = let sep = " : " in List.iter (fun e -> - let ((loc, _name), lxp, _ltp) = e in + let ((sinfo, _name), lxp, _ltp) = e in + let loc = sexp_location sinfo in

- printf "%-15s[%s]" (lexp_name lxp) (Source.Location.to_string - (sexp_location loc)); + printf "%-15s[%s]" (lexp_name lxp) (Source.Location.to_string loc);

let str = lexp_str_decls (!debug_ppctx) [e] in

@@ -138,7 +138,8 @@ let debug_lexp_decls decls =

let str = match str with | scd :: tl - -> printf " FILE: %-25s : %s\n" (sexp_location loc).file scd; + -> let file = Source.Container.name loc.container in + printf " FILE: %-25s : %s\n" file scd; tl | _ -> [] in

===================================== src/elab.ml ===================================== @@ -1906,7 +1906,7 @@ let in_pervasive = ref true let sform_load usr_elctx loc sargs _ot =

let read_file file_name elctx = - let source = new Source.source_file file_name in + let source = Source.of_path file_name in let pres = try prelex source with | Sys_error _ @@ -2003,7 +2003,7 @@ let default_ectx

(* Read BTL files *) let read_file file_name elctx = - let source = new Source.source_file file_name in + let source = Source.of_path file_name in let pres = prelex source in let sxps = lex default_stt pres in let _, lctx = lexp_p_decls [] sxps elctx @@ -2060,7 +2060,7 @@ let lexp_expr_str str ctx = let tenv = default_stt in let grm = ectx_get_grammar ctx in let limit = Some ";" in - let source = new Source.source_string str in + let source = Source.of_string str in let pxps = sexp_parse_source source tenv grm limit in let lexps = lexp_parse_all pxps ctx in List.iter (fun lxp -> @@ -2071,7 +2071,7 @@ let lexp_expr_str str ctx =

let lexp_decl_str str ctx = let tenv = default_stt in - let source = new Source.source_string str in + let source = Source.of_string str in let tokens = lex_source source tenv in lexp_p_decls [] tokens ctx

@@ -2099,7 +2099,7 @@ let process_file : elab_context =

try - let source = new Source.source_file file_name in + let source = Source.of_path file_name in let pretokens = prelex source in let tokens = lex Grammar.default_stt pretokens in let ldecls, ectx' = lexp_p_decls [] tokens ectx in

===================================== src/eval.ml ===================================== @@ -356,7 +356,7 @@ let make_float loc _depth args_val = match args_val with let make_block loc _depth args_val = match args_val with (* From what would we like to make a block? *) | [Vstring str] - -> let source = new Source.source_string str in + -> let source = Source.of_string str in Vsexp (Block (loc, (Prelexer.prelex source))) | _ -> error loc "Sexp.block expects one string as argument"

===================================== src/lexer.ml ===================================== @@ -108,7 +108,7 @@ let lex_symbol

let mksym start_point escaped = if Source.Point.equal start_point source#point - then epsilon (Source.Location.of_point source#file start_point) + then epsilon (Source.Location.of_point source#container start_point) else let raw_name, location = source#slice start_point in let name = if escaped then unescape raw_name else raw_name in @@ -226,8 +226,8 @@ let lex (token_env : token_env) (pretokens : pretoken list) : sexp list = | Prestring (location, text) :: pretokens' -> loop pretokens' (String (location, text) :: acc)

- | Pretoken ({file; start = {line; column; _}; _}, name) :: pretokens' - -> let source = new Source.source_string ~file ~line ~column name in + | Pretoken (location, _) :: pretokens' + -> let source = Source.of_location location in let tokens = split_presymbol token_env source in loop pretokens' (List.rev_append tokens acc) in

===================================== src/sexp.ml ===================================== @@ -113,11 +113,11 @@ let rec sexp_string ?(print_locations = false) sexp = (if print_locations then let open Source.Location in - let {file; start; end'} = sexp_location sexp + let {container; start; end'} = sexp_location sexp in Printf.sprintf "#;("%s" %d %d %d %d %d %d) " - file + (Source.Container.name container) start.offset start.line start.column end'.offset end'.line end'.column else "")

===================================== src/source.ml ===================================== @@ -23,6 +23,9 @@ let first_line_of_file : int = 1

let first_column_of_line : int = 0

+let is_utf8_head (c : char) : bool = + Char.code c < 128 || Char.code c >= 192 + (** A point is a position within a source file. *) module Point = struct type t = {offset : int; line : int; column : int} @@ -60,39 +63,103 @@ module Point = struct l.offset <= r.offset end

+(** A container is a thing that can hold Typer source code. *) +module Container = struct + type lines = string Array.t + + type t = + | File of string * lines (** A file can contain source code. *) + | String of string * lines (** A string entred in a REPL can contain source + code. *) + + let dummy : t = String ("<dummy>", [|""|]) + + let of_string ~(label : string) (contents : string) : t = + let lines = contents |> String.split_on_char '\n' |> Array.of_list in + String (label, lines) + + (** The name of a container is either a path or a label in the case of a + string entred in the REPL. *) + let name : t -> string = function + | File (path, _) -> path + | String (label, _) -> label + + (** The lines of source code inside the container. There is always at least + one empty line. *) + let lines : t -> string array = function + | File (_, lines) -> lines + | String (_, lines) -> lines + + (** Indexes into the lines of the text within the container. Raises + `Invalid_argument` if the index is out of bounds. *) + let nth_line (container : t) (index : int) : string = + (lines container).(index - first_line_of_file) + + (** Gets the byte at the given line and offset. Note that this is *not* the + index of the line, but its line number, which starts at 1. *) + let get (container : t) (line : int) (offset : int) : char = + let text = nth_line container line in + if String.length text = offset + then '\n' + else text.[offset] + + (** Returns the point *on* the last line, *after* the last column. *) + let end_point (self : t) : Point.t = + let lines = lines self in + let last_line = lines.(Array.length lines - 1) in + let column = + String.fold_left + (fun n c -> n + if is_utf8_head c then 1 else 0) + 0 last_line + + first_column_of_line + in + {line = Array.length lines - 1 + first_line_of_file; + column; + offset = String.length last_line} + + let equal (l : t) (r : t) : bool = + l = r +end + (** A location is an open interval of characters within a source file. *) module Location = struct - type t = {file : string; start : Point.t; end' : Point.t} + type t = {container : Container.t; start : Point.t; end' : Point.t}

(** Creates a zero-width location around the given point. *) - let of_point (file : string) (point : Point.t) : t = - {file; start = point; end' = point} + let of_point (container : Container.t) (point : Point.t) : t = + {container; start = point; end' = point}

(** An empty location at the beginning of an empty file. *) - let dummy = of_point "" Point.zero + let dummy = of_point Container.dummy Point.zero

- let to_string (l : t) : string = - if l.start.offset = l.end'.offset - then Printf.sprintf "%s:%d:%d" l.file l.start.line l.start.column + let pp_print (f : Format.formatter) ({container; start; end'} : t) : unit = + let name = Container.name container in + if Point.equal start end' + then Format.fprintf f "%s:%d:%d" name start.line start.column else - Printf.sprintf - "%s:%d:%d-%d:%d" - l.file l.start.line l.start.column l.end'.line l.end'.column + Format.fprintf + f "%s:%d:%d-%d:%d" name start.line start.column end'.line end'.column + + let print : t -> unit = + Format.printf "%a" pp_print + + let to_string : t -> string = + Format.asprintf "%a" pp_print

let equal (l : t) (r : t) = - String.equal l.file r.file + Container.equal l.container r.container && Point.equal l.start r.start && Point.equal l.end' r.end'

let same (l : t) (r : t) = - String.equal l.file r.file + Container.equal l.container r.container && Point.same l.start r.start && Point.same l.end' r.end'

(** Locations form a partial order where one is smaller than another iff it is entirely contained in the latter. *) let (<=) (l : t) (r : t) : bool = - if l.file <> r.file + if not (Container.equal l.container r.container) then false else Point.(<=) r.start l.start && Point.(<=) l.end' r.end'

@@ -100,7 +167,7 @@ module Location = struct that covers both. If the locations do not belong to the same file, simply returns the first one. *) let extend (l : t) (r : t) : t = - if l.file <> r.file + if not (Container.equal l.container r.container) then l else if l == dummy then r @@ -109,128 +176,106 @@ module Location = struct else let start = Point.min l.start r.start in let end' = Point.max l.end' r.end' in - {file = l.file; start; end'} + {container = l.container; start; end'} end

(** A source object is text paired with a cursor. The text can be lazily loaded as it is accessed byte by byte, but it must be retained for future reference by error messages. *) -class virtual t (base_line : int) (base_column : int) (file : string) = -object (self) - val mutable line = base_line - val mutable column = base_column - - (* A path if the text comes from a file, otherwise a meaningful identifier. *) - method file : string = file - - (* Return the byte at the cursor, or None if the cursor is at the end of - the text. *) - method virtual peek : char option - - (* The current point of the cursor. *) - method point : Point.t = - {offset = self#offset; line; column} - - (* The current offset of the cursor in the file, in bytes. *) - method virtual private offset : int - - (* Makes a location starting at the given point and ending at the current - cursor position. *) - method make_location (start : Point.t) : Location.t = - {file; start; end' = self#point} - - (* Slices the text, from (and including) a starting point and to (and - excluding) the curent cursor offset. - - Note that the source is required only to buffer the last line read and may - raise an Invalid_argument if the slice extends before the start of the - line. *) - method slice (point : Point.t) : string * Location.t = - (self#slice_impl point.offset, self#make_location point) - - method virtual private slice_impl : int -> string - - (* Moves the cursor forward one byte *) - method advance : unit = - let is_utf8_head c = Char.code c < 128 || Char.code c >= 192 in - let c = self#peek in - self#advance_impl; - match c with - | Some '\n' - -> line <- line + 1; - column <- 0; - | Some c when is_utf8_head c - -> column <- column + 1 - | _ -> () - - method private virtual advance_impl : unit - - (* Returns the char at the cursor, then advances it forward. *) - method next : char option = - let c = self#peek in - self#advance; - c -end - -let read_buffer_length = 4096 - -class source_file file_name = object (self) - inherit t (first_line_of_file - 1) first_column_of_line file_name - - val in_channel = open_in file_name - val mutable end_of_line = false - val mutable source_line = "" - val mutable line_offset = 0 - val mutable offset = 0 - - method private peek_unchecked = - if offset < String.length source_line - then source_line.[offset] - else '\n' - - method peek = - if offset <= String.length source_line - then Some self#peek_unchecked - else - try - line_offset <- line_offset + 1 + String.length source_line; - source_line <- input_line in_channel; - offset <- 0; - Some self#peek_unchecked - with - | End_of_file -> None - - method private advance_impl = - offset <- offset + 1 - - method private offset = line_offset + offset - - method private slice_impl start_offset = - let relative_start_offset = start_offset - line_offset in - String.sub source_line relative_start_offset (offset - relative_start_offset) -end - -class source_string - ?(file : string = "<string>") - ?(line : int = first_line_of_file) - ?(column : int = first_column_of_line) - source - = -object - inherit t line column file - - val mutable offset = 0 - - method peek = - if offset < String.length source - then Some (source.[offset]) - else None - - method private advance_impl = - offset <- offset + 1 - - method private offset = offset - - method private slice_impl start_offset = - String.sub source start_offset (offset - start_offset) -end +class t (container : Container.t) (base_point : Point.t) (end_point : Point.t) = + let line = base_point.line in + let column = base_point.column in + let offset = base_point.offset in + let end_line = end_point.line in + let end_offset = end_point.offset in + let read_cursor line offset = + if line >= end_line && offset >= end_offset + then None + else Some (Container.get container line offset) + in + object (self) + val mutable cursor = read_cursor line offset + val mutable line = line + val mutable column = column + val mutable offset = offset + + method container : Container.t = container + + (** Returns the byte at the cursor, or None if the cursor is at the end of + the text. *) + method peek : char option = + cursor + + (** The current point of the cursor. *) + method point : Point.t = + {line; column; offset} + + (** Makes a location starting at the given point and ending at the current + cursor position. *) + method make_location (start : Point.t) : Location.t = + { + container; + start; + end' = {offset; line; column}; + } + + (** Slices the text, from (and including) a starting point and to (and + excluding) the curent cursor offset. The range must be inside a single + line. *) + method slice (point : Point.t) : string * Location.t = + assert (point.line = line); + let text = Container.nth_line container line in + String.sub text point.offset (offset - point.offset), + self#make_location point + + (** Moves the cursor forward one byte. *) + method advance : unit = + match cursor with + | None -> () + | Some c + -> if c = '\n' + then begin + line <- line + 1; + column <- first_column_of_line; + offset <- 0; + end + else if is_utf8_head c + then begin + column <- column + 1; + offset <- offset + 1 + end + else + offset <- offset + 1; + cursor <- read_cursor line offset + + (** Returns the char at the cursor, then advances it forward. *) + method next : char option = + let c = self#peek in + self#advance; + c + end + +(** Creates a source object from the contents of the file at the given path. + The file is eagerly read to the end. `Sys_error` is raised if the file + cannot be openned or read. *) +let of_path (path : string) = + let channel = open_in path in + let unfold_lines () = + try Some (input_line channel, ()) with + | End_of_file -> None + in + let lines = Array.of_seq (Seq.unfold unfold_lines ()) in + close_in channel; + + let lines = if Array.length lines = 0 then [|""|] else lines in + let container = Container.File (path, lines) in + new t container Point.zero (Container.end_point container) + +let of_string ?(label : string = "<unknown>") (contents : string) = + let container = Container.of_string ~label contents in + new t container Point.zero (Container.end_point container) + +(** Creates a source object from a location. In practice, this means that the + new source will be a substring of the original source of the location. *) +let of_location (location : Location.t) : #t = + new t location.container location.start location.end'

===================================== src/string.ml ===================================== @@ -22,3 +22,12 @@ include Stdlib.String

(* Backport from 5.0. *) let hash : t -> int = Hashtbl.hash + +(* Backport from 4.13. *) +let fold_left (type a) (f : a -> char -> a) (a : a) (chars : string) : a = + let rec loop n a = + if n < length chars + then loop (n + 1) (f a (get chars n)) + else a + in + loop 0 a

===================================== tests/lexer_test.ml ===================================== @@ -46,42 +46,50 @@ let test_lex name pretokens expected = in add_test "LEXER" name lex

-let l os ls cs oe le ce : Source.Location.t = +let l c os ls cs oe le ce : Source.Location.t = { - file = "test.typer"; + container = c; start = {offset = os; line = ls; column = cs}; end' = {offset = oe; line = le; column = ce}; }

let () = + let source = "a.b" in + let l = l (Source.Container.of_string ~label:"test" source) in test_lex "Inner operator inside a presymbol" - [Pretoken (l 0 1 0 3 1 3, "a.b")] + [Pretoken (l 0 1 0 3 1 3, source)] [Node (l 0 1 0 3 1 3, Symbol (l 1 1 1 2 1 2, "__.__"), [Symbol (l 0 1 0 1 1 1, "a"); Symbol (l 2 1 2 3 1 3, "b")])]

let () = + let source = ".b" in + let l = l (Source.Container.of_string ~label:"test" source) in test_lex "Inner operators at the beginning of a presymbol" - [Pretoken (l 0 1 0 2 1 2, ".b")] + [Pretoken (l 0 1 0 2 1 2, source)] [Node (l 0 1 0 2 1 2, Symbol (l 0 1 0 1 1 1, "__.__"), [epsilon (l 0 1 0 0 1 0); Symbol (l 1 1 1 2 1 2, "b")])]

let () = + let source = "a." in + let l = l (Source.Container.of_string ~label:"test" source) in test_lex "Inner operators at the end of a presymbol" - [Pretoken (l 0 1 0 2 1 2, "a.")] + [Pretoken (l 0 1 0 2 1 2, source)] [Node (l 0 1 0 2 1 2, Symbol (l 1 1 1 2 1 2, "__.__"), [Symbol (l 0 1 0 1 1 1, "a"); epsilon (l 2 1 2 2 1 2)])]

let () = + let source = "." in + let l = l (Source.Container.of_string ~label:"test" source) in test_lex "An inner operator by itself is a simple symbol" - [Pretoken (l 0 1 0 1 1 1, ".")] + [Pretoken (l 0 1 0 1 1 1, source)] [Symbol (l 0 1 0 1 1 1, ".")]

let () = run_all ()

===================================== tests/sexp_test.ml ===================================== @@ -34,7 +34,7 @@ open Lexer open Utest_lib

let sexp_parse_str dcode = - let source = new Source.source_string dcode in + let source = Source.of_string dcode in sexp_parse_source source Grammar.default_stt Grammar.default_grammar (Some ";")

let test_sexp_add dcode testfun =

View it on GitLab: https://gitlab.com/monnier/typer/-/compare/4421b8e7aaad4ebf4e2eb753d5bb48d3c...