RFC: don't fail on directives when the file starts with #!

src/kernel/mreader.ml

@@ -16,9 +16,79 @@ type result = {
  no_labels_for_completion : bool;
 }
 
+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 =
@@ -28,12 +98,13 @@ 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
  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
@@ -52,8 +123,19 @@ let normal_parse ?for_completion config source =
  and parsetree = Mreader_parser.result parser
  and comments = Mreader_lexer.comments lexer
  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 *)
 
@@ -169,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 *)
 

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,26 +66,19 @@ type 'a step =
 type tree = [
  | `Interface of Parsetree.signature
  | `Implementation of Parsetree.structure
-]
-
-type steps =[
- | `Signature of (Parsetree.signature step * Mreader_lexer.triple) list
- | `Structure of (Parsetree.structure step * Mreader_lexer.triple) list
+ | `Script of Parsetree.toplevel_phrase 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 +147,30 @@ 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 state = Parser_raw.Incremental.implementation initial_pos in
+ `Implementation (parse state tokens)
  | 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 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 := [];
- 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
 

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