From 4c33890cf3675d517be08a68bf3d3ffef71d0005 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Wed, 31 Jul 2024 22:26:47 +0200 Subject: [PATCH 01/35] new parser --- src/parsing/ll1.ml | 1316 ++++++++++++++++++++++++++++++++++++++++ src/parsing/lpLexer.ml | 95 +++ src/parsing/parser.ml | 17 +- 3 files changed, 1427 insertions(+), 1 deletion(-) create mode 100644 src/parsing/ll1.ml diff --git a/src/parsing/ll1.ml b/src/parsing/ll1.ml new file mode 100644 index 000000000..57c8b41d9 --- /dev/null +++ b/src/parsing/ll1.ml @@ -0,0 +1,1316 @@ +open Lplib +open Common open Pos open Logger +open Syntax +open Core +open LpLexer +open Lexing +open Sedlexing + +let log = Logger.make 'n' "pars" "parsing" +let log = log.pp + +let the_current_token : (token * position * position) Stdlib.ref = + Stdlib.ref (EOF, dummy_pos, dummy_pos) + +let current_token() : token = + let (t,_,_) = !the_current_token in + (*if log_enabled() then log "current_token: %a" pp_token t;*) + t + +let current_pos() : position * position = + let (_,p1,p2) = !the_current_token in (p1,p2) + +let consume_token (lb:lexbuf) : unit = + the_current_token := LpLexer.token lb ()(*; + if log_enabled() then log "read new token"*) + +let make_pos (lps:position * position): 'a -> 'a loc = + Pos.make_pos (fst lps, snd (current_pos())) + +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 make_pos (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 make_pos (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 identifier" + +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 list (elt:lexbuf -> 'a) (lb:lexbuf): 'a list = + (*if log_enabled() then log "expected: %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 "expected: %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 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_NAT (lb:lexbuf): string = + match current_token() with + | NAT s -> + consume_token lb; + s + | _ -> + expected "" [NAT""] + +let qid (lb:lexbuf): (string list * string) loc = + (*if log_enabled() then log "expected: %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 "expected: %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 "expected: %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 "expected: %s" __FUNCTION__;*) + match current_token() with + | UID s + | NAT 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"";NAT"";UNDERSCORE] + +let int (lb:lexbuf): string = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + match current_token() with + | NAT s + | NEG_NAT s -> + consume_token lb; + s + | _ -> + expected "integer" [NAT"";NEG_NAT""] + +let float_or_int (lb:lexbuf): string = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + match current_token() with + | NAT s + | NEG_NAT s + | FLOAT s -> + consume_token lb; + s + | _ -> + expected "integer or float" [NAT"";NEG_NAT"";FLOAT""] + +let uid_or_int (lb:lexbuf): string loc = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + match current_token() with + | UID s + | NAT s + | NEG_NAT s -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 s + | _ -> + expected "non-qualified identifier" [UID"";NAT"";NEG_NAT""] + +let qid_or_int (lb:lexbuf): (string list * string) loc = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + match current_token() with + | QID p -> + let pos1 = current_pos() in + consume_token lb; + qid_of_path pos1 p + | UID s + | NAT s + | NEG_NAT s -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 ([],s) + | _ -> + expected "possibly qualified identifier" [UID"";QID[];NAT"";NEG_NAT""] + +let path (lb:lexbuf): string list loc = + (*if log_enabled() then log "expected: %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 "expected: %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 (Ghost.sign.sign_path, Unif_rule.equiv.sym_name) + | COERCE_RULE -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (Ghost.sign.sign_path, Coercion.coerce.sym_name) + | _ -> + expected "" [UID"";QID[];UNIF_RULE;COERCE_RULE] + +let term_id (lb:lexbuf): p_term = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + match current_token() with + | UID _ + | QID _ -> + let pos1 = current_pos() in + let i = qid lb in + make_pos pos1 (P_Iden(i, false)) + | UID_EXPL _ + | QID_EXPL _ -> + let pos1 = current_pos() in + let i = qid_expl lb in + make_pos pos1 (P_Iden(i, true)) + | _ -> + expected "" [UID"";QID[];UID_EXPL"";QID_EXPL[]] + +let rec command pos1 p_sym_mod (lb:lexbuf): p_command = + (*if log_enabled() then log "expected: %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_or_int *) + | UID _ + | QID _ + | NAT _ + | NEG_NAT _ -> + begin + match p_sym_mod with + | [{elt=P_opaq;_}] -> + let i = qid_or_int lb in + make_pos 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 + make_pos pos1 (P_require(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 + make_pos pos1 (P_require_as(p,i)) + | _ -> + make_pos pos1 (P_require(false,ps)) + end + end + | OPEN -> + if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) + let pos1 = current_pos() in + consume_token lb; + let l = list path lb in + make_pos pos1 (P_open l) + | SYMBOL -> + let pos1 = current_pos() in + consume_token lb; + let p_sym_nam = uid_or_int 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 -> + 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 make_pos 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 make_pos 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 make_pos 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 make_pos 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 + make_pos 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 + make_pos 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 + make_pos 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 Ghost.sign.sign_path Unif_rule.equiv.sym_name in + let cons = P.qiden Ghost.sign.sign_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 = make_pos pos1 (lhs, rhs) in + make_pos 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 + make_pos 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_or_int lb in + make_pos 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_or_int lb in + let n = notation lb in + make_pos pos1 (P_notation(i,n)) + | _ -> + if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) + let pos1 = current_pos() in + let q = query lb in + make_pos 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 _ + | NAT _ + | NEG_NAT _ -> + let c = constructor lb in + let cs = list (prefix VBAR constructor) lb in + let l = c::cs in + make_pos pos0 (i,t,l) + | VBAR -> + let l = list (prefix VBAR constructor) lb in + make_pos pos0 (i,t,l) + | SEMICOLON -> + let l = [] in + make_pos pos0 (i,t,l) + | _ -> + expected "identifier" [] + end + +and constructor (lb:lexbuf): p_ident * p_term = + let i = uid_or_int 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 "expected: %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; + make_pos pos1 (P_prop (Term.Assoc((d = Pratter.Left)))) + | _ -> + expected "" [ASSOCIATIVE] + end + | ASSOCIATIVE -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (P_prop (Term.Assoc false)) + | COMMUTATIVE -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (P_prop Term.Commu) + | CONSTANT -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (P_prop Term.Const) + | INJECTIVE -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (P_prop Term.Injec) + | OPAQUE -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 P_opaq + | SEQUENTIAL -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (P_mstrat Term.Sequen) + | _ -> + exposition lb + +and exposition (lb:lexbuf): p_modifier = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + match current_token() with + | PRIVATE -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (P_expo Term.Privat) + | PROTECTED -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (P_expo Term.Protec) + | _ -> + expected "" [PRIVATE;PROTECTED] + +and notation (lb:lexbuf): string Sign.notation = + (*if log_enabled() then log "expected: %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 + Sign.Infix(d, p) + | _ -> + let p = float_or_int lb in + Sign.Infix(Pratter.Neither, p) + end + | POSTFIX -> + consume_token lb; + let p = float_or_int lb in + Sign.Postfix p + | PREFIX -> + consume_token lb; + let p = float_or_int lb in + Sign.Prefix p + | QUANTIFIER -> + consume_token lb; + Sign.Quant + | _ -> + expected "" [INFIX;POSTFIX;PREFIX;QUANTIFIER] + +and rule (lb:lexbuf): (p_term * p_term) loc = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + let pos1 = current_pos() in + let l = term lb in + consume HOOK_ARROW lb; + let r = term lb in + make_pos pos1 (l, r) + +and equation (lb:lexbuf): p_term * p_term = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + let l = term lb in + consume EQUIV lb; + let r = term lb in + (l, r) + +and query (lb:lexbuf): p_query = + (*if log_enabled() then log "expected: %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 (fst pos1) ps t (snd pos2) in + let a = make_prod (fst pos1) ps a (snd pos2) in + make_pos 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 (fst pos1) ps t (snd pos2) in + let u = make_abst (fst pos1) ps u (snd pos2) in + make_pos 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 + make_pos pos1 (P_query_normalize(t, {strategy=SNF; steps=None})) + | PRINT -> + let pos1 = current_pos() in + consume_token lb; + begin + match current_token() with + | SEMICOLON -> + make_pos pos1 (P_query_print None) + | _ -> + let i = qid_or_rule lb in + make_pos pos1 (P_query_print (Some i)) + end + | PROOFTERM -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 P_query_proofterm + | DEBUG_FLAGS fl -> + let pos1 = current_pos() in + consume_token lb; + let (b, s) = fl in + make_pos pos1 (P_query_debug(b, s)) + | FLAG -> + let pos1 = current_pos() in + consume_token lb; + let s = consume_STRINGLIT lb in + let b = consume_SWITCH lb in + make_pos pos1 (P_query_flag(s,b)) + | PROVER -> + let pos1 = current_pos() in + consume_token lb; + let s = consume_STRINGLIT lb in + make_pos pos1 (P_query_prover(s)) + | PROVER_TIMEOUT -> + let pos1 = current_pos() in + consume_token lb; + let n = consume_NAT lb in + make_pos pos1 (P_query_prover_timeout n) + | VERBOSE -> + let pos1 = current_pos() in + consume_token lb; + let n = consume_NAT lb in + make_pos pos1 (P_query_verbose n) + | TYPE_QUERY -> + let pos1 = current_pos() in + consume_token lb; + let t = term lb in + make_pos pos1 (P_query_infer(t, {strategy=NONE; steps=None})) + (*| SEARCH s -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (P_query_search s)*) + | _ -> + expected "query" [] + +and term_proof (lb:lexbuf): p_term option * (p_proof * p_proof_end) option = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + match current_token() with + | BEGIN -> + let p = proof lb in + None, Some p + | _ -> + let t = term lb in + begin + match current_token() with + | BEGIN -> + let p = proof lb in + Some t, Some p + | _ -> + Some t, None + end + +and proof (lb:lexbuf): p_proof * p_proof_end = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + consume BEGIN lb; + 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 + | PRINT + | PROOFTERM + | DEBUG + | FLAG + | PROVER + | PROVER_TIMEOUT + | VERBOSE + | SEARCH + (*tactics*) + | ADMIT + | APPLY + | ASSUME + | FAIL + | GENERALIZE + | HAVE + | INDUCTION + | REFINE + | REFLEXIVITY + | REMOVE + | REWRITE + | 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 "expected: %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 "expected: %s" __FUNCTION__;*) + match current_token() with + (*queries*) + | ASSERT _ + | COMPUTE + | PRINT + | PROOFTERM + | DEBUG + | FLAG + | PROVER + | PROVER_TIMEOUT + | VERBOSE + | SEARCH + (*tactics*) + | ADMIT + | APPLY + | ASSUME + | FAIL + | GENERALIZE + | HAVE + | INDUCTION + | REFINE + | REFLEXIVITY + | REMOVE + | REWRITE + | 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 "expected: %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 "expected: %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 "expected: %s" __FUNCTION__;*) + match current_token() with + (*queries*) + | ASSERT _ + | COMPUTE + | PRINT + | PROOFTERM + | DEBUG + | FLAG + | PROVER + | PROVER_TIMEOUT + | VERBOSE + | SEARCH -> + let pos1 = current_pos() in + make_pos 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 + make_pos pos1 (P_tac_apply t) + | ASSUME -> + let pos1 = current_pos() in + consume_token lb; + let xs = nelist param lb in + make_pos pos1 (P_tac_assume xs) + | 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 + make_pos 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 + make_pos pos1 (P_tac_have(i,t)) + | INDUCTION -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 P_tac_induction + | REFINE -> + let pos1 = current_pos() in + consume_token lb; + let t = term lb in + make_pos 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 + make_pos pos1 (P_tac_remove xs) + | 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 = rw_patt_spec lb in + let t = term lb in + let b = d <> Pratter.Left in + make_pos pos1 (P_tac_rewrite(b,Some p,t)) + | _ -> + let t = term lb in + let b = d <> Pratter.Left in + make_pos pos1 (P_tac_rewrite(b,None,t)) + end + | DOT -> + consume_token lb; + let p = rw_patt_spec lb in + let t = term lb in + make_pos pos1 (P_tac_rewrite(true,Some p,t)) + | _ -> + let t = term lb in + make_pos pos1 (P_tac_rewrite(true,None,t)) + end + | SIMPLIFY -> + let pos1 = current_pos() in + consume_token lb; + begin + match current_token() with + | UID _ + | QID _ + | NAT _ + | NEG_NAT _ -> + let i = Some (qid_or_int lb) in + make_pos pos1 (P_tac_simpl i) + | _ -> + let i = None in + make_pos pos1 (P_tac_simpl i) + 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 + make_pos pos1 (P_tac_try t) + | WHY3 -> + let pos1 = current_pos() in + consume_token lb; + begin + match current_token() with + | STRINGLIT s -> + make_pos pos1 (P_tac_why3 (Some s)) + | _ -> + make_pos pos1 (P_tac_why3 None) + end + | _ -> + expected "tactic" [] + +and rw_patt (lb:lexbuf): p_rw_patt = + (*if log_enabled() then log "expected: %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 + | NAT _ + | NEG_NAT _ -> + 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 + make_pos pos1 (Rw_TermInIdInTerm(t1,(x,t3))) + | _ -> + let x = ident_of_term pos1 t1 in + make_pos 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 + make_pos pos1 (Rw_TermAsIdInTerm(t1,(x,t3))) + | _ -> + expected "" [IN] + end + | _ -> + make_pos 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 + make_pos pos1 (Rw_InIdInTerm(x,t2)) + | _ -> + make_pos pos1 (Rw_InTerm(t1)) + end + | _ -> + expected "term or keyword \"in\"" [] + +and rw_patt_spec (lb:lexbuf): p_rw_patt = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + match current_token() with + | L_SQ_BRACKET -> + consume_token lb; + let p = rw_patt lb in + consume R_SQ_BRACKET lb; (*add info on opening bracket*) + p + | _ -> + expected "" [L_SQ_BRACKET] + +and params (lb:lexbuf): p_params = + (*if log_enabled() then log "expected: %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 "expected: %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 + | NAT _ + | NEG_NAT _ -> + 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 "expected: %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 + | NAT _ + | NEG_NAT _ -> + let u = aterm lb in + app pos1 (make_pos pos1 (P_Appl(t,u))) lb + (* bterm *) + | BACKQUOTE + | PI + | LAMBDA + | LET -> + let u = bterm lb in + make_pos pos1 (P_Appl(t,u)) + (* other cases *) + | ARROW -> + consume_token lb; + let u = term lb in + make_pos pos1 (P_Arro(t,u)) + | _ -> + t + +and bterm (lb:lexbuf): p_term = + (*if log_enabled() then log "expected: %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 = make_pos pos1 (P_Abst(fst b, snd b)) in + make_pos pos1 (P_Appl(q, b)) + | PI -> + let pos1 = current_pos() in + consume_token lb; + let b = binder lb in + make_pos pos1 (P_Prod(fst b, snd b)) + | LAMBDA -> + let pos1 = current_pos() in + consume_token lb; + let b = binder lb in + make_pos 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 + make_pos 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 + make_pos 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 "expected: %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; + make_pos pos1 (P_Meta(i,Array.of_list (env lb))) + | _ -> + make_pos pos1 (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; + make_pos 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; + make_pos 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; + make_pos pos1 (P_Expl(t)) + | NAT n -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (P_NLit n) + | NEG_NAT n -> + let pos1 = current_pos() in + consume_token lb; + make_pos pos1 (P_Iden(make_pos pos1 ([],n), false)) + | _ -> + expected "identifier, \"_\", or term between parentheses or square \ + brackets" [] + +and env (lb:lexbuf): p_term list = + (*if log_enabled() then log "expected: %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 "expected: %s" __FUNCTION__;*) + match current_token() with + | UID _ + | NAT _ + | UNDERSCORE -> + let s = param lb in + begin + match current_token() with + | UID _ + | NAT _ + | 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"";NAT"";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"";NAT"";UNDERSCORE;L_PAREN;L_SQ_BRACKET] + +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 (dummy_pos,dummy_pos) [] lb in + match current_token() with + | SEMICOLON -> c + | _ -> expected "" [SEMICOLON] diff --git a/src/parsing/lpLexer.ml b/src/parsing/lpLexer.ml index 6c23af3c9..fc7decbaf 100644 --- a/src/parsing/lpLexer.ml +++ b/src/parsing/lpLexer.ml @@ -344,3 +344,98 @@ let token : lexbuf -> unit -> token * Lexing.position * Lexing.position = let token = let r = ref (EOF, Lexing.dummy_pos, Lexing.dummy_pos) in fun lb () -> Debug.(record_time Lexing (fun () -> r := token lb ())); !r + +let string_of_token = function + | EOF -> "end of file" + | ABORT -> "abort" + | ADMIT -> "admit" + | ADMITTED -> "admitted" + | APPLY -> "apply" + | AS -> "as" + | ASSERT _ -> "assert or assertnot" + | ASSOCIATIVE -> "associative" + | ASSUME -> "assume" + | BEGIN -> "begin" + | BUILTIN -> "builtin" + | COERCE_RULE -> "coerce_rule" + | COMMUTATIVE -> "commutative" + | COMPUTE -> "compute" + | CONSTANT -> "constant" + | DEBUG -> "debug" + | END -> "end" + | FAIL -> "fail" + | FLAG -> "flag" + | GENERALIZE -> "generalize" + | HAVE -> "have" + | IN -> "in" + | INDUCTION -> "induction" + | INDUCTIVE -> "inductive" + | INFIX -> "infix" + | INJECTIVE -> "injective" + | LET -> "let" + | NOTATION -> "notation" + | OPAQUE -> "opaque" + | OPEN -> "open" + | 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" + | REQUIRE -> "require" + | REWRITE -> "rewrite" + | RULE -> "rule" + | SEARCH -> "search" + | SEQUENTIAL -> "sequential" + | SIMPLIFY -> "simplify" + | SOLVE -> "solve" + | SYMBOL -> "symbol" + | SYMMETRY -> "symmetry" + | TRY -> "try" + | TYPE_QUERY -> "type" + | TYPE_TERM -> "TYPE" + | UNIF_RULE -> "unif_rule" + | VERBOSE -> "verbose" + | WHY3 -> "why3" + | WITH -> "with" + | DEBUG_FLAGS _ -> "debug flags" + | NAT _ -> "natural number" + | NEG_NAT _ -> "negative integer" + | FLOAT _ -> "float" + | SIDE _ -> "left or right" + | STRINGLIT _ -> "string literal" + | SWITCH _ -> "on or off" + | ASSIGN -> "≔" + | ARROW -> "→" + | BACKQUOTE -> "`" + | COMMA -> "," + | COLON -> ":" + | DOT -> "." + | EQUIV -> "≡" + | HOOK_ARROW -> "↪" + | LAMBDA -> "λ" + | L_CU_BRACKET -> "{" + | L_PAREN -> "(" + | L_SQ_BRACKET -> "[" + | PI -> "Π" + | R_CU_BRACKET -> "}" + | R_PAREN -> ")" + | R_SQ_BRACKET -> "]" + | SEMICOLON -> ";" + | TURNSTILE -> "⊢" + | VBAR -> "|" + | UNDERSCORE -> "_" + | UID _ -> "non-qualified identifier" + | UID_EXPL _ -> "@-prefixed non-qualified identifier" + | UID_META _ -> "?-prefixed metavariable number" + | UID_PATT _ -> "$-prefixed non-qualified identifier" + | QID _ -> "qualified identifier" + | QID_EXPL _ -> "@-prefixed qualified identifier" + +let pp_token ppf t = Base.string ppf (string_of_token t) diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index 5495f6741..2ea099a95 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -104,7 +104,22 @@ sig let parse = parse ~grammar_entry:LpParser.command let parse_string = parse_string ~grammar_entry:LpParser.command - let parse_file = parse_file ~grammar_entry:LpParser.command + let parse_file fname = (*parse_file ~grammar_entry:LpParser.command fname*) + let inchan = open_in fname in + let lb = Sedlexing.Utf8.from_channel inchan in + Sedlexing.set_filename lb fname; + let generator _ = + try Some(Ll1.command lb) + with + | End_of_file -> close_in inchan; None + | LpLexer.SyntaxError {pos=None; _} -> assert false + | LpLexer.SyntaxError {pos=Some pos; elt} -> parser_fatal pos "%s" elt + | LpParser.Error -> + let pos = Pos.locate (Sedlexing.lexing_positions lb) in + parser_fatal pos "Unexpected token: \"%s\"." + (Sedlexing.Utf8.lexeme lb) + in + Stream.from generator end From f414bc860ecac7460e38cd33731e5157b26fe4d6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Wed, 31 Jul 2024 22:50:07 +0200 Subject: [PATCH 02/35] wip --- src/parsing/ll1.ml | 109 ++++++++++++++++++++++++++++++++++++++++- src/parsing/lpLexer.ml | 95 ----------------------------------- 2 files changed, 107 insertions(+), 97 deletions(-) diff --git a/src/parsing/ll1.ml b/src/parsing/ll1.ml index 57c8b41d9..d36f16015 100644 --- a/src/parsing/ll1.ml +++ b/src/parsing/ll1.ml @@ -6,8 +6,10 @@ open LpLexer open Lexing open Sedlexing -let log = Logger.make 'n' "pars" "parsing" -let log = log.pp +(*let log = Logger.make 'n' "pars" "parsing" +let log = log.pp*) + +(* token management *) let the_current_token : (token * position * position) Stdlib.ref = Stdlib.ref (EOF, dummy_pos, dummy_pos) @@ -24,6 +26,8 @@ let consume_token (lb:lexbuf) : unit = the_current_token := LpLexer.token lb ()(*; if log_enabled() then log "read new token"*) +(* building positions and terms *) + let make_pos (lps:position * position): 'a -> 'a loc = Pos.make_pos (fst lps, snd (current_pos())) @@ -45,6 +49,103 @@ let ident_of_term pos1 {elt; _} = | P_Iden({elt=([], x); pos}, _) -> Pos.make pos x | _ -> LpLexer.syntax_error pos1 "not an identifier" +(* error messages *) + +let string_of_token = function + | EOF -> "end of file" + | ABORT -> "abort" + | ADMIT -> "admit" + | ADMITTED -> "admitted" + | APPLY -> "apply" + | AS -> "as" + | ASSERT _ -> "assert or assertnot" + | ASSOCIATIVE -> "associative" + | ASSUME -> "assume" + | BEGIN -> "begin" + | BUILTIN -> "builtin" + | COERCE_RULE -> "coerce_rule" + | COMMUTATIVE -> "commutative" + | COMPUTE -> "compute" + | CONSTANT -> "constant" + | DEBUG -> "debug" + | END -> "end" + | FAIL -> "fail" + | FLAG -> "flag" + | GENERALIZE -> "generalize" + | HAVE -> "have" + | IN -> "in" + | INDUCTION -> "induction" + | INDUCTIVE -> "inductive" + | INFIX -> "infix" + | INJECTIVE -> "injective" + | LET -> "let" + | NOTATION -> "notation" + | OPAQUE -> "opaque" + | OPEN -> "open" + | 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" + | REQUIRE -> "require" + | REWRITE -> "rewrite" + | RULE -> "rule" + | SEARCH -> "search" + | SEQUENTIAL -> "sequential" + | SIMPLIFY -> "simplify" + | SOLVE -> "solve" + | SYMBOL -> "symbol" + | SYMMETRY -> "symmetry" + | TRY -> "try" + | TYPE_QUERY -> "type" + | TYPE_TERM -> "TYPE" + | UNIF_RULE -> "unif_rule" + | VERBOSE -> "verbose" + | WHY3 -> "why3" + | WITH -> "with" + | DEBUG_FLAGS _ -> "debug flags" + | NAT _ -> "natural number" + | NEG_NAT _ -> "negative integer" + | FLOAT _ -> "float" + | SIDE _ -> "left or right" + | STRINGLIT _ -> "string literal" + | SWITCH _ -> "on or off" + | ASSIGN -> "≔" + | ARROW -> "→" + | BACKQUOTE -> "`" + | COMMA -> "," + | COLON -> ":" + | DOT -> "." + | EQUIV -> "≡" + | HOOK_ARROW -> "↪" + | LAMBDA -> "λ" + | L_CU_BRACKET -> "{" + | L_PAREN -> "(" + | L_SQ_BRACKET -> "[" + | PI -> "Π" + | R_CU_BRACKET -> "}" + | R_PAREN -> ")" + | R_SQ_BRACKET -> "]" + | SEMICOLON -> ";" + | TURNSTILE -> "⊢" + | VBAR -> "|" + | UNDERSCORE -> "_" + | UID _ -> "non-qualified identifier" + | UID_EXPL _ -> "@-prefixed non-qualified identifier" + | UID_META _ -> "?-prefixed metavariable number" + | UID_PATT _ -> "$-prefixed non-qualified identifier" + | QID _ -> "qualified identifier" + | QID_EXPL _ -> "@-prefixed qualified identifier" + +let pp_token ppf t = Base.string ppf (string_of_token t) + let expected (msg:string) (tokens:token list): 'a = if msg <> "" then syntax_error (current_pos()) ("expected: "^msg) else @@ -55,6 +156,8 @@ let expected (msg:string) (tokens:token list): 'a = syntax_error (current_pos()) (List.fold_left (fun s t -> s^", "^soft t) ("expected: "^soft t) ts) +(* generic parsing functions *) + let list (elt:lexbuf -> 'a) (lb:lexbuf): 'a list = (*if log_enabled() then log "expected: %s" __FUNCTION__;*) let acc = ref [] in @@ -73,6 +176,8 @@ let consume (token:token) (lb:lexbuf): unit = let prefix (token:token) (elt:lexbuf -> 'a) (lb:lexbuf): 'a = consume token lb; elt lb +(* parsing functions *) + let consume_STRINGLIT (lb:lexbuf): string = match current_token() with | STRINGLIT s -> diff --git a/src/parsing/lpLexer.ml b/src/parsing/lpLexer.ml index fc7decbaf..6c23af3c9 100644 --- a/src/parsing/lpLexer.ml +++ b/src/parsing/lpLexer.ml @@ -344,98 +344,3 @@ let token : lexbuf -> unit -> token * Lexing.position * Lexing.position = let token = let r = ref (EOF, Lexing.dummy_pos, Lexing.dummy_pos) in fun lb () -> Debug.(record_time Lexing (fun () -> r := token lb ())); !r - -let string_of_token = function - | EOF -> "end of file" - | ABORT -> "abort" - | ADMIT -> "admit" - | ADMITTED -> "admitted" - | APPLY -> "apply" - | AS -> "as" - | ASSERT _ -> "assert or assertnot" - | ASSOCIATIVE -> "associative" - | ASSUME -> "assume" - | BEGIN -> "begin" - | BUILTIN -> "builtin" - | COERCE_RULE -> "coerce_rule" - | COMMUTATIVE -> "commutative" - | COMPUTE -> "compute" - | CONSTANT -> "constant" - | DEBUG -> "debug" - | END -> "end" - | FAIL -> "fail" - | FLAG -> "flag" - | GENERALIZE -> "generalize" - | HAVE -> "have" - | IN -> "in" - | INDUCTION -> "induction" - | INDUCTIVE -> "inductive" - | INFIX -> "infix" - | INJECTIVE -> "injective" - | LET -> "let" - | NOTATION -> "notation" - | OPAQUE -> "opaque" - | OPEN -> "open" - | 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" - | REQUIRE -> "require" - | REWRITE -> "rewrite" - | RULE -> "rule" - | SEARCH -> "search" - | SEQUENTIAL -> "sequential" - | SIMPLIFY -> "simplify" - | SOLVE -> "solve" - | SYMBOL -> "symbol" - | SYMMETRY -> "symmetry" - | TRY -> "try" - | TYPE_QUERY -> "type" - | TYPE_TERM -> "TYPE" - | UNIF_RULE -> "unif_rule" - | VERBOSE -> "verbose" - | WHY3 -> "why3" - | WITH -> "with" - | DEBUG_FLAGS _ -> "debug flags" - | NAT _ -> "natural number" - | NEG_NAT _ -> "negative integer" - | FLOAT _ -> "float" - | SIDE _ -> "left or right" - | STRINGLIT _ -> "string literal" - | SWITCH _ -> "on or off" - | ASSIGN -> "≔" - | ARROW -> "→" - | BACKQUOTE -> "`" - | COMMA -> "," - | COLON -> ":" - | DOT -> "." - | EQUIV -> "≡" - | HOOK_ARROW -> "↪" - | LAMBDA -> "λ" - | L_CU_BRACKET -> "{" - | L_PAREN -> "(" - | L_SQ_BRACKET -> "[" - | PI -> "Π" - | R_CU_BRACKET -> "}" - | R_PAREN -> ")" - | R_SQ_BRACKET -> "]" - | SEMICOLON -> ";" - | TURNSTILE -> "⊢" - | VBAR -> "|" - | UNDERSCORE -> "_" - | UID _ -> "non-qualified identifier" - | UID_EXPL _ -> "@-prefixed non-qualified identifier" - | UID_META _ -> "?-prefixed metavariable number" - | UID_PATT _ -> "$-prefixed non-qualified identifier" - | QID _ -> "qualified identifier" - | QID_EXPL _ -> "@-prefixed qualified identifier" - -let pp_token ppf t = Base.string ppf (string_of_token t) From de901bd2a8dca3eb93832c6cd7e303bc54731ed8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Thu, 1 Aug 2024 19:43:04 +0200 Subject: [PATCH 03/35] rewrite parser.ml --- src/parsing/ll1.ml | 3 + src/parsing/lpLexer.ml | 16 +-- src/parsing/parser.ml | 247 +++++++++++++++++++++++------------------ 3 files changed, 151 insertions(+), 115 deletions(-) diff --git a/src/parsing/ll1.ml b/src/parsing/ll1.ml index d36f16015..337638677 100644 --- a/src/parsing/ll1.ml +++ b/src/parsing/ll1.ml @@ -176,6 +176,9 @@ let consume (token:token) (lb:lexbuf): unit = 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 = diff --git a/src/parsing/lpLexer.ml b/src/parsing/lpLexer.ml index 6c23af3c9..e492af8ad 100644 --- a/src/parsing/lpLexer.ml +++ b/src/parsing/lpLexer.ml @@ -4,13 +4,13 @@ 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. *) @@ -337,8 +337,8 @@ and comment next i lb = 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 -> + | MalFormed -> fail lb "Not Utf8 encoded file" + | InvalidCodepoint k -> fail lb ("Invalid Utf8 code point " ^ string_of_int k) let token = diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index 2ea099a95..07b977eac 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -7,6 +7,10 @@ open Lplib open Base open Common +open Syntax +open Lexing + +type lexpos = Lexing.position (** [parser_fatal pos fmt] is a wrapper for [Error.fatal] that enforces that the error has an attached source code position. *) @@ -15,158 +19,187 @@ let parser_fatal : Pos.pos -> ('a,'b) koutfmt -> 'a = fun pos fmt -> (** Module type of a parser. *) module type PARSER = sig - val parse : in_channel -> Syntax.ast - (** [parse inchan] returns a stream of commands parsed from - channel [inchan]. Commands are parsed lazily and the channel is + val parse_in_channel : in_channel -> ast + (** [parse ic] returns a stream of commands parsed from + channel [ic]. Commands are parsed lazily and the channel is closed once all entries are parsed. *) - val parse_file : string -> Syntax.ast + val parse_file : string -> ast (** [parse_file fname] returns a stream of parsed commands of file [fname]. Commands are parsed lazily. *) - val parse_string : string -> string -> Syntax.ast + val parse_string : string -> string -> ast (** [parse_string f s] returns a stream of parsed commands from string [s] which comes from file [f] ([f] can be anything). *) end -module Lp : -sig - include PARSER +(** Parsing dk syntax. *) +module Dk : PARSER = struct - 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. *) + open Lexing - 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. *) + (* defined in OCaml >= 4.11 only *) + let set_filename (lb:lexbuf) (fname:string): unit = + lb.lex_curr_p <- {lb.lex_curr_p with pos_fname = fname} - val parse_term_string : string -> string -> Syntax.p_term Stream.t - (** [parse_string f s] returns a stream of parsed terms from string [s] - which comes from file [f] ([f] can be anything). *) + (* old code: + let parse_lexbuf : + ?ic:in_channel -> ?fname:string -> lexbuf -> p_command Stream.t = + fun ?ic ?fname lb -> + Option.iter (set_filename lb) fname; + let generator _ = + try Some (command lb) + with + | End_of_file -> Option.iter close_in ic; None + | DkParser.Error -> + let pos = Pos.locate (lb.lex_start_p, lb.lex_curr_p) in + parser_fatal pos "Unexpected token \"%s\"." (lexeme lb) + in + Stream.from generator + + let parse_string fname s = parse_lexbuf ~fname (from_string s) + + let parse_in_channel ic = + try parse_lexbuf ~ic (from_channel ic) + with e -> close_in ic; raise e + + let parse_file fname = + let ic = open_in fname in + parse_lexbuf ~ic ~fname (from_channel ic)*) + + let parse_lexbuf (icopt:in_channel option) (entry:lexbuf -> 'a) (lb:lexbuf) + : 'a Stream.t = + let generator _ = + try Some(entry lb) + with + | End_of_file -> Option.iter close_in icopt; None + | DkParser.Error -> + let pos = Pos.locate (lb.lex_start_p, lb.lex_curr_p) in + parser_fatal pos "Unexpected token \"%s\"." (lexeme lb) + in + Stream.from generator + + let parse_in_channel (entry:lexbuf -> 'a) (ic:in_channel): 'a Stream.t = + parse_lexbuf (Some ic) entry (from_channel ic) + + let parse_file entry fname = parse_in_channel entry (open_in fname) + + let parse_string (entry: lexbuf -> 'a) (fname:string) (s:string) + : 'a Stream.t = + let lb = from_string s in + set_filename lb fname; + parse_lexbuf None entry lb + + let command = + let r = ref (Pos.none (P_open [])) in + fun (lb:lexbuf): p_command -> + Debug.(record_time Parsing + (fun () -> r := DkParser.line DkLexer.token lb)); !r + + (* exported functions *) + let parse_string = parse_string command + let parse_in_channel = parse_in_channel command + let parse_file = parse_file command + +end + +(** Parsing lp syntax. *) +module Lp : +sig + include PARSER 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 - let stream_of_lexbuf : - grammar_entry:(LpLexer.token,'b) MenhirLib.Convert.traditional -> - ?inchan:in_channel -> ?fname:string -> Sedlexing.lexbuf -> + open LpLexer + open Sedlexing + + (* old Menhir parser *) + + type tokenizer = unit -> token * lexpos * lexpos + type 'a parser = tokenizer -> 'a + + let parse_lexbuf : + grammar_entry:(token,'b) MenhirLib.Convert.traditional -> + ?ic:in_channel -> ?fname:string -> lexbuf -> (* Input channel passed as parameter to be closed at the end of stream. *) 'a Stream.t = - fun ~grammar_entry ?inchan ?fname lb -> - Option.iter (Sedlexing.set_filename lb) fname; - let parse = - MenhirLib.Convert.Simplified.traditional2revised - grammar_entry - in + fun ~grammar_entry ?ic ?fname lb -> + Option.iter (set_filename lb) fname; + let parse: 'a parser = + MenhirLib.Convert.Simplified.traditional2revised grammar_entry in let token = LpLexer.token lb in let generator _ = - try Some(parse token) + try Some (parse token) with - | End_of_file -> Option.iter close_in inchan; None - | LpLexer.SyntaxError {pos=None; _} -> assert false - | LpLexer.SyntaxError {pos=Some pos; elt} -> parser_fatal pos "%s" elt + | End_of_file -> Option.iter close_in ic; None + | SyntaxError {pos=None; _} -> assert false + | SyntaxError {pos=Some pos; elt} -> parser_fatal pos "%s" elt | LpParser.Error -> - let pos = Pos.locate (Sedlexing.lexing_positions lb) in - parser_fatal pos "Unexpected token: \"%s\"." - (Sedlexing.Utf8.lexeme lb) + let pos = Pos.locate (lexing_positions lb) in + parser_fatal pos "Unexpected token: \"%s\"." (Utf8.lexeme lb) in Stream.from generator - let parse ~grammar_entry inchan = - stream_of_lexbuf ~grammar_entry ~inchan - (Sedlexing.Utf8.from_channel inchan) - - let parse_file ~grammar_entry fname = - let inchan = open_in fname in - stream_of_lexbuf ~grammar_entry ~inchan ~fname - (Sedlexing.Utf8.from_channel inchan) - let parse_string ~grammar_entry fname s = - stream_of_lexbuf ~grammar_entry ~fname (Sedlexing.Utf8.from_string s) + parse_lexbuf ~grammar_entry ~fname (Utf8.from_string s) - let parse_term = parse ~grammar_entry:LpParser.term_alone - let parse_term_string = parse_string ~grammar_entry:LpParser.term_alone let parse_search_query_string = parse_string ~grammar_entry:LpParser.search_query_alone - let parse_term_file = parse_file ~grammar_entry:LpParser.term_alone - - let parse_qid s = - let stream = parse_string ~grammar_entry:LpParser.qid_alone "LPSearch" s in - (Stream.next stream).elt - - let parse = parse ~grammar_entry:LpParser.command - let parse_string = parse_string ~grammar_entry:LpParser.command - let parse_file fname = (*parse_file ~grammar_entry:LpParser.command fname*) - let inchan = open_in fname in - let lb = Sedlexing.Utf8.from_channel inchan in - Sedlexing.set_filename lb fname; + + (*let parse_in_channel ~grammar_entry ic = + parse_lexbuf ~grammar_entry ~ic (Utf8.from_channel ic) + + let parse_file ~grammar_entry fname = + let ic = open_in fname in + parse_lexbuf ~grammar_entry ~ic ~fname (Utf8.from_channel ic) + + let parse_in_channel = parse_in_channel ~grammar_entry:LpParser.command + let parse_file fname = parse_file ~grammar_entry:LpParser.command fname + let parse_string = parse_string ~grammar_entry:LpParser.command*) + + (* new parser *) + + let parse_lexbuf icopt entry lb = let generator _ = - try Some(Ll1.command lb) + try Some(entry lb) with - | End_of_file -> close_in inchan; None - | LpLexer.SyntaxError {pos=None; _} -> assert false - | LpLexer.SyntaxError {pos=Some pos; elt} -> parser_fatal pos "%s" elt - | LpParser.Error -> - let pos = Pos.locate (Sedlexing.lexing_positions lb) in - parser_fatal pos "Unexpected token: \"%s\"." - (Sedlexing.Utf8.lexeme lb) + | End_of_file -> Option.iter close_in icopt; None + | SyntaxError{pos=None; _} -> assert false + | SyntaxError{pos=Some pos; elt} -> parser_fatal pos "%s" elt in Stream.from generator -end - -(** Parsing dk syntax. *) -module Dk : PARSER = struct - - let token : Lexing.lexbuf -> DkTokens.token = - let r = ref DkTokens.EOF in fun lb -> - Debug.(record_time Lexing (fun () -> r := DkLexer.token lb)); !r + let parse_string entry fname s = + let lb = Utf8.from_string s in + set_filename lb fname; + parse_lexbuf None entry lb - let command : - (Lexing.lexbuf -> DkTokens.token) -> Lexing.lexbuf -> Syntax.p_command = - let r = ref (Pos.none (Syntax.P_open [])) in fun token lb -> - Debug.(record_time Parsing (fun () -> r := DkParser.line token lb)); !r + let parse_in_channel entry ic = + parse_lexbuf (Some ic) entry (Utf8.from_channel ic) - let stream_of_lexbuf : - ?inchan:in_channel -> ?fname:string -> Lexing.lexbuf -> - (* Input channel passed as parameter to be closed at the end of stream. *) - Syntax.p_command Stream.t = - fun ?inchan ?fname lb -> - let fn n = - lb.lex_curr_p <- {lb.lex_curr_p with pos_fname = n} - in - Option.iter fn fname; - (*In OCaml >= 4.11: Lexing.set_filename lb fname;*) - let generator _ = - try Some (command token lb) - with - | End_of_file -> Option.iter close_in inchan; None - | DkParser.Error -> - let pos = Pos.locate (Lexing.(lb.lex_start_p, lb.lex_curr_p)) in - parser_fatal pos "Unexpected token \"%s\"." (Lexing.lexeme lb) - in - Stream.from generator + (*let parse_file entry fname = + let ic = open_in fname in + let lb = Utf8.from_channel ic in + set_filename lb fname; (* useful? *) + let x = parse_lexbuf entry lb in + close_in ic; + x*) - let parse inchan = - try stream_of_lexbuf ~inchan (Lexing.from_channel inchan) - with e -> close_in inchan; raise e + let parse_file entry fname = parse_in_channel entry (open_in fname) - let parse_file fname = - let inchan = open_in fname in - stream_of_lexbuf ~inchan ~fname (Lexing.from_channel inchan) + (* exported functions *) + let parse_string = parse_string Ll1.command + let parse_in_channel = parse_in_channel Ll1.command + let parse_file = parse_file Ll1.command - let parse_string fname s = stream_of_lexbuf ~fname (Lexing.from_string s) end -(* Include parser of new syntax so that functions are directly available.*) include Lp (** [path_of_string s] converts the string [s] into a path. *) @@ -196,7 +229,7 @@ let qident_of_string : string -> Core.Term.qident = fun s -> (** [parse_file fname] selects and runs the correct parser on file [fname], by looking at its extension. *) -let parse_file : string -> Syntax.ast = fun fname -> +let parse_file : string -> ast = fun fname -> match Filename.check_suffix fname Library.lp_src_extension with | true -> Lp.parse_file fname | false -> Dk.parse_file fname From c13d4ec87886e7b60f9ab18a16dcea54a16c2ba4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Thu, 1 Aug 2024 20:50:56 +0200 Subject: [PATCH 04/35] extend new parser to search command --- src/parsing/ll1.ml | 116 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 116 insertions(+) diff --git a/src/parsing/ll1.ml b/src/parsing/ll1.ml index 337638677..0d00636c7 100644 --- a/src/parsing/ll1.ml +++ b/src/parsing/ll1.ml @@ -5,6 +5,7 @@ open Core open LpLexer open Lexing open Sedlexing +open SearchQuerySyntax (*let log = Logger.make 'n' "pars" "parsing" let log = log.pp*) @@ -357,6 +358,8 @@ let term_id (lb:lexbuf): p_term = | _ -> expected "" [UID"";QID[];UID_EXPL"";QID_EXPL[]] +(* commands *) + let rec command pos1 p_sym_mod (lb:lexbuf): p_command = (*if log_enabled() then log "expected: %s" __FUNCTION__;*) match current_token() with @@ -684,6 +687,8 @@ and equation (lb:lexbuf): p_term * p_term = let r = term lb in (l, r) +(* queries *) + and query (lb:lexbuf): p_query = (*if log_enabled() then log "expected: %s" __FUNCTION__;*) match current_token() with @@ -787,6 +792,8 @@ and term_proof (lb:lexbuf): p_term option * (p_proof * p_proof_end) option = Some t, None end +(* proofs *) + and proof (lb:lexbuf): p_proof * p_proof_end = (*if log_enabled() then log "expected: %s" __FUNCTION__;*) consume BEGIN lb; @@ -1129,6 +1136,8 @@ and rw_patt_spec (lb:lexbuf): p_rw_patt = | _ -> expected "" [L_SQ_BRACKET] +(* terms *) + and params (lb:lexbuf): p_params = (*if log_enabled() then log "expected: %s" __FUNCTION__;*) match current_token() with @@ -1413,6 +1422,113 @@ and binder (lb:lexbuf): p_params list * p_term = | _ -> expected "" [UID"";NAT"";UNDERSCORE;L_PAREN;L_SQ_BRACKET] +(* search *) + +and where (lb:lexbuf): bool * inside option = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + match current_token() with + | UID u -> + let r = + match u with + | "=" -> Some Exact + | ">" -> Some Inside + | "≥" + | ">=" -> None + | _ -> expected "\">\", \"=\", \"≥\",\">=\"" [] + in + consume_token lb; + let g = + match current_token() with + | GENERALIZE -> consume_token lb; true + | _ -> false + in + g,r + | _ -> + expected "\">\", \"=\", \"≥\",\">=\"" [] + +and asearch_query(lb:lexbuf): query = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + match current_token() with + | TYPE_QUERY -> + consume_token lb; + let g, w = where lb in + let t = aterm lb in + if w <> None then expected "\"≥\", \">=\"" [] + else QBase(QSearch(t,g,Some(QType None))) + | RULE -> + consume_token lb; + let g, w = where lb in + let t = aterm lb in + QBase(QSearch(t,g,Some (QXhs(w,None)))) + | UID k -> + consume_token lb; + let g, w = where lb in + let t = aterm lb in + begin + match k, t.elt with + | "name", P_Iden(id,false) -> + assert (fst id.elt = []); + if w <> Some Exact then expected "\"=\"" [] + else if g then + expected "\"generalize\" cannot be used with \"name\"" [] + else QBase(QName(snd id.elt)) + | "name", _ -> + expected "path prefix" [] + | "anywhere", _ -> + if w <> None then expected "\"≥\", \">=\"" [] + 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)))) + | _ -> + expected "Unknown keyword" [] + end + | L_PAREN -> + consume_token lb; + let q = search_query lb in + consume R_PAREN lb; + q + | _ -> + expected "" [TYPE_QUERY;RULE;UID"";L_PAREN] + +and csearch_query (lb:lexbuf): query = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + let aq = asearch_query lb in + match current_token() with + | COMMA -> + let aqs = list (prefix COMMA asearch_query) lb in + List.fold_left (fun x aq -> QOpp(x,Intersect,aq)) aq aqs + | _ -> + aq + +and ssearch_query (lb:lexbuf): query = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + let cq = csearch_query lb in + match current_token() with + | SEMICOLON -> + let cqs = list (prefix SEMICOLON csearch_query) lb in + List.fold_left (fun x cq -> QOpp(x,Union,cq)) cq cqs + | _ -> + cq + +and search_query (lb:lexbuf): query = + (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + let q = ssearch_query 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; From 4c8c8ee18b1584614fdece17b874e243c5f2308b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 2 Aug 2024 19:48:42 +0200 Subject: [PATCH 05/35] wip --- src/common/error.ml | 3 +- src/common/pos.ml | 4 +- src/handle/command.ml | 4 +- src/handle/query.ml | 2 +- src/parsing/ll1.ml | 199 ++++++++++++++++++++------------------- src/parsing/lpParser.mly | 2 +- src/parsing/parser.ml | 57 ++++++----- src/parsing/pretty.ml | 26 ++++- src/parsing/syntax.ml | 27 +++++- src/tool/indexing.ml | 43 ++++----- src/tool/indexing.mli | 2 + 11 files changed, 209 insertions(+), 160 deletions(-) diff --git a/src/common/error.ml b/src/common/error.ml index 975284cc7..49dd4eba8 100644 --- a/src/common/error.ml +++ b/src/common/error.ml @@ -73,4 +73,5 @@ let handle_exceptions : (unit -> unit) -> unit = fun f -> try f () with | Fatal(None, msg) -> exit_with "%s" msg | Fatal(Some(p), msg) -> exit_with "[%a] %s" Pos.pp p msg - | e -> exit_with "Uncaught [%s]." (Printexc.to_string e) + | e -> + exit_with "Uncaught exception: %s" (Printexc.to_string e) diff --git a/src/common/pos.ml b/src/common/pos.ml index 4587ab0f7..4ed68be8a 100644 --- a/src/common/pos.ml +++ b/src/common/pos.ml @@ -102,8 +102,8 @@ let to_string : ?print_fname:bool -> pos -> string = let popt_to_string : ?print_fname:bool -> popt -> string = fun ?(print_fname=true) pop -> match pop with - | None -> "Unknown location " - | Some (p) -> to_string ~print_fname p ^ " " + | None -> "Unknown location" + | Some (p) -> to_string ~print_fname p (** [pp ppf pos] prints the optional position [pos] on [ppf]. *) let pp : popt Lplib.Base.pp = fun ppf p -> diff --git a/src/handle/command.ml b/src/handle/command.ml index a9c820deb..32c1929f4 100644 --- a/src/handle/command.ml +++ b/src/handle/command.ml @@ -579,8 +579,8 @@ let get_proof_data : compiler -> sig_state -> p_command -> cmd_output = 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(None ,m) -> fatal pos "%s" m + | Fatal(Some(None) ,m) -> fatal pos "%s" m | e -> fatal pos "Uncaught exception: %s." (Printexc.to_string e) diff --git a/src/handle/query.ml b/src/handle/query.ml index 7c84b3692..886289194 100644 --- a/src/handle/query.ml +++ b/src/handle/query.ml @@ -156,7 +156,7 @@ let handle : Sig_state.t -> proof_state option -> p_query -> result = let ctxt = Env.to_ctxt env in let p = new_problem() in match elt with - | P_query_search s -> return string (Tool.Indexing.search_cmd_txt s) + | P_query_search q -> return string (Tool.Indexing.query_results q) | P_query_debug(_,_) | P_query_verbose(_) | P_query_flag(_,_) diff --git a/src/parsing/ll1.ml b/src/parsing/ll1.ml index 0d00636c7..2943795d7 100644 --- a/src/parsing/ll1.ml +++ b/src/parsing/ll1.ml @@ -5,51 +5,12 @@ open Core open LpLexer open Lexing open Sedlexing -open SearchQuerySyntax -(*let log = Logger.make 'n' "pars" "parsing" -let log = log.pp*) +let log = Logger.make 'n' "pars" "parsing" +let log = log.pp (* token management *) -let the_current_token : (token * position * position) Stdlib.ref = - Stdlib.ref (EOF, dummy_pos, dummy_pos) - -let current_token() : token = - let (t,_,_) = !the_current_token in - (*if log_enabled() then log "current_token: %a" pp_token t;*) - t - -let current_pos() : position * position = - let (_,p1,p2) = !the_current_token in (p1,p2) - -let consume_token (lb:lexbuf) : unit = - the_current_token := LpLexer.token lb ()(*; - if log_enabled() then log "read new token"*) - -(* building positions and terms *) - -let make_pos (lps:position * position): 'a -> 'a loc = - Pos.make_pos (fst lps, snd (current_pos())) - -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 make_pos (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 make_pos (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 identifier" - (* error messages *) let string_of_token = function @@ -147,26 +108,65 @@ let string_of_token = function let pp_token ppf t = Base.string ppf (string_of_token t) +let the_current_token : (token * position * position) Stdlib.ref = + Stdlib.ref (EOF, dummy_pos, dummy_pos) + +let current_token() : token = + let (t,_,_) = !the_current_token in + if log_enabled() then log "current_token: %a" pp_token t; + t + +let current_pos() : position * position = + let (_,p1,p2) = !the_current_token in (p1,p2) + let expected (msg:string) (tokens:token list): 'a = - if msg <> "" then syntax_error (current_pos()) ("expected: "^msg) + 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) + (List.fold_left (fun s t -> s^", "^soft t) ("Expected: "^soft t) ts + ^".") + +let consume_token (lb:lexbuf) : unit = + the_current_token := token lb (); + if log_enabled() then log "read new token" + +(* building positions and terms *) + +let make_pos (lps:position * position): 'a -> 'a loc = + Pos.make_pos (fst lps, snd (current_pos())) + +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 make_pos (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 make_pos (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 identifier." (* generic parsing functions *) let list (elt:lexbuf -> 'a) (lb:lexbuf): 'a list = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %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 "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) let x = elt lb in x :: list elt lb @@ -207,7 +207,7 @@ let consume_NAT (lb:lexbuf): string = expected "" [NAT""] let qid (lb:lexbuf): (string list * string) loc = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | UID s -> let pos1 = current_pos() in @@ -221,7 +221,7 @@ let qid (lb:lexbuf): (string list * string) loc = expected "" [UID"";QID[]] let qid_expl (lb:lexbuf): (string list * string) loc = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | UID_EXPL s -> let pos1 = current_pos() in @@ -235,7 +235,7 @@ let qid_expl (lb:lexbuf): (string list * string) loc = expected "" [UID_EXPL"";QID_EXPL[]] let uid (lb:lexbuf): string loc = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | UID s -> let pos1 = current_pos() in @@ -245,7 +245,7 @@ let uid (lb:lexbuf): string loc = expected "" [UID""] let param (lb:lexbuf): string loc option = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | UID s | NAT s -> @@ -259,7 +259,7 @@ let param (lb:lexbuf): string loc option = expected "non-qualified identifier or \"_\"" [UID"";NAT"";UNDERSCORE] let int (lb:lexbuf): string = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | NAT s | NEG_NAT s -> @@ -269,7 +269,7 @@ let int (lb:lexbuf): string = expected "integer" [NAT"";NEG_NAT""] let float_or_int (lb:lexbuf): string = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | NAT s | NEG_NAT s @@ -280,7 +280,7 @@ let float_or_int (lb:lexbuf): string = expected "integer or float" [NAT"";NEG_NAT"";FLOAT""] let uid_or_int (lb:lexbuf): string loc = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | UID s | NAT s @@ -292,7 +292,7 @@ let uid_or_int (lb:lexbuf): string loc = expected "non-qualified identifier" [UID"";NAT"";NEG_NAT""] let qid_or_int (lb:lexbuf): (string list * string) loc = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | QID p -> let pos1 = current_pos() in @@ -308,7 +308,7 @@ let qid_or_int (lb:lexbuf): (string list * string) loc = expected "possibly qualified identifier" [UID"";QID[];NAT"";NEG_NAT""] let path (lb:lexbuf): string list loc = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with (*| UID s -> let pos1 = current_pos() in @@ -321,7 +321,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 "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | UID s -> let pos1 = current_pos() in @@ -343,7 +343,7 @@ let qid_or_rule (lb:lexbuf): (string list * string) loc = expected "" [UID"";QID[];UNIF_RULE;COERCE_RULE] let term_id (lb:lexbuf): p_term = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | UID _ | QID _ -> @@ -361,7 +361,7 @@ let term_id (lb:lexbuf): p_term = (* commands *) let rec command pos1 p_sym_mod (lb:lexbuf): p_command = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | SIDE _ | ASSOCIATIVE @@ -589,7 +589,7 @@ and constructor (lb:lexbuf): p_ident * p_term = i, make_prod (fst pos1) ps t (snd (current_pos())) and modifier (lb:lexbuf): p_modifier = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | SIDE d -> let pos1 = current_pos() in @@ -630,7 +630,7 @@ and modifier (lb:lexbuf): p_modifier = exposition lb and exposition (lb:lexbuf): p_modifier = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | PRIVATE -> let pos1 = current_pos() in @@ -644,7 +644,7 @@ and exposition (lb:lexbuf): p_modifier = expected "" [PRIVATE;PROTECTED] and notation (lb:lexbuf): string Sign.notation = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | INFIX -> consume_token lb; @@ -673,7 +673,7 @@ and notation (lb:lexbuf): string Sign.notation = expected "" [INFIX;POSTFIX;PREFIX;QUANTIFIER] and rule (lb:lexbuf): (p_term * p_term) loc = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) let pos1 = current_pos() in let l = term lb in consume HOOK_ARROW lb; @@ -681,7 +681,7 @@ and rule (lb:lexbuf): (p_term * p_term) loc = make_pos pos1 (l, r) and equation (lb:lexbuf): p_term * p_term = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) let l = term lb in consume EQUIV lb; let r = term lb in @@ -690,7 +690,7 @@ and equation (lb:lexbuf): p_term * p_term = (* queries *) and query (lb:lexbuf): p_query = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | ASSERT b -> let pos1 = current_pos() in @@ -768,15 +768,16 @@ and query (lb:lexbuf): p_query = consume_token lb; let t = term lb in make_pos pos1 (P_query_infer(t, {strategy=NONE; steps=None})) - (*| SEARCH s -> + | SEARCH -> let pos1 = current_pos() in consume_token lb; - make_pos pos1 (P_query_search s)*) + let q = search lb in + make_pos 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 "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | BEGIN -> let p = proof lb in @@ -795,7 +796,7 @@ and term_proof (lb:lexbuf): p_term option * (p_proof * p_proof_end) option = (* proofs *) and proof (lb:lexbuf): p_proof * p_proof_end = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) consume BEGIN lb; match current_token() with | L_CU_BRACKET -> @@ -843,7 +844,7 @@ and proof (lb:lexbuf): p_proof * p_proof_end = expected "subproof, tactic or query" [] and subproof (lb:lexbuf): p_proofstep list = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | L_CU_BRACKET -> consume_token lb; @@ -854,7 +855,7 @@ and subproof (lb:lexbuf): p_proofstep list = expected "" [L_CU_BRACKET] and steps (lb:lexbuf): p_proofstep list = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with (*queries*) | ASSERT _ @@ -896,13 +897,13 @@ and steps (lb:lexbuf): p_proofstep list = expected "tactic or query" [] and step (lb:lexbuf): p_proofstep = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %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 "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | ABORT -> let pos1 = current_pos() in @@ -920,7 +921,7 @@ and proof_end (lb:lexbuf): p_proof_end = expected "" [ABORT;ADMITTED;END] and tactic (lb:lexbuf): p_tactic = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with (*queries*) | ASSERT _ @@ -1054,7 +1055,7 @@ and tactic (lb:lexbuf): p_tactic = expected "tactic" [] and rw_patt (lb:lexbuf): p_rw_patt = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with (* bterm *) | BACKQUOTE @@ -1126,7 +1127,7 @@ and rw_patt (lb:lexbuf): p_rw_patt = expected "term or keyword \"in\"" [] and rw_patt_spec (lb:lexbuf): p_rw_patt = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | L_SQ_BRACKET -> consume_token lb; @@ -1139,7 +1140,7 @@ and rw_patt_spec (lb:lexbuf): p_rw_patt = (* terms *) and params (lb:lexbuf): p_params = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | L_PAREN -> consume_token lb; @@ -1178,7 +1179,7 @@ and params (lb:lexbuf): p_params = [x], None, false and term (lb:lexbuf): p_term = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with (* bterm *) | BACKQUOTE @@ -1206,7 +1207,7 @@ and term (lb:lexbuf): p_term = expected "term" [] and app (pos1:position * position) (t: p_term) (lb:lexbuf): p_term = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with (* aterm *) | UID _ @@ -1239,7 +1240,7 @@ and app (pos1:position * position) (t: p_term) (lb:lexbuf): p_term = t and bterm (lb:lexbuf): p_term = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | BACKQUOTE -> let pos1 = current_pos() in @@ -1285,7 +1286,7 @@ and bterm (lb:lexbuf): p_term = expected "" [BACKQUOTE;PI;LAMBDA;LET] and aterm (lb:lexbuf): p_term = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | UID _ | QID _ @@ -1349,7 +1350,7 @@ and aterm (lb:lexbuf): p_term = brackets" [] and env (lb:lexbuf): p_term list = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | L_SQ_BRACKET -> consume_token lb; @@ -1368,7 +1369,7 @@ and env (lb:lexbuf): p_term list = expected "" [L_SQ_BRACKET] and binder (lb:lexbuf): p_params list * p_term = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | UID _ | NAT _ @@ -1425,7 +1426,7 @@ and binder (lb:lexbuf): p_params list * p_term = (* search *) and where (lb:lexbuf): bool * inside option = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | UID u -> let r = @@ -1446,8 +1447,8 @@ and where (lb:lexbuf): bool * inside option = | _ -> expected "\">\", \"=\", \"≥\",\">=\"" [] -and asearch_query(lb:lexbuf): query = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) +and asearch (lb:lexbuf): query = + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | TYPE_QUERY -> consume_token lb; @@ -1459,7 +1460,7 @@ and asearch_query(lb:lexbuf): query = consume_token lb; let g, w = where lb in let t = aterm lb in - QBase(QSearch(t,g,Some (QXhs(w,None)))) + QBase(QSearch(t,g,Some(QXhs(w,None)))) | UID k -> consume_token lb; let g, w = where lb in @@ -1492,35 +1493,35 @@ and asearch_query(lb:lexbuf): query = end | L_PAREN -> consume_token lb; - let q = search_query lb in + let q = search lb in consume R_PAREN lb; q | _ -> - expected "" [TYPE_QUERY;RULE;UID"";L_PAREN] + expected "name, anywhere, rule, lhs, rhs, type, concl, hyp, spine" [] -and csearch_query (lb:lexbuf): query = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) - let aq = asearch_query lb in +and csearch (lb:lexbuf): query = + if log_enabled() then log "Expected: %s" __FUNCTION__; + let aq = asearch lb in match current_token() with | COMMA -> - let aqs = list (prefix COMMA asearch_query) lb in + let aqs = list (prefix COMMA asearch) lb in List.fold_left (fun x aq -> QOpp(x,Intersect,aq)) aq aqs | _ -> aq -and ssearch_query (lb:lexbuf): query = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) - let cq = csearch_query lb in +and ssearch (lb:lexbuf): query = + if log_enabled() then log "Expected: %s" __FUNCTION__; + let cq = csearch lb in match current_token() with | SEMICOLON -> - let cqs = list (prefix SEMICOLON csearch_query) lb in + let cqs = list (prefix SEMICOLON csearch) lb in List.fold_left (fun x cq -> QOpp(x,Union,cq)) cq cqs | _ -> cq -and search_query (lb:lexbuf): query = - (*if log_enabled() then log "expected: %s" __FUNCTION__;*) - let q = ssearch_query lb in +and search (lb:lexbuf): query = + if log_enabled() then log "Expected: %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 @@ -1530,7 +1531,7 @@ and search_query (lb:lexbuf): query = 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";*) + if log_enabled() then log "------------------- start reading command"; consume_token lb; if current_token() = EOF then raise End_of_file else diff --git a/src/parsing/lpParser.mly b/src/parsing/lpParser.mly index c25a151fc..d7b7e3c62 100644 --- a/src/parsing/lpParser.mly +++ b/src/parsing/lpParser.mly @@ -207,7 +207,7 @@ query: | TYPE_QUERY t=term { make_pos $sloc (P_query_infer(t, {strategy=NONE; steps=None}))} | SEARCH s=STRINGLIT - { make_pos $sloc (P_query_search s) } + { make_pos $sloc (P_query_search(QBase(QName s))) } qid_or_rule: | i=qid { i } diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index 07b977eac..c65120415 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -10,8 +10,6 @@ open Common open Syntax open Lexing -type lexpos = Lexing.position - (** [parser_fatal pos fmt] is a wrapper for [Error.fatal] that enforces that the error has an attached source code position. *) let parser_fatal : Pos.pos -> ('a,'b) koutfmt -> 'a = fun pos fmt -> @@ -103,25 +101,22 @@ module Dk : PARSER = struct end +open LpLexer +open Sedlexing + (** Parsing lp syntax. *) module Lp : sig include PARSER - 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_search_query_string : (*fname*)string -> (*query*)string -> query end = struct - open LpLexer - open Sedlexing - (* old Menhir parser *) - type tokenizer = unit -> token * lexpos * lexpos + type tokenizer = unit -> token * position * position type 'a parser = tokenizer -> 'a let parse_lexbuf : @@ -139,7 +134,8 @@ sig with | End_of_file -> Option.iter close_in ic; None | SyntaxError {pos=None; _} -> assert false - | SyntaxError {pos=Some pos; elt} -> parser_fatal pos "%s" elt + | SyntaxError {pos=Some pos; elt} -> + parser_fatal pos "Syntax error. %s" elt | LpParser.Error -> let pos = Pos.locate (lexing_positions lb) in parser_fatal pos "Unexpected token: \"%s\"." (Utf8.lexeme lb) @@ -149,8 +145,8 @@ sig let parse_string ~grammar_entry fname s = parse_lexbuf ~grammar_entry ~fname (Utf8.from_string s) - let parse_search_query_string = - parse_string ~grammar_entry:LpParser.search_query_alone + (*let parse_search_query_string = + parse_string ~grammar_entry:LpParser.search_query_alone*) (*let parse_in_channel ~grammar_entry ic = parse_lexbuf ~grammar_entry ~ic (Utf8.from_channel ic) @@ -165,22 +161,25 @@ sig (* new parser *) - let parse_lexbuf icopt entry lb = + let parse_lexbuf (icopt: in_channel option) (entry: lexbuf -> 'a) + (lb: lexbuf): 'a Stream.t = let generator _ = try Some(entry lb) with | End_of_file -> Option.iter close_in icopt; None | SyntaxError{pos=None; _} -> assert false - | SyntaxError{pos=Some pos; elt} -> parser_fatal pos "%s" elt + | SyntaxError{pos=Some pos; elt} -> + parser_fatal pos "Syntax error. %s" elt in Stream.from generator - let parse_string entry fname s = + let parse_string (entry: lexbuf -> 'a) (fname: string) (s: string) + : 'a Stream.t = let lb = Utf8.from_string s in set_filename lb fname; parse_lexbuf None entry lb - let parse_in_channel entry ic = + let parse_in_channel (entry: lexbuf -> 'a) (ic: in_channel): 'a Stream.t = parse_lexbuf (Some ic) entry (Utf8.from_channel ic) (*let parse_file entry fname = @@ -191,9 +190,13 @@ sig close_in ic; x*) - let parse_file entry fname = parse_in_channel entry (open_in fname) + let parse_file (entry: lexbuf -> 'a) (fname: string): 'a Stream.t = + parse_in_channel entry (open_in fname) (* exported functions *) + let parse_search_query_string (fname: string) (s: string): query = + Stream.next (parse_string (Ll1.alone Ll1.search) fname s) + let parse_string = parse_string Ll1.command let parse_in_channel = parse_in_channel Ll1.command let parse_file = parse_file Ll1.command @@ -202,30 +205,32 @@ end include Lp +open Error + (** [path_of_string s] converts the string [s] into a path. *) let path_of_string : string -> Path.t = fun s -> - let open LpLexer in - let lb = Sedlexing.Utf8.from_string s in + let lb = Utf8.from_string s in try begin match token lb () with | UID s, _, _ -> [s] | QID p, _, _ -> List.rev p - | _ -> Error.fatal_no_pos "\"%s\" is not a path." s + | _ -> fatal_no_pos "Syntax error: \"%s\" is not a path." s end - with SyntaxError _ -> Error.fatal_no_pos "\"%s\" is not a path." s + with 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 -> - let open LpLexer in - let lb = Sedlexing.Utf8.from_string s in + let lb = Utf8.from_string s in try begin match token lb () with | QID [], _, _ -> assert false | QID (s::p), _, _ -> (List.rev p, s) - | _ -> Error.fatal_no_pos "\"%s\" is not a qualified identifier." s + | _ -> + fatal_no_pos "Syntax error: \"%s\" is not a qualified identifier." s end with SyntaxError _ -> - Error.fatal_no_pos "\"%s\" is not a qualified identifier." s + 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/pretty.ml b/src/parsing/pretty.ml index f41b97ba2..08e054b54 100644 --- a/src/parsing/pretty.ml +++ b/src/parsing/pretty.ml @@ -239,6 +239,30 @@ let assertion : p_assertion pp = fun ppf a -> | P_assert_typing (t, a) -> out ppf "@[%a@ : %a@]" term t term a | P_assert_conv (t, u) -> out ppf "@[%a@ ≡ %a@]" term t term u +module Search = struct + let inside ppf s = string ppf (match s with Exact -> " =" | Inside -> " >") + let where elt ppf = function + | Spine x -> out ppf "spine%a" elt x + | Conclusion x -> out ppf "concl%a" elt x + | Hypothesis x -> out ppf "hyp%a" elt x + let constr ppf = function + | QType x -> out ppf "type%a" (Option.pp (where (Option.pp inside))) x + | QXhs (i,None) -> out ppf "rule%a" (Option.pp inside) i + | QXhs(i,Some Lhs) -> out ppf "lhs%a" (Option.pp inside) i + | QXhs(i,Some Rhs) -> out ppf "rhs%a" (Option.pp inside) i + let generalize ppf b = if b then string ppf " generalize" + let base_query ppf = function + | QName s -> out ppf "name %s" s + | QSearch(t,g,None) -> out ppf "anywhere%a%a" generalize g term t + | QSearch(t,g,Some c) -> out ppf "%a%a%a" constr c generalize g term t + let op ppf o = string ppf (match o with Union -> "; " | Intersect -> ", ") + let filter ppf (Path s) = out ppf " | %s" s + let rec query ppf = function + | QBase b -> base_query ppf b + | QOpp(q1,o,q2) -> out ppf "%a%a%a" query q1 op o query q2 + | QFilter(q,f) -> out ppf "%a%a" query q filter f +end + let query : p_query pp = fun ppf { elt; _ } -> match elt with | P_query_assert(true, a) -> out ppf "assertnot ⊢ %a" assertion a @@ -255,7 +279,7 @@ let query : p_query pp = fun ppf { elt; _ } -> | P_query_print(Some qid) -> out ppf "print %a" qident qid | P_query_proofterm -> out ppf "proofterm" | P_query_verbose i -> out ppf "verbose %s" i - | P_query_search s -> out ppf "search \"%s\"" s + | P_query_search q -> out ppf "search \"%a\"" Search.query q let rec tactic : p_tactic pp = fun ppf { elt; _ } -> begin match elt with diff --git a/src/parsing/syntax.ml b/src/parsing/syntax.ml index 3da081297..34f9c6c54 100644 --- a/src/parsing/syntax.ml +++ b/src/parsing/syntax.ml @@ -204,6 +204,29 @@ type p_assertion = | P_assert_conv of p_term * p_term (** The two given terms should be convertible. *) +(** Search queries. *) +type side = Lhs | Rhs +type inside = Exact | Inside +type 'a where = + | Spine of 'a + | Conclusion of 'a + | Hypothesis of 'a +type constr = + | QType of (inside option) where option + | QXhs of inside option * side option +type base_query = + | QName of string + | QSearch of p_term * (*generalize:*)bool * constr option +type op = + | Intersect + | Union +type filter = + | Path of string +type query = + | QBase of base_query + | QOpp of query * op * query + | QFilter of query * filter + (** Parser-level representation of a query command. *) type p_query_aux = | P_query_verbose of string @@ -226,7 +249,7 @@ type p_query_aux = (** Print information about a symbol or the current goals. *) | P_query_proofterm (** Print the current proof term (possibly containing open goals). *) - | P_query_search of string + | P_query_search of query (** Runs a search query *) (* I use a string here to be parsed later to avoid polluting LambdaPi code with index and retrieval code *) @@ -252,6 +275,7 @@ type p_tactic_aux = | P_tac_sym | P_tac_why3 of string option | P_tac_try of p_tactic + and p_tactic = p_tactic_aux loc (** [is_destructive t] says whether tactic [t] changes the current goal. *) @@ -398,6 +422,7 @@ let eq_p_query : p_query eq = fun {elt=q1;_} {elt=q2;_} -> | P_query_verbose n1, P_query_verbose n2 -> n1 = n2 | P_query_debug (b1,s1), P_query_debug (b2,s2) -> b1 = b2 && s1 = s2 | P_query_proofterm, P_query_proofterm -> true + | P_query_search q1, P_query_search q2 -> q1 = q2 | _, _ -> false let eq_p_tactic : p_tactic eq = fun {elt=t1;_} {elt=t2;_} -> diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index a21a507af..46a74304f 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -195,11 +195,11 @@ end module DB = struct (* fix codomain type *) - type side = Parsing.SearchQuerySyntax.side = Lhs | Rhs + type side = Parsing.Syntax.side = Lhs | Rhs - type inside = Parsing.SearchQuerySyntax.inside = Exact | Inside + type inside = Parsing.Syntax.inside = Exact | Inside - type 'inside where = 'inside Parsing.SearchQuerySyntax.where = + type 'inside where = 'inside Parsing.Syntax.where = | Spine of 'inside | Conclusion of 'inside | Hypothesis of 'inside @@ -562,7 +562,7 @@ include DB module QueryLanguage = struct - open Parsing.SearchQuerySyntax + open Parsing.Syntax let match_opt p x = match p,x with @@ -637,28 +637,19 @@ include QueryLanguage module UserLevelQueries = struct - let search_cmd_gen ~fail ~pp_results s = - try - let pstream = Parsing.Parser.Lp.parse_search_query_string "LPSearch" s in - let pq = Stream.next pstream in - let mok _ = None in - let items = answer_query ~mok [] pq in - Format.asprintf "%a@." pp_results items - with - | Stream.Failure -> - fail (Format.asprintf "Syntax error: a query was expected") - | Common.Error.Fatal(_,msg) -> - fail (Format.asprintf "Error: %s@." msg) - | exn -> - fail (Format.asprintf "Error: %s@." (Printexc.to_string exn)) - - let search_cmd_html s = - search_cmd_gen ~fail:(fun x -> "" ^ x ^ "") - ~pp_results:html_of_item_set s - - let search_cmd_txt s = - search_cmd_gen ~fail:(fun x -> Common.Error.fatal_no_pos "%s" x) - ~pp_results:pp_item_set s + let query_results_gen pp_results q = + let mok _ = None in + let items = answer_query ~mok [] q in + Format.asprintf "%a@." pp_results items + + let search_cmd_html s = + query_results_gen html_of_item_set + (Parsing.Parser.Lp.parse_search_query_string "" s) + + let query_results = query_results_gen pp_item_set + + let search_cmd_txt s = + query_results (Parsing.Parser.Lp.parse_search_query_string "" s) end diff --git a/src/tool/indexing.mli b/src/tool/indexing.mli index cf41cb0c4..76218706d 100644 --- a/src/tool/indexing.mli +++ b/src/tool/indexing.mli @@ -3,6 +3,8 @@ val empty : unit -> unit val index_sign : rules:string list -> Core.Sign.t -> unit val dump : unit -> unit +val query_results: Parsing.Syntax.query -> string + (* search command used by cli *) val search_cmd_txt: string -> string From 0fefcf590f688d87b4bcbf0380cfa144a5c58531 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Thu, 2 Jan 2025 19:39:44 +0100 Subject: [PATCH 06/35] add parsing of set tactic --- src/parsing/ll1.ml | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/parsing/ll1.ml b/src/parsing/ll1.ml index 2943795d7..f429450eb 100644 --- a/src/parsing/ll1.ml +++ b/src/parsing/ll1.ml @@ -61,6 +61,7 @@ let string_of_token = function | RULE -> "rule" | SEARCH -> "search" | SEQUENTIAL -> "sequential" + | SET -> "set" | SIMPLIFY -> "simplify" | SOLVE -> "solve" | SYMBOL -> "symbol" @@ -827,6 +828,7 @@ and proof (lb:lexbuf): p_proof * p_proof_end = | REFLEXIVITY | REMOVE | REWRITE + | SET | SIMPLIFY | SOLVE | SYMMETRY @@ -880,6 +882,7 @@ and steps (lb:lexbuf): p_proofstep list = | REFLEXIVITY | REMOVE | REWRITE + | SET | SIMPLIFY | SOLVE | SYMMETRY @@ -1013,6 +1016,13 @@ and tactic (lb:lexbuf): p_tactic = let t = term lb in make_pos 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 + make_pos pos1 (P_tac_set(i,t)) | SIMPLIFY -> let pos1 = current_pos() in consume_token lb; From e1c530454bfe9c7f871623e7f8dc71b7011f6771 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Sat, 25 Jan 2025 18:03:55 +0100 Subject: [PATCH 07/35] wip --- src/parsing/ll1.ml | 103 ++++++++++++--------------------------------- 1 file changed, 28 insertions(+), 75 deletions(-) diff --git a/src/parsing/ll1.ml b/src/parsing/ll1.ml index f429450eb..42aeea374 100644 --- a/src/parsing/ll1.ml +++ b/src/parsing/ll1.ml @@ -40,6 +40,7 @@ let string_of_token = function | INDUCTIVE -> "inductive" | INFIX -> "infix" | INJECTIVE -> "injective" + | INT _ -> "integer" | LET -> "let" | NOTATION -> "notation" | OPAQUE -> "opaque" @@ -74,8 +75,6 @@ let string_of_token = function | WHY3 -> "why3" | WITH -> "with" | DEBUG_FLAGS _ -> "debug flags" - | NAT _ -> "natural number" - | NEG_NAT _ -> "negative integer" | FLOAT _ -> "float" | SIDE _ -> "left or right" | STRINGLIT _ -> "string literal" @@ -199,13 +198,13 @@ let consume_SWITCH (lb:lexbuf): bool = | _ -> expected "" [SWITCH true] -let consume_NAT (lb:lexbuf): string = +let consume_INT (lb:lexbuf): string = match current_token() with - | NAT s -> + | INT s -> consume_token lb; s | _ -> - expected "" [NAT""] + expected "" [INT""] let qid (lb:lexbuf): (string list * string) loc = (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) @@ -248,8 +247,7 @@ let uid (lb:lexbuf): string loc = let param (lb:lexbuf): string loc option = (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with - | UID s - | NAT s -> + | UID s -> let pos1 = current_pos() in consume_token lb; Some (make_pos pos1 s) @@ -257,56 +255,26 @@ let param (lb:lexbuf): string loc option = consume_token lb; None | _ -> - expected "non-qualified identifier or \"_\"" [UID"";NAT"";UNDERSCORE] + expected "non-qualified identifier or \"_\"" [UID"";UNDERSCORE] let int (lb:lexbuf): string = (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with - | NAT s - | NEG_NAT s -> + | INT s -> consume_token lb; s | _ -> - expected "integer" [NAT"";NEG_NAT""] + expected "integer" [INT""] let float_or_int (lb:lexbuf): string = (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with - | NAT s - | NEG_NAT s + | INT s | FLOAT s -> consume_token lb; s | _ -> - expected "integer or float" [NAT"";NEG_NAT"";FLOAT""] - -let uid_or_int (lb:lexbuf): string loc = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) - match current_token() with - | UID s - | NAT s - | NEG_NAT s -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 s - | _ -> - expected "non-qualified identifier" [UID"";NAT"";NEG_NAT""] - -let qid_or_int (lb:lexbuf): (string list * string) loc = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) - match current_token() with - | QID p -> - let pos1 = current_pos() in - consume_token lb; - qid_of_path pos1 p - | UID s - | NAT s - | NEG_NAT s -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 ([],s) - | _ -> - expected "possibly qualified identifier" [UID"";QID[];NAT"";NEG_NAT""] + expected "integer or float" [INT"";FLOAT""] let path (lb:lexbuf): string list loc = (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) @@ -376,15 +344,13 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = assert (p_sym_mod = []); let pos1 = current_pos() in command pos1 (nelist modifier lb) lb - (* qid_or_int *) + (* qid *) | UID _ - | QID _ - | NAT _ - | NEG_NAT _ -> + | QID _ -> begin match p_sym_mod with | [{elt=P_opaq;_}] -> - let i = qid_or_int lb in + let i = qid lb in make_pos pos1 (P_opaque i) | [] -> expected "command keyword missing" [] @@ -429,7 +395,7 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = | SYMBOL -> let pos1 = current_pos() in consume_token lb; - let p_sym_nam = uid_or_int lb in + let p_sym_nam = uid lb in let p_sym_arg = list params lb in begin match current_token() with @@ -534,7 +500,7 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = | STRINGLIT s -> consume_token lb; consume ASSIGN lb; - let i = qid_or_int lb in + let i = qid lb in make_pos pos1 (P_builtin(s,i)) | _ -> expected "" [STRINGLIT""] @@ -543,7 +509,7 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) let pos1 = current_pos() in consume_token lb; - let i = qid_or_int lb in + let i = qid lb in let n = notation lb in make_pos pos1 (P_notation(i,n)) | _ -> @@ -564,9 +530,7 @@ and inductive (lb:lexbuf): p_inductive = consume ASSIGN lb; begin match current_token() with - | UID _ - | NAT _ - | NEG_NAT _ -> + | UID _ -> let c = constructor lb in let cs = list (prefix VBAR constructor) lb in let l = c::cs in @@ -582,7 +546,7 @@ and inductive (lb:lexbuf): p_inductive = end and constructor (lb:lexbuf): p_ident * p_term = - let i = uid_or_int lb in + let i = uid lb in let pos1 = current_pos() in let ps = list params lb in consume COLON lb; @@ -757,12 +721,12 @@ and query (lb:lexbuf): p_query = | PROVER_TIMEOUT -> let pos1 = current_pos() in consume_token lb; - let n = consume_NAT lb in + let n = consume_INT lb in make_pos pos1 (P_query_prover_timeout n) | VERBOSE -> let pos1 = current_pos() in consume_token lb; - let n = consume_NAT lb in + let n = consume_INT lb in make_pos pos1 (P_query_verbose n) | TYPE_QUERY -> let pos1 = current_pos() in @@ -1029,10 +993,8 @@ and tactic (lb:lexbuf): p_tactic = begin match current_token() with | UID _ - | QID _ - | NAT _ - | NEG_NAT _ -> - let i = Some (qid_or_int lb) in + | QID _ -> + let i = Some (qid lb) in make_pos pos1 (P_tac_simpl i) | _ -> let i = None in @@ -1083,8 +1045,7 @@ and rw_patt (lb:lexbuf): p_rw_patt = | UID_PATT _ | L_PAREN | L_SQ_BRACKET - | NAT _ - | NEG_NAT _ -> + | INT _ -> let pos1 = current_pos() in let t1 = term lb in begin @@ -1208,8 +1169,7 @@ and term (lb:lexbuf): p_term = | UID_PATT _ | L_PAREN | L_SQ_BRACKET - | NAT _ - | NEG_NAT _ -> + | INT _ -> let pos1 = current_pos() in let h = aterm lb in app pos1 h lb @@ -1230,8 +1190,7 @@ and app (pos1:position * position) (t: p_term) (lb:lexbuf): p_term = | UID_PATT _ | L_PAREN | L_SQ_BRACKET - | NAT _ - | NEG_NAT _ -> + | INT _ -> let u = aterm lb in app pos1 (make_pos pos1 (P_Appl(t,u))) lb (* bterm *) @@ -1347,14 +1306,10 @@ and aterm (lb:lexbuf): p_term = let t = term lb in consume R_SQ_BRACKET lb; make_pos pos1 (P_Expl(t)) - | NAT n -> + | INT n -> let pos1 = current_pos() in consume_token lb; make_pos pos1 (P_NLit n) - | NEG_NAT n -> - let pos1 = current_pos() in - consume_token lb; - make_pos pos1 (P_Iden(make_pos pos1 ([],n), false)) | _ -> expected "identifier, \"_\", or term between parentheses or square \ brackets" [] @@ -1382,13 +1337,11 @@ and binder (lb:lexbuf): p_params list * p_term = (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | UID _ - | NAT _ | UNDERSCORE -> let s = param lb in begin match current_token() with | UID _ - | NAT _ | UNDERSCORE | L_PAREN | L_SQ_BRACKET -> @@ -1408,7 +1361,7 @@ and binder (lb:lexbuf): p_params list * p_term = [p], term lb | _ -> expected "parameter list" - [UID"";NAT"";UNDERSCORE;L_PAREN;L_SQ_BRACKET;COMMA] + [UID"";UNDERSCORE;L_PAREN;L_SQ_BRACKET;COMMA] end | L_PAREN -> let ps = nelist params lb in @@ -1431,7 +1384,7 @@ and binder (lb:lexbuf): p_params list * p_term = expected "" [COMMA] end | _ -> - expected "" [UID"";NAT"";UNDERSCORE;L_PAREN;L_SQ_BRACKET] + expected "" [UID"";UNDERSCORE;L_PAREN;L_SQ_BRACKET] (* search *) From 20194da016e24100c05ff1fa1b9807014b9498f2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Tue, 22 Apr 2025 10:15:00 +0200 Subject: [PATCH 08/35] fix compil --- src/handle/query.ml | 3 ++- src/tool/indexing.ml | 28 +++++++++------------------- src/tool/indexing.mli | 13 +++++++------ 3 files changed, 18 insertions(+), 26 deletions(-) diff --git a/src/handle/query.ml b/src/handle/query.ml index f2f495f79..c3fd6d7e1 100644 --- a/src/handle/query.ml +++ b/src/handle/query.ml @@ -160,7 +160,8 @@ let handle : Sig_state.t -> proof_state option -> p_query -> result = let ctxt = Env.to_ctxt env in let p = new_problem() in match elt with - | P_query_search q -> return string (Tool.Indexing.search_cmd_txt ss q) + | P_query_search q -> + return string (Tool.Indexing.search_cmd_txt_query ss q) | P_query_debug(_,_) | P_query_verbose(_) | P_query_flag(_,_) diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 39311dd4b..2b9241bc4 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -647,21 +647,6 @@ include QueryLanguage module UserLevelQueries = struct -(*<<<<<<< HEAD - let query_results_gen pp_results q = - let mok _ = None in - let items = answer_query ~mok [] q in - Format.asprintf "%a@." pp_results items - - let search_cmd_html s = - query_results_gen html_of_item_set - (Parsing.Parser.Lp.parse_search_query_string "" s) - - let query_results = query_results_gen pp_item_set - - let search_cmd_txt s = - query_results (Parsing.Parser.Lp.parse_search_query_string "" s) -=======*) let search_cmd_gen ss ~from ~how_many ~fail ~pp_results pq = try let mok _ = None in @@ -689,15 +674,20 @@ module UserLevelQueries = struct | exn -> fail (Format.asprintf "Error: %s@." (Printexc.to_string exn)) - let search_cmd_html ss ~from ~how_many pq = + let search_cmd_html ss ~from ~how_many s = search_cmd_gen ss ~from ~how_many ~fail:(fun x -> "" ^ x ^ "") - ~pp_results:(html_of_results_list from) s + ~pp_results:(html_of_results_list from) + (Parsing.Parser.Lp.parse_search_query_string "" s) - let search_cmd_txt ss pq = + let search_cmd_txt_query ss = search_cmd_gen ss ~from:0 ~how_many:999999 ~fail:(fun x -> Common.Error.fatal_no_pos "%s" x) - ~pp_results:pp_results_list s + ~pp_results:pp_results_list + + let search_cmd_txt ss s = + search_cmd_txt_query ss + (Parsing.Parser.Lp.parse_search_query_string "" s) end diff --git a/src/tool/indexing.mli b/src/tool/indexing.mli index fc6f0ce02..87922022b 100644 --- a/src/tool/indexing.mli +++ b/src/tool/indexing.mli @@ -1,14 +1,15 @@ +open Core open Sig_state +open Parsing open Syntax + (* indexing *) val empty : unit -> unit val load_rewriting_rules: string list -> unit -val index_sign : Core.Sign.t -> unit +val index_sign : Sign.t -> unit val dump : unit -> unit -val query_results: Parsing.Syntax.query -> string - (* search command used by cli *) -val search_cmd_txt: Core.Sig_state.sig_state -> string -> string +val search_cmd_txt_query: sig_state -> query -> string +val search_cmd_txt: sig_state -> string -> string (* search command used by websearch *) -val search_cmd_html: - Core.Sig_state.sig_state -> from:int -> how_many:int -> string -> string +val search_cmd_html: sig_state -> from:int -> how_many:int -> string -> string From ee20e9c242088c6f3c5153918f1a5cdaa23e8f92 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Wed, 23 Apr 2025 11:29:44 +0200 Subject: [PATCH 09/35] fix parser: stringlit in terms, and type query in proofs --- src/common/pos.ml | 16 +++++++--------- src/parsing/ll1.ml | 18 ++++++++++++++---- src/parsing/parser.ml | 42 +++++++++++++++++++++--------------------- src/pure/pure.ml | 6 +++--- 4 files changed, 45 insertions(+), 37 deletions(-) diff --git a/src/common/pos.ml b/src/common/pos.ml index 788dba866..9e26f0ce2 100644 --- a/src/common/pos.ml +++ b/src/common/pos.ml @@ -88,13 +88,11 @@ let to_string : ?print_dirname:bool -> ?print_fname:bool -> pos -> string = fun ?(print_dirname=true) ?(print_fname=true) {fname; start_line; start_col; end_line; end_col} -> let fname = - if not print_fname then "" else - match fname with - | None -> "" - | Some(n) -> - if print_dirname then n ^ ":" - else - Filename.basename n ^ ":" + if print_fname then + match fname with + | None -> "" + | Some n -> (if print_dirname then n else Filename.basename n) ^ ":" + else "" in if start_line <> end_line then Printf.sprintf "%s%d:%d-%d:%d" fname start_line start_col end_line end_col @@ -107,8 +105,8 @@ let popt_to_string : ?print_dirname:bool -> ?print_fname:bool -> popt -> string = fun ?(print_dirname=true) ?(print_fname=true) pop -> match pop with - | None -> "Unknown location " - | Some (p) -> to_string ~print_dirname ~print_fname p ^ " " + | None -> "Unknown location" + | Some (p) -> to_string ~print_dirname ~print_fname p (** [pp ppf pos] prints the optional position [pos] on [ppf]. *) let pp : popt Lplib.Base.pp = fun ppf p -> diff --git a/src/parsing/ll1.ml b/src/parsing/ll1.ml index 56e4905a8..6f87aee6c 100644 --- a/src/parsing/ll1.ml +++ b/src/parsing/ll1.ml @@ -784,6 +784,7 @@ and proof (lb:lexbuf): p_proof * p_proof_end = | PROVER_TIMEOUT | VERBOSE | SEARCH + | TYPE_QUERY (*tactics*) | ADMIT | APPLY @@ -838,6 +839,7 @@ and steps (lb:lexbuf): p_proofstep list = | PROVER_TIMEOUT | VERBOSE | SEARCH + | TYPE_QUERY (*tactics*) | ADMIT | APPLY @@ -904,7 +906,8 @@ and tactic (lb:lexbuf): p_tactic = | PROVER | PROVER_TIMEOUT | VERBOSE - | SEARCH -> + | SEARCH + | TYPE_QUERY -> let pos1 = current_pos() in make_pos pos1 (P_tac_query (query lb)) | ADMIT -> @@ -1054,7 +1057,8 @@ and rw_patt (lb:lexbuf): p_rw_patt = | UID_PATT _ | L_PAREN | L_SQ_BRACKET - | INT _ -> + | INT _ + | STRINGLIT _ -> let pos1 = current_pos() in let t1 = term lb in begin @@ -1178,7 +1182,8 @@ and term (lb:lexbuf): p_term = | UID_PATT _ | L_PAREN | L_SQ_BRACKET - | INT _ -> + | INT _ + | STRINGLIT _ -> let pos1 = current_pos() in let h = aterm lb in app pos1 h lb @@ -1199,7 +1204,8 @@ and app (pos1:position * position) (t: p_term) (lb:lexbuf): p_term = | UID_PATT _ | L_PAREN | L_SQ_BRACKET - | INT _ -> + | INT _ + | STRINGLIT _ -> let u = aterm lb in app pos1 (make_pos pos1 (P_Appl(t,u))) lb (* bterm *) @@ -1319,6 +1325,10 @@ and aterm (lb:lexbuf): p_term = let pos1 = current_pos() in consume_token lb; make_pos pos1 (P_NLit 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" [] diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index c65120415..0e6bbcac2 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -17,7 +17,7 @@ let parser_fatal : Pos.pos -> ('a,'b) koutfmt -> 'a = fun pos fmt -> (** Module type of a parser. *) module type PARSER = sig - val parse_in_channel : in_channel -> ast + val parse_in_channel : string -> in_channel -> ast (** [parse ic] returns a stream of commands parsed from channel [ic]. Commands are parsed lazily and the channel is closed once all entries are parsed. *) @@ -31,15 +31,15 @@ module type PARSER = sig which comes from file [f] ([f] can be anything). *) end +(* defined in OCaml >= 4.11 only *) +let set_filename (lb:lexbuf) (fname:string): unit = + lb.lex_curr_p <- {lb.lex_curr_p with pos_fname = fname} + (** Parsing dk syntax. *) module Dk : PARSER = struct open Lexing - (* defined in OCaml >= 4.11 only *) - let set_filename (lb:lexbuf) (fname:string): unit = - lb.lex_curr_p <- {lb.lex_curr_p with pos_fname = fname} - (* old code: let parse_lexbuf : ?ic:in_channel -> ?fname:string -> lexbuf -> p_command Stream.t = @@ -65,8 +65,9 @@ module Dk : PARSER = struct let ic = open_in fname in parse_lexbuf ~ic ~fname (from_channel ic)*) - let parse_lexbuf (icopt:in_channel option) (entry:lexbuf -> 'a) (lb:lexbuf) - : 'a Stream.t = + let parse_lexbuf (fname:string) (icopt:in_channel option) + (entry:lexbuf -> 'a) (lb:lexbuf) : 'a Stream.t = + set_filename lb fname; let generator _ = try Some(entry lb) with @@ -77,16 +78,15 @@ module Dk : PARSER = struct in Stream.from generator - let parse_in_channel (entry:lexbuf -> 'a) (ic:in_channel): 'a Stream.t = - parse_lexbuf (Some ic) entry (from_channel ic) + let parse_in_channel (entry:lexbuf -> 'a) (fname:string) (ic:in_channel) + : 'a Stream.t = + parse_lexbuf fname (Some ic) entry (from_channel ic) - let parse_file entry fname = parse_in_channel entry (open_in fname) + let parse_file entry fname = parse_in_channel entry fname (open_in fname) let parse_string (entry: lexbuf -> 'a) (fname:string) (s:string) : 'a Stream.t = - let lb = from_string s in - set_filename lb fname; - parse_lexbuf None entry lb + parse_lexbuf "" None entry (from_string s) let command = let r = ref (Pos.none (P_open [])) in @@ -161,8 +161,9 @@ sig (* new parser *) - let parse_lexbuf (icopt: in_channel option) (entry: lexbuf -> 'a) - (lb: lexbuf): 'a Stream.t = + let parse_lexbuf (fname:string) (icopt: in_channel option) + (entry: lexbuf -> 'a) (lb: lexbuf): 'a Stream.t = + set_filename lb fname; let generator _ = try Some(entry lb) with @@ -175,12 +176,11 @@ sig let parse_string (entry: lexbuf -> 'a) (fname: string) (s: string) : 'a Stream.t = - let lb = Utf8.from_string s in - set_filename lb fname; - parse_lexbuf None entry lb + parse_lexbuf fname None entry (Utf8.from_string s) - let parse_in_channel (entry: lexbuf -> 'a) (ic: in_channel): 'a Stream.t = - parse_lexbuf (Some ic) entry (Utf8.from_channel ic) + let parse_in_channel (entry: lexbuf -> 'a) (fname:string) (ic: in_channel) + : 'a Stream.t = + parse_lexbuf fname (Some ic) entry (Utf8.from_channel ic) (*let parse_file entry fname = let ic = open_in fname in @@ -191,7 +191,7 @@ sig x*) let parse_file (entry: lexbuf -> 'a) (fname: string): 'a Stream.t = - parse_in_channel entry (open_in fname) + parse_in_channel entry fname (open_in fname) (* exported functions *) let parse_search_query_string (fname: string) (s: string): query = diff --git a/src/pure/pure.ml b/src/pure/pure.ml index b8ebf272e..967dc2d23 100644 --- a/src/pure/pure.ml +++ b/src/pure/pure.ml @@ -168,7 +168,7 @@ let handle_command : state -> Command.t -> command_result = 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) + Cmd_Error(Some p, Pos.popt_to_string p ^ " " ^ m) let handle_tactic : proof_state -> Tactic.t -> int -> tactic_result = fun (_, ss, ps, finalize, prv, sym_pos) tac n -> @@ -177,13 +177,13 @@ let handle_tactic : proof_state -> Tactic.t -> int -> tactic_result = 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) + 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) -> - Cmd_Error(Some p, Pos.popt_to_string p ^ m) + Cmd_Error(Some p, Pos.popt_to_string p ^ " " ^ m) let get_symbols : state -> Term.sym Extra.StrMap.t = fun (_, ss) -> ss.in_scope From 6f5e67b3658209840e7482673394dbc75cbc6d2b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Wed, 23 Apr 2025 11:43:16 +0200 Subject: [PATCH 10/35] fix ll1 parser with last modifs (repeat, orelse, eval, simplify rule off) --- src/parsing/ll1.ml | 46 +++++++++++++++++++++++++++++++++++----------- 1 file changed, 35 insertions(+), 11 deletions(-) diff --git a/src/parsing/ll1.ml b/src/parsing/ll1.ml index 6f87aee6c..99fa9ed2b 100644 --- a/src/parsing/ll1.ml +++ b/src/parsing/ll1.ml @@ -776,26 +776,29 @@ and proof (lb:lexbuf): p_proof * p_proof_end = (*queries*) | ASSERT _ | COMPUTE - | PRINT - | PROOFTERM | DEBUG | FLAG + | PRINT + | PROOFTERM | PROVER | PROVER_TIMEOUT - | VERBOSE | SEARCH | TYPE_QUERY + | VERBOSE (*tactics*) | ADMIT | APPLY | ASSUME + | EVAL | FAIL | GENERALIZE | HAVE | INDUCTION + | ORELSE | REFINE | REFLEXIVITY | REMOVE + | REPEAT | REWRITE | SET | SIMPLIFY @@ -831,26 +834,29 @@ and steps (lb:lexbuf): p_proofstep list = (*queries*) | ASSERT _ | COMPUTE - | PRINT - | PROOFTERM | DEBUG | FLAG + | PRINT + | PROOFTERM | PROVER | PROVER_TIMEOUT - | VERBOSE | SEARCH | TYPE_QUERY + | VERBOSE (*tactics*) | ADMIT | APPLY | ASSUME + | EVAL | FAIL | GENERALIZE | HAVE | INDUCTION + | ORELSE | REFINE | REFLEXIVITY | REMOVE + | REPEAT | REWRITE | SET | SIMPLIFY @@ -899,15 +905,15 @@ and tactic (lb:lexbuf): p_tactic = (*queries*) | ASSERT _ | COMPUTE - | PRINT - | PROOFTERM | DEBUG | FLAG + | PRINT + | PROOFTERM | PROVER | PROVER_TIMEOUT - | VERBOSE | SEARCH - | TYPE_QUERY -> + | TYPE_QUERY + | VERBOSE -> let pos1 = current_pos() in make_pos pos1 (P_tac_query (query lb)) | ADMIT -> @@ -924,6 +930,11 @@ and tactic (lb:lexbuf): p_tactic = consume_token lb; let xs = nelist param lb in make_pos pos1 (P_tac_assume xs) + | EVAL -> + let pos1 = current_pos() in + consume_token lb; + let t = term lb in + make_pos pos1 (P_tac_eval t) | FAIL -> let pos1 = current_pos() in consume_token lb; @@ -944,6 +955,12 @@ and tactic (lb:lexbuf): p_tactic = 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 + make_pos pos1 (P_tac_orelse(t1,t2)) | REFINE -> let pos1 = current_pos() in consume_token lb; @@ -958,6 +975,11 @@ and tactic (lb:lexbuf): p_tactic = consume_token lb; let xs = nelist uid lb in make_pos pos1 (P_tac_remove xs) + | REPEAT -> + let pos1 = current_pos() in + consume_token lb; + let t = tactic lb in + make_pos pos1 (P_tac_repeat t) | REWRITE -> let pos1 = current_pos() in consume_token lb; @@ -1006,7 +1028,9 @@ and tactic (lb:lexbuf): p_tactic = consume_token lb; begin match current_token() with - | SWITCH false -> make_pos pos1 (P_tac_simpl SimpBetaOnly) + | SWITCH false -> + consume_token lb; + make_pos pos1 (P_tac_simpl SimpBetaOnly) | _ -> expected "" [SWITCH false] end | _ -> From 32dcfa6c227c7c59d30032cab6d0f86317795451 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Wed, 23 Apr 2025 17:43:09 +0200 Subject: [PATCH 11/35] opam: increase dream version --- lambdapi.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lambdapi.opam b/lambdapi.opam index 27b1404cd..29fce8454 100644 --- a/lambdapi.opam +++ b/lambdapi.opam @@ -36,7 +36,7 @@ depends: [ "stdlib-shims" {>= "0.1.0"} "odoc" {with-doc} "lwt_ppx" {>= "1.0.0"} - "dream" {>= "1.0.0~alpha3"} + "dream" {>= "1.0.0~alpha7"} ] build: [ ["dune" "subst"] {dev} From 180b50b35feb64ea89fec6cb0db1dcb7e2b2b77b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Wed, 23 Apr 2025 17:46:05 +0200 Subject: [PATCH 12/35] revert previous commit --- lambdapi.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lambdapi.opam b/lambdapi.opam index 29fce8454..27b1404cd 100644 --- a/lambdapi.opam +++ b/lambdapi.opam @@ -36,7 +36,7 @@ depends: [ "stdlib-shims" {>= "0.1.0"} "odoc" {with-doc} "lwt_ppx" {>= "1.0.0"} - "dream" {>= "1.0.0~alpha7"} + "dream" {>= "1.0.0~alpha3"} ] build: [ ["dune" "subst"] {dev} From c194e32e8cd098f21e2faf744d9564e729b67989 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 4 Jul 2025 13:21:39 +0200 Subject: [PATCH 13/35] detail --- src/handle/query.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/handle/query.ml b/src/handle/query.ml index 76ca20a76..bec6cbb02 100644 --- a/src/handle/query.ml +++ b/src/handle/query.ml @@ -176,8 +176,7 @@ let handle : Sig_state.t -> proof_state option -> p_query -> result = match elt with | P_query_search q -> let dbpath = Path.default_dbpath in - return string - (Tool.Indexing.search_cmd_txt_query ss q ~dbpath) + return string (Tool.Indexing.search_cmd_txt_query ss q ~dbpath) | P_query_debug(_,_) | P_query_verbose(_) | P_query_flag(_,_) From 09368423501c034176c376e7f6ccff3274dfcdac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 7 Jul 2025 12:14:36 +0200 Subject: [PATCH 14/35] fix debug query + add debug alone --- src/common/logger.ml | 5 ++- src/handle/query.ml | 4 ++ src/handle/tactic.ml | 15 +++---- src/parsing/ll1.ml | 100 +++++++++++++++++++++++++------------------ tests/OK/Tactic.lp | 6 +-- 5 files changed, 75 insertions(+), 55 deletions(-) diff --git a/src/common/logger.ml b/src/common/logger.ml index 13d48f521..073702a9e 100644 --- a/src/common/logger.ml +++ b/src/common/logger.ml @@ -8,7 +8,7 @@ type logger_pp = { pp: 'a. 'a outfmt -> 'a } (** Type of logging function data. *) type logger = - { logger_key : char (** Character used to unable the logger. *) + { logger_key : char (** Character used to (un)able the logger. *) ; logger_name : string (** Four-characters name used as prefix in logs. *) ; logger_desc : string (** Description of the log displayed in help. *) ; logger_enabled : bool ref (** Is the log enabled? *) @@ -32,9 +32,11 @@ let update_log_enabled () = (** [make key name desc] registers a new logger and returns its pp. *) let make logger_key logger_name logger_desc = + (* Sanity checks. *) if String.length logger_name <> 4 then invalid_arg "Logger.make: name must be 4 characters long"; + let check data = if logger_key = data.logger_key then invalid_arg "Logger.make: key is already used"; @@ -44,6 +46,7 @@ let make logger_key logger_name logger_desc = List.iter check Stdlib.(!loggers); let logger_enabled = ref false in + (* Actual printing function. *) let pp fmt = update_with_color Stdlib.(!Error.err_fmt); diff --git a/src/handle/query.ml b/src/handle/query.ml index bec6cbb02..1d5aa646f 100644 --- a/src/handle/query.ml +++ b/src/handle/query.ml @@ -79,6 +79,10 @@ let return : 'a pp -> 'a -> result = fun pp x -> let handle : Sig_state.t -> proof_state option -> p_query -> result = fun ss ps {elt;pos} -> match elt with + | P_query_debug(_,"") -> + let f (k,d) = Printf.sprintf "\n%c: %s" k d in + let s = String.concat "" (List.map f (Logger.log_summary())) in + return string ("debug flags:"^s) | P_query_debug(e,s) -> Logger.set_debug e s; Console.out 1 "debug %s%s" (if e then "+" else "-") s; diff --git a/src/handle/tactic.ml b/src/handle/tactic.ml index 6ec0e91b6..f76768633 100644 --- a/src/handle/tactic.ml +++ b/src/handle/tactic.ml @@ -74,7 +74,7 @@ let tac_admit: Sig_state.t -> popt -> proof_state -> goal_typ -> proof_state = (** [tac_solve pos ps] tries to simplify the unification goals of the proof state [ps] and fails if constraints are unsolvable. *) let tac_solve : popt -> proof_state -> proof_state = fun pos ps -> - if Logger.log_enabled () then log "@[tac_solve@ %a@]" goals ps; + if Logger.log_enabled () then log "tac_solve"; (* convert the proof_state into a problem *) let gs_typ, gs_unif = List.partition is_typ ps.proof_goals in let p = new_problem() in @@ -116,7 +116,7 @@ let tac_refine : ?check:bool -> popt -> proof_state -> goal_typ -> goal list -> problem -> term -> proof_state = fun ?(check=true) pos ps gt gs p t -> - if Logger.log_enabled () then log "@[tac_refine@ %a@]" term t; + if Logger.log_enabled () then log "tac_refine %a" term t; let c = Env.to_ctxt gt.goal_hyps in if LibMeta.occurs gt.goal_meta c t then fatal pos "Circular refinement."; (* Check that [t] has the required type. *) @@ -125,7 +125,7 @@ let tac_refine : ?check:bool -> match Infer.check_noexn p c t gt.goal_type with | None -> let ids = Ctxt.names c in let term = term_in ids in - fatal pos "%a@ does not have type@ %a." term t term gt.goal_type + fatal pos "%a\ndoes not have type\n%a." term t term gt.goal_type | Some t -> t else t in @@ -133,7 +133,6 @@ let tac_refine : ?check:bool -> log (Color.red "%a ≔ %a") meta gt.goal_meta term t; LibMeta.set p gt.goal_meta (bind_mvar (Env.vars gt.goal_hyps) t); (* Convert the metas and constraints of [p] not in [gs] into new goals. *) - if Logger.log_enabled () then log "%a" problem p; tac_solve pos {ps with proof_goals = Proof.add_goals_of_problem p gs} (** [ind_data t] returns the [ind_data] structure of [s] if [t] is of the @@ -681,15 +680,13 @@ let handle : match elt with | P_tac_fail -> fatal pos "Call to tactic \"fail\"" | P_tac_query(q) -> - if Logger.log_enabled () then log "%a@." Pretty.tactic tac; + if Logger.log_enabled () then log "%a" Pretty.tactic tac; ps, Query.handle ss (Some ps) q | _ -> match ps.proof_goals with - | [] -> fatal pos "No remaining goals." + | [] -> fatal pos "No remaining goal." | g::_ -> - if Logger.log_enabled() then - log ("%a@\n" ^^ Color.red "%a") - Proof.Goal.pp_no_hyp g Pretty.tactic tac; + if Logger.log_enabled() then log "%a" Proof.Goal.pp_no_hyp g; handle ss sym_pos prv ps tac, None (** [handle sym_pos prv r tac n] applies the tactic [tac] from the previous diff --git a/src/parsing/ll1.ml b/src/parsing/ll1.ml index bcdd87573..c994d6987 100644 --- a/src/parsing/ll1.ml +++ b/src/parsing/ll1.ml @@ -19,34 +19,49 @@ let string_of_token = function | ADMIT -> "admit" | ADMITTED -> "admitted" | APPLY -> "apply" + | ARROW -> "→" | AS -> "as" | ASSERT _ -> "assert or assertnot" + | ASSIGN -> "≔" | ASSOCIATIVE -> "associative" | ASSUME -> "assume" + | BACKQUOTE -> "`" | BEGIN -> "begin" | BUILTIN -> "builtin" | 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" @@ -55,6 +70,8 @@ let string_of_token = function | PROTECTED -> "protected" | PROVER -> "prover" | PROVER_TIMEOUT -> "prover_timeout" + | QID _ -> "qualified identifier" + | QID_EXPL _ -> "@-prefixed qualified identifier" | QUANTIFIER -> "quantifier" | REFINE -> "refine" | REFLEXIVITY -> "reflexivity" @@ -63,52 +80,35 @@ let string_of_token = function | 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" - | UNIF_RULE -> "unif_rule" - | VERBOSE -> "verbose" - | WHY3 -> "why3" - | WITH -> "with" - | DEBUG_FLAGS _ -> "debug flags" - | FLOAT _ -> "float" - | SIDE _ -> "left or right" - | STRINGLIT _ -> "string literal" - | SWITCH false -> "off" - | SWITCH true -> "on or off" - | ASSIGN -> "≔" - | ARROW -> "→" - | BACKQUOTE -> "`" - | COMMA -> "," - | COLON -> ":" - | DOT -> "." - | EQUIV -> "≡" - | HOOK_ARROW -> "↪" - | LAMBDA -> "λ" - | L_CU_BRACKET -> "{" - | L_PAREN -> "(" - | L_SQ_BRACKET -> "[" - | PI -> "Π" - | R_CU_BRACKET -> "}" - | R_PAREN -> ")" - | R_SQ_BRACKET -> "]" - | SEMICOLON -> ";" - | TURNSTILE -> "⊢" - | VBAR -> "|" - | UNDERSCORE -> "_" | UID _ -> "non-qualified identifier" | UID_EXPL _ -> "@-prefixed non-qualified identifier" | UID_META _ -> "?-prefixed metavariable number" | UID_PATT _ -> "$-prefixed non-qualified identifier" - | QID _ -> "qualified identifier" - | QID_EXPL _ -> "@-prefixed 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) @@ -124,8 +124,10 @@ let new_parsing f x1 x2 = try let y = f x1 x2 in reset(); y with e -> reset(); raise e let current_token() : token = - let (t,_,_) = !the_current_token in - if log_enabled() then log "current_token: %a" pp_token t; + let (t,p1,p2) = !the_current_token in + let p = locate (p1,p2) in + if log_enabled() then + log "current token [%a]: \"%a\"" Pos.short (Some p) pp_token t; t let current_pos() : position * position = @@ -218,6 +220,14 @@ 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 "Expected: %s" __FUNCTION__;*) match current_token() with @@ -714,11 +724,17 @@ and query (lb:lexbuf): p_query = let pos1 = current_pos() in consume_token lb; make_pos pos1 P_query_proofterm - | DEBUG_FLAGS fl -> + | DEBUG -> let pos1 = current_pos() in consume_token lb; - let (b, s) = fl in - make_pos pos1 (P_query_debug(b, s)) + begin + match current_token() with + | SEMICOLON -> + make_pos pos1 (P_query_debug(true,"")) + | _ -> + let b,s = consume_DEBUG_FLAGS lb in + make_pos pos1 (P_query_debug(b,s)) + end | FLAG -> let pos1 = current_pos() in consume_token lb; @@ -1440,7 +1456,7 @@ and binder (lb:lexbuf): p_params list * p_term = (* search *) and where (lb:lexbuf): bool * inside option = - if log_enabled() then log "Expected: %s" __FUNCTION__; + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | UID u -> let r = @@ -1462,7 +1478,7 @@ and where (lb:lexbuf): bool * inside option = expected "\">\", \"=\", \"≥\",\">=\"" [] and asearch (lb:lexbuf): query = - if log_enabled() then log "Expected: %s" __FUNCTION__; + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) match current_token() with | TYPE_QUERY -> consume_token lb; @@ -1514,7 +1530,7 @@ and asearch (lb:lexbuf): query = expected "name, anywhere, rule, lhs, rhs, type, concl, hyp, spine" [] and csearch (lb:lexbuf): query = - if log_enabled() then log "Expected: %s" __FUNCTION__; + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) let aq = asearch lb in match current_token() with | COMMA -> @@ -1524,7 +1540,7 @@ and csearch (lb:lexbuf): query = aq and ssearch (lb:lexbuf): query = - if log_enabled() then log "Expected: %s" __FUNCTION__; + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) let cq = csearch lb in match current_token() with | SEMICOLON -> @@ -1534,7 +1550,7 @@ and ssearch (lb:lexbuf): query = cq and search (lb:lexbuf): query = - if log_enabled() then log "Expected: %s" __FUNCTION__; + (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) let q = ssearch lb in let qids = list (prefix VBAR qid) lb in let path_of_qid qid = diff --git a/tests/OK/Tactic.lp b/tests/OK/Tactic.lp index d134ea8ae..a86c345f3 100644 --- a/tests/OK/Tactic.lp +++ b/tests/OK/Tactic.lp @@ -97,8 +97,8 @@ begin eval 2 * #rewrite addnA & #reflexivity end; -/*symbol lem2 p : π p → π p ≔ +/*debug +tn; +symbol lem2 p : π p → π p ≔ begin assume p h; eval #refine "h" -end; -*/ +end;*/ From 210dc2ae1f7bf7bbf7375e45a8aec3f7f212eda5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Tue, 8 Jul 2025 10:29:45 +0200 Subject: [PATCH 15/35] add change in new parser --- src/parsing/ll1.ml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/parsing/ll1.ml b/src/parsing/ll1.ml index c994d6987..3e4d1e059 100644 --- a/src/parsing/ll1.ml +++ b/src/parsing/ll1.ml @@ -28,6 +28,7 @@ let string_of_token = function | BACKQUOTE -> "`" | BEGIN -> "begin" | BUILTIN -> "builtin" + | CHANGE -> "change" | COERCE_RULE -> "coerce_rule" | COLON -> ":" | COMMA -> "," @@ -813,6 +814,7 @@ and proof (lb:lexbuf): p_proof * p_proof_end = | ADMIT | APPLY | ASSUME + | CHANGE | EVAL | FAIL | GENERALIZE @@ -871,6 +873,7 @@ and steps (lb:lexbuf): p_proofstep list = | ADMIT | APPLY | ASSUME + | CHANGE | EVAL | FAIL | GENERALIZE @@ -954,6 +957,11 @@ and tactic (lb:lexbuf): p_tactic = consume_token lb; let xs = nelist param lb in make_pos pos1 (P_tac_assume xs) + | CHANGE -> + let pos1 = current_pos() in + consume_token lb; + let t = term lb in + make_pos pos1 (P_tac_change t) | EVAL -> let pos1 = current_pos() in consume_token lb; From 5919791bc09191247643452b5f81653e053f48a5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Tue, 15 Jul 2025 16:47:24 +0200 Subject: [PATCH 16/35] fix parsing of terms from string literals --- src/parsing/ll1.ml | 18 ++++++++---------- src/parsing/lpLexer.ml | 13 +++++++------ src/parsing/parser.ml | 18 ++++++++++-------- src/parsing/pretty.ml | 2 +- tests/OK/Tactic.lp | 3 +-- 5 files changed, 27 insertions(+), 27 deletions(-) diff --git a/src/parsing/ll1.ml b/src/parsing/ll1.ml index 4136e96fa..d4f4c7b1f 100644 --- a/src/parsing/ll1.ml +++ b/src/parsing/ll1.ml @@ -113,17 +113,9 @@ let string_of_token = function let pp_token ppf t = Base.string ppf (string_of_token t) -let dummy_token = (EOF, dummy_pos, dummy_pos) - let the_current_token : (token * position * position) Stdlib.ref = Stdlib.ref dummy_token -let new_parsing f x1 x2 = - let token = !the_current_token in - let reset() = the_current_token := token in - the_current_token := dummy_token; - try let y = f x1 x2 in reset(); y with e -> reset(); raise e - let current_token() : token = let (t,p1,p2) = !the_current_token in let p = locate (p1,p2) in @@ -134,6 +126,12 @@ let current_token() : token = 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 reset(); r with e -> reset(); raise e + let expected (msg:string) (tokens:token list): 'a = if msg <> "" then syntax_error (current_pos()) ("Expected: "^msg^".") else @@ -146,7 +144,7 @@ let expected (msg:string) (tokens:token list): 'a = ^".") let consume_token (lb:lexbuf) : unit = - the_current_token := token lb (); + the_current_token := LpLexer.token lb; if log_enabled() then log "read new token" (* building positions and terms *) @@ -1587,7 +1585,7 @@ let command (lb:lexbuf): p_command = consume_token lb; if current_token() = EOF then raise End_of_file else - let c = command (dummy_pos,dummy_pos) [] lb in + let c = command (Lexing.dummy_pos,Lexing.dummy_pos) [] lb in match current_token() with | SEMICOLON -> c | _ -> expected "" [SEMICOLON] diff --git a/src/parsing/lpLexer.ml b/src/parsing/lpLexer.ml index a29fa6395..caa16cb35 100644 --- a/src/parsing/lpLexer.ml +++ b/src/parsing/lpLexer.ml @@ -340,14 +340,15 @@ 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 +(** [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 (EOF, Lexing.dummy_pos, Lexing.dummy_pos) 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 diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index ec01d3406..098d9cc77 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -126,18 +126,20 @@ sig let parse_file (entry: lexbuf -> 'a) (fname: string): 'a Stream.t = parse_in_channel entry fname (open_in fname) - let first parse entry fname s = - try Stream.next (Ll1.new_parsing parse entry fname s) - with Stream.Failure -> assert false + let parse_entry_string (entry:lexbuf -> 'a) (fname:string) (s:string): 'a = + let lb = Utf8.from_string s in + set_filename lb fname; + Ll1.new_parsing entry lb (* exported functions *) - let parse_term_string = first parse_string (Ll1.alone Ll1.term) - let parse_rwpatt_string = first parse_string (Ll1.alone Ll1.rw_patt_spec) - let parse_search_query_string = first parse_string (Ll1.alone Ll1.search) + let parse_term_string = parse_entry_string Ll1.term + let parse_rwpatt_string = parse_entry_string Ll1.rw_patt_spec + let parse_search_query_string = parse_entry_string Ll1.search let parse_in_channel = parse_in_channel Ll1.command let parse_file = parse_file Ll1.command let parse_string = parse_string Ll1.command + end include Lp @@ -148,7 +150,7 @@ open Error let path_of_string : string -> Path.t = fun s -> let lb = Utf8.from_string s in try - begin match token lb () with + begin match token lb with | UID s, _, _ -> [s] | QID p, _, _ -> List.rev p | _ -> fatal_no_pos "Syntax error: \"%s\" is not a path." s @@ -160,7 +162,7 @@ let path_of_string : string -> Path.t = fun s -> let qident_of_string : string -> Core.Term.qident = fun s -> let lb = Utf8.from_string s in try - begin match token lb () with + begin match token lb with | QID [], _, _ -> assert false | QID (s::p), _, _ -> (List.rev p, s) | _ -> diff --git a/src/parsing/pretty.ml b/src/parsing/pretty.ml index 18c57e6e4..cfb5e4abc 100644 --- a/src/parsing/pretty.ml +++ b/src/parsing/pretty.ml @@ -282,7 +282,7 @@ let query : p_query pp = fun ppf { elt; _ } -> | P_query_print(Some qid) -> out ppf "print %a" qident qid | P_query_proofterm -> out ppf "proofterm" | P_query_verbose i -> out ppf "verbose %s" i - | P_query_search q -> out ppf "search \"%a\"" Search.query q + | P_query_search q -> out ppf "search %a" Search.query q let rec tactic : p_tactic pp = fun ppf { elt; _ } -> begin match elt with diff --git a/tests/OK/Tactic.lp b/tests/OK/Tactic.lp index aeba448f6..b347d68de 100644 --- a/tests/OK/Tactic.lp +++ b/tests/OK/Tactic.lp @@ -100,8 +100,7 @@ begin eval 2 * #rewrite addnA & #reflexivity end; -/*debug +tn; symbol lem2 p : π p → π p ≔ begin assume p h; eval #refine "h" -end;*/ +end; From 3075f6fca813b8318e884a66d93e910f47307e1a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 10 Nov 2025 15:53:02 +0100 Subject: [PATCH 17/35] fix comments --- src/parsing/parser.ml | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index 64cbfff8f..d820bdd0c 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -21,21 +21,21 @@ module type PARSER = sig type lexbuf val parse_in_channel : string -> in_channel -> ast - (** [parse ic] returns a stream of commands parsed from - channel [ic]. Commands are parsed lazily and the channel is + (** [parse f ic] returns a stream of commands parsed from channel [ic] + created from file [f]. Commands are parsed lazily and the channel is closed once all entries are parsed. *) val parse_file : string -> ast - (** [parse_file fname] returns a stream of parsed commands of file - [fname]. Commands are parsed lazily. *) + (** [parse_file f] returns a stream of parsed commands of file [f]. Commands + are parsed lazily. *) val parse_string : string -> string -> ast (** [parse_string f s] returns a stream of parsed commands from string [s] which comes from file [f] ([f] can be anything). *) val parse_lexbuf : lexbuf -> ast - (** [parse_lexbuf lexbuf] is the same as [parse_string] but with an - already created lexbuf *) + (** [parse_lexbuf lb] is the same as [parse_string] but with an already + created lexbuf. *) end @@ -48,9 +48,8 @@ module Dk : PARSER with type lexbuf := Lexing.lexbuf = struct open Lexing - let parse_lexbuf (*fname:string*) (icopt:in_channel option) + let parse_lexbuf (icopt:in_channel option) (entry:lexbuf -> 'a) (lb:lexbuf) : 'a Stream.t = - (*set_filename lb fname;*) let generator _ = try Some(entry lb) with @@ -114,9 +113,8 @@ sig end = struct - let parse_lexbuf (*fname:string*) (icopt: in_channel option) + let parse_lexbuf (icopt: in_channel option) (entry: lexbuf -> 'a) (lb: lexbuf): 'a Stream.t = - (*set_filename lb fname;*) let generator _ = try Some(entry lb) with From e782ab45d073ab58b17b5d3710b3c717aefef247 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Mon, 10 Nov 2025 16:05:36 +0100 Subject: [PATCH 18/35] rename files + remove lpParser.mly and menhir dep --- dune-project | 1 - lambdapi.opam | 1 - src/parsing/dune | 4 +- src/parsing/{ll1.ml => lpParser.ml} | 0 src/parsing/lpParser.mly | 514 ---------------------------- src/parsing/parser.ml | 18 +- src/parsing/searchQuerySyntax.ml | 22 -- 7 files changed, 10 insertions(+), 550 deletions(-) rename src/parsing/{ll1.ml => lpParser.ml} (100%) delete mode 100644 src/parsing/lpParser.mly delete mode 100644 src/parsing/searchQuerySyntax.ml diff --git a/dune-project b/dune-project index 1c777b972..ff963385d 100644 --- a/dune-project +++ b/dune-project @@ -31,7 +31,6 @@ systems: Dedukti, Coq, HRS, CPF.") (dream-pure (>= 1.0.0~alpha2)) (dream-httpaf (>= 1.0.0~alpha3)) (dream (>= 1.0.0~alpha6)) - (menhir (>= 20200624)) (sedlex (>= 3.2)) (alcotest :with-test) (alt-ergo :with-test) diff --git a/lambdapi.opam b/lambdapi.opam index 3a10af877..5d1b80e1a 100644 --- a/lambdapi.opam +++ b/lambdapi.opam @@ -24,7 +24,6 @@ depends: [ "dream-pure" {>= "1.0.0~alpha2"} "dream-httpaf" {>= "1.0.0~alpha3"} "dream" {>= "1.0.0~alpha6"} - "menhir" {>= "20200624"} "sedlex" {>= "3.2"} "alcotest" {with-test} "alt-ergo" {with-test} diff --git a/src/parsing/dune b/src/parsing/dune index dbd73fc61..5205002bc 100644 --- a/src/parsing/dune +++ b/src/parsing/dune @@ -3,11 +3,9 @@ (public_name lambdapi.parsing) (modules :standard) (preprocess (pps sedlex.ppx)) - (libraries camlp-streams lambdapi.core menhirLib pratter sedlex sedlex.ppx lambdapi.common) + (libraries camlp-streams lambdapi.core pratter sedlex sedlex.ppx lambdapi.common) (flags -w +3)) -(menhir (flags --explain --external-tokens LpLexer) (modules lpParser)) - (ocamllex dkLexer) (menhir (flags --explain --external-tokens DkTokens) (modules dkParser)) diff --git a/src/parsing/ll1.ml b/src/parsing/lpParser.ml similarity index 100% rename from src/parsing/ll1.ml rename to src/parsing/lpParser.ml diff --git a/src/parsing/lpParser.mly b/src/parsing/lpParser.mly deleted file mode 100644 index 39774a433..000000000 --- a/src/parsing/lpParser.mly +++ /dev/null @@ -1,514 +0,0 @@ -(** 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)) -%} - -// end of file - -%token EOF - -// keywords in alphabetical order - -%token ABORT -%token ADMIT -%token ADMITTED -%token APPLY -%token AS -%token ASSERT -%token ASSOCIATIVE -%token ASSUME -%token BEGIN -%token BUILTIN -%token CHANGE -%token COERCE_RULE -%token COMMUTATIVE -%token COMPUTE -%token CONSTANT -%token DEBUG -%token END -%token EVAL -%token FAIL -%token FLAG -%token GENERALIZE -%token HAVE -%token IN -%token INDUCTION -%token INDUCTIVE -%token INFIX -%token INJECTIVE -%token LET -%token NOTATION -%token OPAQUE -%token OPEN -%token ORELSE -%token POSTFIX -%token PREFIX -%token PRINT -%token PRIVATE -%token PROOFTERM -%token PROTECTED -%token PROVER -%token PROVER_TIMEOUT -%token QUANTIFIER -%token REFINE -%token REFLEXIVITY -%token REMOVE -%token REPEAT -%token REQUIRE -%token REWRITE -%token RULE -%token SEARCH -%token SEQUENTIAL -%token SET -%token SIMPLIFY -%token SOLVE -%token SYMBOL -%token SYMMETRY -%token TRY -%token TYPE_QUERY -%token TYPE_TERM -%token UNIF_RULE -%token VERBOSE -%token WHY3 -%token WITH - -// other tokens - -%token DEBUG_FLAGS -%token INT -%token FLOAT -%token SIDE -%token STRINGLIT -%token SWITCH - -// symbols - -%token ARROW -%token ASSIGN -%token BACKQUOTE -%token COMMA -%token COLON -%token DOT -%token EQUIV -%token HOOK_ARROW -%token LAMBDA -%token L_CU_BRACKET -%token L_PAREN -%token L_SQ_BRACKET -%token PI -%token R_CU_BRACKET -%token R_PAREN -%token R_SQ_BRACKET -%token SEMICOLON -%token TURNSTILE -%token UNDERSCORE -%token VBAR - -// identifiers - -%token UID -%token UID_EXPL -%token UID_META -%token UID_PATT -%token QID -%token QID_EXPL - -// types - -%start command -%start qid -%start qid_alone -%start term_alone -%start rw_patt_spec_alone -%start search_query_alone - -// patch (see https://github.com/Deducteam/lambdapi/pull/798) -%type equation - -%% - -term_alone: - | t=term EOF - { t } - -rw_patt_spec_alone: - | p=rw_patt_spec EOF - { p } - -qid_alone: - | q=qid EOF - { q } - -search_query_alone: - | q=search_query EOF - { q } - -command: - | OPAQUE i=qid SEMICOLON { make_pos $sloc (P_opaque i) } - | REQUIRE l=list(path) SEMICOLON - { make_pos $sloc (P_require(None,l)) } - | REQUIRE b=open_cmd l=list(path) SEMICOLON - { make_pos $sloc (P_require(Some b,l)) } - | REQUIRE p=path AS i=uid SEMICOLON - { make_pos $sloc (P_require_as(p,i)) } - | b=open_cmd l=list(path) SEMICOLON - { make_pos $sloc (P_open(b,l)) } - | ms=modifier* SYMBOL s=uid al=param_list* COLON a=term - po=proof? SEMICOLON - { let sym = - {p_sym_mod=ms; p_sym_nam=s; p_sym_arg=al; p_sym_typ=Some(a); - p_sym_trm=None; p_sym_def=false; p_sym_prf=po} - in make_pos $sloc (P_symbol(sym)) } - | ms=modifier* SYMBOL s=uid al=param_list* ao=preceded(COLON, term)? - ASSIGN tp=term_proof SEMICOLON - { let sym = - {p_sym_mod=ms; p_sym_nam=s; p_sym_arg=al; p_sym_typ=ao; - p_sym_trm=fst tp; p_sym_prf=snd tp; p_sym_def=true} - in make_pos $sloc (P_symbol(sym)) } - | exp=exposition? xs=param_list* INDUCTIVE - is=separated_nonempty_list(WITH, inductive) SEMICOLON - { make_pos $sloc (P_inductive(Option.to_list exp,xs,is)) } - | RULE rs=separated_nonempty_list(WITH, rule) SEMICOLON - { make_pos $sloc (P_rules(rs)) } - | BUILTIN s=STRINGLIT ASSIGN i=qid SEMICOLON - { make_pos $loc (P_builtin(s,i)) } - | COERCE_RULE r=rule SEMICOLON { make_pos $loc (P_coercion r) } - | UNIF_RULE r=unif_rule SEMICOLON { make_pos $loc (P_unif_rule(r)) } - | NOTATION i=qid n=notation SEMICOLON - { make_pos $loc (P_notation(i,n)) } - | q=query SEMICOLON { make_pos $sloc (P_query(q)) } - | EOF { raise End_of_file } - -open_cmd: - | OPEN { false } - | PRIVATE OPEN { true } - -query: - | k=ASSERT ps=param_list* TURNSTILE t=term COLON a=term - { let t = make_abst $startpos(ps) ps t $endpos(t) in - let a = make_prod $startpos(ps) ps a $endpos(a) in - make_pos $sloc (P_query_assert(k, P_assert_typing(t, a))) } - | k=ASSERT ps=param_list* TURNSTILE t=term EQUIV u=term - { let t = make_abst $startpos(ps) ps t $endpos(t) in - let u = make_abst $startpos(ps) ps u $endpos(u) in - make_pos $sloc (P_query_assert(k, P_assert_conv(t, u))) } - | COMPUTE t=term - { make_pos $sloc (P_query_normalize(t, {strategy=SNF; steps=None})) } - | PRINT i=qid_or_rule? { make_pos $sloc (P_query_print i) } - | PROOFTERM { make_pos $sloc P_query_proofterm } - | DEBUG { make_pos $sloc (P_query_debug(true,"")) } - | DEBUG fl=DEBUG_FLAGS - { let (b, s) = fl in make_pos $sloc (P_query_debug(b, s)) } - | FLAG { make_pos $sloc (P_query_flag("",true)) } - | FLAG s=STRINGLIT b=SWITCH { make_pos $sloc (P_query_flag(s,b)) } - | PROVER s=STRINGLIT { make_pos $sloc (P_query_prover(s)) } - | PROVER_TIMEOUT n=INT - { make_pos $sloc (P_query_prover_timeout n) } - | VERBOSE n=INT { make_pos $sloc (P_query_verbose n) } - | TYPE_QUERY t=term - { make_pos $sloc (P_query_infer(t, {strategy=NONE; steps=None}))} - | SEARCH s=STRINGLIT - { make_pos $sloc (P_query_search(QBase(QName s))) } - -qid_or_rule: - | i=qid { i } - | UNIF_RULE - { make_pos $sloc (Sign.Ghost.path, Unif_rule.equiv.sym_name) } - | COERCE_RULE - { make_pos $sloc (Sign.Ghost.path, Coercion.coerce.sym_name) } - -path: - | UID { LpLexer.syntax_error $sloc "Unqualified identifier" } - | p=QID { make_pos $sloc (List.rev p) } - -modifier: - | d=ioption(SIDE) ASSOCIATIVE - { let b = match d with Some Pratter.Left -> true | _ -> false in - make_pos $sloc (P_prop (Term.Assoc b)) } - | COMMUTATIVE { make_pos $sloc (P_prop Term.Commu) } - | CONSTANT { make_pos $sloc (P_prop Term.Const) } - | INJECTIVE { make_pos $sloc (P_prop Term.Injec) } - | OPAQUE { make_pos $sloc P_opaq } - | SEQUENTIAL { make_pos $sloc (P_mstrat Term.Sequen) } - | exp=exposition { exp } - -exposition: -| PRIVATE { make_pos $sloc (P_expo Term.Privat) } -| PROTECTED { make_pos $sloc (P_expo Term.Protec) } - -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) } - -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)) } - | PI b=binder { make_pos $sloc (P_Prod(fst b, snd b)) } - | LAMBDA b=binder { make_pos $sloc (P_Abst(fst b, snd b)) } - | 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) } - -term_proof: - | t=term { Some t, None } - | p=proof { None, Some p } - | t=term p=proof { Some t, Some p } - -proof: - | BEGIN l=subproof+ pe=proof_end { l, pe } - | BEGIN l=loption(proof_steps) pe=proof_end { [l], pe } - -subproof: L_CU_BRACKET l=loption(proof_steps) R_CU_BRACKET { l } - -proof_steps: - | a=proof_step { [a] } - | a=proof_step SEMICOLON { [a] } - | a=proof_step SEMICOLON l=proof_steps { a :: l } - -proof_step: t=tactic l=subproof* { Tactic(t, l) } - -proof_end: - | ABORT { make_pos $sloc Syntax.P_proof_abort } - | ADMITTED { make_pos $sloc Syntax.P_proof_admitted } - | END { make_pos $sloc Syntax.P_proof_end } - -tactic: - | q=query { make_pos $sloc (P_tac_query q) } - | ADMIT { make_pos $sloc P_tac_admit } - | APPLY t=term { make_pos $sloc (P_tac_apply t) } - | ASSUME xs=param+ { make_pos $sloc (P_tac_assume xs) } - | CHANGE t=term { make_pos $sloc (P_tac_change t) } - | EVAL t=term { make_pos $sloc (P_tac_eval t) } - | FAIL { make_pos $sloc P_tac_fail } - | GENERALIZE i=uid { make_pos $sloc (P_tac_generalize i) } - | HAVE i=uid COLON t=term { make_pos $sloc (P_tac_have(i,t)) } - | INDUCTION { make_pos $sloc P_tac_induction } - | ORELSE t1=tactic t2=tactic { make_pos $sloc (P_tac_orelse(t1,t2)) } - | REFINE t=term { make_pos $sloc (P_tac_refine t) } - | REFLEXIVITY { make_pos $sloc P_tac_refl } - | REMOVE xs=uid+ { make_pos $sloc (P_tac_remove xs) } - | REPEAT t=tactic { make_pos $sloc (P_tac_repeat t) } - | REWRITE d=SIDE? p=rw_patt_spec? t=term - { let b = match d with Some Pratter.Left -> false | _ -> true in - make_pos $sloc (P_tac_rewrite(b,p,t)) } - | SET i=uid ASSIGN t=term { make_pos $sloc (P_tac_set(i,t)) } - | SIMPLIFY { make_pos $sloc (P_tac_simpl SimpAll) } - | SIMPLIFY i=qid { make_pos $sloc (P_tac_simpl (SimpSym i)) } - | SIMPLIFY RULE s=SWITCH - { if s then LpLexer.syntax_error $sloc "Invalid tactic" - else make_pos $sloc (P_tac_simpl SimpBetaOnly) } - | SOLVE { make_pos $sloc P_tac_solve } - | SYMMETRY { make_pos $sloc P_tac_sym } - | TRY t=tactic { make_pos $sloc (P_tac_try t) } - | WHY3 s=STRINGLIT? { make_pos $sloc (P_tac_why3 s) } - -rw_patt: - | t=term { make_pos $sloc (Rw_Term(t)) } - | IN t=term { make_pos $sloc (Rw_InTerm(t)) } - | IN x=uid IN t=term { make_pos $sloc (Rw_InIdInTerm(x, t)) } - | u=term IN x=term t=preceded(IN, term)? - { let ident_of_term {elt; _} = - match elt with - | P_Iden({elt=([], x); pos}, _) -> Pos.make pos x - | _ -> LpLexer.syntax_error $sloc "Not an identifier" - in - match t with - | Some(t) -> make_pos $sloc (Rw_TermInIdInTerm(u, (ident_of_term x, t))) - | None -> make_pos $sloc (Rw_IdInTerm(ident_of_term u, x)) - } - | u=term AS x=uid IN t=term { make_pos $sloc (Rw_TermAsIdInTerm(u,(x,t))) } - -rw_patt_spec: DOT L_SQ_BRACKET p=rw_patt R_SQ_BRACKET { p } - -inductive: i=uid ps=param_list* COLON t=term ASSIGN - VBAR? l=separated_list(VBAR, constructor) - { let t = make_prod $startpos(ps) ps t $endpos(t) in - make_pos $sloc (i,t,l) } - -constructor: i=uid ps=param_list* COLON t=term - { (i, make_prod $startpos(ps) ps t $endpos(t)) } - -rule: l=term HOOK_ARROW r=term { make_pos $sloc (l, r) } - -unif_rule: e=equation HOOK_ARROW - L_SQ_BRACKET es=separated_nonempty_list(SEMICOLON, equation) R_SQ_BRACKET - { (* 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 - make_pos $sloc (lhs, rhs) } - -equation: l=term EQUIV r=term { (l, r) } - -notation: - | INFIX a=SIDE? p=float_or_int - { Term.Infix(Option.get Pratter.Neither a, p) } - | POSTFIX p=float_or_int { Term.Postfix(p) } - | PREFIX p=float_or_int { Term.Prefix(p) } - | QUANTIFIER { Term.Quant } - -float_or_int: - | s=FLOAT { s } - | s=INT { s } - -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) } - -%% diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index d820bdd0c..0eb574a2a 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -143,17 +143,17 @@ sig let parse_entry_string (entry:lexbuf -> 'a) (fname:string) (s:string): 'a = let lb = Utf8.from_string s in set_filename lb fname; - Ll1.new_parsing entry lb + LpParser.new_parsing entry lb (* exported functions *) - let parse_term_string = parse_entry_string Ll1.term - let parse_rwpatt_string = parse_entry_string Ll1.rw_patt_spec - let parse_search_query_string = parse_entry_string Ll1.search - - let parse_in_channel = parse_in_channel Ll1.command - let parse_file = parse_file Ll1.command - let parse_string = parse_string Ll1.command - let parse_lexbuf = parse_lexbuf None Ll1.command + let parse_term_string = parse_entry_string LpParser.term + let parse_rwpatt_string = parse_entry_string LpParser.rw_patt_spec + let parse_search_query_string = parse_entry_string LpParser.search + + let parse_in_channel = parse_in_channel LpParser.command + let parse_file = parse_file LpParser.command + let parse_string = parse_string LpParser.command + let parse_lexbuf = parse_lexbuf None LpParser.command end diff --git a/src/parsing/searchQuerySyntax.ml b/src/parsing/searchQuerySyntax.ml deleted file mode 100644 index ab32e66ba..000000000 --- a/src/parsing/searchQuerySyntax.ml +++ /dev/null @@ -1,22 +0,0 @@ -(* query language *) -type side = Lhs | Rhs -type inside = Exact | Inside -type 'inside where = - | Spine of 'inside - | Conclusion of 'inside - | Hypothesis of 'inside -type constr = - | QType of (inside option) where option - | QXhs of inside option * side option -type base_query = - | QName of string - | QSearch of Syntax.p_term * (*generalize:*)bool * constr option -type op = - | Intersect - | Union -type filter = - | Path of string -type query = - | QBase of base_query - | QOpp of query * op * query - | QFilter of query * filter From 43fc1e3efcfe66b77553302c7fd443e2be7536af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Tue, 25 Nov 2025 16:08:46 +0100 Subject: [PATCH 19/35] start setting initial position when parsing a string (not finished yet) --- src/common/pos.ml | 24 ++++++++++++++++-------- src/handle/tactic.ml | 11 +++++------ src/parsing/parser.ml | 27 +++++++++++++-------------- src/tool/indexing.ml | 4 ++-- 4 files changed, 36 insertions(+), 30 deletions(-) diff --git a/src/common/pos.ml b/src/common/pos.ml index fd8f4a25a..cc851c655 100644 --- a/src/common/pos.ml +++ b/src/common/pos.ml @@ -59,19 +59,15 @@ let pos_end : popt -> popt = fun po -> | Some p -> Some {p with start_line = p.end_line; start_col = p.end_col} (** [cat p1 p2] returns a position starting from [p1] start and ending with - [p2] end. [p1] and [p2] must have the same filename. *) + [p2] end. The result position uses [p2] fname. *) let cat : pos -> pos -> pos = fun p1 p2 -> { fname = p2.fname - (*FIXME: temporary fix for - https://github.com/Deducteam/lambdapi/issues/1001 - if p1.fname <> p2.fname then invalid_arg __LOC__ else p1.fname*) ; start_line = p1.start_line ; start_col = p1.start_col ; start_offset = p1.start_offset ; end_line = p2.end_line ; end_col = p2.end_col - ; end_offset = p2.end_offset - } + ; end_offset = p2.end_offset } let cat : popt -> popt -> popt = fun p1 p2 -> match p1, p2 with @@ -130,8 +126,8 @@ let short : popt Lplib.Base.pp = fun ppf p -> let map : ('a -> 'b) -> 'a loc -> 'b loc = fun f loc -> {loc with elt = f loc.elt} -(** [locate ?fname loc] converts the pair of position [loc] and filename - [fname] of the Lexing library into a {!type:pos}. *) +(** [locate ?fname (p1,p2)] converts the pair of Lexing positions [p1,p2] and + filename [fname] into a {!type:pos}. *) let locate : ?fname:string -> Lexing.position * Lexing.position -> pos = fun ?fname (p1, p2) -> let fname = if p1.pos_fname = "" then fname else Some(p1.pos_fname) in @@ -143,6 +139,18 @@ let locate : ?fname:string -> Lexing.position * Lexing.position -> pos = let end_offset = p2.pos_cnum in {fname; start_line; start_col; start_offset; end_line; end_col; end_offset } +(** [lexpos p] converts a [pos] into a [Lexing.position]. *) +let lexing (p:pos): Lexing.position = + { pos_fname = (match p.fname with None -> "" | Some s -> s) + ; pos_lnum = p.start_line + ; pos_bol = p.start_offset - p.start_col + ; pos_cnum = p.start_offset } + +let lexing_opt (p:popt): Lexing.position = + match p with + | None -> {pos_fname=""; pos_lnum=1; pos_bol=0; pos_cnum=0} + | Some p -> lexing p + (** [make_pos lps elt] creates a located element from the lexing positions [lps] and the element [elt]. *) let make_pos : Lexing.position * Lexing.position -> 'a -> 'a loc = diff --git a/src/handle/tactic.ml b/src/handle/tactic.ml index f26f2fa7c..312951590 100644 --- a/src/handle/tactic.ml +++ b/src/handle/tactic.ml @@ -312,8 +312,7 @@ let p_term_of_string (pos:popt) (t:term): p_term = | Symb s when String.is_string_literal s.sym_name -> begin let string = remove_quotes s.sym_name in - let fname = match pos with Some{fname=Some fn;_} -> fn | _ -> "" in - Parsing.Parser.Lp.parse_term_string fname string + Parsing.Parser.Lp.parse_term_string (lexing_opt pos) string end | _ -> fatal pos "refine tactic not applied to a term string literal" @@ -323,8 +322,7 @@ let p_rw_patt_of_string (pos:popt) (t:term): p_rw_patt option = let string = remove_quotes s.sym_name in if string = "" then None else - let fname = match pos with Some{fname=Some fn;_} -> fn | _ -> "" in - Some (Parsing.Parser.Lp.parse_rwpatt_string fname string) + Some (Parsing.Parser.Lp.parse_rwpatt_string (lexing_opt pos) string) | _ -> fatal pos "rewrite tactic not applied to a pattern string literal" let is_right (pos:popt) (t:term): bool = @@ -339,8 +337,8 @@ let is_right (pos:popt) (t:term): bool = end | _ -> fatal pos "rewrite tactic not applied to a side string literal" -(** [p_tactic t] interprets the term [t] as a tactic. *) -let p_tactic (ss:Sig_state.t) (pos:popt) :int StrMap.t -> term -> p_tactic = +(** [p_tactic ss pos idmap t] interprets the term [t] as a tactic. *) +let p_tactic (ss:Sig_state.t) (pos:popt): int StrMap.t -> term -> p_tactic = let c = get_config ss pos in let rec tac idmap t = Pos.make pos (tac_aux idmap t) and tac_aux idmap t = @@ -677,6 +675,7 @@ let rec handle : let ps = handle ss sym_pos prv ps t1 in handle ss sym_pos prv ps t2 | P_tac_eval pt -> + log "%a" Pos.short pt.pos; let t = Eval.snf (Env.to_ctxt env) (scope pt) in let idmap = get_names g in handle ss sym_pos prv ps (p_tactic ss pos idmap t) diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index 0eb574a2a..022d5e055 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -95,20 +95,17 @@ module Lp : sig include PARSER with type lexbuf := Sedlexing.lexbuf - val parse_term_string : - (*fname*)string -> (*term*)string -> Syntax.p_term - (** [parse_rwpatt_string f s] returns a term from string [s] which comes - from file [f] ([f] can be anything). *) + val parse_term_string: Lexing.position -> string -> Syntax.p_term + (** [parse_rwpatt_string p s] parses a term from string [s] assuming that + [s] starts at position [p]. *) - val parse_rwpatt_string : - (*fname*)string -> (*rwpatt*)string -> Syntax.p_rw_patt - (** [parse_rwpatt_string f s] returns a rewrite pattern specification from - string [s] which comes from file [f] ([f] can be anything). *) + val parse_rwpatt_string: Lexing.position -> string -> Syntax.p_rw_patt + (** [parse_rwpatt_string f s] parses a rewrite pattern specification from + string [s] assuming that [s] starts at position [p]. *) - val parse_search_query_string : - (*fname*)string -> (*query*)string -> Syntax.query - (** [parse_search_query_string f s] returns a query from string [s] which - comes from file [f] ([f] can be anything). *) + val parse_search_query_string: Lexing.position -> string -> Syntax.query + (** [parse_search_query_string f s] parses a query from string [s] assuming + that [s] starts at position [p]. *) end = struct @@ -140,9 +137,11 @@ sig let parse_file (entry: lexbuf -> 'a) (fname: string): 'a Stream.t = parse_in_channel entry fname (open_in fname) - let parse_entry_string (entry:lexbuf -> 'a) (fname:string) (s:string): 'a = + let parse_entry_string (entry:lexbuf -> 'a) (lexpos:Lexing.position) + (s:string): 'a = let lb = Utf8.from_string s in - set_filename lb fname; + set_position lb lexpos; + set_filename lb lexpos.pos_fname; LpParser.new_parsing entry lb (* exported functions *) diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 7a1e30bbf..cce013a96 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -702,13 +702,13 @@ module UserLevelQueries = struct ~fail:(fun x -> "" ^ x ^ "") ~pp_results:(html_of_results_list from) ~tag:("

