(* pa_o.cmo q_MLast.cmo pa_extend.cmo pr_dump.cmo *)
(***********************************************************************)
(*                                                                     *)
(*                               Camlp4                                *)
(*                                                                     *)
(*     Alain Frisch, projet Cristal, INRIA Rocquencourt                *)
(*                                                                     *)
(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the GNU Library General Public License, with    *)
(*  the special exception on linking described in file                 *)
(*   ../../../LICENSE.                                                 *)
(*                                                                     *)
(***********************************************************************)


open Syntax
open Lexgen
open Compact

(* Adapted from output.ml *)
(**************************)

(* Output the DFA tables and its entry points *)

(* To output an array of short ints, encoded as a string *)

let output_byte buf b =
  Buffer.add_char buf '\\';
  Buffer.add_char buf (Char.chr(48 + b / 100));
  Buffer.add_char buf (Char.chr(48 + (b / 10) mod 10));
  Buffer.add_char buf (Char.chr(48 + b mod 10))

let loc = (Lexing.dummy_pos,Lexing.dummy_pos)

let output_array v =
  let b = Buffer.create (Array.length v * 3) in
  for i = 0 to Array.length v - 1 do
    output_byte b (v.(i) land 0xFF);
    output_byte b ((v.(i) asr 8) land 0xFF);
    if i land 7 = 7 then Buffer.add_string b "\\\n    "
  done;
  let s = Buffer.contents b in
  <:expr< $str:s$ >>

let output_byte_array v =
  let b = Buffer.create (Array.length v * 2) in
  for i = 0 to Array.length v - 1 do
    output_byte b (v.(i) land 0xFF);
    if i land 15 = 15 then Buffer.add_string b "\\\n    "
  done;
  let s = Buffer.contents b in
  <:expr< $str:s$ >>



(* Output the tables *)

let output_tables tbl =
  <:str_item< value lex_tables = {
    Lexing.lex_base = $output_array tbl.tbl_base$;
    Lexing.lex_backtrk = $output_array tbl.tbl_backtrk$;
    Lexing.lex_default = $output_array tbl.tbl_default$;
    Lexing.lex_trans = $output_array tbl.tbl_trans$;
    Lexing.lex_check = $output_array tbl.tbl_check$;
    Lexing.lex_base_code = $output_array tbl.tbl_base_code$;
    Lexing.lex_backtrk_code = $output_array tbl.tbl_backtrk_code$;
    Lexing.lex_default_code = $output_array tbl.tbl_default_code$;
    Lexing.lex_trans_code = $output_array tbl.tbl_trans_code$;
    Lexing.lex_check_code = $output_array tbl.tbl_check_code$;
    Lexing.lex_code = $output_byte_array tbl.tbl_code$
  } >>

(* Output the entries *)

let rec make_alias n = function
  | [] -> []
  | h::t ->
      (h, "__ocaml_lex_arg_" ^ (string_of_int n)) :: (make_alias (succ n) t)

let abstraction =
  List.fold_right (fun (p,a) e -> <:expr< fun ($p$ as $lid:a$) -> $e$ >>)


let application =
  List.fold_left (fun f (_,a) -> <:expr< $f$ $lid:a$ >>)

let int i = <:expr< $int:string_of_int i$ >>

let output_memory_actions acts =
  let aux = function
    | Copy (tgt, src) ->
        <:expr< lexbuf.Lexing.lex_mem.($int tgt$) :=
      lexbuf.Lexing.lex_mem.($int src$) >>
    | Set tgt ->
        <:expr< lexbuf.Lexing.lex_mem.($int tgt$) :=
      lexbuf.Lexing.lex_curr_pos >>
  in
  <:expr< do { $list:List.map aux acts$ } >>

let output_base_mem = function
  | Mem i -> <:expr< lexbuf.Lexing.lex_mem.($int i$) >>
  | Start -> <:expr< lexbuf.Lexing.lex_start_pos >>
  | End   -> <:expr< lexbuf.Lexing.lex_curr_pos >>

let output_tag_access = function
  | Sum (a,0) -> output_base_mem a
  | Sum (a,i) -> <:expr< $output_base_mem a$ + $int i$ >>

let rec output_env e = function
  | [] -> e
  | (x, Ident_string (o,nstart,nend)) :: rem ->
      <:expr<
          let $lid:x$ =
            Lexing.$lid:if o then "sub_lexeme_opt" else "sub_lexeme"$
            lexbuf $output_tag_access nstart$ $output_tag_access nend$
          in $output_env e rem$
      >>
  | (x, Ident_char (o,nstart)) :: rem ->
      <:expr<
          let $lid:x$ =
            Lexing.$lid: if o then "sub_lexeme_char_opt" else "sub_lexeme_char"$
            lexbuf $output_tag_access nstart$
          in $output_env e rem$
      >>

