(* camlp4r *)
(***********************************************************************)
(*                                                                     *)
(*                             Camlp4                                  *)
(*                                                                     *)
(*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
(*                                                                     *)
(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(***********************************************************************)

(* $Id: plexer.ml,v 2.1 1998/12/04 18:29:12 ddr Exp $ *)

open Stdpp;
open Token;

(* The string buffering machinery *)

value buff = ref (String.create 80);
value store len x =
  do if len >= String.length buff.val then
       buff.val := buff.val ^ String.create (String.length buff.val)
     else ();
     buff.val.[len] := x;
  return succ len
;
value mstore len s =
  add_rec len 0 where rec add_rec len i =
    if i == String.length s then len else add_rec (store len s.[i]) (succ i)
;
value get_buff len = String.sub buff.val 0 len;

(* The lexer *)

value valch x = Char.code x - Char.code '0';

value rec ident len =
  parser
  [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246'
      | '\248'..'\255' | '0'..'9' | '_' | ''' as c); s :] ->
      ident (store len c) s
  | [: :] -> len ]
and ident2 len =
  parser
  [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
         '%' | '.' | ':' | '<' | '>' | '|' as
         c);
       s :] ->
      ident2 (store len c) s
  | [: :] -> len ]
and ident3 len =
  parser
  [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246'
      | '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | '+' |
         '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' |
         '~' | ''' | '$' as
         c);
       s :] ->
      ident3 (store len c) s
  | [: :] -> len ]
and base_number len =
  parser
  [ [: `'o' | 'O'; s :] -> octal_digits (store len 'o') s
  | [: `'x' | 'X'; s :] -> hexa_digits (store len 'x') s
  | [: `'b' | 'B'; s :] -> binary_digits (store len 'b') s
  | [: a = number len :] -> a ]
and octal_digits len =
  parser
  [ [: `('0'..'7' as d); s :] -> octal_digits (store len d) s
  | [: :] -> ("INT", get_buff len) ]
and hexa_digits len =
  parser
  [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d); s :] ->
      hexa_digits (store len d) s
  | [: :] -> ("INT", get_buff len) ]
and binary_digits len =
  parser
  [ [: `('0'..'1' as d); s :] -> binary_digits (store len d) s
  | [: :] -> ("INT", get_buff len) ]
and number len =
  parser
  [ [: `('0'..'9' as c); s :] -> number (store len c) s
  | [: `'.'; s :] -> decimal_part (store len '.') s
  | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
  | [: :] -> ("INT", get_buff len) ]
and decimal_part len =
  parser
  [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s
  | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
  | [: :] -> ("FLOAT", get_buff len) ]
and exponent_part len =
  parser
  [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s
  | [: a = end_exponent_part len :] -> a ]
and end_exponent_part len =
  parser
  [ [: `('0'..'9' as c); s :] -> end_exponent_part (store len c) s
  | [: :] -> ("FLOAT", get_buff len) ]
;

value rec escape =
  parser
  [ [: `'n' :] -> '\n'
  | [: `'r' :] -> '\r'
  | [: `'t' :] -> '\t'
  | [: `'b' :] -> '\b'
  | [: `'\\' :] -> '\\'
  | [: `('0'..'9' as c); cod = escape1 (valch c) :] -> Char.chr cod ]
and escape1 cod =
  parser
  [ [: `('0'..'9' as c); a = escape2 (10 * cod + valch c) :] -> a
  | [: :] -> cod ]
and escape2 cod =
  parser [ [: `('0'..'9' as c) :] -> 10 * cod + valch c | [: :] -> cod ]
;

value escape_string =
  parser
  [ [: c = escape :] -> c
  | [: `'"' :] -> '"' ]
;
value escape_char =
  parser
  [ [: c = escape :] -> c
  | [: `''' :] -> ''' ]
;

value rec skip_spaces =
  parser
  [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] -> skip_spaces s
  | [: :] -> () ]
;

value rec skip_indent =
  parser
  [ [: `' ' | '\t'; s :] -> skip_indent s
  | [: :] -> () ]
;

value skip_opt_newline =
  parser
  [ [: `'\n' :] -> ()
  | [: :] -> () ]
;

value error_on_unknown_keywords = ref False;

