{
(* (c) Microsoft Corporation 2005-2008.  *)
  
open Fslexast
open Fslexpars
open Internal.Utilities
open Internal.Utilities.Text.Lexing
open System.Text

let escape c = 
  match c with
  | '\\' -> '\\'
  | '\'' -> '\''
  | 'n' -> '\n'
  | 't' -> '\t'
  | 'b' -> '\b'
  | 'r' -> '\r'
  | c -> c

let lexeme (lexbuf : LexBuffer<char>) = new System.String(lexbuf.Lexeme)
let newline (lexbuf:LexBuffer<_>) = lexbuf.EndPos <- lexbuf.EndPos.NextLine

let unexpected_char lexbuf =
      failwith ("Unexpected character '"^(lexeme lexbuf)^"'")

let digit d = 
      if d >= '0' && d <= '9' then int32 d - int32 '0'   
      else failwith "digit" 

let hexdigit d = 
      if d >= '0' && d <= '9' then digit d 
      else if d >= 'a' && d <= 'f' then int32 d - int32 'a' + 10
      else if d >= 'A' && d <= 'F' then int32 d - int32 'A' + 10
      else failwithf "bad hexdigit: %c" d 

let trigraph c1 c2 c3 =
      char (digit c1 * 100 + digit c2 * 10 + digit c3)

let hexgraph c1 c2 =
      char (hexdigit c1 * 16 + hexdigit c2)

let unicodegraph_short (s:string) =
    if s.Length <> 4 then failwith "unicodegraph";
    char(hexdigit s.[0] * 4096 + hexdigit s.[1] * 256 + hexdigit s.[2] * 16 + hexdigit s.[3])

let unicodegraph_long (s:string) =
    if s.Length <> 8 then failwith "unicodegraph_long";
    let high = hexdigit s.[0] * 4096 + hexdigit s.[1] * 256 + hexdigit s.[2] * 16 + hexdigit s.[3] in 
    let low = hexdigit s.[4] * 4096 + hexdigit s.[5] * 256 + hexdigit s.[6] * 16 + hexdigit s.[7] in 
    if high = 0 then None, char low 
    else 
      (* A surrogate pair - see http://www.unicode.org/unicode/uni2book/ch03.pdf, section 3.7 *)
      Some (char(0xD800 + ((high * 0x10000 + low - 0x10000) / 0x400))),
      char(0xDF30 + ((high * 0x10000 + low - 0x10000) % 0x400))

} 

let letter = ['A'-'Z'] | ['a'-'z']
let digit = ['0'-'9']
let whitespace = [' ' '\t']
let char = '\'' ( [^'\\'] | ('\\' ( '\\' | '\'' | "\"" | 'n' | 't' | 'b' | 'r'))) '\''
let hex = ['0'-'9'] | ['A'-'F'] | ['a'-'f']
let hexgraph = '\\' 'x' hex hex
let trigraph = '\\' digit digit digit
let newline = ('\n' | '\r' '\n')
let ident_start_char = letter       
let ident_char = ( ident_start_char| digit | ['\'' '_'] )
let ident = ident_start_char ident_char*

let unicodegraph_short = '\\' 'u' hex hex hex hex
let unicodegraph_long =  '\\' 'U' hex hex hex hex hex hex hex hex

rule token = parse
 | "rule" {RULE }
 | "parse" {PARSE }
 | "eof" {EOF }
 | "let" {LET }
 | "and" {AND }
 | char
   { let s = lexeme lexbuf in 
     CHAR (if s.[1] = '\\' then escape s.[2] else s.[1])  }
 
 | '\'' trigraph '\''
   { let s = lexeme lexbuf in 
     CHAR (trigraph s.[2] s.[3] s.[4]) }
 
 | '\'' hexgraph '\''
   { let s = lexeme lexbuf in 
     CHAR (hexgraph s.[3] s.[4]) }
 
 | '\'' unicodegraph_short '\''
   { let s = lexeme lexbuf in 
     CHAR (unicodegraph_short s.[3..6]) }
 
 | '\'' unicodegraph_long '\''
   { let s = lexeme lexbuf in 
     match (unicodegraph_long s.[3..10]) with 
     | None, c -> CHAR(c)
     | Some _ , _ -> failwith "Unicode characters needing surrogate pairs are not yet supported by this tool" }
 
 | '\'' '\\' ['A'-'Z'] ['a'-'z'] '\''
   { let s = (lexeme lexbuf).[2..3] in 
     UNICODE_CATEGORY (s) }
     
 | '{' { let p = lexbuf.StartPos in code p (new StringBuilder 100) lexbuf }

 | '"' { string  lexbuf.StartPos (new StringBuilder 100) lexbuf }
 
 | whitespace+  { token lexbuf }
 | newline { newline lexbuf; token lexbuf }
 | ident_start_char ident_char* { IDENT (lexeme lexbuf) }
 | '|' { BAR }
 | '.' { DOT }
 | '+' { PLUS }
 | '*' { STAR }
 | '?' { QMARK }
 | '=' { EQUALS }
 | '[' { LBRACK }
 | ']' { RBRACK }
 | '(' { LPAREN }
 | ')' { RPAREN }
 | '_' { UNDERSCORE }
 | '^' { HAT }
 | '-' { DASH }
 | "(*" { ignore(comment lexbuf.StartPos lexbuf); token lexbuf }
 | "//" [^'\n''\r']* { token lexbuf }
 | _ { unexpected_char lexbuf }     
 | eof { EOF  }                                     
and string p buff = parse
 |  '\\' newline { newline lexbuf; string p buff lexbuf }
 |  '\\' ( '"' | '\\' | '\'' | 'n' | 't' | 'b' | 'r')
   { let _ = buff.Append (escape (lexeme lexbuf).[1]) in
     string p buff lexbuf } 
 | trigraph
   { let s = lexeme lexbuf in 
     let _ = buff.Append (trigraph s.[1] s.[2] s.[3]) in
     string p buff lexbuf  }
 | '"' { STRING (buff.ToString()) }
 | newline { newline lexbuf; 
             let _ = buff.Append System.Environment.NewLine in
             string p buff lexbuf }
 | (whitespace | letter | digit) +  
   { let _ = buff.Append (lexeme lexbuf) in 
     string p buff lexbuf }
 | eof { failwith (Printf.sprintf "end of file in string started at (%d,%d)" p.pos_lnum (p.pos_cnum - p.pos_bol))  }
 | _ { let _ = buff.Append (lexeme lexbuf).[0] in
       string p buff lexbuf }
and code p buff = parse
 | "}" { CODE (buff.ToString(), p) }
 | "{" { let _ = buff.Append (lexeme lexbuf) in 
         ignore(code p buff lexbuf); 
         let _ = buff.Append "}" in
         code p buff lexbuf }
 | '\\' ('"' | '\\')
   { let _ = buff.Append (lexeme lexbuf) in 
     code p buff lexbuf } 
 | "\"" { let _ = buff.Append (lexeme lexbuf) in 
          ignore(codestring buff lexbuf); 
          code p buff lexbuf }
 | newline { newline lexbuf; 
             let _ = buff.Append System.Environment.NewLine in
             code p buff lexbuf }
 | (whitespace | letter | digit) +  
   { let _ = buff.Append (lexeme lexbuf) in 
     code p buff lexbuf }
 | "//" [^'\n''\r']*
   { let _ = buff.Append (lexeme lexbuf) in
     code p buff lexbuf }
 | eof { EOF }
 | _ { let _ = buff.Append (lexeme lexbuf).[0] in
       code p buff lexbuf }

and codestring buff = parse
 |  '\\' ('"' | '\\')
   { let _ = buff.Append (lexeme lexbuf) in 
     codestring buff lexbuf } 
 | '"' { let _ = buff.Append (lexeme lexbuf) in 
         buff.ToString() }
 | newline { newline lexbuf; 
             let _ = buff.Append System.Environment.NewLine in
             codestring buff lexbuf }
 | (whitespace | letter | digit) +  
   { let _ = buff.Append (lexeme lexbuf) in 
     codestring buff lexbuf }
 | eof { failwith "unterminated string in code" }
 | _ { let _ = buff.Append (lexeme lexbuf).[0] in
       codestring buff lexbuf }

and comment p = parse
 |  char { comment p lexbuf } 
 | '"' { ignore(try string lexbuf.StartPos (new StringBuilder 100) lexbuf 
                with Failure s -> failwith (s ^ "\n" ^ Printf.sprintf "error while processing string nested in comment started at (%d,%d)" p.pos_lnum (p.pos_cnum - p.pos_bol))); 
         comment p lexbuf }
 | "(*" { ignore(try comment p lexbuf with Failure s -> failwith (s ^ "\n" ^ Printf.sprintf "error while processing nested comment started at (%d,%d)" p.pos_lnum (p.pos_cnum - p.pos_bol))); 
          comment p lexbuf }
 | newline { newline lexbuf; comment p lexbuf }
 | "*)" { () }
 | eof { failwith (Printf.sprintf "end of file in comment started at (%d,%d)" p.pos_lnum (p.pos_cnum - p.pos_bol))  }
 | [^ '\'' '(' '*' '\n' '\r' '"' ')' ]+  { comment p lexbuf }
 | _  { comment p lexbuf }