let output_entry e =
  let init_num, init_moves = e.auto_initial_state in
  let args = make_alias 0 (e.auto_args @ [ <:patt< lexbuf >> ]) in
  let f = "__ocaml_lex_rec_" ^ e.auto_name ^ "_rec" in
  let call_f = application <:expr< $lid:f$ >> args in
  let body_wrapper =
    <:expr<
      do {
        lexbuf.Lexing.lex_mem := Array.create $int e.auto_mem_size$ (-1) ;
        $output_memory_actions init_moves$;
        $call_f$ $int init_num$
      } >> in
  let cases =
    List.map
      (fun (num, env, (loc,e)) ->
         <:patt< $int:string_of_int num$ >>,
         None,
         output_env <:expr< $e$ >> env
             (* Note: the <:expr<...>> above is there to set the location *)
      ) e.auto_actions @
    [ <:patt< __ocaml_lex_n >>,
      None,
      <:expr< do
        { lexbuf.Lexing.refill_buff lexbuf; $call_f$ __ocaml_lex_n  }>> ]
  in
  let engine =
    if e.auto_mem_size = 0
    then <:expr< Lexing.engine >>
    else <:expr< Lexing.new_engine >> in
  let body =
    <:expr< fun state ->
      match $engine$ lex_tables state lexbuf with [ $list:cases$ ] >> in
  [
    <:patt< $lid:e.auto_name$ >>, (abstraction args body_wrapper);
    <:patt< $lid:f$ >>, (abstraction args body)
  ]

(* Main output function *)

exception Table_overflow

let output_lexdef tables entry_points =
  Printf.eprintf
    "pa_ocamllex: lexer found; %d states, %d transitions, table size %d bytes\n"
    (Array.length tables.tbl_base)
    (Array.length tables.tbl_trans)
    (2 * (Array.length tables.tbl_base + Array.length tables.tbl_backtrk +
          Array.length tables.tbl_default + Array.length tables.tbl_trans +
          Array.length tables.tbl_check));
  let size_groups =
    (2 * (Array.length tables.tbl_base_code +
          Array.length tables.tbl_backtrk_code +
          Array.length tables.tbl_default_code +
          Array.length tables.tbl_trans_code +
          Array.length tables.tbl_check_code) +
    Array.length tables.tbl_code) in
  if  size_groups > 0 then
    Printf.eprintf "pa_ocamllex: %d additional bytes used for bindings\n"
      size_groups ;
  flush stderr;
  if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow;

  let entries = List.map output_entry entry_points in
  [output_tables tables; <:str_item< value rec $list:List.flatten entries$ >> ]


(* Adapted from parser.mly and main.ml *)
(***************************************)

(* Auxiliaries for the parser. *)

let char s = Char.code (Token.eval_char s)

let named_regexps =
  (Hashtbl.create 13 : (string, regular_expression) Hashtbl.t)

let regexp_for_string s =
  let rec re_string n =
    if n >= String.length s then Epsilon
    else if succ n = String.length s then
      Characters (Cset.singleton (Char.code s.[n]))
    else
      Sequence
        (Characters(Cset.singleton (Char.code s.[n])),
         re_string (succ n))
  in re_string 0

let char_class c1 c2 = Cset.interval c1 c2

let all_chars = Cset.all_chars

let rec remove_as = function
  | Bind (e,_) -> remove_as e
  | Epsilon|Eof|Characters _ as e -> e
  | Sequence (e1, e2) -> Sequence (remove_as e1, remove_as e2)
  | Alternative (e1, e2) -> Alternative (remove_as e1, remove_as e2)
  | Repetition e -> Repetition (remove_as e)

let () =
  Hashtbl.add named_regexps "eof" (Characters Cset.eof)

(* The parser *)

let let_regexp = Grammar.Entry.create Pcaml.gram "pa_ocamllex let"
let header = Grammar.Entry.create Pcaml.gram "pa_ocamllex header"
let lexer_def = Grammar.Entry.create Pcaml.gram "pa_ocaml lexerdef"

