hcfg/lib/parser.ml

let rec split_at1 l n =
  if n = 0 then ([], l) else
  match l with
  | [] -> ([], [])
  | h :: t -> let (l1, l2) = split_at1 t (n-1) in (h :: l1, l2);;

let safe_hd xs =
  match xs with
    | [] -> None
    | x :: _ -> Some x

let safe_tl xs =
  match xs with
    | [] -> None
    | _ :: xs -> Some xs


let safe_list xs = 
  match List.length xs with
    | 0 -> (None, None)
    | 1 -> ((Some (List.hd xs)), None)
    | _ -> ((Some (List.hd xs)), Some(List.tl xs))

let list_skip xs n =
  match split_at1 xs n with
    | (_, tl) -> tl

let if_list_peek xs n v =
  match List.nth_opt xs n with
    | Some x -> x = v 
    | _ -> false

module Parser = struct
  include Token

  let split_with (l:Token.token_type list) left right =
    let f (length, level) (i, tk) =
      if level < 1 && i < length then 
        (i, level)
      else
        match tk with
        | a when Token.equal a left -> (length, level + 1)
        | a when Token.equal a right -> (length, level - 1)
        | _   -> (length, level)
    in
    match List.fold_left f (List.length l, 1) (List.mapi (fun i e -> (i,e)) l) with
      | (i, _) -> Some (split_at1 l i)

  module Obj = Map.Make(String);;

  type hvalue = 
    | INTEGER of int
    | FLOAT of float
    | STRING of string
    | BINARY of Bytes.t
    | BOOL of bool
    | NULL
    | ARRAY of hvalue List.t
    | OBJECT of hvalue Obj.t

  let rec equal a b = 
    match (a,b) with
      | (INTEGER a, INTEGER b) -> Int.equal a b
      | (FLOAT a, FLOAT b) -> Float.equal a b
      | (STRING a, STRING b) -> String.equal a b
      | (BINARY a, BINARY b) -> Bytes.equal a b
      | (BOOL a, BOOL b) -> Bool.equal a b
      | (NULL, NULL) -> true 
      | (ARRAY a, ARRAY b) -> List.equal equal a b
      | (OBJECT a, OBJECT b) -> Obj.equal equal a b
      | _ -> false 

  let stringify_bytes b = Bytes.fold_left (fun acc b -> acc ^ Printf.sprintf "\\x%2x" (Char.code b)) "" b

  let rec hvalue_to_string = function
    | INTEGER a -> "INTEGER: " ^ Int.to_string a
    | FLOAT a -> "INTEGER: " ^ Float.to_string a
    | STRING a -> "INTEGER: " ^ a
    | BINARY a -> "BINARY " ^ Bytes.fold_left (fun acc b -> acc ^ Printf.sprintf "\\x%2x" (Char.code b)) "" a
    | BOOL a -> "BOOL: " ^ Bool.to_string a
    | NULL -> "NULL"
    | ARRAY a -> "ARRAY [" ^ (String.concat ", " (List.map hvalue_to_string a)) ^ "]"
    | OBJECT a -> "OBJECT {" ^ (String.concat ", " (List.map (fun (k,v) -> k ^ ": (" ^ (hvalue_to_string v) ^ ")") (Obj.to_list a) )) ^ "}"
  
  let parse_primitive token =
    match token with
      | Token.INTEGER a -> INTEGER a
      | Token.FLOAT a -> FLOAT a
      | Token.STRING a -> STRING a
      | Token.BINARY a -> BINARY a
      | Token.BOOL a -> BOOL a
      | Token.NULL -> NULL
      | _ -> failwith "Not a primitive token"

  let print_token_array tokens =
    List.map Token.token_to_string tokens |> String.concat "; "
  

  let rec parse tokens =
    match safe_hd tokens with
      | Some(Token.INTEGER _ | Token.FLOAT _ | Token.STRING _ | Token.BINARY _  | Token.BOOL _ | Token.NULL as t) -> parse_primitive t
      | Some(Token.LBRACE) -> (match safe_tl tokens with
        | Some(tl) -> parse_object tl
        | _ -> failwith "Not a valid hcfg file")

      | Some(Token.LBRACKET) -> (match safe_tl tokens with
        | Some(tl) -> parse_arr tl
        | _ -> failwith "Not a valid hcfg file")
      | Some(Token.EOF) -> failwith "Empty tree"
      | _ -> failwith "Not a valid hcfg file"
  and parse_object tokens =
    let rec parse_object_i tkns acc =
      match safe_list tkns with
        | (Some hd, Some tl) -> (match hd with
          | Token.IDENT i when if_list_peek tl 0 Token.COLON -> (match List.nth_opt tl 1 with
            | Some(Token.INTEGER _ | Token.FLOAT _ | Token.STRING _ | Token.BINARY _ | Token.BOOL _ | Token.NULL as t) when if_list_peek tl 2 Token.COMMA -> let (_arr, rest) = split_at1 tl 3 in parse_object_i rest (Obj.add i (parse_primitive t) acc)
            | Some(Token.INTEGER _ | Token.FLOAT _ | Token.STRING _ | Token.BINARY _ | Token.BOOL _ | Token.NULL as t) when if_list_peek tl 2 Token.RBRACE -> let (_arr, rest) = split_at1 tl 2 in parse_object_i rest (Obj.add i (parse_primitive t) acc)
            | Some Token.LBRACKET -> (match split_with (list_skip tl 2) Token.LBRACKET Token.RBRACKET with 
              | Some (arr, rest) -> 
                parse_object_i (rest) (Obj.add i (parse_arr arr) acc)
              | None -> failwith "uhhh arr in obj")
            | Some Token.LBRACE -> (match split_with (list_skip tl 2) Token.LBRACE Token.RBRACE with 
              | Some (arr, rest) -> parse_object_i (rest) (Obj.add i (parse_object arr) acc)
              | None -> failwith "uhhh arr in obj")
            | _ -> "TODO: Unhandled token for object value" ^ Token.token_to_string hd ^ "(" ^ print_token_array tl ^ ")" |> failwith
          )
          | Token.COMMA when not (if_list_peek tl 0 Token.RBRACE) -> parse_object_i tl acc
          | Token.COMMA when if_list_peek tl 0 Token.RBRACE -> acc
          | Token.RBRACE -> acc
          | _ -> "TODO: Unhandled token in object: " ^ (Token.token_to_string hd) ^ " (" ^ (print_token_array tl) ^ ")"|> failwith)
        | (Some Token.RBRACE, _) -> acc
        | _ -> (String.concat ", " (List.map (fun (k,v) -> k ^ ": (" ^ (hvalue_to_string v) ^ ")") (Obj.to_list acc))) |> failwith
    in OBJECT (parse_object_i tokens (Obj.empty))
  and parse_arr tokens =
    let rec parse_arr_i tkns acc =
      match safe_list tkns with
        | (Some hd, Some tl) -> (match hd with
          | Token.INTEGER _ | Token.FLOAT _ | Token.STRING _ | Token.BINARY _ | Token.NULL as t -> (match safe_list tl with
            | (Some Token.COMMA, Some tl) -> (match safe_hd tl with
              | Some Token.EOF -> failwith "Unterminated Array"
              | Some Token.RBRACKET -> ((parse_primitive t) :: acc)
              | _ -> parse_arr_i tl ((parse_primitive t) :: acc)
            )
            | (Some Token.RBRACKET, _) -> ((parse_primitive t) :: acc)
            | (Some Token.EOF, _) -> failwith "Unterminated Array"
            | _ -> "Invalid Array (" ^ print_token_array tl ^ ")" |> failwith
          )
          | Token.LBRACKET -> (match split_with tl Token.LBRACKET Token.RBRACKET with 
            | Some (arr, rest) -> parse_arr_i (rest) (parse_arr arr :: acc)
            | None -> failwith "uhhh arr in arr")
          | Token.LBRACE -> (match split_with tl Token.LBRACE Token.RBRACE with 
            | Some (arr, rest) -> parse_arr_i (rest) (parse_object arr :: acc)
            | None -> failwith "uhhh obj in arr")
          | Token.RBRACKET -> acc
          | t ->  "TODO: Unhandled token in array: " ^ (Token.token_to_string t) ^ " (" ^ (print_token_array tl) ^ ")"|> failwith
          )
        | (Some Token.EOF, None) -> acc
        | (Some Token.RBRACKET, None) -> acc
        | _ -> "TODO: parse_arr (" ^ (print_token_array tkns) ^ ")"|> failwith
    in ARRAY (List.rev (parse_arr_i tokens []))
end