From 7efd7c0af92dcba3b6ce66c388250c0800fd68b0 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Thu, 3 Jul 2025 16:44:24 +0200 Subject: [PATCH 01/58] New command "deindex PATH" It deindex all constants whose path is a suffix of PATH. Question: what are useful CLI args for deindex? E.g. - a list of filenames - a .pkg file (or the fact that it must use the .pkg file) - a user-provided PATH like it is now? Moreover notice that there is currently no check that PATH is a well-formed PATH and A.B matches A.BC as a prefix. --- src/cli/lambdapi.ml | 22 +++++++++++++++++- src/tool/indexing.ml | 54 +++++++++++++++++++++++++++++++++++++------ src/tool/indexing.mli | 1 + 3 files changed, 69 insertions(+), 8 deletions(-) diff --git a/src/cli/lambdapi.ml b/src/cli/lambdapi.ml index af1c5cf48..8fb85bc9b 100644 --- a/src/cli/lambdapi.ml +++ b/src/cli/lambdapi.ml @@ -112,6 +112,14 @@ let index_cmd cfg add_only rules files dbpath_opt = Tool.Indexing.dump ~dbpath () in Error.handle_exceptions run +let deindex_cmd cfg path dbpath_opt = + Config.init cfg; + let run () = + Tool.Indexing.deindex_path path ; + let dbpath = Option.get Path.default_dbpath dbpath_opt in + Tool.Indexing.dump ~dbpath () in + Error.handle_exceptions run + end (** Running the main type-checking mode. *) @@ -488,6 +496,11 @@ let path_in_url : string option CLT.t = "The path in the URL accepted by the server." in Arg.(value & opt (some string) None & info ["url"] ~docv:"String" ~doc) +let path_prefix : string CLT.t = + let doc = + "The prefix path of the constants to de-index." in + Arg.(required & pos 0 (some string) None & info [] ~docv:"PATH" ~doc) + let header_file_arg : string option CLT.t = let doc = "html file holding the header of the web page of the server." in @@ -500,6 +513,13 @@ let index_cmd = Cmdliner.Term.(const LPSearchMain.index_cmd $ Config.full $ add_only_arg $ rules_arg $ files $ custom_dbpath) +let deindex_cmd = + let doc = + "De-index all constants whose path is a suffix of the given path." in + Cmd.v (Cmd.info "deindex" ~doc ~man:man_pkg_file) + Cmdliner.Term.(const LPSearchMain.deindex_cmd $ Config.full + $ path_prefix $ custom_dbpath) + let search_cmd = let doc = "Run a search query against the index." in Cmd.v (Cmd.info "search" ~doc ~man:man_pkg_file) @@ -522,7 +542,7 @@ let _ = [ check_cmd ; parse_cmd ; export_cmd ; lsp_server_cmd ; decision_tree_cmd ; help_cmd ; version_cmd ; Init.cmd ; Install.install_cmd ; Install.uninstall_cmd - ; index_cmd ; search_cmd ; websearch_cmd ] + ; index_cmd ; deindex_cmd ; search_cmd ; websearch_cmd ] in let doc = "A type-checker for the lambdapi-calculus modulo rewriting." in let sdocs = Manpage.s_common_options in diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 57bcc4e2d..bac773853 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -3,6 +3,10 @@ open Common open Pos type sym_name = Common.Path.t * string +let is_path_prefix patt p = + let string_of_path x = Format.asprintf "%a" Common.Path.pp x in + Lplib.String.is_prefix patt (string_of_path p) + let name_of_sym s = (s.sym_path, s.sym_name) (* discrimination tree *) @@ -145,6 +149,38 @@ let insert_name (namemap,index) name v = | Some l -> l in Lplib.Extra.StrMap.add name (v::vs) namemap, index +let rec remove_index ~what = + function + | Leaf l -> + let l' = List.filter what l in + (match l' with + | [] -> Choice [] + | _::_ -> Leaf l') + | Choice l -> + Choice (List.filter_map (remove_node ~what) l) + +and remove_node ~what = + function + | IHOLE i -> + (match remove_index ~what i with + | Choice [] -> None + | i' -> Some (IHOLE i')) + | IRigid (r,i) -> + (match remove_index ~what i with + | Choice [] -> None + | i' -> Some (IRigid (r,i'))) + +let remove_from_name_index ~what i = + Lplib.Extra.StrMap.filter_map + (fun _ l -> + let f x = if what x then Some x else None in + match List.filter_map f l with + | [] -> None + | l' -> Some l') i + +let remove ~what (dbname, index) = + remove_from_name_index ~what dbname, remove_index ~what index + let rec search_index ~generalize index stack = match index,stack with | Leaf vs, [] -> vs @@ -330,6 +366,10 @@ module DB = struct let db' = Index.insert_name (Lazy.force !db) k v in db := lazy db' + let remove ~what = + let db' = Index.remove ~what (Lazy.force !db) in + db := lazy db' + let set_of_list ~generalize k l = ItemSet.of_list (List.map @@ -569,6 +609,10 @@ let index_sign sign = rules) rules +let deindex_path path = + DB.remove + ~what:(fun (((sym_path,_),_),_) -> not (is_path_prefix path sym_path)) + (* let's flatten the interface *) include DB @@ -626,12 +670,8 @@ module QueryLanguage = struct (fun _ positions1 positions2 -> Some (positions1 @ positions2)) let filter set f = - let f ((p',_),_) _ = - match f with - | Path p -> - let string_of_path x = Format.asprintf "%a" Common.Path.pp x in - Lplib.String.is_prefix p (string_of_path p') in - ItemSet.filter f set + let g ((p',_),_) _ = let Path p = f in is_path_prefix p p' in + ItemSet.filter g set let answer_query ~mok ss env = let rec aux = @@ -707,4 +747,4 @@ let _ = assert (transform_ascii_to_unicode " forall x, y" = " Π x, y"); assert (transform_ascii_to_unicode "forall x, y" = "Π x, y"); assert (transform_ascii_to_unicode "forall.x, y" = "Π.x, y"); - assert (transform_ascii_to_unicode "((forall x, y" = "((Π x, y") \ No newline at end of file + assert (transform_ascii_to_unicode "((forall x, y" = "((Π x, y") diff --git a/src/tool/indexing.mli b/src/tool/indexing.mli index 63ee8febb..c0068156a 100644 --- a/src/tool/indexing.mli +++ b/src/tool/indexing.mli @@ -4,6 +4,7 @@ open Core val empty : unit -> unit val load_rewriting_rules: string list -> unit val index_sign : Sign.t -> unit +val deindex_path : string -> unit val dump : dbpath:string -> unit -> unit (* search command used by cli *) From a4c58fff91e49eb6a3483516919c99d22199f8b4 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Fri, 4 Jul 2025 11:23:56 +0200 Subject: [PATCH 02/58] Added new filter Q | "regexp" --- src/parsing/lpParser.mly | 3 +++ src/parsing/searchQuerySyntax.ml | 1 + src/tool/indexing.ml | 14 +++++++++++--- 3 files changed, 15 insertions(+), 3 deletions(-) diff --git a/src/parsing/lpParser.mly b/src/parsing/lpParser.mly index 4f229ce23..1b6dddd11 100644 --- a/src/parsing/lpParser.mly +++ b/src/parsing/lpParser.mly @@ -502,5 +502,8 @@ search_query: else Format.asprintf "%a.%a" Core.Print.path p Core.Print.uid n in SearchQuerySyntax.QFilter (q,Path path) } + | q=search_query VBAR s=STRINGLIT + { let re = Str.regexp s in + SearchQuerySyntax.QFilter (q,RegExp re) } %% diff --git a/src/parsing/searchQuerySyntax.ml b/src/parsing/searchQuerySyntax.ml index ab32e66ba..078545ba0 100644 --- a/src/parsing/searchQuerySyntax.ml +++ b/src/parsing/searchQuerySyntax.ml @@ -16,6 +16,7 @@ type op = | Union type filter = | Path of string + | RegExp of Str.regexp type query = | QBase of base_query | QOpp of query * op * query diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index bac773853..ec4da202c 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -3,9 +3,14 @@ open Common open Pos type sym_name = Common.Path.t * string +let string_of_path x = Format.asprintf "%a" Common.Path.pp x + let is_path_prefix patt p = - let string_of_path x = Format.asprintf "%a" Common.Path.pp x in - Lplib.String.is_prefix patt (string_of_path p) + Lplib.String.is_prefix patt (string_of_path p) + +let re_matches_sym_name re (p,name) = + (* CSC: fix me *) + Str.string_match re (string_of_path p ^ "." ^ name) 0 let name_of_sym s = (s.sym_path, s.sym_name) @@ -670,7 +675,10 @@ module QueryLanguage = struct (fun _ positions1 positions2 -> Some (positions1 @ positions2)) let filter set f = - let g ((p',_),_) _ = let Path p = f in is_path_prefix p p' in + let g ((p',_ as name),_) _ = + match f with + | Path p -> is_path_prefix p p' + | RegExp re -> re_matches_sym_name re name in ItemSet.filter g set let answer_query ~mok ss env = From b87fc34d220acdc1c433d49b3bc31213f6bfc281 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Sun, 6 Jul 2025 19:18:09 +0200 Subject: [PATCH 03/58] Use tail recursive functions in a few places Now the query 'concl >= _ | ".*vsum.*"' terminates on the medium-sized HOL light extraction --- src/tool/indexing.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index ec4da202c..30a86db55 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -14,6 +14,10 @@ let re_matches_sym_name re (p,name) = let name_of_sym s = (s.sym_path, s.sym_name) +(* Tail recursive implementation of List.append for + OCaml < 5.1 *) +let (@) l1 l2 = List.rev_append (List.rev l1) l2 + (* discrimination tree *) (* substitution trees would be best *) @@ -376,8 +380,9 @@ module DB = struct db := lazy db' let set_of_list ~generalize k l = + (* rev_map is used because it is tail recursive *) ItemSet.of_list - (List.map + (List.rev_map (fun (i,pos) -> i, List.map (fun x -> generalize,k,x) pos) l) From 52ec33c0d5456164f3994e5bfbb93ea9a17cda1b Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Sun, 6 Jul 2025 19:18:18 +0200 Subject: [PATCH 04/58] More issues --- TODO.md | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/TODO.md b/TODO.md index a1364e94e..53a0e70da 100644 --- a/TODO.md +++ b/TODO.md @@ -4,6 +4,22 @@ TODO Index and search ---------------- +* After "Number of results: 3" there is a missing CRLF + +* why type only supports? = + also doc is wrong, but I suppose code is wrong + +* concl = _ + justifications include the following that are not expected + $0.[V#] occurs inside the spine of the type and + $0.[V#] occurs inside the hypothesis of the type and + $0.[V#] occurs as the exact hypothesis of the type and + $0.[V#] occurs as the exact conclusion of the type and + $0.[V#] occurs inside the conclusion of the type and + +* CLI interface: it tries to render way too many results + and it takes ages + * Too many results found? anywhere >= (Π x: _, (= _ V# V#)) From 40f3efbc33611f67f3566049096ca6094e01c220 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Sun, 6 Jul 2025 20:54:57 +0200 Subject: [PATCH 05/58] Bug fixed: too many justifications returned a query like 'concl = _' was returning justifications of the form _ found in hypothesis Now only really relevant justifications are returned Signed-off-by: Claudio Sacerdoti Coen --- TODO.md | 18 ++++++++++-------- src/tool/indexing.ml | 25 +++++++++++++------------ 2 files changed, 23 insertions(+), 20 deletions(-) diff --git a/TODO.md b/TODO.md index 53a0e70da..d0fa28c97 100644 --- a/TODO.md +++ b/TODO.md @@ -9,14 +9,6 @@ Index and search * why type only supports? = also doc is wrong, but I suppose code is wrong -* concl = _ - justifications include the following that are not expected - $0.[V#] occurs inside the spine of the type and - $0.[V#] occurs inside the hypothesis of the type and - $0.[V#] occurs as the exact hypothesis of the type and - $0.[V#] occurs as the exact conclusion of the type and - $0.[V#] occurs inside the conclusion of the type and - * CLI interface: it tries to render way too many results and it takes ages @@ -36,3 +28,13 @@ anywhere >= (Π x: _, (= _ x x)) * alignments with same name ==> automatic preference? * better pagination + +Performance improvements +------------------------ + +* see if compressing the index yields a significant gain + +* currently in a query like 'concl = _' it builds an extremely large matching set + and THEN it filters out the justifications that have Concl Exact; maybe we + could save a lot of time anticipating the filtrage + diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 30a86db55..3a525e0a2 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -646,17 +646,18 @@ module QueryLanguage = struct | _, _ -> false let filter_constr constr _ positions = - match constr with - | QType wherep -> - List.exists - (function - | _,_,Type where -> match_where wherep where - | _ -> false) positions - | QXhs (insp,sidep) -> - List.exists - (function - | _,_,Xhs (ins,side) -> match_opt insp ins && match_opt sidep side - | _ -> false) positions + Option.map (fun x -> [x]) + (match constr with + | QType wherep -> + List.find_opt + (function + | _,_,Type where -> match_where wherep where + | _ -> false) positions + | QXhs (insp,sidep) -> + List.find_opt + (function + | _,_,Xhs (ins,side) -> match_opt insp ins && match_opt sidep side + | _ -> false) positions) let answer_base_query ~mok ss env = function @@ -665,7 +666,7 @@ module QueryLanguage = struct let res = search_pterm ~generalize ~mok ss env patt in (match constr with | None -> res - | Some constr -> ItemSet.filter (filter_constr constr) res) + | Some constr -> ItemSet.filter_map (filter_constr constr) res) let perform_op = function From 02489efe14a4963d0b6d67cd65707ec2efdc3392 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Mon, 7 Jul 2025 00:00:12 +0200 Subject: [PATCH 06/58] Issue understood --- TODO.md | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/TODO.md b/TODO.md index d0fa28c97..c1dcf73c9 100644 --- a/TODO.md +++ b/TODO.md @@ -12,11 +12,6 @@ Index and search * CLI interface: it tries to render way too many results and it takes ages -* Too many results found? - -anywhere >= (Π x: _, (= _ V# V#)) -anywhere >= (Π x: _, (= _ x x)) - * html tags in textual output :-( * would it be more reasonable to save the normalization rules @@ -38,3 +33,16 @@ Performance improvements and THEN it filters out the justifications that have Concl Exact; maybe we could save a lot of time anticipating the filtrage +Misleading output +----------------- + ++ Too many results found? + +anywhere >= (Π x: _, (= _ V# V#)) +anywhere >= (Π x: _, (= _ x x)) + +NO, it's ok, but the output is misleading. The second form is equivalent +to the first that is equivalent to (_ -> (= _ V# V#)) that is what it is +found. However it shows the pattern saying that " (Π x: _, (= _ x x))" was +found, that is the misleading thing. + From a01c625f1e159b1865599b1b7fff6d4a1e58d1e2 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Mon, 7 Jul 2025 17:09:00 +0200 Subject: [PATCH 07/58] Showing mapping to Coq files in search results 1. during indexing using --source=PATH one can add indexing information mapping LP identifiers to Coq identifiers and locations 2. when the search results are shown, the Coq code is also printed if the LP identifier is found in the map in point 1 The code to generate the file used in 1 should belong to HOL2DK. Right now we have hacked some best-effort shell script that we will commit in the HOL2DK_indexing repository --- TODO.md | 10 +++ src/cli/lambdapi.ml | 10 ++- src/common/pos.ml | 40 ++++++--- src/tool/indexing.ml | 191 ++++++++++++++++++++++++++++-------------- src/tool/indexing.mli | 1 + 5 files changed, 174 insertions(+), 78 deletions(-) diff --git a/TODO.md b/TODO.md index c1dcf73c9..80c9b5236 100644 --- a/TODO.md +++ b/TODO.md @@ -4,6 +4,16 @@ TODO Index and search ---------------- +* generate mappings from LP to V automatically with HOL2DK and find + what to do with manually written files; also right now there are + mappings that are lost and mappings that are confused in a many-to-one + relation + +* document new features, e.g. -sources (and find better + terminology), deindex + +* remove should remove also from source index + * After "Number of results: 3" there is a missing CRLF * why type only supports? = diff --git a/src/cli/lambdapi.ml b/src/cli/lambdapi.ml index 8fb85bc9b..fd8141983 100644 --- a/src/cli/lambdapi.ml +++ b/src/cli/lambdapi.ml @@ -95,7 +95,7 @@ let websearch_cmd cfg rules port require header_file dbpath_opt path_in_url = Tool.Websearch.start ~header ss ~port ~dbpath ~path_in_url () in Error.handle_exceptions run -let index_cmd cfg add_only rules files dbpath_opt = +let index_cmd cfg add_only rules files source dbpath_opt = Config.init cfg; let run () = if not add_only then Tool.Indexing.empty (); @@ -108,6 +108,7 @@ let index_cmd cfg add_only rules files dbpath_opt = Tool.Indexing.load_rewriting_rules rules; Tool.Indexing.index_sign (no_wrn Compile.compile_file file) in List.iter handle files; + Option.iter Tool.Indexing.parse_source_map source; let dbpath = Option.get Path.default_dbpath dbpath_opt in Tool.Indexing.dump ~dbpath () in Error.handle_exceptions run @@ -491,6 +492,11 @@ let custom_dbpath : string option CLT.t = "Path to the search DB file." in Arg.(value & opt (some string) None & info ["db"] ~docv:"PATH" ~doc) +let source_file : string option CLT.t = + let doc = + "Path to the mapping to additional sources." in + Arg.(value & opt (some string) None & info ["sources"] ~docv:"PATH" ~doc) + let path_in_url : string option CLT.t = let doc = "The path in the URL accepted by the server." in @@ -511,7 +517,7 @@ let index_cmd = let doc = "Index the given files." in Cmd.v (Cmd.info "index" ~doc ~man:man_pkg_file) Cmdliner.Term.(const LPSearchMain.index_cmd $ Config.full - $ add_only_arg $ rules_arg $ files $ custom_dbpath) + $ add_only_arg $ rules_arg $ files $ source_file $ custom_dbpath) let deindex_cmd = let doc = diff --git a/src/common/pos.ml b/src/common/pos.ml index 788dba866..00dc0f989 100644 --- a/src/common/pos.ml +++ b/src/common/pos.ml @@ -144,11 +144,14 @@ let make_pos : Lexing.position * Lexing.position -> 'a -> 'a loc = file at position [pos]. [sep] is the separator replacing each newline (e.g. "
\n"). [delimiters] is a pair of delimiters used to wrap the "unknown location" message returned when the position does not refer to a - file. [escape] is used to escape the file contents.*) + file. [escape] is used to escape the file contents. + + The value -1 for end_col is to be interpreted as "at the end of line". *) let print_file_contents : escape:(string -> string) -> - delimiters:(string*string) -> popt Lplib.Base.pp = - fun ~escape ~delimiters:(db,de) ppf pos -> + delimiters:(string*string) -> complain_if_location_unknown:bool -> + popt Lplib.Base.pp = + fun ~escape ~delimiters:(db,de) ~complain_if_location_unknown ppf pos -> match pos with | Some { fname=Some fname; start_line; start_col; end_line; end_col } -> (* WARNING: do not try to understand the following code! @@ -156,7 +159,10 @@ let print_file_contents : (* ignore the lines before the start_line *) let ch = open_in fname in - let out = Buffer.create ((end_line - start_line) * 80 + end_col + 1) in + let out = + Buffer.create + ((end_line - start_line) * 80 + + (if end_col = -1 then 80 else end_col) + 1) in for i = 0 to start_line - 2 do ignore (input_line ch) done ; @@ -189,20 +195,32 @@ let print_file_contents : (* identify what the end_line is and how many UTF8 codepoints to keep *) let endl,end_col = if start_line = end_line then - startstr, end_col - start_col + if end_col = -1 then + startstr, -1 + else + startstr, end_col - start_col else input_line ch, end_col in (* keep the first end_col UTF8 codepoints of the end_line *) assert (String.is_valid_utf_8 endl); let bytepos = ref 0 in - for i = 0 to end_col - 1 do - let uchar = String.get_utf_8_uchar endl !bytepos in - assert (Uchar.utf_decode_is_valid uchar) ; - bytepos := !bytepos + Uchar.utf_decode_length uchar - done ; + let i = ref 0 in + (try + while !i <= end_col -1 || end_col = -1 do + let uchar = String.get_utf_8_uchar endl !bytepos in + assert (Uchar.utf_decode_is_valid uchar) ; + bytepos := !bytepos + Uchar.utf_decode_length uchar ; + incr i + done + with + Invalid_argument _ -> () (* End of line reached *)) ; let str = String.sub endl 0 !bytepos in Buffer.add_string out (escape str) ; close_in ch ; string ppf (Buffer.contents out) - | None | Some {fname=None} -> string ppf (db ^ "unknown location" ^ de) + | None | Some {fname=None} -> + if complain_if_location_unknown then + string ppf (db ^ "unknown location" ^ de) + else + string ppf "" diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 3a525e0a2..f078b9193 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -18,6 +18,17 @@ let name_of_sym s = (s.sym_path, s.sym_name) OCaml < 5.1 *) let (@) l1 l2 = List.rev_append (List.rev l1) l2 +let dump_to ~filename i = + let ch = open_out_bin filename in + Marshal.to_channel ch i [] ; + close_out ch + +let restore_from ~filename = + let ch = open_in_bin filename in + let i = Marshal.from_channel ch in + close_in ch ; + i + (* discrimination tree *) (* substitution trees would be best *) @@ -219,17 +230,6 @@ let search ~generalize (_,index) term = let locate_name (namemap,_) name = match Lplib.Extra.StrMap.find_opt name namemap with None -> [] | Some l -> l -let dump_to ~filename i = - let ch = open_out_bin filename in - Marshal.to_channel ch i [] ; - close_out ch - -let restore_from ~filename = - let ch = open_in_bin filename in - let i = Marshal.from_channel ch in - close_in ch ; - i - end module DB = struct @@ -283,8 +283,99 @@ module DB = struct m) empty l end + module Sym_nameMap = + Map.Make(struct type t = sym_name let compare = compare end) + type answer = ((*generalized:*)bool * term * position) list + (* disk persistence *) + + let the_dbpath : string ref = ref Path.default_dbpath + + let rwpaths = ref [] + + let restore_from_disk () = + try restore_from ~filename:!the_dbpath + with Sys_error msg -> + Common.Error.wrn None "%s.\n\ + Type \"lambdapi index --help\" to learn how to create the index." msg ; + Sym_nameMap.empty, Index.empty + + (* The persistent database *) + let db : + ((string * string * int * int) Sym_nameMap.t * + (item * position list) Index.db) Lazy.t ref = + ref (lazy (restore_from_disk ())) + + let empty () = db := lazy (Sym_nameMap.empty,Index.empty) + + let insert k v = + let sidx,idx = Lazy.force !db in + let db' = sidx, Index.insert idx k v in + db := lazy db' + + let insert_name k v = + let sidx,idx = Lazy.force !db in + let db' = sidx, Index.insert_name idx k v in + db := lazy db' + + let remove ~what = + let sidx,idx = Lazy.force !db in + let db' = sidx,Index.remove ~what idx in + db := lazy db' + + let set_of_list ~generalize k l = + (* rev_map is used because it is tail recursive *) + ItemSet.of_list + (List.rev_map + (fun (i,pos) -> + i, List.map (fun x -> generalize,k,x) pos) l) + + let search ~generalize k = + set_of_list ~generalize k + (Index.search ~generalize (snd (Lazy.force !db)) k) + + let dump ~dbpath () = + dump_to ~filename:dbpath (Lazy.force !db) + + let locate_name name = + let k = Term.mk_Wild (* dummy, unused *) in + set_of_list ~generalize:false k + (Index.locate_name (snd (Lazy.force !db)) name) + + let parse_source_map filename = + let sidx,idx = Lazy.force !db in + let sidx = ref sidx in + let ch = open_in filename in + (try + while true do + let line = input_line ch in + match String.split_on_char ' ' line with + | [fname; start_line; end_line; sourceid; lpid] -> + let rec sym_name_of = + function + | [] -> assert false + | [name] -> [],name + | hd::tl -> let path,name = sym_name_of tl in hd::path,name in + let lpid = sym_name_of (String.split_on_char '.' lpid) in + let start_line = int_of_string start_line in + let end_line = int_of_string end_line in + sidx := + Sym_nameMap.add lpid (sourceid,fname,start_line,end_line) !sidx + | _ -> + raise + (Common.Error.Fatal(None,"wrong file format for source map file")) + done ; + with + | Failure _ as exn -> + close_in ch; + raise + (Common.Error.Fatal(None,"wrong file format for source map file: " ^ + Printexc.to_string exn)) + | End_of_file -> close_in ch) ; + db := lazy (!sidx,idx) + + type ho_pp = { run : 'a. 'a Lplib.Base.pp -> 'a Lplib.Base.pp } let identity_escaper : ho_pp = @@ -296,6 +387,15 @@ module DB = struct Format.pp_print_string fmt res } + let source_infos_of_sym_name sym_name = + match Sym_nameMap.find_opt sym_name (fst (Lazy.force !db)) with + | None -> None, None + | Some (sourceid, fname, start_line, end_line) -> + let start_col = 0 in + let end_col = -1 in (* to the end of line *) + Some sourceid, + Some { fname=Some fname; start_line; start_col; end_line; end_col } + let generic_pp_of_position_list ~escaper ~sep = Lplib.List.pp (fun ppf position -> @@ -323,14 +423,25 @@ module DB = struct Lplib.Base.out fmt "Nothing found" else Lplib.List.pp - (fun ppf (((p,n),pos),(positions : answer)) -> - Lplib.Base.out ppf "%s%a.%s%s%s@%s%s%a%s%s%s%a%s%s%s@." + (fun ppf (((p,n) as sym_name,pos),(positions : answer)) -> + let sourceid,sourcepos = source_infos_of_sym_name sym_name in + Lplib.Base.out ppf "%s%a.%s%s%s@%s%s%a%s%s%s%a%s%a%s%a%s%s%s@." lisb (escaper.run Core.Print.path) p boldb n bolde (popt_to_string ~print_dirname:false pos) separator (generic_pp_of_position_list ~escaper ~sep) positions separator preb codeb - (Common.Pos.print_file_contents ~escape ~delimiters) - pos codee pree lise) + (Common.Pos.print_file_contents ~escape ~delimiters + ~complain_if_location_unknown:true) pos + separator + (fun ppf opt -> + match opt with + | None -> Lplib.Base.string ppf "" + | Some sourceid -> + Lplib.Base.string ppf ("Translated to " ^ sourceid)) sourceid + separator + (Common.Pos.print_file_contents ~escape ~delimiters + ~complain_if_location_unknown:false) sourcepos + codee pree lise) "" fmt l let html_of_item_list = @@ -349,56 +460,6 @@ module DB = struct let html_of_results_list from fmt l = Lplib.Base.out fmt "
    %a
" from html_of_item_list l - (* disk persistence *) - - let the_dbpath : string ref = ref Path.default_dbpath - - let rwpaths = ref [] - - let restore_from_disk () = - try Index.restore_from ~filename:!the_dbpath - with Sys_error msg -> - Common.Error.wrn None "%s.\n\ - Type \"lambdapi index --help\" to learn how to create the index." msg ; - Index.empty - - let db : (item * position list) Index.db Lazy.t ref = - ref (lazy (restore_from_disk ())) - - let empty () = db := lazy Index.empty - - let insert k v = - let db' = Index.insert (Lazy.force !db) k v in - db := lazy db' - - let insert_name k v = - let db' = Index.insert_name (Lazy.force !db) k v in - db := lazy db' - - let remove ~what = - let db' = Index.remove ~what (Lazy.force !db) in - db := lazy db' - - let set_of_list ~generalize k l = - (* rev_map is used because it is tail recursive *) - ItemSet.of_list - (List.rev_map - (fun (i,pos) -> - i, List.map (fun x -> generalize,k,x) pos) l) - - let search ~generalize k = - set_of_list ~generalize k - (Index.search ~generalize (Lazy.force !db) k) - - let dump ~dbpath () = - the_dbpath := dbpath; - Index.dump_to ~filename:dbpath (Lazy.force !db) - - let locate_name name = - let k = Term.mk_Wild (* dummy, unused *) in - set_of_list ~generalize:false k - (Index.locate_name (Lazy.force !db) name) - end exception Overloaded of string * DB.answer DB.ItemSet.t diff --git a/src/tool/indexing.mli b/src/tool/indexing.mli index c0068156a..62b1937b4 100644 --- a/src/tool/indexing.mli +++ b/src/tool/indexing.mli @@ -4,6 +4,7 @@ open Core val empty : unit -> unit val load_rewriting_rules: string list -> unit val index_sign : Sign.t -> unit +val parse_source_map : string -> unit (* the name of the file *) val deindex_path : string -> unit val dump : dbpath:string -> unit -> unit From 0a4b1d6df4558fbe8ad500886acb37aaf8d4f808 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Mon, 7 Jul 2025 18:18:50 +0200 Subject: [PATCH 08/58] unindex also removes from source map --- TODO.md | 2 -- src/tool/indexing.ml | 15 +++++++++------ 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/TODO.md b/TODO.md index 80c9b5236..56dab35b9 100644 --- a/TODO.md +++ b/TODO.md @@ -12,8 +12,6 @@ Index and search * document new features, e.g. -sources (and find better terminology), deindex -* remove should remove also from source index - * After "Number of results: 3" there is a missing CRLF * why type only supports? = diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index f078b9193..e241fb5aa 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -319,10 +319,15 @@ module DB = struct let db' = sidx, Index.insert_name idx k v in db := lazy db' - let remove ~what = + let remove path = let sidx,idx = Lazy.force !db in - let db' = sidx,Index.remove ~what idx in - db := lazy db' + let keep sym_path = not (is_path_prefix path sym_path) in + let idx = + Index.remove + ~what:(fun (((sym_path,_),_),_) -> keep sym_path ) idx in + let sidx = + Sym_nameMap.filter (fun (sym_path,_) _ -> keep sym_path) sidx in + db := lazy (sidx,idx) let set_of_list ~generalize k l = (* rev_map is used because it is tail recursive *) @@ -680,9 +685,7 @@ let index_sign sign = rules) rules -let deindex_path path = - DB.remove - ~what:(fun (((sym_path,_),_),_) -> not (is_path_prefix path sym_path)) +let deindex_path path = DB.remove path (* let's flatten the interface *) include DB From 15bfaef074119f02db109c0a76f15016eceab65d Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Mon, 7 Jul 2025 18:43:45 +0200 Subject: [PATCH 09/58] Regular expressions now match substrings by default It used to match only prefixes of strings, which was quite weird --- src/tool/indexing.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index e241fb5aa..4cdfd5f43 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -9,8 +9,10 @@ let is_path_prefix patt p = Lplib.String.is_prefix patt (string_of_path p) let re_matches_sym_name re (p,name) = - (* CSC: fix me *) - Str.string_match re (string_of_path p ^ "." ^ name) 0 + try + ignore (Str.search_forward re (string_of_path p ^ "." ^ name) 0) ; + true + with Not_found -> false let name_of_sym s = (s.sym_path, s.sym_name) From 4e7a4cfeac37acc4bc533c487a9be93979f9563a Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Tue, 8 Jul 2025 13:47:47 +0200 Subject: [PATCH 10/58] Fail when trying to index the same constant twice. Note: there's no easy way to implement the same check for rules. However it is unlikely to index twice a file that contains only rewriting rules. --- src/tool/indexing.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 4cdfd5f43..e784ec1d4 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -4,13 +4,14 @@ open Common open Pos type sym_name = Common.Path.t * string let string_of_path x = Format.asprintf "%a" Common.Path.pp x +let string_of_sym_name (p,n) = string_of_path p ^ "." ^ n let is_path_prefix patt p = Lplib.String.is_prefix patt (string_of_path p) -let re_matches_sym_name re (p,name) = +let re_matches_sym_name re sym_name = try - ignore (Str.search_forward re (string_of_path p ^ "." ^ name) 0) ; + ignore (Str.search_forward re (string_of_sym_name sym_name) 0) ; true with Not_found -> false @@ -658,6 +659,11 @@ let index_rule sym ({Core.Term.lhs=lhsargs ; rule_pos ; _} as rule) = let index_sym sym = let qname = name_of_sym sym in (* Name *) + if List.exists (fun ((sn,_),_) -> sn=qname) + (DB.ItemSet.bindings (DB.locate_name (snd qname))) + then + raise + (Common.Error.Fatal(None,string_of_sym_name qname ^ " already indexed")) ; DB.insert_name (snd qname) ((qname,sym.sym_decl_pos),[Name]) ; (* Type + InType *) let typ = Timed.(!(sym.Core.Term.sym_type)) in From 9b59ee2937077cf33dc11e4673af26b00f69f56b Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Tue, 8 Jul 2025 15:13:00 +0200 Subject: [PATCH 11/58] Fixed: Plac _ can occur in the r.h.s. of rewriting rules E.g. in last rewriting rule in tests/OK/coercions.lp --- TODO.md | 7 +++++++ src/tool/indexing.ml | 29 +++++++++++++++++++++++++---- 2 files changed, 32 insertions(+), 4 deletions(-) diff --git a/TODO.md b/TODO.md index 56dab35b9..4a9d0e376 100644 --- a/TODO.md +++ b/TODO.md @@ -32,6 +32,13 @@ Index and search * better pagination +* Command.handle_require_as: require as X <== what should we do with the renaming? + +* Compile.compile_with: where it calls link we must index all the signature + Sign.add_rules + Sign.add_symbol + +* check the semantics of indexing the Plac _ as variables + Performance improvements ------------------------ diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index e784ec1d4..563994114 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -90,7 +90,13 @@ let rec node_of_stack t s v = (* Let-ins are expanded during indexing *) node_of_stack (subst bind bod) s v | Meta _ -> assert false - | Plac _ -> assert false (* not for meta-closed terms *) + | Plac _ -> + (* this may happen in a rewriting rule that uses a _ in the r.h.s. + that is NOT instantiated; the rule is meant to open a proof + obligation. + + Tentative implementation: a placeholder is seen as a variable *) + IRigid(IVar, index_of_stack s v) | Wild -> assert false (* used only by tactics and reduction *) | TRef _ -> assert false (* destroyed by unfold *) | Bvar _ -> assert false @@ -114,7 +120,14 @@ let rec match_rigid r term = | IAbst, Abst(t1,bind) -> let _, t2 = unbind bind in [t1;t2] | IProd, Prod(t1,bind) -> let _, t2 = unbind bind in [t1;t2] | _, LLet (_typ, bod, bind) -> match_rigid r (subst bind bod) - | _, (Meta _ | Plac _ | Wild | TRef _) -> assert false + | IVar, Plac _ -> + (* this may happen in a rewriting rule that uses a _ in the r.h.s. + that is NOT instantiated; the rule is meant to open a proof + obligation. + + Tentative implementation: a placeholder is seen as a variable *) + [] + | _, (Meta _ | Wild | TRef _) -> assert false | _, _ -> raise NoMatch (* match anything with a flexible term *) @@ -559,7 +572,14 @@ let rec is_flexible t = | Appl(t,_) -> is_flexible t | LLet(_,_,b) -> let _, t = unbind b in is_flexible t | Vari _ | Type | Kind | Symb _ | Prod _ | Abst _ -> false - | Meta _ | Plac _ | Wild | TRef _ | Bvar _ -> assert false + | Plac _ -> + (* this may happen in a rewriting rule that uses a _ in the r.h.s. + that is NOT instantiated; the rule is meant to open a proof + obligation + + Tentative implementation: a placeholder is seen as a variable *) + false + | Meta _ | Wild | TRef _ | Bvar _ -> assert false let enter = DB.(function @@ -589,6 +609,7 @@ let subterms_to_index ~is_spine t = | Vari _ | Type | Kind + | Plac _ | Symb _ -> [] | Abst(t,b) -> let _, t2 = unbind b in @@ -613,7 +634,7 @@ let subterms_to_index ~is_spine t = let _, t3 = unbind b in aux ~where:(enter where) t1 @ aux ~where:(enter where) t2 @ aux ~where:(enter where) t3 - | Meta _ | Plac _ | Wild | TRef _ -> assert false + | Meta _ | Wild | TRef _ -> assert false in aux ~where:(if is_spine then Spine Exact else Conclusion Exact) t let insert_rigid t v = From dc5b98bf1d6794bddeed9b6b148e750358fba528 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Tue, 8 Jul 2025 15:13:40 +0200 Subject: [PATCH 12/58] add_rule reimplemented as a special case of add_rules --- src/core/sign.ml | 22 +++++++--------------- 1 file changed, 7 insertions(+), 15 deletions(-) diff --git a/src/core/sign.ml b/src/core/sign.ml index 52376289e..9f36eb147 100644 --- a/src/core/sign.ml +++ b/src/core/sign.ml @@ -327,21 +327,6 @@ let read = let open Stdlib in let r = ref (dummy ()) in fun n -> Debug.(record_time Reading (fun () -> r := read n)); !r -(** [add_rule sign sym r] adds the new rule [r] to the symbol [sym]. When the - rule does not correspond to a symbol of signature [sign], it is stored in - its dependencies. /!\ does not update the decision tree or the critical - pairs. *) -let add_rule : t -> sym_rule -> unit = fun sign (sym,r) -> - sym.sym_rules := !(sym.sym_rules) @ [r]; - if sym.sym_path <> sign.sign_path then - let sm = Path.Map.find sym.sym_path !(sign.sign_deps) in - let f = function - | None -> Some([r],None) - | Some(rs,n) -> Some(rs@[r],n) - in - let sm = StrMap.update sym.sym_name f sm in - sign.sign_deps := Path.Map.add sym.sym_path sm !(sign.sign_deps) - (** [add_rules sign sym rs] adds the new rules [rs] to the symbol [sym]. When the rules do not correspond to a symbol of signature [sign], they are stored in its dependencies. /!\ does not update the decision tree or the @@ -357,6 +342,13 @@ let add_rules : t -> sym -> rule list -> unit = fun sign sym rs -> let sm = StrMap.update sym.sym_name f sm in sign.sign_deps := Path.Map.add sym.sym_path sm !(sign.sign_deps) +(** [add_rule sign sym r] adds the new rule [r] to the symbol [sym]. When the + rule does not correspond to a symbol of signature [sign], it is stored in + its dependencies. /!\ does not update the decision tree or the critical + pairs. *) +let add_rule : t -> sym_rule -> unit = fun sign (sym,r) -> + add_rules sign sym [r] + (** [add_notation sign sym nota] changes the notation of [sym] to [nota] in the signature [sign]. *) let add_notation : t -> sym -> float notation -> unit = fun sign sym nota -> From c7bf80b44fd41d9752048738e7a19af5ea2ba2bb Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Tue, 8 Jul 2025 19:02:28 +0200 Subject: [PATCH 13/58] The local development is now non-permanently indexed 1. we used a Timed.ref to update the indexes with the local development (i.e. just the files that have been required, not the others) so that it is possible to query the local development 2. when doing "require ... as Foo" the user can use Foo.X in the queries; (but not regular expressions involving Foo, but that seems reasonable) We have introduced some "hakish" code here and there to be reviewed. In particular: 1. we store in Common/Mode if we are running LSP 2. we detected that the current LSP buffer has "fname" set to an URI "file:///". We use this feature to distinguish between the buffer and the filesystem so that, when showing query results to the user, if the text comes from the buffer we can retrieve it 3. we use a finely tuned combination of Stdlib.ref/Timed.ref to "remember" things that would be forgotten. E.g.: a) we remember the LSP buffer content *after* the end of the compilation b) we remember the index *after* the end of the indexing of a single file 4. we used a maison stream-like representation of file contents to be able to retrieve the text to be shown to the user both from the filesystem or from strings (i.e. the content of the LSP buffer) 5. since indexing is now performed even during compilation when things enter a signature in LSP mode, we created a huge circular dependency in the modules that we break using multiple callbacks and Stdlib.ref that are set here and there. Maybe one can do (much) better. In particular pure now depends on tool. --- TODO.md | 7 +++--- src/cli/lambdapi.ml | 7 ++++-- src/common/mode.ml | 4 ++++ src/common/pos.ml | 31 +++++++++++++++--------- src/core/sign.ml | 7 +++++- src/handle/compile.ml | 1 + src/pure/dune | 2 +- src/pure/pure.ml | 1 + src/tool/indexing.ml | 55 ++++++++++++++++++++++++++++++++++++------- src/tool/indexing.mli | 5 ++++ 10 files changed, 92 insertions(+), 28 deletions(-) create mode 100644 src/common/mode.ml diff --git a/TODO.md b/TODO.md index 4a9d0e376..1f6123258 100644 --- a/TODO.md +++ b/TODO.md @@ -32,10 +32,9 @@ Index and search * better pagination -* Command.handle_require_as: require as X <== what should we do with the renaming? - -* Compile.compile_with: where it calls link we must index all the signature - Sign.add_rules + Sign.add_symbol +* document require ... as Foo: using Foo.X in the query already + works (pure magic!); of course it does not work when using + regular expressions [ check before! ] * check the semantics of indexing the Plac _ as variables diff --git a/src/cli/lambdapi.ml b/src/cli/lambdapi.ml index fd8141983..3606827d2 100644 --- a/src/cli/lambdapi.ml +++ b/src/cli/lambdapi.ml @@ -104,7 +104,7 @@ let index_cmd cfg add_only rules files source dbpath_opt = let time = Time.save () in let handle file = Console.reset_default (); - Time.restore time; + Tool.Indexing.preserving_index Time.restore time; Tool.Indexing.load_rewriting_rules rules; Tool.Indexing.index_sign (no_wrn Compile.compile_file file) in List.iter handle files; @@ -210,7 +210,10 @@ let export_cmd (cfg:Config.t) (output:output option) (encoding:string option) (** Running the LSP server. *) let lsp_server_cmd : Config.t -> bool -> string -> unit = fun cfg standard_lsp lsp_log_file -> - let run _ = Config.init cfg; Lsp.Lp_lsp.main standard_lsp lsp_log_file in + let run _ = + Config.init cfg; + Common.Mode.lsp_mod := true ; + Lsp.Lp_lsp.main standard_lsp lsp_log_file in Error.handle_exceptions run (** Printing a decision tree. *) diff --git a/src/common/mode.ml b/src/common/mode.ml new file mode 100644 index 000000000..54ddbcb96 --- /dev/null +++ b/src/common/mode.ml @@ -0,0 +1,4 @@ +(** [lsp_mod] indicates whether we are executing the LSP server. + Constants and rules are indexed automatically only in LSP mode + and not in check mode *) +let lsp_mod = Stdlib.ref false diff --git a/src/common/pos.ml b/src/common/pos.ml index 00dc0f989..0c11ec816 100644 --- a/src/common/pos.ml +++ b/src/common/pos.ml @@ -140,35 +140,44 @@ let locate : ?fname:string -> Lexing.position * Lexing.position -> pos = let make_pos : Lexing.position * Lexing.position -> 'a -> 'a loc = fun lps elt -> in_pos (locate lps) elt -(** [print_file_contents escape sep delimiters pos] prints the contents of the - file at position [pos]. [sep] is the separator replacing each newline +(** [print_file_contents parse_file escape sep delimiters pos] prints the + contents of the file at position [pos]. The [parse_file] function + takes in input [pos.fname] (that in reality may be a filename or + a URI, e.g. when the text comes from LSP) and it returns both a stream + of lines provided by a function that raises End_of_file if the file + content is terminated, and a function to close the resources when + we are done with the stream. + [sep] is the separator replacing each newline (e.g. "
\n"). [delimiters] is a pair of delimiters used to wrap the "unknown location" message returned when the position does not refer to a file. [escape] is used to escape the file contents. The value -1 for end_col is to be interpreted as "at the end of line". *) let print_file_contents : - escape:(string -> string) -> + parse_file:(string -> (unit -> string) * (unit -> unit)) -> + escape:(string -> string) -> delimiters:(string*string) -> complain_if_location_unknown:bool -> popt Lplib.Base.pp = - fun ~escape ~delimiters:(db,de) ~complain_if_location_unknown ppf pos -> + fun ~parse_file ~escape ~delimiters:(db,de) ~complain_if_location_unknown + ppf pos -> match pos with | Some { fname=Some fname; start_line; start_col; end_line; end_col } -> (* WARNING: do not try to understand the following code! It's dangerous for your health! *) - (* ignore the lines before the start_line *) - let ch = open_in fname in + let input_line,finish = parse_file fname in let out = Buffer.create ((end_line - start_line) * 80 + (if end_col = -1 then 80 else end_col) + 1) in + + (* ignore the lines before the start_line *) for i = 0 to start_line - 2 do - ignore (input_line ch) + ignore (input_line ()) done ; (* skip the first start_col UTF8 codepoints of the start_line *) - let startl = input_line ch in + let startl = input_line () in assert (String.is_valid_utf_8 startl); let bytepos = ref 0 in for i = 0 to start_col - 1 do @@ -188,7 +197,7 @@ let print_file_contents : (* add the lines in between the start_line and the end_line *) for i = 0 to end_line - start_line - 2 do - Buffer.add_string out (escape (input_line ch)) ; + Buffer.add_string out (escape (input_line ())) ; Buffer.add_string out "\n" done ; @@ -199,7 +208,7 @@ let print_file_contents : startstr, -1 else startstr, end_col - start_col - else input_line ch, end_col in + else input_line (), end_col in (* keep the first end_col UTF8 codepoints of the end_line *) assert (String.is_valid_utf_8 endl); @@ -217,7 +226,7 @@ let print_file_contents : let str = String.sub endl 0 !bytepos in Buffer.add_string out (escape str) ; - close_in ch ; + finish () ; string ppf (Buffer.contents out) | None | Some {fname=None} -> if complain_if_location_unknown then diff --git a/src/core/sign.ml b/src/core/sign.ml index 9f36eb147..2889d8918 100644 --- a/src/core/sign.ml +++ b/src/core/sign.ml @@ -219,6 +219,9 @@ let unlink : t -> unit = fun sign -> let f s cps = unlink_sym s; List.iter unlink_cp_pos cps in SymMap.iter f !(sign.sign_cp_pos) +let add_symbol_callback = Stdlib.ref (fun _ -> ()) +let add_rules_callback = Stdlib.ref (fun _ _ -> ()) + (** [add_symbol sign expo prop mstrat opaq name pos typ impl notation] adds in the signature [sign] a symbol with name [name], exposition [expo], property [prop], matching strategy [strat], opacity [opaq], type [typ], @@ -233,6 +236,7 @@ let add_symbol : t -> expo -> prop -> match_strat -> bool -> strloc -> (cleanup typ) (minimize_impl impl) in sign.sign_symbols := StrMap.add name.elt sym !(sign.sign_symbols); + if Stdlib.(!Common.Mode.lsp_mod) then Stdlib.(!add_symbol_callback sym) ; sym (** [strip_private sign] removes private symbols from signature [sign]. *) @@ -340,7 +344,8 @@ let add_rules : t -> sym -> rule list -> unit = fun sign sym rs -> | Some(rs',n) -> Some(rs'@rs,n) in let sm = StrMap.update sym.sym_name f sm in - sign.sign_deps := Path.Map.add sym.sym_path sm !(sign.sign_deps) + sign.sign_deps := Path.Map.add sym.sym_path sm !(sign.sign_deps) ; + if Stdlib.(!Common.Mode.lsp_mod) then Stdlib.(!add_rules_callback sym rs) (** [add_rule sign sym r] adds the new rule [r] to the symbol [sym]. When the rule does not correspond to a symbol of signature [sign], it is stored in diff --git a/src/handle/compile.ml b/src/handle/compile.ml index 79706c6cd..d43a6fce3 100644 --- a/src/handle/compile.ml +++ b/src/handle/compile.ml @@ -79,6 +79,7 @@ let rec compile_with : we need to explicitly update the decision tree of their symbols because it is not done in linking which normally follows loading. *) Ghost.iter (fun s -> Tree.update_dtree s []); + if Stdlib.(!Common.Mode.lsp_mod) then Tool.Indexing.index_sign sign ; sign end diff --git a/src/pure/dune b/src/pure/dune index 82aca4a9a..dce63ea6e 100644 --- a/src/pure/dune +++ b/src/pure/dune @@ -2,5 +2,5 @@ (name pure) (public_name lambdapi.pure) (modules :standard) - (libraries camlp-streams lambdapi.handle lambdapi.core) + (libraries camlp-streams lambdapi.handle lambdapi.core lambdapi.tool) (flags -w +3)) diff --git a/src/pure/pure.ml b/src/pure/pure.ml index e8876593a..474dd506b 100644 --- a/src/pure/pure.ml +++ b/src/pure/pure.ml @@ -62,6 +62,7 @@ type state = Time.t * Sig_state.t let parse_text : fname:string -> string -> Command.t list * (Pos.pos * string) option = fun ~fname s -> + Stdlib.(Tool.Indexing.lsp_input := (fname,s)) ; let parse_string = if Filename.check_suffix fname dk_src_extension then Parser.Dk.parse_string diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 563994114..ec4982a32 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -1,5 +1,8 @@ open Core open Term open Common open Pos +open Timed + +let lsp_input = Stdlib.ref ("","") type sym_name = Common.Path.t * string @@ -306,12 +309,12 @@ module DB = struct (* disk persistence *) - let the_dbpath : string ref = ref Path.default_dbpath + let the_dbpath : string Stdlib.ref = Stdlib.ref Path.default_dbpath - let rwpaths = ref [] + let rwpaths = Stdlib.ref [] let restore_from_disk () = - try restore_from ~filename:!the_dbpath + try restore_from ~filename:Stdlib.(!the_dbpath) with Sys_error msg -> Common.Error.wrn None "%s.\n\ Type \"lambdapi index --help\" to learn how to create the index." msg ; @@ -323,6 +326,12 @@ module DB = struct (item * position list) Index.db) Lazy.t ref = ref (lazy (restore_from_disk ())) + let preserving_index f x = + let saved_db = !db in + let res = f x in + db := saved_db ; + res + let empty () = db := lazy (Sym_nameMap.empty,Index.empty) let insert k v = @@ -436,6 +445,22 @@ module DB = struct pp_inside inside pp_side side)) sep + (* given a filename/URI it returns the stream of lines + and a function to close the resources *) + let parse_file fname = + if String.starts_with ~prefix:"file:///" fname then + (assert (fst Stdlib.(!lsp_input) = fname) ; + let text = snd Stdlib.(!lsp_input) in + let lines = ref (String.split_on_char '\n' text) in + (fun () -> + match !lines with + | [] -> raise End_of_file + | he::tl -> lines := tl ; he), + (fun () -> ())) + else + let ch = open_in fname in + (fun () -> input_line ch), (fun () -> close_in ch) + let generic_pp_of_item_list ~escape ~escaper ~separator ~sep ~delimiters ~lis:(lisb,lise) ~pres:(preb,pree) ~bold:(boldb,bolde) ~code:(codeb,codee) fmt l @@ -451,7 +476,7 @@ module DB = struct (popt_to_string ~print_dirname:false pos) separator (generic_pp_of_position_list ~escaper ~sep) positions separator preb codeb - (Common.Pos.print_file_contents ~escape ~delimiters + (Common.Pos.print_file_contents ~parse_file ~escape ~delimiters ~complain_if_location_unknown:true) pos separator (fun ppf opt -> @@ -460,7 +485,7 @@ module DB = struct | Some sourceid -> Lplib.Base.string ppf ("Translated to " ^ sourceid)) sourceid separator - (Common.Pos.print_file_contents ~escape ~delimiters + (Common.Pos.print_file_contents ~parse_file ~escape ~delimiters ~complain_if_location_unknown:false) sourcepos codee pree lise) "" fmt l @@ -535,7 +560,7 @@ let load_meta_rules () = match elt with Parsing.Syntax.P_rules r -> rules := List.rev_append r !rules | _ -> ()) - cmdstream) !DB.rwpaths ; + cmdstream) Stdlib.(!DB.rwpaths) ; let rules = List.rev !rules in let handle_rule map r = let (s,r) = check_rule r in @@ -670,6 +695,12 @@ let index_rule sym ({Core.Term.lhs=lhsargs ; rule_pos ; _} as rule) = let rhs = rule.rhs in let get_inside = function | DB.Conclusion ins -> ins | _ -> assert false in let filename = Option.get rule_pos.fname in + let filename = + if String.starts_with ~prefix:"file:///" filename then + let n = String.length "file://" in + String.sub filename n (String.length filename - n) + else + filename in let path = Library.path_of_file Parsing.LpLexer.escape filename in let rule_name = (path,Common.Pos.to_string ~print_fname:false rule_pos) in index_term_and_subterms ~is_spine:false lhs @@ -677,6 +708,10 @@ let index_rule sym ({Core.Term.lhs=lhsargs ; rule_pos ; _} as rule) = index_term_and_subterms ~is_spine:false rhs (fun where -> ((rule_name,Some rule_pos),[Xhs(get_inside where,Rhs)])) +let _ = + Stdlib.(Core.Sign.add_rules_callback := + fun sym rules -> List.iter (index_rule sym) rules) + let index_sym sym = let qname = name_of_sym sym in (* Name *) @@ -695,8 +730,10 @@ let index_sym sym = (* Rules *) List.iter (index_rule sym) Timed.(!(sym.Core.Term.sym_rules)) +let _ = Stdlib.(Core.Sign.add_symbol_callback := index_sym) + let load_rewriting_rules rwrules = - DB.rwpaths := rwrules + Stdlib.(DB.rwpaths := rwrules) let index_sign sign = (*Console.set_flag "print_domains" true ; @@ -833,13 +870,13 @@ module UserLevelQueries = struct fail (Format.asprintf "Error: %s@." (Printexc.to_string exn)) let search_cmd_html ss ~from ~how_many s ~dbpath = - the_dbpath := dbpath; + Stdlib.(the_dbpath := dbpath); search_cmd_gen ss ~from ~how_many ~fail:(fun x -> "" ^ x ^ "") ~pp_results:(html_of_results_list from) ~title_tag:("

","

") s let search_cmd_txt ss s ~dbpath = - the_dbpath := dbpath; + Stdlib.(the_dbpath := dbpath); search_cmd_gen ss ~from:0 ~how_many:999999 ~fail:(fun x -> Common.Error.fatal_no_pos "%s" x) ~pp_results:pp_results_list ~title_tag:("","") s diff --git a/src/tool/indexing.mli b/src/tool/indexing.mli index 62b1937b4..60aca95ba 100644 --- a/src/tool/indexing.mli +++ b/src/tool/indexing.mli @@ -8,6 +8,11 @@ val parse_source_map : string -> unit (* the name of the file *) val deindex_path : string -> unit val dump : dbpath:string -> unit -> unit +val preserving_index : ('a -> 'b) -> 'a -> 'b + +(* set by lsp; used to print the query results *) +val lsp_input : ((*uri*)string * (*text*)string) ref + (* search command used by cli *) val search_cmd_txt: Sig_state.sig_state -> string -> dbpath:string -> string From 60f9e017a00ea5b50a96a5b71ba099abccc3c419 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Thu, 10 Jul 2025 16:53:14 +0200 Subject: [PATCH 14/58] Websearch switched to rocq{Lexer,Parser} - doc and welcome page of websearch to be updated with the new syntax - in "lambdapi search" and VScode -> and forall cannot be used any more - the new syntax allows all the LP syntax plus: t ::= ... | forall binders, t | exists binders, t | fun binders => t | t -> t - the binders used in the new entries allow also "x ... z : t" that is currently rejected by LP (but it is allowed in Coq) TODO: but for exists, all the Coq's stdlib notations are NOT in place (e.g. arithmetic/logic connectives, numbers, ...). How should we add them? Maybe one possible path is to have "special" notation files that can be fed to websearch when it starts. As for rewriting rules for normalization, the notation files are supposed to add notation to symbols that have NOT been put in the environment. It may be feasible: the file that calls Pratter already uses our find_sym to resolve symbols! --- src/parsing/dune | 2 + src/parsing/parser.ml | 95 ++++++++----- src/parsing/rocqLexer.ml | 227 +++++++++++++++++++++++++++++++ src/parsing/rocqParser.mly | 269 +++++++++++++++++++++++++++++++++++++ src/tool/indexing.ml | 4 +- 5 files changed, 562 insertions(+), 35 deletions(-) create mode 100644 src/parsing/rocqLexer.ml create mode 100644 src/parsing/rocqParser.mly diff --git a/src/parsing/dune b/src/parsing/dune index dbd73fc61..81a91d7a1 100644 --- a/src/parsing/dune +++ b/src/parsing/dune @@ -8,6 +8,8 @@ (menhir (flags --explain --external-tokens LpLexer) (modules lpParser)) +(menhir (flags --explain --external-tokens RocqLexer) (modules rocqParser)) + (ocamllex dkLexer) (menhir (flags --explain --external-tokens DkTokens) (modules dkParser)) diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index bc4824fb6..30ff1abad 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -29,39 +29,15 @@ module type PARSER = sig which comes from file [f] ([f] can be anything). *) end -module Lp : -sig - include PARSER - - val parse_term : in_channel -> Syntax.p_term Stream.t - (** [parse inchan] returns a stream of terms parsed from - channel [inchan]. Terms are parsed lazily and the channel is - closed once all entries are parsed. *) - - val parse_term_file : string -> Syntax.p_term Stream.t - (** [parse_file fname] returns a stream of parsed terms of file - [fname]. Terms are parsed lazily. *) - - val parse_term_string : string -> string -> Syntax.p_term Stream.t - (** [parse_term_string f s] returns a stream of parsed terms from string [s] - which comes from file [f] ([f] can be anything). *) - - val parse_rwpatt_string : string -> string -> Syntax.p_rw_patt Stream.t - (** [parse_rwpatt_string f s] returns a stream of parsed rewrite pattern - specifications from string [s] which comes from file [f] ([f] can be - anything). *) - - val parse_search_query_string : - string -> string -> SearchQuerySyntax.query Stream.t - (** [parse_search_query_string f s] returns a stream of parsed terms from - string [s] which comes from file [f] ([f] can be anything). *) - - val parse_qid : string -> Core.Term.qident - end -= struct - +module Aux(Lexer : + sig + type token + val get_token : + Sedlexing.lexbuf -> unit -> token * Lexing.position * Lexing.position + end) = +struct let stream_of_lexbuf : - grammar_entry:(LpLexer.token,'b) MenhirLib.Convert.traditional -> + grammar_entry:(Lexer.token,'b) MenhirLib.Convert.traditional -> ?inchan:in_channel -> ?fname:string -> Sedlexing.lexbuf -> (* Input channel passed as parameter to be closed at the end of stream. *) 'a Stream.t = @@ -71,7 +47,7 @@ sig MenhirLib.Convert.Simplified.traditional2revised grammar_entry in - let token = LpLexer.token lb in + let token = Lexer.get_token lb in let generator _ = try Some(parse token) with @@ -97,6 +73,41 @@ sig let parse_string ~grammar_entry fname s = stream_of_lexbuf ~grammar_entry ~fname (Sedlexing.Utf8.from_string s) +end + +module Lp : +sig + include PARSER + + val parse_term : in_channel -> Syntax.p_term Stream.t + (** [parse inchan] returns a stream of terms parsed from + channel [inchan]. Terms are parsed lazily and the channel is + closed once all entries are parsed. *) + + val parse_term_file : string -> Syntax.p_term Stream.t + (** [parse_file fname] returns a stream of parsed terms of file + [fname]. Terms are parsed lazily. *) + + val parse_term_string : string -> string -> Syntax.p_term Stream.t + (** [parse_term_string f s] returns a stream of parsed terms from string [s] + which comes from file [f] ([f] can be anything). *) + + val parse_rwpatt_string : string -> string -> Syntax.p_rw_patt Stream.t + (** [parse_rwpatt_string f s] returns a stream of parsed rewrite pattern + specifications from string [s] which comes from file [f] ([f] can be + anything). *) + + val parse_search_query_string : + string -> string -> SearchQuerySyntax.query Stream.t + (** [parse_search_query_string f s] returns a stream of parsed terms from + string [s] which comes from file [f] ([f] can be anything). *) + + val parse_qid : string -> Core.Term.qident + end += struct + include Aux(struct type token = LpLexer.token + let get_token = LpLexer.token end) + let parse_term = parse ~grammar_entry:LpParser.term_alone let parse_term_string = parse_string ~grammar_entry:LpParser.term_alone let parse_rwpatt_string = @@ -115,6 +126,24 @@ sig end +module Rocq : +sig + val parse_search_query_string : + string -> string -> SearchQuerySyntax.query Stream.t + (** [parse_search_query_string f s] returns a stream of parsed terms from + string [s] which comes from file [f] ([f] can be anything). *) +end += struct + include Aux(struct type token = RocqLexer.token + let get_token = RocqLexer.token end) + + let parse_string ~grammar_entry fname s = + stream_of_lexbuf ~grammar_entry ~fname (Sedlexing.Utf8.from_string s) + + let parse_search_query_string = + parse_string ~grammar_entry:RocqParser.search_query_alone +end + (** Parsing dk syntax. *) module Dk : PARSER = struct diff --git a/src/parsing/rocqLexer.ml b/src/parsing/rocqLexer.ml new file mode 100644 index 000000000..6f0b2537e --- /dev/null +++ b/src/parsing/rocqLexer.ml @@ -0,0 +1,227 @@ +(** Lexer for Lambdapi syntax, using Sedlex, a Utf8 lexer generator. *) + +open Lplib +open Sedlexing +open Common open Pos + +let remove_first : Sedlexing.lexbuf -> string = fun lb -> + Utf8.sub_lexeme lb 1 (lexeme_length lb - 1) + +let remove_last : Sedlexing.lexbuf -> string = fun lb -> + Utf8.sub_lexeme lb 0 (lexeme_length lb - 1) + +let remove_ends : Sedlexing.lexbuf -> string = fun lb -> + Utf8.sub_lexeme lb 1 (lexeme_length lb - 2) + +exception SyntaxError of strloc + +let syntax_error : Lexing.position * Lexing.position -> string -> 'a = + fun pos msg -> raise (SyntaxError (Pos.make_pos pos msg)) + +let fail : Sedlexing.lexbuf -> string -> 'a = fun lb msg -> + syntax_error (Sedlexing.lexing_positions lb) msg + +let invalid_character : Sedlexing.lexbuf -> 'a = fun lb -> + fail lb "Invalid character" + +(** Tokens. *) +type token = + (* end of file *) + | EOF + + (* keywords in alphabetical order *) + | GENERALIZE + | IN + | LET + | RULE + | TYPE_QUERY + | TYPE_TERM + + (* other tokens *) + | INT of string + | STRINGLIT of string + + (* symbols *) + | ARROW + | ASSIGN + | BACKQUOTE + | COMMA + | COLON + | DOT + | EXISTS + | FORALL + | FUN + | LAMBDA + | L_PAREN + | L_SQ_BRACKET + | PI + | R_PAREN + | R_SQ_BRACKET + | SEMICOLON + | THICKARROW + | UNDERSCORE + | VBAR + + (* identifiers *) + | UID of string + | UID_EXPL of string + | UID_META of int + | UID_PATT of string + | QID of Path.t (* in reverse order *) + | QID_EXPL of Path.t (* in reverse order *) + +(** Some regexp definitions. *) +let space = [%sedlex.regexp? Chars " \t\n\r"] +let digit = [%sedlex.regexp? '0' .. '9'] +let nat = [%sedlex.regexp? Plus digit] +let int = [%sedlex.regexp? nat | '-', nat] +let float = [%sedlex.regexp? int, '.', Plus digit] +let oneline_comment = [%sedlex.regexp? "//", Star (Compl ('\n' | '\r'))] +let string = [%sedlex.regexp? '"', Star (Compl '"'), '"'] + +(** Identifiers. + + There are two kinds of identifiers: regular identifiers and escaped + identifiers of the form ["{|...|}"]. + + Modulo those surrounding brackets, escaped identifiers allow to use as + identifiers keywords or filenames that are not regular identifiers. + + An escaped identifier denoting a filename or directory is unescaped before + accessing to it. Hence, the module ["{|a b|}"] refers to the file ["a b"]. + + Identifiers need to be normalized so that an escaped identifier, once + unescaped, is not regular. To this end, every identifier of the form + ["{|s|}"] with s regular, is understood as ["s"] (function + [remove_useless_escape] below). + + Finally, identifiers must not be empty, so that we can use the empty string + for the path of ghost signatures. *) + +(** Unqualified regular identifiers are any non-empty sequence of characters + not among: *) +let forbidden_letter = [%sedlex.regexp? Chars " ,;\r\t\n(){}[]:.`\"@$|/"] +let regid = [%sedlex.regexp? '/' | Plus (Compl forbidden_letter)] + +let is_regid : string -> bool = fun s -> + let lb = Utf8.from_string s in + match%sedlex lb with + | regid, eof -> true + | _ -> false + +(** Unqualified escaped identifiers are any non-empty sequence of characters + (except "|}") between "{|" and "|}". *) +let notbars = [%sedlex.regexp? Star (Compl '|')] +let escid = [%sedlex.regexp? + "{|", notbars, '|', Star ('|' | Compl (Chars "|}"), notbars, '|'), '}'] + +(** [escape s] converts a string [s] into an escaped identifier if it is not + regular. We do not check whether [s] contains ["|}"]. FIXME? *) +let escape s = if is_regid s then s else Escape.escape s + +(** [remove_useless_escape s] replaces escaped regular identifiers by their + unescape form. *) +let remove_useless_escape : string -> string = fun s -> + let s' = Escape.unescape s in if is_regid s' then s' else s + +(** Lexer. *) +let rec token lb = + match%sedlex lb with + + (* end of file *) + | eof -> EOF + + (* spaces *) + | space -> token lb + + (* comments *) + | oneline_comment -> token lb + | "/*" -> comment token 0 lb + + (* keywords *) + | "exists" -> EXISTS (* in Coq *) + | "forall" -> FORALL (* in Coq *) + | "fun" -> FUN (* in Coq *) + | "generalize" -> GENERALIZE + | "in" -> IN + | "let" -> LET + | "rule" -> RULE + | "type" -> TYPE_QUERY + | "TYPE" -> TYPE_TERM + + (* other tokens *) + | int -> INT(Utf8.lexeme lb) + | string -> STRINGLIT(Utf8.sub_lexeme lb 1 (lexeme_length lb - 2)) + + (* symbols *) + | 0x2254 (* ≔ *) -> ASSIGN + | 0x2192 (* → *) -> ARROW (* not in Coq! *) + | "->" -> ARROW (* in Coq *) + | "=>" -> THICKARROW (* in Coq *) + | '`' -> BACKQUOTE + | ',' -> COMMA + | ':' -> COLON + | '.' -> DOT + | 0x03bb (* λ *) -> LAMBDA (* not in Coq! *) + | '(' -> L_PAREN + | '[' -> L_SQ_BRACKET + | 0x03a0 (* Π *) -> PI + | ')' -> R_PAREN + | ']' -> R_SQ_BRACKET + | ';' -> SEMICOLON + | '|' -> VBAR + | '_' -> UNDERSCORE + + (* identifiers *) + | regid -> UID(Utf8.lexeme lb) + | escid -> UID(remove_useless_escape(Utf8.lexeme lb)) + | '@', regid -> UID_EXPL(remove_first lb) + | '@', escid -> UID_EXPL(remove_useless_escape(remove_first lb)) + | '?', nat -> UID_META(int_of_string(remove_first lb)) + | '$', regid -> UID_PATT(remove_first lb) + | '$', escid -> UID_PATT(remove_useless_escape(remove_first lb)) + | '$', nat -> UID_PATT(remove_first lb) + + | regid, '.' -> qid false [remove_last lb] lb + | escid, '.' -> qid false [remove_useless_escape(remove_last lb)] lb + | '@', regid, '.' -> qid true [remove_ends lb] lb + | '@', escid, '.' -> qid true [remove_useless_escape(remove_ends lb)] lb + + (* invalid character *) + | _ -> invalid_character lb + +and qid expl ids lb = + match%sedlex lb with + | oneline_comment -> qid expl ids lb + | "/*" -> comment (qid expl ids) 0 lb + | regid, '.' -> qid expl (remove_last lb :: ids) lb + | escid, '.' -> qid expl (remove_useless_escape(remove_last lb) :: ids) lb + | regid -> + if expl then QID_EXPL(Utf8.lexeme lb :: ids) + else QID(Utf8.lexeme lb :: ids) + | escid -> + if expl then QID_EXPL(remove_useless_escape (Utf8.lexeme lb) :: ids) + else QID(remove_useless_escape (Utf8.lexeme lb) :: ids) + | _ -> + fail lb ("Invalid identifier: \"" + ^ String.concat "." (List.rev (Utf8.lexeme lb :: ids)) ^ "\".") + +and comment next i lb = + match%sedlex lb with + | eof -> fail lb "Unterminated comment." + | "*/" -> if i=0 then next lb else comment next (i-1) lb + | "/*" -> comment next (i+1) lb + | any -> comment next i lb + | _ -> invalid_character lb + +(** [token buf] is a lexing function on buffer [buf] that can be passed to + a parser. *) +let token : lexbuf -> unit -> token * Lexing.position * Lexing.position = + fun lb () -> try with_tokenizer token lb () with + | Sedlexing.MalFormed -> fail lb "Not Utf8 encoded file" + | Sedlexing.InvalidCodepoint k -> + fail lb ("Invalid Utf8 code point " ^ string_of_int k) + +let token = + let r = ref (EOF, Lexing.dummy_pos, Lexing.dummy_pos) in fun lb () -> + Debug.(record_time Lexing (fun () -> r := token lb ())); !r diff --git a/src/parsing/rocqParser.mly b/src/parsing/rocqParser.mly new file mode 100644 index 000000000..4b0524ad7 --- /dev/null +++ b/src/parsing/rocqParser.mly @@ -0,0 +1,269 @@ +(** Lambdapi parser, using the parser generator Menhir. *) + +%{ + open Lplib + open Common open Pos + open Syntax + open Core + + let qid_of_path lps = function + | [] -> assert false + | id::mp -> make_pos lps (List.rev mp, id) + + let make_abst startpos ps t endpos = + if ps = [] then t else make_pos (startpos,endpos) (P_Abst(ps,t)) + + let make_prod startpos ps t endpos = + if ps = [] then t else make_pos (startpos,endpos) (P_Prod(ps,t)) + + exception Error +%} + + +// end of file + +%token EOF + +// keywords in alphabetical order + +%token GENERALIZE +%token IN +%token LET +%token RULE +%token TYPE_QUERY +%token TYPE_TERM + +// other tokens + +%token INT +%token STRINGLIT + +// symbols + +%token ARROW +%token ASSIGN +%token BACKQUOTE +%token COMMA +%token COLON +%token DOT +%token EXISTS +%token FORALL +%token FUN +%token LAMBDA +%token L_PAREN +%token L_SQ_BRACKET +%token PI +%token R_PAREN +%token R_SQ_BRACKET +%token SEMICOLON +%token THICKARROW +%token UNDERSCORE +%token VBAR + +// identifiers + +%token UID +%token UID_EXPL +%token UID_META +%token UID_PATT +%token QID +%token QID_EXPL + +// types + +%start search_query_alone + +%% + +search_query_alone: + | q=search_query EOF + { q } + +uid: s=UID { make_pos $sloc s} + +param_list: + | x=param { ([x], None, false) } + | L_PAREN xs=param+ COLON a=term R_PAREN { (xs, Some(a), false) } + | L_SQ_BRACKET xs=param+ a=preceded(COLON, term)? R_SQ_BRACKET + { (xs, a, true) } + +fun_param_list: + | x=param { ([x], None, false) } + | L_PAREN xs=param+ COLON a=term R_PAREN { (xs, Some(a), false) } + +param: + | s=uid { Some s } + | UNDERSCORE { None } + +term: + | t=bterm { t } + | t=saterm { t } + | t=saterm u=bterm { make_pos $sloc (P_Appl(t,u)) } + | t=saterm ARROW u=term { make_pos $sloc (P_Arro(t, u)) } + +bterm: + | BACKQUOTE q=term_id b=binder + { let b = make_pos $loc(b) (P_Abst(fst b, snd b)) in + make_pos $sloc (P_Appl(q, b)) } + | EXISTS b=rocqbinder(COMMA) + { {(List.fold_right + (fun bin res -> + Pos.none (P_Appl( + Pos.none (P_Iden(Pos.none ([],"∃"), false)), + Pos.none (P_Abst([bin], res))))) + (fst b) + (snd b)) + with pos = Some (Pos.locate $sloc) } + } (* in Coq *) + | FORALL b=rocqbinder(COMMA) + { make_pos $sloc (P_Prod(fst b, snd b)) } (* in Coq *) + | PI b=binder + { make_pos $sloc (P_Prod(fst b, snd b)) } (* not in Coq! *) + | LAMBDA b=binder + { make_pos $sloc (P_Abst(fst b, snd b)) } (* not in Coq! *) + | FUN b=rocqbinder(THICKARROW) + { make_pos $sloc (P_Abst(fst b, snd b)) } (* in Coq *) + | LET x=uid a=param_list* b=preceded(COLON, term)? ASSIGN t=term IN u=term + { make_pos $sloc (P_LLet(x, a, b, t, u)) } + +saterm: + | t=saterm u=aterm { make_pos $sloc (P_Appl(t,u)) } + | t=aterm { t } + +aterm: + | ti=term_id { ti } + | UNDERSCORE { make_pos $sloc P_Wild } + | TYPE_TERM { make_pos $sloc P_Type } + | s=UID_META ts=env? + { let i = make_pos $loc(s) s + and ts = match ts with None -> [||] | Some ts -> Array.of_list ts in + make_pos $sloc (P_Meta(i,ts)) } + | s=UID_PATT e=env? + { let i = if s = "_" then None else Some(make_pos $loc(s) s) in + make_pos $sloc (P_Patt(i, Option.map Array.of_list e)) } + | L_PAREN t=term R_PAREN { make_pos $sloc (P_Wrap(t)) } + | L_SQ_BRACKET t=term R_SQ_BRACKET { make_pos $sloc (P_Expl(t)) } + | n=INT { make_pos $sloc (P_NLit n) } + | s=STRINGLIT { make_pos $sloc (P_SLit s) } + +env: DOT L_SQ_BRACKET ts=separated_list(SEMICOLON, term) R_SQ_BRACKET { ts } + +term_id: + | i=qid { make_pos $sloc (P_Iden(i, false)) } + | i=qid_expl { make_pos $sloc (P_Iden(i, true)) } + +qid: + | s=UID { make_pos $sloc ([], s) } + | p=QID { qid_of_path $sloc p } + +qid_expl: + | s=UID_EXPL { make_pos $sloc ([], s) } + | p=QID_EXPL { qid_of_path $sloc p } + +binder: + | ps=param_list+ COMMA t=term { (ps, t) } + | p=param COLON a=term COMMA t=term { ([[p], Some a, false], t) } + +rocqbinder(terminator): + | ps=fun_param_list+ a=preceded(COLON, term)? terminator t=term + { if a = None then + (ps, t) + else if List.for_all (fun (_,typ,_) -> typ = None) ps then + (List.map (fun (v,_,b) -> v,a,b) ps, t) + else + raise Error + } + +maybe_generalize: + | g = GENERALIZE? + { g <> None } + +where: + | u = UID g=maybe_generalize + { g, match u with + | "=" -> Some SearchQuerySyntax.Exact + | ">" -> Some SearchQuerySyntax.Inside + | "≥" + | ">=" -> None + | _ -> + LpLexer.syntax_error $sloc + "Only \">\", \"=\", \"≥\" and \">=\" accepted" + } + +asearch_query: + (* "type" is a keyword... *) + | TYPE_QUERY gw=where t=aterm + { let g,w = gw in + if w <> None then + LpLexer.syntax_error $sloc + "Only \"≥\" and \">=\" accepted for \"type\"" + else + SearchQuerySyntax.QBase(QSearch(t,g,Some (QType None))) } + | RULE gw=where t=aterm + { let g,w = gw in + SearchQuerySyntax.QBase(QSearch(t,g,Some (QXhs(w,None)))) } + | k=UID gw=where t=aterm + { let open SearchQuerySyntax in + let g,w = gw in + match k,t.elt with + | "name",P_Iden(id,false) -> + assert (fst id.elt = []) ; + if w <> Some Exact then + LpLexer.syntax_error $sloc + "Only \"=\" accepted for \"name\"" + else if g = true then + LpLexer.syntax_error $sloc + "\"generalize\" cannot be used with \"name\"" + else + QBase(QName (snd id.elt)) + | "name",_ -> + LpLexer.syntax_error $sloc "Path prefix expected after \"name:\"" + | "anywhere",_ -> + if w <> None then + LpLexer.syntax_error $sloc + "Only \"≥\" and \">=\" accepted for \"anywhere\"" + else + QBase(QSearch(t,g,None)) + | "spine",_ -> + QBase(QSearch(t,g,Some (QType (Some (Spine w))))) + | "concl",_ -> + QBase(QSearch(t,g,Some (QType (Some (Conclusion w))))) + | "hyp",_ -> + QBase(QSearch(t,g,Some (QType (Some (Hypothesis w))))) + | "lhs",_ -> + QBase(QSearch(t,g,Some (QXhs(w,Some Lhs)))) + | "rhs",_ -> + QBase(QSearch(t,g,Some (QXhs(w,Some Rhs)))) + | _,_ -> + LpLexer.syntax_error $sloc ("Unknown keyword: " ^ k) + } + | L_PAREN q=search_query R_PAREN + { q } + +csearch_query: + | q=asearch_query + { q } + | q1=csearch_query COMMA q2=asearch_query + { SearchQuerySyntax.QOpp (q1,SearchQuerySyntax.Intersect,q2) } + +ssearch_query: + | q=csearch_query + { q } + | q1=ssearch_query SEMICOLON q2=csearch_query + { SearchQuerySyntax.QOpp (q1,SearchQuerySyntax.Union,q2) } + +search_query: + | q=ssearch_query + { q } + | q=search_query VBAR qid=qid + { let p,n = qid.elt in + let path = + if p = [] then n + else + Format.asprintf "%a.%a" Core.Print.path p Core.Print.uid n in + SearchQuerySyntax.QFilter (q,Path path) } + | q=search_query VBAR s=STRINGLIT + { let re = Str.regexp s in + SearchQuerySyntax.QFilter (q,RegExp re) } + +%% diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index ec4982a32..d9050d9a3 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -841,9 +841,8 @@ module UserLevelQueries = struct let search_cmd_gen ss ~from ~how_many ~fail ~pp_results ~title_tag:(hb,he) s = - let s = transform_ascii_to_unicode s in try - let pstream = Parsing.Parser.Lp.parse_search_query_string "LPSearch" s in + let pstream = Parsing.Parser.Rocq.parse_search_query_string "LPSearch" s in let pq = Stream.next pstream in let mok _ = None in let items = ItemSet.bindings (answer_query ~mok ss [] pq) in @@ -876,6 +875,7 @@ module UserLevelQueries = struct ~pp_results:(html_of_results_list from) ~title_tag:("

","

") s let search_cmd_txt ss s ~dbpath = + let s = transform_ascii_to_unicode s in Stdlib.(the_dbpath := dbpath); search_cmd_gen ss ~from:0 ~how_many:999999 ~fail:(fun x -> Common.Error.fatal_no_pos "%s" x) From 94b610afff1553520eb5655c4df2ccf6bec73e62 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Thu, 10 Jul 2025 16:54:03 +0200 Subject: [PATCH 15/58] ... --- TODO.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/TODO.md b/TODO.md index 1f6123258..3b118d225 100644 --- a/TODO.md +++ b/TODO.md @@ -4,6 +4,8 @@ TODO Index and search ---------------- +* add notations for Coq stdlib to websearch (using Pratter?) + * generate mappings from LP to V automatically with HOL2DK and find what to do with manually written files; also right now there are mappings that are lost and mappings that are confused in a many-to-one From cecd16f6737c9441750408cc1ef9e8635943a708 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Thu, 10 Jul 2025 17:17:27 +0200 Subject: [PATCH 16/58] Updated --- TODO.md | 65 ++++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 43 insertions(+), 22 deletions(-) diff --git a/TODO.md b/TODO.md index 3b118d225..431f3f017 100644 --- a/TODO.md +++ b/TODO.md @@ -11,34 +11,46 @@ Index and search mappings that are lost and mappings that are confused in a many-to-one relation -* document new features, e.g. -sources (and find better - terminology), deindex +* normalize queries when given as commands in lambdapi + +* syntactic sugar for regular expressions / way to write a regular + expression - only query efficiently + (concl = _ | "regexpr") + +* CLI interface: it tries to render way too many results + and it takes ages -* After "Number of results: 3" there is a missing CRLF +* after "Number of results: 3" there is a missing CRLF * why type only supports? = also doc is wrong, but I suppose code is wrong -* CLI interface: it tries to render way too many results - and it takes ages +* check the semantics of indexing the Plac _ as variables -* html tags in textual output :-( +* when disambiguating an identifier, after rewriting one could be + left with just one id (not working now) + +Think about +----------- + +* alignments with same name ==> automatic preference? * would it be more reasonable to save the normalization rules when the index is created and apply them as default when searching, in particular when searching as a lambdapi command? -* normalize queries when given as commands in lambdapi +* package management -* alignments with same name ==> automatic preference? +* update index / deindex (it should work at package level) -* better pagination +* more external sources when showing query results, including Git repos -* document require ... as Foo: using Foo.X in the query already - works (pure magic!); of course it does not work when using - regular expressions [ check before! ] +* VS code integration: right now lambdapi works on the current development + mixed with remote, but different sets of rewriting rules would make sense; + should it instead only work with the current development and dispatch + queries via VS code to a remote websearch? -* check the semantics of indexing the Plac _ as variables +* ranking Performance improvements ------------------------ @@ -49,16 +61,25 @@ Performance improvements and THEN it filters out the justifications that have Concl Exact; maybe we could save a lot of time anticipating the filtrage -Misleading output ------------------ +Documentation +------------- -+ Too many results found? +* document new features, e.g. -sources (and find better + terminology), deindex + +* document Coq syntax in websearch + +* document require ... as Foo: using Foo.X in the query already + works (pure magic!); of course it does not work when using + regular expressions [ check before! ] -anywhere >= (Π x: _, (= _ V# V#)) -anywhere >= (Π x: _, (= _ x x)) +* Misleading output for: -NO, it's ok, but the output is misleading. The second form is equivalent -to the first that is equivalent to (_ -> (= _ V# V#)) that is what it is -found. However it shows the pattern saying that " (Π x: _, (= _ x x))" was -found, that is the misleading thing. + anywhere >= (Π x: _, (= _ V# V#)) + anywhere >= (Π x: _, (= _ x x)) + Are there too many results? NO, it's ok, but the output is misleading. + The second form is equivalent + to the first that is equivalent to (_ -> (= _ V# V#)) that is what it is + found. However it shows the pattern saying that " (Π x: _, (= _ x x))" was + found, that is the misleading thing. From caa4f000e8d6856dc8a2aba373c8189ce9926452 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Thu, 10 Jul 2025 17:36:42 +0200 Subject: [PATCH 17/58] ... --- TODO.md | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/TODO.md b/TODO.md index 431f3f017..7258ade19 100644 --- a/TODO.md +++ b/TODO.md @@ -21,9 +21,7 @@ Index and search and it takes ages * after "Number of results: 3" there is a missing CRLF - -* why type only supports? = - also doc is wrong, but I suppose code is wrong +* also after "Please rewrite the query ... following:" * check the semantics of indexing the Plac _ as variables @@ -64,6 +62,10 @@ Performance improvements Documentation ------------- +* fix the doc: not only "anywhere" but also "type" can be paired + only with ">="; maybe make it explicit that to match exactly the + type of a constant one should use "spine =" + * document new features, e.g. -sources (and find better terminology), deindex From 8de1444ddb7f52ad4bee653a6cbb6bc00ae0c4c4 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Thu, 10 Jul 2025 17:40:34 +0200 Subject: [PATCH 18/58] ... --- TODO.md | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/TODO.md b/TODO.md index 7258ade19..e9ee7d9be 100644 --- a/TODO.md +++ b/TODO.md @@ -4,14 +4,13 @@ TODO Index and search ---------------- -* add notations for Coq stdlib to websearch (using Pratter?) +* after "Number of results: 3" there is a missing CRLF +* also after "Please rewrite the query ... following:" -* generate mappings from LP to V automatically with HOL2DK and find - what to do with manually written files; also right now there are - mappings that are lost and mappings that are confused in a many-to-one - relation +* when disambiguating an identifier, after rewriting one could be + left with just one id (not working now) -* normalize queries when given as commands in lambdapi +* add notations for Coq stdlib to websearch (using Pratter?) * syntactic sugar for regular expressions / way to write a regular expression - only query efficiently @@ -20,13 +19,12 @@ Index and search * CLI interface: it tries to render way too many results and it takes ages -* after "Number of results: 3" there is a missing CRLF -* also after "Please rewrite the query ... following:" - -* check the semantics of indexing the Plac _ as variables +* normalize queries when given as commands in lambdapi -* when disambiguating an identifier, after rewriting one could be - left with just one id (not working now) +* generate mappings from LP to V automatically with HOL2DK and find + what to do with manually written files; also right now there are + mappings that are lost and mappings that are confused in a many-to-one + relation Think about ----------- From f8c1059da490fa265a0d0cfd9967f8ab14607cc2 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Thu, 10 Jul 2025 17:51:45 +0200 Subject: [PATCH 19/58] Fix missing \n --- TODO.md | 3 --- src/tool/indexing.ml | 6 +++--- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/TODO.md b/TODO.md index e9ee7d9be..ccd6b0fc2 100644 --- a/TODO.md +++ b/TODO.md @@ -4,9 +4,6 @@ TODO Index and search ---------------- -* after "Number of results: 3" there is a missing CRLF -* also after "Please rewrite the query ... following:" - * when disambiguating an identifier, after rewriting one could be left with just one id (not working now) diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index d9050d9a3..a38113bf6 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -849,17 +849,17 @@ module UserLevelQueries = struct let resultsno = List.length items in let _,items = Lplib.List.cut items from in let items,_ = Lplib.List.cut items how_many in - Format.asprintf "%sNumber of results: %d%s%a@." + Format.asprintf "%sNumber of results: %d%s@.%a@." hb resultsno he pp_results items with | Stream.Failure -> - fail (Format.asprintf "Syntax error: a query was expected") + fail (Format.asprintf "Syntax error: a query was expected@.") | Common.Error.Fatal(_,msg) -> fail (Format.asprintf "Error: %s@." msg) | Overloaded(name,res) -> fail (Format.asprintf "Overloaded symbol %s. Please rewrite the query replacing %s \ - with a fully qualified identifier among the following: %a" + with a fully qualified identifier among the following:@.%a@." name name pp_results (ItemSet.bindings res)) | Stack_overflow -> fail From d4ab72d976e0da3b4cd7c9d9f12cd54da5b0cc88 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Thu, 10 Jul 2025 18:48:22 +0200 Subject: [PATCH 20/58] Search results from CLI are now printed line-by-line (streamed) --- TODO.md | 4 ++-- src/cli/lambdapi.ml | 4 ++-- src/handle/query.ml | 2 +- src/tool/indexing.ml | 38 +++++++++++++++++++++----------------- src/tool/indexing.mli | 3 ++- 5 files changed, 28 insertions(+), 23 deletions(-) diff --git a/TODO.md b/TODO.md index ccd6b0fc2..f4928d1fd 100644 --- a/TODO.md +++ b/TODO.md @@ -13,8 +13,8 @@ Index and search expression - only query efficiently (concl = _ | "regexpr") -* CLI interface: it tries to render way too many results - and it takes ages +* CLI interface: use colors? be aware of redirections over files / more + / less * normalize queries when given as commands in lambdapi diff --git a/src/cli/lambdapi.ml b/src/cli/lambdapi.ml index 3606827d2..ab21f6021 100644 --- a/src/cli/lambdapi.ml +++ b/src/cli/lambdapi.ml @@ -35,8 +35,8 @@ let search_cmd cfg rules require s dbpath_opt = Tool.Indexing.load_rewriting_rules rules ; let ss = sig_state_of_require require in let dbpath = Option.get Path.default_dbpath dbpath_opt in - out Format.std_formatter "%s@." - (Tool.Indexing.search_cmd_txt ss s ~dbpath) in + out Format.std_formatter "%a@." + (Tool.Indexing.search_cmd_txt ss ~dbpath) s in Error.handle_exceptions run let websearch_cmd cfg rules port require header_file dbpath_opt path_in_url = diff --git a/src/handle/query.ml b/src/handle/query.ml index b07dc77c7..faf5dd4c4 100644 --- a/src/handle/query.ml +++ b/src/handle/query.ml @@ -177,7 +177,7 @@ let handle : Sig_state.t -> proof_state option -> p_query -> result = match elt with | P_query_search s -> let dbpath = Path.default_dbpath in - return string (Tool.Indexing.search_cmd_txt ss s ~dbpath) + return (Tool.Indexing.search_cmd_txt ss ~dbpath) s | P_query_debug(_,_) | P_query_verbose(_) | P_query_flag(_,_) diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index a38113bf6..7b2913886 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -471,7 +471,7 @@ module DB = struct Lplib.List.pp (fun ppf (((p,n) as sym_name,pos),(positions : answer)) -> let sourceid,sourcepos = source_infos_of_sym_name sym_name in - Lplib.Base.out ppf "%s%a.%s%s%s@%s%s%a%s%s%s%a%s%a%s%a%s%s%s@." + Lplib.Base.out ppf "%s%a.%s%s%s@%s%s%a%s%s%s%a%s%a%s%a%s%s%s%s@." lisb (escaper.run Core.Print.path) p boldb n bolde (popt_to_string ~print_dirname:false pos) separator (generic_pp_of_position_list ~escaper ~sep) positions @@ -487,7 +487,7 @@ module DB = struct separator (Common.Pos.print_file_contents ~parse_file ~escape ~delimiters ~complain_if_location_unknown:false) sourcepos - codee pree lise) + codee pree lise separator) "" fmt l let html_of_item_list = @@ -840,46 +840,50 @@ module UserLevelQueries = struct Str.global_replace (Str.regexp "\\bforall\\b") "Π" s let search_cmd_gen ss ~from ~how_many ~fail ~pp_results - ~title_tag:(hb,he) s = + ~title_tag:(hb,he) fmt s = try let pstream = Parsing.Parser.Rocq.parse_search_query_string "LPSearch" s in let pq = Stream.next pstream in let mok _ = None in - let items = ItemSet.bindings (answer_query ~mok ss [] pq) in + let items = answer_query ~mok ss [] pq in + let items = ItemSet.bindings items in let resultsno = List.length items in let _,items = Lplib.List.cut items from in let items,_ = Lplib.List.cut items how_many in - Format.asprintf "%sNumber of results: %d%s@.%a@." + Lplib.Base.out fmt "%sNumber of results: %d%s@.%a@." hb resultsno he pp_results items with | Stream.Failure -> - fail (Format.asprintf "Syntax error: a query was expected@.") + Lplib.Base.out fmt "%s" + (fail (Format.asprintf "Syntax error: a query was expected@.")) | Common.Error.Fatal(_,msg) -> - fail (Format.asprintf "Error: %s@." msg) + Lplib.Base.out fmt "%s" (fail (Format.asprintf "Error: %s@." msg)) | Overloaded(name,res) -> - fail (Format.asprintf + Lplib.Base.out fmt "%s" (fail (Format.asprintf "Overloaded symbol %s. Please rewrite the query replacing %s \ with a fully qualified identifier among the following:@.%a@." - name name pp_results (ItemSet.bindings res)) + name name pp_results (ItemSet.bindings res))) | Stack_overflow -> - fail + Lplib.Base.out fmt "%s" (fail (Format.asprintf - "Error: too many results. Please refine your query.@." ) + "Error: too many results. Please refine your query.@." )) | exn -> - fail (Format.asprintf "Error: %s@." (Printexc.to_string exn)) + Lplib.Base.out fmt "%s" + (fail (Format.asprintf "Error: %s@." (Printexc.to_string exn))) let search_cmd_html ss ~from ~how_many s ~dbpath = Stdlib.(the_dbpath := dbpath); - search_cmd_gen ss ~from ~how_many - ~fail:(fun x -> "" ^ x ^ "") - ~pp_results:(html_of_results_list from) ~title_tag:("

","

") s + Format.asprintf "%a" + (search_cmd_gen ss ~from ~how_many + ~fail:(fun x -> "" ^ x ^ "") + ~pp_results:(html_of_results_list from) ~title_tag:("

","

")) s - let search_cmd_txt ss s ~dbpath = + let search_cmd_txt ss ~dbpath fmt s = let s = transform_ascii_to_unicode s in Stdlib.(the_dbpath := dbpath); search_cmd_gen ss ~from:0 ~how_many:999999 ~fail:(fun x -> Common.Error.fatal_no_pos "%s" x) - ~pp_results:pp_results_list ~title_tag:("","") s + ~pp_results:pp_results_list ~title_tag:("","") fmt s end diff --git a/src/tool/indexing.mli b/src/tool/indexing.mli index 60aca95ba..0f83152b6 100644 --- a/src/tool/indexing.mli +++ b/src/tool/indexing.mli @@ -14,7 +14,8 @@ val preserving_index : ('a -> 'b) -> 'a -> 'b val lsp_input : ((*uri*)string * (*text*)string) ref (* search command used by cli *) -val search_cmd_txt: Sig_state.sig_state -> string -> dbpath:string -> string +val search_cmd_txt: + Sig_state.sig_state -> dbpath:string -> string Lplib.Base.pp (* search command used by websearch *) val search_cmd_html: From 821b2340fec1fa19655f2176678c72b3fb259cde Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Thu, 10 Jul 2025 19:13:11 +0200 Subject: [PATCH 21/58] Use colors for textual output --- TODO.md | 3 --- src/tool/indexing.ml | 8 ++++++-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/TODO.md b/TODO.md index f4928d1fd..4a637c252 100644 --- a/TODO.md +++ b/TODO.md @@ -13,9 +13,6 @@ Index and search expression - only query efficiently (concl = _ | "regexpr") -* CLI interface: use colors? be aware of redirections over files / more - / less - * normalize queries when given as commands in lambdapi * generate mappings from LP to V automatically with HOL2DK and find diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 7b2913886..58c119143 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -496,10 +496,14 @@ module DB = struct ~lis:("
  • ","
    • ") ~pres:("
    ","
    ") ~bold:("","") ~code:("","") - let pp_item_list = + let pp_item_list fmt l = generic_pp_of_item_list ~escape:(fun x -> x) ~escaper:identity_escaper ~separator:"\n" ~sep:" and\n" ~delimiters:("","") - ~lis:("* ","") ~pres:("","") ~bold:("","") ~code:("","") + ~lis:("* ","") ~pres:("","") + ~bold:(if Stdlib.(!Common.Mode.lsp_mod) || Unix.isatty Unix.stdout then + ("","") + else ("","")) + ~code:("","") fmt l let pp_results_list fmt l = pp_item_list fmt l From 20c5c68942b90c7fa3e677a8e2b40436b7273d16 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Fri, 11 Jul 2025 09:21:24 +0200 Subject: [PATCH 22/58] ... --- TODO.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/TODO.md b/TODO.md index 4a637c252..6709a5298 100644 --- a/TODO.md +++ b/TODO.md @@ -4,6 +4,9 @@ TODO Index and search ---------------- +* @abdelghani include git sub-repos and automatize the generation + of the file to output Coq sources + * when disambiguating an identifier, after rewriting one could be left with just one id (not working now) From ef93bcae76fc512d1f0b5bbf210036aca36eca76 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Fri, 11 Jul 2025 09:29:55 +0200 Subject: [PATCH 23/58] ... --- TODO.md | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/TODO.md b/TODO.md index 6709a5298..6214e2438 100644 --- a/TODO.md +++ b/TODO.md @@ -4,8 +4,9 @@ TODO Index and search ---------------- -* @abdelghani include git sub-repos and automatize the generation - of the file to output Coq sources +* @abdelghani include in HOL2DK_indexing git sub-repos of + coq-hol-light-real-with-N and coq-hol-light + and automatize the generation of the file to output Coq sources * when disambiguating an identifier, after rewriting one could be left with just one id (not working now) From d1efd6550acbf01c7594eb05e1eb2c543e502af0 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Fri, 11 Jul 2025 09:43:17 +0200 Subject: [PATCH 24/58] ... --- TODO.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/TODO.md b/TODO.md index 6214e2438..1004f42e9 100644 --- a/TODO.md +++ b/TODO.md @@ -8,6 +8,14 @@ Index and search coq-hol-light-real-with-N and coq-hol-light and automatize the generation of the file to output Coq sources +* @abdelghani + - use lplib/color.ml in place of our color management of the + output [ but do not lose our code to check if we are + in lsp_mode or targeting a tty ] + - "Overloaded symbol prod. Please rewrite the query replacing..." + is printed in red but the following lines are also in red + (i.e. black color is not restored) + * when disambiguating an identifier, after rewriting one could be left with just one id (not working now) From 18154ae02a77689edecf5cc585341ba5de07563b Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Fri, 11 Jul 2025 09:56:05 +0200 Subject: [PATCH 25/58] ... --- TODO.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/TODO.md b/TODO.md index 1004f42e9..db9016258 100644 --- a/TODO.md +++ b/TODO.md @@ -16,6 +16,12 @@ Index and search is printed in red but the following lines are also in red (i.e. black color is not restored) +* @abdelghani + - commit the very nice new look&feel of websearch + - (maybe?) allow an --add-examples=FNAME to include in the + generated webpage an HTML snippet (e.g. with examples or + additional infos for that instance) + * when disambiguating an identifier, after rewriting one could be left with just one id (not working now) From 790dc093dfdc80e4c0d257ccb21c2e6ff091f4b4 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Fri, 11 Jul 2025 10:09:36 +0200 Subject: [PATCH 26/58] Overloading is now detected up to normalization rules - this basically removes ALL overloaded problems from the HOL export - the code is written so that the two normalized symbols may be unequal (in the sense of =) but have the same path. Maybe one should investigate why this is necessary, but for the time being it is safe to ignore. [ We are probably comparing a real symbol with a bogus one or even two bogus ones that differ ] --- TODO.md | 3 --- src/tool/indexing.ml | 56 +++++++++++++++++++++++++++++++++----------- 2 files changed, 42 insertions(+), 17 deletions(-) diff --git a/TODO.md b/TODO.md index db9016258..7c14b5935 100644 --- a/TODO.md +++ b/TODO.md @@ -22,9 +22,6 @@ Index and search generated webpage an HTML snippet (e.g. with examples or additional infos for that instance) -* when disambiguating an identifier, after rewriting one could be - left with just one id (not working now) - * add notations for Coq stdlib to websearch (using Pratter?) * syntactic sugar for regular expressions / way to write a regular diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 58c119143..1b99c7809 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -514,25 +514,51 @@ end exception Overloaded of string * DB.answer DB.ItemSet.t +let normalize_fun = ref (fun _ -> assert false) + +let mk_bogus_sym mp name pos = + Core.Term.create_sym mp Core.Term.Public Core.Term.Defin Core.Term.Sequen + false (Common.Pos.make pos name) None Core.Term.mk_Type [] + +let elim_duplicates_up_to_normalization res = + let resl = DB.ItemSet.bindings res in + let norm = + List.map + (fun ((((mp,name),sympos),l) as inp) -> + let s = mk_bogus_sym mp name sympos in + match !normalize_fun (Core.Term.mk_Symb s) with + | Symb {sym_path ; sym_name ; _} -> + (((sym_path,sym_name),sympos), l) + | _ -> inp) resl in + let res = List.sort (fun ((x,_),_) ((y,_),_) -> compare x y) norm in + let res = + let rec uniq = + function + | [] | [_] as l -> l + | ((x,_),_)::(((y,_),_)::_ as l) when x=y -> uniq l + | i::l -> i::uniq l in + uniq res in + DB.ItemSet.of_list res + let find_sym ~prt ~prv sig_state ({elt=(mp,name); pos} as s) = - let pos,mp = - match mp with - [] -> - let res = DB.locate_name name in - if DB.ItemSet.cardinal res > 1 then - raise (Overloaded (name,res)) ; - (match DB.ItemSet.choose_opt res with - | None -> Common.Error.fatal pos "Unknown symbol %s." name - | Some (((mp,_),sympos),[_,_,DB.Name]) -> sympos,mp - | Some _ -> assert false) (* locate only returns DB.Name*) - | _::_ -> None,mp - in try Core.Sig_state.find_sym ~prt ~prv sig_state s with Common.Error.Fatal _ -> - Core.Term.create_sym mp Core.Term.Public Core.Term.Defin Core.Term.Sequen - false (Common.Pos.make pos name) None Core.Term.mk_Type [] + let pos,mp = + match mp with + [] -> + let res_orig = DB.locate_name name in + let res = elim_duplicates_up_to_normalization res_orig in + if DB.ItemSet.cardinal res > 1 then + raise (Overloaded (name,res_orig)) ; + (match DB.ItemSet.choose_opt res with + | None -> Common.Error.fatal pos "Unknown symbol %s." name + | Some (((mp,_),sympos),[_,_,DB.Name]) -> sympos,mp + | Some _ -> assert false) (* locate only returns DB.Name*) + | _::_ -> None,mp + in + mk_bogus_sym mp name pos module QNameMap = Map.Make(struct type t = sym_name let compare = Stdlib.compare end) @@ -585,6 +611,8 @@ let normalize typ = with Not_found -> Core.Tree_type.empty_dtree in Core.Eval.snf ~dtree ~tags:[`NoExpand] [] typ +let _ = normalize_fun := normalize + let search_pterm ~generalize ~mok ss env pterm = let env = ("V#",(new_var "V#",Term.mk_Type,None))::env in From 6d0ed69e3f76a9e38576937b958c731595a1b672 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Fri, 11 Jul 2025 14:51:34 +0200 Subject: [PATCH 27/58] Bug fixed: after normalization in elim duplicates the wrong name was kept Example: Real was no longer found because it must become R and not Real --- src/tool/indexing.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 1b99c7809..58d291f19 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -545,7 +545,7 @@ let find_sym ~prt ~prv sig_state ({elt=(mp,name); pos} as s) = Core.Sig_state.find_sym ~prt ~prv sig_state s with Common.Error.Fatal _ -> - let pos,mp = + let pos,mp,name = match mp with [] -> let res_orig = DB.locate_name name in @@ -554,9 +554,9 @@ let find_sym ~prt ~prv sig_state ({elt=(mp,name); pos} as s) = raise (Overloaded (name,res_orig)) ; (match DB.ItemSet.choose_opt res with | None -> Common.Error.fatal pos "Unknown symbol %s." name - | Some (((mp,_),sympos),[_,_,DB.Name]) -> sympos,mp + | Some (((mp,name),sympos),[_,_,DB.Name]) -> sympos,mp,name | Some _ -> assert false) (* locate only returns DB.Name*) - | _::_ -> None,mp + | _::_ -> None,mp,name in mk_bogus_sym mp name pos From 8b593054bab2b762a27a73780da25c3b9d7fa0c6 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Fri, 11 Jul 2025 16:55:40 +0200 Subject: [PATCH 28/58] Multiple --require are now allowed In particular one can require (and open) theory_hol.lp and then require (and open) a notation.lp file to add infix notation. --- TODO.md | 5 +++++ src/cli/lambdapi.ml | 24 ++++++++++++++---------- src/tool/indexing.ml | 7 +++++-- src/tool/indexing.mli | 1 + 4 files changed, 25 insertions(+), 12 deletions(-) diff --git a/TODO.md b/TODO.md index 7c14b5935..c3b55cbe2 100644 --- a/TODO.md +++ b/TODO.md @@ -4,6 +4,9 @@ TODO Index and search ---------------- +* @abdelghani test if search in vscode still works once that + you have repaired lsp :-) + * @abdelghani include in HOL2DK_indexing git sub-repos of coq-hol-light-real-with-N and coq-hol-light and automatize the generation of the file to output Coq sources @@ -69,6 +72,8 @@ Performance improvements Documentation ------------- +* fix the doc: --require can now be repeated + * fix the doc: not only "anywhere" but also "type" can be paired only with ">="; maybe make it explicit that to match exactly the type of a constant one should use "spine =" diff --git a/src/cli/lambdapi.ml b/src/cli/lambdapi.ml index ab21f6021..e65061865 100644 --- a/src/cli/lambdapi.ml +++ b/src/cli/lambdapi.ml @@ -20,19 +20,22 @@ module CLT = Cmdliner.Term module LPSearchMain = struct -let sig_state_of_require = - function - None -> Core.Sig_state.dummy - | Some req -> - (* Search for a package from the current working directory. *) - Package.apply_config (Filename.concat (Sys.getcwd()) ".") ; - Core.Sig_state.of_sign - (Compile.compile (Parsing.Parser.path_of_string req)) +let sig_state_of_require l = + (* Search for a package from the current working directory. *) + Package.apply_config (Filename.concat (Sys.getcwd()) ".") ; + List.fold_left + (fun ss req -> + Handle.Command.handle Compile.compile ss + (Pos.none + (Parsing.Syntax.P_require + (true, [Pos.none (Parsing.Parser.path_of_string req)])))) + Core.Sig_state.dummy l let search_cmd cfg rules require s dbpath_opt = Config.init cfg; let run () = Tool.Indexing.load_rewriting_rules rules ; + Tool.Indexing.force_meta_rules_loading () ; let ss = sig_state_of_require require in let dbpath = Option.get Path.default_dbpath dbpath_opt in out Format.std_formatter "%a@." @@ -43,6 +46,7 @@ let websearch_cmd cfg rules port require header_file dbpath_opt path_in_url = Config.init cfg; let run () = Tool.Indexing.load_rewriting_rules rules ; + Tool.Indexing.force_meta_rules_loading () ; let ss = sig_state_of_require require in let header = match header_file with | None -> @@ -485,10 +489,10 @@ let rules_arg : string list CLT.t = multiple times to fetch rules from multiple files." in Arg.(value & opt_all string [] & info ["rules"] ~docv:"FILENAME" ~doc) -let require_arg : string option CLT.t = +let require_arg : string list CLT.t = let doc = "LP file to be required before starting the search engine." in - Arg.(value & opt (some string) None & info ["require"] ~docv:"PATH" ~doc) + Arg.(value & opt_all string [] & info ["require"] ~docv:"PATH" ~doc) let custom_dbpath : string option CLT.t = let doc = diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 58d291f19..c707a308a 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -605,6 +605,8 @@ let load_meta_rules () = let meta_rules = lazy (load_meta_rules ()) +let force_meta_rules_loading () = ignore (Lazy.force meta_rules) + let normalize typ = let dtree sym = try QNameMap.find (name_of_sym sym) (Lazy.force meta_rules) @@ -616,11 +618,12 @@ let _ = normalize_fun := normalize let search_pterm ~generalize ~mok ss env pterm = let env = ("V#",(new_var "V#",Term.mk_Type,None))::env in + Dream.log "QUERY before scoping: %a@." Parsing.Pretty.term pterm ; let query = Parsing.Scope.scope_search_pattern ~find_sym ~mok ss env pterm in - Dream.log "QUERY before: %a" Core.Print.term query ; + Dream.log "QUERY before normalize: %a" Core.Print.term query ; let query = normalize query in - Dream.log "QUERY after: %a" Core.Print.term query ; + Dream.log "QUERY to be executed: %a" Core.Print.term query ; DB.search ~generalize query let rec is_flexible t = diff --git a/src/tool/indexing.mli b/src/tool/indexing.mli index 0f83152b6..b927ac01d 100644 --- a/src/tool/indexing.mli +++ b/src/tool/indexing.mli @@ -3,6 +3,7 @@ open Core (* indexing *) val empty : unit -> unit val load_rewriting_rules: string list -> unit +val force_meta_rules_loading: unit -> unit val index_sign : Sign.t -> unit val parse_source_map : string -> unit (* the name of the file *) val deindex_path : string -> unit From 7ff31c7bef81d647138c29f5ae74e17dda3d27aa Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Fri, 11 Jul 2025 17:31:48 +0200 Subject: [PATCH 29/58] Added support for /\ \/ ~ to the Rocq lexer --- TODO.md | 2 ++ src/parsing/rocqLexer.ml | 5 +++++ 2 files changed, 7 insertions(+) diff --git a/TODO.md b/TODO.md index c3b55cbe2..a8ff05d16 100644 --- a/TODO.md +++ b/TODO.md @@ -72,6 +72,8 @@ Performance improvements Documentation ------------- +* document the Coq syntax: ~ /\ \/ -> forall exists = + * fix the doc: --require can now be repeated * fix the doc: not only "anywhere" but also "type" can be paired diff --git a/src/parsing/rocqLexer.ml b/src/parsing/rocqLexer.ml index 6f0b2537e..4c9396da7 100644 --- a/src/parsing/rocqLexer.ml +++ b/src/parsing/rocqLexer.ml @@ -172,6 +172,11 @@ let rec token lb = | '|' -> VBAR | '_' -> UNDERSCORE + (* rocq identifiers *) + | "\\/" -> UID("∨") + | "/\\" -> UID("∧") + | "~" -> UID("¬") + (* identifiers *) | regid -> UID(Utf8.lexeme lb) | escid -> UID(remove_useless_escape(Utf8.lexeme lb)) From 1f7259eb653534d74466ca97692206669408057b Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Fri, 11 Jul 2025 17:38:27 +0200 Subject: [PATCH 30/58] .. --- TODO.md | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/TODO.md b/TODO.md index a8ff05d16..b581701e2 100644 --- a/TODO.md +++ b/TODO.md @@ -25,8 +25,6 @@ Index and search generated webpage an HTML snippet (e.g. with examples or additional infos for that instance) -* add notations for Coq stdlib to websearch (using Pratter?) - * syntactic sugar for regular expressions / way to write a regular expression - only query efficiently (concl = _ | "regexpr") @@ -41,7 +39,14 @@ Index and search Think about ----------- -* alignments with same name ==> automatic preference? +* what notations for Coq should websearch know about; + right now they are in: + - notation.lp file + problem: if you want to add a lot of them, you need to + require the definitions first (without requiring all the + library...) + - hard-coded lexing tokens in rocqLexer, e.g. /\ mapped to + the corresponding Unicode character * would it be more reasonable to save the normalization rules when the index is created and apply them as default when searching, @@ -72,7 +77,7 @@ Performance improvements Documentation ------------- -* document the Coq syntax: ~ /\ \/ -> forall exists = +* document the Coq syntax: ~ /\ \/ -> = forall exists fun * fix the doc: --require can now be repeated @@ -83,8 +88,6 @@ Documentation * document new features, e.g. -sources (and find better terminology), deindex -* document Coq syntax in websearch - * document require ... as Foo: using Foo.X in the query already works (pure magic!); of course it does not work when using regular expressions [ check before! ] From 9c8d0031c9b1adba5bc443b2a427c33ceb6dfcdf Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Wed, 16 Jul 2025 16:27:33 +0200 Subject: [PATCH 31/58] New pratter API --- src/parsing/pratt.ml | 47 ++++++++++++++++++++------------------------ 1 file changed, 21 insertions(+), 26 deletions(-) diff --git a/src/parsing/pratt.ml b/src/parsing/pratt.ml index 2091a7397..04383f891 100644 --- a/src/parsing/pratt.ml +++ b/src/parsing/pratt.ml @@ -21,27 +21,26 @@ end = struct open Lplib open Pos - let is_op : Sig_state.find_sym -> Sig_state.t -> Env.t -> p_term - -> (Pratter.fixity * float) option = - fun find_sym ss env t -> + let ops (find_sym: Sig_state.find_sym) (ss: Sig_state.t) (env: Env.t) + (t: p_term) : (Pratter.fixity * float * p_term) list = match t.elt with | P_Iden({elt=(mp, s); _} as id, false) -> - let open Option.Monad in - let* sym = + let sym = try (* Look if [id] is in [env]... *) if mp <> [] then raise Not_found; - ignore (Env.find s env); None + ignore (Env.find s env); [] with Not_found -> (* ... or look into the signature *) - Some(find_sym ~prt:true ~prv:true ss id) + [find_sym ~prt:true ~prv:true ss id] in - (match Timed.(!(sym.sym_nota)) with - | Term.Infix(assoc, prio) -> Some(Pratter.Infix assoc, prio) - | Term.Prefix(prio) | Succ(Prefix(prio)) -> - Some(Pratter.Prefix, prio) - | Term.Postfix(prio) | Succ(Postfix(prio)) -> - Some(Pratter.Postfix, prio) - | _ -> None) - | _ -> None + List.concat_map (fun (sym: Term.sym) -> + match Timed.(!(sym.sym_nota)) with + | Term.Infix(assoc, prio) -> [Pratter.Infix assoc, prio, t] + | Term.Prefix(prio) | Succ(Prefix(prio)) -> + [Pratter.Prefix, prio, t] + | Term.Postfix(prio) | Succ(Postfix(prio)) -> + [Pratter.Postfix, prio, t] + | _ -> []) sym + | _ -> [] let appl : p_term -> p_term -> p_term = fun t u -> Pos.make (Pos.cat t.pos u.pos) (P_Appl(t, u)) @@ -54,18 +53,14 @@ end = struct Sig_state.t -> Env.t -> p_term -> p_term = fun ?(find_sym=Sig_state.find_sym) st env t -> let h, args = Syntax.p_get_args t in - let strm = Stream.of_list (h :: args) in - let is_op = is_op find_sym st env in - match Pratter.expression ~is_op ~appl strm with + let ops = ops find_sym st env in + let p = Pratter.expression ~ops ~appl ~token:Fun.id in + match Pratter.run p (List.to_seq (h :: args)) with | Ok e -> e - | Error `TooFewArguments -> + | Error `Too_few_arguments -> Error.fatal t.pos "Malformed application in \"%a\"" Pretty.term t - | Error `OpConflict (t, u) -> - Error.fatal t.pos "Operator conflict between \"%a\" and \"%a\"" - Pretty.term t Pretty.term u - | Error `UnexpectedInfix t -> - Error.fatal t.pos "Unexpected infix operator \"%a\"" Pretty.term t - | Error `UnexpectedPostfix t -> - Error.fatal t.pos "Unexpected postfix operator \"%a\"" Pretty.term t + | Error `Op_conflict (t) -> + Error.fatal t.pos "Operator conflict on \"%a\"" + Pretty.term t end include Pratt From f1d288638e82a75063e5e242f8eff1b028a87828 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Thu, 17 Jul 2025 10:38:21 +0200 Subject: [PATCH 32/58] fix sig_state_of_require: the ghost signature needs to be open --- src/cli/lambdapi.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cli/lambdapi.ml b/src/cli/lambdapi.ml index a76623194..0815a56c6 100644 --- a/src/cli/lambdapi.ml +++ b/src/cli/lambdapi.ml @@ -29,7 +29,7 @@ let sig_state_of_require l = (Pos.none (Parsing.Syntax.P_require (Some false, [Pos.none (Parsing.Parser.path_of_string req)])))) - Core.Sig_state.dummy l + (Sig_state.open_sign Core.Sig_state.dummy Sign.Ghost.sign) l let search_cmd cfg rules require s dbpath_opt = Config.init cfg; From e19588d067a2038ccdcfb15e0b7ea567a3f4efcc Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Thu, 17 Jul 2025 15:46:50 +0200 Subject: [PATCH 33/58] Reverted commit that was due to Sig_state.dummy not respecting the invariants --- src/cli/lambdapi.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cli/lambdapi.ml b/src/cli/lambdapi.ml index 48008f93b..803120631 100644 --- a/src/cli/lambdapi.ml +++ b/src/cli/lambdapi.ml @@ -29,7 +29,7 @@ let sig_state_of_require l = (Pos.none (Parsing.Syntax.P_require (Some false, [Pos.none (Parsing.Parser.path_of_string req)])))) - (Sig_state.open_sign Core.Sig_state.dummy Sign.Ghost.sign) l + Core.Sig_state.dummy l let search_cmd cfg rules require s dbpath_opt = Config.init cfg; From 3ebc4cff3e007c07976954754fdc13815ed0e2e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Thu, 17 Jul 2025 17:15:34 +0200 Subject: [PATCH 34/58] fix comments (lambdapi -> rocq) --- src/parsing/rocqLexer.ml | 2 +- src/parsing/rocqParser.mly | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parsing/rocqLexer.ml b/src/parsing/rocqLexer.ml index 4c9396da7..3040e0c8c 100644 --- a/src/parsing/rocqLexer.ml +++ b/src/parsing/rocqLexer.ml @@ -1,4 +1,4 @@ -(** Lexer for Lambdapi syntax, using Sedlex, a Utf8 lexer generator. *) +(** Lexer for Rocq syntax, using Sedlex, a Utf8 lexer generator. *) open Lplib open Sedlexing diff --git a/src/parsing/rocqParser.mly b/src/parsing/rocqParser.mly index 4b0524ad7..d783487c3 100644 --- a/src/parsing/rocqParser.mly +++ b/src/parsing/rocqParser.mly @@ -1,4 +1,4 @@ -(** Lambdapi parser, using the parser generator Menhir. *) +(** Rocq parser, using the parser generator Menhir. *) %{ open Lplib From 9a0de11d2980b813c4fe08bbc91b2b65eabb0a25 Mon Sep 17 00:00:00 2001 From: Abdelghani Alidra Date: Thu, 28 Aug 2025 12:38:36 +0200 Subject: [PATCH 35/58] document deindex --- CHANGES.md | 5 +++++ doc/options.rst | 9 +++++++++ 2 files changed, 14 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 7e7cf7f28..445c4c878 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -5,6 +5,11 @@ and this project adheres to [Semantic Versioning](https://semver.org/). ## Unreleased +### Added + +- CLI command `deindex` to remove constants from the index. + + ### Changed - `simplify` now fails if the goal cannot be simplified. diff --git a/doc/options.rst b/doc/options.rst index bab6c2c89..c367d0daf 100644 --- a/doc/options.rst +++ b/doc/options.rst @@ -11,6 +11,7 @@ The available commands are: * ``check``: check the correctness of input files. * ``decision-tree``: output the decision tree of a symbol as a Dot graph (see :doc:`dtrees`) +* ``deindex``: remove constants from the search index given a prefix path * ``export``: translate the input file to other formats. * ``help``: display the main help message. * ``index``: create an index of symbols and rules of input files. @@ -88,6 +89,14 @@ decision-tree * ``--ghost`` print the decision tree of a ghost symbol. Ghost symbols are symbols used internally that cannot be used in the concrete syntax. +deindex +------- + +* ``--path`` : indicates the suffix of the paths of the symbols to be removed from the index. + The path must be dot (`.`) separated. + For insrance, if symbol `tests.OK.natural.N` is indexed, `lambdapi deindex --path tests.OK.natural` + will remove it (together with all the symbols whose path starts with `tests.OK.natural.N`) from the index. + export ------ From 2c5480c495a631f7ca2fcb79e9538d9bf982493f Mon Sep 17 00:00:00 2001 From: Abdelghani Alidra Date: Thu, 28 Aug 2025 12:58:55 +0200 Subject: [PATCH 36/58] documented current dev indexing --- CHANGES.md | 1 + doc/queries.rst | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index 445c4c878..f374b9d3a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -8,6 +8,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/). ### Added - CLI command `deindex` to remove constants from the index. +- Indexing of symbols from current development (as well as currently required files) and their deindexing when files are closed are now automatically supported. ### Changed diff --git a/doc/queries.rst b/doc/queries.rst index ad537c618..682677cbc 100644 --- a/doc/queries.rst +++ b/doc/queries.rst @@ -111,7 +111,7 @@ beginning, the timeout is set to 2s. ------------------ Runs a query between double quotes against the index file -``~/.LPSearch.db``. See :doc:`query_language` for the query language +``~/.LPSearch.db`` updated with current development and required files. See :doc:`query_language` for the query language specification. :: From 43a4ef12ff58bcb7a9b2f3209c209f3457225df1 Mon Sep 17 00:00:00 2001 From: Abdelghani Alidra Date: Thu, 28 Aug 2025 13:10:12 +0200 Subject: [PATCH 37/58] update doc of deindex --- doc/options.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/options.rst b/doc/options.rst index c367d0daf..2a93786b9 100644 --- a/doc/options.rst +++ b/doc/options.rst @@ -93,7 +93,7 @@ deindex ------- * ``--path`` : indicates the suffix of the paths of the symbols to be removed from the index. - The path must be dot (`.`) separated. + The path must be dot (`.`) and is not checked for well formness (i.e. A.B matches A.BC). For insrance, if symbol `tests.OK.natural.N` is indexed, `lambdapi deindex --path tests.OK.natural` will remove it (together with all the symbols whose path starts with `tests.OK.natural.N`) from the index. From 0f9cf9f8889c0389be4bd5bab8657b7898d74953 Mon Sep 17 00:00:00 2001 From: Abdelghani Alidra Date: Fri, 29 Aug 2025 09:52:14 +0200 Subject: [PATCH 38/58] document filtering with regexp --- CHANGES.md | 2 +- doc/query_language.rst | 8 ++++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index f374b9d3a..873f6df5a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -9,7 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/). - CLI command `deindex` to remove constants from the index. - Indexing of symbols from current development (as well as currently required files) and their deindexing when files are closed are now automatically supported. - +- Added filtering of search results using regular expressions. ### Changed diff --git a/doc/query_language.rst b/doc/query_language.rst index 1016f8e5b..b30625145 100644 --- a/doc/query_language.rst +++ b/doc/query_language.rst @@ -7,7 +7,7 @@ Queries can be expressed according to the following syntax: Q ::= B | Q,Q | Q;Q | Q|PATH B ::= WHERE HOW GENERALIZE? PATTERN - PATH ::= << string >> + PATH ::= << string >> | "<< RegExp>>" WHERE ::= name | anywhere | rule | lhs | rhs | type | concl | hyp | spine HOW ::= > | = | >= | ≥ GENERALIZE ::= generalize @@ -22,7 +22,7 @@ where The semantics of the query language is the following: -* a query ``Q`` is either a base query ``B``, the conjunction ``Q1,Q2`` of two queries ``Q1`` and ``Q2``, their disjunction ``Q1;Q2`` or the query ``Q|PATH`` that behaves as ``Q``, but only keeps the results whose path is a suffix of ``PATH`` (that must be a valid path prefix) +* a query ``Q`` is either a base query ``B``, the conjunction ``Q1,Q2`` of two queries ``Q1`` and ``Q2``, their disjunction ``Q1;Q2`` or the query ``Q|PATH`` that behaves as ``Q``, but only keeps the results whose path is a suffix of ``PATH`` (that must be a valid path prefix) or matches the regular expression between double quotes (``""``) * a base query ``name = ID`` looks for symbols with name ``ID`` in the library. The identifier ``ID`` must not be qualified. * a base query ``WHERE HOW GENERALIZE? PATTERN`` looks in the library for occurrences of the pattern ``PATTERN`` **up to normalization rules** and, if ``generalize`` is specified, also **up to generalization** of the pattern. The normalization rules are library specific and are employed during indexing. They can be used, for example, to remove the clutter associated to encodings, to align concepts by mapping symbols to cross-library standard ones, or to standardize the shape of statements to improve recall (e.g. replacing occurrence of ``x > y`` with ``y < x``). @@ -53,5 +53,9 @@ Examples: in a module whose path is a suffix of ``math.arithmetics``. The query can return ``plus_O : ∀x: nat. plus x O = x`` where ``plus_O`` has fully qualified name ``math.arithmetics.addition.plus`` + * ``concl > plus | "*.arithmetics"`` + searches for theorems having an hypothesis containing ``plus`` and located + in a module whose path matches ``*.arithmetics``. The query + can return ``math.arithmetics.addition.plus`` and ``mathematics.arithmetics.addition.plus`` * ``name = nat ; name = NAT`` searches for symbols named either ``nat`` or ``NAT`` From 14d88974f8d031403181813e0e7a7df6e02228e5 Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Mon, 1 Sep 2025 13:21:55 +0200 Subject: [PATCH 39/58] document Rocq support --- CHANGES.md | 1 + doc/options.rst | 3 +++ doc/query_language.rst | 6 +++--- src/cli/lambdapi.ml | 8 +++----- 4 files changed, 10 insertions(+), 8 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 873f6df5a..804d71023 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -10,6 +10,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/). - CLI command `deindex` to remove constants from the index. - Indexing of symbols from current development (as well as currently required files) and their deindexing when files are closed are now automatically supported. - Added filtering of search results using regular expressions. +- Added support for basic Rocq syntax for writing search queries (fun, forall, exists, /\ and ~) ### Changed diff --git a/doc/options.rst b/doc/options.rst index 2a93786b9..f0eb34395 100644 --- a/doc/options.rst +++ b/doc/options.rst @@ -183,6 +183,9 @@ index * ``--db `` tells lambdapi to index symbols and rules in ```` instead of ``~/.LPSearch.db``. +* ``--source`` indicates the path to the file containing the mapping to additional sources (for instance, Rocq sources corresponding to indexed ones). + These sources will also be displayed by the websearch engine when showing the results. + install/uninstall ----------------- diff --git a/doc/query_language.rst b/doc/query_language.rst index b30625145..537916db1 100644 --- a/doc/query_language.rst +++ b/doc/query_language.rst @@ -11,7 +11,7 @@ Queries can be expressed according to the following syntax: WHERE ::= name | anywhere | rule | lhs | rhs | type | concl | hyp | spine HOW ::= > | = | >= | ≥ GENERALIZE ::= generalize - PATTERN ::= << term possibly containing placeholders _ (for terms) and V# (for variable occurrences >> + PATTERN ::= << term possibly containing placeholders _ (for terms) and V# (for variable occurrences) >> where @@ -19,6 +19,8 @@ where * parentheses can be used as usual to force a different precedence order * ``anywhere`` can be paired only with ``>=`` and ``name`` can be paired only with ``>=`` and no ``generalize`` * a pattern should be wrapped in parentheses, unless it is atomic (e.g. an identifier or a placeholder) +* a pattern is expressed using the Lambdapi terms syntax. Additionaly, the search engine allows the use of a basic Rocq syntax to express terms. + Specifically, ``fun``, ``forall``, ``exists``, ``/\`` and ``~`` are supported to express terms inside the pattern. The semantics of the query language is the following: @@ -42,8 +44,6 @@ The semantics of the query language is the following: * ``=`` the pattern must match the whole position * ``>`` the pattern must match a strict subterm of the position -Note that for commodity, ``forall`` and ``->`` can be used inside the query instead of the Unicode characters ``Π`` and ``→`` respectively. - Examples: * ``hyp = (nat → bool) , hyp >= (list nat)`` diff --git a/src/cli/lambdapi.ml b/src/cli/lambdapi.ml index 803120631..c89feea33 100644 --- a/src/cli/lambdapi.ml +++ b/src/cli/lambdapi.ml @@ -67,11 +67,9 @@ let websearch_cmd cfg rules port require header_file dbpath_opt path_in_url = query language specification to learn about the query language.
    The query language also uses the - Lambdapi terms syntax.
    with the possibility to use, - for commodity, - \"forall\" and \"->\" instead of \"Π\" and \"→\" respectively - (results are displayed with the Unicode symbols - \"Π\" and \"→\" though). + Lambdapi terms syntax.
    + while supporting a subset of the Rocq syntax (specificaly, + terms using fun, forall, exists, /\ and ~ are allowed) In particular, the following constructors can come handy for writing queries:

    From 2b88b50f8df48811591c22dd59464543c8859ad0 Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Mon, 1 Sep 2025 13:51:53 +0200 Subject: [PATCH 40/58] document multiple --require flag and disambiguating overloaded symbols --- CHANGES.md | 6 +++++- doc/options.rst | 4 ++-- src/cli/lambdapi.ml | 2 +- 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 804d71023..77b005896 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -10,7 +10,11 @@ and this project adheres to [Semantic Versioning](https://semver.org/). - CLI command `deindex` to remove constants from the index. - Indexing of symbols from current development (as well as currently required files) and their deindexing when files are closed are now automatically supported. - Added filtering of search results using regular expressions. -- Added support for basic Rocq syntax for writing search queries (fun, forall, exists, /\ and ~) +- Added support for basic Rocq syntax for writing search queries (fun, forall, exists, /\ and ~). +- Allow the `--require` flag to be used multiple times with the `search` and `websearch` commands. +- Ambiguity due to overloaded symbols is now solved by normalisation. + + ### Changed diff --git a/doc/options.rst b/doc/options.rst index f0eb34395..4d8459a7e 100644 --- a/doc/options.rst +++ b/doc/options.rst @@ -45,7 +45,7 @@ The ``index`` command generates the file ``~/.LPSearch.db`` if ``$HOME`` is defi **Remark on search:** -The command ``search`` takes as argument a query and runs it against the index file ``~/.LPSearch.db``. It is also possible to normalize terms in the query wrt some rules by using ``--rules`` options. It is advised to use the same set of rules previously used during indexing. It is also possible to pass via ``--require`` a file to be required and opened before performing the query, e.g. to specify implicit arguments for symbols. See :doc:`query_language` for the specification of the query language. +The command ``search`` takes as argument a query and runs it against the index file ``~/.LPSearch.db``. It is also possible to normalize terms in the query wrt some rules by using ``--rules`` options. It is advised to use the same set of rules previously used during indexing. It is also possible to pass via ``--require`` files to be required and opened before performing the query, e.g. to specify implicit arguments for symbols. See :doc:`query_language` for the specification of the query language. **Common flags:** @@ -203,7 +203,7 @@ search * ``--rules `` tells lambdapi to normalize terms in the query using the rules given in the file ````. Several files can be specified by using several ``--rules`` options. In these files, symbols must be fully qualified but no ``require`` command is needed. Moreover, the rules do not need to preserve typing. On the other hand, right hand-side of rules must contain implicit arguments. It is advised to use the same set of rules previously used during indexing. -* ``--require `` requires and open ```` when starting the search engine. The file can be used for example to specify implicit arguments for symbols used in the queries. +* ``--require `` requires and opens ```` when starting the search engine. The files can be used for example to specify implicit arguments for symbols used in the queries. * ``--db `` tells lambdapi to search in ```` instead of ``~/.LPSearch.db``. diff --git a/src/cli/lambdapi.ml b/src/cli/lambdapi.ml index c89feea33..829fdafcf 100644 --- a/src/cli/lambdapi.ml +++ b/src/cli/lambdapi.ml @@ -489,7 +489,7 @@ let rules_arg : string list CLT.t = let require_arg : string list CLT.t = let doc = - "LP file to be required before starting the search engine." in + "LP files to be required before starting the search engine." in Arg.(value & opt_all string [] & info ["require"] ~docv:"PATH" ~doc) let custom_dbpath : string option CLT.t = From d868fb4a560de9468248c2bee97de0d6ca9e63e8 Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Mon, 1 Sep 2025 14:36:04 +0200 Subject: [PATCH 41/58] update CHANGES.md with search improvements --- CHANGES.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 77b005896..7b55d257f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -13,6 +13,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/). - Added support for basic Rocq syntax for writing search queries (fun, forall, exists, /\ and ~). - Allow the `--require` flag to be used multiple times with the `search` and `websearch` commands. - Ambiguity due to overloaded symbols is now solved by normalisation. +- Added streaming of results in command line search. +- Supporting `Plac` in rewriting rules. +- Fixed Stack_overflow exception due large number of search results. From 74712037ad3df1d6a349387ce25b96cac606c276 Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Thu, 16 Oct 2025 19:00:11 +0200 Subject: [PATCH 42/58] use Lplib.Color instead of hand made coloring in indexing --- src/cli/lambdapi.ml | 2 +- src/lplib/color.ml | 2 ++ src/tool/indexing.ml | 62 +++++++++++++++++++++++++------------------- 3 files changed, 38 insertions(+), 28 deletions(-) diff --git a/src/cli/lambdapi.ml b/src/cli/lambdapi.ml index 829fdafcf..0e8aae406 100644 --- a/src/cli/lambdapi.ml +++ b/src/cli/lambdapi.ml @@ -67,7 +67,7 @@ let websearch_cmd cfg rules port require header_file dbpath_opt path_in_url = query language specification to learn about the query language.
    The query language also uses the - Lambdapi terms syntax.
    + Lambdapi terms syntax.
    while supporting a subset of the Rocq syntax (specificaly, terms using fun, forall, exists, /\ and ~ are allowed) In particular, the following constructors can come handy for diff --git a/src/lplib/color.ml b/src/lplib/color.ml index 4d316926a..d4068d221 100644 --- a/src/lplib/color.ml +++ b/src/lplib/color.ml @@ -75,6 +75,8 @@ let blu fmt = colorize Blu fmt let mag fmt = colorize Mag fmt let cya fmt = colorize Cya fmt +let default (fmt:('a, 'b, 'c, 'd, 'e, 'f) format6) = fmt + (** [g_or_r cond fmt] colors the format [fmt] in green if [cond] is [true] and in red otherwise. *) let g_or_r cond = if cond then gre else red diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 5603e41f9..54dc822ac 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -463,47 +463,55 @@ module DB = struct let generic_pp_of_item_list ~escape ~escaper ~separator ~sep ~delimiters ~lis:(lisb,lise) ~pres:(preb,pree) - ~bold:(boldb,bolde) ~code:(codeb,codee) fmt l - = + ~bold:(boldb,bolde) ~code:(codeb,codee) ?(colorizer=Lplib.Color.default) + fmt l = if l = [] then Lplib.Base.out fmt "Nothing found" else - Lplib.List.pp - (fun ppf (((p,n) as sym_name,pos),(positions : answer)) -> - let sourceid,sourcepos = source_infos_of_sym_name sym_name in - Lplib.Base.out ppf "%s%a.%s%s%s@%s%s%a%s%s%s%a%s%a%s%a%s%s%s%s@." - lisb (escaper.run Core.Print.path) p boldb n bolde - (popt_to_string ~print_dirname:false pos) - separator (generic_pp_of_position_list ~escaper ~sep) positions - separator preb codeb - (Common.Pos.print_file_contents ~parse_file ~escape ~delimiters - ~complain_if_location_unknown:true) pos - separator - (fun ppf opt -> - match opt with - | None -> Lplib.Base.string ppf "" - | Some sourceid -> - Lplib.Base.string ppf ("Translated to " ^ sourceid)) sourceid - separator - (Common.Pos.print_file_contents ~parse_file ~escape ~delimiters - ~complain_if_location_unknown:false) sourcepos - codee pree lise separator) + Lplib.List.pp (fun ppf (((p,n) as sym_name,pos),(positions : answer)) -> + let sourceid,sourcepos = source_infos_of_sym_name sym_name in + (* let n_pp = (Lplib.Color.red "%s") n in *) + Lplib.Base.out ppf + ("%s%a.%s" + ^^ + (colorizer "%s") + ^^ "%s@%s%s%a%s%s%s%a%s%a%s%a%s%s%s%s@.") + lisb (escaper.run Core.Print.path) p boldb n bolde + (popt_to_string ~print_dirname:false pos) + separator (generic_pp_of_position_list ~escaper ~sep) positions + separator preb codeb + (Common.Pos.print_file_contents ~parse_file ~escape ~delimiters + ~complain_if_location_unknown:true) pos + separator + (fun ppf opt -> + match opt with + | None -> Lplib.Base.string ppf "" + | Some sourceid -> + Lplib.Base.string ppf ("Translated to " ^ sourceid)) sourceid + separator + (Common.Pos.print_file_contents ~parse_file ~escape ~delimiters + ~complain_if_location_unknown:false) sourcepos + codee pree lise separator) "" fmt l let html_of_item_list = generic_pp_of_item_list ~escape:Dream.html_escape ~escaper:html_escaper ~separator:"
    \n" ~sep:" and
    \n" ~delimiters:("

    ","

    ") ~lis:("
  • ","
    • ") ~pres:("
    ","
    ") ~bold:("","") - ~code:("","") + ~code:("","") ~colorizer: Lplib.Color.default let pp_item_list fmt l = generic_pp_of_item_list ~escape:(fun x -> x) ~escaper:identity_escaper ~separator:"\n" ~sep:" and\n" ~delimiters:("","") ~lis:("* ","") ~pres:("","") - ~bold:(if Stdlib.(!Common.Mode.lsp_mod) || Unix.isatty Unix.stdout then - ("","") - else ("","")) - ~code:("","") fmt l + ~bold:("","") + ~code:("","") + ~colorizer: + (if Stdlib.(!Common.Mode.lsp_mod) || Unix.isatty Unix.stdout then + Lplib.Color.red + else + Lplib.Color.default) + fmt l let pp_results_list fmt l = pp_item_list fmt l From 107d6900e0fcf55f393a54d85769a70515a8a7fb Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Thu, 6 Nov 2025 16:18:31 +0100 Subject: [PATCH 43/58] fix color of error messages: specifically Overloaded symbol prod. Please rewrite the query replacing... --- src/cli/config.ml | 2 +- src/cli/lambdapi.ml | 2 +- src/common/error.ml | 27 +++++++++++++++------------ src/handle/command.ml | 6 +++--- src/handle/tactic.ml | 6 +++--- src/lsp/lp_doc.ml | 2 +- src/lsp/lp_lsp.ml | 2 +- src/pure/pure.ml | 12 ++++++------ src/tool/indexing.ml | 19 ++++++++++--------- 9 files changed, 41 insertions(+), 37 deletions(-) diff --git a/src/cli/config.ml b/src/cli/config.ml index 14240aaab..788e15709 100644 --- a/src/cli/config.ml +++ b/src/cli/config.ml @@ -109,7 +109,7 @@ let map_dir : (Path.t * string) list CLT.t = let path : Path.t Arg.conv = let parse (s: string) : (Path.t, [>`Msg of string]) result = try Ok(Parser.path_of_string s) - with Error.Fatal(_,s) -> Error(`Msg(s)) + with Error.Fatal(_,s, _) -> Error(`Msg(s)) in let print fmt p = Path.pp fmt p in Arg.conv (parse, print) diff --git a/src/cli/lambdapi.ml b/src/cli/lambdapi.ml index 0e8aae406..9382dfd23 100644 --- a/src/cli/lambdapi.ml +++ b/src/cli/lambdapi.ml @@ -288,7 +288,7 @@ let qident : qident CLT.t = let qident : qident Arg.conv = let parse (s: string): (qident, [>`Msg of string]) result = try Ok(Parser.qident_of_string s) - with Fatal(_,s) -> Error(`Msg(s)) + with Fatal(_,s,_) -> Error(`Msg(s)) in let print fmt qid = Pretty.qident fmt (Pos.none qid) in Arg.conv (parse, print) diff --git a/src/common/error.ml b/src/common/error.ml index 40cad8fe5..4073aae52 100644 --- a/src/common/error.ml +++ b/src/common/error.ml @@ -37,7 +37,7 @@ let no_wrn : ('a -> 'b) -> 'a -> 'b = fun f x -> cases where positions are expected [Some None] may be used to indicate the abscence of a position. This may happen when terms are generated (e.g., by a form of desugaring). *) -exception Fatal of Pos.popt option * string +exception Fatal of Pos.popt option * string * string (** [fatal_str fmt] may be called an arbitrary number of times to build up the error message of the [fatal] or [fatal_no_pos] functions prior to calling @@ -46,16 +46,19 @@ exception Fatal of Pos.popt option * string let fatal_msg : 'a outfmt -> 'a = fun fmt -> out Format.str_formatter fmt -(** [fatal popt fmt] raises the [Fatal(popt,msg)] exception, in which [msg] is - built from the format [fmt] (provided the necessary arguments). *) +(** [fatal popt fmt] raises the [Fatal(popt,msg,more)] exception, in which [msg] is + built from the format [fmt] (provided the necessary arguments). + [more] continues the error message and is printed in normal format instead of + red color*) + let fatal : Pos.popt -> ('a,'b) koutfmt -> 'a = fun pos fmt -> - let cont _ = raise (Fatal(Some(pos), Format.flush_str_formatter ())) in + let cont _ = raise (Fatal(Some(pos), Format.flush_str_formatter (), "")) in Format.kfprintf cont Format.str_formatter fmt (** [fatal_no_pos fmt] is similar to [fatal _ fmt], but it is used to raise an error that has no precise attached source code position. *) -let fatal_no_pos : ('a,'b) koutfmt -> 'a = fun fmt -> - let cont _ = raise (Fatal(None, Format.flush_str_formatter ())) in +let fatal_no_pos : ?more:string -> ('a,'b) koutfmt -> 'a = fun ?(more="") fmt -> + let cont _ = raise (Fatal(None, Format.flush_str_formatter (), more)) in Format.kfprintf cont Format.str_formatter fmt (** [handle_exceptions f] runs [f ()] in an exception handler and handles both @@ -64,15 +67,15 @@ let fatal_no_pos : ('a,'b) koutfmt -> 'a = fun fmt -> [1] (indicating failure). Hence, [handle_exceptions] should only be called by the main program logic, not by the internals. *) let handle_exceptions : (unit -> unit) -> unit = fun f -> - let exit_with : type a b. (a,b) koutfmt -> a = fun fmt -> + let exit_with : type a b. string -> (a,b) koutfmt -> a = fun cnt fmt -> Color.update_with_color Format.err_formatter; - Format.kfprintf (fun _ -> exit 1) Format.err_formatter + Format.kfprintf (fun _ -> Color.update_with_color Format.err_formatter;(Format.kfprintf (fun _ -> exit 1) Format.err_formatter "%s" cnt)) Format.err_formatter (Color.red (fmt ^^ "@.")) in try f () with - | Fatal(None, msg) -> exit_with "%s" msg - | Fatal(Some(p), msg) -> exit_with "[%a] %s" Pos.pp p msg + | Fatal(None, msg, cnt) -> exit_with cnt "%s" msg + | Fatal(Some(p), msg, cnt) -> exit_with cnt "[%a] %s" Pos.pp p msg | e -> - exit_with "Uncaught [%s].\n%s" + exit_with "" "Uncaught [%s].\n%s" (Printexc.to_string e) - (Printexc.get_backtrace()) + (Printexc.get_backtrace()) \ No newline at end of file diff --git a/src/handle/command.ml b/src/handle/command.ml index c8cad76cc..8d48e2ef6 100644 --- a/src/handle/command.ml +++ b/src/handle/command.ml @@ -623,9 +623,9 @@ let get_proof_data : compiler -> sig_state -> p_command -> cmd_output = ss with | Timeout as e -> raise e - | Fatal(Some(Some(_)),_) as e -> raise e - | Fatal(None ,m) -> fatal pos "Error on command.@.%s" m - | Fatal(Some(None) ,m) -> fatal pos "Error on command.@.%s" m + | Fatal(Some(Some(_)),_, _) as e -> raise e + | Fatal(None ,m, _) -> fatal pos "Error on command.@.%s" m + | Fatal(Some(None) ,m, _) -> fatal pos "Error on command.@.%s" m | e -> fatal pos "Uncaught exception: %s." (Printexc.to_string e) diff --git a/src/handle/tactic.ml b/src/handle/tactic.ml index 55a4711c4..aae8319a1 100644 --- a/src/handle/tactic.ml +++ b/src/handle/tactic.ml @@ -665,12 +665,12 @@ let rec handle : | P_tac_try tactic -> begin try handle ss sym_pos prv ps tactic - with Fatal(_, _s) -> ps + with Fatal(_, _s, _) -> ps end | P_tac_orelse(t1,t2) -> begin try handle ss sym_pos prv ps t1 - with Fatal(_, _s) -> handle ss sym_pos prv ps t2 + with Fatal(_, _s, _) -> handle ss sym_pos prv ps t2 end | P_tac_repeat t -> begin @@ -679,7 +679,7 @@ let rec handle : let ps = handle ss sym_pos prv ps t in if List.length ps.proof_goals < nb_goals then ps else handle ss sym_pos prv ps tac - with Fatal(_, _s) -> ps + with Fatal(_, _s, _) -> ps end | P_tac_and(t1,t2) -> let ps = handle ss sym_pos prv ps t1 in diff --git a/src/lsp/lp_doc.ml b/src/lsp/lp_doc.ml index 2eecef981..d3390d418 100644 --- a/src/lsp/lp_doc.ml +++ b/src/lsp/lp_doc.ml @@ -131,7 +131,7 @@ let new_doc ~uri ~version ~text = assert(String.is_prefix "file://" uri); let path = String.sub uri 7 (String.length uri - 7) in Some(Pure.initial_state path), [] - with Error.Fatal(_pos, msg) -> + with Error.Fatal(_pos, msg, _) -> let loc : Pos.pos = { fname = Some(uri); diff --git a/src/lsp/lp_lsp.ml b/src/lsp/lp_lsp.ml index ec48b398e..28d5f83c3 100644 --- a/src/lsp/lp_lsp.ml +++ b/src/lsp/lp_lsp.ml @@ -58,7 +58,7 @@ let do_check_text ofmt ~doc = let doc, diags = try Lp_doc.check_text ~doc - with Common.Error.Fatal(_pos, msg) -> + with Common.Error.Fatal(_pos, msg, _) -> let loc : Pos.pos = { fname = Some(doc.uri); diff --git a/src/pure/pure.ml b/src/pure/pure.ml index 0b31e013e..e2b6dbaa3 100644 --- a/src/pure/pure.ml +++ b/src/pure/pure.ml @@ -73,9 +73,9 @@ let parse_text : Stream.iter (fun c -> Stdlib.(cmds := c :: !cmds)) (parse_string fname s); List.rev Stdlib.(!cmds), None with - | Fatal(Some(Some(pos)), msg) -> List.rev Stdlib.(!cmds), Some(pos, msg) - | Fatal(Some(None) , _ ) -> assert false - | Fatal(None , _ ) -> assert false + | Fatal(Some(Some(pos)), msg, _) -> List.rev Stdlib.(!cmds), Some(pos, msg) + | Fatal(Some(None) , _ , _) -> assert false + | Fatal(None , _ , _) -> assert false type proof_finalizer = Sig_state.t -> Proof.proof_state -> Sig_state.t @@ -170,7 +170,7 @@ let handle_command : state -> Command.t -> command_result = (t, ss, d.pdata_state, d.pdata_finalize, d.pdata_prv, d.pdata_sym_pos) in Cmd_Proof(ps, d.pdata_proof, d.pdata_sym_pos, d.pdata_end_pos) - with Fatal(Some p,m) -> + with Fatal(Some p,m, _) -> Cmd_Error(Some p, Pos.popt_to_string p ^ " " ^ m) let handle_tactic : proof_state -> Tactic.t -> int -> tactic_result = @@ -179,13 +179,13 @@ let handle_tactic : proof_state -> Tactic.t -> int -> tactic_result = let ps, qres = Handle.Tactic.handle ss sym_pos prv (ps, None) tac n in let qres = Option.map (fun f -> f ()) qres in Tac_OK((Time.save (), ss, ps, finalize, prv, sym_pos), qres) - with Fatal(Some p,m) -> + with Fatal(Some p,m, _) -> Tac_Error(Some p, Pos.popt_to_string p ^ " " ^ m) let end_proof : proof_state -> command_result = fun (_, ss, ps, finalize, _, _) -> try Cmd_OK((Time.save (), finalize ss ps), None) - with Fatal(Some p,m) -> + with Fatal(Some p,m, _) -> Cmd_Error(Some p, Pos.popt_to_string p ^ " " ^ m) let get_symbols : state -> Term.sym Extra.StrMap.t = diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 54dc822ac..1a3eb62d6 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -394,14 +394,14 @@ module DB = struct Sym_nameMap.add lpid (sourceid,fname,start_line,end_line) !sidx | _ -> raise - (Common.Error.Fatal(None,"wrong file format for source map file")) + (Common.Error.Fatal(None,"wrong file format for source map file", "")) done ; with | Failure _ as exn -> close_in ch; raise (Common.Error.Fatal(None,"wrong file format for source map file: " ^ - Printexc.to_string exn)) + Printexc.to_string exn, "")) | End_of_file -> close_in ch) ; db := lazy (!sidx,idx) @@ -762,7 +762,7 @@ let index_sym sym = (DB.ItemSet.bindings (DB.locate_name (snd qname))) then raise - (Common.Error.Fatal(None,string_of_sym_name qname ^ " already indexed")) ; + (Common.Error.Fatal(None,string_of_sym_name qname ^ " already indexed", "")) ; DB.insert_name (snd qname) ((qname,sym.sym_decl_pos),[Name]) ; (* Type + InType *) let typ = Timed.(!(sym.Core.Term.sym_type)) in @@ -882,7 +882,7 @@ module UserLevelQueries = struct let s = Str.global_replace (Str.regexp_string " -> ") " → " s in Str.global_replace (Str.regexp "\\bforall\\b") "Π" s - let search_cmd_gen ss ~from ~how_many ~fail ~pp_results + let search_cmd_gen ss ~from ~how_many ~(fail:(?more:string -> string -> string)) ~pp_results ~title_tag:(hb,he) fmt s = try let pstream = Parsing.Parser.Rocq.parse_search_query_string "LPSearch" s in @@ -899,13 +899,14 @@ module UserLevelQueries = struct | Stream.Failure -> Lplib.Base.out fmt "%s" (fail (Format.asprintf "Syntax error: a query was expected@.")) - | Common.Error.Fatal(_,msg) -> + | Common.Error.Fatal(_,msg, _) -> Lplib.Base.out fmt "%s" (fail (Format.asprintf "Error: %s@." msg)) | Overloaded(name,res) -> Lplib.Base.out fmt "%s" (fail (Format.asprintf "Overloaded symbol %s. Please rewrite the query replacing %s \ - with a fully qualified identifier among the following:@.%a@." - name name pp_results (ItemSet.bindings res))) + with a fully qualified identifier among the following:@." + name name) + ~more:(Format.asprintf "%a@." pp_results (ItemSet.bindings res))) | Stack_overflow -> Lplib.Base.out fmt "%s" (fail (Format.asprintf @@ -918,14 +919,14 @@ module UserLevelQueries = struct Stdlib.(the_dbpath := dbpath); Format.asprintf "%a" (search_cmd_gen ss ~from ~how_many - ~fail:(fun x -> "" ^ x ^ "") + ~fail:(fun ?more x -> "" ^ x ^ "" ^ (Option.value more ~default:"")) ~pp_results:(html_of_results_list from) ~title_tag:("

    ","

    ")) s let search_cmd_txt ss ~dbpath fmt s = let s = transform_ascii_to_unicode s in Stdlib.(the_dbpath := dbpath); search_cmd_gen ss ~from:0 ~how_many:999999 - ~fail:(fun x -> Common.Error.fatal_no_pos "%s" x) + ~fail:(fun ?more x -> Common.Error.fatal_no_pos ?more "%s" x) ~pp_results:pp_results_list ~title_tag:("","") fmt s end From 4a4896505eeb4a0fd5add1600825425abeb33061 Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Thu, 6 Nov 2025 19:42:27 +0100 Subject: [PATCH 44/58] read header of websearch page from file --- dune-project | 2 ++ src/cli/lambdapi.ml | 44 +++++---------------------------------- src/tool/description.html | 38 +++++++++++++++++++++++++++++++++ src/tool/dune | 13 +++++++++++- 4 files changed, 57 insertions(+), 40 deletions(-) create mode 100644 src/tool/description.html diff --git a/dune-project b/dune-project index 6e69ec795..24e32cc7b 100644 --- a/dune-project +++ b/dune-project @@ -9,6 +9,7 @@ (license CECILL-2.1) (using menhir 2.0) +(using dune_site 0.1) (package (name lambdapi) @@ -47,4 +48,5 @@ systems: Dedukti, Coq, HRS, CPF.") (lwt_ppx (>= 1)) (uri (>= 1.1)) ) + (sites (share server_resources)) ) diff --git a/src/cli/lambdapi.ml b/src/cli/lambdapi.ml index 9382dfd23..5c25ba612 100644 --- a/src/cli/lambdapi.ml +++ b/src/cli/lambdapi.ml @@ -50,45 +50,11 @@ let websearch_cmd cfg rules port require header_file dbpath_opt path_in_url = let ss = sig_state_of_require require in let header = match header_file with | None -> - " - -

    LambdaPi - Search Engine

    -
    -

    - The search button answers the query. Read the - query language specification to learn about the query language. -
    The query language also uses the - Lambdapi terms syntax.
    - while supporting a subset of the Rocq syntax (specificaly, - terms using fun, forall, exists, /\ and ~ are allowed) - In particular, the following constructors can come handy for - writing queries:
    -

    -
      -
    • an anonymous functionλ (x:A) y z,t - mapping x, y - and z (of type A for x) to t.
      • -
    • a dependent product - forall (x:A) y z,T -
      • -
    • a non-dependent product A -> T - (syntactic sugar for forall x:A,T when - x does not occur in T)
      • -
    -
    - " + let themes_locations : string list = Tool.Mysites.Sites.server_resources in + let file = match themes_locations with + | [] -> assert false + | x :: _ -> x in + Lplib.String.string_of_file (file ^ "/default/description.html") | Some file -> Lplib.String.string_of_file file in let dbpath = Option.get Path.default_dbpath dbpath_opt in let path_in_url = match path_in_url with diff --git a/src/tool/description.html b/src/tool/description.html new file mode 100644 index 000000000..ea4e7e04a --- /dev/null +++ b/src/tool/description.html @@ -0,0 +1,38 @@ + + +

    LambdaPi + Search Engine

    +
    +

    + The search button answers the query. Read the + query language specification to learn about the query language. +
    The query language also uses the + Lambdapi terms syntax.
    + while supporting a subset of the Rocq syntax (specificaly, + terms using fun, forall, exists, /\ and ~ are allowed) + In particular, the following constructors can come handy for + writing queries:
    +

    +
      +
    • an anonymous functionλ (x:A) y z,t + mapping x, y + and z (of type A for x) to t.
      • +
    • a dependent product + forall (x:A) y z,T +
      • +
    • a non-dependent product A -> T + (syntactic sugar for forall x:A,T when + x does not occur in T)
      • +
    +
    \ No newline at end of file diff --git a/src/tool/dune b/src/tool/dune index d3cc83495..ac46dc70a 100644 --- a/src/tool/dune +++ b/src/tool/dune @@ -2,10 +2,21 @@ (name tool) (public_name lambdapi.tool) (modules :standard) - (libraries lambdapi.parsing lambdapi.core dream unix) + (libraries lambdapi.parsing lambdapi.core dream unix dune-site) (preprocess (pps lwt_ppx))) (rule (targets websearch.ml) (deps websearch.eml.ml) (action (run dream_eml %{deps} --workspace %{workspace_root}))) + +(install + (section (site (lambdapi server_resources))) + (files + (description.html as default/description.html) + ) +) + +(generate_sites_module + (module mysites) + (sites lambdapi)) From f3f5a35a68d63d44bdceaff45b30077951178a28 Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Fri, 7 Nov 2025 09:12:18 +0100 Subject: [PATCH 45/58] move the default html header to ressources --- TODO.md | 12 ------------ {src/tool => ressources}/description.html | 0 ressources/dune | 23 +++++++++++++++++++++++ src/cli/dune | 2 +- src/cli/lambdapi.ml | 2 +- src/tool/dune | 13 +------------ 6 files changed, 26 insertions(+), 26 deletions(-) rename {src/tool => ressources}/description.html (100%) create mode 100644 ressources/dune diff --git a/TODO.md b/TODO.md index b581701e2..187cb0c9a 100644 --- a/TODO.md +++ b/TODO.md @@ -4,23 +4,11 @@ TODO Index and search ---------------- -* @abdelghani test if search in vscode still works once that - you have repaired lsp :-) - * @abdelghani include in HOL2DK_indexing git sub-repos of coq-hol-light-real-with-N and coq-hol-light and automatize the generation of the file to output Coq sources * @abdelghani - - use lplib/color.ml in place of our color management of the - output [ but do not lose our code to check if we are - in lsp_mode or targeting a tty ] - - "Overloaded symbol prod. Please rewrite the query replacing..." - is printed in red but the following lines are also in red - (i.e. black color is not restored) - -* @abdelghani - - commit the very nice new look&feel of websearch - (maybe?) allow an --add-examples=FNAME to include in the generated webpage an HTML snippet (e.g. with examples or additional infos for that instance) diff --git a/src/tool/description.html b/ressources/description.html similarity index 100% rename from src/tool/description.html rename to ressources/description.html diff --git a/ressources/dune b/ressources/dune new file mode 100644 index 000000000..2f4367a8e --- /dev/null +++ b/ressources/dune @@ -0,0 +1,23 @@ +(library + (name ressources) + ; (public_name lambdapi.tool) + (modules :standard) + (libraries lambdapi.parsing lambdapi.core dream unix dune-site) + (preprocess (pps lwt_ppx)) +) + +; (rule +; (targets websearch.ml) +; (deps websearch.eml.ml) +; (action (run dream_eml %{deps} --workspace %{workspace_root}))) + +(install + (section (site (lambdapi server_resources))) + (files + (description.html as default/description.html) + ) +) + +(generate_sites_module + (module mysites) + (sites lambdapi)) diff --git a/src/cli/dune b/src/cli/dune index 572d1a1e6..b6692f1c2 100644 --- a/src/cli/dune +++ b/src/cli/dune @@ -4,4 +4,4 @@ (modes byte native) (modules :standard) (libraries cmdliner lambdapi.lsp lambdapi.tool lambdapi.handle - lambdapi.export unix)) + lambdapi.export unix ressources)) diff --git a/src/cli/lambdapi.ml b/src/cli/lambdapi.ml index 5c25ba612..cb40228ef 100644 --- a/src/cli/lambdapi.ml +++ b/src/cli/lambdapi.ml @@ -50,7 +50,7 @@ let websearch_cmd cfg rules port require header_file dbpath_opt path_in_url = let ss = sig_state_of_require require in let header = match header_file with | None -> - let themes_locations : string list = Tool.Mysites.Sites.server_resources in + let themes_locations : string list = Ressources.Mysites.Sites.server_resources in let file = match themes_locations with | [] -> assert false | x :: _ -> x in diff --git a/src/tool/dune b/src/tool/dune index ac46dc70a..e94761262 100644 --- a/src/tool/dune +++ b/src/tool/dune @@ -8,15 +8,4 @@ (rule (targets websearch.ml) (deps websearch.eml.ml) - (action (run dream_eml %{deps} --workspace %{workspace_root}))) - -(install - (section (site (lambdapi server_resources))) - (files - (description.html as default/description.html) - ) -) - -(generate_sites_module - (module mysites) - (sites lambdapi)) + (action (run dream_eml %{deps} --workspace %{workspace_root}))) \ No newline at end of file From c331b1fe70708c658f82439c7bbd24dd51f895e4 Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Mon, 10 Nov 2025 11:23:51 +0100 Subject: [PATCH 46/58] update dependencies and description header --- dune-project | 1 + lambdapi.opam | 1 + ressources/description.html | 153 +++++++++++++++++++++++++++--------- 3 files changed, 118 insertions(+), 37 deletions(-) diff --git a/dune-project b/dune-project index 24e32cc7b..9f81fd377 100644 --- a/dune-project +++ b/dune-project @@ -47,6 +47,7 @@ systems: Dedukti, Coq, HRS, CPF.") (odoc :with-doc) (lwt_ppx (>= 1)) (uri (>= 1.1)) + (dune-site (>= 3.15)) ) (sites (share server_resources)) ) diff --git a/lambdapi.opam b/lambdapi.opam index 2e65966cd..c6af8dded 100644 --- a/lambdapi.opam +++ b/lambdapi.opam @@ -38,6 +38,7 @@ depends: [ "odoc" {with-doc} "lwt_ppx" {>= "1"} "uri" {>= "1.1"} + "dune-site" {>= "3.15"} ] build: [ ["dune" "subst"] {dev} diff --git a/ressources/description.html b/ressources/description.html index ea4e7e04a..f148cef5a 100644 --- a/ressources/description.html +++ b/ressources/description.html @@ -1,38 +1,117 @@ + - -

    LambdaPi - Search Engine

    -
    -

    - The search button answers the query. Read the - query language specification to learn about the query language. -
    The query language also uses the - Lambdapi terms syntax.
    - while supporting a subset of the Rocq syntax (specificaly, - terms using fun, forall, exists, /\ and ~ are allowed) - In particular, the following constructors can come handy for - writing queries:
    -

    -
      -
    • an anonymous functionλ (x:A) y z,t - mapping x, y - and z (of type A for x) to t.
      • -
    • a dependent product - forall (x:A) y z,T -
      • -
    • a non-dependent product A -> T - (syntactic sugar for forall x:A,T when - x does not occur in T)
      • -
    -
    \ No newline at end of file + + +
    + Something went wrong?Open an issue + Like this tool?Join the discussion +

    LambdaPi Search Engine

    +
    + +
    + + +

    + The search button answers the query. Read the + query language specification to learn about the query language. +
    The query language also uses the + Lambdapi terms syntax.
    + while supporting a subset of the Rocq syntax (specificaly, + terms using fun, forall, exists, /\ and ~ are allowed) + In particular, the following constructors can come handy for + writing queries:
    +

    +
      +
    • an anonymous functionλ (x:A) y z,t + mapping x, y + and z (of type A for x) to t.
      • +
    • a dependent product + forall (x:A) y z,T +
      • +
    • a non-dependent product A -> T + (syntactic sugar for forall x:A,T when + x does not occur in T)
      • +
    + +
    + + \ No newline at end of file From ccb5489cc88e0dcacf6dc25264e39e6a7802aa17 Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Thu, 27 Nov 2025 18:13:14 +0100 Subject: [PATCH 47/58] finalize git merging branch master into indexing_BO --- dune-project | 1 - ressources/dune | 3 ++- {src/cli => ressources}/lambdapi.ico | Bin src/pure/pure.ml | 12 ++++++------ src/tool/dune | 2 +- src/tool/indexing.ml | 4 +++- src/tool/lambdapi.ico | Bin 13707 -> 0 bytes src/tool/websearch.eml.ml | 2 +- 8 files changed, 13 insertions(+), 11 deletions(-) rename {src/cli => ressources}/lambdapi.ico (100%) delete mode 100644 src/tool/lambdapi.ico diff --git a/dune-project b/dune-project index f9be3bfd0..ea0e2d351 100644 --- a/dune-project +++ b/dune-project @@ -9,7 +9,6 @@ (license CECILL-2.1) (using menhir 2.0) -(using dune_site 0.1) (package (name lambdapi) diff --git a/ressources/dune b/ressources/dune index 2f4367a8e..3e6f6f399 100644 --- a/ressources/dune +++ b/ressources/dune @@ -1,6 +1,6 @@ (library (name ressources) - ; (public_name lambdapi.tool) + (public_name lambdapi.ressources) (modules :standard) (libraries lambdapi.parsing lambdapi.core dream unix dune-site) (preprocess (pps lwt_ppx)) @@ -15,6 +15,7 @@ (section (site (lambdapi server_resources))) (files (description.html as default/description.html) + (lambdapi.ico as default/lambdapi.ico) ) ) diff --git a/src/cli/lambdapi.ico b/ressources/lambdapi.ico similarity index 100% rename from src/cli/lambdapi.ico rename to ressources/lambdapi.ico diff --git a/src/pure/pure.ml b/src/pure/pure.ml index 2588e9d9d..eaf2174f6 100644 --- a/src/pure/pure.ml +++ b/src/pure/pure.ml @@ -65,11 +65,11 @@ let parse_command p : (Command.t, Pos.popt * string) Result.t = Result.Error (None, "EOF") | Some c -> Ok c - | exception Fatal(Some(Some(pos)), msg) -> + | exception Fatal(Some(Some(pos)), msg, "") -> Error(Some pos, msg) - | exception Fatal(Some(None) , _ ) -> + | exception Fatal(Some(None) , _ , "") -> assert false - | exception Fatal(None , _ ) -> + | exception Fatal(None , _ , "") -> assert false (** Exception raised by [parse_text] on error. *) @@ -105,9 +105,9 @@ let parse_file : Stream.iter (fun c -> Stdlib.(cmds := c :: !cmds)) (parse_file fname); List.rev Stdlib.(!cmds), None with - | Fatal(Some(Some(pos)), msg) -> List.rev Stdlib.(!cmds), Some(pos, msg) - | Fatal(Some(None) , _ ) -> assert false - | Fatal(None , _ ) -> assert false + | Fatal(Some(Some(pos)), msg, "") -> List.rev Stdlib.(!cmds), Some(pos, msg) + | Fatal(Some(None) , _ , "" ) -> assert false + | Fatal(None , _ , "" ) -> assert false type proof_finalizer = Sig_state.t -> Proof.proof_state -> Sig_state.t diff --git a/src/tool/dune b/src/tool/dune index 13feed661..62eeda1cf 100644 --- a/src/tool/dune +++ b/src/tool/dune @@ -2,7 +2,7 @@ (name tool) (public_name lambdapi.tool) (modules :standard) - (libraries lambdapi.parsing lambdapi.core dream unix dune-site) + (libraries lambdapi.parsing lambdapi.core dream unix dune-site lambdapi.ressources) (preprocess (pps lwt_ppx))) diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 1a3eb62d6..e20707deb 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -423,8 +423,10 @@ module DB = struct | Some (sourceid, fname, start_line, end_line) -> let start_col = 0 in let end_col = -1 in (* to the end of line *) + (* FIX ME *) + let start_offset, end_offset = 0, 0 in Some sourceid, - Some { fname=Some fname; start_line; start_col; end_line; end_col } + Some { fname=Some fname; start_line; start_col; end_line; end_col; start_offset; end_offset } let generic_pp_of_position_list ~escaper ~sep = Lplib.List.pp diff --git a/src/tool/lambdapi.ico b/src/tool/lambdapi.ico deleted file mode 100644 index b3c207a5daa199c536c0ea02bdbc074f42d0f035..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 13707 zcmX}Tby$?$_dQI5gmgCy4Fb~LNJy7-I5g5NjWh@hUDBNn-5oe)s&w#4%teS`hN>xZkuSvZwa z)f}_&bZ$&@yo&2sNe>Uc%|MB#^U!boI9@YdGW&K@4fDi8;Ab6PMM+!Kn5J=GmC zFxA%D+82pSZ?-p{G1VOyxE&y^9*FjHe!g$x<=Lyn=aSLy=?-^vbd)Tl#sBf^a|kXK zIbN_zRsqeMH>!r9&sPT;kx@~>`#&lPLdD$=%pxNrgGhO-nCBS?%Hkz0Eg6!NlO;_| zsLVn*I0H+%wE7T(g9wp$<)9I-DMRk=yjgdaMXla9WeGSDt-KO`6583{m$9;9+!V;l z%ru~sr!nH^LCB<85^!3Vl$3u6G+wPH=V>x;c_azqzwBFj2xK8!qYNBjm7H2VZT(nc#t= zi2xr*pT`ROChUP;qLy1uCL2$c(zn?gs#DL2`4ZC8AAxN?TcVPX;-S$)hr>mHP?6~1 z;K2SRJiPL?mF=NFiLiUwQ9$|<{FBDT4s6ycTyntC3`v`I>E}=Fbcw)VD>Fhi1CMZv z-|L;5zp2Z`m0`x**w|~Sm zWn}E*;@(x5FHi9!_mcT~%Q@@fY)V57n;fL{3>OZpXrA{211iZ)uQw02`XkIIvs-Jkt+}M4|9#r)U8=X%&*X}8^waS@TfHxd(nDg!vHADh_4#?w z>Z<4(ZQ$h|7Kuba$Jx_7q#qTV>Wk0iQ^OAAT#lxP621gfxxX-A(&^hbmd4qN9jSr2 z-GRtsJ^5BiknVMGkONXW!~ys?KL5-fB0ELJ&$OaOe+_M$o_;QGn09yv@!xFc*5dKjh>M9)=uq{l(U1}xvcqA!sS5{A7deT!6M+@4P|FkL8SHk!=B<*>+g z_lx=k?R2HNx$F|yfVz$jve)l*WTUrFhqLH|O&lx=Dk{MV2{?>x*EQ~2ePMNh-6QvT zw=M+F^-@8sux+>E(`Ao@Q`_6Kubcb(5jWR#mdD;tcifwz#pUG@;N!ZV->rX~9mELb z>hS0cld_FXOdw;&PsdiHT_eE%rISnnH#@FHPo~tQhRORr;G$s`W%Xp-M5Nm<)F4cT zvMzI?MSeoyCPzY;$IVlMcKTk2%xKyQ>6gCGKte`F9v^x|9ScNCv%w~D|B8sOlp?J2gbD;te5v4^^4mm3Z0ZR8SXXk9%^K2FO z==gXybIwCzMu5l|l_i@POg#i+Z;9*=(*ljk6NIyTHDh0R)m%pF)Q@W_))= znB2g@$7dpCo0g(6vqCCMsH&cuD3HV0{8_G*IjFDdD_;MJ)bH*b-k{O0x}5uDrg+x+ z`RS&)JBkDyP>(6*zbByk9SSi zn7FHF=kye-Tl(A6yRQPEeTMGGGy2iwmwRmKuN=DmJ60D0S~Dcs&9veHsFk!f8nvDN z*0N{SW>*K(=hq9S{XoGY2mi4pBAb{;2>vPm%PvgYB;K{ER{i$u^ow}e`~fZ*U9M%) zNd}L#*>b}n2ic$N>)`S6_jF7@2@IMYDIHcxIACESUXB7!cN0@KiMX$HzkSm(KbXqL z(o3hLq*QDhNzErrqtRcIId^*}1?4a!AtOWo{(Z$jwgn1BSi^MH5J#ZkRruQ*7G5K} zRC?of{@xfLs6`PuBKR4?+^#$4;g@5AQaC>tJ;n_$CNM#tZ%*{nh3Ar%&Z~^u$^0cZ zCf;{1M_bl{tN+49V38wWQ+;@$De>G?IaU6PW|cZ_)DSr`^WpK%yT3#wE6@7Jx7E@< zpvUyW$^{79_a}3L?=SbYri*nL?r2+_OyBa{#y;mkRG@cMfjTL>{>d^Cn&yM(ho)y4 zadg2J^Ab!KU8YI7$E{>hjH7I8las>$eTh>W3<|tP4!LHdYz~9@N3E!x3g?fT$Me;n z?jk=H$yd^pq*6<|PRcj)4*BN(ZrXeEMtAx9M{7e1=!^KLWrCillGs&nqJxnUMU?^J z4e}d#L2dS82*SF(-{VcS`5x*U5?kv9RTojUTyYdVJ-tES4=g>E$7RgI)EsfDP@u|6 ze}tV)@QR8OKp>D0SdENVqjdUDVcr0|F-5|m?8I&QWPcwL!bsP&_2uVi`}H+-o}0C& zn(w#t=@vhAjXwk^m{XoUWKz(b`e;6w<7x|hlhcOkS;A|Ea)^WLg}8R~-WXxcx^wS7 z)$i3-<((#7NFu(Fy^O-)x}nc~Qmz~3)Oke8YvBJ!wzJ|eh~F^&rqO^F6_K3AuS_a( zXjGRBltZdCCfm1WaoKdg;9w;^f+U!r5k0ELfL-v&vx~<^I0OYr zs(HQMVrV2dU`%b7uJneYN<1Dr1zcu@H-sCvds_0-bPz}cK2v;xU&PNio-GwLICh1Dv!sI` z8jB-e^=e@v z3dsZ@He4?Hs9#1c_)Myd=q!v@7!FI&Fa_NhX;*RYt<_o|A0GqE;S#kF@F(f3dN^gs z^{px9a6C1WmwYM2qP=IdClT^vv)A$bV4B`o6+THc^X*ywRkAy}o&l6qA=Qr^ zlSA>rPRMP~{c1U61q$;w4fY2PBG1a>?GFts!^3tG;Cf9!6TIHN{R$)Yzc}DWOAB(9$&q7ix?#rl+%_ z`etW~qT=Ht5)yP|T}aD?ImJEsExw>?tTuhQ;$3gD_E%)G3bN{)y zp_P6d&(H$eJ_4P7W0-TnAplR8-3#sYKKD?M#LhH1uAy&jRhEDG=nfeieB-p*qKI6% zr}S`rjCl9ZMw&^ZAELqNUp+q-kslq6?(FOgilo?_ua+heaHL4AqWXdagT!kBIlc)? za=mzs2lDs#hcmt7mca)pbBz{(MEvg5TLNFigXKNsZcdgE;o+MuvBrT(=Iz_JKRr^R z9za$G0l)0xWbm#^NfMdMZ z?!|=gd|=(cxEpNC@vlhdyGPA9jvl^JE+>>O8cIz`fp^;*Ph3_>y9fcl3RfA;|2vUY zNXyTkDp@H^2gDsY@I|t6$k^yX+S0OE`1RYSSW)_XE;*VFKZ|CObrt)Q&tO{ur zQb`*gwAn5D?ty+7hC$3r&J5F)^1MNIFX%I@=Vo?!pTJJ)tGOqdG4!MO>f4L7(zpeK zawHLq&9jiT`fP4Xlcn0Av5D+Yks|(7D(Vskm-GQIgFG8z+O!@NKyU|wbnQC=27lw~ z(yM@-YMd_BGbvf$r7JwlRi*{)HZGp6H=5Ak<;L;a(ff=f3{g>ZJjLL>FY>>piD>SS zmg&!E1&%JTN1YDWT_x?a>?-%~iKflhA|X@iS5xy!-*~&m(&~H1#$vRMyj(-ThgcaO zV0adazD)#`JP)i9IBzGSra}6J)(PlnXhCA1Z@5YO%e9#L=PJQInHhpT`sFnG(mlmH z^Snw!tkO2_^tvBDpgB5*mfzXCLyA3qPT(zufXm-YePreC8|M7@6;oeZb6wuSmH=dr zk)Qe^Za@FN#r+WChb(-|q6@`C!Q2R_sHmVla(M}Og-I=*t)PqcM=FRBcCuStM||wF zhta5E7DrX)i*Z7g_P~1(CxdzTI$Il=%Lg%0Q5u0XRZ=%8=!JD8jsE>2Y1{t4VSH~~ zA7a7#fUSW?LWV=d??CcU;U5>xBu{Oa%C?l5$=Y)tJ25lh3BRSFtUt(K!83E%kEg3`PIR9aNpaa*ykX-*HJ)LDY`yf*`8lzOVQl7j!fpPnD>WcK^~)CJK*HC z3iG_xP*98nSr^5|<}ipN!SKc*Z;adWs~%)*KI82K(O06Enql-ND8if~lL5&7YKBEK+ChoZw{R|&KFTzq z3M)A~Cr3juLlcjkV-%o8sLqu>@Ot3p`K*i`fJ9t(6p|A}b74U~-m!3oiqYvLx*9-q z*?@s-zYqhNo)GItu`;pwJiBcv9swyq4hLOAYAQ-s*JW8APvEmrkCUMMCwlqVpbk;~ zR%9d?naBJ{?AY8Kp^iNVWa+VcjsH`0NK1>LoUp9*F4`1m3BZg}>goxurMwkV3G8dZ zxNJ*A=YCfQxTCLDl)0CE%grhU)#KQDu-kMh`^vm+fv-a;>>hM*oAaKkPt9O9qZ9f`3Dk^GOS)NvKb5j#ac6K(2Peqr36x4lKGQojI^fy3kO-}lk7dTvP zf6?x>D2iotA@OK@K5O5Z}Xuy-V_KZlD@QM7h zxh85%u(T8uoJS?*OJMcmn+zkn%+YMAZ;wyL#7`s`Kj|kwg*H=Q4j*~}nqSbEM$8a( za7YLOiEy$Bf(N|>7cy)nHy2peOxWiFEEp)BBtEL}>;BT(d|gyHVk<+?#;n+SGFz&) zY_?q1#%ZH9|EO9ci$?!}o=xF~>3vL0Oz)s2od1`=8A0G+jf{+#m6$R+k_H2WTLEe| zHDP3|2@)3<7mnxeb!B8WWhEdD{sEB1jScFXGZl-yvNE$VOoOcG&W?`FyFW?%y9!9L zs!;Zgz3iON`O2^7KwRWX@>SqKGSy6Kd4o(^`Sr2ci&|*_FC5f?mVyxjHIEMo;1Mf_dfrhI356LD z$Oqu(YrGmDn*!>nii|(=b}R7;0d8Sn&iwKL27pp<{q(J7idg=C0I@ze_hFFV!fIzO zVSXZsRvSo2I`U! z@UB{&*k{k)Og{S^wkcaREeQK5^|znj1$^)E%Dw9#!%;@Sgsr0Tx6WJ!=-a42uWVIt zkClZ83DwMd;5_f88p5p$B}(X*0BRKNl}59Y6nMwiz26~1cmIp|Q=7*zQA=B!M$GWR zZk4~EAHZt5+j;Zpfv=+RIN+^?A(r}4N$#EicAx|pG&$BcJ77BJr#qMPi;L8y$1%qc zaEcU*f-Y%5+rfmeUI_tCz}*&pgVTnI5-}|sF1(+%~pwE7)@GBY7 zX45yiDX6FbDlT4QrbnO>-TUYPTP6{1U!mhJ|3_&>n7>@Q;W4`|bUbe^e7m86_xyTJ z)e@op8|jV^`N_%2RMWV<9V0N^R7s#=K#KVZ8_N}xD?h|e0krkzD50ww}k^-{oH;Op-G~z>UrYJu_dpK6cWZNW>Nufj)FB=2i$5#uF<; z_$~|j&Ouq(*_gmMod59AUXirs7oYVc#bSdkMxt0@cK}{+kAe-r7U7U83j9h+RBWoN z!&zNL;UUA4bRyjIcjFO-ZHwiNjuMYEs%Z_fu)u;On%-v%W{j9f_TUM6o{%I~;XuNB z&bRt$CAuXIn8;`3yEMmy5dq?%LQ6wrRP~$aD;_Iv7nhOsE}l*M?3TnX&(?Nqgbpue zGJhn13C=4hfMi+}T3-``{)HibWQtASPpz%2ES=I-bxg&a{ zCQ&k=DB!pX z=XFcF8vAnh>vpPUZNIj(=n<+_su~VVRj!wFnBf5X{u)p*^2sWuoeu6F9}DRs6t%hS zD*z10V>74mugbSL(`Lo|+1%W9KHu!+bTFUszlX5TrY@!xi)gc-ZDK%l_~n69zExVj z-t4py9*l_UatWJZB_hB5kA0?-h&6#vK|_j`E^@-vd=GH`2szCrpyHSsuzoH0-B*gQ zkRMZQh(%1!SYB;rCyU<`a{M#KNUDrTG4Doeic=F3;H0G3BA z5kdf%?9dc8nG`m=l3oBpIIW8|oTkWAHp_=u)u31~Lv~xEjhonUQjP>IJT#SjJ`p}b z-2*lX<>NxKDIS(4);m9kQe_$+3YJT8Xzo=|+#GARDOtpJC zRo<+wuIAO96D0x@X_Oh1MfS0Tn18X_P|y2vFHU8}mk0+m=6Ho!4=K(;-XPmqUpKMY zShzV1J2wC5f5rXsRY@e+ zsGKU|-*c0t1=HrOJy_wpVlHnkpLLZ)_VAUdJU?Uybok6*8YCDrtF&z+$+*dZ6vTLD z6`_tlp;hu8==HWjN{EPv=C@~^vd<~W1pR|){On88bzWF$Z~yzniZ%u%BaXlDP7cuZZqDpK=EDBF8M?flO>l8PIu+$dzf0n} z(DP8^F&iWwNA~K@mb2N%*SGI*);g+9;iqZ|s79s>Bj8^mQ}{J=Ki_(WWM+~T@4cVv1}X;{ zk0o|rD%|B&HoA`w*eCcJz3l@GN-4Bf4gU4(mxj)wj)TU%qR7N?vgX?_a|?ksW!`L= zpOC&u1b(f9Hghm*SE*Vm<0VjZxX)TfcFggLn!PXWP-gK#WTK7Nb!k}5a z142xMM|=fP?c_P;#zX9M01C|`TtRks2G=lfbK|CR6w3HEWuGq3QJtgm8=TG*D|1KacH;mY1G!$==l=jiFbxzzwUQb%h$T9w*sf+Y zK5L`zjsh8-dm9^QMyExANQU3n!^2~$1Z$;G$EvKm$?Lbt`K|TmLX`yerEFatJ0RL+ zuTw9u)j?8%!ooc(%}$E43^4b@8Dv&AQ=Dt=2jWk3I1Xqz5`k2VYF1gHx4ogC%d8f; z$j+Tn!1L=YX=ey!{7-RePKSWF5V-Orw*2#@~&1>*%B zA0Ki~0U9lYuM+3*CI-*%!vr#e`1ILWD0m_}*@U1>lgXOigxA(`93#63QEqQH8OC-B(H>e18VhjuoN!!>6&T`p&6S6*HM%>M0S^`81 zNn^@frF>jm^ExN$m7h_+hT=kFh&gew80`C)T%|*$HIJPc;NS@5|9Jsg-mBf7o!nNY zvFjr-sb){nAh;VVDJvtInl|0PMS{&x^4Kk(t7IW#5NXU>E8}8oCPBOXE_Ph5l*XMn zmx;s;?mvI{Kr%2e!0lzdKY3bbj<~X5vnPc^GV897E@i zzq>B+*%Jh>t_|v5 zjUiawAJ4$j*VorJO~-|K5ZJl;_#2h1CO3Myg)$kFhKMgS%XiQ#CB zJ2!x3^8HENQ_w|+pH9#Iza~dk0Xn2vOS}H_Cmf)y6=ptZn`@5S3`l&wVR!#|Mu(-7 zxzHN}j=PD24;<(MvMuJVT(d*_WBdVOakKhWV^(vsKv8LuztR0!d;Ao@gEboOIp!|JciWl)?J5+|!d&8YR6<2v z`1=rJL2mjVvjOV|;3nyTCHZNNmirXs-N&O@KN&zlK?lv2L&~pOG|wk`{EqNP`;!14MgH5q7y8uP{hAXMU zh6V!PYgfih>`J`|#5dm7B}11H8w3kL+bf88R^*YIxW1BC7(sV02k9)_EoWw_eALbX zyRdc_75z1W`wgfSn}`Djc1VPtG`j0!q)4|=@U(VZYoW2RkO{CU8T5F{6KH;0}?_5lz!wK6RDkYt(2`y1j)$je*i2>_Xp@qmq-0h(0K4{Sx52Bzv z6e`OfN@Qt;ffaLf(9zGjKfV*))T8APVDYFdD4?Si7dIK(8oBrcII|8a+`d+I@rvyJ zkH0FJ)-J~|wo7D3*`F@d)c)aASK<;K9UbD-ZLGHQ5tz)hE!OnJAcMP1{Eo4VuBqV( z^LpO}hk$x3bv$p1A9lRAhkh5ClxU!-iO1@HRvVQd9^i*<+~z+0g|j1Pv-QrF%<%WR zs=Ag|zlf2=XFzX6em8tJaPf~xp>}##`3@=y=nAf42Cy?4ly@ppEG-9Hy;9M|$#{oF z!YL!9uMEot6*59KJysy5EmPR4xqEJn>#3X*FJIXxl2gU$&gT7IyR5xg?EEZ%gz|>o zQ@1?tTL2dTuY=w8-$qLF&%}X@KyO7J-)gK@g^j0^l(3Z8LD+A8ZT2GKP*9BfrZXJg zUS5VGqQ1tvb#Xm{Z)|MLg}E{4e+z9f?-x!s0yA+7+F?M9=IpOD#?<^-1R0r_3bm+} zi`>mw$pIbIcz12+XLxGL!xIq$1QV#$*b;qEkiaxLN zO{sK&A8JtSR6KPTL)eAU;L$Zk2SM!B6QSQ&DhCekcliq>tF^7c7^Q=iW=?ya%(>cP z>;%-;C#cyVg}77*1ObC+L`2W&@JNIhqN1P>l$S@idOmZ^sy3SAFQ%t;eRU;EEhHXT zyv;9EMKW{TksoF(FOO2u%@>v`Jm?E}2ScfbaHFpkG-y1qn_3-}-6AnyO8WVV@B5Y311ACX!?(2Iy_>8rIaCnkww% zlV~I)B$1AGyJP%39!KD0IZa>TK*+`V1>B<&=Q{BXkL$c!Xc>r>OYK*Vu!W zaKW-oFk9{fFqaH)U*N??qS@bZXLbHD!cpuM7V@F~61Jo|PA6ww=wM+%$8OkUq`L6q zp{STrHl~R4nu`etXcJH#6qJ>LK2F+x8jum*{*2YX!qu~TFBItdJTW0 z&HGAhsaT!;NlNme$a%pnF&n?H&%0xK+Tq*lo$WzmGrUgk6;p5JeE}rX_HrhR%+;8@ zSh2gl%Gv2aD(Za>=X-lrNL0mtD(<6+5{iNaWwCaLH~M^hvUHh=?Y29*8GiiZPPi#K ze1nLGhllpf*XOyb)PR`xicNr{PF?p#799m@+1X(QHz`+fE3b)MZyOu&y0|Zz@JXC? zbdY#Mr8}Tg-O+3B@6|<}1s2lpFx)tAXWvnYr!DND%GeKffOLEQ=hwTEOQ(ySDCg5< zzL=YgL6urq;yMuvd=ynw7XAdA zmjVo?T9{V_PuqhrT#lZ}qoW)6-plg@0u z-6RI$0ARx>*zg<~biTsq9OAb>K3n>CS8yTa*sg~IfgyX-{ z)9p$iFmQ3f-K=aiu<4NS8;x6OX%>?n#S!v^12FZU*7 z6dSJnKSPG&gLY_DJ~527<75$ye7U9>6;k@OIfcC59r$CJukxW7jIT924Y2Z4EME)l z+Vb>QhQCtEI7J=pxzDi+N(k`>Jbh>=>#&_wu>-|Oh_7||50^-hA;_BooHgk7PD^ujj840>8JVz&6qf2DpEl$?tym2NpL~e>W1Vpf@3LX2E5XNMn9b4ECB(Vp4Qu{YB z?0pk!M|`HuDrZ@GYcs$i=q>c1`QBvy!<#O_v|7Ll+q%|zlXOA9b(B678%H6esnG}* z7bY`E>Ey(zJtUs>A&m~Q+ZjD)VeDy9M2N-;EW#_|vh58JqTvXf4qm_yFM@GxgC zcdGI(sFwbh7F>hfO5o#ZGY(;K{C85pI*H^o`!VSr_h|H;ig*|X_-zS_`vd*Ib#_e;=B{_gUIfvaWB*Mo7AI1aX) zu&1zg`+3=(Z(^T85ww7lNBRpu{3`M@Histv!gKv((@8D<29Ic{2E`x17ePrgfOfiT z%^dLZxX~~1a<6uG+x@b39w-PepgNKSn5K`N8xL}qsOMc#Rn_)$cZX~$b5~pGW59pb z?)oF{jo&4cXLC$lU3vNG-24c9j`?OZpIu8!%QmG*BEH|sM=XjQG2W4>BHG{|GRH^81*ZKV(GaXcWJa*?os~7;jep`-=u$9P4I|(3}@Obdgq!220R*lczB+$ zMyA%>4};GLOF1H5d4Yi+8JN>VX~CX2Ff%a1LRHq1Dw#WAK{@}e3hUR$gIxqzGQj2( ztd9=fVf>I4eUKV#Dh06|I@sgl0bW)v_XFoyIF~;bsoPqD5CuaxgPJJtCvZ!|tzSCC7tNhYyRaJ+*BG(^5gVE9{iD#rBDxGxJ&*6hUKdzgBE4 zyNa=0#>7xCN#Nw<26=VJ3>I!T0wYxW-MQRjJ3`$&Ji-i{qrJ0st$r*lpuXkdDPN># zT$;!dC`3H5FDGHpC>T7d1O;3s^oB~fY=fyv+@0wEbC0=GN6aIXm6r$KoW|YbCVF<+ zS^OiEi|+}hmv@SG;}^3U<3P_g8m6XBhUy9<(lks=sDx(}^p&-`A|A){gw6pcsyPR1 zh%|Ki^Qc={h;MYiH*=YJi4v^%d>o}+wV!rO7 z0Hu#0E+tiuo5=n{rz&?tR1g@$CrGd=*+fMtnjGW!9Q>3JfYXgWdX!r$8+M=^Dfype zPM*11g}Wo9)AN+fBV=%T8Kl2{cx-2H-vf&>c}wu=HH%nno7eBx@zfH~zGc7V+4L7&yr-94zUPg>5}y!zfc3G7p2k+NQ8CWK=!XKY}A-svl3 zKPRU1)aG-E5=$*%LbzhZPex9Tk)OZS7Sc0jkFq&%$DXAF*){$J_%T2MMLypPG>KwQ{EK9qsadMi4xcXP=O-Vf#OA6YR@gEyUAuDDW{3o1 zd3(nOwR`<`{cb5sFNka?*`rAxE>DppSR;o?s3k?lkd!VQnVc)+hVBgifvQ^W|8tCA zp6B-t%~kqvc^qjw-o)CBjLWhyeeA^D57M>p1yp`^(=H>oG^?SnlyR)~rOus-%XF~q zcr|S5R2Nbn09XXozr>VKz;ob!ayZc?0oa9>c5Dr*bV96x4goE1LY94h!i~&&K)E^~ z7+{tAGjiyV2(E`h{~6I-uV6<>Np9t|BHcFbI6Z_IR+HIs?=s$VEG-fDtUPu*N#BiC zXRVlJWL9~_L`Q!Cv`WUdFil~!O;-u~`Kn;$G}i;>?totzfoel`oF55a$ z22$Gy+%Q4#^X{yukmui?o+gJ693)c7MO$t6!gl6wZ4rEMqES^9Q`djk4F79Z-N31E z1L(2mzv3la|NQpqex!`06iJQY;34mYi53(VPNQE6;**@Oj6DB+%s1^07+^N3(_8 zP)_5C5E)wl*P|@%c68HSLr;C_)+EV@Jm93FB3;BOev2OwZ diff --git a/src/tool/websearch.eml.ml b/src/tool/websearch.eml.ml index 252aac823..ea2132c00 100644 --- a/src/tool/websearch.eml.ml +++ b/src/tool/websearch.eml.ml @@ -74,7 +74,7 @@ let show_form ~from ?(message="") ?output csrf_tag ~hide_description= -let themes_locations : string list = Mysites.Sites.server_resources +let themes_locations : string list = Ressources.Mysites.Sites.server_resources let start ~header ss ~port ~dbpath ~path_in_url () = (*Common.Logger.set_debug true "e" ;*) let interface = "0.0.0.0" in From 16d7303ced728770dcfaf48df34dfb128b0a64b7 Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Tue, 9 Dec 2025 14:16:02 +0100 Subject: [PATCH 48/58] various fixes --- CHANGES.md | 2 -- doc/options.rst | 8 ++++---- doc/query_language.rst | 2 +- src/cli/config.ml | 2 +- src/cli/lambdapi.ml | 3 ++- src/common/error.ml | 22 +++++++++++++--------- src/pure/pure.ml | 15 ++++++++------- src/tool/indexing.ml | 24 +++++++++++++++++------- 8 files changed, 46 insertions(+), 32 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 41b496d67..828e244bc 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -17,8 +17,6 @@ and this project adheres to [Semantic Versioning](https://semver.org/). - Supporting `Plac` in rewriting rules. - Fixed Stack_overflow exception due large number of search results. - - ### Changed - `simplify` now fails if the goal cannot be simplified. diff --git a/doc/options.rst b/doc/options.rst index 4d8459a7e..749ee2a04 100644 --- a/doc/options.rst +++ b/doc/options.rst @@ -92,10 +92,10 @@ decision-tree deindex ------- -* ``--path`` : indicates the suffix of the paths of the symbols to be removed from the index. +* ``--path``: indicates the prefix of symbols paths to be removed from the index. The path must be dot (`.`) and is not checked for well formness (i.e. A.B matches A.BC). - For insrance, if symbol `tests.OK.natural.N` is indexed, `lambdapi deindex --path tests.OK.natural` - will remove it (together with all the symbols whose path starts with `tests.OK.natural.N`) from the index. + For instance, `lambdapi deindex --path tests.OK.natural`` removes from the index all the symbols + whose path starts with `tests.OK.natural` like `tests.OK.natural.N`. export ------ @@ -203,7 +203,7 @@ search * ``--rules `` tells lambdapi to normalize terms in the query using the rules given in the file ````. Several files can be specified by using several ``--rules`` options. In these files, symbols must be fully qualified but no ``require`` command is needed. Moreover, the rules do not need to preserve typing. On the other hand, right hand-side of rules must contain implicit arguments. It is advised to use the same set of rules previously used during indexing. -* ``--require `` requires and opens ```` when starting the search engine. The files can be used for example to specify implicit arguments for symbols used in the queries. +* ``--require `` requires and opens ```` when starting the search engine. The file can be used for example to specify implicit arguments for symbols used in the queries. * ``--db `` tells lambdapi to search in ```` instead of ``~/.LPSearch.db``. diff --git a/doc/query_language.rst b/doc/query_language.rst index 537916db1..6b59d2b7c 100644 --- a/doc/query_language.rst +++ b/doc/query_language.rst @@ -7,7 +7,7 @@ Queries can be expressed according to the following syntax: Q ::= B | Q,Q | Q;Q | Q|PATH B ::= WHERE HOW GENERALIZE? PATTERN - PATH ::= << string >> | "<< RegExp>>" + PATH ::= << string >> | "<< regexp>>" WHERE ::= name | anywhere | rule | lhs | rhs | type | concl | hyp | spine HOW ::= > | = | >= | ≥ GENERALIZE ::= generalize diff --git a/src/cli/config.ml b/src/cli/config.ml index 788e15709..5a6e8b9e3 100644 --- a/src/cli/config.ml +++ b/src/cli/config.ml @@ -109,7 +109,7 @@ let map_dir : (Path.t * string) list CLT.t = let path : Path.t Arg.conv = let parse (s: string) : (Path.t, [>`Msg of string]) result = try Ok(Parser.path_of_string s) - with Error.Fatal(_,s, _) -> Error(`Msg(s)) + with Error.Fatal(_,s, err_desc) -> Error(`Msg(s ^ "\n" ^ err_desc)) in let print fmt p = Path.pp fmt p in Arg.conv (parse, print) diff --git a/src/cli/lambdapi.ml b/src/cli/lambdapi.ml index cb40228ef..677eb4689 100644 --- a/src/cli/lambdapi.ml +++ b/src/cli/lambdapi.ml @@ -50,7 +50,8 @@ let websearch_cmd cfg rules port require header_file dbpath_opt path_in_url = let ss = sig_state_of_require require in let header = match header_file with | None -> - let themes_locations : string list = Ressources.Mysites.Sites.server_resources in + let themes_locations : string list = + Ressources.Mysites.Sites.server_resources in let file = match themes_locations with | [] -> assert false | x :: _ -> x in diff --git a/src/common/error.ml b/src/common/error.ml index 4073aae52..f6fb6f90c 100644 --- a/src/common/error.ml +++ b/src/common/error.ml @@ -36,7 +36,8 @@ let no_wrn : ('a -> 'b) -> 'a -> 'b = fun f x -> code position (e.g., errors related to command-line arguments parsing). In cases where positions are expected [Some None] may be used to indicate the abscence of a position. This may happen when terms are generated (e.g., by - a form of desugaring). *) + a form of desugaring). The last argument is used to provide an optional + description of the error, displayed differently from the error itself. *) exception Fatal of Pos.popt option * string * string (** [fatal_str fmt] may be called an arbitrary number of times to build up the @@ -46,10 +47,10 @@ exception Fatal of Pos.popt option * string * string let fatal_msg : 'a outfmt -> 'a = fun fmt -> out Format.str_formatter fmt -(** [fatal popt fmt] raises the [Fatal(popt,msg,more)] exception, in which [msg] is - built from the format [fmt] (provided the necessary arguments). - [more] continues the error message and is printed in normal format instead of - red color*) +(** [fatal popt fmt] raises the [Fatal(popt,msg,more)] exception, in which + [msg] is built from the format [fmt] (provided the necessary arguments). + [more] continues the error message and is printed in normal format instead + of red color*) let fatal : Pos.popt -> ('a,'b) koutfmt -> 'a = fun pos fmt -> let cont _ = raise (Fatal(Some(pos), Format.flush_str_formatter (), "")) in @@ -57,9 +58,10 @@ let fatal : Pos.popt -> ('a,'b) koutfmt -> 'a = fun pos fmt -> (** [fatal_no_pos fmt] is similar to [fatal _ fmt], but it is used to raise an error that has no precise attached source code position. *) -let fatal_no_pos : ?more:string -> ('a,'b) koutfmt -> 'a = fun ?(more="") fmt -> - let cont _ = raise (Fatal(None, Format.flush_str_formatter (), more)) in - Format.kfprintf cont Format.str_formatter fmt +let fatal_no_pos : ?more:string -> ('a,'b) koutfmt -> 'a = + fun ?(more="") fmt -> + let cont _ = raise (Fatal(None, Format.flush_str_formatter (), more)) in + Format.kfprintf cont Format.str_formatter fmt (** [handle_exceptions f] runs [f ()] in an exception handler and handles both expected and unexpected exceptions by displaying a graceful error message. @@ -69,7 +71,9 @@ let fatal_no_pos : ?more:string -> ('a,'b) koutfmt -> 'a = fun ?(more="") fmt -> let handle_exceptions : (unit -> unit) -> unit = fun f -> let exit_with : type a b. string -> (a,b) koutfmt -> a = fun cnt fmt -> Color.update_with_color Format.err_formatter; - Format.kfprintf (fun _ -> Color.update_with_color Format.err_formatter;(Format.kfprintf (fun _ -> exit 1) Format.err_formatter "%s" cnt)) Format.err_formatter + Format.kfprintf (fun _ -> Color.update_with_color Format.err_formatter; + (Format.kfprintf (fun _ -> exit 1) + Format.err_formatter "%s" cnt)) Format.err_formatter (Color.red (fmt ^^ "@.")) in try f () with diff --git a/src/pure/pure.ml b/src/pure/pure.ml index eaf2174f6..28ef46271 100644 --- a/src/pure/pure.ml +++ b/src/pure/pure.ml @@ -88,7 +88,8 @@ let parse_text : Stream.iter (fun c -> Stdlib.(cmds := c :: !cmds)) (parse_string fname s); List.rev Stdlib.(!cmds), None with - | Fatal(Some(Some(pos)), msg, _) -> List.rev Stdlib.(!cmds), Some(pos, msg) + | Fatal(Some(Some(pos)), msg, err_desc) -> + List.rev Stdlib.(!cmds), Some(pos, msg ^ "\n" ^ err_desc) | Fatal(Some(None) , _ , _) -> assert false | Fatal(None , _ , _) -> assert false @@ -159,8 +160,8 @@ let handle_command : state -> Command.t -> command_result = (t, ss, d.pdata_state, d.pdata_finalize, d.pdata_prv, d.pdata_sym_pos) in Cmd_Proof(ps, d.pdata_proof, d.pdata_sym_pos, d.pdata_end_pos) - with Fatal(Some p,m, _) -> - Cmd_Error(Some p, Pos.popt_to_string p ^ " " ^ m) + with Fatal(Some p,m, err_desc) -> + Cmd_Error(Some p, m ^ "\n" ^ err_desc) let handle_tactic : proof_state -> Tactic.t -> int -> tactic_result = fun (_, ss, ps, finalize, prv, sym_pos) tac n -> @@ -168,14 +169,14 @@ let handle_tactic : proof_state -> Tactic.t -> int -> tactic_result = let ps, qres = Handle.Tactic.handle ss sym_pos prv (ps, None) tac n in let qres = Option.map (fun f -> f ()) qres in Tac_OK((Time.save (), ss, ps, finalize, prv, sym_pos), qres) - with Fatal(Some p,m, _) -> - Tac_Error(Some p, Pos.popt_to_string p ^ " " ^ m) + with Fatal(Some p,m, err_desc) -> + Tac_Error(Some p, m ^ "\n" ^ err_desc) let end_proof : proof_state -> command_result = fun (_, ss, ps, finalize, _, _) -> try Cmd_OK((Time.save (), finalize ss ps), None) - with Fatal(Some p,m, _) -> - Cmd_Error(Some p, Pos.popt_to_string p ^ " " ^ m) + with Fatal(Some p,m, err_descr) -> + Cmd_Error(Some p, m ^ "\n" ^ err_descr) let get_symbols : state -> Term.sym Extra.StrMap.t = fun (_, ss) -> ss.in_scope diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index e20707deb..d8aaef04b 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -394,7 +394,8 @@ module DB = struct Sym_nameMap.add lpid (sourceid,fname,start_line,end_line) !sidx | _ -> raise - (Common.Error.Fatal(None,"wrong file format for source map file", "")) + (Common.Error.Fatal + (None,"wrong file format for source map file", "")) done ; with | Failure _ as exn -> @@ -426,7 +427,8 @@ module DB = struct (* FIX ME *) let start_offset, end_offset = 0, 0 in Some sourceid, - Some { fname=Some fname; start_line; start_col; end_line; end_col; start_offset; end_offset } + Some { fname=Some fname; start_line; start_col; end_line; + end_col; start_offset; end_offset } let generic_pp_of_position_list ~escaper ~sep = Lplib.List.pp @@ -764,7 +766,8 @@ let index_sym sym = (DB.ItemSet.bindings (DB.locate_name (snd qname))) then raise - (Common.Error.Fatal(None,string_of_sym_name qname ^ " already indexed", "")) ; + (Common.Error.Fatal + (None,string_of_sym_name qname ^ " already indexed", "")); DB.insert_name (snd qname) ((qname,sym.sym_decl_pos),[Name]) ; (* Type + InType *) let typ = Timed.(!(sym.Core.Term.sym_type)) in @@ -884,10 +887,16 @@ module UserLevelQueries = struct let s = Str.global_replace (Str.regexp_string " -> ") " → " s in Str.global_replace (Str.regexp "\\bforall\\b") "Π" s - let search_cmd_gen ss ~from ~how_many ~(fail:(?more:string -> string -> string)) ~pp_results - ~title_tag:(hb,he) fmt s = + let search_cmd_gen + ss + ~from + ~how_many + ~(fail:(?more:string -> string -> string)) + ~pp_results + ~title_tag:(hb,he) fmt s = try - let pstream = Parsing.Parser.Rocq.parse_search_query_string "LPSearch" s in + let pstream = Parsing.Parser.Rocq.parse_search_query_string + "LPSearch" s in let pq = Stream.next pstream in let mok _ = None in let items = answer_query ~mok ss [] pq in @@ -921,7 +930,8 @@ module UserLevelQueries = struct Stdlib.(the_dbpath := dbpath); Format.asprintf "%a" (search_cmd_gen ss ~from ~how_many - ~fail:(fun ?more x -> "" ^ x ^ "" ^ (Option.value more ~default:"")) + ~fail:(fun ?more x -> "" ^ x ^ "" + ^ (Option.value more ~default:"")) ~pp_results:(html_of_results_list from) ~title_tag:("

    ","

    ")) s let search_cmd_txt ss ~dbpath fmt s = From ea6119b622446773d1b07bab721537fd37f524cc Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Tue, 9 Dec 2025 14:56:56 +0100 Subject: [PATCH 49/58] various fixes --- src/common/error.ml | 17 +++++++++-------- src/tool/indexing.ml | 10 +++++----- 2 files changed, 14 insertions(+), 13 deletions(-) diff --git a/src/common/error.ml b/src/common/error.ml index f6fb6f90c..3c024a1f4 100644 --- a/src/common/error.ml +++ b/src/common/error.ml @@ -47,10 +47,10 @@ exception Fatal of Pos.popt option * string * string let fatal_msg : 'a outfmt -> 'a = fun fmt -> out Format.str_formatter fmt -(** [fatal popt fmt] raises the [Fatal(popt,msg,more)] exception, in which +(** [fatal popt fmt] raises the [Fatal(popt,msg,err_desc)] exception, in which [msg] is built from the format [fmt] (provided the necessary arguments). - [more] continues the error message and is printed in normal format instead - of red color*) + [err_desc] continues the error message and is printed in normal format + instead of red color*) let fatal : Pos.popt -> ('a,'b) koutfmt -> 'a = fun pos fmt -> let cont _ = raise (Fatal(Some(pos), Format.flush_str_formatter (), "")) in @@ -58,9 +58,10 @@ let fatal : Pos.popt -> ('a,'b) koutfmt -> 'a = fun pos fmt -> (** [fatal_no_pos fmt] is similar to [fatal _ fmt], but it is used to raise an error that has no precise attached source code position. *) -let fatal_no_pos : ?more:string -> ('a,'b) koutfmt -> 'a = - fun ?(more="") fmt -> - let cont _ = raise (Fatal(None, Format.flush_str_formatter (), more)) in +let fatal_no_pos : ?err_desc:string -> ('a,'b) koutfmt -> 'a = + fun ?(err_desc="") fmt -> + let cont _ = + raise (Fatal(None, Format.flush_str_formatter (), err_desc)) in Format.kfprintf cont Format.str_formatter fmt (** [handle_exceptions f] runs [f ()] in an exception handler and handles both @@ -69,11 +70,11 @@ let fatal_no_pos : ?more:string -> ('a,'b) koutfmt -> 'a = [1] (indicating failure). Hence, [handle_exceptions] should only be called by the main program logic, not by the internals. *) let handle_exceptions : (unit -> unit) -> unit = fun f -> - let exit_with : type a b. string -> (a,b) koutfmt -> a = fun cnt fmt -> + let exit_with : type a b. string -> (a,b) koutfmt -> a = fun err_desc fmt -> Color.update_with_color Format.err_formatter; Format.kfprintf (fun _ -> Color.update_with_color Format.err_formatter; (Format.kfprintf (fun _ -> exit 1) - Format.err_formatter "%s" cnt)) Format.err_formatter + Format.err_formatter "%s" err_desc)) Format.err_formatter (Color.red (fmt ^^ "@.")) in try f () with diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index d8aaef04b..4c4e60101 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -891,7 +891,7 @@ module UserLevelQueries = struct ss ~from ~how_many - ~(fail:(?more:string -> string -> string)) + ~(fail:(?err_desc:string -> string -> string)) ~pp_results ~title_tag:(hb,he) fmt s = try @@ -917,7 +917,7 @@ module UserLevelQueries = struct "Overloaded symbol %s. Please rewrite the query replacing %s \ with a fully qualified identifier among the following:@." name name) - ~more:(Format.asprintf "%a@." pp_results (ItemSet.bindings res))) + ~err_desc:(Format.asprintf "%a@." pp_results (ItemSet.bindings res))) | Stack_overflow -> Lplib.Base.out fmt "%s" (fail (Format.asprintf @@ -930,15 +930,15 @@ module UserLevelQueries = struct Stdlib.(the_dbpath := dbpath); Format.asprintf "%a" (search_cmd_gen ss ~from ~how_many - ~fail:(fun ?more x -> "" ^ x ^ "" - ^ (Option.value more ~default:"")) + ~fail:(fun ?err_desc x -> "" ^ x ^ "" + ^ (Option.value err_desc ~default:"")) ~pp_results:(html_of_results_list from) ~title_tag:("

    ","

    ")) s let search_cmd_txt ss ~dbpath fmt s = let s = transform_ascii_to_unicode s in Stdlib.(the_dbpath := dbpath); search_cmd_gen ss ~from:0 ~how_many:999999 - ~fail:(fun ?more x -> Common.Error.fatal_no_pos ?more "%s" x) + ~fail:(fun ?err_desc x -> Common.Error.fatal_no_pos ?err_desc "%s" x) ~pp_results:pp_results_list ~title_tag:("","") fmt s end From c284cb7ffe33c304bcf33b70042a217f1620df38 Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Tue, 9 Dec 2025 15:19:21 +0100 Subject: [PATCH 50/58] move lsp_mod to console.md --- src/cli/lambdapi.ml | 2 +- src/common/console.ml | 5 +++++ src/common/mode.ml | 4 ---- src/core/sign.ml | 4 ++-- src/handle/compile.ml | 2 +- src/tool/indexing.ml | 2 +- 6 files changed, 10 insertions(+), 9 deletions(-) delete mode 100644 src/common/mode.ml diff --git a/src/cli/lambdapi.ml b/src/cli/lambdapi.ml index 677eb4689..eac1554a4 100644 --- a/src/cli/lambdapi.ml +++ b/src/cli/lambdapi.ml @@ -181,7 +181,7 @@ let lsp_server_cmd : Config.t -> bool -> string -> unit = fun cfg standard_lsp lsp_log_file -> let run _ = Config.init cfg; - Common.Mode.lsp_mod := true ; + Common.Console.lsp_mod := true ; Lsp.Lp_lsp.main standard_lsp lsp_log_file in Error.handle_exceptions run diff --git a/src/common/console.ml b/src/common/console.ml index 32a2bdb6a..efd8b53f9 100644 --- a/src/common/console.ml +++ b/src/common/console.ml @@ -103,3 +103,8 @@ module State = struct in apply e end + +(** [lsp_mod] indicates whether we are executing the LSP server. + Constants and rules are indexed automatically only in LSP mode + and not in check mode *) +let lsp_mod = Stdlib.ref false diff --git a/src/common/mode.ml b/src/common/mode.ml deleted file mode 100644 index 54ddbcb96..000000000 --- a/src/common/mode.ml +++ /dev/null @@ -1,4 +0,0 @@ -(** [lsp_mod] indicates whether we are executing the LSP server. - Constants and rules are indexed automatically only in LSP mode - and not in check mode *) -let lsp_mod = Stdlib.ref false diff --git a/src/core/sign.ml b/src/core/sign.ml index 26e06cf93..cdd64ccf3 100644 --- a/src/core/sign.ml +++ b/src/core/sign.ml @@ -244,7 +244,7 @@ let add_symbol : t -> expo -> prop -> match_strat -> bool -> strloc -> (cleanup typ) (minimize_impl impl) in sign.sign_symbols := StrMap.add name.elt sym !(sign.sign_symbols); - if Stdlib.(!Common.Mode.lsp_mod) then Stdlib.(!add_symbol_callback sym) ; + if Stdlib.(!Common.Console.lsp_mod) then Stdlib.(!add_symbol_callback sym) ; sym (** [strip_private sign] removes private symbols from signature [sign]. *) @@ -358,7 +358,7 @@ let add_rules : t -> sym -> rule list -> unit = fun sign s rs -> let d = {d with dep_symbols=sm} in sign.sign_deps := Path.Map.add s.sym_path d !(sign.sign_deps) end ; - if Stdlib.(!Common.Mode.lsp_mod) then Stdlib.(!add_rules_callback s rs) + if Stdlib.(!Common.Console.lsp_mod) then Stdlib.(!add_rules_callback s rs) (** [add_rule sign s r] adds the new rule [r] to the symbol [s]. When the rule does not correspond to a symbol of signature [sign], it is stored in its diff --git a/src/handle/compile.ml b/src/handle/compile.ml index aeff6fecd..a35bd3b1c 100644 --- a/src/handle/compile.ml +++ b/src/handle/compile.ml @@ -83,7 +83,7 @@ let rec compile_with : we need to explicitly update the decision tree of their symbols because it is not done in linking which normally follows loading. *) Ghost.iter (fun s -> Tree.update_dtree s []); - if Stdlib.(!Common.Mode.lsp_mod) then Tool.Indexing.index_sign sign ; + if Stdlib.(!Common.Console.lsp_mod) then Tool.Indexing.index_sign sign ; sign end diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 4c4e60101..81e06ad91 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -511,7 +511,7 @@ module DB = struct ~bold:("","") ~code:("","") ~colorizer: - (if Stdlib.(!Common.Mode.lsp_mod) || Unix.isatty Unix.stdout then + (if Stdlib.(!Common.Console.lsp_mod) || Unix.isatty Unix.stdout then Lplib.Color.red else Lplib.Color.default) From 1084b34c47ec8b43c9ac0433c3e4ab50cf38427c Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Tue, 9 Dec 2025 16:13:09 +0100 Subject: [PATCH 51/58] minor reformulation of the doc --- doc/queries.rst | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/queries.rst b/doc/queries.rst index c870e8099..ba457ad99 100644 --- a/doc/queries.rst +++ b/doc/queries.rst @@ -110,7 +110,8 @@ beginning, the timeout is set to 2s. ------------------ Runs a query between double quotes against the index file -``~/.LPSearch.db`` updated with current development and required files. See :doc:`query_language` for the query language +``~/.LPSearch.db`` updated with the assets defined in the file under development including the assets "imported" by the `require` command. +See :doc:`query_language` for the query language specification. :: From c9936ebc1cddb0a23f24f856843d4e7908bd59a1 Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Mon, 15 Dec 2025 15:36:46 +0100 Subject: [PATCH 52/58] refactore lpParser to reuse code with Rocq --- src/parsing/lpParser.ml | 4 ++-- src/parsing/parser.ml | 49 ++++++++++++++++++++++++++++++++++++----- 2 files changed, 46 insertions(+), 7 deletions(-) diff --git a/src/parsing/lpParser.ml b/src/parsing/lpParser.ml index aa861f216..89ebc297d 100644 --- a/src/parsing/lpParser.ml +++ b/src/parsing/lpParser.ml @@ -119,14 +119,14 @@ let current_token() : token = let (t,_,_) = !the_current_token in t let current_pos() : position * position = let (_,p1,p2) = !the_current_token in (p1,p2) - +(* let new_parsing (entry:lexbuf -> 'a) (lb:lexbuf): 'a = let t = !the_current_token in let reset() = the_current_token := t in the_current_token := LpLexer.token lb; try let r = entry lb in begin reset(); r end with e -> begin reset(); raise e end - + *) let expected (msg:string) (tokens:token list): 'a = if msg <> "" then syntax_error (current_pos()) ("Expected: "^msg^".") else diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index b1371552d..77d306b47 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -92,11 +92,28 @@ open Sedlexing module Aux(Lexer: sig - val parsing : - (Sedlexing.lexbuf -> 'a) -> Sedlexing.lexbuf -> 'a + type token + val the_current_token : (token * position * position) ref + val get_token : Sedlexing.lexbuf -> unit + -> token * Lexing.position * Lexing.position + (* val parsing : + (Sedlexing.lexbuf -> 'a) -> Sedlexing.lexbuf -> 'a *) end)= struct +(* let current_token() : Lexer.token = let (t,_,_) = + !Lexer.the_current_token in t *) + +let current_pos() : position * position = + let (_,p1,p2) = !Lexer.the_current_token in (p1,p2) + +let new_parsing (entry:lexbuf -> 'a) (lb:lexbuf): 'a = + let t = !Lexer.the_current_token in + let reset() = Lexer.the_current_token := t in + Lexer.the_current_token := Lexer.get_token lb (); + try let r = entry lb in begin reset(); r end + with e -> begin reset(); raise e end + let handle_error (icopt: in_channel option) (entry: lexbuf -> 'a) (lb: lexbuf): 'a option = try Some(entry lb) @@ -130,7 +147,7 @@ struct let lb = Utf8.from_string s in set_position lb lexpos; set_filename lb lexpos.pos_fname; - Stream.next (parse_lexbuf None (Lexer.parsing entry) lb) + Stream.next (parse_lexbuf None (new_parsing entry) lb) end (** Parsing lp syntax. *) @@ -153,8 +170,12 @@ sig end = struct - - include Aux(struct let parsing = LpParser.new_parsing end) + include Aux(struct + type token = LpLexer.token + let the_current_token = LpParser.the_current_token + let get_token x _ = LpLexer.token x + (* parsing = LpParser.new_parsing *) + end) (* exported functions *) let parse_term_string = parse_entry_string LpParser.term let parse_rwpatt_string = parse_entry_string LpParser.rwpatt @@ -167,6 +188,24 @@ sig end +(* module Rocq : +sig + val parse_search_string : + Lexing.position -> string -> Syntax.search + (** [parse_search_query_string f s] returns a stream of parsed terms from + string [s] which comes from file [f] ([f] can be anything). *) +end += struct + include Aux(struct let parsing = RocqLexer.) + + let parse_string ~grammar_entry fname s = + stream_of_lexbuf ~grammar_entry ~fname (Sedlexing.Utf8.from_string s) + + let parse_search_query_string = + parse_string ~grammar_entry:RocqParser.search_query_alone +end *) + + include Lp open Error From b8de4085190fcd7dca8411910480d4855738ef0a Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Mon, 15 Dec 2025 16:01:38 +0100 Subject: [PATCH 53/58] add parser for Rocq. FIX ME --- src/parsing/parser.ml | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index 77d306b47..ad55233de 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -188,22 +188,30 @@ sig end -(* module Rocq : +module Rocq : sig val parse_search_string : Lexing.position -> string -> Syntax.search + (* TODO update the next comment *) (** [parse_search_query_string f s] returns a stream of parsed terms from string [s] which comes from file [f] ([f] can be anything). *) end = struct - include Aux(struct let parsing = RocqLexer.) - let parse_string ~grammar_entry fname s = - stream_of_lexbuf ~grammar_entry ~fname (Sedlexing.Utf8.from_string s) + include Aux(struct + type token = LpLexer.token + let the_current_token = LpParser.the_current_token + let get_token x _ = LpLexer.token x + (* parsing = LpParser.new_parsing *) + end) + (* exported functions *) - let parse_search_query_string = - parse_string ~grammar_entry:RocqParser.search_query_alone -end *) + let parse_search_string = parse_entry_string LpParser.search + + (* let parse_search_string = + parse_entry_string LpParser.search *) + (* parse_string ~grammar_entry:RocqParser.search_query_alone *) +end include Lp From c4184a36f3223d1baa7d6d84c70eb03474a74a9b Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Tue, 16 Dec 2025 17:56:40 +0100 Subject: [PATCH 54/58] fix error handling in search queries --- src/tool/indexing.ml | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 164368d07..424ac2fea 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -883,9 +883,12 @@ module UserLevelQueries = struct let search_cmd_gen ss ~from ~how_many ~(fail:?err_desc:string -> string -> string) - ~pp_results ~tag:(hb,he) fmt q = + ~pp_results ~tag:(hb,he) q fmt s = try let mok _ = None in + let q = match q with + | None -> Parsing.Parser.Lp.parse_search_string (lexing_opt None) s + | Some q -> q in let items = ItemSet.bindings (answer_query ~mok ss [] q) in let resultsno = List.length items in let _,items = Lplib.List.cut items from in @@ -913,11 +916,18 @@ module UserLevelQueries = struct Lplib.Base.out fmt "%s" (fail (Format.asprintf "Error: %s@." (Printexc.to_string exn))) + let search_cmd_txt_string ss ~dbpath s = + Stdlib.(the_dbpath := dbpath); + Format.asprintf "%a" (search_cmd_gen ss ~from:0 ~how_many:999999 + ~fail:(fun ?err_desc x -> Common.Error.fatal_no_pos ?err_desc "%s" x) + ~pp_results:pp_results_list ~tag:("","") None) s + let search_cmd_txt_query ss ~dbpath q = Stdlib.(the_dbpath := dbpath); Format.asprintf "%a" (search_cmd_gen ss ~from:0 ~how_many:999999 ~fail:(fun ?err_desc x -> Common.Error.fatal_no_pos ?err_desc "%s" x) - ~pp_results:pp_results_list ~tag:("","")) q + ~pp_results:pp_results_list ~tag:("","") (Some q)) "" + (** [transform_ascii_to_unicode s] replaces all the occurences of ["->"] and ["forall"] with ["→"] and ["Π"] in the search query [s] *) @@ -943,15 +953,14 @@ module UserLevelQueries = struct ) ~pp_results:(html_of_results_list from) ~tag:("

    "," Date: Wed, 17 Dec 2025 10:06:06 +0100 Subject: [PATCH 55/58] rocq parser fails in parsing rocq --- src/parsing/parser.ml | 14 +++++++++----- src/parsing/rocqLexer.ml | 10 +++++++++- src/parsing/rocqParser.mly | 1 + 3 files changed, 19 insertions(+), 6 deletions(-) diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index ad55233de..e7d054bf9 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -199,14 +199,18 @@ end = struct include Aux(struct - type token = LpLexer.token - let the_current_token = LpParser.the_current_token - let get_token x _ = LpLexer.token x - (* parsing = LpParser.new_parsing *) + type token = RocqLexer.token + let the_current_token = RocqLexer.the_current_token + let get_token x _ = RocqLexer.token x () end) (* exported functions *) - let parse_search_string = parse_entry_string LpParser.search + let parse = + MenhirLib.Convert.Simplified.traditional2revised + RocqParser.search_query_alone + let token lb = RocqLexer.token lb + let parse_lexbuf lb = parse (token lb) + let parse_search_string pos s = parse_entry_string parse_lexbuf pos s (* let parse_search_string = parse_entry_string LpParser.search *) diff --git a/src/parsing/rocqLexer.ml b/src/parsing/rocqLexer.ml index 3040e0c8c..ea9e92941 100644 --- a/src/parsing/rocqLexer.ml +++ b/src/parsing/rocqLexer.ml @@ -227,6 +227,14 @@ let token : lexbuf -> unit -> token * Lexing.position * Lexing.position = | Sedlexing.InvalidCodepoint k -> fail lb ("Invalid Utf8 code point " ^ string_of_int k) +let dummy_token = (EOF, Lexing.dummy_pos, Lexing.dummy_pos) + let token = - let r = ref (EOF, Lexing.dummy_pos, Lexing.dummy_pos) in fun lb () -> + let r = ref dummy_token in fun lb () -> Debug.(record_time Lexing (fun () -> r := token lb ())); !r + +let the_current_token : + (token * Lexing.position * Lexing.position) Stdlib.ref = + Stdlib.ref dummy_token + +let current_token() : token = let (t,_,_) = !the_current_token in t diff --git a/src/parsing/rocqParser.mly b/src/parsing/rocqParser.mly index 3858621af..ce5e7fa9f 100644 --- a/src/parsing/rocqParser.mly +++ b/src/parsing/rocqParser.mly @@ -17,6 +17,7 @@ if ps = [] then t else make_pos (startpos,endpos) (P_Prod(ps,t)) exception Error + %} From ca9cc439265d47aa40c76cdc67f795adf0faadc4 Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Wed, 17 Dec 2025 12:52:21 +0100 Subject: [PATCH 56/58] reset rocq parser --- src/parsing/dune | 2 +- src/parsing/parser.ml | 9 +- src/parsing/rocqLexer.ml | 193 ++++- src/parsing/rocqParser.ml | 1658 ++++++++++++++++++++++++++++++++++++ src/parsing/rocqParser.mly | 270 ------ 5 files changed, 1822 insertions(+), 310 deletions(-) create mode 100644 src/parsing/rocqParser.ml delete mode 100644 src/parsing/rocqParser.mly diff --git a/src/parsing/dune b/src/parsing/dune index db34692cc..4ed10159a 100644 --- a/src/parsing/dune +++ b/src/parsing/dune @@ -8,7 +8,7 @@ ; (menhir (flags --explain --external-tokens LpLexer) (modules lpParser)) -(menhir (flags --explain --external-tokens RocqLexer) (modules rocqParser)) +; (menhir (flags --explain --external-tokens RocqLexer) (modules rocqParser)) (ocamllex dkLexer) diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index e7d054bf9..382872e17 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -201,17 +201,20 @@ end include Aux(struct type token = RocqLexer.token let the_current_token = RocqLexer.the_current_token - let get_token x _ = RocqLexer.token x () + let get_token x _ = RocqLexer.token x end) (* exported functions *) - +(* let parse = MenhirLib.Convert.Simplified.traditional2revised RocqParser.search_query_alone let token lb = RocqLexer.token lb let parse_lexbuf lb = parse (token lb) - let parse_search_string pos s = parse_entry_string parse_lexbuf pos s + let parse_search_string pos s = parse_entry_string parse_lexbuf pos s *) + let parse_term_string = parse_entry_string RocqParser.term + let parse_rwpatt_string = parse_entry_string RocqParser.rwpatt + let parse_search_string = parse_entry_string RocqParser.search (* let parse_search_string = parse_entry_string LpParser.search *) (* parse_string ~grammar_entry:RocqParser.search_query_alone *) diff --git a/src/parsing/rocqLexer.ml b/src/parsing/rocqLexer.ml index ea9e92941..80de94c26 100644 --- a/src/parsing/rocqLexer.ml +++ b/src/parsing/rocqLexer.ml @@ -1,16 +1,16 @@ -(** Lexer for Rocq syntax, using Sedlex, a Utf8 lexer generator. *) +(** Lexer for Lambdapi syntax, using Sedlex, a Utf8 lexer generator. *) open Lplib open Sedlexing open Common open Pos -let remove_first : Sedlexing.lexbuf -> string = fun lb -> +let remove_first : lexbuf -> string = fun lb -> Utf8.sub_lexeme lb 1 (lexeme_length lb - 1) -let remove_last : Sedlexing.lexbuf -> string = fun lb -> +let remove_last : lexbuf -> string = fun lb -> Utf8.sub_lexeme lb 0 (lexeme_length lb - 1) -let remove_ends : Sedlexing.lexbuf -> string = fun lb -> +let remove_ends : lexbuf -> string = fun lb -> Utf8.sub_lexeme lb 1 (lexeme_length lb - 2) exception SyntaxError of strloc @@ -18,10 +18,10 @@ exception SyntaxError of strloc let syntax_error : Lexing.position * Lexing.position -> string -> 'a = fun pos msg -> raise (SyntaxError (Pos.make_pos pos msg)) -let fail : Sedlexing.lexbuf -> string -> 'a = fun lb msg -> - syntax_error (Sedlexing.lexing_positions lb) msg +let fail : lexbuf -> string -> 'a = fun lb msg -> + syntax_error (lexing_positions lb) msg -let invalid_character : Sedlexing.lexbuf -> 'a = fun lb -> +let invalid_character : lexbuf -> 'a = fun lb -> fail lb "Invalid character" (** Tokens. *) @@ -30,16 +30,78 @@ type token = | EOF (* keywords in alphabetical order *) + | ABORT + | ADMIT + | ADMITTED + | APPLY + | AS + | ASSERT of bool (* true for "assertnot" *) + | ASSOCIATIVE + | ASSUME + | BEGIN + | BUILTIN + | CHANGE + | COERCE_RULE + | COMMUTATIVE + | COMPUTE + | CONSTANT + | DEBUG + | END + | EVAL + | FAIL + | FLAG | GENERALIZE + | HAVE | IN + | INDUCTION + | INDUCTIVE + | INFIX + | INJECTIVE | LET + | NOTATION + | OPAQUE + | OPEN + | ORELSE + | POSTFIX + | PREFIX + | PRINT + | PRIVATE + | PROOFTERM + | PROTECTED + | PROVER + | PROVER_TIMEOUT + | QUANTIFIER + | REFINE + | REFLEXIVITY + | REMOVE + | REPEAT + | REQUIRE + | REWRITE | RULE + | SEARCH + | SEQUENTIAL + | SET + | SIMPLIFY + | SOLVE + | SYMBOL + | SYMMETRY + | TRY | TYPE_QUERY | TYPE_TERM + | UNIF_RULE + | VERBOSE + | WHY3 + | WITH (* other tokens *) + | DEBUG_FLAGS of (bool * string) + (* Tuple constructor (with parens) required by Menhir. *) | INT of string + | QINT of Path.t * string + | FLOAT of string + | SIDE of Pratter.associativity | STRINGLIT of string + | SWITCH of bool (* symbols *) | ARROW @@ -48,17 +110,18 @@ type token = | COMMA | COLON | DOT - | EXISTS - | FORALL - | FUN + | EQUIV + | HOOK_ARROW | LAMBDA + | L_CU_BRACKET | L_PAREN | L_SQ_BRACKET | PI + | R_CU_BRACKET | R_PAREN | R_SQ_BRACKET | SEMICOLON - | THICKARROW + | TURNSTILE | UNDERSCORE | VBAR @@ -111,9 +174,9 @@ let is_regid : string -> bool = fun s -> (** Unqualified escaped identifiers are any non-empty sequence of characters (except "|}") between "{|" and "|}". *) -let notbars = [%sedlex.regexp? Star (Compl '|')] +let nobars = [%sedlex.regexp? Star (Compl '|')] let escid = [%sedlex.regexp? - "{|", notbars, '|', Star ('|' | Compl (Chars "|}"), notbars, '|'), '}'] + "{|", nobars, '|', Star ('|' | Compl (Chars "|}"), nobars, '|'), '}'] (** [escape s] converts a string [s] into an escaped identifier if it is not regular. We do not check whether [s] contains ["|}"]. FIXME? *) @@ -139,44 +202,103 @@ let rec token lb = | "/*" -> comment token 0 lb (* keywords *) - | "exists" -> EXISTS (* in Coq *) - | "forall" -> FORALL (* in Coq *) - | "fun" -> FUN (* in Coq *) + | "abort" -> ABORT + | "admit" -> ADMIT + | "admitted" -> ADMITTED + | "apply" -> APPLY + | "as" -> AS + | "assert" -> ASSERT false + | "assertnot" -> ASSERT true + | "associative" -> ASSOCIATIVE + | "assume" -> ASSUME + | "begin" -> BEGIN + | "builtin" -> BUILTIN + | "change" -> CHANGE + | "coerce_rule" -> COERCE_RULE + | "commutative" -> COMMUTATIVE + | "compute" -> COMPUTE + | "constant" -> CONSTANT + | "debug" -> DEBUG + | "end" -> END + | "eval" -> EVAL + | "fail" -> FAIL + | "flag" -> FLAG | "generalize" -> GENERALIZE + | "have" -> HAVE | "in" -> IN + | "induction" -> INDUCTION + | "inductive" -> INDUCTIVE + | "infix" -> INFIX + | "injective" -> INJECTIVE + | "left" -> SIDE(Pratter.Left) | "let" -> LET + | "notation" -> NOTATION + | "off" -> SWITCH(false) + | "on" -> SWITCH(true) + | "opaque" -> OPAQUE + | "open" -> OPEN + | "orelse" -> ORELSE + | "postfix" -> POSTFIX + | "prefix" -> PREFIX + | "print" -> PRINT + | "private" -> PRIVATE + | "proofterm" -> PROOFTERM + | "protected" -> PROTECTED + | "prover" -> PROVER + | "prover_timeout" -> PROVER_TIMEOUT + | "quantifier" -> QUANTIFIER + | "refine" -> REFINE + | "reflexivity" -> REFLEXIVITY + | "remove" -> REMOVE + | "repeat" -> REPEAT + | "require" -> REQUIRE + | "rewrite" -> REWRITE + | "right" -> SIDE(Pratter.Right) | "rule" -> RULE + | "search" -> SEARCH + | "sequential" -> SEQUENTIAL + | "set" -> SET + | "simplify" -> SIMPLIFY + | "solve" -> SOLVE + | "symbol" -> SYMBOL + | "symmetry" -> SYMMETRY + | "try" -> TRY | "type" -> TYPE_QUERY | "TYPE" -> TYPE_TERM + | "unif_rule" -> UNIF_RULE + | "verbose" -> VERBOSE + | "why3" -> WHY3 + | "with" -> WITH (* other tokens *) + | '+', Plus lowercase -> DEBUG_FLAGS(true, remove_first lb) + | '-', Plus lowercase -> DEBUG_FLAGS(false, remove_first lb) | int -> INT(Utf8.lexeme lb) + | float -> FLOAT(Utf8.lexeme lb) | string -> STRINGLIT(Utf8.sub_lexeme lb 1 (lexeme_length lb - 2)) (* symbols *) | 0x2254 (* ≔ *) -> ASSIGN - | 0x2192 (* → *) -> ARROW (* not in Coq! *) - | "->" -> ARROW (* in Coq *) - | "=>" -> THICKARROW (* in Coq *) + | 0x2192 (* → *) -> ARROW | '`' -> BACKQUOTE | ',' -> COMMA | ':' -> COLON | '.' -> DOT - | 0x03bb (* λ *) -> LAMBDA (* not in Coq! *) + | 0x2261 (* ≡ *) -> EQUIV + | 0x21aa (* ↪ *) -> HOOK_ARROW + | 0x03bb (* λ *) -> LAMBDA + | '{' -> L_CU_BRACKET | '(' -> L_PAREN | '[' -> L_SQ_BRACKET | 0x03a0 (* Π *) -> PI + | '}' -> R_CU_BRACKET | ')' -> R_PAREN | ']' -> R_SQ_BRACKET | ';' -> SEMICOLON + | 0x22a2 (* ⊢ *) -> TURNSTILE | '|' -> VBAR | '_' -> UNDERSCORE - (* rocq identifiers *) - | "\\/" -> UID("∨") - | "/\\" -> UID("∧") - | "~" -> UID("¬") - (* identifiers *) | regid -> UID(Utf8.lexeme lb) | escid -> UID(remove_useless_escape(Utf8.lexeme lb)) @@ -199,6 +321,7 @@ and qid expl ids lb = match%sedlex lb with | oneline_comment -> qid expl ids lb | "/*" -> comment (qid expl ids) 0 lb + | int -> QINT(List.rev ids, Utf8.lexeme lb) | regid, '.' -> qid expl (remove_last lb :: ids) lb | escid, '.' -> qid expl (remove_useless_escape(remove_last lb) :: ids) lb | regid -> @@ -207,9 +330,7 @@ and qid expl ids lb = | escid -> if expl then QID_EXPL(remove_useless_escape (Utf8.lexeme lb) :: ids) else QID(remove_useless_escape (Utf8.lexeme lb) :: ids) - | _ -> - fail lb ("Invalid identifier: \"" - ^ String.concat "." (List.rev (Utf8.lexeme lb :: ids)) ^ "\".") + | _ -> fail lb ("Invalid identifier: \"" ^ Utf8.lexeme lb ^ "\".") and comment next i lb = match%sedlex lb with @@ -219,19 +340,19 @@ and comment next i lb = | any -> comment next i lb | _ -> invalid_character lb -(** [token buf] is a lexing function on buffer [buf] that can be passed to - a parser. *) -let token : lexbuf -> unit -> token * Lexing.position * Lexing.position = - fun lb () -> try with_tokenizer token lb () with - | Sedlexing.MalFormed -> fail lb "Not Utf8 encoded file" - | Sedlexing.InvalidCodepoint k -> +(** [token lb] is a lexing function on [lb] that can be passed to a parser. *) +let token : lexbuf -> token * Lexing.position * Lexing.position = + fun lb -> try Sedlexing.with_tokenizer token lb () with + | MalFormed -> fail lb "Not Utf8 encoded file" + | InvalidCodepoint k -> fail lb ("Invalid Utf8 code point " ^ string_of_int k) let dummy_token = (EOF, Lexing.dummy_pos, Lexing.dummy_pos) let token = - let r = ref dummy_token in fun lb () -> - Debug.(record_time Lexing (fun () -> r := token lb ())); !r + let r = ref dummy_token in fun lb -> + Debug.(record_time Lexing (fun () -> r := token lb)); !r + let the_current_token : (token * Lexing.position * Lexing.position) Stdlib.ref = diff --git a/src/parsing/rocqParser.ml b/src/parsing/rocqParser.ml new file mode 100644 index 000000000..b9d3aebbe --- /dev/null +++ b/src/parsing/rocqParser.ml @@ -0,0 +1,1658 @@ +open Lplib +open Common open Pos open Logger +open Syntax +open Core +open LpLexer +open Lexing +open Sedlexing + +let log = LpParser.log + +(* token management *) + +let string_of_token = function + | EOF -> "end of file" + | ABORT -> "abort" + | ADMIT -> "admit" + | ADMITTED -> "admitted" + | APPLY -> "apply" + | ARROW -> "→" + | AS -> "as" + | ASSERT _ -> "assert or assertnot" + | ASSIGN -> "≔" + | ASSOCIATIVE -> "associative" + | ASSUME -> "assume" + | BACKQUOTE -> "`" + | BEGIN -> "begin" + | BUILTIN -> "builtin" + | CHANGE -> "change" + | COERCE_RULE -> "coerce_rule" + | COLON -> ":" + | COMMA -> "," + | COMMUTATIVE -> "commutative" + | COMPUTE -> "compute" + | CONSTANT -> "constant" + | DEBUG -> "debug" + | DEBUG_FLAGS _ -> "debug flags" + | DOT -> "." + | END -> "end" + | EQUIV -> "≡" + | EVAL -> "eval" + | FAIL -> "fail" + | FLAG -> "flag" + | FLOAT _ -> "float" + | GENERALIZE -> "generalize" + | HAVE -> "have" + | HOOK_ARROW -> "↪" + | IN -> "in" + | INDUCTION -> "induction" + | INDUCTIVE -> "inductive" + | INFIX -> "infix" + | INJECTIVE -> "injective" + | INT _ -> "integer" + | LAMBDA -> "λ" + | LET -> "let" + | L_CU_BRACKET -> "{" + | L_PAREN -> "(" + | L_SQ_BRACKET -> "[" + | NOTATION -> "notation" + | OPAQUE -> "opaque" + | OPEN -> "open" + | ORELSE -> "orelse" + | PI -> "Π" + | POSTFIX -> "postfix" + | PREFIX -> "prefix" + | PRINT -> "print" + | PRIVATE -> "private" + | PROOFTERM -> "proofterm" + | PROTECTED -> "protected" + | PROVER -> "prover" + | PROVER_TIMEOUT -> "prover_timeout" + | QID _ -> "qualified identifier" + | QID_EXPL _ -> "@-prefixed qualified identifier" + | QINT _ -> "qualified integer" + | QUANTIFIER -> "quantifier" + | REFINE -> "refine" + | REFLEXIVITY -> "reflexivity" + | REMOVE -> "remove" + | REPEAT -> "repeat" + | REQUIRE -> "require" + | REWRITE -> "rewrite" + | RULE -> "rule" + | R_CU_BRACKET -> "}" + | R_PAREN -> ")" + | R_SQ_BRACKET -> "]" + | SEARCH -> "search" + | SEQUENTIAL -> "sequential" + | SEMICOLON -> ";" + | SET -> "set" + | SIDE _ -> "left or right" + | SIMPLIFY -> "simplify" + | SOLVE -> "solve" + | STRINGLIT _ -> "string literal" + | SWITCH false -> "off" + | SWITCH true -> "on or off" + | SYMBOL -> "symbol" + | SYMMETRY -> "symmetry" + | TRY -> "try" + | TURNSTILE -> "⊢" + | TYPE_QUERY -> "type" + | TYPE_TERM -> "TYPE" + | UID _ -> "non-qualified identifier" + | UID_EXPL _ -> "@-prefixed non-qualified identifier" + | UID_META _ -> "?-prefixed metavariable number" + | UID_PATT _ -> "$-prefixed non-qualified identifier" + | UNDERSCORE -> "_" + | UNIF_RULE -> "unif_rule" + | VBAR -> "|" + | VERBOSE -> "verbose" + | WHY3 -> "why3" + | WITH -> "with" + +let pp_token ppf t = Base.string ppf (string_of_token t) + +let the_current_token : (token * position * position) Stdlib.ref = + Stdlib.ref dummy_token + +let current_token() : token = let (t,_,_) = !the_current_token in t + +let current_pos() : position * position = + let (_,p1,p2) = !the_current_token in (p1,p2) +(* +let new_parsing (entry:lexbuf -> 'a) (lb:lexbuf): 'a = + let t = !the_current_token in + let reset() = the_current_token := t in + the_current_token := LpLexer.token lb; + try let r = entry lb in begin reset(); r end + with e -> begin reset(); raise e end + *) +let expected (msg:string) (tokens:token list): 'a = + if msg <> "" then syntax_error (current_pos()) ("Expected: "^msg^".") + else + match tokens with + | [] -> assert false + | t::ts -> + let soft = string_of_token in + syntax_error (current_pos()) + (List.fold_left (fun s t -> s^", "^soft t) ("Expected: "^soft t) ts + ^".") + +let consume_token (lb:lexbuf) : unit = + the_current_token := LpLexer.token lb; + if log_enabled() then + let (t,p1,p2) = !the_current_token in + let p = locate (p1,p2) in + log "read new token %a %a" Pos.short (Some p) pp_token t + +(* building positions and terms *) + +let extend_pos (*s:string*) (lps:position * position): 'a -> 'a loc = + let p1 = fst lps and p2 = fst (current_pos()) in + let p2 = + if p2.pos_cnum > p2.pos_bol then + {p2 with pos_cnum = p2.pos_cnum - 1} + else p2 + in + (*if log_enabled() then + log "extend_pos %s %a -> %a" s Pos.pp_lexing lps Pos.pp_lexing lps2;*) + make_pos (p1,p2) + +let qid_of_path (lps: position * position): + string list -> (string list * string) loc = function + | [] -> assert false + | id::mp -> make_pos lps (List.rev mp, id) + +let make_abst (pos1:position) (ps:p_params list) (t:p_term) (pos2:position) + :p_term = + if ps = [] then t + else extend_pos (*__FUNCTION__*) (pos1,pos2) (P_Abst(ps,t)) + +let make_prod (pos1:position) (ps:p_params list) (t:p_term) (pos2:position) + :p_term = + if ps = [] then t + else extend_pos (*__FUNCTION__*) (pos1,pos2) (P_Prod(ps,t)) + +let ident_of_term pos1 {elt; _} = + match elt with + | P_Iden({elt=([], x); pos}, _) -> Pos.make pos x + | _ -> LpLexer.syntax_error pos1 "not an unqualified identifier." + +(* generic parsing functions *) + +let list (elt:lexbuf -> 'a) (lb:lexbuf): 'a list = + if log_enabled() then log "%s" __FUNCTION__; + let acc = ref [] in + (try while true do acc := elt lb :: !acc done with SyntaxError _ -> ()); + List.rev !acc + +let nelist (elt:lexbuf -> 'a) (lb:lexbuf): 'a list = + if log_enabled() then log "%s" __FUNCTION__; + let x = elt lb in + x :: list elt lb + +let consume (token:token) (lb:lexbuf): unit = + if current_token() = token then consume_token lb + else expected "" [token] + +let prefix (token:token) (elt:lexbuf -> 'a) (lb:lexbuf): 'a = + consume token lb; elt lb + +let alone (entry:lexbuf -> 'a) (lb:lexbuf): 'a = + let x = entry lb in if current_token() != EOF then expected "" [EOF] else x + +(* parsing functions *) + +let consume_STRINGLIT (lb:lexbuf): string = + match current_token() with + | STRINGLIT s -> + consume_token lb; + s + | _ -> + expected "" [STRINGLIT""] + +let consume_SWITCH (lb:lexbuf): bool = + match current_token() with + | SWITCH b -> + consume_token lb; + b + | _ -> + expected "" [SWITCH true] + +let consume_INT (lb:lexbuf): string = + match current_token() with + | INT s -> + consume_token lb; + s + | _ -> + expected "" [INT""] + +let consume_DEBUG_FLAGS (lb:lexbuf): bool * string = + match current_token() with + | DEBUG_FLAGS(b,s) -> + consume_token lb; + b,s + | _ -> + expected "" [DEBUG_FLAGS(true,"")] + +let qid (lb:lexbuf): (string list * string) loc = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | UID s -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 ([], s) + | QID p -> + let pos1 = current_pos() in + consume_token lb; + qid_of_path pos1 p + | _ -> + expected "" [UID"";QID[]] + +let qid_expl (lb:lexbuf): (string list * string) loc = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | UID_EXPL s -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 ([], s) + | QID_EXPL p -> + let pos1 = current_pos() in + consume_token lb; + qid_of_path pos1 p + | _ -> + expected "" [UID_EXPL"";QID_EXPL[]] + +let uid (lb:lexbuf): string loc = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | UID s -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 s + | _ -> + expected "" [UID""] + +let param (lb:lexbuf): string loc option = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | UID s -> + let pos1 = current_pos() in + consume_token lb; + Some (make_pos pos1 s) + | UNDERSCORE -> + consume_token lb; + None + | _ -> + expected "non-qualified identifier or \"_\"" [UID"";UNDERSCORE] + +let int (lb:lexbuf): string = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | INT s -> + consume_token lb; + s + | _ -> + expected "integer" [INT""] + +let float_or_int (lb:lexbuf): string = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | INT s + | FLOAT s -> + consume_token lb; + s + | _ -> + expected "integer or float" [INT"";FLOAT""] + +let path (lb:lexbuf): string list loc = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + (*| UID s -> + let pos1 = current_pos() in + LpLexer.syntax_error pos1 "Unqualified identifier"*) + | QID p -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (List.rev p) + | _ -> + expected "" [QID[]] + +let qid_or_rule (lb:lexbuf): (string list * string) loc = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | UID s -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 ([], s) + | QID p -> + let pos1 = current_pos() in + consume_token lb; + qid_of_path pos1 p + | UNIF_RULE -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (Sign.Ghost.path, Unif_rule.equiv.sym_name) + | COERCE_RULE -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (Sign.Ghost.path, Coercion.coerce.sym_name) + | _ -> + expected "" [UID"";QID[];UNIF_RULE;COERCE_RULE] + +let term_id (lb:lexbuf): p_term = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | UID _ + | QID _ -> + let i = qid lb in + {i with elt=P_Iden(i, false)} + | UID_EXPL _ + | QID_EXPL _ -> + let i = qid_expl lb in + {i with elt=P_Iden(i, true)} + | _ -> + expected "" [UID"";QID[];UID_EXPL"";QID_EXPL[]] + +(* commands *) + +let rec command pos1 (p_sym_mod:p_modifier list) (lb:lexbuf): p_command = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | SIDE _ + | ASSOCIATIVE + | COMMUTATIVE + | CONSTANT + | INJECTIVE + | SEQUENTIAL + | PRIVATE + | OPAQUE + | PROTECTED -> + assert (p_sym_mod = []); + let pos1 = current_pos() in + command pos1 (nelist modifier lb) lb + (* qid *) + | UID _ + | QID _ -> + begin + match p_sym_mod with + | [{elt=P_opaq;_}] -> + let i = qid lb in + extend_pos (*__FUNCTION__*) pos1 (P_opaque i) + | [] -> + expected "command keyword missing" [] + | {elt=P_opaq;_}::{pos;_}::_ -> + expected "an opaque command must be followed by an identifier" [] + | _ -> + expected "" [SYMBOL] + end + | REQUIRE -> + if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) + let pos1 = current_pos() in + consume_token lb; + begin + match current_token() with + | OPEN -> + consume_token lb; + let ps = nelist path lb in + extend_pos (*__FUNCTION__*) pos1 (P_require(Some false,ps)) + | PRIVATE -> + consume_token lb; + begin + match current_token() with + | OPEN -> consume_token lb + | _ -> expected "" [OPEN] + end; + let ps = nelist path lb in + extend_pos (*__FUNCTION__*) pos1 (P_require(Some true,ps)) + | _ -> + let ps = nelist path lb in + begin + match current_token() with + | AS -> + let p = + match ps with + | [p] -> p + | _ -> expected "a single module before \"as\"" [] + in + consume_token lb; + let i = uid lb in + extend_pos (*__FUNCTION__*) pos1 (P_require_as(p,i)) + | _ -> + extend_pos (*__FUNCTION__*) pos1 (P_require(None,ps)) + end + end + | OPEN -> + let prv = + match p_sym_mod with + | [] -> false + | {elt=P_expo Term.Privat;_}::_ -> true + | _ -> expected "" [SYMBOL] + in + let pos1 = current_pos() in + consume_token lb; + let l = list path lb in + extend_pos (*__FUNCTION__*) pos1 (P_open(prv,l)) + | SYMBOL -> + let pos1 = current_pos() in + consume_token lb; + let p_sym_nam = uid lb in + let p_sym_arg = list params lb in + begin + match current_token() with + | COLON -> + consume_token lb; + let p_sym_typ = Some(term lb) in + begin + match current_token() with + | BEGIN -> + consume_token lb; + let p_sym_prf = Some (proof lb) in + let p_sym_def = false in + let sym = + {p_sym_mod; p_sym_nam; p_sym_arg; p_sym_typ; + p_sym_trm=None; p_sym_def; p_sym_prf} + in extend_pos (*__FUNCTION__*) pos1 (P_symbol(sym)) + | ASSIGN -> + consume_token lb; + let p_sym_trm, p_sym_prf = term_proof lb in + let p_sym_def = true in + let sym = + {p_sym_mod; p_sym_nam; p_sym_arg; p_sym_typ; + p_sym_trm; p_sym_def; p_sym_prf} + in extend_pos (*__FUNCTION__*) pos1 (P_symbol(sym)) + | SEMICOLON -> + let p_sym_trm = None in + let p_sym_def = false in + let p_sym_prf = None in + let sym = + {p_sym_mod; p_sym_nam; p_sym_arg; p_sym_typ; + p_sym_trm; p_sym_def; p_sym_prf} + in extend_pos (*__FUNCTION__*) pos1 (P_symbol(sym)) + | _ -> + expected "" [BEGIN;ASSIGN] + end + | ASSIGN -> + consume_token lb; + let p_sym_trm, p_sym_prf = term_proof lb in + let p_sym_def = true in + let p_sym_typ = None in + let sym = + {p_sym_mod; p_sym_nam; p_sym_arg; p_sym_typ; + p_sym_trm; p_sym_def; p_sym_prf} + in extend_pos (*__FUNCTION__*) pos1 (P_symbol(sym)) + | _ -> + expected "" [COLON;ASSIGN] + end + | L_PAREN + | L_SQ_BRACKET -> + let pos1 = current_pos() in + let xs = nelist params lb in + consume INDUCTIVE lb; + let i = inductive lb in + let is = list (prefix WITH inductive) lb in + extend_pos (*__FUNCTION__*) pos1 (P_inductive(p_sym_mod,xs,i::is)) + | INDUCTIVE -> + let pos1 = current_pos() in + consume_token lb; + let i = inductive lb in + let is = list (prefix WITH inductive) lb in + extend_pos (*__FUNCTION__*) pos1 (P_inductive(p_sym_mod,[],i::is)) + | RULE -> + if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) + let pos1 = current_pos() in + consume_token lb; + let r = rule lb in + let rs = list (prefix WITH rule) lb in + extend_pos (*__FUNCTION__*) pos1 (P_rules(r::rs)) + | UNIF_RULE -> + if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) + let pos1 = current_pos() in + consume_token lb; + let e = equation lb in + consume HOOK_ARROW lb; + consume L_SQ_BRACKET lb; + let eq1 = equation lb in + let eqs = list (prefix SEMICOLON equation) lb in + let es = eq1::eqs in + consume R_SQ_BRACKET lb; + (* FIXME: give sensible positions instead of Pos.none and P.appl. *) + let equiv = P.qiden Sign.Ghost.path Unif_rule.equiv.sym_name in + let cons = P.qiden Sign.Ghost.path Unif_rule.cons.sym_name in + let mk_equiv (t, u) = P.appl (P.appl equiv t) u in + let lhs = mk_equiv e in + let es = List.rev_map mk_equiv es in + let (en, es) = List.(hd es, tl es) in + let cat e es = P.appl (P.appl cons e) es in + let rhs = List.fold_right cat es en in + let r = extend_pos (*__FUNCTION__*) pos1 (lhs, rhs) in + extend_pos (*__FUNCTION__*) pos1 (P_unif_rule(r)) + | COERCE_RULE -> + if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) + let pos1 = current_pos() in + consume_token lb; + let r = rule lb in + extend_pos (*__FUNCTION__*) pos1 (P_coercion r) + | BUILTIN -> + if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) + let pos1 = current_pos() in + consume_token lb; + begin + match current_token() with + | STRINGLIT s -> + consume_token lb; + consume ASSIGN lb; + let i = qid lb in + extend_pos (*__FUNCTION__*) pos1 (P_builtin(s,i)) + | _ -> + expected "" [STRINGLIT""] + end + | NOTATION -> + if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) + let pos1 = current_pos() in + consume_token lb; + let i = qid lb in + let n = notation lb in + extend_pos (*__FUNCTION__*) pos1 (P_notation(i,n)) + | _ -> + if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) + let pos1 = current_pos() in + let q = query lb in + extend_pos (*__FUNCTION__*) pos1 (P_query(q)) + +and inductive (lb:lexbuf): p_inductive = + let pos0 = current_pos() in + let i = uid lb in + let pos1 = current_pos() in + let ps = list params lb in + consume COLON lb; + let t = term lb in + let pos2 = current_pos() in + let t = make_prod (fst pos1) ps t (snd pos2) in + consume ASSIGN lb; + begin + match current_token() with + | UID _ -> + let c = constructor lb in + let cs = list (prefix VBAR constructor) lb in + let l = c::cs in + extend_pos (*__FUNCTION__*) pos0 (i,t,l) + | VBAR -> + let l = list (prefix VBAR constructor) lb in + extend_pos (*__FUNCTION__*) pos0 (i,t,l) + | SEMICOLON -> + let l = [] in + extend_pos (*__FUNCTION__*) pos0 (i,t,l) + | _ -> + expected "identifier" [] + end + +and constructor (lb:lexbuf): p_ident * p_term = + let i = uid lb in + let pos1 = current_pos() in + let ps = list params lb in + consume COLON lb; + let t = term lb in + i, make_prod (fst pos1) ps t (snd (current_pos())) + +and modifier (lb:lexbuf): p_modifier = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | SIDE d -> + let pos1 = current_pos() in + consume_token lb; + begin + match current_token() with + | ASSOCIATIVE -> + consume_token lb; + extend_pos (*__FUNCTION__*) pos1 + (P_prop (Term.Assoc((d = Pratter.Left)))) + | _ -> + expected "" [ASSOCIATIVE] + end + | ASSOCIATIVE -> + let pos1 = current_pos() in + consume_token lb; + extend_pos (*__FUNCTION__*) pos1 (P_prop (Term.Assoc false)) + | COMMUTATIVE -> + let pos1 = current_pos() in + consume_token lb; + extend_pos (*__FUNCTION__*) pos1 (P_prop Term.Commu) + | CONSTANT -> + let pos1 = current_pos() in + consume_token lb; + extend_pos (*__FUNCTION__*) pos1 (P_prop Term.Const) + | INJECTIVE -> + let pos1 = current_pos() in + consume_token lb; + extend_pos (*__FUNCTION__*) pos1 (P_prop Term.Injec) + | OPAQUE -> + let pos1 = current_pos() in + consume_token lb; + extend_pos (*__FUNCTION__*) pos1 P_opaq + | SEQUENTIAL -> + let pos1 = current_pos() in + consume_token lb; + extend_pos (*__FUNCTION__*) pos1 (P_mstrat Term.Sequen) + | _ -> + exposition lb + +and exposition (lb:lexbuf): p_modifier = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | PRIVATE -> + let pos1 = current_pos() in + consume_token lb; + extend_pos (*__FUNCTION__*) pos1 (P_expo Term.Privat) + | PROTECTED -> + let pos1 = current_pos() in + consume_token lb; + extend_pos (*__FUNCTION__*) pos1 (P_expo Term.Protec) + | _ -> + expected "" [PRIVATE;PROTECTED] + +and notation (lb:lexbuf): string Term.notation = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | INFIX -> + consume_token lb; + begin + match current_token() with + | SIDE d -> + consume_token lb; + let p = float_or_int lb in + Term.Infix(d, p) + | _ -> + let p = float_or_int lb in + Term.Infix(Pratter.Neither, p) + end + | POSTFIX -> + consume_token lb; + let p = float_or_int lb in + Term.Postfix p + | PREFIX -> + consume_token lb; + let p = float_or_int lb in + Term.Prefix p + | QUANTIFIER -> + consume_token lb; + Term.Quant + | _ -> + expected "" [INFIX;POSTFIX;PREFIX;QUANTIFIER] + +and rule (lb:lexbuf): (p_term * p_term) loc = + if log_enabled() then log "%s" __FUNCTION__; + let pos1 = current_pos() in + let l = term lb in + consume HOOK_ARROW lb; + let r = term lb in + extend_pos (*__FUNCTION__*) pos1 (l, r) + +and equation (lb:lexbuf): p_term * p_term = + if log_enabled() then log "%s" __FUNCTION__; + let l = term lb in + consume EQUIV lb; + let r = term lb in + (l, r) + +(* queries *) + +and query (lb:lexbuf): p_query = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | ASSERT b -> + let pos1 = current_pos() in + consume_token lb; + let ps = list params lb in + consume TURNSTILE lb; + let t = term lb in + begin + match current_token() with + | COLON -> + consume_token lb; + let a = term lb in + let pos2 = current_pos() in + let t = make_abst (snd pos1) ps t (fst pos2) in + let a = make_prod (snd pos1) ps a (fst pos2) in + extend_pos (*__FUNCTION__*) pos1 + (P_query_assert(b, P_assert_typing(t,a))) + | EQUIV -> + consume_token lb; + let u = term lb in + let pos2 = current_pos() in + let t = make_abst (snd pos1) ps t (fst pos2) in + let u = make_abst (snd pos1) ps u (fst pos2) in + extend_pos (*__FUNCTION__*) pos1 + (P_query_assert(b, P_assert_conv(t, u))) + | _ -> + expected "" [COLON;EQUIV] + end + | COMPUTE -> + let pos1 = current_pos() in + consume_token lb; + let t = term lb in + extend_pos (*__FUNCTION__*) pos1 + (P_query_normalize(t, {strategy=SNF; steps=None})) + | PRINT -> + let pos1 = current_pos() in + consume_token lb; + begin + match current_token() with + | SEMICOLON -> + extend_pos (*__FUNCTION__*) pos1 (P_query_print None) + | _ -> + let i = qid_or_rule lb in + extend_pos (*__FUNCTION__*) pos1 (P_query_print (Some i)) + end + | PROOFTERM -> + let pos1 = current_pos() in + consume_token lb; + extend_pos (*__FUNCTION__*) pos1 P_query_proofterm + | DEBUG -> + let pos1 = current_pos() in + consume_token lb; + begin + match current_token() with + | SEMICOLON -> + extend_pos (*__FUNCTION__*) pos1 (P_query_debug(true,"")) + | _ -> + let b,s = consume_DEBUG_FLAGS lb in + extend_pos (*__FUNCTION__*) pos1 (P_query_debug(b,s)) + end + | FLAG -> + let pos1 = current_pos() in + consume_token lb; + let s = consume_STRINGLIT lb in + let b = consume_SWITCH lb in + extend_pos (*__FUNCTION__*) pos1 (P_query_flag(s,b)) + | PROVER -> + let pos1 = current_pos() in + consume_token lb; + let s = consume_STRINGLIT lb in + extend_pos (*__FUNCTION__*) pos1 (P_query_prover(s)) + | PROVER_TIMEOUT -> + let pos1 = current_pos() in + consume_token lb; + let n = consume_INT lb in + extend_pos (*__FUNCTION__*) pos1 (P_query_prover_timeout n) + | VERBOSE -> + let pos1 = current_pos() in + consume_token lb; + let n = consume_INT lb in + extend_pos (*__FUNCTION__*) pos1 (P_query_verbose n) + | TYPE_QUERY -> + let pos1 = current_pos() in + consume_token lb; + let t = term lb in + extend_pos (*__FUNCTION__*) pos1 + (P_query_infer(t, {strategy=NONE; steps=None})) + | SEARCH -> + let pos1 = current_pos() in + consume_token lb; + let q = search lb in + extend_pos (*__FUNCTION__*) pos1 (P_query_search q) + | _ -> + expected "query" [] + +and term_proof (lb:lexbuf): p_term option * (p_proof * p_proof_end) option = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | BEGIN -> + consume_token lb; + let p = proof lb in + None, Some p + | _ -> + let t = term lb in + begin + match current_token() with + | BEGIN -> + consume_token lb; + let p = proof lb in + Some t, Some p + | _ -> + Some t, None + end + +(* proofs *) + +and proof (lb:lexbuf): p_proof * p_proof_end = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | L_CU_BRACKET -> + let l = nelist subproof lb in + if current_token() = SEMICOLON then consume_token lb; + let pe = proof_end lb in + l, pe + (*queries*) + | ASSERT _ + | COMPUTE + | DEBUG + | FLAG + | PRINT + | PROOFTERM + | PROVER + | PROVER_TIMEOUT + | SEARCH + | TYPE_QUERY + | VERBOSE + (*tactics*) + | ADMIT + | APPLY + | ASSUME + | CHANGE + | EVAL + | FAIL + | GENERALIZE + | HAVE + | INDUCTION + | ORELSE + | REFINE + | REFLEXIVITY + | REMOVE + | REPEAT + | REWRITE + | SET + | SIMPLIFY + | SOLVE + | SYMMETRY + | TRY + | WHY3 -> + let l = steps lb in + let pe = proof_end lb in + [l], pe + | END + | ABORT + | ADMITTED -> + let pe = proof_end lb in + [], pe + | _ -> + expected "subproof, tactic or query" [] + +and subproof (lb:lexbuf): p_proofstep list = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | L_CU_BRACKET -> + consume_token lb; + let l = steps lb in + consume R_CU_BRACKET lb; + l + | _ -> + expected "" [L_CU_BRACKET] + +and steps (lb:lexbuf): p_proofstep list = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + (*queries*) + | ASSERT _ + | COMPUTE + | DEBUG + | FLAG + | PRINT + | PROOFTERM + | PROVER + | PROVER_TIMEOUT + | SEARCH + | TYPE_QUERY + | VERBOSE + (*tactics*) + | ADMIT + | APPLY + | ASSUME + | CHANGE + | EVAL + | FAIL + | GENERALIZE + | HAVE + | INDUCTION + | ORELSE + | REFINE + | REFLEXIVITY + | REMOVE + | REPEAT + | REWRITE + | SET + | SIMPLIFY + | SOLVE + | SYMMETRY + | TRY + | WHY3 -> + let a = step lb in + let acc = list (prefix SEMICOLON step) lb in + if current_token() = SEMICOLON then consume_token lb; + a::acc + | END + | ABORT + | ADMITTED -> + [] + | _ -> + expected "tactic or query" [] + +and step (lb:lexbuf): p_proofstep = + if log_enabled() then log "%s" __FUNCTION__; + let t = tactic lb in + let l = list subproof lb in + Tactic(t, l) + +and proof_end (lb:lexbuf): p_proof_end = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | ABORT -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 Syntax.P_proof_abort + | ADMITTED -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 Syntax.P_proof_admitted + | END -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 Syntax.P_proof_end + | _ -> + expected "" [ABORT;ADMITTED;END] + +and tactic (lb:lexbuf): p_tactic = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + (*queries*) + | ASSERT _ + | COMPUTE + | DEBUG + | FLAG + | PRINT + | PROOFTERM + | PROVER + | PROVER_TIMEOUT + | SEARCH + | TYPE_QUERY + | VERBOSE -> + let pos1 = current_pos() in + extend_pos (*__FUNCTION__*) pos1 (P_tac_query (query lb)) + | ADMIT -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 P_tac_admit + | APPLY -> + let pos1 = current_pos() in + consume_token lb; + let t = term lb in + extend_pos (*__FUNCTION__*) pos1 (P_tac_apply t) + | ASSUME -> + let pos1 = current_pos() in + consume_token lb; + let xs = nelist param lb in + extend_pos (*__FUNCTION__*) pos1 (P_tac_assume xs) + | CHANGE -> + let pos1 = current_pos() in + consume_token lb; + let t = term lb in + extend_pos (*__FUNCTION__*) pos1 (P_tac_change t) + | EVAL -> + let pos1 = current_pos() in + consume_token lb; + let t = term lb in + extend_pos (*__FUNCTION__*) pos1 (P_tac_eval t) + | FAIL -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 P_tac_fail + | GENERALIZE -> + let pos1 = current_pos() in + consume_token lb; + let i = uid lb in + extend_pos (*__FUNCTION__*) pos1 (P_tac_generalize i) + | HAVE -> + let pos1 = current_pos() in + consume_token lb; + let i = uid lb in + consume COLON lb; + let t = term lb in + extend_pos (*__FUNCTION__*) pos1 (P_tac_have(i,t)) + | INDUCTION -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 P_tac_induction + | ORELSE -> + let pos1 = current_pos() in + consume_token lb; + let t1 = tactic lb in + let t2 = tactic lb in + extend_pos (*__FUNCTION__*) pos1 (P_tac_orelse(t1,t2)) + | REFINE -> + let pos1 = current_pos() in + consume_token lb; + let t = term lb in + extend_pos (*__FUNCTION__*) pos1 (P_tac_refine t) + | REFLEXIVITY -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 P_tac_refl + | REMOVE -> + let pos1 = current_pos() in + consume_token lb; + let xs = nelist uid lb in + extend_pos (*__FUNCTION__*) pos1 (P_tac_remove xs) + | REPEAT -> + let pos1 = current_pos() in + consume_token lb; + let t = tactic lb in + extend_pos (*__FUNCTION__*) pos1 (P_tac_repeat t) + | REWRITE -> + let pos1 = current_pos() in + consume_token lb; + begin + match current_token() with + | SIDE d -> + consume_token lb; + begin + match current_token() with + | DOT -> + consume_token lb; + let p = rwpatt_bracket lb in + let t = term lb in + let b = d <> Pratter.Left in + extend_pos (*__FUNCTION__*) pos1 (P_tac_rewrite(b,Some p,t)) + | _ -> + let t = term lb in + let b = d <> Pratter.Left in + extend_pos (*__FUNCTION__*) pos1 (P_tac_rewrite(b,None,t)) + end + | DOT -> + consume_token lb; + let p = rwpatt_bracket lb in + let t = term lb in + extend_pos (*__FUNCTION__*) pos1 (P_tac_rewrite(true,Some p,t)) + | _ -> + let t = term lb in + extend_pos (*__FUNCTION__*) pos1 (P_tac_rewrite(true,None,t)) + end + | SET -> + let pos1 = current_pos() in + consume_token lb; + let i = uid lb in + consume ASSIGN lb; + let t = term lb in + extend_pos (*__FUNCTION__*) pos1 (P_tac_set(i,t)) + | SIMPLIFY -> + let pos1 = current_pos() in + consume_token lb; + begin + match current_token() with + | UID _ + | QID _ -> + extend_pos (*__FUNCTION__*) pos1 (P_tac_simpl(SimpSym(qid lb))) + | RULE -> + consume_token lb; + begin + match current_token() with + | SWITCH false -> + consume_token lb; + extend_pos (*__FUNCTION__*) pos1 (P_tac_simpl SimpBetaOnly) + | _ -> expected "" [SWITCH false] + end + | _ -> + extend_pos (*__FUNCTION__*) pos1 (P_tac_simpl SimpAll) + end + | SOLVE -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 P_tac_solve + | SYMMETRY -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 P_tac_sym + | TRY -> + let pos1 = current_pos() in + consume_token lb; + let t = tactic lb in + extend_pos (*__FUNCTION__*) pos1 (P_tac_try t) + | WHY3 -> + let pos1 = current_pos() in + consume_token lb; + begin + match current_token() with + | STRINGLIT s -> + extend_pos (*__FUNCTION__*) pos1 (P_tac_why3 (Some s)) + | _ -> + make_pos pos1 (P_tac_why3 None) + end + | _ -> + expected "tactic" [] + +and rwpatt_content (lb:lexbuf): p_rwpatt = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + (* bterm *) + | BACKQUOTE + | PI + | LAMBDA + | LET + (* aterm *) + | UID _ + | QID _ + | UID_EXPL _ + | QID_EXPL _ + | UNDERSCORE + | TYPE_TERM + | UID_META _ + | UID_PATT _ + | L_PAREN + | L_SQ_BRACKET + | INT _ + | QINT _ + | STRINGLIT _ -> + let pos1 = current_pos() in + let t1 = term lb in + begin + match current_token() with + | IN -> + consume_token lb; + let t2 = term lb in + begin + match current_token() with + | IN -> + consume_token lb; + let t3 = term lb in + let x = ident_of_term pos1 t2 in + extend_pos (*__FUNCTION__*) pos1 + (Rw_TermInIdInTerm(t1,(x,t3))) + | _ -> + let x = ident_of_term pos1 t1 in + extend_pos (*__FUNCTION__*) pos1 (Rw_IdInTerm(x,t2)) + end + | AS -> + consume_token lb; + let t2 = term lb in + begin + match current_token() with + | IN -> + consume_token lb; + let t3 = term lb in + let x = ident_of_term pos1 t2 in + extend_pos (*__FUNCTION__*) pos1 + (Rw_TermAsIdInTerm(t1,(x,t3))) + | _ -> + expected "" [IN] + end + | _ -> + extend_pos (*__FUNCTION__*) pos1 (Rw_Term(t1)) + end + | IN -> + let pos1 = current_pos() in + consume_token lb; + let t1 = term lb in + begin + match current_token() with + | IN -> + consume_token lb; + let t2 = term lb in + let x = ident_of_term pos1 t1 in + extend_pos (*__FUNCTION__*) pos1 (Rw_InIdInTerm(x,t2)) + | _ -> + extend_pos (*__FUNCTION__*) pos1 (Rw_InTerm(t1)) + end + | _ -> + expected "term or keyword \"in\"" [] + +and rwpatt_bracket (lb:lexbuf): p_rwpatt = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | L_SQ_BRACKET -> + consume_token lb; + let p = rwpatt_content lb in + consume R_SQ_BRACKET lb; (*add info on opening bracket*) + p + | _ -> + expected "" [L_SQ_BRACKET] + +and rwpatt (lb:lexbuf): p_rwpatt = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | DOT -> + consume_token lb; + rwpatt_bracket lb + | _ -> + expected "" [DOT] + +(* terms *) + +and params (lb:lexbuf): p_params = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | L_PAREN -> + consume_token lb; + let ps = nelist param lb in + begin + match current_token() with + | COLON -> + consume_token lb; + let typ = term lb in + consume R_PAREN lb; + ps, Some typ, false + | R_PAREN -> + consume_token lb; + ps, None, false + | _ -> + expected "" [COLON;R_PAREN] + end + | L_SQ_BRACKET -> + consume_token lb; + let ps = nelist param lb in + begin + match current_token() with + | COLON -> + consume_token lb; + let typ = term lb in + consume R_SQ_BRACKET lb; + ps, Some typ, true + | R_SQ_BRACKET -> + consume_token lb; + ps, None, true + | _ -> + expected "" [COLON;R_SQ_BRACKET] + end + | _ -> + let x = param lb in + [x], None, false + +and term (lb:lexbuf): p_term = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + (* bterm *) + | BACKQUOTE + | PI + | LAMBDA + | LET -> + bterm lb + (* aterm *) + | UID _ + | QID _ + | UID_EXPL _ + | QID_EXPL _ + | UNDERSCORE + | TYPE_TERM + | UID_META _ + | UID_PATT _ + | L_PAREN + | L_SQ_BRACKET + | INT _ + | QINT _ + | STRINGLIT _ -> + let pos1 = current_pos() in + let h = aterm lb in + app pos1 h lb + | _ -> + expected "term" [] + +and app (pos1:position * position) (t: p_term) (lb:lexbuf): p_term = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + (* aterm *) + | UID _ + | QID _ + | UID_EXPL _ + | QID_EXPL _ + | UNDERSCORE + | TYPE_TERM + | UID_META _ + | UID_PATT _ + | L_PAREN + | L_SQ_BRACKET + | INT _ + | QINT _ + | STRINGLIT _ -> + let u = aterm lb in + app pos1 (extend_pos (*__FUNCTION__*) pos1 (P_Appl(t,u))) lb + (* bterm *) + | BACKQUOTE + | PI + | LAMBDA + | LET -> + let u = bterm lb in + extend_pos (*__FUNCTION__*) pos1 (P_Appl(t,u)) + (* other cases *) + | ARROW -> + consume_token lb; + let u = term lb in + extend_pos (*__FUNCTION__*) pos1 (P_Arro(t,u)) + | _ -> + t + +and bterm (lb:lexbuf): p_term = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | BACKQUOTE -> + let pos1 = current_pos() in + consume_token lb; + let q = term_id lb in + let b = binder lb in + let b = extend_pos (*__FUNCTION__*) pos1 (P_Abst(fst b, snd b)) in + extend_pos (*__FUNCTION__*) pos1 (P_Appl(q, b)) + | PI -> + let pos1 = current_pos() in + consume_token lb; + let b = binder lb in + extend_pos (*__FUNCTION__*) pos1 (P_Prod(fst b, snd b)) + | LAMBDA -> + let pos1 = current_pos() in + consume_token lb; + let b = binder lb in + extend_pos (*__FUNCTION__*) pos1 (P_Abst(fst b, snd b)) + | LET -> + let pos1 = current_pos() in + consume_token lb; + let x = uid lb in + let a = list params lb in + begin + match current_token() with + | COLON -> + consume_token lb; + let b = Some (term lb) in + consume ASSIGN lb; + let t = term lb in + consume IN lb; + let u = term lb in + extend_pos (*__FUNCTION__*) pos1 (P_LLet(x, a, b, t, u)) + | _ -> + let b = None in + consume ASSIGN lb; + let t = term lb in + consume IN lb; + let u = term lb in + extend_pos (*__FUNCTION__*) pos1 (P_LLet(x, a, b, t, u)) + end + | _ -> + expected "" [BACKQUOTE;PI;LAMBDA;LET] + +and aterm (lb:lexbuf): p_term = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | UID _ + | QID _ + | UID_EXPL _ + | QID_EXPL _ -> + term_id lb + | UNDERSCORE -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 P_Wild + | TYPE_TERM -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 P_Type + | UID_META s -> + let pos1 = current_pos() in + consume_token lb; + let i = make_pos pos1 s in + begin + match current_token() with + | DOT -> + consume_token lb; + extend_pos (*__FUNCTION__*) pos1 + (P_Meta(i,Array.of_list (env lb))) + | _ -> + {i with elt=P_Meta(i,[||])} + end + | UID_PATT s -> + let pos1 = current_pos() in + consume_token lb; + let i = + if s = "_" then None else Some(make_pos pos1 s) in + begin + match current_token() with + | DOT -> + consume_token lb; + extend_pos (*__FUNCTION__*) pos1 + (P_Patt(i, Some(Array.of_list (env lb)))) + | _ -> + make_pos pos1 (P_Patt(i, None)) + end + | L_PAREN -> + let pos1 = current_pos() in + consume_token lb; + let t = term lb in + consume R_PAREN lb; + extend_pos (*__FUNCTION__*) pos1 (P_Wrap(t)) + | L_SQ_BRACKET -> + let pos1 = current_pos() in + consume_token lb; + let t = term lb in + consume R_SQ_BRACKET lb; + extend_pos (*__FUNCTION__*) pos1 (P_Expl(t)) + | INT n -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (P_NLit([],n)) + | QINT(p,n) -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (P_NLit(p,n)) + | STRINGLIT s -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (P_SLit s) + | _ -> + expected "identifier, \"_\", or term between parentheses or square \ + brackets" [] + +and env (lb:lexbuf): p_term list = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | L_SQ_BRACKET -> + consume_token lb; + begin + match current_token() with + | R_SQ_BRACKET -> + consume_token lb; + [] + | _ -> + let t = term lb in + let ts = list (prefix SEMICOLON term) lb in + consume R_SQ_BRACKET lb; + t::ts + end + | _ -> + expected "" [L_SQ_BRACKET] + +and binder (lb:lexbuf): p_params list * p_term = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | UID _ + | UNDERSCORE -> + let s = param lb in + begin + match current_token() with + | UID _ + | UNDERSCORE + | L_PAREN + | L_SQ_BRACKET -> + let ps = list params lb in + consume COMMA lb; + let p = [s], None, false in + p::ps, term lb + | COMMA -> + consume_token lb; + let p = [s], None, false in + [p], term lb + | COLON -> + consume_token lb; + let a = term lb in + consume COMMA lb; + let p = [s], Some a, false in + [p], term lb + | _ -> + expected "parameter list" + [UID"";UNDERSCORE;L_PAREN;L_SQ_BRACKET;COMMA] + end + | L_PAREN -> + let ps = nelist params lb in + begin + match current_token() with + | COMMA -> + consume_token lb; + ps, term lb + | _ -> + expected "" [COMMA] + end + | L_SQ_BRACKET -> + let ps = nelist params lb in + begin + match current_token() with + | COMMA -> + consume_token lb; + ps, term lb + | _ -> + expected "" [COMMA] + end + | _ -> + expected "" [UID"";UNDERSCORE;L_PAREN;L_SQ_BRACKET] + +(* search *) + +and generalize (lb:lexbuf): bool = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | GENERALIZE -> consume_token lb; true + | _ -> false + +and relation (lb:lexbuf): relation option = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | UID "=" -> consume_token lb; Some Exact + | UID ">" -> consume_token lb; Some Inside + | UID ("≥"|">=") -> consume_token lb; None + | _ -> expected "\">\", \"=\", \"≥\",\">=\"" [] + +and where (lb:lexbuf): bool * relation option = + if log_enabled() then log "%s" __FUNCTION__; + let r = relation lb in + let g = generalize lb in + g,r + +and asearch (lb:lexbuf): search = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | UID "name" -> + begin + consume_token lb; + match current_token() with + | UID "=" -> + consume_token lb; + QBase(QName (uid lb).elt) + | _ -> expected "\"=\"" [] + end + | TYPE_QUERY -> + begin + consume_token lb; + match current_token() with + | UID ("≥"|">=") -> + consume_token lb; + let g = generalize lb in + let t = term lb in + QBase(QSearch(t,g,Some(QType None))) + | _ -> expected "\"≥\",\">=\"" [] + end + | UID "anywhere" -> + begin + consume_token lb; + match current_token() with + | UID ("≥"|">=") -> + consume_token lb; + let g = generalize lb in + let t = term lb in + QBase(QSearch(t,g,None)) + | _ -> expected "\"≥\",\">=\"" [] + end + | RULE -> + consume_token lb; + let r = relation lb in + let g = generalize lb in + let t = term lb in + QBase(QSearch(t,g,Some(QXhs(r,None)))) + | UID "spine" -> + begin + consume_token lb; + let r = relation lb in + let g = generalize lb in + let t = term lb in + QBase(QSearch(t,g,Some(QType(Some(Spine r))))) + end + | UID "concl" -> + begin + consume_token lb; + let r = relation lb in + let g = generalize lb in + let t = term lb in + QBase(QSearch(t,g,Some(QType(Some(Conclusion r))))) + end + | UID "hyp" -> + begin + consume_token lb; + let r = relation lb in + let g = generalize lb in + let t = term lb in + QBase(QSearch(t,g,Some(QType(Some(Hypothesis r))))) + end + | UID "lhs" -> + begin + consume_token lb; + let r = relation lb in + let g = generalize lb in + let t = term lb in + QBase(QSearch(t,g,Some(QXhs(r,Some Lhs)))) + end + | UID "rhs" -> + begin + consume_token lb; + let r = relation lb in + let g = generalize lb in + let t = term lb in + QBase(QSearch(t,g,Some(QXhs(r,Some Rhs)))) + end + | L_PAREN -> + consume_token lb; + let q = search lb in + consume R_PAREN lb; + q + | _ -> + expected "name, anywhere, rule, lhs, rhs, type, concl, hyp, spine" [] + +and csearch (lb:lexbuf): search = + if log_enabled() then log "%s" __FUNCTION__; + let aq = asearch lb in + match current_token() with + | COMMA -> + let aqs = list (prefix COMMA asearch) lb in + List.fold_left (fun x aq -> QOp(x,Intersect,aq)) aq aqs + | _ -> + aq + +and ssearch (lb:lexbuf): search = + if log_enabled() then log "%s" __FUNCTION__; + let cq = csearch lb in + match current_token() with + | SEMICOLON -> + let cqs = list (prefix SEMICOLON csearch) lb in + List.fold_left (fun x cq -> QOp(x,Union,cq)) cq cqs + | _ -> + cq + +and search (lb:lexbuf): search = + if log_enabled() then log "%s" __FUNCTION__; + let q = ssearch lb in + let qids = list (prefix VBAR qid) lb in + let path_of_qid qid = + let p,n = qid.elt in + if p = [] then n + else Format.asprintf "%a.%a" Print.path p Print.uid n + in + List.fold_left (fun x qid -> QFilter(x,Path(path_of_qid qid))) q qids + +let command (lb:lexbuf): p_command = + if log_enabled() then log "------------------- start reading command"; + consume_token lb; + if current_token() = EOF then raise End_of_file + else + let c = command (Lexing.dummy_pos,Lexing.dummy_pos) [] lb in + match current_token() with + | SEMICOLON -> c + | _ -> expected "" [SEMICOLON] diff --git a/src/parsing/rocqParser.mly b/src/parsing/rocqParser.mly deleted file mode 100644 index ce5e7fa9f..000000000 --- a/src/parsing/rocqParser.mly +++ /dev/null @@ -1,270 +0,0 @@ -(** Rocq parser, using the parser generator Menhir. *) - -%{ - open Lplib - open Common open Pos - open Syntax - open Core - - let qid_of_path lps = function - | [] -> assert false - | id::mp -> make_pos lps (List.rev mp, id) - - let make_abst startpos ps t endpos = - if ps = [] then t else make_pos (startpos,endpos) (P_Abst(ps,t)) - - let make_prod startpos ps t endpos = - if ps = [] then t else make_pos (startpos,endpos) (P_Prod(ps,t)) - - exception Error - -%} - - -// end of file - -%token EOF - -// keywords in alphabetical order - -%token GENERALIZE -%token IN -%token LET -%token RULE -%token TYPE_QUERY -%token TYPE_TERM - -// other tokens - -%token INT -%token STRINGLIT - -// symbols - -%token ARROW -%token ASSIGN -%token BACKQUOTE -%token COMMA -%token COLON -%token DOT -%token EXISTS -%token FORALL -%token FUN -%token LAMBDA -%token L_PAREN -%token L_SQ_BRACKET -%token PI -%token R_PAREN -%token R_SQ_BRACKET -%token SEMICOLON -%token THICKARROW -%token UNDERSCORE -%token VBAR - -// identifiers - -%token UID -%token UID_EXPL -%token UID_META -%token UID_PATT -%token QID -%token QID_EXPL - -// types - -%start search_query_alone - -%% - -search_query_alone: - | q=search_query EOF - { q } - -uid: s=UID { make_pos $sloc s} - -param_list: - | x=param { ([x], None, false) } - | L_PAREN xs=param+ COLON a=term R_PAREN { (xs, Some(a), false) } - | L_SQ_BRACKET xs=param+ a=preceded(COLON, term)? R_SQ_BRACKET - { (xs, a, true) } - -fun_param_list: - | x=param { ([x], None, false) } - | L_PAREN xs=param+ COLON a=term R_PAREN { (xs, Some(a), false) } - -param: - | s=uid { Some s } - | UNDERSCORE { None } - -term: - | t=bterm { t } - | t=saterm { t } - | t=saterm u=bterm { make_pos $sloc (P_Appl(t,u)) } - | t=saterm ARROW u=term { make_pos $sloc (P_Arro(t, u)) } - -bterm: - | BACKQUOTE q=term_id b=binder - { let b = make_pos $loc(b) (P_Abst(fst b, snd b)) in - make_pos $sloc (P_Appl(q, b)) } - | EXISTS b=rocqbinder(COMMA) - { {(List.fold_right - (fun bin res -> - Pos.none (P_Appl( - Pos.none (P_Iden(Pos.none ([],"∃"), false)), - Pos.none (P_Abst([bin], res))))) - (fst b) - (snd b)) - with pos = Some (Pos.locate $sloc) } - } (* in Coq *) - | FORALL b=rocqbinder(COMMA) - { make_pos $sloc (P_Prod(fst b, snd b)) } (* in Coq *) - | PI b=binder - { make_pos $sloc (P_Prod(fst b, snd b)) } (* not in Coq! *) - | LAMBDA b=binder - { make_pos $sloc (P_Abst(fst b, snd b)) } (* not in Coq! *) - | FUN b=rocqbinder(THICKARROW) - { make_pos $sloc (P_Abst(fst b, snd b)) } (* in Coq *) - | LET x=uid a=param_list* b=preceded(COLON, term)? ASSIGN t=term IN u=term - { make_pos $sloc (P_LLet(x, a, b, t, u)) } - -saterm: - | t=saterm u=aterm { make_pos $sloc (P_Appl(t,u)) } - | t=aterm { t } - -aterm: - | ti=term_id { ti } - | UNDERSCORE { make_pos $sloc P_Wild } - | TYPE_TERM { make_pos $sloc P_Type } - | s=UID_META ts=env? - { let i = make_pos $loc(s) s - and ts = match ts with None -> [||] | Some ts -> Array.of_list ts in - make_pos $sloc (P_Meta(i,ts)) } - | s=UID_PATT e=env? - { let i = if s = "_" then None else Some(make_pos $loc(s) s) in - make_pos $sloc (P_Patt(i, Option.map Array.of_list e)) } - | L_PAREN t=term R_PAREN { make_pos $sloc (P_Wrap(t)) } - | L_SQ_BRACKET t=term R_SQ_BRACKET { make_pos $sloc (P_Expl(t)) } - | n=INT { make_pos $sloc (P_NLit ([],n)) } - | s=STRINGLIT { make_pos $sloc (P_SLit s) } - -env: DOT L_SQ_BRACKET ts=separated_list(SEMICOLON, term) R_SQ_BRACKET { ts } - -term_id: - | i=qid { make_pos $sloc (P_Iden(i, false)) } - | i=qid_expl { make_pos $sloc (P_Iden(i, true)) } - -qid: - | s=UID { make_pos $sloc ([], s) } - | p=QID { qid_of_path $sloc p } - -qid_expl: - | s=UID_EXPL { make_pos $sloc ([], s) } - | p=QID_EXPL { qid_of_path $sloc p } - -binder: - | ps=param_list+ COMMA t=term { (ps, t) } - | p=param COLON a=term COMMA t=term { ([[p], Some a, false], t) } - -rocqbinder(terminator): - | ps=fun_param_list+ a=preceded(COLON, term)? terminator t=term - { if a = None then - (ps, t) - else if List.for_all (fun (_,typ,_) -> typ = None) ps then - (List.map (fun (v,_,b) -> v,a,b) ps, t) - else - raise Error - } - -maybe_generalize: - | g = GENERALIZE? - { g <> None } - -where: - | u = UID g=maybe_generalize - { g, match u with - | "=" -> Some Syntax.Exact - | ">" -> Some Syntax.Inside - | "≥" - | ">=" -> None - | _ -> - LpLexer.syntax_error $sloc - "Only \">\", \"=\", \"≥\" and \">=\" accepted" - } - -asearch_query: - (* "type" is a keyword... *) - | TYPE_QUERY gw=where t=aterm - { let g,w = gw in - if w <> None then - LpLexer.syntax_error $sloc - "Only \"≥\" and \">=\" accepted for \"type\"" - else - Syntax.QBase(QSearch(t,g,Some (QType None))) } - | RULE gw=where t=aterm - { let g,w = gw in - Syntax.QBase(QSearch(t,g,Some (QXhs(w,None)))) } - | k=UID gw=where t=aterm - { let open Syntax in - let g,w = gw in - match k,t.elt with - | "name",P_Iden(id,false) -> - assert (fst id.elt = []) ; - if w <> Some Exact then - LpLexer.syntax_error $sloc - "Only \"=\" accepted for \"name\"" - else if g = true then - LpLexer.syntax_error $sloc - "\"generalize\" cannot be used with \"name\"" - else - QBase(QName (snd id.elt)) - | "name",_ -> - LpLexer.syntax_error $sloc "Path prefix expected after \"name:\"" - | "anywhere",_ -> - if w <> None then - LpLexer.syntax_error $sloc - "Only \"≥\" and \">=\" accepted for \"anywhere\"" - else - QBase(QSearch(t,g,None)) - | "spine",_ -> - QBase(QSearch(t,g,Some (QType (Some (Spine w))))) - | "concl",_ -> - QBase(QSearch(t,g,Some (QType (Some (Conclusion w))))) - | "hyp",_ -> - QBase(QSearch(t,g,Some (QType (Some (Hypothesis w))))) - | "lhs",_ -> - QBase(QSearch(t,g,Some (QXhs(w,Some Lhs)))) - | "rhs",_ -> - QBase(QSearch(t,g,Some (QXhs(w,Some Rhs)))) - | _,_ -> - LpLexer.syntax_error $sloc ("Unknown keyword: " ^ k) - } - | L_PAREN q=search_query R_PAREN - { q } - -csearch_query: - | q=asearch_query - { q } - | q1=csearch_query COMMA q2=asearch_query - { Syntax.QOp (q1,Syntax.Intersect,q2) } - -ssearch_query: - | q=csearch_query - { q } - | q1=ssearch_query SEMICOLON q2=csearch_query - { Syntax.QOp (q1,Syntax.Union,q2) } - -search_query: - | q=ssearch_query - { q } - | q=search_query VBAR qid=qid - { let p,n = qid.elt in - let path = - if p = [] then n - else - Format.asprintf "%a.%a" Core.Print.path p Core.Print.uid n in - Syntax.QFilter (q,Path path) } - | q=search_query VBAR s=STRINGLIT - { let re = Str.regexp s in - Syntax.QFilter (q,RegExp re) } - -%% From 0b4510cc539f11ca7586f0df05ffa2ed61db8c32 Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Wed, 17 Dec 2025 20:02:06 +0100 Subject: [PATCH 57/58] Fix the Rocq parser --- src/parsing/parser.ml | 17 +- src/parsing/rocqLexer.ml | 166 +----- src/parsing/rocqParser.ml | 1018 ++++--------------------------------- src/tool/indexing.ml | 2 +- 4 files changed, 139 insertions(+), 1064 deletions(-) diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index 382872e17..d8f1f232f 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -119,7 +119,9 @@ let new_parsing (entry:lexbuf -> 'a) (lb:lexbuf): 'a = try Some(entry lb) with | End_of_file -> Option.iter close_in icopt; None + | RocqLexer.SyntaxError{pos=None; _} | SyntaxError{pos=None; _} -> assert false + | RocqLexer.SyntaxError{pos=Some pos; elt} | SyntaxError{pos=Some pos; elt} -> parser_fatal pos "Syntax error. %s" elt @@ -200,7 +202,7 @@ end include Aux(struct type token = RocqLexer.token - let the_current_token = RocqLexer.the_current_token + let the_current_token = RocqParser.the_current_token let get_token x _ = RocqLexer.token x end) (* exported functions *) @@ -234,8 +236,11 @@ let path_of_string : string -> Path.t = fun s -> | QID p, _, _ -> List.rev p | _ -> fatal_no_pos "Syntax error: \"%s\" is not a path." s end - with SyntaxError _ -> - fatal_no_pos "Syntax error: \"%s\" is not a path." s + with + SyntaxError _ + | RocqLexer.SyntaxError _ -> + fatal_no_pos "Syntax error: \"%s\" is not a path." s + (** [qident_of_string s] converts the string [s] into a qident. *) let qident_of_string : string -> Core.Term.qident = fun s -> @@ -247,8 +252,10 @@ let qident_of_string : string -> Core.Term.qident = fun s -> | _ -> fatal_no_pos "Syntax error: \"%s\" is not a qualified identifier." s end - with SyntaxError _ -> - fatal_no_pos "Syntax error: \"%s\" is not a qualified identifier." s + with + | RocqLexer.SyntaxError _ + | SyntaxError _ -> + fatal_no_pos "Syntax error: \"%s\" is not a qualified identifier." s (** [parse_file fname] selects and runs the correct parser on file [fname], by looking at its extension. *) diff --git a/src/parsing/rocqLexer.ml b/src/parsing/rocqLexer.ml index 80de94c26..533a90b24 100644 --- a/src/parsing/rocqLexer.ml +++ b/src/parsing/rocqLexer.ml @@ -1,4 +1,4 @@ -(** Lexer for Lambdapi syntax, using Sedlex, a Utf8 lexer generator. *) +(** Lexer for Rocq syntax, using Sedlex, a Utf8 lexer generator. *) open Lplib open Sedlexing @@ -30,78 +30,17 @@ type token = | EOF (* keywords in alphabetical order *) - | ABORT - | ADMIT - | ADMITTED - | APPLY - | AS - | ASSERT of bool (* true for "assertnot" *) - | ASSOCIATIVE - | ASSUME - | BEGIN - | BUILTIN - | CHANGE - | COERCE_RULE - | COMMUTATIVE - | COMPUTE - | CONSTANT - | DEBUG - | END - | EVAL - | FAIL - | FLAG | GENERALIZE - | HAVE | IN - | INDUCTION - | INDUCTIVE - | INFIX - | INJECTIVE | LET - | NOTATION - | OPAQUE - | OPEN - | ORELSE - | POSTFIX - | PREFIX - | PRINT - | PRIVATE - | PROOFTERM - | PROTECTED - | PROVER - | PROVER_TIMEOUT - | QUANTIFIER - | REFINE - | REFLEXIVITY - | REMOVE - | REPEAT - | REQUIRE - | REWRITE | RULE - | SEARCH - | SEQUENTIAL - | SET - | SIMPLIFY - | SOLVE - | SYMBOL - | SYMMETRY - | TRY | TYPE_QUERY | TYPE_TERM - | UNIF_RULE - | VERBOSE - | WHY3 - | WITH (* other tokens *) - | DEBUG_FLAGS of (bool * string) - (* Tuple constructor (with parens) required by Menhir. *) | INT of string - | QINT of Path.t * string - | FLOAT of string - | SIDE of Pratter.associativity + (* | QINT of Path.t * string *) | STRINGLIT of string - | SWITCH of bool (* symbols *) | ARROW @@ -110,18 +49,17 @@ type token = | COMMA | COLON | DOT - | EQUIV - | HOOK_ARROW + | EXISTS + | FORALL + | FUN | LAMBDA - | L_CU_BRACKET | L_PAREN | L_SQ_BRACKET | PI - | R_CU_BRACKET | R_PAREN | R_SQ_BRACKET | SEMICOLON - | TURNSTILE + | THICKARROW | UNDERSCORE | VBAR @@ -202,103 +140,44 @@ let rec token lb = | "/*" -> comment token 0 lb (* keywords *) - | "abort" -> ABORT - | "admit" -> ADMIT - | "admitted" -> ADMITTED - | "apply" -> APPLY - | "as" -> AS - | "assert" -> ASSERT false - | "assertnot" -> ASSERT true - | "associative" -> ASSOCIATIVE - | "assume" -> ASSUME - | "begin" -> BEGIN - | "builtin" -> BUILTIN - | "change" -> CHANGE - | "coerce_rule" -> COERCE_RULE - | "commutative" -> COMMUTATIVE - | "compute" -> COMPUTE - | "constant" -> CONSTANT - | "debug" -> DEBUG - | "end" -> END - | "eval" -> EVAL - | "fail" -> FAIL - | "flag" -> FLAG + | "exists" -> EXISTS (* in Coq *) + | "forall" -> FORALL (* in Coq *) + | "fun" -> FUN (* in Coq *) | "generalize" -> GENERALIZE - | "have" -> HAVE | "in" -> IN - | "induction" -> INDUCTION - | "inductive" -> INDUCTIVE - | "infix" -> INFIX - | "injective" -> INJECTIVE - | "left" -> SIDE(Pratter.Left) | "let" -> LET - | "notation" -> NOTATION - | "off" -> SWITCH(false) - | "on" -> SWITCH(true) - | "opaque" -> OPAQUE - | "open" -> OPEN - | "orelse" -> ORELSE - | "postfix" -> POSTFIX - | "prefix" -> PREFIX - | "print" -> PRINT - | "private" -> PRIVATE - | "proofterm" -> PROOFTERM - | "protected" -> PROTECTED - | "prover" -> PROVER - | "prover_timeout" -> PROVER_TIMEOUT - | "quantifier" -> QUANTIFIER - | "refine" -> REFINE - | "reflexivity" -> REFLEXIVITY - | "remove" -> REMOVE - | "repeat" -> REPEAT - | "require" -> REQUIRE - | "rewrite" -> REWRITE - | "right" -> SIDE(Pratter.Right) | "rule" -> RULE - | "search" -> SEARCH - | "sequential" -> SEQUENTIAL - | "set" -> SET - | "simplify" -> SIMPLIFY - | "solve" -> SOLVE - | "symbol" -> SYMBOL - | "symmetry" -> SYMMETRY - | "try" -> TRY | "type" -> TYPE_QUERY | "TYPE" -> TYPE_TERM - | "unif_rule" -> UNIF_RULE - | "verbose" -> VERBOSE - | "why3" -> WHY3 - | "with" -> WITH (* other tokens *) - | '+', Plus lowercase -> DEBUG_FLAGS(true, remove_first lb) - | '-', Plus lowercase -> DEBUG_FLAGS(false, remove_first lb) | int -> INT(Utf8.lexeme lb) - | float -> FLOAT(Utf8.lexeme lb) | string -> STRINGLIT(Utf8.sub_lexeme lb 1 (lexeme_length lb - 2)) (* symbols *) | 0x2254 (* ≔ *) -> ASSIGN - | 0x2192 (* → *) -> ARROW + | 0x2192 (* → *) -> ARROW (* not in Coq! *) + | "->" -> ARROW (* in Coq *) + | "=>" -> THICKARROW (* in Coq *) | '`' -> BACKQUOTE | ',' -> COMMA | ':' -> COLON | '.' -> DOT - | 0x2261 (* ≡ *) -> EQUIV - | 0x21aa (* ↪ *) -> HOOK_ARROW - | 0x03bb (* λ *) -> LAMBDA - | '{' -> L_CU_BRACKET + | 0x03bb (* λ *) -> LAMBDA (* not in Coq! *) | '(' -> L_PAREN | '[' -> L_SQ_BRACKET | 0x03a0 (* Π *) -> PI - | '}' -> R_CU_BRACKET | ')' -> R_PAREN | ']' -> R_SQ_BRACKET | ';' -> SEMICOLON - | 0x22a2 (* ⊢ *) -> TURNSTILE | '|' -> VBAR | '_' -> UNDERSCORE + (* rocq identifiers *) + | "\\/" -> UID("∨") + | "/\\" -> UID("∧") + | "~" -> UID("¬") + (* identifiers *) | regid -> UID(Utf8.lexeme lb) | escid -> UID(remove_useless_escape(Utf8.lexeme lb)) @@ -321,7 +200,7 @@ and qid expl ids lb = match%sedlex lb with | oneline_comment -> qid expl ids lb | "/*" -> comment (qid expl ids) 0 lb - | int -> QINT(List.rev ids, Utf8.lexeme lb) + (* | int -> QINT(List.rev ids, Utf8.lexeme lb) *) | regid, '.' -> qid expl (remove_last lb :: ids) lb | escid, '.' -> qid expl (remove_useless_escape(remove_last lb) :: ids) lb | regid -> @@ -352,10 +231,3 @@ let dummy_token = (EOF, Lexing.dummy_pos, Lexing.dummy_pos) let token = let r = ref dummy_token in fun lb -> Debug.(record_time Lexing (fun () -> r := token lb)); !r - - -let the_current_token : - (token * Lexing.position * Lexing.position) Stdlib.ref = - Stdlib.ref dummy_token - -let current_token() : token = let (t,_,_) = !the_current_token in t diff --git a/src/parsing/rocqParser.ml b/src/parsing/rocqParser.ml index b9d3aebbe..7d544e41a 100644 --- a/src/parsing/rocqParser.ml +++ b/src/parsing/rocqParser.ml @@ -2,7 +2,7 @@ open Lplib open Common open Pos open Logger open Syntax open Core -open LpLexer +open RocqLexer open Lexing open Sedlexing @@ -12,90 +12,31 @@ let log = LpParser.log let string_of_token = function | EOF -> "end of file" - | ABORT -> "abort" - | ADMIT -> "admit" - | ADMITTED -> "admitted" - | APPLY -> "apply" | ARROW -> "→" - | AS -> "as" - | ASSERT _ -> "assert or assertnot" | ASSIGN -> "≔" - | ASSOCIATIVE -> "associative" - | ASSUME -> "assume" | BACKQUOTE -> "`" - | BEGIN -> "begin" - | BUILTIN -> "builtin" - | CHANGE -> "change" - | COERCE_RULE -> "coerce_rule" | COLON -> ":" | COMMA -> "," - | COMMUTATIVE -> "commutative" - | COMPUTE -> "compute" - | CONSTANT -> "constant" - | DEBUG -> "debug" - | DEBUG_FLAGS _ -> "debug flags" | DOT -> "." - | END -> "end" - | EQUIV -> "≡" - | EVAL -> "eval" - | FAIL -> "fail" - | FLAG -> "flag" - | FLOAT _ -> "float" | GENERALIZE -> "generalize" - | HAVE -> "have" - | HOOK_ARROW -> "↪" + | EXISTS -> "exists" + | FORALL -> "forall" + | FUN -> "fun" + | THICKARROW -> "=>" | IN -> "in" - | INDUCTION -> "induction" - | INDUCTIVE -> "inductive" - | INFIX -> "infix" - | INJECTIVE -> "injective" | INT _ -> "integer" | LAMBDA -> "λ" | LET -> "let" - | L_CU_BRACKET -> "{" | L_PAREN -> "(" | L_SQ_BRACKET -> "[" - | NOTATION -> "notation" - | OPAQUE -> "opaque" - | OPEN -> "open" - | ORELSE -> "orelse" | PI -> "Π" - | POSTFIX -> "postfix" - | PREFIX -> "prefix" - | PRINT -> "print" - | PRIVATE -> "private" - | PROOFTERM -> "proofterm" - | PROTECTED -> "protected" - | PROVER -> "prover" - | PROVER_TIMEOUT -> "prover_timeout" | QID _ -> "qualified identifier" | QID_EXPL _ -> "@-prefixed qualified identifier" - | QINT _ -> "qualified integer" - | QUANTIFIER -> "quantifier" - | REFINE -> "refine" - | REFLEXIVITY -> "reflexivity" - | REMOVE -> "remove" - | REPEAT -> "repeat" - | REQUIRE -> "require" - | REWRITE -> "rewrite" | RULE -> "rule" - | R_CU_BRACKET -> "}" | R_PAREN -> ")" | R_SQ_BRACKET -> "]" - | SEARCH -> "search" - | SEQUENTIAL -> "sequential" | SEMICOLON -> ";" - | SET -> "set" - | SIDE _ -> "left or right" - | SIMPLIFY -> "simplify" - | SOLVE -> "solve" | STRINGLIT _ -> "string literal" - | SWITCH false -> "off" - | SWITCH true -> "on or off" - | SYMBOL -> "symbol" - | SYMMETRY -> "symmetry" - | TRY -> "try" - | TURNSTILE -> "⊢" | TYPE_QUERY -> "type" | TYPE_TERM -> "TYPE" | UID _ -> "non-qualified identifier" @@ -103,11 +44,7 @@ let string_of_token = function | UID_META _ -> "?-prefixed metavariable number" | UID_PATT _ -> "$-prefixed non-qualified identifier" | UNDERSCORE -> "_" - | UNIF_RULE -> "unif_rule" | VBAR -> "|" - | VERBOSE -> "verbose" - | WHY3 -> "why3" - | WITH -> "with" let pp_token ppf t = Base.string ppf (string_of_token t) @@ -138,7 +75,7 @@ let expected (msg:string) (tokens:token list): 'a = ^".") let consume_token (lb:lexbuf) : unit = - the_current_token := LpLexer.token lb; + the_current_token := RocqLexer.token lb; if log_enabled() then let (t,p1,p2) = !the_current_token in let p = locate (p1,p2) in @@ -210,13 +147,6 @@ let consume_STRINGLIT (lb:lexbuf): string = | _ -> expected "" [STRINGLIT""] -let consume_SWITCH (lb:lexbuf): bool = - match current_token() with - | SWITCH b -> - consume_token lb; - b - | _ -> - expected "" [SWITCH true] let consume_INT (lb:lexbuf): string = match current_token() with @@ -226,13 +156,6 @@ let consume_INT (lb:lexbuf): string = | _ -> expected "" [INT""] -let consume_DEBUG_FLAGS (lb:lexbuf): bool * string = - match current_token() with - | DEBUG_FLAGS(b,s) -> - consume_token lb; - b,s - | _ -> - expected "" [DEBUG_FLAGS(true,"")] let qid (lb:lexbuf): (string list * string) loc = if log_enabled() then log "%s" __FUNCTION__; @@ -294,16 +217,6 @@ let int (lb:lexbuf): string = | _ -> expected "integer" [INT""] -let float_or_int (lb:lexbuf): string = - if log_enabled() then log "%s" __FUNCTION__; - match current_token() with - | INT s - | FLOAT s -> - consume_token lb; - s - | _ -> - expected "integer or float" [INT"";FLOAT""] - let path (lb:lexbuf): string list loc = if log_enabled() then log "%s" __FUNCTION__; match current_token() with @@ -317,29 +230,7 @@ let path (lb:lexbuf): string list loc = | _ -> expected "" [QID[]] -let qid_or_rule (lb:lexbuf): (string list * string) loc = - if log_enabled() then log "%s" __FUNCTION__; - match current_token() with - | UID s -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 ([], s) - | QID p -> - let pos1 = current_pos() in - consume_token lb; - qid_of_path pos1 p - | UNIF_RULE -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 (Sign.Ghost.path, Unif_rule.equiv.sym_name) - | COERCE_RULE -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 (Sign.Ghost.path, Coercion.coerce.sym_name) - | _ -> - expected "" [UID"";QID[];UNIF_RULE;COERCE_RULE] - -let term_id (lb:lexbuf): p_term = +let rec term_id (lb:lexbuf): p_term = if log_enabled() then log "%s" __FUNCTION__; match current_token() with | UID _ @@ -355,769 +246,6 @@ let term_id (lb:lexbuf): p_term = (* commands *) -let rec command pos1 (p_sym_mod:p_modifier list) (lb:lexbuf): p_command = - if log_enabled() then log "%s" __FUNCTION__; - match current_token() with - | SIDE _ - | ASSOCIATIVE - | COMMUTATIVE - | CONSTANT - | INJECTIVE - | SEQUENTIAL - | PRIVATE - | OPAQUE - | PROTECTED -> - assert (p_sym_mod = []); - let pos1 = current_pos() in - command pos1 (nelist modifier lb) lb - (* qid *) - | UID _ - | QID _ -> - begin - match p_sym_mod with - | [{elt=P_opaq;_}] -> - let i = qid lb in - extend_pos (*__FUNCTION__*) pos1 (P_opaque i) - | [] -> - expected "command keyword missing" [] - | {elt=P_opaq;_}::{pos;_}::_ -> - expected "an opaque command must be followed by an identifier" [] - | _ -> - expected "" [SYMBOL] - end - | REQUIRE -> - if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) - let pos1 = current_pos() in - consume_token lb; - begin - match current_token() with - | OPEN -> - consume_token lb; - let ps = nelist path lb in - extend_pos (*__FUNCTION__*) pos1 (P_require(Some false,ps)) - | PRIVATE -> - consume_token lb; - begin - match current_token() with - | OPEN -> consume_token lb - | _ -> expected "" [OPEN] - end; - let ps = nelist path lb in - extend_pos (*__FUNCTION__*) pos1 (P_require(Some true,ps)) - | _ -> - let ps = nelist path lb in - begin - match current_token() with - | AS -> - let p = - match ps with - | [p] -> p - | _ -> expected "a single module before \"as\"" [] - in - consume_token lb; - let i = uid lb in - extend_pos (*__FUNCTION__*) pos1 (P_require_as(p,i)) - | _ -> - extend_pos (*__FUNCTION__*) pos1 (P_require(None,ps)) - end - end - | OPEN -> - let prv = - match p_sym_mod with - | [] -> false - | {elt=P_expo Term.Privat;_}::_ -> true - | _ -> expected "" [SYMBOL] - in - let pos1 = current_pos() in - consume_token lb; - let l = list path lb in - extend_pos (*__FUNCTION__*) pos1 (P_open(prv,l)) - | SYMBOL -> - let pos1 = current_pos() in - consume_token lb; - let p_sym_nam = uid lb in - let p_sym_arg = list params lb in - begin - match current_token() with - | COLON -> - consume_token lb; - let p_sym_typ = Some(term lb) in - begin - match current_token() with - | BEGIN -> - consume_token lb; - let p_sym_prf = Some (proof lb) in - let p_sym_def = false in - let sym = - {p_sym_mod; p_sym_nam; p_sym_arg; p_sym_typ; - p_sym_trm=None; p_sym_def; p_sym_prf} - in extend_pos (*__FUNCTION__*) pos1 (P_symbol(sym)) - | ASSIGN -> - consume_token lb; - let p_sym_trm, p_sym_prf = term_proof lb in - let p_sym_def = true in - let sym = - {p_sym_mod; p_sym_nam; p_sym_arg; p_sym_typ; - p_sym_trm; p_sym_def; p_sym_prf} - in extend_pos (*__FUNCTION__*) pos1 (P_symbol(sym)) - | SEMICOLON -> - let p_sym_trm = None in - let p_sym_def = false in - let p_sym_prf = None in - let sym = - {p_sym_mod; p_sym_nam; p_sym_arg; p_sym_typ; - p_sym_trm; p_sym_def; p_sym_prf} - in extend_pos (*__FUNCTION__*) pos1 (P_symbol(sym)) - | _ -> - expected "" [BEGIN;ASSIGN] - end - | ASSIGN -> - consume_token lb; - let p_sym_trm, p_sym_prf = term_proof lb in - let p_sym_def = true in - let p_sym_typ = None in - let sym = - {p_sym_mod; p_sym_nam; p_sym_arg; p_sym_typ; - p_sym_trm; p_sym_def; p_sym_prf} - in extend_pos (*__FUNCTION__*) pos1 (P_symbol(sym)) - | _ -> - expected "" [COLON;ASSIGN] - end - | L_PAREN - | L_SQ_BRACKET -> - let pos1 = current_pos() in - let xs = nelist params lb in - consume INDUCTIVE lb; - let i = inductive lb in - let is = list (prefix WITH inductive) lb in - extend_pos (*__FUNCTION__*) pos1 (P_inductive(p_sym_mod,xs,i::is)) - | INDUCTIVE -> - let pos1 = current_pos() in - consume_token lb; - let i = inductive lb in - let is = list (prefix WITH inductive) lb in - extend_pos (*__FUNCTION__*) pos1 (P_inductive(p_sym_mod,[],i::is)) - | RULE -> - if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) - let pos1 = current_pos() in - consume_token lb; - let r = rule lb in - let rs = list (prefix WITH rule) lb in - extend_pos (*__FUNCTION__*) pos1 (P_rules(r::rs)) - | UNIF_RULE -> - if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) - let pos1 = current_pos() in - consume_token lb; - let e = equation lb in - consume HOOK_ARROW lb; - consume L_SQ_BRACKET lb; - let eq1 = equation lb in - let eqs = list (prefix SEMICOLON equation) lb in - let es = eq1::eqs in - consume R_SQ_BRACKET lb; - (* FIXME: give sensible positions instead of Pos.none and P.appl. *) - let equiv = P.qiden Sign.Ghost.path Unif_rule.equiv.sym_name in - let cons = P.qiden Sign.Ghost.path Unif_rule.cons.sym_name in - let mk_equiv (t, u) = P.appl (P.appl equiv t) u in - let lhs = mk_equiv e in - let es = List.rev_map mk_equiv es in - let (en, es) = List.(hd es, tl es) in - let cat e es = P.appl (P.appl cons e) es in - let rhs = List.fold_right cat es en in - let r = extend_pos (*__FUNCTION__*) pos1 (lhs, rhs) in - extend_pos (*__FUNCTION__*) pos1 (P_unif_rule(r)) - | COERCE_RULE -> - if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) - let pos1 = current_pos() in - consume_token lb; - let r = rule lb in - extend_pos (*__FUNCTION__*) pos1 (P_coercion r) - | BUILTIN -> - if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) - let pos1 = current_pos() in - consume_token lb; - begin - match current_token() with - | STRINGLIT s -> - consume_token lb; - consume ASSIGN lb; - let i = qid lb in - extend_pos (*__FUNCTION__*) pos1 (P_builtin(s,i)) - | _ -> - expected "" [STRINGLIT""] - end - | NOTATION -> - if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) - let pos1 = current_pos() in - consume_token lb; - let i = qid lb in - let n = notation lb in - extend_pos (*__FUNCTION__*) pos1 (P_notation(i,n)) - | _ -> - if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) - let pos1 = current_pos() in - let q = query lb in - extend_pos (*__FUNCTION__*) pos1 (P_query(q)) - -and inductive (lb:lexbuf): p_inductive = - let pos0 = current_pos() in - let i = uid lb in - let pos1 = current_pos() in - let ps = list params lb in - consume COLON lb; - let t = term lb in - let pos2 = current_pos() in - let t = make_prod (fst pos1) ps t (snd pos2) in - consume ASSIGN lb; - begin - match current_token() with - | UID _ -> - let c = constructor lb in - let cs = list (prefix VBAR constructor) lb in - let l = c::cs in - extend_pos (*__FUNCTION__*) pos0 (i,t,l) - | VBAR -> - let l = list (prefix VBAR constructor) lb in - extend_pos (*__FUNCTION__*) pos0 (i,t,l) - | SEMICOLON -> - let l = [] in - extend_pos (*__FUNCTION__*) pos0 (i,t,l) - | _ -> - expected "identifier" [] - end - -and constructor (lb:lexbuf): p_ident * p_term = - let i = uid lb in - let pos1 = current_pos() in - let ps = list params lb in - consume COLON lb; - let t = term lb in - i, make_prod (fst pos1) ps t (snd (current_pos())) - -and modifier (lb:lexbuf): p_modifier = - if log_enabled() then log "%s" __FUNCTION__; - match current_token() with - | SIDE d -> - let pos1 = current_pos() in - consume_token lb; - begin - match current_token() with - | ASSOCIATIVE -> - consume_token lb; - extend_pos (*__FUNCTION__*) pos1 - (P_prop (Term.Assoc((d = Pratter.Left)))) - | _ -> - expected "" [ASSOCIATIVE] - end - | ASSOCIATIVE -> - let pos1 = current_pos() in - consume_token lb; - extend_pos (*__FUNCTION__*) pos1 (P_prop (Term.Assoc false)) - | COMMUTATIVE -> - let pos1 = current_pos() in - consume_token lb; - extend_pos (*__FUNCTION__*) pos1 (P_prop Term.Commu) - | CONSTANT -> - let pos1 = current_pos() in - consume_token lb; - extend_pos (*__FUNCTION__*) pos1 (P_prop Term.Const) - | INJECTIVE -> - let pos1 = current_pos() in - consume_token lb; - extend_pos (*__FUNCTION__*) pos1 (P_prop Term.Injec) - | OPAQUE -> - let pos1 = current_pos() in - consume_token lb; - extend_pos (*__FUNCTION__*) pos1 P_opaq - | SEQUENTIAL -> - let pos1 = current_pos() in - consume_token lb; - extend_pos (*__FUNCTION__*) pos1 (P_mstrat Term.Sequen) - | _ -> - exposition lb - -and exposition (lb:lexbuf): p_modifier = - if log_enabled() then log "%s" __FUNCTION__; - match current_token() with - | PRIVATE -> - let pos1 = current_pos() in - consume_token lb; - extend_pos (*__FUNCTION__*) pos1 (P_expo Term.Privat) - | PROTECTED -> - let pos1 = current_pos() in - consume_token lb; - extend_pos (*__FUNCTION__*) pos1 (P_expo Term.Protec) - | _ -> - expected "" [PRIVATE;PROTECTED] - -and notation (lb:lexbuf): string Term.notation = - if log_enabled() then log "%s" __FUNCTION__; - match current_token() with - | INFIX -> - consume_token lb; - begin - match current_token() with - | SIDE d -> - consume_token lb; - let p = float_or_int lb in - Term.Infix(d, p) - | _ -> - let p = float_or_int lb in - Term.Infix(Pratter.Neither, p) - end - | POSTFIX -> - consume_token lb; - let p = float_or_int lb in - Term.Postfix p - | PREFIX -> - consume_token lb; - let p = float_or_int lb in - Term.Prefix p - | QUANTIFIER -> - consume_token lb; - Term.Quant - | _ -> - expected "" [INFIX;POSTFIX;PREFIX;QUANTIFIER] - -and rule (lb:lexbuf): (p_term * p_term) loc = - if log_enabled() then log "%s" __FUNCTION__; - let pos1 = current_pos() in - let l = term lb in - consume HOOK_ARROW lb; - let r = term lb in - extend_pos (*__FUNCTION__*) pos1 (l, r) - -and equation (lb:lexbuf): p_term * p_term = - if log_enabled() then log "%s" __FUNCTION__; - let l = term lb in - consume EQUIV lb; - let r = term lb in - (l, r) - -(* queries *) - -and query (lb:lexbuf): p_query = - if log_enabled() then log "%s" __FUNCTION__; - match current_token() with - | ASSERT b -> - let pos1 = current_pos() in - consume_token lb; - let ps = list params lb in - consume TURNSTILE lb; - let t = term lb in - begin - match current_token() with - | COLON -> - consume_token lb; - let a = term lb in - let pos2 = current_pos() in - let t = make_abst (snd pos1) ps t (fst pos2) in - let a = make_prod (snd pos1) ps a (fst pos2) in - extend_pos (*__FUNCTION__*) pos1 - (P_query_assert(b, P_assert_typing(t,a))) - | EQUIV -> - consume_token lb; - let u = term lb in - let pos2 = current_pos() in - let t = make_abst (snd pos1) ps t (fst pos2) in - let u = make_abst (snd pos1) ps u (fst pos2) in - extend_pos (*__FUNCTION__*) pos1 - (P_query_assert(b, P_assert_conv(t, u))) - | _ -> - expected "" [COLON;EQUIV] - end - | COMPUTE -> - let pos1 = current_pos() in - consume_token lb; - let t = term lb in - extend_pos (*__FUNCTION__*) pos1 - (P_query_normalize(t, {strategy=SNF; steps=None})) - | PRINT -> - let pos1 = current_pos() in - consume_token lb; - begin - match current_token() with - | SEMICOLON -> - extend_pos (*__FUNCTION__*) pos1 (P_query_print None) - | _ -> - let i = qid_or_rule lb in - extend_pos (*__FUNCTION__*) pos1 (P_query_print (Some i)) - end - | PROOFTERM -> - let pos1 = current_pos() in - consume_token lb; - extend_pos (*__FUNCTION__*) pos1 P_query_proofterm - | DEBUG -> - let pos1 = current_pos() in - consume_token lb; - begin - match current_token() with - | SEMICOLON -> - extend_pos (*__FUNCTION__*) pos1 (P_query_debug(true,"")) - | _ -> - let b,s = consume_DEBUG_FLAGS lb in - extend_pos (*__FUNCTION__*) pos1 (P_query_debug(b,s)) - end - | FLAG -> - let pos1 = current_pos() in - consume_token lb; - let s = consume_STRINGLIT lb in - let b = consume_SWITCH lb in - extend_pos (*__FUNCTION__*) pos1 (P_query_flag(s,b)) - | PROVER -> - let pos1 = current_pos() in - consume_token lb; - let s = consume_STRINGLIT lb in - extend_pos (*__FUNCTION__*) pos1 (P_query_prover(s)) - | PROVER_TIMEOUT -> - let pos1 = current_pos() in - consume_token lb; - let n = consume_INT lb in - extend_pos (*__FUNCTION__*) pos1 (P_query_prover_timeout n) - | VERBOSE -> - let pos1 = current_pos() in - consume_token lb; - let n = consume_INT lb in - extend_pos (*__FUNCTION__*) pos1 (P_query_verbose n) - | TYPE_QUERY -> - let pos1 = current_pos() in - consume_token lb; - let t = term lb in - extend_pos (*__FUNCTION__*) pos1 - (P_query_infer(t, {strategy=NONE; steps=None})) - | SEARCH -> - let pos1 = current_pos() in - consume_token lb; - let q = search lb in - extend_pos (*__FUNCTION__*) pos1 (P_query_search q) - | _ -> - expected "query" [] - -and term_proof (lb:lexbuf): p_term option * (p_proof * p_proof_end) option = - if log_enabled() then log "%s" __FUNCTION__; - match current_token() with - | BEGIN -> - consume_token lb; - let p = proof lb in - None, Some p - | _ -> - let t = term lb in - begin - match current_token() with - | BEGIN -> - consume_token lb; - let p = proof lb in - Some t, Some p - | _ -> - Some t, None - end - -(* proofs *) - -and proof (lb:lexbuf): p_proof * p_proof_end = - if log_enabled() then log "%s" __FUNCTION__; - match current_token() with - | L_CU_BRACKET -> - let l = nelist subproof lb in - if current_token() = SEMICOLON then consume_token lb; - let pe = proof_end lb in - l, pe - (*queries*) - | ASSERT _ - | COMPUTE - | DEBUG - | FLAG - | PRINT - | PROOFTERM - | PROVER - | PROVER_TIMEOUT - | SEARCH - | TYPE_QUERY - | VERBOSE - (*tactics*) - | ADMIT - | APPLY - | ASSUME - | CHANGE - | EVAL - | FAIL - | GENERALIZE - | HAVE - | INDUCTION - | ORELSE - | REFINE - | REFLEXIVITY - | REMOVE - | REPEAT - | REWRITE - | SET - | SIMPLIFY - | SOLVE - | SYMMETRY - | TRY - | WHY3 -> - let l = steps lb in - let pe = proof_end lb in - [l], pe - | END - | ABORT - | ADMITTED -> - let pe = proof_end lb in - [], pe - | _ -> - expected "subproof, tactic or query" [] - -and subproof (lb:lexbuf): p_proofstep list = - if log_enabled() then log "%s" __FUNCTION__; - match current_token() with - | L_CU_BRACKET -> - consume_token lb; - let l = steps lb in - consume R_CU_BRACKET lb; - l - | _ -> - expected "" [L_CU_BRACKET] - -and steps (lb:lexbuf): p_proofstep list = - if log_enabled() then log "%s" __FUNCTION__; - match current_token() with - (*queries*) - | ASSERT _ - | COMPUTE - | DEBUG - | FLAG - | PRINT - | PROOFTERM - | PROVER - | PROVER_TIMEOUT - | SEARCH - | TYPE_QUERY - | VERBOSE - (*tactics*) - | ADMIT - | APPLY - | ASSUME - | CHANGE - | EVAL - | FAIL - | GENERALIZE - | HAVE - | INDUCTION - | ORELSE - | REFINE - | REFLEXIVITY - | REMOVE - | REPEAT - | REWRITE - | SET - | SIMPLIFY - | SOLVE - | SYMMETRY - | TRY - | WHY3 -> - let a = step lb in - let acc = list (prefix SEMICOLON step) lb in - if current_token() = SEMICOLON then consume_token lb; - a::acc - | END - | ABORT - | ADMITTED -> - [] - | _ -> - expected "tactic or query" [] - -and step (lb:lexbuf): p_proofstep = - if log_enabled() then log "%s" __FUNCTION__; - let t = tactic lb in - let l = list subproof lb in - Tactic(t, l) - -and proof_end (lb:lexbuf): p_proof_end = - if log_enabled() then log "%s" __FUNCTION__; - match current_token() with - | ABORT -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 Syntax.P_proof_abort - | ADMITTED -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 Syntax.P_proof_admitted - | END -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 Syntax.P_proof_end - | _ -> - expected "" [ABORT;ADMITTED;END] - -and tactic (lb:lexbuf): p_tactic = - if log_enabled() then log "%s" __FUNCTION__; - match current_token() with - (*queries*) - | ASSERT _ - | COMPUTE - | DEBUG - | FLAG - | PRINT - | PROOFTERM - | PROVER - | PROVER_TIMEOUT - | SEARCH - | TYPE_QUERY - | VERBOSE -> - let pos1 = current_pos() in - extend_pos (*__FUNCTION__*) pos1 (P_tac_query (query lb)) - | ADMIT -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 P_tac_admit - | APPLY -> - let pos1 = current_pos() in - consume_token lb; - let t = term lb in - extend_pos (*__FUNCTION__*) pos1 (P_tac_apply t) - | ASSUME -> - let pos1 = current_pos() in - consume_token lb; - let xs = nelist param lb in - extend_pos (*__FUNCTION__*) pos1 (P_tac_assume xs) - | CHANGE -> - let pos1 = current_pos() in - consume_token lb; - let t = term lb in - extend_pos (*__FUNCTION__*) pos1 (P_tac_change t) - | EVAL -> - let pos1 = current_pos() in - consume_token lb; - let t = term lb in - extend_pos (*__FUNCTION__*) pos1 (P_tac_eval t) - | FAIL -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 P_tac_fail - | GENERALIZE -> - let pos1 = current_pos() in - consume_token lb; - let i = uid lb in - extend_pos (*__FUNCTION__*) pos1 (P_tac_generalize i) - | HAVE -> - let pos1 = current_pos() in - consume_token lb; - let i = uid lb in - consume COLON lb; - let t = term lb in - extend_pos (*__FUNCTION__*) pos1 (P_tac_have(i,t)) - | INDUCTION -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 P_tac_induction - | ORELSE -> - let pos1 = current_pos() in - consume_token lb; - let t1 = tactic lb in - let t2 = tactic lb in - extend_pos (*__FUNCTION__*) pos1 (P_tac_orelse(t1,t2)) - | REFINE -> - let pos1 = current_pos() in - consume_token lb; - let t = term lb in - extend_pos (*__FUNCTION__*) pos1 (P_tac_refine t) - | REFLEXIVITY -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 P_tac_refl - | REMOVE -> - let pos1 = current_pos() in - consume_token lb; - let xs = nelist uid lb in - extend_pos (*__FUNCTION__*) pos1 (P_tac_remove xs) - | REPEAT -> - let pos1 = current_pos() in - consume_token lb; - let t = tactic lb in - extend_pos (*__FUNCTION__*) pos1 (P_tac_repeat t) - | REWRITE -> - let pos1 = current_pos() in - consume_token lb; - begin - match current_token() with - | SIDE d -> - consume_token lb; - begin - match current_token() with - | DOT -> - consume_token lb; - let p = rwpatt_bracket lb in - let t = term lb in - let b = d <> Pratter.Left in - extend_pos (*__FUNCTION__*) pos1 (P_tac_rewrite(b,Some p,t)) - | _ -> - let t = term lb in - let b = d <> Pratter.Left in - extend_pos (*__FUNCTION__*) pos1 (P_tac_rewrite(b,None,t)) - end - | DOT -> - consume_token lb; - let p = rwpatt_bracket lb in - let t = term lb in - extend_pos (*__FUNCTION__*) pos1 (P_tac_rewrite(true,Some p,t)) - | _ -> - let t = term lb in - extend_pos (*__FUNCTION__*) pos1 (P_tac_rewrite(true,None,t)) - end - | SET -> - let pos1 = current_pos() in - consume_token lb; - let i = uid lb in - consume ASSIGN lb; - let t = term lb in - extend_pos (*__FUNCTION__*) pos1 (P_tac_set(i,t)) - | SIMPLIFY -> - let pos1 = current_pos() in - consume_token lb; - begin - match current_token() with - | UID _ - | QID _ -> - extend_pos (*__FUNCTION__*) pos1 (P_tac_simpl(SimpSym(qid lb))) - | RULE -> - consume_token lb; - begin - match current_token() with - | SWITCH false -> - consume_token lb; - extend_pos (*__FUNCTION__*) pos1 (P_tac_simpl SimpBetaOnly) - | _ -> expected "" [SWITCH false] - end - | _ -> - extend_pos (*__FUNCTION__*) pos1 (P_tac_simpl SimpAll) - end - | SOLVE -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 P_tac_solve - | SYMMETRY -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 P_tac_sym - | TRY -> - let pos1 = current_pos() in - consume_token lb; - let t = tactic lb in - extend_pos (*__FUNCTION__*) pos1 (P_tac_try t) - | WHY3 -> - let pos1 = current_pos() in - consume_token lb; - begin - match current_token() with - | STRINGLIT s -> - extend_pos (*__FUNCTION__*) pos1 (P_tac_why3 (Some s)) - | _ -> - make_pos pos1 (P_tac_why3 None) - end - | _ -> - expected "tactic" [] - and rwpatt_content (lb:lexbuf): p_rwpatt = if log_enabled() then log "%s" __FUNCTION__; match current_token() with @@ -1138,7 +266,7 @@ and rwpatt_content (lb:lexbuf): p_rwpatt = | L_PAREN | L_SQ_BRACKET | INT _ - | QINT _ + (* | QINT _ *) | STRINGLIT _ -> let pos1 = current_pos() in let t1 = term lb in @@ -1159,20 +287,6 @@ and rwpatt_content (lb:lexbuf): p_rwpatt = let x = ident_of_term pos1 t1 in extend_pos (*__FUNCTION__*) pos1 (Rw_IdInTerm(x,t2)) end - | AS -> - consume_token lb; - let t2 = term lb in - begin - match current_token() with - | IN -> - consume_token lb; - let t3 = term lb in - let x = ident_of_term pos1 t2 in - extend_pos (*__FUNCTION__*) pos1 - (Rw_TermAsIdInTerm(t1,(x,t3))) - | _ -> - expected "" [IN] - end | _ -> extend_pos (*__FUNCTION__*) pos1 (Rw_Term(t1)) end @@ -1254,11 +368,37 @@ and params (lb:lexbuf): p_params = let x = param lb in [x], None, false +and fun_param_list (lb:lexbuf) = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | L_PAREN -> + consume_token lb; + let ps = nelist param lb in + begin + match current_token() with + | COLON -> + consume_token lb; + let typ = term lb in + consume R_PAREN lb; + ps, Some typ, false + | R_PAREN -> + consume_token lb; + ps, None, false + | _ -> + expected "" [COLON;R_PAREN] + end + | _ -> + let x = param lb in + [x], None, false + and term (lb:lexbuf): p_term = if log_enabled() then log "%s" __FUNCTION__; match current_token() with (* bterm *) | BACKQUOTE + | EXISTS + | FORALL + | FUN | PI | LAMBDA | LET -> @@ -1275,7 +415,6 @@ and term (lb:lexbuf): p_term = | L_PAREN | L_SQ_BRACKET | INT _ - | QINT _ | STRINGLIT _ -> let pos1 = current_pos() in let h = aterm lb in @@ -1298,7 +437,6 @@ and app (pos1:position * position) (t: p_term) (lb:lexbuf): p_term = | L_PAREN | L_SQ_BRACKET | INT _ - | QINT _ | STRINGLIT _ -> let u = aterm lb in app pos1 (extend_pos (*__FUNCTION__*) pos1 (P_Appl(t,u))) lb @@ -1327,7 +465,23 @@ and bterm (lb:lexbuf): p_term = let b = binder lb in let b = extend_pos (*__FUNCTION__*) pos1 (P_Abst(fst b, snd b)) in extend_pos (*__FUNCTION__*) pos1 (P_Appl(q, b)) + | EXISTS -> + let pos1 = current_pos() in + consume_token lb; + let b = rocqbinder lb COMMA in + let f = fun bin res -> + extend_pos pos1 (P_Appl( + extend_pos pos1 (P_Iden(extend_pos pos1 ([],"∃"), false)), + extend_pos pos1 (P_Abst([bin], res)))) in + (List.fold_right f (fst b) (snd b)) + | FORALL -> + (* { make_pos $sloc (P_Prod(fst b, snd b)) } *) + let pos1 = current_pos() in + consume_token lb; + let b = rocqbinder lb COMMA in + extend_pos (*__FUNCTION__*) pos1 (P_Prod(fst b, snd b)) | PI -> + (* { make_pos $sloc (P_Prod(fst b, snd b)) } *) let pos1 = current_pos() in consume_token lb; let b = binder lb in @@ -1337,6 +491,11 @@ and bterm (lb:lexbuf): p_term = consume_token lb; let b = binder lb in extend_pos (*__FUNCTION__*) pos1 (P_Abst(fst b, snd b)) + | FUN -> + let pos1 = current_pos() in + consume_token lb; + let b = rocqbinder lb THICKARROW in + extend_pos (*__FUNCTION__*) pos1 (P_Abst(fst b, snd b)) | LET -> let pos1 = current_pos() in consume_token lb; @@ -1422,10 +581,6 @@ and aterm (lb:lexbuf): p_term = let pos1 = current_pos() in consume_token lb; make_pos pos1 (P_NLit([],n)) - | QINT(p,n) -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 (P_NLit(p,n)) | STRINGLIT s -> let pos1 = current_pos() in consume_token lb; @@ -1506,6 +661,56 @@ and binder (lb:lexbuf): p_params list * p_term = | _ -> expected "" [UID"";UNDERSCORE;L_PAREN;L_SQ_BRACKET] +and rocqbinder (lb:lexbuf) terminator : p_params list * p_term = + if log_enabled() then log "%s" __FUNCTION__; + match current_token() with + | UID _ + | UNDERSCORE -> + let s = param lb in + begin + match current_token() with + | UID _ + | UNDERSCORE + | L_PAREN -> + let ps = list params lb in + consume terminator lb; + let p = [s], None, false in + p::ps, term lb + | COLON -> + consume_token lb; + let a = term lb in + consume terminator lb; + let p = [s], Some a, false in + [p], term lb + (* | terminator *) + | _ -> + if current_token() = terminator then + begin + consume_token lb; + let p = [s], None, false in + [p], term lb + end + else + expected "parameter list" + [UID"";UNDERSCORE;L_PAREN;terminator] + end + | L_PAREN -> + let ps = nelist params lb in + begin + match current_token() with + | _ -> + if current_token() = terminator then + begin + consume_token lb; + ps, term lb + end + else + expected "" [terminator] + end + | _ -> + expected "" [UID"";UNDERSCORE;L_PAREN;] + + (* search *) and generalize (lb:lexbuf): bool = @@ -1637,7 +842,8 @@ and ssearch (lb:lexbuf): search = cq and search (lb:lexbuf): search = - if log_enabled() then log "%s" __FUNCTION__; + (* expected "prbolem " []*) + if log_enabled() then log "%s" __FUNCTION__; let q = ssearch lb in let qids = list (prefix VBAR qid) lb in let path_of_qid qid = @@ -1646,13 +852,3 @@ and search (lb:lexbuf): search = else Format.asprintf "%a.%a" Print.path p Print.uid n in List.fold_left (fun x qid -> QFilter(x,Path(path_of_qid qid))) q qids - -let command (lb:lexbuf): p_command = - if log_enabled() then log "------------------- start reading command"; - consume_token lb; - if current_token() = EOF then raise End_of_file - else - let c = command (Lexing.dummy_pos,Lexing.dummy_pos) [] lb in - match current_token() with - | SEMICOLON -> c - | _ -> expected "" [SEMICOLON] diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 424ac2fea..4574b22e9 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -887,7 +887,7 @@ module UserLevelQueries = struct try let mok _ = None in let q = match q with - | None -> Parsing.Parser.Lp.parse_search_string (lexing_opt None) s + | None -> Parsing.Parser.Rocq.parse_search_string (lexing_opt None) s | Some q -> q in let items = ItemSet.bindings (answer_query ~mok ss [] q) in let resultsno = List.length items in From d52e09784a8b4db1bb000afab35a68754102253d Mon Sep 17 00:00:00 2001 From: Abdelghani ALIDRA Date: Fri, 19 Dec 2025 23:18:18 +0100 Subject: [PATCH 58/58] Fix double semicolon after search qeuries in LP files --- src/parsing/lpParser.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parsing/lpParser.ml b/src/parsing/lpParser.ml index 89ebc297d..5c3088d2f 100644 --- a/src/parsing/lpParser.ml +++ b/src/parsing/lpParser.ml @@ -1632,7 +1632,7 @@ and ssearch (lb:lexbuf): search = let cq = csearch lb in match current_token() with | SEMICOLON -> - let cqs = list (prefix SEMICOLON csearch) lb in + let cqs = list (csearch) lb in List.fold_left (fun x cq -> QOp(x,Union,cq)) cq cqs | _ -> cq