EXTEND
 GLOBAL: Pcaml.str_item let_regexp header lexer_def;

 let_regexp: [
   [ x = LIDENT; "="; r = regexp ->
       if Hashtbl.mem named_regexps x then
         Printf.eprintf
           "pa_ocamllex (warning): multiple definition of named regexp '%s'\n"
           x;
       Hashtbl.add named_regexps x r;
   ]
 ];

 lexer_def: [
   [ def = LIST0 definition SEP "and" ->
       (try
          let (entries, transitions) = make_dfa def in
          let tables = compact_tables transitions in
          let output = output_lexdef tables entries in
          <:str_item< declare $list: output$ end >>
        with
          |Table_overflow ->
             failwith "Transition table overflow in lexer, automaton is too big"
          | Lexgen.Memory_overflow ->
              failwith "Position memory overflow in lexer, too many as variables")
   ]
 ];


 Pcaml.str_item: [
   [ "pa_ocamllex"; LIDENT "rule"; d = lexer_def -> d
   | "pa_ocamllex"; "let"; let_regexp ->
       <:str_item< declare $list: []$ end >>
   ]
 ];

 definition: [
   [ x=LIDENT; pl = LIST0 Pcaml.patt LEVEL "simple"; "=";
     short=[ LIDENT "parse" -> false | LIDENT "shortest" -> true ];
     OPT "|"; l = LIST0 [ r=regexp; a=action -> (r,a) ] SEP "|" ->
     { name=x ; shortest=short ; args=pl ; clauses = l } ]
 ];

 action: [
   [ "{"; e = OPT Pcaml.expr; "}" ->
       let e = match e with
         | Some e -> e
         | None -> <:expr< () >>
       in
       (loc,e)
   ]
 ];

 header:  [
   [ "{"; e = LIST0 [ si = Pcaml.str_item; OPT ";;" -> si ]; "}" ->
       [<:str_item< declare $list:e$ end>>, loc] ]
   | [ -> [] ]
 ];

 regexp: [
   [ r = regexp; "as"; i = LIDENT -> Bind (r,i) ]
 | [ r1 = regexp; "|"; r2 = regexp -> Alternative(r1,r2) ]
 | [ r1 = regexp; r2 = regexp -> Sequence(r1,r2) ]
 | [ r = regexp; "*" -> Repetition r
   | r = regexp; "+" -> Sequence(Repetition (remove_as r), r)
   | r = regexp; "?" -> Alternative(Epsilon, r)
   | "("; r = regexp; ")" -> r
   | "_" -> Characters all_chars
   | c = CHAR -> Characters (Cset.singleton (char c))
   | s = STRING -> regexp_for_string (Token.eval_string loc s)
   | "["; cc = ch_class; "]" ->  Characters cc
   | x = LIDENT ->
       try  Hashtbl.find named_regexps x
       with Not_found ->
         failwith
           ("pa_ocamllex (error): reference to unbound regexp name `"^x^"'")
   ]
 ];

 ch_class: [
   [ "^"; cc = ch_class -> Cset.complement cc]
 | [ c1 = CHAR; "-"; c2 = CHAR -> Cset.interval (char c1) (char c2)
   | c = CHAR -> Cset.singleton (char c)
   | cc1 = ch_class; cc2 = ch_class -> Cset.union cc1 cc2
   ]
 ];
END

(* We have to be careful about "rule"; in standalone mode,
   it is used as a keyword (otherwise, there is a conflict
   with named regexp); in normal mode, it is used as LIDENT
   (we do not want to reserve such an useful identifier).

   Plexer does not like identifiers used as keyword _and_
   as LIDENT ...
*)

let standalone =
  let already = ref false in
  fun () ->
    if not (!already) then
    begin
      already := true;
      Printf.eprintf "pa_ocamllex: stand-alone mode\n";

      DELETE_RULE Pcaml.str_item: "pa_ocamllex"; LIDENT "rule";lexer_def END;
      DELETE_RULE Pcaml.str_item: "pa_ocamllex"; "let"; let_regexp END;
      let ocamllex = Grammar.Entry.create Pcaml.gram "pa_ocamllex" in
      EXTEND GLOBAL: ocamllex let_regexp header lexer_def;
      ocamllex: [
        [ h = header;
          l  = [LIST0 ["let"; let_regexp]; "rule"; d = lexer_def -> (d,loc)];
          t = header; EOI -> h @ (l :: t) ,false
        ]
      ];
      END;
      Pcaml.parse_implem := Grammar.Entry.parse ocamllex
    end

let () =
  Pcaml.add_option "-ocamllex" (Arg.Unit standalone)
    "Activate (standalone) ocamllex emulation mode."
