exapunks_vm / lib / Host_parser.ml

(* This Source Code Form is subject to the terms of the Mozilla Public
   License, v. 2.0. If a copy of the MPL was not distributed with this
   file, You can obtain one at https://mozilla.org/MPL/2.0/. *)

open MParser

(* TYPES *)

module StrSet = Set.Make (String)

type parsed_host = string * int

and parsed_link = string * int * string

and parsed_file = {
  name : int;
  loc : string;
  contents : Value.t list;
}

and parsed_hardware_reg = {
  name : string;
  loc : string;
}

and parsed_f_objs =
  | File of parsed_file
  | Hard of parsed_hardware_reg

and parsed_environment = {
  name : string option;
  hosts : parsed_host list;
  links : parsed_link list;
  files : parsed_f_objs list;
}

and user_state = StrSet.t

(* PARSERS *)

let string_return str result = skip_string str >>$ result

let open_square = skip_string "[" << spaces

let close_square = spaces >> skip_string "]"

let open_curly = skip_string "{" << spaces

let close_curly = spaces >> skip_string "}"

let p_name = many1_chars alphanum

let host =
  spaces >> p_name >>= fun name ->
  get_user_state >>= fun s ->
  if StrSet.mem name s then fail "Can't define two hosts with same name"
  else
    update_user_state (fun s -> StrSet.add name s)
    >> spaces
    >> between open_square close_square digit
    >>= fun size ->
    spaces >> string ";" >> spaces >>$ (name, int_of_string (String.make 1 size))

let hosts = string "hosts" >> spaces1 >> between open_curly close_curly (many1 host)

let number =
  option (string "-") >>= fun neg ->
  many1_chars digit >>= fun num ->
  let num = int_of_string num in
  return (if Option.is_some neg then -num else num)

let p_link_int = between open_square close_square number

let p_link_both =
  p_name >>= fun host1 ->
  spaces >> p_link_int >>= fun link1 ->
  spaces1 >> skip_string "<->" >> spaces1 >> p_link_int >>= fun link2 ->
  spaces >> p_name |>> fun host2 -> [ (host1, link1, host2); (host2, link2, host1) ]

let p_link_forward =
  p_name >>= fun host1 ->
  spaces1 >> p_link_int >>= fun link1 ->
  spaces1 >> skip_string "->"
  >> (spaces1 >> p_name |>> fun host2 -> [ (host1, link1, host2) ])

let p_link_backward =
  p_name >>= fun host1 ->
  spaces1 >> skip_string "<-" >> spaces1 >> p_link_int >>= fun link2 ->
  spaces1 >> p_name |>> fun host2 -> [ (host2, link2, host1) ]

let p_link =
  choice [ p_link_both; p_link_forward; p_link_backward ] << spaces << skip_string ";"

let p_links =
  skip_string "links" >> spaces1
  >> between open_curly close_curly
       (many1 (spaces >> p_link << spaces) |>> fun links -> List.flatten links)
  << spaces

let p_file_contents =
  between open_square close_square
    ( spaces
    >> sep_end_by
         (choice [ number |>> Value.int; p_name |>> Value.key ])
         (string "," << spaces)
    << spaces
    |>> fun contents -> contents )

let p_file =
  number >>= fun name ->
  spaces >> between open_square close_square p_name >>= fun loc ->
  get_user_state >>= fun s ->
  let loc_name = string_of_int name ^ loc in
  if StrSet.mem loc_name s then fail "Can't define hardware register twice in one host"
  else
    update_user_state (fun s -> StrSet.add loc_name s)
    >> spaces >> skip_string ":" >> spaces >> p_file_contents
    >>= fun contents -> string ";" >> spaces >> return (File { name; loc; contents })

let p_hardware_name =
  string "#" >>= fun r ->
  many1_chars alphanum |>> fun name -> r ^ name

let p_hardware_register =
  p_hardware_name >>= fun name ->
  spaces >> between open_square close_square p_name >>= fun loc ->
  get_user_state >>= fun s ->
  let loc_name = name ^ loc in
  if StrSet.mem loc_name s then fail "Can't define hardware register twice in one host"
  else
    update_user_state (fun s -> StrSet.add loc_name s)
    >> string ";" >> spaces
    >> return (Hard { name; loc })

let p_file_alts = spaces >> choice [ p_file; p_hardware_register ]

let p_files =
  spaces >> skip_string "files" >> spaces1
  >> between open_curly close_curly (many1 p_file_alts |>> fun files -> files)

let environment : (parsed_environment, user_state) t =
  spaces >> skip_string "environment" >> option (many1_chars letter) >>= fun name ->
  spaces >> open_curly >> spaces >> option hosts << spaces >>= fun hosts ->
  spaces >> option p_links >>= fun links ->
  spaces >> option p_files >>= fun files ->
  close_curly
  >>
  let hosts = Option.value ~default:[] hosts in
  let links = Option.value ~default:[] links in
  let files = Option.value ~default:[] files in
  return { name; hosts; links; files }

(* PRINTING FUNCTIONS *)

let show_parsed_host ((name, size) : parsed_host) : string =
  Printf.sprintf "%s [%i];" name size

let show_parsed_link ((left, link, right) : parsed_link) : string =
  Printf.sprintf "%s [%i] -> %s;" left link right

let show_parsed_file file_obj : string =
  match file_obj with
  | File { name; loc; contents } ->
      Printf.sprintf "%i [%s]: [ %s ];" name loc
        (contents |> List.map Value.show |> String.concat ", ")
  | Hard { name; loc } -> Printf.sprintf "%s [%s];" name loc

let show_parsed_environment env =
  let hosts =
    env.hosts |> List.map (fun h -> "    " ^ show_parsed_host h) |> String.concat "\n"
  in
  let links =
    env.links |> List.map (fun h -> "    " ^ show_parsed_link h) |> String.concat "\n"
  in
  let files =
    env.files |> List.map (fun h -> "    " ^ show_parsed_file h) |> String.concat "\n"
  in
  [
    (*AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA*)
    Printf.sprintf "environment %s{"
      (match env.name with
      | None -> ""
      | Some n -> n ^ " ");
    (if List.is_empty env.hosts then "" else Printf.sprintf "  hosts {\n%s\n  }" hosts);
    (if List.is_empty env.links then "" else Printf.sprintf "  links {\n%s\n  }" links);
    (if List.is_empty env.files then "" else Printf.sprintf "  files {\n%s\n  }" files);
    "}";
    (*AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA*)
  ]
  |> List.filter (fun line -> line != "")
  |> String.concat "\n"