open Ast.Value exception Invalid_character of char exception Expected of char let invalid_char c = raise @@ Invalid_character c let expected c = raise @@ Expected c let either f g c = f c || g c let is_digit c = '0' <= c && c <= '9' let is_num = function | 'x' -> true | '.' -> true | c -> is_digit c let is_whitespace = function | ' ' | '\t' | '\n' -> true | _ -> false let is_alpha c = ('A' <= c && c <= 'Z') || ('a' <= c && c <= 'z') let is_ident_start = either is_alpha ((=) '_') let is_ident = either is_ident_start is_digit let expect_char c seq = match seq () with | Seq.Nil -> expected c | Seq.Cons (x, seq) -> if x = c then seq else expected c let expect_token str tok seq = let rec aux ts seq = match ts (), seq () with | Seq.Nil, _ -> Some seq | Seq.Cons _, Seq.Nil -> None | Seq.Cons (a, ts), Seq.Cons (b, seq) -> if a = b then aux ts seq else None in let str = String.to_seq str in aux str seq |> Option.map (fun s -> tok, s) let find_token seq = !Token.tokens |> List.find_map (fun (s, t) -> expect_token s t seq) (* same as take_while f seq, drop_while f seq *) let rec partition_while f seq = match seq () with | Seq.Nil -> Seq.empty, seq | Seq.Cons (x, seq) -> if f x then let n, s = partition_while f seq in Seq.cons x n, s else Seq.(empty, cons x seq) let tokenize str = let seq = String.to_seq str in let rec aux seq = let open Token in let open Seq in match seq () with | Nil -> empty | Cons (x, seq) -> (* skip whitespace *) if is_whitespace x then aux seq (* string *) else if x = '"' then let str, seq = partition_while ((<>) '"') seq in let str = String (String.of_seq str) in let seq = expect_char '"' seq in cons (Value str) (aux seq) (* number (int, float) *) else if is_digit x then let n, seq = partition_while is_num seq in let n = String.of_seq @@ cons x n in let n = if String.contains n '.' (* float *) then Float (float_of_string n) else Int (int_of_string n) in cons (Value n) (aux seq) (* idents *) else if is_ident_start x then let id, seq = partition_while is_ident seq in let id = String.of_seq @@ cons x id in cons (Ident id) (aux seq) (* tokens *) else match find_token @@ cons x seq with | None -> invalid_char x | Some (t, seq) -> cons t (aux seq) in aux seq