"," Date: Wed, 26 Nov 2025 14:56:03 +0100 Subject: [PATCH 20/35] rename LpParser.make_pos into extend_pos and use it only when encessary + reorganize common/pos.ml --- src/common/pos.ml | 181 +++++++++++++----------- src/handle/tactic.ml | 3 +- src/parsing/lpParser.ml | 303 +++++++++++++++++++++------------------- 3 files changed, 257 insertions(+), 230 deletions(-) diff --git a/src/common/pos.ml b/src/common/pos.ml index cc851c655..7996894fe 100644 --- a/src/common/pos.ml +++ b/src/common/pos.ml @@ -23,41 +23,6 @@ let cmp : pos cmp = fun p1 p2 -> (p1.start_line, p1.start_col, (p1.fname, p1.end_line, p1.end_col)) (p2.start_line, p2.start_col, (p2.fname, p2.end_line, p2.end_col)) -(** Convenient short name for an optional position. *) -type popt = pos option - -(** [equal p1 p2] tells whether [p1] and [p2] denote the same position. *) -let equal : popt -> popt -> bool = fun p1 p2 -> - match (p1, p2) with - | (Some(p1), Some(p2)) -> p1 = p2 - | (None , None ) -> true - | (_ , _ ) -> false - -(** Type constructor extending a type (e.g. a piece of abstract syntax) with a - a source code position. *) -type 'a loc = - { elt : 'a (** The element that is being localised. *) - ; pos : popt (** Position of the element in the source code. *) } - -(** Localised string type (widely used). *) -type strloc = string loc - -(** [make pos elt] associates the position [pos] to [elt]. *) -let make : popt -> 'a -> 'a loc = fun pos elt -> { elt ; pos } - -(** [none elt] wraps [elt] in a ['a loc] structure without any specific source - code position. *) -let none : 'a -> 'a loc = fun elt -> make None elt - -(** [in_pos pos elt] associates the position [pos] to [elt]. *) -let in_pos : pos -> 'a -> 'a loc = fun p elt -> make (Some p) elt - -(** [pos_end po] creates a position from the end of position [po]. *) -let pos_end : popt -> popt = fun po -> - match po with - | None -> None - | Some p -> Some {p with start_line = p.end_line; start_col = p.end_col} - (** [cat p1 p2] returns a position starting from [p1] start and ending with [p2] end. The result position uses [p2] fname. *) let cat : pos -> pos -> pos = fun p1 p2 -> @@ -69,21 +34,25 @@ let cat : pos -> pos -> pos = fun p1 p2 -> ; end_col = p2.end_col ; end_offset = p2.end_offset } -let cat : popt -> popt -> popt = fun p1 p2 -> - match p1, p2 with - | Some p1, Some p2 -> Some (cat p1 p2) - | Some p, None - | None, Some p -> Some p - | None, None -> None - -(** [shift k p] returns a position that is [k] characters after [p]. *) -let shift : int -> popt -> popt = fun k p -> - match p with - | None -> assert false - | Some ({start_col; _} as p) -> Some {p with start_col = start_col + k} +(** [locate ?fname (p1,p2)] converts the pair of Lexing positions [p1,p2] and + filename [fname] into a {!type:pos}. *) +let locate : ?fname:string -> Lexing.position * Lexing.position -> pos = + fun ?fname (p1, p2) -> + let fname = if p1.pos_fname = "" then fname else Some(p1.pos_fname) in + let start_line = p1.pos_lnum in + let start_col = p1.pos_cnum - p1.pos_bol in + let start_offset = p1.pos_cnum in + let end_line = p2.pos_lnum in + let end_col = p2.pos_cnum - p2.pos_bol in + let end_offset = p2.pos_cnum in + {fname; start_line; start_col; start_offset; end_line; end_col; end_offset } -let after = shift 1 -let before = shift (-1) +(** [lexing p] converts a [pos] into a [Lexing.position]. *) +let lexing (p:pos): Lexing.position = + { pos_fname = (match p.fname with None -> "" | Some s -> s) + ; pos_lnum = p.start_line + ; pos_bol = p.start_offset - p.start_col + ; pos_cnum = p.start_offset } (** [to_string ?print_fname pos] transforms [pos] into a readable string. If [print_fname] is [true] (the default), the filename contained in [pos] is @@ -105,6 +74,78 @@ let to_string : ?print_dirname:bool -> ?print_fname:bool -> pos -> string = else Printf.sprintf "%s%d:%d-%d" fname start_line start_col end_col + + +(** Type of optional positions. *) +type popt = pos option + +(** [equal p1 p2] tells whether [p1] and [p2] denote the same position. *) +let equal : popt -> popt -> bool = fun p1 p2 -> + match (p1, p2) with + | (Some(p1), Some(p2)) -> p1 = p2 + | (None , None ) -> true + | (_ , _ ) -> false + +(** [pos_end po] creates a position from the end of position [po]. *) +let pos_end : popt -> popt = fun po -> + match po with + | None -> None + | Some p -> Some {p with start_line = p.end_line; start_col = p.end_col} + +(** [cat] extends and hide the above [cat] function from [pos] to [popt]. *) +let cat : popt -> popt -> popt = fun p1 p2 -> + match p1, p2 with + | Some p1, Some p2 -> Some (cat p1 p2) + | Some p, None + | None, Some p -> Some p + | None, None -> None + +(** [shift k p] returns a position that is [k] characters after [p]. *) +let shift : int -> popt -> popt = fun k p -> + match p with + | None -> assert false + | Some ({start_col; _} as p) -> Some {p with start_col = start_col + k} + +let after = shift 1 +let before = shift (-1) + +(** [lexing_opt p] converts a [popt] into a [Lexing.position]. *) +let lexing_opt (p:popt): Lexing.position = + match p with + | None -> {pos_fname=""; pos_lnum=1; pos_bol=0; pos_cnum=0} + | Some p -> lexing p + + + +(** Type constructor extending a type (e.g. a piece of abstract syntax) with a + an optional source code position. *) +type 'a loc = + { elt : 'a (** The element that is being localised. *) + ; pos : popt (** Position of the element in the source code. *) } + +(** Localised string type (widely used). *) +type strloc = string loc + +(** [make pos elt] associates the position [pos] to [elt]. *) +let make : popt -> 'a -> 'a loc = fun pos elt -> { elt ; pos } + +(** [none elt] wraps [elt] in a ['a loc] structure without any specific source + code position. *) +let none : 'a -> 'a loc = fun elt -> make None elt + +(** [map f loc] applies function [f] on the value of [loc] and keeps the + position unchanged. *) +let map : ('a -> 'b) -> 'a loc -> 'b loc = fun f loc -> + {loc with elt = f loc.elt} + +(** [in_pos pos elt] associates the position [pos] to [elt]. *) +let in_pos : pos -> 'a -> 'a loc = fun p elt -> make (Some p) elt + +(** [make_pos lps elt] creates a located element from the lexing positions + [lps] and the element [elt]. *) +let make_pos : Lexing.position * Lexing.position -> 'a -> 'a loc = + fun lps elt -> in_pos (locate lps) elt + let popt_to_string : ?print_dirname:bool -> ?print_fname:bool -> popt -> string = fun ?(print_dirname=true) ?(print_fname=true) pop -> @@ -113,48 +154,19 @@ let popt_to_string : | Some (p) -> to_string ~print_dirname ~print_fname p (** [pp ppf pos] prints the optional position [pos] on [ppf]. *) -let pp : popt Lplib.Base.pp = fun ppf p -> +let pp : popt pp = fun ppf p -> string ppf (popt_to_string p) (** [short ppf pos] prints the optional position [pos] on [ppf]. *) -let short : popt Lplib.Base.pp = fun ppf p -> +let short : popt pp = fun ppf p -> let print_fname=false in string ppf (popt_to_string ~print_fname p) -(** [map f loc] applies function [f] on the value of [loc] and keeps the - position unchanged. *) -let map : ('a -> 'b) -> 'a loc -> 'b loc = fun f loc -> - {loc with elt = f loc.elt} - -(** [locate ?fname (p1,p2)] converts the pair of Lexing positions [p1,p2] and - filename [fname] into a {!type:pos}. *) -let locate : ?fname:string -> Lexing.position * Lexing.position -> pos = - fun ?fname (p1, p2) -> - let fname = if p1.pos_fname = "" then fname else Some(p1.pos_fname) in - let start_line = p1.pos_lnum in - let start_col = p1.pos_cnum - p1.pos_bol in - let start_offset = p1.pos_cnum in - let end_line = p2.pos_lnum in - let end_col = p2.pos_cnum - p2.pos_bol in - let end_offset = p2.pos_cnum in - {fname; start_line; start_col; start_offset; end_line; end_col; end_offset } - -(** [lexpos p] converts a [pos] into a [Lexing.position]. *) -let lexing (p:pos): Lexing.position = - { pos_fname = (match p.fname with None -> "" | Some s -> s) - ; pos_lnum = p.start_line - ; pos_bol = p.start_offset - p.start_col - ; pos_cnum = p.start_offset } +(** [pp_lexing ppf lps] prints the Lexing.position pair [lps] on [ppf]. *) +let pp_lexing : (Lexing.position * Lexing.position) pp = + fun ppf lps -> short ppf (Some (locate lps)) -let lexing_opt (p:popt): Lexing.position = - match p with - | None -> {pos_fname=""; pos_lnum=1; pos_bol=0; pos_cnum=0} - | Some p -> lexing p -(** [make_pos lps elt] creates a located element from the lexing positions - [lps] and the element [elt]. *) -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 @@ -162,8 +174,7 @@ let make_pos : Lexing.position * Lexing.position -> 'a -> 'a loc = "unknown location" message returned when the position does not refer to a file. [escape] is used to escape the file contents.*) let print_file_contents : - escape:(string -> string) -> - delimiters:(string*string) -> popt Lplib.Base.pp = + escape:(string -> string) -> delimiters:(string*string) -> popt pp = fun ~escape ~delimiters:(db,de) ppf pos -> match pos with | Some { fname=Some fname; start_line; start_col; end_line; end_col } -> diff --git a/src/handle/tactic.ml b/src/handle/tactic.ml index 312951590..6d3fcac62 100644 --- a/src/handle/tactic.ml +++ b/src/handle/tactic.ml @@ -675,10 +675,9 @@ let rec handle : let ps = handle ss sym_pos prv ps t1 in handle ss sym_pos prv ps t2 | P_tac_eval pt -> - log "%a" Pos.short pt.pos; let t = Eval.snf (Env.to_ctxt env) (scope pt) in let idmap = get_names g in - handle ss sym_pos prv ps (p_tactic ss pos idmap t) + handle ss sym_pos prv ps (p_tactic ss pt.pos idmap t) (** Representation of a tactic output. *) type tac_output = proof_state * Query.result diff --git a/src/parsing/lpParser.ml b/src/parsing/lpParser.ml index d4f4c7b1f..3accf10c8 100644 --- a/src/parsing/lpParser.ml +++ b/src/parsing/lpParser.ml @@ -11,8 +11,6 @@ let log = log.pp (* token management *) -(* error messages *) - let string_of_token = function | EOF -> "end of file" | ABORT -> "abort" @@ -117,10 +115,12 @@ let the_current_token : (token * position * position) Stdlib.ref = Stdlib.ref dummy_token let current_token() : token = - let (t,p1,p2) = !the_current_token in - let p = locate (p1,p2) in - if log_enabled() then - log "current token [%a]: \"%a\"" Pos.short (Some p) pp_token t; + let (t,_p1,_p2) = !the_current_token in + (*begin + if log_enabled() then + let p = locate (p1,p2) in + log "current token [%a]: \"%a\"" Pos.short (Some p) pp_token t + end;*) t let current_pos() : position * position = @@ -145,12 +145,18 @@ let expected (msg:string) (tokens:token list): 'a = let consume_token (lb:lexbuf) : unit = the_current_token := LpLexer.token lb; - if log_enabled() then log "read new token" + 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 make_pos (lps:position * position): 'a -> 'a loc = - Pos.make_pos (fst lps, snd (current_pos())) +let extend_pos (*s:string*) (lps:position * position): 'a -> 'a loc = + let lps2 = (fst lps, snd (current_pos())) in + (*if log_enabled() then + log "extend_pos %s %a -> %a" s Pos.pp_lexing lps Pos.pp_lexing lps2;*) + make_pos lps2 let qid_of_path (lps: position * position): string list -> (string list * string) loc = function @@ -159,11 +165,13 @@ let qid_of_path (lps: position * position): let make_abst (pos1:position) (ps:p_params list) (t:p_term) (pos2:position) :p_term = - if ps = [] then t else make_pos (pos1,pos2) (P_Abst(ps,t)) + 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 make_pos (pos1,pos2) (P_Prod(ps,t)) + if ps = [] then t + else extend_pos (*__FUNCTION__*) (pos1,pos2) (P_Prod(ps,t)) let ident_of_term pos1 {elt; _} = match elt with @@ -173,13 +181,13 @@ let ident_of_term pos1 {elt; _} = (* generic parsing functions *) let list (elt:lexbuf -> 'a) (lb:lexbuf): 'a list = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %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 "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; let x = elt lb in x :: list elt lb @@ -228,8 +236,8 @@ let consume_DEBUG_FLAGS (lb:lexbuf): bool * string = expected "" [DEBUG_FLAGS(true,"")] let qid (lb:lexbuf): (string list * string) loc = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) - match current_token() with + if log_enabled() then log "Expected: %s" __FUNCTION__; + match current_token() with | UID s -> let pos1 = current_pos() in consume_token lb; @@ -242,7 +250,7 @@ let qid (lb:lexbuf): (string list * string) loc = expected "" [UID"";QID[]] let qid_expl (lb:lexbuf): (string list * string) loc = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | UID_EXPL s -> let pos1 = current_pos() in @@ -256,7 +264,7 @@ let qid_expl (lb:lexbuf): (string list * string) loc = expected "" [UID_EXPL"";QID_EXPL[]] let uid (lb:lexbuf): string loc = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | UID s -> let pos1 = current_pos() in @@ -266,7 +274,7 @@ let uid (lb:lexbuf): string loc = expected "" [UID""] let param (lb:lexbuf): string loc option = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | UID s -> let pos1 = current_pos() in @@ -279,7 +287,7 @@ let param (lb:lexbuf): string loc option = expected "non-qualified identifier or \"_\"" [UID"";UNDERSCORE] let int (lb:lexbuf): string = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | INT s -> consume_token lb; @@ -288,7 +296,7 @@ let int (lb:lexbuf): string = expected "integer" [INT""] let float_or_int (lb:lexbuf): string = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | INT s | FLOAT s -> @@ -298,7 +306,7 @@ let float_or_int (lb:lexbuf): string = expected "integer or float" [INT"";FLOAT""] let path (lb:lexbuf): string list loc = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with (*| UID s -> let pos1 = current_pos() in @@ -311,7 +319,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 "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | UID s -> let pos1 = current_pos() in @@ -333,25 +341,23 @@ let qid_or_rule (lb:lexbuf): (string list * string) loc = expected "" [UID"";QID[];UNIF_RULE;COERCE_RULE] let term_id (lb:lexbuf): p_term = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | UID _ | QID _ -> - let pos1 = current_pos() in let i = qid lb in - make_pos pos1 (P_Iden(i, false)) + {i with elt=P_Iden(i, false)} | UID_EXPL _ | QID_EXPL _ -> - let pos1 = current_pos() in let i = qid_expl lb in - make_pos pos1 (P_Iden(i, true)) + {i with elt=P_Iden(i, true)} | _ -> expected "" [UID"";QID[];UID_EXPL"";QID_EXPL[]] (* commands *) let rec command pos1 p_sym_mod (lb:lexbuf): p_command = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | SIDE _ | ASSOCIATIVE @@ -372,7 +378,7 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = match p_sym_mod with | [{elt=P_opaq;_}] -> let i = qid lb in - make_pos pos1 (P_opaque i) + extend_pos (*__FUNCTION__*) pos1 (P_opaque i) | [] -> expected "command keyword missing" [] | {elt=P_opaq;_}::{pos;_}::_ -> @@ -389,7 +395,7 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = | OPEN -> consume_token lb; let ps = nelist path lb in - make_pos pos1 (P_require(Some false,ps)) + extend_pos (*__FUNCTION__*) pos1 (P_require(Some false,ps)) | PRIVATE -> consume_token lb; begin @@ -398,7 +404,7 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = | _ -> expected "" [OPEN] end; let ps = nelist path lb in - make_pos pos1 (P_require(Some true,ps)) + extend_pos (*__FUNCTION__*) pos1 (P_require(Some true,ps)) | _ -> let ps = nelist path lb in begin @@ -411,9 +417,9 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = in consume_token lb; let i = uid lb in - make_pos pos1 (P_require_as(p,i)) + extend_pos (*__FUNCTION__*) pos1 (P_require_as(p,i)) | _ -> - make_pos pos1 (P_require(None,ps)) + extend_pos (*__FUNCTION__*) pos1 (P_require(None,ps)) end end | OPEN -> @@ -426,7 +432,7 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = let pos1 = current_pos() in consume_token lb; let l = list path lb in - make_pos pos1 (P_open(prv,l)) + extend_pos (*__FUNCTION__*) pos1 (P_open(prv,l)) | SYMBOL -> let pos1 = current_pos() in consume_token lb; @@ -445,7 +451,7 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = 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 make_pos pos1 (P_symbol(sym)) + in extend_pos (*__FUNCTION__*) pos1 (P_symbol(sym)) | ASSIGN -> consume_token lb; let p_sym_trm, p_sym_prf = term_proof lb in @@ -453,7 +459,7 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = let sym = {p_sym_mod; p_sym_nam; p_sym_arg; p_sym_typ; p_sym_trm; p_sym_def; p_sym_prf} - in make_pos pos1 (P_symbol(sym)) + in extend_pos (*__FUNCTION__*) pos1 (P_symbol(sym)) | SEMICOLON -> let p_sym_trm = None in let p_sym_def = false in @@ -461,7 +467,7 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = let sym = {p_sym_mod; p_sym_nam; p_sym_arg; p_sym_typ; p_sym_trm; p_sym_def; p_sym_prf} - in make_pos pos1 (P_symbol(sym)) + in extend_pos (*__FUNCTION__*) pos1 (P_symbol(sym)) | _ -> expected "" [BEGIN;ASSIGN] end @@ -473,7 +479,7 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = let sym = {p_sym_mod; p_sym_nam; p_sym_arg; p_sym_typ; p_sym_trm; p_sym_def; p_sym_prf} - in make_pos pos1 (P_symbol(sym)) + in extend_pos (*__FUNCTION__*) pos1 (P_symbol(sym)) | _ -> expected "" [COLON;ASSIGN] end @@ -484,20 +490,20 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = consume INDUCTIVE lb; let i = inductive lb in let is = list (prefix WITH inductive) lb in - make_pos pos1 (P_inductive(p_sym_mod,xs,i::is)) + 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 - make_pos pos1 (P_inductive(p_sym_mod,[],i::is)) + 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 - make_pos pos1 (P_rules(r::rs)) + extend_pos (*__FUNCTION__*) pos1 (P_rules(r::rs)) | UNIF_RULE -> if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) let pos1 = current_pos() in @@ -518,14 +524,14 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = 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 = make_pos pos1 (lhs, rhs) in - make_pos pos1 (P_unif_rule(r)) + 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 - make_pos pos1 (P_coercion r) + extend_pos (*__FUNCTION__*) pos1 (P_coercion r) | BUILTIN -> if p_sym_mod <> [] then expected "" [SYMBOL]; (*or modifiers*) let pos1 = current_pos() in @@ -536,7 +542,7 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = consume_token lb; consume ASSIGN lb; let i = qid lb in - make_pos pos1 (P_builtin(s,i)) + extend_pos (*__FUNCTION__*) pos1 (P_builtin(s,i)) | _ -> expected "" [STRINGLIT""] end @@ -546,12 +552,12 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = consume_token lb; let i = qid lb in let n = notation lb in - make_pos pos1 (P_notation(i,n)) + 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 - make_pos pos1 (P_query(q)) + extend_pos (*__FUNCTION__*) pos1 (P_query(q)) and inductive (lb:lexbuf): p_inductive = let pos0 = current_pos() in @@ -569,13 +575,13 @@ and inductive (lb:lexbuf): p_inductive = let c = constructor lb in let cs = list (prefix VBAR constructor) lb in let l = c::cs in - make_pos pos0 (i,t,l) + extend_pos (*__FUNCTION__*) pos0 (i,t,l) | VBAR -> let l = list (prefix VBAR constructor) lb in - make_pos pos0 (i,t,l) + extend_pos (*__FUNCTION__*) pos0 (i,t,l) | SEMICOLON -> let l = [] in - make_pos pos0 (i,t,l) + extend_pos (*__FUNCTION__*) pos0 (i,t,l) | _ -> expected "identifier" [] end @@ -589,7 +595,7 @@ and constructor (lb:lexbuf): p_ident * p_term = i, make_prod (fst pos1) ps t (snd (current_pos())) and modifier (lb:lexbuf): p_modifier = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | SIDE d -> let pos1 = current_pos() in @@ -598,53 +604,54 @@ and modifier (lb:lexbuf): p_modifier = match current_token() with | ASSOCIATIVE -> consume_token lb; - make_pos pos1 (P_prop (Term.Assoc((d = Pratter.Left)))) + extend_pos (*__FUNCTION__*) pos1 + (P_prop (Term.Assoc((d = Pratter.Left)))) | _ -> expected "" [ASSOCIATIVE] end | ASSOCIATIVE -> let pos1 = current_pos() in consume_token lb; - make_pos pos1 (P_prop (Term.Assoc false)) + extend_pos (*__FUNCTION__*) pos1 (P_prop (Term.Assoc false)) | COMMUTATIVE -> let pos1 = current_pos() in consume_token lb; - make_pos pos1 (P_prop Term.Commu) + extend_pos (*__FUNCTION__*) pos1 (P_prop Term.Commu) | CONSTANT -> let pos1 = current_pos() in consume_token lb; - make_pos pos1 (P_prop Term.Const) + extend_pos (*__FUNCTION__*) pos1 (P_prop Term.Const) | INJECTIVE -> let pos1 = current_pos() in consume_token lb; - make_pos pos1 (P_prop Term.Injec) + extend_pos (*__FUNCTION__*) pos1 (P_prop Term.Injec) | OPAQUE -> let pos1 = current_pos() in consume_token lb; - make_pos pos1 P_opaq + extend_pos (*__FUNCTION__*) pos1 P_opaq | SEQUENTIAL -> let pos1 = current_pos() in consume_token lb; - make_pos pos1 (P_mstrat Term.Sequen) + extend_pos (*__FUNCTION__*) pos1 (P_mstrat Term.Sequen) | _ -> exposition lb and exposition (lb:lexbuf): p_modifier = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | PRIVATE -> let pos1 = current_pos() in consume_token lb; - make_pos pos1 (P_expo Term.Privat) + extend_pos (*__FUNCTION__*) pos1 (P_expo Term.Privat) | PROTECTED -> let pos1 = current_pos() in consume_token lb; - make_pos pos1 (P_expo Term.Protec) + extend_pos (*__FUNCTION__*) pos1 (P_expo Term.Protec) | _ -> expected "" [PRIVATE;PROTECTED] and notation (lb:lexbuf): string Term.notation = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | INFIX -> consume_token lb; @@ -673,15 +680,15 @@ and notation (lb:lexbuf): string Term.notation = expected "" [INFIX;POSTFIX;PREFIX;QUANTIFIER] and rule (lb:lexbuf): (p_term * p_term) loc = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; let pos1 = current_pos() in let l = term lb in consume HOOK_ARROW lb; let r = term lb in - make_pos pos1 (l, r) + extend_pos (*__FUNCTION__*) pos1 (l, r) and equation (lb:lexbuf): p_term * p_term = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; let l = term lb in consume EQUIV lb; let r = term lb in @@ -690,7 +697,7 @@ and equation (lb:lexbuf): p_term * p_term = (* queries *) and query (lb:lexbuf): p_query = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | ASSERT b -> let pos1 = current_pos() in @@ -706,14 +713,16 @@ and query (lb:lexbuf): p_query = let pos2 = current_pos() in let t = make_abst (fst pos1) ps t (snd pos2) in let a = make_prod (fst pos1) ps a (snd pos2) in - make_pos pos1 (P_query_assert(b, P_assert_typing(t,a))) + 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 (fst pos1) ps t (snd pos2) in let u = make_abst (fst pos1) ps u (snd pos2) in - make_pos pos1 (P_query_assert(b, P_assert_conv(t, u))) + extend_pos (*__FUNCTION__*) pos1 + (P_query_assert(b, P_assert_conv(t, u))) | _ -> expected "" [COLON;EQUIV] end @@ -721,69 +730,71 @@ and query (lb:lexbuf): p_query = let pos1 = current_pos() in consume_token lb; let t = term lb in - make_pos pos1 (P_query_normalize(t, {strategy=SNF; steps=None})) + 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 -> - make_pos pos1 (P_query_print None) + extend_pos (*__FUNCTION__*) pos1 (P_query_print None) | _ -> let i = qid_or_rule lb in - make_pos pos1 (P_query_print (Some i)) + extend_pos (*__FUNCTION__*) pos1 (P_query_print (Some i)) end | PROOFTERM -> let pos1 = current_pos() in consume_token lb; - make_pos pos1 P_query_proofterm + extend_pos (*__FUNCTION__*) pos1 P_query_proofterm | DEBUG -> let pos1 = current_pos() in consume_token lb; begin match current_token() with | SEMICOLON -> - make_pos pos1 (P_query_debug(true,"")) + extend_pos (*__FUNCTION__*) pos1 (P_query_debug(true,"")) | _ -> let b,s = consume_DEBUG_FLAGS lb in - make_pos pos1 (P_query_debug(b,s)) + 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 - make_pos pos1 (P_query_flag(s,b)) + extend_pos (*__FUNCTION__*) pos1 (P_query_flag(s,b)) | PROVER -> let pos1 = current_pos() in consume_token lb; let s = consume_STRINGLIT lb in - make_pos pos1 (P_query_prover(s)) + extend_pos (*__FUNCTION__*) pos1 (P_query_prover(s)) | PROVER_TIMEOUT -> let pos1 = current_pos() in consume_token lb; let n = consume_INT lb in - make_pos pos1 (P_query_prover_timeout n) + extend_pos (*__FUNCTION__*) pos1 (P_query_prover_timeout n) | VERBOSE -> let pos1 = current_pos() in consume_token lb; let n = consume_INT lb in - make_pos pos1 (P_query_verbose n) + extend_pos (*__FUNCTION__*) pos1 (P_query_verbose n) | TYPE_QUERY -> let pos1 = current_pos() in consume_token lb; let t = term lb in - make_pos pos1 (P_query_infer(t, {strategy=NONE; steps=None})) + 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 - make_pos pos1 (P_query_search q) + 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 "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | BEGIN -> let p = proof lb in @@ -802,7 +813,7 @@ and term_proof (lb:lexbuf): p_term option * (p_proof * p_proof_end) option = (* proofs *) and proof (lb:lexbuf): p_proof * p_proof_end = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; consume BEGIN lb; match current_token() with | L_CU_BRACKET -> @@ -856,7 +867,7 @@ and proof (lb:lexbuf): p_proof * p_proof_end = expected "subproof, tactic or query" [] and subproof (lb:lexbuf): p_proofstep list = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | L_CU_BRACKET -> consume_token lb; @@ -867,7 +878,7 @@ and subproof (lb:lexbuf): p_proofstep list = expected "" [L_CU_BRACKET] and steps (lb:lexbuf): p_proofstep list = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with (*queries*) | ASSERT _ @@ -915,13 +926,13 @@ and steps (lb:lexbuf): p_proofstep list = expected "tactic or query" [] and step (lb:lexbuf): p_proofstep = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %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 "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | ABORT -> let pos1 = current_pos() in @@ -939,7 +950,7 @@ and proof_end (lb:lexbuf): p_proof_end = expected "" [ABORT;ADMITTED;END] and tactic (lb:lexbuf): p_tactic = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with (*queries*) | ASSERT _ @@ -954,7 +965,7 @@ and tactic (lb:lexbuf): p_tactic = | TYPE_QUERY | VERBOSE -> let pos1 = current_pos() in - make_pos pos1 (P_tac_query (query lb)) + extend_pos (*__FUNCTION__*) pos1 (P_tac_query (query lb)) | ADMIT -> let pos1 = current_pos() in consume_token lb; @@ -963,22 +974,22 @@ and tactic (lb:lexbuf): p_tactic = let pos1 = current_pos() in consume_token lb; let t = term lb in - make_pos pos1 (P_tac_apply t) + extend_pos (*__FUNCTION__*) pos1 (P_tac_apply t) | ASSUME -> let pos1 = current_pos() in consume_token lb; let xs = nelist param lb in - make_pos pos1 (P_tac_assume xs) + extend_pos (*__FUNCTION__*) pos1 (P_tac_assume xs) | CHANGE -> let pos1 = current_pos() in consume_token lb; let t = term lb in - make_pos pos1 (P_tac_change t) + extend_pos (*__FUNCTION__*) pos1 (P_tac_change t) | EVAL -> let pos1 = current_pos() in consume_token lb; let t = term lb in - make_pos pos1 (P_tac_eval t) + extend_pos (*__FUNCTION__*) pos1 (P_tac_eval t) | FAIL -> let pos1 = current_pos() in consume_token lb; @@ -987,14 +998,14 @@ and tactic (lb:lexbuf): p_tactic = let pos1 = current_pos() in consume_token lb; let i = uid lb in - make_pos pos1 (P_tac_generalize i) + 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 - make_pos pos1 (P_tac_have(i,t)) + extend_pos (*__FUNCTION__*) pos1 (P_tac_have(i,t)) | INDUCTION -> let pos1 = current_pos() in consume_token lb; @@ -1004,12 +1015,12 @@ and tactic (lb:lexbuf): p_tactic = consume_token lb; let t1 = tactic lb in let t2 = tactic lb in - make_pos pos1 (P_tac_orelse(t1,t2)) + extend_pos (*__FUNCTION__*) pos1 (P_tac_orelse(t1,t2)) | REFINE -> let pos1 = current_pos() in consume_token lb; let t = term lb in - make_pos pos1 (P_tac_refine t) + extend_pos (*__FUNCTION__*) pos1 (P_tac_refine t) | REFLEXIVITY -> let pos1 = current_pos() in consume_token lb; @@ -1018,12 +1029,12 @@ and tactic (lb:lexbuf): p_tactic = let pos1 = current_pos() in consume_token lb; let xs = nelist uid lb in - make_pos pos1 (P_tac_remove xs) + extend_pos (*__FUNCTION__*) pos1 (P_tac_remove xs) | REPEAT -> let pos1 = current_pos() in consume_token lb; let t = tactic lb in - make_pos pos1 (P_tac_repeat t) + extend_pos (*__FUNCTION__*) pos1 (P_tac_repeat t) | REWRITE -> let pos1 = current_pos() in consume_token lb; @@ -1038,20 +1049,20 @@ and tactic (lb:lexbuf): p_tactic = let p = rw_patt_spec lb in let t = term lb in let b = d <> Pratter.Left in - make_pos pos1 (P_tac_rewrite(b,Some p,t)) + extend_pos (*__FUNCTION__*) pos1 (P_tac_rewrite(b,Some p,t)) | _ -> let t = term lb in let b = d <> Pratter.Left in - make_pos pos1 (P_tac_rewrite(b,None,t)) + extend_pos (*__FUNCTION__*) pos1 (P_tac_rewrite(b,None,t)) end | DOT -> consume_token lb; let p = rw_patt_spec lb in let t = term lb in - make_pos pos1 (P_tac_rewrite(true,Some p,t)) + extend_pos (*__FUNCTION__*) pos1 (P_tac_rewrite(true,Some p,t)) | _ -> let t = term lb in - make_pos pos1 (P_tac_rewrite(true,None,t)) + extend_pos (*__FUNCTION__*) pos1 (P_tac_rewrite(true,None,t)) end | SET -> let pos1 = current_pos() in @@ -1059,7 +1070,7 @@ and tactic (lb:lexbuf): p_tactic = let i = uid lb in consume ASSIGN lb; let t = term lb in - make_pos pos1 (P_tac_set(i,t)) + extend_pos (*__FUNCTION__*) pos1 (P_tac_set(i,t)) | SIMPLIFY -> let pos1 = current_pos() in consume_token lb; @@ -1067,18 +1078,18 @@ and tactic (lb:lexbuf): p_tactic = match current_token() with | UID _ | QID _ -> - make_pos pos1 (P_tac_simpl(SimpSym(qid lb))) + extend_pos (*__FUNCTION__*) pos1 (P_tac_simpl(SimpSym(qid lb))) | RULE -> consume_token lb; begin match current_token() with | SWITCH false -> consume_token lb; - make_pos pos1 (P_tac_simpl SimpBetaOnly) + extend_pos (*__FUNCTION__*) pos1 (P_tac_simpl SimpBetaOnly) | _ -> expected "" [SWITCH false] end | _ -> - make_pos pos1 (P_tac_simpl SimpAll) + extend_pos (*__FUNCTION__*) pos1 (P_tac_simpl SimpAll) end | SOLVE -> let pos1 = current_pos() in @@ -1092,14 +1103,14 @@ and tactic (lb:lexbuf): p_tactic = let pos1 = current_pos() in consume_token lb; let t = tactic lb in - make_pos pos1 (P_tac_try t) + extend_pos (*__FUNCTION__*) pos1 (P_tac_try t) | WHY3 -> let pos1 = current_pos() in consume_token lb; begin match current_token() with | STRINGLIT s -> - make_pos pos1 (P_tac_why3 (Some s)) + extend_pos (*__FUNCTION__*) pos1 (P_tac_why3 (Some s)) | _ -> make_pos pos1 (P_tac_why3 None) end @@ -1107,7 +1118,7 @@ and tactic (lb:lexbuf): p_tactic = expected "tactic" [] and rw_patt (lb:lexbuf): p_rw_patt = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with (* bterm *) | BACKQUOTE @@ -1140,10 +1151,11 @@ and rw_patt (lb:lexbuf): p_rw_patt = consume_token lb; let t3 = term lb in let x = ident_of_term pos1 t2 in - make_pos pos1 (Rw_TermInIdInTerm(t1,(x,t3))) + extend_pos (*__FUNCTION__*) pos1 + (Rw_TermInIdInTerm(t1,(x,t3))) | _ -> let x = ident_of_term pos1 t1 in - make_pos pos1 (Rw_IdInTerm(x,t2)) + extend_pos (*__FUNCTION__*) pos1 (Rw_IdInTerm(x,t2)) end | AS -> consume_token lb; @@ -1154,12 +1166,13 @@ and rw_patt (lb:lexbuf): p_rw_patt = consume_token lb; let t3 = term lb in let x = ident_of_term pos1 t2 in - make_pos pos1 (Rw_TermAsIdInTerm(t1,(x,t3))) + extend_pos (*__FUNCTION__*) pos1 + (Rw_TermAsIdInTerm(t1,(x,t3))) | _ -> expected "" [IN] end | _ -> - make_pos pos1 (Rw_Term(t1)) + extend_pos (*__FUNCTION__*) pos1 (Rw_Term(t1)) end | IN -> let pos1 = current_pos() in @@ -1171,15 +1184,15 @@ and rw_patt (lb:lexbuf): p_rw_patt = consume_token lb; let t2 = term lb in let x = ident_of_term pos1 t1 in - make_pos pos1 (Rw_InIdInTerm(x,t2)) + extend_pos (*__FUNCTION__*) pos1 (Rw_InIdInTerm(x,t2)) | _ -> - make_pos pos1 (Rw_InTerm(t1)) + extend_pos (*__FUNCTION__*) pos1 (Rw_InTerm(t1)) end | _ -> expected "term or keyword \"in\"" [] and rw_patt_spec (lb:lexbuf): p_rw_patt = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | L_SQ_BRACKET -> consume_token lb; @@ -1192,7 +1205,7 @@ and rw_patt_spec (lb:lexbuf): p_rw_patt = (* terms *) and params (lb:lexbuf): p_params = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | L_PAREN -> consume_token lb; @@ -1231,7 +1244,7 @@ and params (lb:lexbuf): p_params = [x], None, false and term (lb:lexbuf): p_term = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with (* bterm *) | BACKQUOTE @@ -1259,7 +1272,8 @@ and term (lb:lexbuf): p_term = expected "term" [] and app (pos1:position * position) (t: p_term) (lb:lexbuf): p_term = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "app %a" pp_lexing pos1; match current_token() with (* aterm *) | UID _ @@ -1275,42 +1289,42 @@ and app (pos1:position * position) (t: p_term) (lb:lexbuf): p_term = | INT _ | STRINGLIT _ -> let u = aterm lb in - app pos1 (make_pos pos1 (P_Appl(t,u))) lb + app pos1 (extend_pos (*__FUNCTION__*) pos1 (P_Appl(t,u))) lb (* bterm *) | BACKQUOTE | PI | LAMBDA | LET -> let u = bterm lb in - make_pos pos1 (P_Appl(t,u)) + extend_pos (*__FUNCTION__*) pos1 (P_Appl(t,u)) (* other cases *) | ARROW -> consume_token lb; let u = term lb in - make_pos pos1 (P_Arro(t,u)) + extend_pos (*__FUNCTION__*) pos1 (P_Arro(t,u)) | _ -> t and bterm (lb:lexbuf): p_term = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %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 = make_pos pos1 (P_Abst(fst b, snd b)) in - make_pos pos1 (P_Appl(q, b)) + 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 - make_pos pos1 (P_Prod(fst b, snd b)) + extend_pos (*__FUNCTION__*) pos1 (P_Prod(fst b, snd b)) | LAMBDA -> let pos1 = current_pos() in consume_token lb; let b = binder lb in - make_pos pos1 (P_Abst(fst b, snd b)) + extend_pos (*__FUNCTION__*) pos1 (P_Abst(fst b, snd b)) | LET -> let pos1 = current_pos() in consume_token lb; @@ -1325,20 +1339,20 @@ and bterm (lb:lexbuf): p_term = let t = term lb in consume IN lb; let u = term lb in - make_pos pos1 (P_LLet(x, a, b, t, u)) + 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 - make_pos pos1 (P_LLet(x, a, b, t, u)) + 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 "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | UID _ | QID _ @@ -1361,19 +1375,22 @@ and aterm (lb:lexbuf): p_term = match current_token() with | DOT -> consume_token lb; - make_pos pos1 (P_Meta(i,Array.of_list (env lb))) + extend_pos (*__FUNCTION__*) pos1 + (P_Meta(i,Array.of_list (env lb))) | _ -> - make_pos pos1 (P_Meta(i,[||])) + {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 + let i = + if s = "_" then None else Some(make_pos pos1 s) in begin match current_token() with | DOT -> consume_token lb; - make_pos pos1 (P_Patt(i, Some(Array.of_list (env lb)))) + extend_pos (*__FUNCTION__*) pos1 + (P_Patt(i, Some(Array.of_list (env lb)))) | _ -> make_pos pos1 (P_Patt(i, None)) end @@ -1382,13 +1399,13 @@ and aterm (lb:lexbuf): p_term = consume_token lb; let t = term lb in consume R_PAREN lb; - make_pos pos1 (P_Wrap(t)) + 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; - make_pos pos1 (P_Expl(t)) + extend_pos (*__FUNCTION__*) pos1 (P_Expl(t)) | INT n -> let pos1 = current_pos() in consume_token lb; @@ -1402,7 +1419,7 @@ and aterm (lb:lexbuf): p_term = brackets" [] and env (lb:lexbuf): p_term list = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | L_SQ_BRACKET -> consume_token lb; @@ -1421,7 +1438,7 @@ and env (lb:lexbuf): p_term list = expected "" [L_SQ_BRACKET] and binder (lb:lexbuf): p_params list * p_term = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | UID _ | UNDERSCORE -> @@ -1476,7 +1493,7 @@ and binder (lb:lexbuf): p_params list * p_term = (* search *) and where (lb:lexbuf): bool * inside option = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | UID u -> let r = @@ -1498,7 +1515,7 @@ and where (lb:lexbuf): bool * inside option = expected "\">\", \"=\", \"≥\",\">=\"" [] and asearch (lb:lexbuf): query = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | TYPE_QUERY -> consume_token lb; @@ -1550,7 +1567,7 @@ and asearch (lb:lexbuf): query = expected "name, anywhere, rule, lhs, rhs, type, concl, hyp, spine" [] and csearch (lb:lexbuf): query = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; let aq = asearch lb in match current_token() with | COMMA -> @@ -1560,7 +1577,7 @@ and csearch (lb:lexbuf): query = aq and ssearch (lb:lexbuf): query = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; let cq = csearch lb in match current_token() with | SEMICOLON -> @@ -1570,7 +1587,7 @@ and ssearch (lb:lexbuf): query = cq and search (lb:lexbuf): query = - (*if log_enabled() then log "Expected: %s" __FUNCTION__;*) + if log_enabled() then log "Expected: %s" __FUNCTION__; let q = ssearch lb in let qids = list (prefix VBAR qid) lb in let path_of_qid qid = From 0f6fe1c1516bc030981fdeafcf1f3ba8869a50a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Wed, 26 Nov 2025 16:11:23 +0100 Subject: [PATCH 21/35] make parse_entry_string handle errors --- src/parsing/lpParser.ml | 3 ++- src/parsing/parser.ml | 21 +++++++++++---------- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/src/parsing/lpParser.ml b/src/parsing/lpParser.ml index 3accf10c8..c97fde3d8 100644 --- a/src/parsing/lpParser.ml +++ b/src/parsing/lpParser.ml @@ -130,7 +130,8 @@ 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 reset(); r with e -> reset(); raise e + 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^".") diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index 022d5e055..6be54534b 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -110,17 +110,18 @@ sig end = struct + let handle_error (icopt: in_channel option) + (entry: lexbuf -> 'a) (lb: lexbuf): 'a option = + try Some(entry lb) + with + | End_of_file -> Option.iter close_in icopt; None + | SyntaxError{pos=None; _} -> assert false + | SyntaxError{pos=Some pos; elt} -> + parser_fatal pos "Syntax error. %s" elt + let parse_lexbuf (icopt: in_channel option) (entry: lexbuf -> 'a) (lb: lexbuf): 'a Stream.t = - let generator _ = - try Some(entry lb) - with - | End_of_file -> Option.iter close_in icopt; None - | SyntaxError{pos=None; _} -> assert false - | SyntaxError{pos=Some pos; elt} -> - parser_fatal pos "Syntax error. %s" elt - in - Stream.from generator + Stream.from (fun _ -> handle_error icopt entry lb) let parse_string (entry: lexbuf -> 'a) (fname: string) (s: string) : 'a Stream.t = @@ -142,7 +143,7 @@ sig let lb = Utf8.from_string s in set_position lb lexpos; set_filename lb lexpos.pos_fname; - LpParser.new_parsing entry lb + Stream.next (parse_lexbuf None (LpParser.new_parsing entry) lb) (* exported functions *) let parse_term_string = parse_entry_string LpParser.term From 75391f889bd682a18249d4c9a07a7070c6160adf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Wed, 26 Nov 2025 20:25:37 +0100 Subject: [PATCH 22/35] rename rw_patt into rwpatt, and fix rwpatt parsing --- src/handle/rewrite.ml | 2 +- src/handle/tactic.ml | 8 +++++--- src/parsing/lpParser.ml | 24 +++++++++++++++++------- src/parsing/parser.ml | 4 ++-- src/parsing/pretty.ml | 4 ++-- src/parsing/scope.ml | 4 ++-- src/parsing/scope.mli | 4 ++-- src/parsing/syntax.ml | 14 +++++++------- 8 files changed, 38 insertions(+), 26 deletions(-) diff --git a/src/handle/rewrite.ml b/src/handle/rewrite.ml index 245b696e6..9bce82d8d 100644 --- a/src/handle/rewrite.ml +++ b/src/handle/rewrite.ml @@ -372,7 +372,7 @@ let swap : eq_config -> term -> term -> term -> term -> term = equational lemma that is appied. It handles the full set of SSReflect patterns. *) let rewrite : Sig_state.t -> problem -> popt -> goal_typ -> bool -> - (term, binder) Parsing.Syntax.rw_patt option -> term -> term = + (term, binder) Parsing.Syntax.rwpatt option -> term -> term = fun ss p pos {goal_hyps=g_env; goal_type=g_type; _} l2r pat t -> (* Obtain the required symbols from the current signature. *) diff --git a/src/handle/tactic.ml b/src/handle/tactic.ml index 6d3fcac62..1f50605b0 100644 --- a/src/handle/tactic.ml +++ b/src/handle/tactic.ml @@ -316,7 +316,9 @@ let p_term_of_string (pos:popt) (t:term): p_term = end | _ -> fatal pos "refine tactic not applied to a term string literal" -let p_rw_patt_of_string (pos:popt) (t:term): p_rw_patt option = +let p_rwpatt_of_string (pos:popt) (t:term): p_rwpatt option = + if Logger.log_enabled() then + log "p_rwpatt_of_string %a %a" Pos.short pos term t; match t with | Symb s when String.is_string_literal s.sym_name -> let string = remove_quotes s.sym_name in @@ -377,7 +379,7 @@ let p_tactic (ss:Sig_state.t) (pos:popt): int StrMap.t -> term -> p_tactic = | T_repeat, _ -> assert false | T_rewrite, [side;pat;_;t] -> P_tac_rewrite(is_right pos side, - p_rw_patt_of_string pos pat, p_term pos idmap t) + p_rwpatt_of_string pos pat, p_term pos idmap t) | T_rewrite, _ -> assert false | T_set, [t1;_;t2] -> P_tac_set(p_ident_of_sym pos t1, p_term pos idmap t2) @@ -626,7 +628,7 @@ let rec handle : let g = List.fold_left remove g ids in {ps with proof_goals = g::gs} | P_tac_rewrite(l2r,pat,eq) -> - let pat = Option.map (Scope.scope_rw_patt ss env) pat in + let pat = Option.map (Scope.scope_rwpatt ss env) pat in let p = new_problem() in tac_refine pos ps gt gs p (Rewrite.rewrite ss p pos gt l2r pat (scope eq)) diff --git a/src/parsing/lpParser.ml b/src/parsing/lpParser.ml index c97fde3d8..b8941fdb8 100644 --- a/src/parsing/lpParser.ml +++ b/src/parsing/lpParser.ml @@ -447,6 +447,7 @@ let rec command pos1 p_sym_mod (lb:lexbuf): p_command = 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 = @@ -798,6 +799,7 @@ and term_proof (lb:lexbuf): p_term option * (p_proof * p_proof_end) option = if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | BEGIN -> + consume_token lb; let p = proof lb in None, Some p | _ -> @@ -805,6 +807,7 @@ and term_proof (lb:lexbuf): p_term option * (p_proof * p_proof_end) option = begin match current_token() with | BEGIN -> + consume_token lb; let p = proof lb in Some t, Some p | _ -> @@ -815,7 +818,6 @@ and term_proof (lb:lexbuf): p_term option * (p_proof * p_proof_end) option = and proof (lb:lexbuf): p_proof * p_proof_end = if log_enabled() then log "Expected: %s" __FUNCTION__; - consume BEGIN lb; match current_token() with | L_CU_BRACKET -> let l = nelist subproof lb in @@ -1047,7 +1049,7 @@ and tactic (lb:lexbuf): p_tactic = match current_token() with | DOT -> consume_token lb; - let p = rw_patt_spec lb in + 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)) @@ -1058,7 +1060,7 @@ and tactic (lb:lexbuf): p_tactic = end | DOT -> consume_token lb; - let p = rw_patt_spec lb in + let p = rwpatt_bracket lb in let t = term lb in extend_pos (*__FUNCTION__*) pos1 (P_tac_rewrite(true,Some p,t)) | _ -> @@ -1118,7 +1120,7 @@ and tactic (lb:lexbuf): p_tactic = | _ -> expected "tactic" [] -and rw_patt (lb:lexbuf): p_rw_patt = +and rwpatt_content (lb:lexbuf): p_rwpatt = if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with (* bterm *) @@ -1192,17 +1194,26 @@ and rw_patt (lb:lexbuf): p_rw_patt = | _ -> expected "term or keyword \"in\"" [] -and rw_patt_spec (lb:lexbuf): p_rw_patt = +and rwpatt_bracket (lb:lexbuf): p_rwpatt = if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | L_SQ_BRACKET -> consume_token lb; - let p = rw_patt lb in + 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 "Expected: %s" __FUNCTION__; + match current_token() with + | DOT -> + consume_token lb; + rwpatt_bracket lb + | _ -> + expected "" [DOT] + (* terms *) and params (lb:lexbuf): p_params = @@ -1274,7 +1285,6 @@ and term (lb:lexbuf): p_term = and app (pos1:position * position) (t: p_term) (lb:lexbuf): p_term = if log_enabled() then log "Expected: %s" __FUNCTION__; - if log_enabled() then log "app %a" pp_lexing pos1; match current_token() with (* aterm *) | UID _ diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index 6be54534b..093866bf3 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -99,7 +99,7 @@ sig (** [parse_rwpatt_string p s] parses a term from string [s] assuming that [s] starts at position [p]. *) - val parse_rwpatt_string: Lexing.position -> string -> Syntax.p_rw_patt + val parse_rwpatt_string: Lexing.position -> string -> Syntax.p_rwpatt (** [parse_rwpatt_string f s] parses a rewrite pattern specification from string [s] assuming that [s] starts at position [p]. *) @@ -147,7 +147,7 @@ sig (* exported functions *) let parse_term_string = parse_entry_string LpParser.term - let parse_rwpatt_string = parse_entry_string LpParser.rw_patt_spec + let parse_rwpatt_string = parse_entry_string LpParser.rwpatt let parse_search_query_string = parse_entry_string LpParser.search let parse_in_channel = parse_in_channel LpParser.command diff --git a/src/parsing/pretty.ml b/src/parsing/pretty.ml index 86675d3c3..7e7b0212c 100644 --- a/src/parsing/pretty.ml +++ b/src/parsing/pretty.ml @@ -226,7 +226,7 @@ let proof_end : p_proof_end pp = fun ppf pe -> | P_proof_admitted -> "admitted" | P_proof_abort -> "abort") -let rw_patt : p_rw_patt pp = fun ppf p -> +let rwpatt : p_rwpatt pp = fun ppf p -> match p.elt with | Rw_Term(t) -> term ppf t | Rw_InTerm(t) -> out ppf "in %a" term t @@ -307,7 +307,7 @@ let rec tactic : p_tactic pp = fun ppf { elt; _ } -> | P_tac_repeat t -> out ppf "repeat %a" tactic t | P_tac_rewrite(b,p,t) -> let dir ppf b = if not b then out ppf " left" in - let pat ppf p = out ppf " .[%a]" rw_patt p in + let pat ppf p = out ppf " .[%a]" rwpatt p in out ppf "rewrite%a%a %a" dir b (Option.pp pat) p term t | P_tac_set (id, t) -> out ppf "set %a ≔ %a" ident id term t | P_tac_simpl SimpAll -> out ppf "simplify" diff --git a/src/parsing/scope.ml b/src/parsing/scope.ml index b7140eb41..104e4b3d3 100644 --- a/src/parsing/scope.ml +++ b/src/parsing/scope.ml @@ -631,9 +631,9 @@ let scope_rule : let scope_pattern : sig_state -> env -> p_term -> term = fun ss env t -> scope 0 M_Patt ss env t -(** [scope_rw_patt ss env s] scopes the parser-level rewrite tactic +(** [scope_rwpatt ss env s] scopes the parser-level rewrite tactic specification [s] into an actual rewrite specification. *) -let scope_rw_patt : sig_state -> env -> p_rw_patt -> (term, binder) rw_patt = +let scope_rwpatt : sig_state -> env -> p_rwpatt -> (term, binder) rwpatt = fun ss env s -> match s.elt with | Rw_Term(t) -> Rw_Term(scope_pattern ss env t) diff --git a/src/parsing/scope.mli b/src/parsing/scope.mli index 6f87a9263..fbedb632a 100644 --- a/src/parsing/scope.mli +++ b/src/parsing/scope.mli @@ -34,7 +34,7 @@ val scope_search_pattern : val scope_rule : ?find_sym: find_sym -> bool -> sig_state -> p_rule -> sym_rule -(** [scope_rw_patt ss env t] turns a parser-level rewrite tactic specification +(** [scope_rwpatt ss env t] turns a parser-level rewrite tactic specification [s] into an actual rewrite specification (possibly containing variables of [env] and using [ss] for aliasing). *) -val scope_rw_patt : sig_state -> env -> p_rw_patt -> (term, binder) rw_patt +val scope_rwpatt : sig_state -> env -> p_rwpatt -> (term, binder) rwpatt diff --git a/src/parsing/syntax.ml b/src/parsing/syntax.ml index 43b6bff52..1a2e2ff59 100644 --- a/src/parsing/syntax.ml +++ b/src/parsing/syntax.ml @@ -189,7 +189,7 @@ end Reflection Extension for the Coq system", by Georges Gonthier, Assia Mahboubi and Enrico Tassi, INRIA Research Report 6455, 2016, @see , section 8, p. 48. *) -type ('term, 'binder) rw_patt = +type ('term, 'binder) rwpatt = | Rw_Term of 'term | Rw_InTerm of 'term | Rw_InIdInTerm of 'binder @@ -197,7 +197,7 @@ type ('term, 'binder) rw_patt = | Rw_TermInIdInTerm of 'term * 'binder | Rw_TermAsIdInTerm of 'term * 'binder -type p_rw_patt = (p_term, p_ident * p_term) rw_patt loc +type p_rwpatt = (p_term, p_ident * p_term) rwpatt loc (** Parser-level representation of an assertion. *) type p_assertion = @@ -280,7 +280,7 @@ type p_tactic_aux = | P_tac_refl | P_tac_remove of p_ident list | P_tac_repeat of p_tactic - | P_tac_rewrite of bool * p_rw_patt option * p_term + | P_tac_rewrite of bool * p_rwpatt option * p_term (* The boolean indicates if the equation is applied from left to right. *) | P_tac_set of p_ident * p_term | P_tac_simpl of simp_flag @@ -407,7 +407,7 @@ let eq_p_inductive : p_inductive eq = fun {elt=(i1,t1,l1);_} {elt=(i2,t2,l2);_} -> List.eq eq_cons ((i1,t1)::l1) ((i2,t2)::l2) -let eq_p_rw_patt : p_rw_patt eq = fun {elt=r1;_} {elt=r2;_} -> +let eq_p_rwpatt : p_rwpatt eq = fun {elt=r1;_} {elt=r2;_} -> match r1, r2 with | Rw_Term t1, Rw_Term t2 | Rw_InTerm t1, Rw_InTerm t2 -> eq_p_term t1 t2 @@ -458,7 +458,7 @@ let eq_p_tactic : p_tactic eq = fun {elt=t1;_} {elt=t2;_} -> | P_tac_assume xs1, P_tac_assume xs2 -> List.eq (Option.eq eq_p_ident) xs1 xs2 | P_tac_rewrite(b1,p1,t1), P_tac_rewrite(b2,p2,t2) -> - b1 = b2 && Option.eq eq_p_rw_patt p1 p2 && eq_p_term t1 t2 + b1 = b2 && Option.eq eq_p_rwpatt p1 p2 && eq_p_term t1 t2 | P_tac_query q1, P_tac_query q2 -> eq_p_query q1 q2 | P_tac_why3 so1, P_tac_why3 so2 -> so1 = so2 | P_tac_simpl s1, P_tac_simpl s2 -> eq_simp_flag s1 s2 @@ -614,7 +614,7 @@ let fold_idents : ('a -> p_qident -> 'a) -> 'a -> p_command list -> 'a = fold_term (fold_term a l) r in - let fold_rw_patt_vars : StrSet.t -> 'a -> p_rw_patt -> 'a = fun vs a p -> + let fold_rwpatt_vars : StrSet.t -> 'a -> p_rwpatt -> 'a = fun vs a p -> match p.elt with | Rw_Term t | Rw_InTerm t -> fold_term_vars vs a t @@ -652,7 +652,7 @@ let fold_idents : ('a -> p_qident -> 'a) -> 'a -> p_command list -> 'a = | P_tac_change t | P_tac_rewrite (_, None, t) -> (vs, fold_term_vars vs a t) | P_tac_rewrite (_, Some p, t) -> - (vs, fold_term_vars vs (fold_rw_patt_vars vs a p) t) + (vs, fold_term_vars vs (fold_rwpatt_vars vs a p) t) | P_tac_query q -> (vs, fold_query_vars vs a q) | P_tac_assume idopts -> (add_idopts vs idopts, a) | P_tac_remove ids -> From ea6e01973901e5bcf0bc6dac53409a5c1290ae97 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Wed, 26 Nov 2025 20:55:25 +0100 Subject: [PATCH 23/35] fix extend_pos --- src/parsing/lpParser.ml | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/parsing/lpParser.ml b/src/parsing/lpParser.ml index b8941fdb8..40142be67 100644 --- a/src/parsing/lpParser.ml +++ b/src/parsing/lpParser.ml @@ -154,10 +154,15 @@ let consume_token (lb:lexbuf) : unit = (* building positions and terms *) let extend_pos (*s:string*) (lps:position * position): 'a -> 'a loc = - let lps2 = (fst lps, snd (current_pos())) in + 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 lps2 + make_pos (p1,p2) let qid_of_path (lps: position * position): string list -> (string list * string) loc = function From 3a33513fc2326854293fe1a7f175fad90221acac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Thu, 27 Nov 2025 11:51:58 +0100 Subject: [PATCH 24/35] fix starting positions in p_term_of_string and p_rwpatt_of_string --- src/handle/tactic.ml | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/src/handle/tactic.ml b/src/handle/tactic.ml index 1f50605b0..3e56dde0d 100644 --- a/src/handle/tactic.ml +++ b/src/handle/tactic.ml @@ -307,15 +307,22 @@ let p_query_of_term (c:config) (pos:popt) (t:term) :p_query = | Symb s, ts -> p_query c pos s ts | _ -> fatal pos "Unhandled query expression: %a." term t*) +(** [p_term_of_string pos t] turns into a p_term a string literal term [t] + that is part of a bigger term obtained by scoping and normalizing of a + p_term at position [pos]. *) let p_term_of_string (pos:popt) (t:term): p_term = match t with | Symb s when String.is_string_literal s.sym_name -> begin let string = remove_quotes s.sym_name in - Parsing.Parser.Lp.parse_term_string (lexing_opt pos) string + let p = lexing_opt (after s.sym_pos) in + Parsing.Parser.Lp.parse_term_string p string end - | _ -> fatal pos "refine tactic not applied to a term string literal" + | _ -> fatal pos "not a string literal" +(** [p_rwpatt_of_string pos t] turns into a p_rwpatt option a string literal + term [t] that is part of a bigger term obtained by scoping and normalizing + of a p_term at position [pos]. *) let p_rwpatt_of_string (pos:popt) (t:term): p_rwpatt option = if Logger.log_enabled() then log "p_rwpatt_of_string %a %a" Pos.short pos term t; @@ -323,9 +330,9 @@ let p_rwpatt_of_string (pos:popt) (t:term): p_rwpatt option = | Symb s when String.is_string_literal s.sym_name -> let string = remove_quotes s.sym_name in if string = "" then None - else - Some (Parsing.Parser.Lp.parse_rwpatt_string (lexing_opt pos) string) - | _ -> fatal pos "rewrite tactic not applied to a pattern string literal" + else let p = lexing_opt (after s.sym_pos) in + Some (Parsing.Parser.Lp.parse_rwpatt_string p string) + | _ -> fatal pos "not a string literal" let is_right (pos:popt) (t:term): bool = match t with @@ -339,7 +346,8 @@ let is_right (pos:popt) (t:term): bool = end | _ -> fatal pos "rewrite tactic not applied to a side string literal" -(** [p_tactic ss pos idmap t] interprets the term [t] as a tactic. *) +(** [p_tactic ss pos idmap t] interprets as a tactic the term [t] obtained by + scoping and normalization of a p_term at position [pos]. *) let p_tactic (ss:Sig_state.t) (pos:popt): int StrMap.t -> term -> p_tactic = let c = get_config ss pos in let rec tac idmap t = Pos.make pos (tac_aux idmap t) From a3f566137ef835f01e1e52aa0ace62fee1996fba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 28 Nov 2025 07:32:36 +0100 Subject: [PATCH 25/35] remove Makefile.bnf --- CONTRIBUTING.md | 5 +-- Makefile | 6 +-- doc/Makefile.bnf | 110 ----------------------------------------------- doc/lambdapi.bnf | 61 ++++++++------------------ 4 files changed, 22 insertions(+), 160 deletions(-) delete mode 100644 doc/Makefile.bnf diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index fdd32e49e..4178986f6 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -66,8 +66,9 @@ Changing the syntax of Lambdapi When changing the syntax of Lambdapi, make sure to update the following files: +- `doc/lambdapi.bnf` - `src/core/lpLexer.ml` -- `src/core/lpParser.mly` +- `src/core/lpParser.ml` - `src/core/pretty.ml` - `src/core/print.ml` - `editors/vim/syntax/lambdapi.vim` @@ -76,8 +77,6 @@ following files: - `editors/vscode/lp.configuration.json` (comments configuration), - `editors/vscode/syntaxes/lp.tmLanguage.json` (syntax highlighting), - `misc/lambdapi.tex` -- `doc/Makefile.bnf` -- `doc/lambdapi.bnf` by doing `make bnf` - the User Manual files in the `doc/` repository (do `make doc` to generate and check the Sphynx documentation). Adding a tactic diff --git a/Makefile b/Makefile index bc1a60b25..3c017b996 100644 --- a/Makefile +++ b/Makefile @@ -15,13 +15,9 @@ odoc: @dune build --only-packages lambdapi @doc .PHONY: doc -doc: bnf +doc: $(MAKE) -C doc html -.PHONY: bnf -bnf: - $(MAKE) -C doc -f Makefile.bnf - #### Unit tests and sanity check ############################################# .PHONY: sanity_check diff --git a/doc/Makefile.bnf b/doc/Makefile.bnf deleted file mode 100644 index 599c96a93..000000000 --- a/doc/Makefile.bnf +++ /dev/null @@ -1,110 +0,0 @@ -default: lambdapi.bnf - -BNF_GEN := obelisk - -lambdapi.bnf: Makefile.bnf ../src/parsing/lpParser.mly - printf "; DO NOT EDIT THIS FILE MANUALLY\n" > $@ - printf "; It is generated automatically with 'make bnf'.\n\n" >> $@ - printf "QID ::= [UID \".\"]+ UID\n\n" >> $@ - printf " ::= \"on\"\n | \"off\"\n\n" >> $@ - printf " ::= \"left\"\n | \"right\"\n\n" >> $@ - printf " ::= \"assert\"\n | \"assertnot\"\n\n" >> $@ - $(BNF_GEN) ../src/parsing/lpParser.mly | sed \ - -e 's/SWITCH//g' \ - -e 's/ABORT/"abort"/g' \ - -e 's/ADMITTED/"admitted"/g' \ - -e 's/ADMIT/"admit"/g' \ - -e 's/APPLY/"apply"/g' \ - -e 's/ASSERT//g' \ - -e 's/ASSOCIATIVE/"associative"/g' \ - -e 's/ASSUME/"assume"/g' \ - -e 's/ASSIGN/"≔"/g' \ - -e 's/AS/"as"/g' \ - -e 's/BEGIN/"begin"/g' \ - -e 's/BUILTIN/"builtin"/g' \ - -e 's/CHANGE/"change"/g' \ - -e 's/COERCE_RULE/"coerce_rule"/g' \ - -e 's/COMMUTATIVE/"commutative"/g' \ - -e 's/COMPUTE/"compute"/g' \ - -e 's/CONSTANT/"constant"/g' \ - -e 's/DEBUG_FLAGS/("+"|"-") +/g' \ - -e 's/DEBUG/"debug"/g' \ - -e 's/DOT/"."/g' \ - -e 's/END/"end"/g' \ - -e 's/EVAL/"eval"/g' \ - -e 's/FAIL/"fail"/g' \ - -e 's/FLAG/"flag"/g' \ - -e 's/GENERALIZE/"generalize"/g' \ - -e 's/HAVE/"have"/g' \ - -e 's/INDUCTION/"induction"/g' \ - -e 's/INDUCTIVE/"inductive"/g' \ - -e 's/INFIX/"infix"/g' \ - -e 's/INJECTIVE/"injective"/g' \ - -e 's/LET/"let"/g' \ - -e 's/NEG_NAT/"-"/g' \ - -e 's/NAT//g' \ - -e 's/NOTATION/"notation"/g' \ - -e 's/OPEN/"open"/g' \ - -e 's/OPAQUE/"opaque"/g' \ - -e 's/ORELSE/"orelse"/g' \ - -e 's/POSTFIX/"postfix"/g' \ - -e 's/PREFIX/"prefix"/g' \ - -e 's/PRINT/"print"/g' \ - -e 's/PRIVATE/"private"/g' \ - -e 's/PROOFTERM/"proofterm"/g' \ - -e 's/PROTECTED/"protected"/g' \ - -e 's/PROVER_TIMEOUT/"prover_timeout"/g' \ - -e 's/PROVER/"prover"/g' \ - -e 's/QUANTIFIER/"quantifier"/g' \ - -e 's/REFLEXIVITY/"reflexivity"/g' \ - -e 's/REFINE/"refine"/g' \ - -e 's/REMOVE/"remove"/g' \ - -e 's/REPEAT/"repeat"/g' \ - -e 's/REQUIRE/"require"/g' \ - -e 's/RESOLVE/"resolve"/g' \ - -e 's/REWRITE/"rewrite"/g' \ - -e 's/SET/"set"/g' \ - -e 's/UNIF_RULE/"unif_rule"/g' \ - -e 's/RULE/"rule"/g' \ - -e 's/SIDE//g' \ - -e 's/SEARCH/"search"/g' \ - -e 's/SEQUENTIAL/"sequential"/g' \ - -e 's/SIMPLIFY/"simplify"/g' \ - -e 's/SOLVE/"solve"/g' \ - -e 's/STRINGLIT//g' \ - -e 's/SYMBOL/"symbol"/g' \ - -e 's/SYMMETRY/"symmetry"/g' \ - -e 's/TRY/"try"/g' \ - -e 's/TYPE_QUERY/"type"/g' \ - -e 's/TYPE_TERM/"TYPE"/g' \ - -e 's/VERBOSE/"verbose"/g' \ - -e 's/WHY3/"why3"/g' \ - -e 's/WITH/"with"/g' \ - -e 's/INT//g' \ - -e 's/IN/"in"/g' \ - -e 's/FLOAT//g' \ - -e 's/HOOK_ARROW/"↪"/g' \ - -e 's/ARROW/"→"/g' \ - -e 's/BACKQUOTE/"`"/g' \ - -e 's/COMMA/","/g' \ - -e 's/SEMICOLON/";"/g' \ - -e 's/COLON/":"/g' \ - -e 's/EQUIV/"≡"/g' \ - -e 's/LAMBDA/"λ"/g' \ - -e 's/L_CU_BRACKET/"{"/g' \ - -e 's/L_PAREN/"("/g' \ - -e 's/L_SQ_BRACKET/"["/g' \ - -e 's/PI/"Π"/g' \ - -e 's/R_CU_BRACKET/"}"/g' \ - -e 's/R_PAREN/")"/g' \ - -e 's/R_SQ_BRACKET/"]"/g' \ - -e 's/TURNSTILE/"⊢"/g' \ - -e 's/VBAR/"|"/g' \ - -e 's/UNDERSCORE/"_"/g' \ - -e 's/UID_EXPL/"@" UID/g' \ - -e 's/UID_META/"?" UID/g' \ - -e 's/UID_PATT/"$$" UID/g' \ - -e 's/QID_EXPL/"@" QID/g' \ - -e 's/| EOF//g' \ - -e 's/"rule" /"rule" "off"/' \ - >> $@ diff --git a/doc/lambdapi.bnf b/doc/lambdapi.bnf index 950debeec..845bf45ba 100644 --- a/doc/lambdapi.bnf +++ b/doc/lambdapi.bnf @@ -1,6 +1,3 @@ -; DO NOT EDIT THIS FILE MANUALLY -; It is generated automatically with 'make bnf'. - QID ::= [UID "."]+ UID ::= "on" @@ -12,32 +9,20 @@ QID ::= [UID "."]+ UID ::= "assert" | "assertnot" - ::= EOF - - ::= EOF - - ::= EOF - - ::= EOF - ::= "opaque" ";" | "require" * ";" | "require" * ";" - | "require" "as" ";" + | "require" "as" UID ";" | * ";" - | * "symbol" * ":" [] - ";" - | * "symbol" * [":" ] "≔" - ";" - | [] * "inductive" ("with" - )* ";" + | * "symbol" UID * ":" [] ";" + | * "symbol" UID * [":" ] "≔" ";" + | [] * "inductive" ("with" )* ";" | "rule" ("with" )* ";" | "builtin" "≔" ";" | "coerce_rule" ";" | "unif_rule" ";" | "notation" ";" | ";" - ::= "open" | "private" "open" @@ -75,13 +60,11 @@ QID ::= [UID "."]+ UID ::= "private" | "protected" - ::= UID - ::= | "(" + ":" ")" | "[" + [":" ] "]" - ::= + ::= UID | "_" ::= @@ -92,7 +75,7 @@ QID ::= [UID "."]+ UID ::= "`" | "Π" | "λ" - | "let" * [":" ] "≔" "in" + | "let" UID * [":" ] "≔" "in" ::= + @@ -146,16 +129,16 @@ QID ::= [UID "."]+ UID | "change" | "eval" | "fail" - | "generalize" - | "have" ":" + | "generalize" UID + | "have" UID ":" | "induction" | "orelse" | "refine" | "reflexivity" - | "remove" + + | "remove" UID+ | "repeat" - | "rewrite" [] [] - | "set" "≔" + | "rewrite" [] [] + | "set" UID "≔" | "simplify" | "simplify" | "simplify" "rule" "off" @@ -164,23 +147,21 @@ QID ::= [UID "."]+ UID | "try" | "why3" [] - ::= + ::= | "in" - | "in" "in" + | "in" UID "in" | "in" ["in" ] - | "as" "in" + | "as" UID "in" - ::= "." "[" "]" + ::= "." "[" "]" - ::= * ":" "≔" ["|"] [ - ("|" )*] + ::= UID * ":" "≔" ["|"] [ ("|" )*] - ::= * ":" + ::= UID * ":" ::= "↪" - ::= "↪" "[" (";" - )* "]" + ::= "↪" "[" (";" )* "]" ::= "≡" @@ -192,9 +173,7 @@ QID ::= [UID "."]+ UID ::= | - ::= ["generalize"] - - ::= UID + ::= UID ["generalize"] ::= "type" | "rule" @@ -207,5 +186,3 @@ QID ::= [UID "."]+ UID ::= | "|" - - From b22d5bf569ac1993eb5587b89723dd218b31eec8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 28 Nov 2025 07:39:15 +0100 Subject: [PATCH 26/35] add dep on menhir for dk parser --- dune-project | 1 + lambdapi.opam | 1 + 2 files changed, 2 insertions(+) diff --git a/dune-project b/dune-project index ff963385d..1c777b972 100644 --- a/dune-project +++ b/dune-project @@ -31,6 +31,7 @@ systems: Dedukti, Coq, HRS, CPF.") (dream-pure (>= 1.0.0~alpha2)) (dream-httpaf (>= 1.0.0~alpha3)) (dream (>= 1.0.0~alpha6)) + (menhir (>= 20200624)) (sedlex (>= 3.2)) (alcotest :with-test) (alt-ergo :with-test) diff --git a/lambdapi.opam b/lambdapi.opam index 125f09117..ba734125a 100644 --- a/lambdapi.opam +++ b/lambdapi.opam @@ -25,6 +25,7 @@ depends: [ "dream-pure" {>= "1.0.0~alpha2"} "dream-httpaf" {>= "1.0.0~alpha3"} "dream" {>= "1.0.0~alpha6"} + "menhir" {>= "20200624"} "sedlex" {>= "3.2"} "alcotest" {with-test} "alt-ergo" {with-test} From a837fba9188d9b5166f6979bea2f40b90aee5ce8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 28 Nov 2025 07:50:42 +0100 Subject: [PATCH 27/35] detail --- src/parsing/lpParser.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/parsing/lpParser.ml b/src/parsing/lpParser.ml index 40142be67..c1220bb97 100644 --- a/src/parsing/lpParser.ml +++ b/src/parsing/lpParser.ml @@ -718,16 +718,16 @@ and query (lb:lexbuf): p_query = consume_token lb; let a = term lb in let pos2 = current_pos() in - let t = make_abst (fst pos1) ps t (snd pos2) in - let a = make_prod (fst pos1) ps a (snd pos2) 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 (fst pos1) ps t (snd pos2) in - let u = make_abst (fst pos1) ps u (snd pos2) 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))) | _ -> From 66d5d2f33c36b80f249fae43c31472bb02c4380b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 28 Nov 2025 07:56:21 +0100 Subject: [PATCH 28/35] detail --- 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 c1220bb97..c4395e143 100644 --- a/src/parsing/lpParser.ml +++ b/src/parsing/lpParser.ml @@ -362,7 +362,7 @@ let term_id (lb:lexbuf): p_term = (* commands *) -let rec command pos1 p_sym_mod (lb:lexbuf): p_command = +let rec command pos1 (p_sym_mod:p_modifier list) (lb:lexbuf): p_command = if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | SIDE _ From 877d04c79ecb21be5f52981990b042450d283e21 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 28 Nov 2025 13:53:57 +0100 Subject: [PATCH 29/35] wip --- src/parsing/dune | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/parsing/dune b/src/parsing/dune index 5205002bc..dbd73fc61 100644 --- a/src/parsing/dune +++ b/src/parsing/dune @@ -3,9 +3,11 @@ (public_name lambdapi.parsing) (modules :standard) (preprocess (pps sedlex.ppx)) - (libraries camlp-streams lambdapi.core pratter sedlex sedlex.ppx lambdapi.common) + (libraries camlp-streams lambdapi.core menhirLib pratter sedlex sedlex.ppx lambdapi.common) (flags -w +3)) +(menhir (flags --explain --external-tokens LpLexer) (modules lpParser)) + (ocamllex dkLexer) (menhir (flags --explain --external-tokens DkTokens) (modules dkParser)) From f4e9e9b75c14d4b933d192386aeef5073d66f92a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 28 Nov 2025 14:07:23 +0100 Subject: [PATCH 30/35] rename query data type into search --- src/parsing/dune | 2 -- src/parsing/lpParser.ml | 8 ++++---- src/parsing/parser.ml | 2 +- src/parsing/syntax.ml | 17 ++++++++--------- src/tool/indexing.mli | 2 +- 5 files changed, 14 insertions(+), 17 deletions(-) diff --git a/src/parsing/dune b/src/parsing/dune index dbd73fc61..1ac0824ba 100644 --- a/src/parsing/dune +++ b/src/parsing/dune @@ -6,8 +6,6 @@ (libraries camlp-streams lambdapi.core menhirLib pratter sedlex sedlex.ppx lambdapi.common) (flags -w +3)) -(menhir (flags --explain --external-tokens LpLexer) (modules lpParser)) - (ocamllex dkLexer) (menhir (flags --explain --external-tokens DkTokens) (modules dkParser)) diff --git a/src/parsing/lpParser.ml b/src/parsing/lpParser.ml index c4395e143..d400b6270 100644 --- a/src/parsing/lpParser.ml +++ b/src/parsing/lpParser.ml @@ -1530,7 +1530,7 @@ and where (lb:lexbuf): bool * inside option = | _ -> expected "\">\", \"=\", \"≥\",\">=\"" [] -and asearch (lb:lexbuf): query = +and asearch (lb:lexbuf): search = if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | TYPE_QUERY -> @@ -1582,7 +1582,7 @@ and asearch (lb:lexbuf): query = | _ -> expected "name, anywhere, rule, lhs, rhs, type, concl, hyp, spine" [] -and csearch (lb:lexbuf): query = +and csearch (lb:lexbuf): search = if log_enabled() then log "Expected: %s" __FUNCTION__; let aq = asearch lb in match current_token() with @@ -1592,7 +1592,7 @@ and csearch (lb:lexbuf): query = | _ -> aq -and ssearch (lb:lexbuf): query = +and ssearch (lb:lexbuf): search = if log_enabled() then log "Expected: %s" __FUNCTION__; let cq = csearch lb in match current_token() with @@ -1602,7 +1602,7 @@ and ssearch (lb:lexbuf): query = | _ -> cq -and search (lb:lexbuf): query = +and search (lb:lexbuf): search = if log_enabled() then log "Expected: %s" __FUNCTION__; let q = ssearch lb in let qids = list (prefix VBAR qid) lb in diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index 093866bf3..fa84de5bc 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -103,7 +103,7 @@ sig (** [parse_rwpatt_string f s] parses a rewrite pattern specification from string [s] assuming that [s] starts at position [p]. *) - val parse_search_query_string: Lexing.position -> string -> Syntax.query + val parse_search_query_string: Lexing.position -> string -> Syntax.search (** [parse_search_query_string f s] parses a query from string [s] assuming that [s] starts at position [p]. *) diff --git a/src/parsing/syntax.ml b/src/parsing/syntax.ml index 1a2e2ff59..6ea8a7410 100644 --- a/src/parsing/syntax.ml +++ b/src/parsing/syntax.ml @@ -214,9 +214,9 @@ type 'a where = | Conclusion of 'a | Hypothesis of 'a type constr = - | QType of (inside option) where option + | QType of inside option where option | QXhs of inside option * side option -type base_query = +type base_search = | QName of string | QSearch of p_term * (*generalize:*)bool * constr option type op = @@ -224,10 +224,10 @@ type op = | Union type filter = | Path of string -type query = - | QBase of base_query - | QOpp of query * op * query - | QFilter of query * filter +type search = + | QBase of base_search + | QOpp of search * op * search + | QFilter of search * filter (** Parser-level representation of a query command. *) type p_query_aux = @@ -251,9 +251,8 @@ type p_query_aux = (** Print information about a symbol or the current goals. *) | P_query_proofterm (** Print the current proof term (possibly containing open goals). *) - | P_query_search of query - (** Runs a search query *) (* I use a string here to be parsed later - to avoid polluting LambdaPi code with index and retrieval code *) + | P_query_search of search + (** Runs a search query *) type p_query = p_query_aux loc diff --git a/src/tool/indexing.mli b/src/tool/indexing.mli index cd37430cf..eb61bdedb 100644 --- a/src/tool/indexing.mli +++ b/src/tool/indexing.mli @@ -9,7 +9,7 @@ val dump : dbpath:string -> unit -> unit (* search command used by cli *) val search_cmd_txt: sig_state -> dbpath:string -> string -> string -val search_cmd_txt_query: sig_state -> dbpath:string -> query -> string +val search_cmd_txt_query: sig_state -> dbpath:string -> search -> string (* search command used by websearch *) val search_cmd_html: From b7e232dc0d5d5c2d3490da5ca434b6eeb06e457a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 28 Nov 2025 14:10:26 +0100 Subject: [PATCH 31/35] wip --- src/parsing/parser.ml | 14 +++++++------- src/tool/indexing.ml | 4 ++-- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index fa84de5bc..949117101 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -20,6 +20,10 @@ module type PARSER = sig type lexbuf + val parse_lexbuf : lexbuf -> ast + (** [parse_lexbuf lb] is the same as [parse_string] but with an already + created lexbuf. *) + val parse_in_channel : string -> in_channel -> ast (** [parse f ic] returns a stream of commands parsed from channel [ic] created from file [f]. Commands are parsed lazily and the channel is @@ -33,10 +37,6 @@ module type PARSER = sig (** [parse_string f s] returns a stream of parsed commands from string [s] which comes from file [f] ([f] can be anything). *) - val parse_lexbuf : lexbuf -> ast - (** [parse_lexbuf lb] is the same as [parse_string] but with an already - created lexbuf. *) - end (* defined in OCaml >= 4.11 only *) @@ -103,8 +103,8 @@ sig (** [parse_rwpatt_string f s] parses a rewrite pattern specification from string [s] assuming that [s] starts at position [p]. *) - val parse_search_query_string: Lexing.position -> string -> Syntax.search - (** [parse_search_query_string f s] parses a query from string [s] assuming + val parse_search_string: Lexing.position -> string -> Syntax.search + (** [parse_search_string f s] parses a query from string [s] assuming that [s] starts at position [p]. *) end @@ -148,7 +148,7 @@ sig (* exported functions *) let parse_term_string = parse_entry_string LpParser.term let parse_rwpatt_string = parse_entry_string LpParser.rwpatt - let parse_search_query_string = parse_entry_string LpParser.search + let parse_search_string = parse_entry_string LpParser.search let parse_in_channel = parse_in_channel LpParser.command let parse_file = parse_file LpParser.command diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index cce013a96..85c15273c 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -702,13 +702,13 @@ module UserLevelQueries = struct ~fail:(fun x -> "" ^ x ^ "") ~pp_results:(html_of_results_list from) ~tag:("