value next_token_fun find_id_kwd find_spe_kwd =
  let err bp ep msg = raise_with_loc (bp, ep) (Token.Error msg) in
  let keyword_or_error (bp, ep) s =
    try ("", find_spe_kwd s) with
    [ Not_found ->
        if error_on_unknown_keywords.val then
          err bp ep ("illegal token: " ^ s)
        else ("", s) ]
  in
  let rec next_token =
    parser bp
    [ [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] ->
        let id = get_buff (ident (store 0 c) s) in
        try ("", find_id_kwd id) with [ Not_found -> ("UIDENT", id) ]
    | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] ->
        let id = get_buff (ident (store 0 c) s) in
        try ("", find_id_kwd id) with [ Not_found -> ("LIDENT", id) ]
    | [: `('1'..'9' as c); s :] -> number (store 0 c) s
    | [: `'0'; s :] -> base_number (store 0 '0') s
    | [: `'''; s :] ep ->
        match Stream.npeek 2 s with
        [ [_; '''] | ['\\'; _] -> ("CHAR", String.make 1 (char bp s))
        | _ -> keyword_or_error (bp, ep) "'" ]
    | [: `'"'; s :] -> ("STRING", string bp 0 s)
    | [: `'$'; s :] -> locate_or_antiquot bp 0 s
    | [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
           '%' as
           c);
         s :] ->
        let id = get_buff (ident2 (store 0 c) s) in
        keyword_or_error (bp, Stream.count s) id
    | [: `'<'; s :] -> less bp s
    | [: `(':' as c1);
         len =
           parser
           [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2
           | [: :] -> store 0 c1 ] :] ep ->
        let id = get_buff len in keyword_or_error (bp, ep) id
    | [: `('>' | '|' as c1);
         len =
           parser
           [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2
           | [: a = ident2 (store 0 c1) :] -> a ] :] ep ->
        let id = get_buff len in keyword_or_error (bp, ep) id
    | [: `('[' | '{' as c1); s :] ->
        let len =
          match Stream.npeek 2 s with
          [ ['<'; '<' | ':'] -> store 0 c1
          | _ ->
              match s with parser
              [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2
              | [: :] -> store 0 c1 ] ]
        in
        let ep = Stream.count s in
        let id = get_buff len in keyword_or_error (bp, ep) id
    | [: `'.'; id = parser [ [: `'.' :] -> ".." | [: :] -> "." ] :] ep ->
        keyword_or_error (bp, ep) id
    | [: `';'; id = parser [ [: `';' :] -> ";;" | [: :] -> ";" ] :] ep ->
        keyword_or_error (bp, ep) id
    | [: `'\\'; s :] -> ("LIDENT", get_buff (ident3 0 s))
    | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) ]
  and less bp =
    parser
    [ [: `'<'; s :] -> ("QUOTATION", (":" ^ get_buff (quotation bp 0 s)))
    | [: `':'; i = parser [: len = ident 0 :] -> get_buff len;
         `'<' ? "character '<' expected"; s :] ->
        ("QUOTATION", i ^ ":" ^ get_buff (quotation bp 0 s))
    | [: s :] ep ->
        let id = get_buff (ident2 (store 0 '<') s) in
        keyword_or_error (bp, ep) id ]
  and string bp len =
    parser
    [ [: `'"' :] -> get_buff len
    | [: `'\\';
         len =
           parser
           [ [: `'\n'; _ = skip_indent :] -> len
           | [: `'\r'; _ = skip_opt_newline; _ = skip_indent :] -> len
           | [: c = escape_string :] -> store len c
           | [: `c :] -> store (store len '\\') c ];
         s :] ->
        string bp len s
    | [: `c; s :] -> string bp (store len c) s
    | [: :] ep -> err bp ep "string not terminated" ]
  and char bp =
    parser
    [ [: `'\\'; c = escape_char ? "escape character expected";
         `''' ? "quote expected" :] -> c
    | [: `c; `''' ? "quote expected" :] -> c
    | [: :] ep -> err bp ep "char not terminated" ]
  and locate_or_antiquot bp len =
    parser
    [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
    | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s
    | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
    | [: `':'; s :] ->
        let k = get_buff len in
        ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
    | [: `'\\'; `c; s :] ->
        ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
    | [: `c; s :] ->
        ("ANTIQUOT", ":" ^  locate_or_antiquot_rest bp (store len c) s)
    | [: :] ep -> err bp ep "antiquotation not terminated" ]
  and maybe_locate bp len =
    parser
    [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
    | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
    | [: `':'; s :] ->
        ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s)
    | [: `'\\'; `c; s :] ->
        ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
    | [: `c; s :] ->
        ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
    | [: :] ep -> err bp ep "antiquotation not terminated" ]
  and antiquot bp len =
    parser
    [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
    | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] ->
        antiquot bp (store len c) s
    | [: `':'; s :] ->
        let k = get_buff len in
        ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
    | [: `'\\'; `c; s :] ->
        ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
    | [: `c; s :] ->
        ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
    | [: :] ep -> err bp ep "antiquotation not terminated" ]
  and locate_or_antiquot_rest bp len =
    parser
    [ [: `'$' :] -> get_buff len
    | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s
    | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s
    | [: :] ep -> err bp ep "antiquotation not terminated" ]
  and quotation bp len =
    parser
    [ [: `'>'; s :] -> maybe_end_quotation bp len s
    | [: `'<'; s :] ->
        quotation bp (maybe_nested_quotation bp (store len '<') s) s
    | [: `'\\';
         len =
           parser
           [ [: `('>' | '<' | '\\' as c) :] -> store len c
           | [: :] -> store len '\\' ];
         s :] ->
        quotation bp len s
    | [: `c; s :] -> quotation bp (store len c) s
    | [: :] ep -> err bp ep "quotation not terminated" ]
  and maybe_nested_quotation bp len =
    parser
    [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
    | [: `':'; len = ident (store len ':');
         a =
           parser
           [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
           | [: :] -> len ] :] ->
        a
    | [: :] -> len ]
  and maybe_end_quotation bp len =
    parser [ [: `'>' :] -> len | [: a = quotation bp (store len '>') :] -> a ]
  in
  let rec next_token_loc =
    parser bp
    [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] -> next_token_loc s
    | [: `'('; s :] -> maybe_comment bp s
    | [: `'#'; _ = spaces_tabs; t = linenum bp :] -> t
    | [: tok = next_token :] ep -> (tok, (bp, ep))
    | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ]
  and maybe_comment bp =
    parser
    [ [: `'*'; s :] -> do comment bp s; return next_token_loc s
    | [: :] ep -> let tok = keyword_or_error (bp, ep) "(" in (tok, (bp, ep)) ]
  and comment bp =
    parser
    [ [: `'('; s :] -> maybe_nested_comment bp s
    | [: `'*'; s :] -> maybe_end_comment bp s
    | [: `c; s :] -> comment bp s
    | [: :] ep -> err bp ep "comment not terminated" ]
  and maybe_nested_comment bp =
    parser
    [ [: `'*'; s :] -> do comment bp s; return comment bp s
    | [: a = comment bp :] -> a ]
  and maybe_end_comment bp =
    parser [ [: `')' :] -> () | [: a = comment bp :] -> a ]
  and linenum bp =
    parser
    [ [: `'0'..'9'; _ = digits; _ = spaces_tabs; `'"'; _ = any_to_nl; s :] ->
        next_token_loc s
    | [: :] -> (keyword_or_error (bp, bp + 1) "#", (bp, bp + 1)) ]
  and spaces_tabs =
    parser
    [ [: `' ' | '\t'; s :] -> spaces_tabs s
    | [: :] -> () ]
  and digits =
    parser
    [ [: `'0'..'9'; s :] -> digits s
    | [: :] -> () ]
  and any_to_nl =
    parser
    [ [: `'\r' | '\n' :] -> ()
    | [: `_; s :] -> any_to_nl s
    | [: :] -> () ]
  in
  fun cstrm ->
    try next_token_loc cstrm with
    [ Stream.Error str ->
        err (Stream.count cstrm) (Stream.count cstrm + 1) str ]
;

value locerr () = invalid_arg "Lexer: location function";
value loct_create () = ref (Array.create 1024 None);
value loct_func loct i =
  match
    if i < 0 || i >= Array.length loct.val then None
    else Array.unsafe_get loct.val i
  with
  [ Some loc -> loc
  | _ -> locerr () ]
;
value loct_add loct i loc =
  do if i >= Array.length loct.val then
       let new_tmax = Array.length loct.val * 2 in
       let new_loct = Array.create new_tmax None in
       do Array.blit loct.val 0 new_loct 0 (Array.length loct.val);
          loct.val := new_loct;
       return ()
     else ();
     loct.val.(i) := Some loc;
  return ()
;

value func kwd_table =
  let find = Hashtbl.find kwd_table in
  let lex cstrm =
    let next_token_loc = next_token_fun find find in
    let loct = loct_create () in
    let ts =
      Stream.from
        (fun i ->
           let (tok, loc) = next_token_loc cstrm in
           do loct_add loct i loc; return Some tok)
    in
    let locf = loct_func loct in
    (ts, locf)
  in
  lex
;

value rec check_keyword_stream =
  parser [: _ = check; _ = Stream.empty :] -> True
and check =
  parser
  [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246'
       | '\248'..'\255'; s :] -> check_ident s
  | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
        '%' | '.';
       s :] ->
      check_ident2 s
  | [: `'<'; s :] ->
      match Stream.npeek 1 s with
      [ [':' | '<']  -> ()
      | _ -> check_ident2 s ]
  | [: `':';
       _ =
         parser [ [: `']' | ':' | '=' | '>' :] -> () | [: :] -> () ] :] ep ->
      ()
  | [: `'>' | '|';
       _ =
         parser [ [: `']' | '}' :] -> () | [: a = check_ident2 :] -> a ] :] ->
      ()
  | [: `'[' | '{'; s :] ->
      match Stream.npeek 2 s with
      [ ['<'; '<' | ':'] -> ()
      | _ ->
          match s with parser [ [: `'|' | '<' | ':' :] -> () | [: :] -> () ] ]
  | [: `';'; _ = parser [ [: `';' :] -> () | [: :] -> () ] :] -> ()
  | [: `_ :] -> () ]
and check_ident =
  parser
  [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
        '\248'..'\255' | '0'..'9' | '_' | '''; s :] -> check_ident s
  | [: :] -> () ]
and check_ident2 =
  parser
  [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
        '%' | '.' | ':' | '<' | '>' | '|';
       s :] ->
      check_ident2 s
  | [: :] -> () ]
;

value check_keyword s =
  try check_keyword_stream (Stream.of_string s) with _ -> False
;

value using_token kwd_table (p_con, p_prm) =
  match p_con with
  [ "" ->
      try
        let _ = Hashtbl.find kwd_table p_prm in ()
      with
      [ Not_found ->
          if check_keyword p_prm then Hashtbl.add kwd_table p_prm p_prm
          else
            raise (Token.Error ("\
the token \"" ^ p_prm ^ "\" does not respect Plexer rules")) ]
  | "LIDENT" | "UIDENT" | "INT"| "FLOAT" | "CHAR" | "STRING" | "QUOTATION"
  | "ANTIQUOT" | "LOCATE" | "EOI" -> ()
  | _ ->
      raise (Token.Error ("\
the constructor \"" ^ p_con ^ "\" is not recognized by Plexer")) ]
;

value removing_token kwd_table (p_con, p_prm) =
  if p_con = "" then Hashtbl.remove kwd_table p_prm else ()
;

value text =
  fun
  [ ("", t) -> "'" ^ t ^ "'"
  | ("LIDENT", "") -> "lowercase identifier"
  | ("LIDENT", t) -> "'" ^ t ^ "'"
  | ("UIDENT", "") -> "uppercase identifier"
  | ("UIDENT", t) -> "'" ^ t ^ "'"
  | ("INT", "") -> "integer"
  | ("INT", s) -> "'" ^ s ^ "'"
  | ("FLOAT", "") -> "float"
  | ("STRING", "") -> "string"
  | ("CHAR", "") -> "char"
  | ("QUOTATION", "") -> "quotation"
  | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\""
  | ("LOCATE", "") -> "locate"
  | ("EOI", "") -> "end of input"
  | (con, "") -> con
  | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ]
;

value eq_before_colon p e =
  loop 0 where rec loop i =
    if i == String.length e then
      failwith "Internal error in Plexer: incorrect ANTIQUOT"
    else if i == String.length p then e.[i] == ':'
    else if p.[i] == e.[i] then loop (i + 1)
    else False
;

value after_colon e =
  try
    let i = String.index e ':' in
    String.sub e (i + 1) (String.length e - i - 1)
  with [ Not_found -> "" ]
;

value tparse =
  fun
  [ ("ANTIQUOT", p_prm) ->
      parser [: `("ANTIQUOT", prm) when eq_before_colon p_prm prm :] ->
        after_colon prm
  | (p_con, "") ->
      parser [: `(con, prm) when con = p_con :] -> prm
  | (p_con, p_prm) ->
      parser [: `(con, prm) when con = p_con && prm = p_prm :] -> prm ]
;

value make () =
  let kwd_table = Hashtbl.create 301 in
  {func = func kwd_table; using = using_token kwd_table;
   removing = removing_token kwd_table; tparse = tparse; text = text}
;