ulexer.ml

open Camlp4.PreCast

module Loc = struct
  type t = int * int

  let mk _ = (0,0)
  let ghost = (-1,-1)

  let of_lexing_position _ = assert false
  let to_ocaml_location _ = assert false
  let of_ocaml_location _ = assert false
  let of_lexbuf _ = assert false
  let of_tuple _ = assert false
  let to_tuple _ = assert false

  let merge (x1, x2) (y1, y2) = (min x1 y1, max x2 y2)
  let join (x1, _) = (x1, x1)
  let move _ _ _ = assert false
  let shift _ _ = assert false
  let move_line _ _ = assert false
  let file_name  _ = assert false
  let start_line _ = assert false
  let stop_line  _ = assert false
  let start_bol  _ = assert false
  let stop_bol   _ = assert false
  let start_off  = fst
  let stop_off   = snd
  let start_pos  _ = assert false
  let stop_pos   _ = assert false
  let is_ghost   _ = assert false
  let ghostify   _ = assert false
  let set_file_name _ = assert false
  let strictly_before _ = assert false
  let make_absolute _ = assert false
  let print _ = assert false
  let dump  _ = assert false
  let to_string _ = assert false
  exception Exc_located of t * exn
  let raise loc exn =
    match exn with
    | Exc_located _ -> raise exn
    | _ -> raise (Exc_located (loc, exn))
  let name = ref "_loc"
end

type token =
  | KEYWORD of string
  | IDENT of string
  | ANY_IN_NS of string
  | INT of string
  | CHAR of string
  | STRING of string
  | STRING2 of string
  | PTYPE of string
  | EOI