"," Date: Fri, 28 Nov 2025 15:22:52 +0100 Subject: [PATCH 32/35] wip --- CHANGES.md | 1 + src/parsing/lpParser.ml | 6 ++--- src/parsing/pretty.ml | 54 +++++++++++++++++++++++------------------ src/parsing/syntax.ml | 16 ++++++------ src/tool/indexing.ml | 38 ++++++++++++++--------------- 5 files changed, 61 insertions(+), 54 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index ef23a392c..45df48866 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -10,6 +10,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/). - `simplify` now fails if the goal cannot be simplified. - Hover messages are now formated in Markdown. Position of the error is removed from diagnostics when the error occurs in the file currently open in the editor. +- Change lp parser based on menhir by one written by hand to provide more helpful error messages while being equally efficient. ## 3.0.0 (2025-07-16) diff --git a/src/parsing/lpParser.ml b/src/parsing/lpParser.ml index d400b6270..767812d77 100644 --- a/src/parsing/lpParser.ml +++ b/src/parsing/lpParser.ml @@ -1508,7 +1508,7 @@ and binder (lb:lexbuf): p_params list * p_term = (* search *) -and where (lb:lexbuf): bool * inside option = +and where (lb:lexbuf): bool * relation option = if log_enabled() then log "Expected: %s" __FUNCTION__; match current_token() with | UID u -> @@ -1588,7 +1588,7 @@ and csearch (lb:lexbuf): search = match current_token() with | COMMA -> let aqs = list (prefix COMMA asearch) lb in - List.fold_left (fun x aq -> QOpp(x,Intersect,aq)) aq aqs + List.fold_left (fun x aq -> QOp(x,Intersect,aq)) aq aqs | _ -> aq @@ -1598,7 +1598,7 @@ and ssearch (lb:lexbuf): search = match current_token() with | SEMICOLON -> let cqs = list (prefix SEMICOLON csearch) lb in - List.fold_left (fun x cq -> QOpp(x,Union,cq)) cq cqs + List.fold_left (fun x cq -> QOp(x,Union,cq)) cq cqs | _ -> cq diff --git a/src/parsing/pretty.ml b/src/parsing/pretty.ml index 7e7b0212c..e50ad40a6 100644 --- a/src/parsing/pretty.ml +++ b/src/parsing/pretty.ml @@ -242,29 +242,35 @@ let assertion : p_assertion pp = fun ppf a -> | P_assert_typing (t, a) -> out ppf "@[%a@ : %a@]" term t term a | P_assert_conv (t, u) -> out ppf "@[%a@ ≡ %a@]" term t term u -module Search = struct - let inside ppf s = string ppf (match s with Exact -> " =" | Inside -> " >") - let where elt ppf = function - | Spine x -> out ppf "spine%a" elt x - | Conclusion x -> out ppf "concl%a" elt x - | Hypothesis x -> out ppf "hyp%a" elt x - let constr ppf = function - | QType x -> out ppf "type%a" (Option.pp (where (Option.pp inside))) x - | QXhs (i,None) -> out ppf "rule%a" (Option.pp inside) i - | QXhs(i,Some Lhs) -> out ppf "lhs%a" (Option.pp inside) i - | QXhs(i,Some Rhs) -> out ppf "rhs%a" (Option.pp inside) i - let generalize ppf b = if b then string ppf " generalize" - let base_query ppf = function - | QName s -> out ppf "name %s" s - | QSearch(t,g,None) -> out ppf "anywhere%a%a" generalize g term t - | QSearch(t,g,Some c) -> out ppf "%a%a%a" constr c generalize g term t - let op ppf o = string ppf (match o with Union -> "; " | Intersect -> ", ") - let filter ppf (Path s) = out ppf " | %s" s - let rec query ppf = function - | QBase b -> base_query ppf b - | QOpp(q1,o,q2) -> out ppf "%a%a%a" query q1 op o query q2 - | QFilter(q,f) -> out ppf "%a%a" query q filter f -end +let relation ppf s = string ppf (match s with Exact -> " =" | Inside -> " >") + +let where elt ppf = function + | Spine x -> out ppf "spine%a" elt x + | Conclusion x -> out ppf "concl%a" elt x + | Hypothesis x -> out ppf "hyp%a" elt x + +let search_constr ppf = function + | QType x -> out ppf "type%a" (Option.pp (where (Option.pp relation))) x + | QXhs(i,None) -> out ppf "rule%a" (Option.pp relation) i + | QXhs(i,Some Lhs) -> out ppf "lhs%a" (Option.pp relation) i + | QXhs(i,Some Rhs) -> out ppf "rhs%a" (Option.pp relation) i + +let generalize ppf b = if b then string ppf " generalize" + +let search_base ppf = function + | QName s -> out ppf "name %s" s + | QSearch(t,g,None) -> out ppf "anywhere%a%a" generalize g term t + | QSearch(t,g,Some c) -> + out ppf "%a%a%a" search_constr c generalize g term t + +let op ppf o = string ppf (match o with Union -> "; " | Intersect -> ", ") + +let filter ppf (Path s) = out ppf " | %s" s + +let rec search ppf = function + | QBase b -> search_base ppf b + | QOp(q1,o,q2) -> out ppf "%a%a%a" search q1 op o search q2 + | QFilter(q,f) -> out ppf "%a%a" search q filter f let query : p_query pp = fun ppf { elt; _ } -> match elt with @@ -283,7 +289,7 @@ let query : p_query pp = fun ppf { elt; _ } -> | P_query_print(Some qid) -> out ppf "print %a" qident qid | P_query_proofterm -> out ppf "proofterm" | P_query_verbose i -> out ppf "verbose %s" i - | P_query_search q -> out ppf "search %a" Search.query q + | P_query_search q -> out ppf "search %a" search q let rec tactic : p_tactic pp = fun ppf { elt; _ } -> begin match elt with diff --git a/src/parsing/syntax.ml b/src/parsing/syntax.ml index 6ea8a7410..f1601edd1 100644 --- a/src/parsing/syntax.ml +++ b/src/parsing/syntax.ml @@ -208,25 +208,25 @@ type p_assertion = (** Search queries. *) type side = Lhs | Rhs -type inside = Exact | Inside +type relation = Exact | Inside type 'a where = | Spine of 'a | Conclusion of 'a | Hypothesis of 'a -type constr = - | QType of inside option where option - | QXhs of inside option * side option -type base_search = +type search_constr = + | QType of relation option where option + | QXhs of relation option * side option +type search_base = | QName of string - | QSearch of p_term * (*generalize:*)bool * constr option + | QSearch of p_term * (*generalize:*)bool * search_constr option type op = | Intersect | Union type filter = | Path of string type search = - | QBase of base_search - | QOpp of search * op * search + | QBase of search_base + | QOp of search * op * search | QFilter of search * filter (** Parser-level representation of a query command. *) diff --git a/src/tool/indexing.ml b/src/tool/indexing.ml index 85c15273c..0ea53c853 100644 --- a/src/tool/indexing.ml +++ b/src/tool/indexing.ml @@ -192,37 +192,37 @@ module DB = struct type side = Parsing.Syntax.side = Lhs | Rhs - type inside = Parsing.Syntax.inside = Exact | Inside + type relation = Parsing.Syntax.relation = Exact | Inside - type 'inside where = 'inside Parsing.Syntax.where = - | Spine of 'inside - | Conclusion of 'inside - | Hypothesis of 'inside - (* the "name" in the sym_name of rules is just the printed position of - the rule; the associated position is never None *) + type 'relation where = 'relation Parsing.Syntax.where = + | Spine of 'relation + | Conclusion of 'relation + | Hypothesis of 'relation type position = | Name - | Type of inside where - | Xhs of inside * side + | Type of relation where + | Xhs of relation * side type item = sym_name * Common.Pos.pos option + (* the "name" in the sym_name of rules is just the printed position of + the rule; the associated position is never None *) let pp_side fmt = function | Lhs -> Lplib.Base.out fmt "lhs" | Rhs -> Lplib.Base.out fmt "rhs" - let pp_inside fmt = + let pp_relation fmt = function | Exact -> Lplib.Base.out fmt "as the exact" | Inside -> Lplib.Base.out fmt "inside the" let pp_where fmt = function - | Spine ins -> Lplib.Base.out fmt "%a spine of" pp_inside ins - | Hypothesis ins -> Lplib.Base.out fmt "%a hypothesis of" pp_inside ins - | Conclusion ins -> Lplib.Base.out fmt "%a conclusion of" pp_inside ins + | Spine ins -> Lplib.Base.out fmt "%a spine of" pp_relation ins + | Hypothesis ins -> Lplib.Base.out fmt "%a hypothesis of" pp_relation ins + | Conclusion ins -> Lplib.Base.out fmt "%a conclusion of" pp_relation ins module ItemSet = struct @@ -263,11 +263,11 @@ module DB = struct (escaper.run Print.term) term (if generalize then "generalized " else "") pp_where where - | generalize,term,Xhs (inside,side) -> + | generalize,term,Xhs (relation,side) -> Lplib.Base.out ppf "%a occurs %s %a %a" (escaper.run Print.term) term (if generalize then "generalized" else "") - pp_inside inside pp_side side)) + pp_relation relation pp_side side)) sep let generic_pp_of_item_list ~escape ~escaper ~separator ~sep ~delimiters @@ -528,14 +528,14 @@ let index_rule sym ({Core.Term.lhs=lhsargs ; rule_pos ; _} as rule) = | Some pos -> pos in let lhs = Core.Term.add_args (Core.Term.mk_Symb sym) lhsargs in let rhs = rule.rhs in - let get_inside = function | DB.Conclusion ins -> ins | _ -> assert false in + let get_relation = function | DB.Conclusion r -> r | _ -> assert false in let filename = Option.get rule_pos.fname 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 - (fun where -> ((rule_name,Some rule_pos),[Xhs(get_inside where,Lhs)])) ; + (fun where -> ((rule_name,Some rule_pos),[Xhs(get_relation where,Lhs)])) ; index_term_and_subterms ~is_spine:false rhs - (fun where -> ((rule_name,Some rule_pos),[Xhs(get_inside where,Rhs)])) + (fun where -> ((rule_name,Some rule_pos),[Xhs(get_relation where,Rhs)])) let index_sym sym = let qname = name_of_sym sym in @@ -637,7 +637,7 @@ module QueryLanguage = struct let rec aux = function | QBase bq -> answer_base_query ~mok ss env bq - | QOpp (q1,op,q2) -> perform_op op (aux q1) (aux q2) + | QOp (q1,op,q2) -> perform_op op (aux q1) (aux q2) | QFilter (q,f) -> filter (aux q) f in aux From 61856bd89ce4523d9059a434297675b7111ed13a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 28 Nov 2025 16:03:15 +0100 Subject: [PATCH 33/35] wip --- src/parsing/lpParser.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/parsing/lpParser.ml b/src/parsing/lpParser.ml index 767812d77..d101ce6e2 100644 --- a/src/parsing/lpParser.ml +++ b/src/parsing/lpParser.ml @@ -1536,25 +1536,25 @@ and asearch (lb:lexbuf): search = | TYPE_QUERY -> consume_token lb; let g, w = where lb in - let t = aterm lb in if w <> None then expected "\"≥\", \">=\"" [] - else QBase(QSearch(t,g,Some(QType None))) + else QBase(QSearch(aterm lb,g,Some(QType None))) | RULE -> consume_token lb; let g, w = where lb in - let t = aterm lb in - QBase(QSearch(t,g,Some(QXhs(w,None)))) + QBase(QSearch(aterm lb,g,Some(QXhs(w,None)))) | UID k -> consume_token lb; let g, w = where lb in + let posw = current_pos() in let t = aterm lb in begin match k, t.elt with | "name", P_Iden(id,false) -> - assert (fst id.elt = []); - if w <> Some Exact then expected "\"=\"" [] + if fst id.elt <> [] then expected "" [UID""] + else if w <> Some Exact then + syntax_error posw "Only \"=\" is accepted after \"name\"" else if g then - expected "\"generalize\" cannot be used with \"name\"" [] + syntax_error posw "\"generalize\" cannot be used with \"name\"" else QBase(QName(snd id.elt)) | "name", _ -> expected "path prefix" [] From 5d1499c1ae3d4f1c700bc1332fb67f2445df4f3a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 28 Nov 2025 18:08:43 +0100 Subject: [PATCH 34/35] improve code for parsing search queries --- doc/lambdapi.bnf | 10 +- src/parsing/lpParser.ml | 222 +++++++++++++++++++++------------------- 2 files changed, 123 insertions(+), 109 deletions(-) diff --git a/doc/lambdapi.bnf b/doc/lambdapi.bnf index 845bf45ba..f5e5024b2 100644 --- a/doc/lambdapi.bnf +++ b/doc/lambdapi.bnf @@ -173,11 +173,13 @@ QID ::= [UID "."]+ UID ::= | - ::= UID ["generalize"] + ::= "=" | ">" | ">=" | "≥" - ::= "type" - | "rule" - | UID + ::= "concl" | "hyp" | "spine" | "rule" | "lhs" | "rhs" + + ::= "name" "=" UID + | ("type"|"anywhere") ("≥"|">=") ["generalize"] + | ["generalize"] | "(" ")" ::= ("," )* diff --git a/src/parsing/lpParser.ml b/src/parsing/lpParser.ml index d101ce6e2..5f18081b3 100644 --- a/src/parsing/lpParser.ml +++ b/src/parsing/lpParser.ml @@ -114,14 +114,7 @@ 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,_p1,_p2) = !the_current_token in - (*begin - if log_enabled() then - let p = locate (p1,p2) in - log "current token [%a]: \"%a\"" Pos.short (Some p) pp_token t - end;*) - t +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) @@ -182,18 +175,18 @@ let make_prod (pos1:position) (ps:p_params list) (t:p_term) (pos2:position) let ident_of_term pos1 {elt; _} = match elt with | P_Iden({elt=([], x); pos}, _) -> Pos.make pos x - | _ -> LpLexer.syntax_error pos1 "not an identifier." + | _ -> 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 "Expected: %s" __FUNCTION__; + 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 "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; let x = elt lb in x :: list elt lb @@ -242,7 +235,7 @@ let consume_DEBUG_FLAGS (lb:lexbuf): bool * string = expected "" [DEBUG_FLAGS(true,"")] let qid (lb:lexbuf): (string list * string) loc = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | UID s -> let pos1 = current_pos() in @@ -256,7 +249,7 @@ let qid (lb:lexbuf): (string list * string) loc = expected "" [UID"";QID[]] let qid_expl (lb:lexbuf): (string list * string) loc = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | UID_EXPL s -> let pos1 = current_pos() in @@ -270,7 +263,7 @@ let qid_expl (lb:lexbuf): (string list * string) loc = expected "" [UID_EXPL"";QID_EXPL[]] let uid (lb:lexbuf): string loc = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | UID s -> let pos1 = current_pos() in @@ -280,7 +273,7 @@ let uid (lb:lexbuf): string loc = expected "" [UID""] let param (lb:lexbuf): string loc option = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | UID s -> let pos1 = current_pos() in @@ -293,7 +286,7 @@ let param (lb:lexbuf): string loc option = expected "non-qualified identifier or \"_\"" [UID"";UNDERSCORE] let int (lb:lexbuf): string = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | INT s -> consume_token lb; @@ -302,7 +295,7 @@ let int (lb:lexbuf): string = expected "integer" [INT""] let float_or_int (lb:lexbuf): string = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | INT s | FLOAT s -> @@ -312,7 +305,7 @@ let float_or_int (lb:lexbuf): string = expected "integer or float" [INT"";FLOAT""] let path (lb:lexbuf): string list loc = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with (*| UID s -> let pos1 = current_pos() in @@ -325,7 +318,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 "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | UID s -> let pos1 = current_pos() in @@ -347,7 +340,7 @@ let qid_or_rule (lb:lexbuf): (string list * string) loc = expected "" [UID"";QID[];UNIF_RULE;COERCE_RULE] let term_id (lb:lexbuf): p_term = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | UID _ | QID _ -> @@ -363,7 +356,7 @@ 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 "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | SIDE _ | ASSOCIATIVE @@ -602,7 +595,7 @@ and constructor (lb:lexbuf): p_ident * p_term = i, make_prod (fst pos1) ps t (snd (current_pos())) and modifier (lb:lexbuf): p_modifier = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | SIDE d -> let pos1 = current_pos() in @@ -644,7 +637,7 @@ and modifier (lb:lexbuf): p_modifier = exposition lb and exposition (lb:lexbuf): p_modifier = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | PRIVATE -> let pos1 = current_pos() in @@ -658,7 +651,7 @@ and exposition (lb:lexbuf): p_modifier = expected "" [PRIVATE;PROTECTED] and notation (lb:lexbuf): string Term.notation = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | INFIX -> consume_token lb; @@ -687,7 +680,7 @@ and notation (lb:lexbuf): string Term.notation = expected "" [INFIX;POSTFIX;PREFIX;QUANTIFIER] and rule (lb:lexbuf): (p_term * p_term) loc = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; let pos1 = current_pos() in let l = term lb in consume HOOK_ARROW lb; @@ -695,7 +688,7 @@ and rule (lb:lexbuf): (p_term * p_term) loc = extend_pos (*__FUNCTION__*) pos1 (l, r) and equation (lb:lexbuf): p_term * p_term = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; let l = term lb in consume EQUIV lb; let r = term lb in @@ -704,7 +697,7 @@ and equation (lb:lexbuf): p_term * p_term = (* queries *) and query (lb:lexbuf): p_query = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | ASSERT b -> let pos1 = current_pos() in @@ -801,7 +794,7 @@ and query (lb:lexbuf): p_query = expected "query" [] and term_proof (lb:lexbuf): p_term option * (p_proof * p_proof_end) option = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | BEGIN -> consume_token lb; @@ -822,7 +815,7 @@ and term_proof (lb:lexbuf): p_term option * (p_proof * p_proof_end) option = (* proofs *) and proof (lb:lexbuf): p_proof * p_proof_end = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | L_CU_BRACKET -> let l = nelist subproof lb in @@ -875,7 +868,7 @@ and proof (lb:lexbuf): p_proof * p_proof_end = expected "subproof, tactic or query" [] and subproof (lb:lexbuf): p_proofstep list = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | L_CU_BRACKET -> consume_token lb; @@ -886,7 +879,7 @@ and subproof (lb:lexbuf): p_proofstep list = expected "" [L_CU_BRACKET] and steps (lb:lexbuf): p_proofstep list = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with (*queries*) | ASSERT _ @@ -934,13 +927,13 @@ and steps (lb:lexbuf): p_proofstep list = expected "tactic or query" [] and step (lb:lexbuf): p_proofstep = - if log_enabled() then log "Expected: %s" __FUNCTION__; + 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 "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | ABORT -> let pos1 = current_pos() in @@ -958,7 +951,7 @@ and proof_end (lb:lexbuf): p_proof_end = expected "" [ABORT;ADMITTED;END] and tactic (lb:lexbuf): p_tactic = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with (*queries*) | ASSERT _ @@ -1126,7 +1119,7 @@ and tactic (lb:lexbuf): p_tactic = expected "tactic" [] and rwpatt_content (lb:lexbuf): p_rwpatt = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with (* bterm *) | BACKQUOTE @@ -1200,7 +1193,7 @@ and rwpatt_content (lb:lexbuf): p_rwpatt = expected "term or keyword \"in\"" [] and rwpatt_bracket (lb:lexbuf): p_rwpatt = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | L_SQ_BRACKET -> consume_token lb; @@ -1211,7 +1204,7 @@ and rwpatt_bracket (lb:lexbuf): p_rwpatt = expected "" [L_SQ_BRACKET] and rwpatt (lb:lexbuf): p_rwpatt = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | DOT -> consume_token lb; @@ -1222,7 +1215,7 @@ and rwpatt (lb:lexbuf): p_rwpatt = (* terms *) and params (lb:lexbuf): p_params = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | L_PAREN -> consume_token lb; @@ -1261,7 +1254,7 @@ and params (lb:lexbuf): p_params = [x], None, false and term (lb:lexbuf): p_term = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with (* bterm *) | BACKQUOTE @@ -1289,7 +1282,7 @@ and term (lb:lexbuf): p_term = expected "term" [] and app (pos1:position * position) (t: p_term) (lb:lexbuf): p_term = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with (* aterm *) | UID _ @@ -1322,7 +1315,7 @@ and app (pos1:position * position) (t: p_term) (lb:lexbuf): p_term = t and bterm (lb:lexbuf): p_term = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | BACKQUOTE -> let pos1 = current_pos() in @@ -1368,7 +1361,7 @@ and bterm (lb:lexbuf): p_term = expected "" [BACKQUOTE;PI;LAMBDA;LET] and aterm (lb:lexbuf): p_term = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | UID _ | QID _ @@ -1435,7 +1428,7 @@ and aterm (lb:lexbuf): p_term = brackets" [] and env (lb:lexbuf): p_term list = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | L_SQ_BRACKET -> consume_token lb; @@ -1454,7 +1447,7 @@ and env (lb:lexbuf): p_term list = expected "" [L_SQ_BRACKET] and binder (lb:lexbuf): p_params list * p_term = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; match current_token() with | UID _ | UNDERSCORE -> @@ -1508,72 +1501,91 @@ and binder (lb:lexbuf): p_params list * p_term = (* search *) -and where (lb:lexbuf): bool * relation option = - if log_enabled() then log "Expected: %s" __FUNCTION__; +and generalize (lb:lexbuf): bool = + if log_enabled() then log "%s" __FUNCTION__; match current_token() with - | UID u -> - let r = - match u with - | "=" -> Some Exact - | ">" -> Some Inside - | "≥" - | ">=" -> None - | _ -> expected "\">\", \"=\", \"≥\",\">=\"" [] - in - consume_token lb; - let g = - match current_token() with - | GENERALIZE -> consume_token lb; true - | _ -> false - in - g,r - | _ -> - expected "\">\", \"=\", \"≥\",\">=\"" [] + | 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 "Expected: %s" __FUNCTION__; + 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 -> - consume_token lb; - let g, w = where lb in - if w <> None then expected "\"≥\", \">=\"" [] - else QBase(QSearch(aterm lb,g,Some(QType None))) + begin + consume_token lb; + match current_token() with + | UID ("≥"|">=") -> + consume_token lb; + let g = generalize lb in + let t = aterm 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 = aterm lb in + QBase(QSearch(t,g,None)) + | _ -> expected "\"≥\",\">=\"" [] + end | RULE -> consume_token lb; - let g, w = where lb in - QBase(QSearch(aterm lb,g,Some(QXhs(w,None)))) - | UID k -> - consume_token lb; - let g, w = where lb in - let posw = current_pos() in + let r = relation lb in + let g = generalize lb in let t = aterm lb in - begin - match k, t.elt with - | "name", P_Iden(id,false) -> - if fst id.elt <> [] then expected "" [UID""] - else if w <> Some Exact then - syntax_error posw "Only \"=\" is accepted after \"name\"" - else if g then - syntax_error posw "\"generalize\" cannot be used with \"name\"" - else QBase(QName(snd id.elt)) - | "name", _ -> - expected "path prefix" [] - | "anywhere", _ -> - if w <> None then expected "\"≥\", \">=\"" [] - 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)))) - | _ -> - expected "Unknown keyword" [] - end + QBase(QSearch(t,g,Some(QXhs(r,None)))) + | UID "spine" -> + let r = relation lb in + let g = generalize lb in + let t = aterm lb in + QBase(QSearch(t,g,Some(QType(Some(Spine r))))) + | UID "concl" -> + let r = relation lb in + let g = generalize lb in + let t = aterm lb in + QBase(QSearch(t,g,Some(QType(Some(Conclusion r))))) + | UID "hyp" -> + let r = relation lb in + let g = generalize lb in + let t = aterm lb in + QBase(QSearch(t,g,Some(QType(Some(Hypothesis r))))) + | UID "lhs" -> + let r = relation lb in + let g = generalize lb in + let t = aterm lb in + QBase(QSearch(t,g,Some(QXhs(r,Some Lhs)))) + | UID "rhs" -> + let r = relation lb in + let g = generalize lb in + let t = aterm lb in + QBase(QSearch(t,g,Some(QXhs(r,Some Rhs)))) | L_PAREN -> consume_token lb; let q = search lb in @@ -1583,7 +1595,7 @@ and asearch (lb:lexbuf): search = expected "name, anywhere, rule, lhs, rhs, type, concl, hyp, spine" [] and csearch (lb:lexbuf): search = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; let aq = asearch lb in match current_token() with | COMMA -> @@ -1593,7 +1605,7 @@ and csearch (lb:lexbuf): search = aq and ssearch (lb:lexbuf): search = - if log_enabled() then log "Expected: %s" __FUNCTION__; + if log_enabled() then log "%s" __FUNCTION__; let cq = csearch lb in match current_token() with | SEMICOLON -> @@ -1603,7 +1615,7 @@ and ssearch (lb:lexbuf): search = cq and search (lb:lexbuf): search = - if log_enabled() then log "Expected: %s" __FUNCTION__; + 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 = From 5ba326e98829d33bbceb5d3b1b1424cbf4d6a1cc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Fri, 28 Nov 2025 18:36:16 +0100 Subject: [PATCH 35/35] fix bnf file --- doc/lambdapi.bnf | 92 ++++++++++++++++++------------------------------ 1 file changed, 35 insertions(+), 57 deletions(-) diff --git a/doc/lambdapi.bnf b/doc/lambdapi.bnf index f5e5024b2..92329d0c4 100644 --- a/doc/lambdapi.bnf +++ b/doc/lambdapi.bnf @@ -1,36 +1,32 @@ -QID ::= [UID "."]+ UID + ::= [ "."]+ - ::= "on" - | "off" + ::= | - ::= "left" - | "right" + ::= "on" | "off" + + ::= "left" | "right" ::= "assert" | "assertnot" ::= "opaque" ";" - | "require" * ";" - | "require" * ";" - | "require" "as" UID ";" - | * ";" - | * "symbol" UID * ":" [] ";" - | * "symbol" UID * [":" ] "≔" ";" + | "require" * ";" + | "require" [["private"] "open"] * ";" + | "require" "as" ";" + | ["private"] "open" * ";" + | * "symbol" * ":" [] ";" + | * "symbol" * [":" ] "≔" ";" | [] * "inductive" ("with" )* ";" | "rule" ("with" )* ";" - | "builtin" "≔" ";" + | "builtin" "≔" ";" | "coerce_rule" ";" | "unif_rule" ";" - | "notation" ";" + | "notation" ";" | ";" - ::= "open" - | "private" "open" - - ::= * "⊢" ":" - | * "⊢" "≡" + ::= * "⊢" (":"|"≡") | "compute" - | "print" [] + | "print" [ | "unif_rule" | "coerce_rule"] | "proofterm" | "debug" | "debug" ("+"|"-") + @@ -42,30 +38,20 @@ QID ::= [UID "."]+ UID | "type" | "search" - ::= - | "unif_rule" - | "coerce_rule" - - ::= UID - | QID - ::= [] "associative" | "commutative" | "constant" | "injective" | "opaque" | "sequential" - | - - ::= "private" - | "protected" + | "private" + | "protected" ::= | "(" + ":" ")" | "[" + [":" ] "]" - ::= UID - | "_" + ::= | "_" ::= | @@ -75,30 +61,23 @@ QID ::= [UID "."]+ UID ::= "`" | "Π" | "λ" - | "let" UID * [":" ] "≔" "in" + | "let" * [":" ] "≔" "in" ::= + ::= | "_" | "TYPE" - | "?" UID [] - | "$" UID [] + | "?" [] + | "$" [] | "(" ")" | "[" "]" | | - ::= "." "[" [ (";" )*] "]" - - ::= - | + ::= ["@"] - ::= UID - | QID - - ::= "@" UID - | "@" QID + ::= "." "[" [ (";" )*] "]" ::= + "," | ":" "," @@ -129,18 +108,18 @@ QID ::= [UID "."]+ UID | "change" | "eval" | "fail" - | "generalize" UID - | "have" UID ":" + | "generalize" + | "have" ":" | "induction" | "orelse" | "refine" | "reflexivity" - | "remove" UID+ + | "remove" + | "repeat" | "rewrite" [] [] - | "set" UID "≔" + | "set" "≔" | "simplify" - | "simplify" + | "simplify" | "simplify" "rule" "off" | "solve" | "symmetry" @@ -149,15 +128,15 @@ QID ::= [UID "."]+ UID ::= | "in" - | "in" UID "in" + | "in" "in" | "in" ["in" ] - | "as" UID "in" + | "as" "in" ::= "." "[" "]" - ::= UID * ":" "≔" ["|"] [ ("|" )*] + ::= * ":" "≔" ["|"] [ ("|" )*] - ::= UID * ":" + ::= * ":" ::= "↪" @@ -170,14 +149,13 @@ QID ::= [UID "."]+ UID | "prefix" | "quantifier" - ::= - | + ::= | ::= "=" | ">" | ">=" | "≥" ::= "concl" | "hyp" | "spine" | "rule" | "lhs" | "rhs" - ::= "name" "=" UID + ::= "name" "=" | ("type"|"anywhere") ("≥"|">=") ["generalize"] | ["generalize"] | "(" ")" @@ -187,4 +165,4 @@ QID ::= [UID "."]+ UID ::= (";" )* ::= - | "|" + | "|"