(****************************************************************************)
(*                                                                          *)
(*                                   OCaml                                  *)
(*                                                                          *)
(*                            INRIA Rocquencourt                            *)
(*                                                                          *)
(*  Copyright  2006   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 LICENSE at the top of the Camlp4      *)
(*  source tree.                                                            *)
(*                                                                          *)
(****************************************************************************)

(* Authors:
 * - Nicolas Pouillard: initial version
 *)

open Format;

module Make (Loc : Sig.Loc)
: Sig.Camlp4Token with module Loc = Loc
= struct
  module Loc  = Loc;
  open Sig;
  type t = camlp4_token;
  type token = t;

  value to_string =
    fun
    [ KEYWORD s    -> sprintf "KEYWORD %S" s
    | SYMBOL s     -> sprintf "SYMBOL %S" s
    | LIDENT s     -> sprintf "LIDENT %S" s
    | UIDENT s     -> sprintf "UIDENT %S" s
    | INT _ s      -> sprintf "INT %s" s
    | INT32 _ s    -> sprintf "INT32 %sd" s
    | INT64 _ s    -> sprintf "INT64 %sd" s
    | NATIVEINT _ s-> sprintf "NATIVEINT %sd" s
    | FLOAT _ s    -> sprintf "FLOAT %s" s
    | CHAR _ s     -> sprintf "CHAR '%s'" s
    | STRING _ s   -> sprintf "STRING \"%s\"" s
                      (* here it's not %S since the string is already escaped *)
    | LABEL s      -> sprintf "LABEL %S" s
    | OPTLABEL s   -> sprintf "OPTLABEL %S" s
    | ANTIQUOT n s -> sprintf "ANTIQUOT %s: %S" n s
    | QUOTATION x  -> sprintf "QUOTATION { q_name=%S; q_loc=%S; q_shift=%d; q_contents=%S }"
                        x.q_name x.q_loc x.q_shift x.q_contents
    | COMMENT s    -> sprintf "COMMENT %S" s
    | BLANKS s     -> sprintf "BLANKS %S" s
    | NEWLINE      -> sprintf "NEWLINE"
    | EOI          -> sprintf "EOI"
    | ESCAPED_IDENT s -> sprintf "ESCAPED_IDENT %S" s
    | LINE_DIRECTIVE i None -> sprintf "LINE_DIRECTIVE %d" i
    | LINE_DIRECTIVE i (Some s) -> sprintf "LINE_DIRECTIVE %d %S" i s ];

  value print ppf x = pp_print_string ppf (to_string x);

  value match_keyword kwd =
    fun
    [ KEYWORD kwd' when kwd = kwd' -> True
    | _ -> False ];

  value extract_string =
    fun
    [ KEYWORD s | SYMBOL s | LIDENT s | UIDENT s | INT _ s | INT32 _ s |
      INT64 _ s | NATIVEINT _ s | FLOAT _ s | CHAR _ s | STRING _ s |
      LABEL s | OPTLABEL s | COMMENT s | BLANKS s | ESCAPED_IDENT s -> s
    | tok ->
        invalid_arg ("Cannot extract a string from this token: "^
                     to_string tok) ];

  module Error = struct
    type t =
      [ Illegal_token of string
      | Keyword_as_label of string
      | Illegal_token_pattern of string and string
      | Illegal_constructor of string ];

    exception E of t;

    value print ppf =
      fun
      [ Illegal_token s ->
          fprintf ppf "Illegal token (%s)" s
      | Keyword_as_label kwd ->
          fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
      | Illegal_token_pattern p_con p_prm ->
          fprintf ppf "Illegal token pattern: %s %S" p_con p_prm
      | Illegal_constructor con ->
          fprintf ppf "Illegal constructor %S" con ];

    value to_string x =
      Format.asprintf "%a" print x;
  end;
  let module M = ErrorHandler.Register Error in ();

  module Filter = struct
    type token_filter = stream_filter t Loc.t;

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

    value err error loc =
      raise (Loc.Exc_located loc (Error.E error));

    value keyword_conversion tok is_kwd =
      match tok with
      [ SYMBOL s | LIDENT s | UIDENT s when is_kwd s -> KEYWORD s
      | ESCAPED_IDENT s -> LIDENT s
      | _ -> tok ];

    value check_keyword_as_label tok loc is_kwd =
      let s =
        match tok with
        [ LABEL s         -> s
        | OPTLABEL s      -> s
        | _               -> "" ]
      in if s <> "" && is_kwd s then err (Error.Keyword_as_label s) loc else ();

    value check_unknown_keywords tok loc =
      match tok with
      [ SYMBOL s -> err (Error.Illegal_token s) loc
      | _        -> () ];

    value error_no_respect_rules p_con p_prm =
      raise (Error.E (Error.Illegal_token_pattern p_con p_prm));

    value check_keyword _ = True;
      (* FIXME let lb = Lexing.from_string s in
      let next () = token default_context lb in
      try
        match next () with
        [ SYMBOL _ | UIDENT _ | LIDENT _ -> (next () = EOI)
        | _ -> False ]
      with [ Stream.Error _ -> False ];                        *)

    value error_on_unknown_keywords = ref False;

    value rec ignore_layout =
      parser
      [ [: `(COMMENT _ | BLANKS _ | NEWLINE | LINE_DIRECTIVE _ _, _); s :] ->
          ignore_layout s
      | [: ` x; s :] -> [: ` x; ignore_layout s :]
      | [: :] -> [: :] ];

    value mk is_kwd =
      { is_kwd = is_kwd;
        filter = ignore_layout };

    value filter x =
      let f tok loc = do {
        let tok = keyword_conversion tok x.is_kwd;
        check_keyword_as_label tok loc x.is_kwd;
        if error_on_unknown_keywords.val
        then check_unknown_keywords tok loc else ();
        debug token "@[<hov 2>Lexer before filter:@ %a@ at@ %a@]@."
                    print tok Loc.dump loc in
        (tok, loc)
      } in
      let rec filter =
        parser
        [ [: `(tok, loc); s :] -> [: ` f tok loc; filter s :]
        | [: :] -> [: :] ]
      in
      let rec tracer = (* FIXME add a debug block construct *)
        parser
        [ [: `((_tok, _loc) as x); xs :] ->
            debug token "@[<hov 2>Lexer after filter:@ %a@ at@ %a@]@."
                        print _tok Loc.dump _loc in
            [: ` x; tracer xs :]
        | [: :] -> [: :] ]
      in fun strm -> tracer (x.filter (filter strm));

    value define_filter x f = x.filter := f x.filter;

    value keyword_added _ _ _ = ();
    value keyword_removed _ _ = ();
  end;

end;

(* Char and string tokens to real chars and string *)
module Eval = struct

  value valch x = Char.code x - Char.code '0';
  value valch_hex x =
    let d = Char.code x in
    if d >= 97 then d - 87
    else if d >= 65 then d - 55
    else d - 48;

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

  value skip_opt_linefeed = parser
    [ [: `'\010' :] -> ()
    | [: :] -> () ];

  value chr c =
    if c < 0 || c > 255 then failwith "invalid char token" else Char.chr c;

  value rec backslash = parser
    [ [: `'\010' :] -> '\010'
    | [: `'\013' :] -> '\013'
    | [: `'n' :]  -> '\n'
    | [: `'r' :]  -> '\r'
    | [: `'t' :]  -> '\t'
    | [: `'b' :]  -> '\b'
    | [: `'\\' :] -> '\\'
    | [: `'"' :]  -> '"'
    | [: `'\'' :]  -> '\''
    | [: `' ' :]  -> ' '
    | [: `('0'..'9' as c1); `('0'..'9' as c2); `('0'..'9' as c3) :] ->
        chr (100 * (valch c1) + 10 * (valch c2) + (valch c3))
    | [: `'x'; `('0'..'9' | 'a'..'f' | 'A'..'F' as c1) ;
              `('0'..'9' | 'a'..'f' | 'A'..'F' as c2) :] ->
        chr (16 * (valch_hex c1) + (valch_hex c2)) ];

  value rec backslash_in_string strict store = parser
    [ [: `'\010'; s :] -> skip_indent s
    | [: `'\013'; s :] -> do { skip_opt_linefeed s; skip_indent s }
    | [: x = backslash :] -> store x
    | [: `c when not strict :] -> do { store '\\'; store c }
    | [: :] -> failwith "invalid string token" ];

  value char s =
    if String.length s = 1 then s.[0]
    else if String.length s = 0 then failwith "invalid char token"
    else match Stream.of_string s with parser
        [ [: `'\\'; x = backslash :] -> x
        | [: :] -> failwith "invalid char token" ];

  value string ?strict s =
    let buf = Buffer.create 23 in
    let store = Buffer.add_char buf in
    let rec parse = parser
      [ [: `'\\'; _ = backslash_in_string (strict <> None) store; s :] -> parse s
      | [: `c; s :] -> do { store c; parse s }
      | [: :] -> Buffer.contents buf ]
    in parse (Stream.of_string s);
end;
