diff --git a/src/let-syntax/dune b/src/let-syntax/dune new file mode 100644 index 00000000..0d7b1143 --- /dev/null +++ b/src/let-syntax/dune @@ -0,0 +1,2 @@ +(executable (name pp)) +(ocamllex pp) diff --git a/src/let-syntax/pp.mll b/src/let-syntax/pp.mll new file mode 100644 index 00000000..560460b2 --- /dev/null +++ b/src/let-syntax/pp.mll @@ -0,0 +1,186 @@ +{ +open StdLabels +open Printf + +let fname = Sys.argv.(1) +let fname_gen = fname ^ ".generated" + +let lexeme_len lb = + Lexing.lexeme_end lb - Lexing.lexeme_start lb + +let fail lb msg = + let start = Lexing.lexeme_start_p lb in + let stop = Lexing.lexeme_end_p lb in + Printf.eprintf + "File %S, line %d, characters %d-%d:\n\ + Error: %s\n%!" + fname start.pos_lnum (start.pos_cnum - start.pos_bol) + (stop.pos_cnum - start.pos_bol) + msg; + exit 1 + +(* Line number in generated file *) +let lnum = ref 1 + +let ps s = + String.iter s ~f:(function + | '\n' -> incr lnum + | _ -> ()); + print_string s +let pc = function + | '\n' -> incr lnum; print_char '\n' + | c -> print_char c +let npc n c = for _ = 1 to n do pc c done +let pf fmt = ksprintf ps fmt + +let gen_id = + let n = ref 0 in + fun () -> + incr n; + sprintf "__x%d__" !n + +let buf = Buffer.create 512 +let add_lexeme lb = Buffer.add_string buf (Lexing.lexeme lb) + +type mode = Generated_code | Source_code + +let mode = ref Generated_code + +let enter_generated_code () = + mode := Generated_code; + pc '\n'; + pf "# %d %S\n" !lnum fname_gen + +let enter_source_code (pos : Lexing.position) = + mode := Source_code; + pc '\n'; + pf "# %d %S\n" pos.pos_lnum fname; + let col = pos.pos_cnum - pos.pos_bol in + npc col ' ' + +let pass_through lb = + if !mode = Generated_code then + enter_source_code (Lexing.lexeme_start_p lb); + ps (Lexing.lexeme lb) + +type and_or_in = And | In +} + +let space = [' ' '\t'] +let newline = '\n' | "\r\n" +let id = ['a'-'z' '_'] ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9']* + +rule main col = parse + | eof + { In } + | newline + { pass_through lexbuf; + Lexing.new_line lexbuf; + after_newline col lexbuf + } + | " in" newline + { pass_through lexbuf; + Lexing.new_line lexbuf; + after_in_and_newline col lexbuf + } + | _ + { pass_through lexbuf; + main col lexbuf + } + | id as id + { pass_through lexbuf; + match id with + | "let" -> after_let col (Lexing.lexeme_start_p lexbuf) lexbuf + | _ -> main col lexbuf + } + +and after_let col pos = parse + | "%" (id as id) + { if id <> "map" then begin + pass_through lexbuf; + main col lexbuf + end else begin + let col' = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in + let rec loop () = + let pos = Lexing.lexeme_end_p lexbuf in + enter_generated_code (); + let id = gen_id () in + ps id; + lhs lexbuf; + let pattern = Buffer.contents buf in + Buffer.clear buf; + (id, (pos, pattern)) :: + match main col' lexbuf with + | And -> loop () + | In -> [] + in + let ids, patterns = List.split (loop ()) in + enter_generated_code (); + ps "Let_syntax.(fun f -> const f"; + List.iter ids ~f:(pf "$ %s"); + ps ") @@ fun "; + List.iter patterns ~f:(fun (pos, pattern) -> + pc '('; + enter_source_code pos; + ps pattern; + pc ')'); + ps "->"; + mode := Generated_code; + main col lexbuf + end + } + | "" + { main col lexbuf } + +and after_newline col = parse + | space* + { pass_through lexbuf; + if lexeme_len lexbuf = col then + after_indent col lexbuf + else + main col lexbuf + } + +and after_indent col = parse + | id as id + { pass_through lexbuf; + match id with + | "and" -> And + | "in" -> In + | _ -> fail lexbuf "'and' or 'in' keyword expected" + } + +and after_in_and_newline col = parse + | space* newline + { pass_through lexbuf; + Lexing.new_line lexbuf; + after_in_and_newline col lexbuf + } + | space* + { pass_through lexbuf; + if lexeme_len lexbuf = col then + In + else + main col lexbuf + } + +and lhs = parse + | eof + { () + } + | newline as s + { Buffer.add_string buf s; + Lexing.new_line lexbuf; + lhs lexbuf + } + | "=" + { pass_through lexbuf + } + | _ as c + { Buffer.add_char buf c; + lhs lexbuf + } + +{ + let (And | In) = main (-1) (Lexing.from_channel (open_in_bin fname)) +}