Skip to content

Commit

Permalink
Merge pull request #155 from Julow/fix-parts-parsing
Browse files Browse the repository at this point in the history 
Fix parts parsing
  • Loading branch information
@samoht
samoht authored Sep 6, 2019
2 parents 39f0b57 + a4470a6 commit e0a4def
Show file tree
Hide file tree
Showing 5 changed files with 104 additions and 265 deletions.
11 changes: 1 addition & 10 deletions bin/test/main.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -182,15 +182,6 @@ let run_toplevel_tests ?root c ppf tests t =
) tests;
Block.pp_footer ppf ()

let trim l =
let rec aux = function
| [] -> []
| h::t -> if String.trim h = "" then aux t else String.trim h :: t
in
let no_head = aux l in
let no_tail = List.rev (aux (List.rev no_head)) in
no_tail

type file = { first: Mdx_top.Part.file; current: Mdx_top.Part.file }

let files: (string, file) Hashtbl.t = Hashtbl.create 8
Expand Down Expand Up @@ -228,8 +219,8 @@ let update_block_with_file ppf t file part =
(match part with None -> "" | Some p -> p)
file
| Some lines ->
let lines = trim lines in
let contents = String.concat "\n" lines in
let contents = String.trim contents in
Output.pp ppf (`Output contents);
Block.pp_footer ppf ()

Expand Down
323 changes: 72 additions & 251 deletions lib/top/part.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,253 +14,78 @@
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)

open Mdx.Migrate_ast
open Mdx.Compat

module Part = struct

type t =
{ name: string;
sep_indent: string; (** Whitespaces before the [@@@part] separator *)
body: string; }

let v ~name ~body = { name; body }
let v ~name ~sep_indent ~body = { name; sep_indent; body }
let name {name;_} = name
let sep_indent {sep_indent;_} = sep_indent
let body {body;_} = body

end

module Lexbuf = struct

open Lexing

type t = {
contents: string;
lexbuf : lexbuf;
}

let initial_pos name = {
pos_fname = name;
pos_lnum = 1;
pos_bol = 0;
pos_cnum = 0;
}

let v ~fname contents =
let lexbuf = Lexing.from_string contents in
lexbuf.lex_curr_p <- initial_pos fname;
Location.input_name := fname;
{ contents; lexbuf }

let of_file fname =
let ic = open_in fname in
let len = in_channel_length ic in
let result = really_input_string ic len in
close_in_noerr ic;
v ~fname result
(** Remove empty strings at the beginning of a list *)
let rec remove_empty_heads = function
| "" :: tl -> remove_empty_heads tl
| l -> l

let trim_empty_rev l =
remove_empty_heads (List.rev (remove_empty_heads l))

module Parse_parts =
struct

let part_statement_re =
let open Re in
let ws = rep space in
compile @@ whole_string @@ seq [
group ws; str "[@@@"; ws; str "part"; ws;
str "\""; group (rep1 any); str "\"";
ws; str "]"; ws; opt (str ";;"); ws;
]

let next_part ~name ~sep_indent = fun lines_rev ->
let body = String.concat "\n" (trim_empty_rev lines_rev) in
Part.v ~name ~sep_indent ~body

let next_part_of_groups groups =
let sep_indent = Re.Group.get groups 1 in
let name = Re.Group.get groups 2 in
next_part ~name ~sep_indent

let rec parse_parts input make_part lines =
match input_line input with
| exception End_of_file -> [make_part lines]
| line ->
match Re.exec_opt part_statement_re line with
| None -> parse_parts input make_part (line :: lines)
| Some groups ->
let next_part = next_part_of_groups groups in
make_part lines :: parse_parts input next_part []

let of_file name =
let input = open_in name in
parse_parts input (next_part ~name:"" ~sep_indent:"") []

end

module Phrase = struct

open Lexing
open Parsetree

type kind = Code | Part of string

exception Cannot_parse_payload of Location.t

let string_of_location
{Location.loc_start = {pos_fname; pos_lnum; pos_bol; pos_cnum};_}
=
Printf.sprintf "%s, line %d, col %d" pos_fname pos_lnum (pos_cnum - pos_bol)

let payload_constants loc = function
| PStr [{pstr_desc = Pstr_eval (expr, _); _}] ->
let one {pexp_loc; pexp_desc; _} = match pexp_desc with
| Pexp_apply ({pexp_desc = Pexp_ident ident; _},
[Asttypes.Nolabel, {pexp_desc = Pexp_constant const; _}]) ->
(pexp_loc, Some ident, const)
| Pexp_constant const -> (pexp_loc, None, const)
| _ -> raise (Cannot_parse_payload pexp_loc)
in
let rec consts = function
| {pexp_desc=Pexp_sequence(e, rest); _} -> one e :: consts rest
| e -> [one e]
in
consts expr
| PStr [] -> []
| _ -> raise (Cannot_parse_payload loc)

let payload_strings loc = function
| PStr [] -> []
| x ->
let aux = function
| _, Some {Location.txt = Longident.Lident "ocaml"; _},
Pconst_string (str, _) -> (`OCaml, str)
| _, None, Pconst_string (str, _) -> (`Raw, str)
| loc, _, _ -> raise (Cannot_parse_payload loc)
in
List.map aux (payload_constants loc x)

let kind_impl = function
| {pstr_desc = Pstr_attribute (name, payload); pstr_loc}
when name.Asttypes.txt = "part" ->
begin match payload_strings pstr_loc payload with
| [`Raw, part] -> Part part
| _ ->
prerr_endline
(string_of_location pstr_loc ^ ": cannot parse [@@@part] payload");
Code
| exception (Cannot_parse_payload loc) ->
prerr_endline
(string_of_location loc ^ ": cannot parse [@@@part] payload");
Code
end
| _ -> Code

