(*
 * Copyright 2021 Damien Guichard
 *
 * Licensed under the EUPL-1.2-or-later
 *)

module Lex
:
sig
	type position
	type demand
	exception Demand_denied of position * demand
	class make :
		in_channel ->
		object
			method demand_int   : int
			method demand_float : float
			method demand_line  : unit
			method demand_position : position
			method demand_mono    : char -> unit
			method demand_name    : string
			method demand_string  : string
			method demand_word    : string -> unit			
			method granted_mono   : char -> bool
			method granted_word   : string -> bool
			method promised_int   : bool
			method promised_float : bool
			method promised_mono  : char -> bool
			method promised_name  : bool
		end
	val print_position : position -> unit
	val print_denied : demand -> unit
end
=
struct
	type position =
		{line: int; text: string; start: int; stop: int}
	type demand =
		| Word of string
		| Mono of char
		| Name
		| String
		| Int
	exception
		Demand_denied of position * demand
	type kind =
		| K_Word | K_Mono | K_Integer | K_Float
	class make file = 
		object (self)
			val mutable str = ""
			val mutable len = 0
			val mutable row = 0
			val mutable lex = K_Mono
			val mutable l = 0
			val mutable r = 0
			method private read_text =
				str <- input_line file; l <- 0; r <- 0;
				len <- String.length str; row <- row+1;
				if len > 1 && str.[0] = '/' && str.[1] = '/'
				then self#read_text 
			method private blank_space =
				if r >= len then (self#read_text; r <- r-1; true)
				else let c = str.[r] in c=' ' || c='\t' || c='\n'
			method private read_next =
				let upper_lower () =
					r < len && let c = str.[r] in
					c>='a' && c<='z' || c>='A' && c<='Z'
				and alpha_num () =
					r < len && 
					match str.[r] with
					| 'a'..'z' | 'A'..'Z' | '0'..'9' -> true
					| c -> String.contains "_-+=/@*&?|!²<>" c
				and ascii_num () =
					r < len && let c = str.[r] in
					c>='0' && c<='9'
				in
				while self#blank_space do r <- r+1 done;
				l <- r;
				lex <- match str.[l] with
				| c when upper_lower () ->
						while alpha_num () do r <- r+1 done;
						while str.[r-1] = '-' do r <- r-1 done;
						K_Word  
				| c when ascii_num () || c='-' ->
						if c='-' then r <- r+1;
						while ascii_num () do r <- r+1 done;
						if r < len && str.[r] = '.' then begin
							r <- r+1;
							while ascii_num () do r <- r+1 done;
							if r < len && str.[r] = 'e' then begin
								r <- r+1;
								if r < len && (str.[r]='+' || str.[r]='-')
								then r <- r+1;
								while ascii_num () do r <- r+1 done
							end;
							K_Float
						end else
							K_Integer 
				| c ->
						r <- r+1;
						K_Mono
			method private read_string =
				while r < len && str.[r] <> str.[l] do
					r <- r+1
				done;
				(r < len) && (r <- r+1; true)
			method private same_word s =
				String.length s = r - l &&
				let a = ref 0 and b = ref l in
				while !b < r && s.[!a] = str.[!b] do incr a; incr b done;
				!b = r
			method private raise_denied : 'a. demand -> 'a = fun demand -> 
				let position = {line = row; text = str; start = l; stop = r}
				in raise (Demand_denied(position,demand))
			(* demands *)
			method demand_line =
				self#read_text; self#read_next
			method demand_position =
				{line = row; text = str; start = l; stop = r}
			method demand_word s =
				match lex with
				| K_Word when self#same_word s -> self#read_next
				| _ -> self#raise_denied (Word s)
			method demand_mono c =
				match lex with
				| K_Mono when str.[l]=c -> self#read_next
				| _ -> self#raise_denied (Mono c)
			method demand_name =
				match lex with
				| K_Word ->
					let s = String.sub str l (r - l) in self#read_next; s
				| _ -> self#raise_denied Name
			method demand_string =
				match lex with
				| K_Mono when self#read_string ->
					let s = String.sub str (l+1) (r-l-2) in self#read_next; s
				| _ -> self#raise_denied String
			method demand_int =
				match lex with
				| K_Integer ->
					let n = int_of_string (String.sub str l (r - l))
					in self#read_next; n 
				| _ -> self#raise_denied Int
			method demand_float =
				let x = float_of_string (String.sub str l (r - l))
				in self#read_next; x 
			(* promises *)
			method promised_mono c =
				lex = K_Mono && str.[l]=c
			method promised_name =
				lex = K_Word 
			method promised_int =
				lex = K_Integer 
			method promised_float =
				lex = K_Float
			(* grants *)
			method granted_word s =
				match lex with
				| K_Word when self#same_word s -> self#read_next; true
				| _ -> false
			method granted_mono c =
				match lex with
				| K_Mono when str.[l]=c -> self#read_next; true
				| _ -> false
			initializer
				self#demand_line  
		end
	let print_position p =
		print_string "line: ";
		print_int    p.line;
		print_string " | erratum: ";
		print_string (String.sub p.text p.start (p.stop - p.start));
		print_string " | "
	let print_denied demand =
		print_string "expected: ";
		( match demand with
		| Word str -> print_string "keyword "; print_string str
		| Mono chr -> print_string "character "; print_char chr
		| Name     -> print_string "an identifier"
		| String   -> print_string "a string "
		| Int      -> print_string "an integer" );
		print_newline ()
end