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 =
  | KWD of string
  | CHAR of char
  | EOI

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

  let sf = Printf.sprintf

  let to_string =
    function
    | CHAR s -> sf "CHAR %c" s
    | KWD s  -> sf "KWD \"%s\"" s
    | EOI    -> sf "EOI"

  let print ppf x = pp_print_string ppf (to_string x)

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

  let extract_string =
    function
    | KWD s -> s
    | CHAR c -> String.make 1 c 
    | 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 mk is_kwd =
      { is_kwd = is_kwd;
        filter = (fun s -> s) }

    let filter x =
      let f tok loc =
        let tok' = tok 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

(***********************************************************)
(* Lexer *)

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

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

let rec token = lexer 
 | [' ' '\t'] -> token lexbuf
 | ['*' '?' '+' '(' ')' ';' '|' ] ->
         let k = KWD (L.latin1_lexeme lexbuf) in return lexbuf k
 | ['A'-'Z' 'a'-'z'] -> 
         let c = CHAR (L.latin1_lexeme_char lexbuf 0) in return lexbuf c
 | eof -> return lexbuf EOI
 | _ -> illegal lexbuf


(***********************************************************)

let enc = ref L.Latin1
let lexbuf = ref None
let last_tok = ref (KWD "DUMMY")

let raise_clean e =
  clear_buff ();
  raise e

let mk () _loc cs =
  let lb = L.from_var_enc_stream enc cs in
  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