let kind_intf = function
| {psig_desc = Psig_attribute (name, payload); psig_loc}
when name.Asttypes.txt = "part" ->
begin match payload_strings psig_loc payload with
| [`Raw, part] -> Part part
| _ ->
prerr_endline
(string_of_location psig_loc ^ ": cannot parse [@@@part] payload");
Code
| exception (Cannot_parse_payload loc) ->
prerr_endline
(string_of_location loc ^ ": cannot parse [@@@part] payload");
Code
end
| _ -> Code


(* by default, [structure_item] locations do not contain the [;;] token,
so here we try to extend the location when this is needed. *)
let shift_semi_semi doc loc =
let str = doc.Lexbuf.contents in
let stop = loc.pos_cnum in
let rec aux n =
if n+1 >= String.length str then loc
else match str.[n], str.[n+1] with
| '\n', _ -> aux (n+1)
| ';', ';' -> { loc with pos_cnum = n + 2 }
| _, _ -> loc
in
aux stop

let body_impl doc s =
let start = match s with
| s::_ -> Some s.pstr_loc.loc_start.pos_cnum
| _ -> None
in
let stop = match List.rev s with
| s::_ -> Some (shift_semi_semi doc s.pstr_loc.loc_end).pos_cnum
| _ -> None
in
match start, stop with
| Some start, Some stop ->
String.sub doc.Lexbuf.contents start (stop - start)
| _ -> ""
type file = Part.t list

let body_intf doc s =
let start = match s with
| s::_ -> Some s.psig_loc.loc_start.pos_cnum
| _ -> None
in
let stop = match List.rev s with
| s::_ -> Some (shift_semi_semi doc s.psig_loc.loc_end).pos_cnum
| _ -> None
in
match start, stop with
| Some start, Some stop ->
String.sub doc.Lexbuf.contents start (stop - start)
| _ -> ""
let read file = Parse_parts.of_file file

let parts ~body doc phrases =
let rec aux parts part strs = function
| (s, Code) :: rest -> aux parts part (s :: strs) rest
| (_, Part name) :: rest ->
let body = body doc (List.rev strs) in
let parts = Part.v ~name:part ~body :: parts in
aux parts name [] rest
| [] ->
let parts =
if part <> "" || strs <> [] then
let body = body doc (List.rev strs) in
Part.v ~name:part ~body :: parts
else
if List.length parts = 0 then
[Part.v ~name:"" ~body:""]
else
parts
in
List.rev parts
in
aux [] "" [] phrases

let handle_syntax_error e =
#if OCAML_MAJOR >= 4 && OCAML_MINOR >= 8
(* The function is now Parse.prepare_error, but it is not
exposed; luckily enough, it is register to print the
exception. *)
Fmt.failwith "Cannot parse: %s" (Printexc.to_string (Syntaxerr.Error e))
#else
Fmt.failwith "Cannot parse: %a" Syntaxerr.report_error e
#endif

let read_impl doc =
try
let strs = Parse.implementation doc.Lexbuf.lexbuf in
List.map (fun x -> x, kind_impl x) strs
with Syntaxerr.Error e ->
handle_syntax_error e

let read_intf doc =
try
let strs = Parse.interface doc.Lexbuf.lexbuf in
List.map (fun x -> x, kind_intf x) strs
with Syntaxerr.Error e ->
handle_syntax_error e

end

type file =
| Parts of Part.t list
| Body of (exn * string)

let read_impl lexbuf =
Phrase.(parts ~body:body_impl lexbuf (read_impl lexbuf))

let read_intf lexbuf =
Phrase.(parts ~body:body_intf lexbuf (read_intf lexbuf))

let read file =
let lexbuf = Lexbuf.of_file file in
let read = match Filename.extension file with
| ".ml" -> read_impl
| ".mli" -> read_intf
| s -> Fmt.failwith "unknown extension: %s" s
in
try
lexbuf
|> read
|> fun x -> Parts x
with e ->
Body (e, lexbuf.Lexbuf.contents)

let err_parse_error (e, _) =
Fmt.failwith "Parse error: %a" Fmt.exn e

let find file ~part = match file, part with
| Body (_, s), None -> Some [s]
| Body b, _ -> err_parse_error b
| Parts parts, Some part ->
(match List.find_opt (fun p -> String.equal (Part.name p) part) parts with
let find file ~part = match part with
| Some part ->
(match List.find_opt (fun p -> String.equal (Part.name p) part) file with
| Some p -> Some [Part.body p]
| None -> None )
| Parts parts, None ->
List.fold_left (fun acc p -> Part.body p :: [""] @ acc) [] parts
| None ->
List.fold_left (fun acc p -> Part.body p :: [""] @ acc) [] file
|> List.rev
|> fun x -> Some x

Expand All @@ -270,27 +95,23 @@ let rec replace_or_append part_name body = function
| p :: tl ->
p :: replace_or_append part_name body tl
| [] ->
[{ name = part_name; body }]

let replace file ~part ~lines = match file, part with
| Body (e, _), None -> Body (e, String.concat "\n" lines)
| Body b , _ -> err_parse_error b
| Parts parts, _ ->
let part = match part with None -> "" | Some p -> p in
let parts = replace_or_append part (String.concat "\n" lines) parts in
Parts parts

let contents = function
| Body (_, s) -> String.trim s ^ "\n"
| Parts parts ->
let lines =
List.fold_left (fun acc p ->
let body = Part.body p in
match Part.name p with
| "" -> body :: acc
| n -> body :: ("\n[@@@part \"" ^ n ^ "\"] ;;\n") :: acc
) [] parts
in
let lines = List.rev lines in
let lines = String.concat "\n" lines in
String.trim lines ^ "\n"
[{ name = part_name; sep_indent = ""; body }]

let replace file ~part ~lines =
let part = match part with None -> "" | Some p -> p in
replace_or_append part (String.concat "\n" lines) file

let contents file =
let lines =
List.fold_left (fun acc p ->
let body = Part.body p in
match Part.name p with
| "" -> body :: acc
| n ->
let indent = Part.sep_indent p in
body :: ("\n" ^ indent ^ "[@@@part \"" ^ n ^ "\"] ;;\n") :: acc
) [] file
in
let lines = List.rev lines in
let lines = String.concat "\n" lines in
String.trim lines ^ "\n"
11 changes: 10 additions & 1 deletion test/sync_to_ml.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -40,6 +40,15 @@ let () =
()
```

```ocaml file=sync_to_ml.mli,part=1
module A =
struct
```

```ocaml file=sync_to_ml.mli,part=2
type t = Some of int | Many
```

```ocaml file=sync_to_ml.mli,part=3
type t = Some of int | Many
end
```
Loading

0 comments on commit e0a4def

Please sign in to comment.