module Token = struct
  open Format
  module Loc = Loc
  type t = token
  type token = t

  let sf = Printf.sprintf

  let to_string =
    function
    | KEYWORD s -> sf "KEYWORD %S" s
    | IDENT s -> sf "IDENT %S" s
    | INT s -> sf "INT %s" s
    | CHAR s -> sf "CHAR \'%s\'" s
    | STRING s -> sf "STRING \"%s\"" s
    | STRING2 s -> sf "STRING \'%s\'" s
                      (* here it's not %S since the string is already escaped *)
    | PTYPE s -> sf "PTYPE \'%S\'" s
    | ANY_IN_NS s -> sf "ANY_IN_NS %S" s
    | EOI -> sf "EOI"

  let print ppf x = pp_print_string ppf (to_string x)

  let match_keyword kwd =
    function
    | KEYWORD kwd' when kwd = kwd' -> true
    | _ -> false

  let extract_string =
    function
      | KEYWORD s | IDENT s | INT s | CHAR s | STRING s | STRING2 s | PTYPE s |
	  ANY_IN_NS s -> s
      | tok ->
        invalid_arg ("Cannot extract a string from this token: "^
                     to_string tok)

  module Error = struct
    type t = string
    exception E of string
    let print = pp_print_string
    let to_string x = x
  end

  module Filter = struct
    type token_filter = (t, Loc.t) Camlp4.Sig.stream_filter

    type t =
      { is_kwd : string -> bool;
        mutable filter : token_filter }

    let keyword_conversion tok is_kwd =
      match tok with
      | IDENT s when is_kwd s -> KEYWORD s
      | _ -> tok

    let mk is_kwd =
      { is_kwd = is_kwd;
        filter = (fun s -> s) }

    let filter x =
      let f tok loc =
        let tok' = keyword_conversion tok x.is_kwd in
        (tok', loc)
      in
      let rec filter =
        parser
        | [< '(tok, loc); s >] -> [< ' f tok loc; filter s >]
        | [< >] -> [< >]
      in
      fun strm -> x.filter (filter strm)

    let define_filter x f = x.filter <- f x.filter

    let keyword_added _ _ _ = ()
    let keyword_removed _ _ = ()
  end

end
module Error = Camlp4.Struct.EmptyError

module L = Ulexing

exception Error of int * int * string

let toplevel = ref false

let error i j s = raise (Error (i,j,s))

(* Buffer for string literals *)

let string_buff = Buffer.create 1024

let store_lexeme lexbuf =
  Buffer.add_string string_buff (Ulexing.utf8_lexeme lexbuf)
let store_ascii = Buffer.add_char string_buff
let store_code  = Utf8.store string_buff
let clear_buff () = Buffer.clear string_buff
let get_stored_string () =
  let s = Buffer.contents string_buff in
  clear_buff ();
  Buffer.clear string_buff;
  s

let enc = ref L.Latin1

(* Parse characters literals \123; \x123; *)

let hexa_digit = function
  | '0'..'9' as c -> (Char.code c) - (Char.code '0')
  | 'a'..'f' as c -> (Char.code c) - (Char.code 'a') + 10
  | 'A'..'F' as c -> (Char.code c) - (Char.code 'A') + 10
  | _ -> -1

let parse_char lexbuf base i =
  let s = L.latin1_sub_lexeme lexbuf i (L.lexeme_length lexbuf - i - 1) in
  let r = ref 0 in
  for i = 0 to String.length s - 1 do
    let c = hexa_digit s.[i] in
    if (c >= base) || (c < 0) then
      error (L.lexeme_start lexbuf) (L.lexeme_end lexbuf) "invalid digit";
    r := !r * base + c;
  done;
  !r


let regexp ncname_char =
  xml_letter | xml_digit | [ '-' '_' ] | xml_combining_char | xml_extender | "\\."
let regexp ncname = ( xml_letter ncname_char* ) | ('_' ncname_char+)
let regexp qname = (ncname ':')? ncname

(* Should be [^ xml_letter ] *)
let regexp not_xml_letter = [^ 'A'-'Z' 'a'-'z' '0'-'9' '_' ]

let illegal lexbuf =
  error
    (L.lexeme_start lexbuf)
    (L.lexeme_end lexbuf)
    "Illegal character"

let in_comment = ref false
let in_brackets = ref 0

let return lexbuf tok = (tok, L.loc lexbuf)
let return_loc i j tok = (tok, (i,j))

let rec token = lexer
 | xml_blank+ -> token lexbuf
 | qname ->
     let s = L.utf8_lexeme lexbuf in
     return lexbuf (IDENT s)
 | ncname ":*" ->
     let s = L.utf8_sub_lexeme lexbuf 0 (L.lexeme_length lexbuf - 2) in
     return lexbuf (ANY_IN_NS s)
 | ".:*" ->
     return lexbuf (ANY_IN_NS "")
 | '-'? ['0'-'9']+ ->
     return lexbuf (INT (L.utf8_lexeme lexbuf))
 | [ "<>=.,:;+-*/@&{}()|?`!$" ]
 | "->" | "::" | ";;" | "--" | "//" | "/@" | ":=" | "\\" | "++"
 | "<=" | ">=" | "<<" | ">>" | "||" | "&&" | "**" | "_"
 | ".."
 | ["?+*"] "?" | "#" ->
     return lexbuf (KEYWORD (L.utf8_lexeme lexbuf))
 | "[" -> in_brackets := !in_brackets + 1;
     return lexbuf (KEYWORD (L.utf8_lexeme lexbuf))
 | "]" -> in_brackets := !in_brackets - 1;
     return lexbuf (KEYWORD (L.utf8_lexeme lexbuf))
 | '"' ->
     let start = L.lexeme_start lexbuf in
     string (L.lexeme_start lexbuf) '"' lexbuf;
     let s = get_stored_string () in
     return_loc start (L.lexeme_end lexbuf) (STRING s)
 | "'" "\\"? _ "'" ->
     L.rollback lexbuf;
     (fun _ -> lexer
	 | "'" -> let start = L.lexeme_start lexbuf in
		  string (L.lexeme_start lexbuf) '\'' lexbuf;
		  let s = get_stored_string () in
		  return_loc start (L.lexeme_end lexbuf) (CHAR s)
	 | _ -> assert false) () lexbuf
 | "'" ncname ->
     let s = L.utf8_lexeme lexbuf in
     let s = String.sub s 1 (String.length s - 1) in
     return lexbuf (PTYPE s)
 | "(*" ->
     in_comment := true;
     comment (L.lexeme_start lexbuf) lexbuf;
     in_comment := false;
     token lexbuf
 | "/*" ->
     in_comment := true;
     tcomment (L.lexeme_start lexbuf) lexbuf;
     in_comment := false;
     token lexbuf
 | eof ->
     return lexbuf EOI
 | _ ->
     illegal lexbuf

and token2 = lexer
 | xml_blank+ -> token2 lexbuf
 | qname ->
     let s = L.utf8_lexeme lexbuf in
     return lexbuf (IDENT s)
 | ncname ":*" ->
     let s = L.utf8_sub_lexeme lexbuf 0 (L.lexeme_length lexbuf - 2) in
     return lexbuf (ANY_IN_NS s)
 | ".:*" ->
     return lexbuf (ANY_IN_NS "")
 | '-'? ['0'-'9']+ ->
     return lexbuf (INT (L.utf8_lexeme lexbuf))
 | [ "<>=.,:;+-*/@&{}()|?`!$" ]
 | "->" | "::" | ";;" | "--" | "//" | "/@" | ":=" | "\\" | "++"
 | "<=" | ">=" | "<<" | ">>" | "||" | "&&" | "**" | "_"
 | ".."
 | ["?+*"] "?" | "#" ->
     return lexbuf (KEYWORD (L.utf8_lexeme lexbuf))
 | "[" -> in_brackets := !in_brackets + 1;
     return lexbuf (KEYWORD (L.utf8_lexeme lexbuf))
 | "]" -> in_brackets := !in_brackets - 1;
     return lexbuf (KEYWORD (L.utf8_lexeme lexbuf))
 | '"' ->
     let start = L.lexeme_start lexbuf in
     string (L.lexeme_start lexbuf) '"' lexbuf;
     let s = get_stored_string () in
     return_loc start (L.lexeme_end lexbuf) (STRING s)
 | "'" "\\"? _ "'--'" "\\"? _ "'"
 | "'" [^ '\'']+ "'" not_xml_letter ->
     L.rollback lexbuf;
     (fun _ -> lexer
	 | "'" -> let start = L.lexeme_start lexbuf in
		  string (L.lexeme_start lexbuf) '\'' lexbuf;
		  let s = get_stored_string () in
		  return_loc start (L.lexeme_end lexbuf) (STRING2 s)
	 | _ -> assert false) () lexbuf
 | "'" ncname ->
     let s = L.utf8_lexeme lexbuf in
     let s = String.sub s 1 (String.length s - 1) in
     return lexbuf (PTYPE s)
 | "(*" ->
     in_comment := true;
     comment (L.lexeme_start lexbuf) lexbuf;
     in_comment := false;
     token2 lexbuf
 | "/*" ->
     in_comment := true;
     tcomment (L.lexeme_start lexbuf) lexbuf;
     in_comment := false;
     token2 lexbuf
 | eof ->
     return lexbuf EOI
 | _ ->
     illegal lexbuf

and token2toplevel = lexer
 | xml_blank+ -> token2toplevel lexbuf
 | qname ->
     let s = L.utf8_lexeme lexbuf in
     return lexbuf (IDENT s)
 | ncname ":*" ->
     let s = L.utf8_sub_lexeme lexbuf 0 (L.lexeme_length lexbuf - 2) in
     return lexbuf (ANY_IN_NS s)
 | ".:*" ->
     return lexbuf (ANY_IN_NS "")
 | '-'? ['0'-'9']+ ->
     return lexbuf (INT (L.utf8_lexeme lexbuf))
 | [ "<>=.,:;+-*/@&{}()|?`!$" ]
 | "->" | "::" | ";;" | "--" | "//" | "/@" | ":=" | "\\" | "++"
 | "<=" | ">=" | "<<" | ">>" | "||" | "&&" | "**" | "_"
 | ".."
 | ["?+*"] "?" | "#" ->
     return lexbuf (KEYWORD (L.utf8_lexeme lexbuf))
 | "[" -> in_brackets := !in_brackets + 1;
     return lexbuf (KEYWORD (L.utf8_lexeme lexbuf))
 | "]" -> in_brackets := !in_brackets - 1;
     return lexbuf (KEYWORD (L.utf8_lexeme lexbuf))
 | '"' ->
     let start = L.lexeme_start lexbuf in
     string (L.lexeme_start lexbuf) '"' lexbuf;
     let s = get_stored_string () in
     return_loc start (L.lexeme_end lexbuf) (STRING s)
 | "'" "\\"? _ "'--'" "\\"? _ "'"
 | "'" ((";"[^ ";'"]) | [^ ";'"])* ";"? "'" not_xml_letter ->
     L.rollback lexbuf;
     (fun _ -> lexer
	 | "'" -> let start = L.lexeme_start lexbuf in
		  string (L.lexeme_start lexbuf) '\'' lexbuf;
		  let s = get_stored_string () in
		  return_loc start (L.lexeme_end lexbuf) (STRING2 s)
	 | _ -> assert false) () lexbuf
 | "'" ncname ->
     let s = L.utf8_lexeme lexbuf in
     let s = String.sub s 1 (String.length s - 1) in
     return lexbuf (PTYPE s)
 | "(*" ->
     in_comment := true;
     comment (L.lexeme_start lexbuf) lexbuf;
     in_comment := false;
     token2toplevel lexbuf
 | "/*" ->
     in_comment := true;
     tcomment (L.lexeme_start lexbuf) lexbuf;
     in_comment := false;
     token2toplevel lexbuf
 | eof ->
     return lexbuf EOI
 | _ ->
     illegal lexbuf

and comment start = lexer
  | "(*" ->
      comment (L.lexeme_start lexbuf) lexbuf;
      comment start lexbuf
  | "*)" ->
      ()
  | eof ->
      error start (start+2) "Unterminated comment"
  | _ ->
      comment start lexbuf

and tcomment start = lexer
  | "*/" ->
      ()
  | eof ->
      error start (start+2) "Unterminated comment"
  | _ ->
      tcomment start lexbuf

and string start endchar = lexer
  | '"' -> if endchar = '"' then ()
    else (store_lexeme lexbuf; string start endchar lexbuf)
  | "'" -> if endchar = '\'' then ()
    else (store_lexeme lexbuf; string start endchar lexbuf)
  | '\\' ['\\' '"' '\''] ->
    store_ascii (L.latin1_lexeme_char lexbuf 1); string start endchar lexbuf
  | "\\n" -> store_ascii '\n'; string start endchar lexbuf
  | "\\t" -> store_ascii '\t'; string start endchar lexbuf
  | "\\r" -> store_ascii '\r'; string start endchar lexbuf
  | '\\' ['0'-'9']+ ';' ->
    store_code (parse_char lexbuf 10 1); string start endchar lexbuf
  | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F']+ ';' ->
      store_code (parse_char lexbuf 16 2); string start endchar lexbuf
  | '\\' -> illegal lexbuf;
  | eof -> error start (start+1) "Unterminated string"
  | _ -> store_lexeme lexbuf; string start endchar lexbuf

let token lexbuf = if !in_brackets = 0 then token lexbuf
  else if !toplevel then token2toplevel lexbuf else token2 lexbuf

let lexbuf = ref None
let last_tok = ref (KEYWORD "DUMMY")

let rec sync lb =
  match !last_tok with
  | KEYWORD ";;" | EOI -> ()
  | _ -> last_tok := fst (token lb); sync lb

let raise_clean e =
  clear_buff ();
  in_comment := false;
  (* reinit encoding ? *)
  raise e

let mk () _FIXME_loc cs =
  let lb = L.from_var_enc_stream enc cs in
  (lexer ("#!" [^ '\n']* "\n")? -> ()) lb;
  lexbuf := Some lb;
  let next _ =
    let tok, loc =
      try token lb
      with
	| Ulexing.Error ->
	    raise_clean (Error (Ulexing.lexeme_end lb, Ulexing.lexeme_end lb,
			  "Unexpected character"))
	| Ulexing.InvalidCodepoint i ->
	    raise_clean (Error (Ulexing.lexeme_end lb, Ulexing.lexeme_end lb,
			  "Code point invalid for the current encoding"))
	| e -> raise_clean e
    in
    last_tok := tok;
    Some (tok, loc)
  in
  Stream.from next

let dump_file f =
  let ic = open_in f in
  let lexbuf = L.from_var_enc_channel enc ic in
  (try
     while true do
       let (tok,_) = token lexbuf in
       Format.printf "%a@." Token.print tok;
       if tok = EOI then exit 0
     done
   with
     | Ulexing.Error ->
	 Printf.eprintf "Lexing error at offset %i\n:Unexpected character\n"
	   (Ulexing.lexeme_end lexbuf)
     | Error (i,j,s) ->
	 Printf.eprintf "Lexing error at offset %i-%i:\n%s\n"
	   i j s
     | Ulexing.InvalidCodepoint i ->
	 Printf.eprintf "Lexing error at offset %i\n:Invalid code point for the current encoding\n"
	   (Ulexing.lexeme_end lexbuf)
  );
  close_in ic