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
  | STRING1 of string
  | STRING2 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
    | STRING1 s    -> sf "STRING \"%s\"" s
    | STRING2 s    -> sf "STRING \"%s\"" s
                      (* here it's not %S since the string is already escaped *)
    | 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 | STRING1 s | STRING2 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 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


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

let in_comment = ref false

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))
 | '"' | "'" ->
     let start = L.lexeme_start lexbuf in
     let double_quote = L.latin1_lexeme_char lexbuf 0 = '"' in
     string (L.lexeme_start lexbuf) double_quote lexbuf;
     let s = get_stored_string () in
     return_loc start (L.lexeme_end lexbuf)
       (if double_quote then STRING2 s else STRING1 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 comment start = lexer
  | "(*" ->
      comment (L.lexeme_start lexbuf) lexbuf;
      comment start lexbuf
  | "*)" ->
      ()
  | '"' | "'" ->
      let double_quote = L.latin1_lexeme_char lexbuf 0 = '"' in
      string (L.lexeme_start lexbuf) double_quote lexbuf;
      clear_buff ();
      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 double = lexer
  | '"' | "'" ->
      let d = L.latin1_lexeme_char lexbuf 0 = '"' in
      if d != double then (store_lexeme lexbuf; string start double lexbuf)
  | '\\' ['\\' '"' '\''] ->
      store_ascii (L.latin1_lexeme_char lexbuf 1);
      string start double lexbuf
  | "\\n" -> 
      store_ascii '\n';	string start double lexbuf
  | "\\t" -> 
      store_ascii '\t';	string start double lexbuf
  | "\\r" -> 
      store_ascii '\r';	string start double lexbuf
  | '\\' ['0'-'9']+ ';' ->
      store_code (parse_char lexbuf 10 1);
      string start double lexbuf
  | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F']+ ';' ->
      store_code (parse_char lexbuf 16 2);
      string start double lexbuf
  | '\\' ->
      illegal lexbuf;
  | eof ->
      error start (start+1) "Unterminated string"
  | _ ->
      store_lexeme lexbuf;
      string start double 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
