From bc63b1ec878026a34db4e932e19ed0833c180072 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Thu, 23 Apr 2020 15:54:22 +0200 Subject: [PATCH 1/4] Kernel: remove dead code --- src/kernel/mreader_parser.ml | 63 ++++++++---------------------------- 1 file changed, 14 insertions(+), 49 deletions(-) diff --git a/src/kernel/mreader_parser.ml b/src/kernel/mreader_parser.ml index f05ec067e6..e59cb88393 100644 --- a/src/kernel/mreader_parser.ml +++ b/src/kernel/mreader_parser.ml @@ -67,24 +67,16 @@ type tree = [ | `Implementation of Parsetree.structure ] -type steps =[ - | `Signature of (Parsetree.signature step * Mreader_lexer.triple) list - | `Structure of (Parsetree.structure step * Mreader_lexer.triple) list -] - type t = { - kind: kind; tree: tree; - steps: steps; errors: exn list; - lexer: Mreader_lexer.t; } let eof_token = (Parser_raw.EOF, Lexing.dummy_pos, Lexing.dummy_pos) let errors_ref = ref [] -let resume_parse = +let parse = let rec normal acc tokens = function | I.InputNeeded env as checkpoint -> let token, tokens = match tokens with @@ -153,58 +145,31 @@ let resume_parse = | `Ok (checkpoint, _) -> normal ((Correct checkpoint, token) :: acc) tokens checkpoint in - fun acc tokens -> function - | Correct checkpoint -> normal acc tokens checkpoint - | Recovering candidates -> recover acc tokens candidates - -let seek_step steps tokens = - let rec aux acc = function - | (step :: steps), (token :: tokens) when snd step = token -> - aux (step :: acc) (steps, tokens) - | _, tokens -> acc, tokens - in - aux [] (steps, tokens) - -let parse initial steps tokens initial_pos = - let acc, tokens = seek_step steps tokens in - let step = - match acc with - | (step, _) :: _ -> step - | [] -> Correct (initial initial_pos) - in - let acc, result = resume_parse acc tokens step in - List.rev acc, result + fun initial tokens -> + snd (normal [] tokens initial) -let run_parser warnings lexer previous kind = +let run_parser warnings lexer kind = Msupport.catch_errors warnings errors_ref @@ fun () -> let tokens = Mreader_lexer.tokens lexer in let initial_pos = Mreader_lexer.initial_position lexer in match kind with | ML -> - let steps = match previous with - | `Structure steps -> steps - | _ -> [] - in - let steps, result = - let state = Parser_raw.Incremental.implementation in - parse state steps tokens initial_pos in - `Structure steps, `Implementation result + let result = + let state = Parser_raw.Incremental.implementation initial_pos in + parse state tokens in + `Implementation result | MLI -> - let steps = match previous with - | `Signature steps -> steps - | _ -> [] - in - let steps, result = - let state = Parser_raw.Incremental.interface in - parse state steps tokens initial_pos in - `Signature steps, `Interface result + let result = + let state = Parser_raw.Incremental.interface initial_pos in + parse state tokens in + `Interface result let make warnings lexer kind = errors_ref := []; - let steps, tree = run_parser warnings lexer `None kind in + let tree = run_parser warnings lexer kind in let errors = !errors_ref in errors_ref := []; - {kind; steps; tree; errors; lexer} + {tree; errors} let result t = t.tree From 0887fbabf7638ab6ce3b01362d9d847fba45cea4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Thu, 23 Apr 2020 16:16:17 +0200 Subject: [PATCH 2/4] Kernel/Mreader: don't fail on toplevel directives when using `#!` --- src/kernel/mreader.ml | 17 ++++++++++++++++- src/kernel/mreader_parser.ml | 17 +++++++++-------- src/kernel/mreader_parser.mli | 2 ++ 3 files changed, 27 insertions(+), 9 deletions(-) diff --git a/src/kernel/mreader.ml b/src/kernel/mreader.ml index fe51deaeb2..8b10ad72ae 100644 --- a/src/kernel/mreader.ml +++ b/src/kernel/mreader.ml @@ -16,6 +16,12 @@ type result = { no_labels_for_completion : bool; } +let rec process_directives acc = function + | [] -> List.rev acc + | Parsetree.Ptop_dir _ :: phrases -> process_directives acc phrases + | Parsetree.Ptop_def items :: phrases -> + process_directives (List.rev_append items acc) phrases + (* Normal entry point *) let normal_parse ?for_completion config source = @@ -28,7 +34,9 @@ let normal_parse ?for_completion config source = in Logger.log ~section:"Mreader" ~title:"run" "extension(%S) = %S" filename extension; - if List.exists ~f:(fun (_impl,intf) -> intf = extension) + if String.is_prefixed ~by:"#!" (Msource.text source) + then Mreader_parser.SCRIPT + else if List.exists ~f:(fun (_impl,intf) -> intf = extension) Mconfig.(config.merlin.suffixes) then Mreader_parser.MLI else Mreader_parser.ML @@ -52,6 +60,13 @@ let normal_parse ?for_completion config source = and parsetree = Mreader_parser.result parser and comments = Mreader_lexer.comments lexer in + let parsetree = + match parsetree with + | `Script phrases -> + `Implementation (process_directives [] phrases) + | `Implementation x -> `Implementation x + | `Interface x -> `Interface x + in { config; lexer_errors; parser_errors; comments; parsetree; no_labels_for_completion; } diff --git a/src/kernel/mreader_parser.ml b/src/kernel/mreader_parser.ml index e59cb88393..6823161307 100644 --- a/src/kernel/mreader_parser.ml +++ b/src/kernel/mreader_parser.ml @@ -33,6 +33,7 @@ module I = Parser_raw.MenhirInterpreter type kind = | ML | MLI + | SCRIPT (*| MLL | MLY*) module Dump = struct @@ -65,6 +66,7 @@ type 'a step = type tree = [ | `Interface of Parsetree.signature | `Implementation of Parsetree.structure + | `Script of Parsetree.toplevel_phrase list ] type t = { @@ -154,15 +156,14 @@ let run_parser warnings lexer kind = let initial_pos = Mreader_lexer.initial_position lexer in match kind with | ML -> - let result = - let state = Parser_raw.Incremental.implementation initial_pos in - parse state tokens in - `Implementation result + let state = Parser_raw.Incremental.implementation initial_pos in + `Implementation (parse state tokens) | MLI -> - let result = - let state = Parser_raw.Incremental.interface initial_pos in - parse state tokens in - `Interface result + let state = Parser_raw.Incremental.interface initial_pos in + `Interface (parse state tokens) + | SCRIPT -> + let state = Parser_raw.Incremental.use_file initial_pos in + `Script (parse state tokens) let make warnings lexer kind = errors_ref := []; diff --git a/src/kernel/mreader_parser.mli b/src/kernel/mreader_parser.mli index d2b9ebff0b..e00b89caf0 100644 --- a/src/kernel/mreader_parser.mli +++ b/src/kernel/mreader_parser.mli @@ -29,6 +29,7 @@ type kind = | ML | MLI + | SCRIPT (*| MLL | MLY*) type t @@ -38,6 +39,7 @@ val make : Warnings.state -> Mreader_lexer.t -> kind -> t type tree = [ | `Interface of Parsetree.signature | `Implementation of Parsetree.structure + | `Script of Parsetree.toplevel_phrase list ] val result : t -> tree From 48ced2ad0ec650eaa22ae527fcae9337cc99cbda Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Thu, 23 Apr 2020 16:38:34 +0200 Subject: [PATCH 3/4] Kernel/Mreader: process `#require` in scripts --- src/kernel/mreader.ml | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/src/kernel/mreader.ml b/src/kernel/mreader.ml index 8b10ad72ae..0c63aa28ad 100644 --- a/src/kernel/mreader.ml +++ b/src/kernel/mreader.ml @@ -16,11 +16,21 @@ type result = { no_labels_for_completion : bool; } -let rec process_directives acc = function - | [] -> List.rev acc - | Parsetree.Ptop_dir _ :: phrases -> process_directives acc phrases +let rec process_directives config acc = function + | [] -> (config, List.rev acc) + | Parsetree.Ptop_dir + { pdir_name = { txt = "require"; _ }; + pdir_arg = Some { pdira_desc = (Pdir_string package); _ }; + _ } :: phrases -> + let open Mconfig in + let merlin = { + config.merlin with + packages_to_load = package :: config.merlin.packages_to_load} in + process_directives {config with merlin} acc phrases + | Parsetree.Ptop_dir _ :: phrases -> + process_directives config acc phrases | Parsetree.Ptop_def items :: phrases -> - process_directives (List.rev_append items acc) phrases + process_directives config (List.rev_append items acc) phrases (* Normal entry point *) @@ -60,12 +70,15 @@ let normal_parse ?for_completion config source = and parsetree = Mreader_parser.result parser and comments = Mreader_lexer.comments lexer in - let parsetree = + let config, parsetree = match parsetree with | `Script phrases -> - `Implementation (process_directives [] phrases) - | `Implementation x -> `Implementation x - | `Interface x -> `Interface x + let config, parsetree = process_directives config [] phrases in + config, `Implementation parsetree + | `Implementation parsetree -> + config, `Implementation parsetree + | `Interface parsetree -> + config, `Interface parsetree in { config; lexer_errors; parser_errors; comments; parsetree; no_labels_for_completion; } From 863a54e4e27955014ef977d0d70e7f2bc0fddafb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Thu, 23 Apr 2020 17:32:56 +0200 Subject: [PATCH 4/4] WIP/RFC: Mreader: process `#use` and `#mod_use` --- src/kernel/mreader.ml | 116 +++++++++++++++++++++++++++++++----------- 1 file changed, 86 insertions(+), 30 deletions(-) diff --git a/src/kernel/mreader.ml b/src/kernel/mreader.ml index 0c63aa28ad..4acbae308c 100644 --- a/src/kernel/mreader.ml +++ b/src/kernel/mreader.ml @@ -16,25 +16,79 @@ type result = { no_labels_for_completion : bool; } -let rec process_directives config acc = function - | [] -> (config, List.rev acc) - | Parsetree.Ptop_dir - { pdir_name = { txt = "require"; _ }; - pdir_arg = Some { pdira_desc = (Pdir_string package); _ }; - _ } :: phrases -> - let open Mconfig in - let merlin = { - config.merlin with - packages_to_load = package :: config.merlin.packages_to_load} in - process_directives {config with merlin} acc phrases - | Parsetree.Ptop_dir _ :: phrases -> - process_directives config acc phrases - | Parsetree.Ptop_def items :: phrases -> - process_directives config (List.rev_append items acc) phrases +let rec process_directives + config lexer_errors parser_errors comments no_labels_for_completion + phrases = + let rec process config acc = function + | [] -> + let parsetree = `Implementation (List.rev acc) in + { config; lexer_errors; parser_errors; comments; parsetree; + no_labels_for_completion; } + | Parsetree.Ptop_dir + { pdir_name = { txt = "require"; _ }; + pdir_arg = Some { pdira_desc = (Pdir_string package); _ }; + _ } :: phrases -> + let open Mconfig in + let merlin = { + config.merlin with + packages_to_load = package :: config.merlin.packages_to_load} in + process {config with merlin} acc phrases + | Parsetree.Ptop_dir + { pdir_name = { txt = "use"; _ }; + pdir_arg = Some { pdira_desc = (Pdir_string "topfind"); _ }; + _ } :: phrases -> + process config acc phrases + | Parsetree.Ptop_dir + { pdir_name = { txt = "use"; _ }; + pdir_arg = Some { pdira_desc = (Pdir_string file); _ }; + _ } :: phrases -> begin + (* TODO check suffix for implementation *) + (* TODO lookup for file in some "configured" paths. Which one ?? *) + let in_channel = open_in file in + let source = Msource.make (Misc.string_of_file in_channel) in + close_in in_channel; + let u = normal_parse config source in + match u.parsetree with + | `Implementation items -> + (* TODO merge syntax and lexer_errors ?? *) + process u.config (List.rev_append items acc) phrases + | `Interface _ -> + assert false + end + | Parsetree.Ptop_dir + { pdir_name = { txt = "mod_use"; _ }; + pdir_arg = Some { pdira_desc = (Pdir_string file); _ }; + _ } :: phrases -> begin + (* TODO check suffix for implementation *) + (* TODO lookup for file in some "configured" paths. Which one ?? *) + let in_channel = open_in file in + let source = Msource.make (Misc.string_of_file in_channel) in + close_in in_channel; + let u = normal_parse config source in + match u.parsetree with + | `Implementation items -> + (* TODO merge syntax and lexer_errors ?? *) + let modname = + String.capitalize_ascii (Filename.remove_extension file) in + let mod_item = + let open Ast_helper in + Str.module_ (Mb.mk + (Location.mknoloc (Some modname)) + (Mod.structure items)) + in + process u.config (mod_item :: acc) phrases + | `Interface _ -> + assert false + end + | Parsetree.Ptop_dir _ :: phrases -> + process config acc phrases + | Parsetree.Ptop_def items :: phrases -> + process config (List.rev_append items acc) phrases in + process config [] phrases (* Normal entry point *) -let normal_parse ?for_completion config source = +and normal_parse ?for_completion config source = let kind = let filename = Mconfig.(config.query.filename) in let extension = @@ -51,7 +105,6 @@ let normal_parse ?for_completion config source = then Mreader_parser.MLI else Mreader_parser.ML in - Mocaml.setup_config config; let lexer = let keywords = Extension.keywords Mconfig.(config.merlin.extensions) in Mreader_lexer.make Mconfig.(config.ocaml.warnings) keywords config source @@ -70,18 +123,19 @@ let normal_parse ?for_completion config source = and parsetree = Mreader_parser.result parser and comments = Mreader_lexer.comments lexer in - let config, parsetree = - match parsetree with - | `Script phrases -> - let config, parsetree = process_directives config [] phrases in - config, `Implementation parsetree - | `Implementation parsetree -> - config, `Implementation parsetree - | `Interface parsetree -> - config, `Interface parsetree - in - { config; lexer_errors; parser_errors; comments; parsetree; - no_labels_for_completion; } + match parsetree with + | `Script phrases -> + process_directives + config lexer_errors parser_errors comments no_labels_for_completion + phrases + | `Implementation parsetree -> + let parsetree = `Implementation parsetree in + { config; lexer_errors; parser_errors; comments; parsetree; + no_labels_for_completion; } + | `Interface parsetree -> + let parsetree = `Interface parsetree in + { config; lexer_errors; parser_errors; comments; parsetree; + no_labels_for_completion; } (* Pretty-printing *) @@ -197,7 +251,9 @@ let parse ?for_completion config source = let (lexer_errors, parser_errors, comments) = ([], [], []) in { config; lexer_errors; parser_errors; comments; parsetree; no_labels_for_completion; } - | None -> normal_parse ?for_completion config source + | None -> + Mocaml.setup_config config; + normal_parse ?for_completion config source (* Update config after parse *)