open Data
open Runtime_lib

let wrap_in_channel ic = new_vtrace @@ InChannel ic

let unwrap_in_channel { v_; _ } =
  match v_ with
  | InChannel ic -> ic
  | _ -> raise BombExn

let wrap_out_channel oc = new_vtrace @@ OutChannel oc

let unwrap_out_channel { v_; _ } =
  match v_ with
  | OutChannel oc -> oc
  | _ -> raise BombExn

let wrap_open_flag = function
  | Open_rdonly -> cc "Open_rdonly" 0
  | Open_wronly -> cc "Open_wronly" 1
  | Open_append -> cc "Open_append" 2
  | Open_creat -> cc "Open_creat" 3
  | Open_trunc -> cc "Open_trunc" 4
  | Open_excl -> cc "Open_excl" 5
  | Open_binary -> cc "Open_binary" 6
  | Open_text -> cc "Open_text" 7
  | Open_nonblock -> cc "Open_nonblock" 8

let unwrap_open_flag { v_; _ } =
  match v_ with
  | Constructor ("Open_rdonly", _, None) -> Open_rdonly
  | Constructor ("Open_wronly", _, None) -> Open_wronly
  | Constructor ("Open_append", _, None) -> Open_append
  | Constructor ("Open_creat", _, None) -> Open_creat
  | Constructor ("Open_trunc", _, None) -> Open_trunc
  | Constructor ("Open_excl", _, None) -> Open_excl
  | Constructor ("Open_binary", _, None) -> Open_binary
  | Constructor ("Open_text", _, None) -> Open_text
  | Constructor ("Open_nonblock", _, None) -> Open_nonblock
  | _ -> raise BombExn

let rec wrap_list wrapf = function
  | [] -> cc "[]" 0
  | x :: l ->
    new_vtrace @@ Constructor ("::", 0,
                         Some (new_vtrace @@ Tuple [ wrapf x; wrap_list wrapf l ]))

let rec unwrap_list unwrapf { v_; _ } =
  match v_ with
  | Constructor ("[]", _, None) -> []
  | Constructor ("::", _, Some arg) ->
    begin match arg.v_ with
      | Tuple [ x; l ] ->
         unwrapf x :: unwrap_list unwrapf l
      | _ -> raise BombExn
    end
  | _ -> raise BombExn

let unwrap_marshal_flag { v_; _ } =
  match v_ with
  | Constructor ("No_sharing", _, None) -> Marshal.No_sharing
  | Constructor ("Closures", _, None) -> Marshal.Closures
  | Constructor ("Compat_32", _, None) -> Marshal.Compat_32
  | _ -> raise BombExn

external open_descriptor_out
  :  int ->
  out_channel
  = "caml_ml_open_descriptor_out"

external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in"
external open_desc : string -> open_flag list -> int -> int = "caml_sys_open"
external close_desc: int -> unit = "caml_sys_close"

external set_out_channel_name
  :  out_channel ->
  string ->
  unit
  = "caml_ml_set_channel_name"

external out_channels_list
  :  unit ->
  out_channel list
  = "caml_ml_out_channels_list"

external unsafe_output
  :  out_channel ->
  bytes ->
  int ->
  int ->
  unit
  = "caml_ml_output_bytes"

external unsafe_output_string
  :  out_channel ->
  string ->
  int ->
  int ->
  unit
  = "caml_ml_output"

external set_in_channel_name
  :  in_channel ->
  string ->
  unit
  = "caml_ml_set_channel_name"

external unsafe_input
  :  in_channel ->
  bytes ->
  int ->
  int ->
  int
  = "caml_ml_input"

external format_int : string -> int -> string = "caml_format_int"
external format_float : string -> float -> string = "caml_format_float"
external random_seed : unit -> int array = "caml_sys_random_seed"

let seeded_hash_param meaningful total seed { v_; _ } =
  match v_ with
  | Bomb -> failwith "tried to hash 💣"
  | Hole _ -> failwith "tried to hash holeval"
  | Int n -> Hashtbl.seeded_hash_param meaningful total seed n
  | Int32 n -> Hashtbl.seeded_hash_param meaningful total seed n
  | Int64 n -> Hashtbl.seeded_hash_param meaningful total seed n
  | Nativeint n -> Hashtbl.seeded_hash_param meaningful total seed n
  | Float f -> Hashtbl.seeded_hash_param meaningful total seed f
  | Tuple _l -> 0
  | String s ->
    Hashtbl.seeded_hash_param meaningful total seed (Bytes.to_string s)
  | Constructor (c, _, _v) -> Hashtbl.seeded_hash_param meaningful total seed c
  | Object _ -> 0
  | Array _a -> 0
  | Record _r -> 0
  | Fexpr _ | Fun _ | Function _
  | InChannel _ | OutChannel _ | Prim _ | Lz _
  | ModVal _ | Fun_with_extra_args _ ->
    assert false
  | ExCall _ -> failwith "tried to hash ExCall"
  | ExDontCare -> failwith "tried to hash ExDontCare"

external digest_unsafe_string
  :  string ->
  int ->
  int ->
  string
  = "caml_md5_string"

external marshal_to_channel
  :  out_channel ->
  'a ->
  unit list ->
  unit
  = "caml_output_value"

external caml_output_value_to_string : 'a -> Marshal.extern_flags list -> string
  = "caml_output_value_to_string"

external append_prim : 'a array -> 'a array -> 'a array = "caml_array_append"
external input_scan_line : in_channel -> int = "caml_ml_input_scan_line"

external caml_int32_format : string -> int32 -> string = "caml_int32_format"
external caml_int64_format : string -> int64 -> string = "caml_int64_format"
external caml_nativeint_format : string -> nativeint -> string = "caml_nativeint_format"

external caml_sys_system_command: string -> int = "caml_sys_system_command"

open Data
open Runtime_lib

let wrap_in_channel ic = new_vtrace @@ InChannel ic

let unwrap_in_channel { v_; _ } =
  match v_ with
  | InChannel ic -> ic
  | _ -> raise BombExn

let wrap_out_channel oc = new_vtrace @@ OutChannel oc

let unwrap_out_channel { v_; _ } =
  match v_ with
  | OutChannel oc -> oc
  | _ -> raise BombExn

let wrap_open_flag = function
  | Open_rdonly -> cc "Open_rdonly" 0
  | Open_wronly -> cc "Open_wronly" 1
  | Open_append -> cc "Open_append" 2
  | Open_creat -> cc "Open_creat" 3
  | Open_trunc -> cc "Open_trunc" 4
  | Open_excl -> cc "Open_excl" 5
  | Open_binary -> cc "Open_binary" 6
  | Open_text -> cc "Open_text" 7
  | Open_nonblock -> cc "Open_nonblock" 8

let unwrap_open_flag { v_; _ } =
  match v_ with
  | Constructor ("Open_rdonly", _, None) -> Open_rdonly
  | Constructor ("Open_wronly", _, None) -> Open_wronly
  | Constructor ("Open_append", _, None) -> Open_append
  | Constructor ("Open_creat", _, None) -> Open_creat
  | Constructor ("Open_trunc", _, None) -> Open_trunc
  | Constructor ("Open_excl", _, None) -> Open_excl
  | Constructor ("Open_binary", _, None) -> Open_binary
  | Constructor ("Open_text", _, None) -> Open_text
  | Constructor ("Open_nonblock", _, None) -> Open_nonblock
  | _ -> raise BombExn

let rec wrap_list wrapf = function
  | [] -> cc "[]" 0
  | x :: l ->
    new_vtrace @@ Constructor ("::", 0,
                         Some (new_vtrace @@ Tuple [ wrapf x; wrap_list wrapf l ]))

let rec unwrap_list unwrapf { v_; _ } =
  match v_ with
  | Constructor ("[]", _, None) -> []
  | Constructor ("::", _, Some arg) ->
    begin match arg.v_ with
      | Tuple [ x; l ] ->
         unwrapf x :: unwrap_list unwrapf l
      | _ -> raise BombExn
    end
  | _ -> raise BombExn

let unwrap_marshal_flag { v_; _ } =
  match v_ with
  | Constructor ("No_sharing", _, None) -> Marshal.No_sharing
  | Constructor ("Closures", _, None) -> Marshal.Closures
  | Constructor ("Compat_32", _, None) -> Marshal.Compat_32
  | _ -> raise BombExn

external open_descriptor_out
  :  int ->
  out_channel
  = "caml_ml_open_descriptor_out"

external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in"
external open_desc : string -> open_flag list -> int -> int = "caml_sys_open"
external close_desc: int -> unit = "caml_sys_close"

external set_out_channel_name
  :  out_channel ->
  string ->
  unit
  = "caml_ml_set_channel_name"

external out_channels_list
  :  unit ->
  out_channel list
  = "caml_ml_out_channels_list"

external unsafe_output
  :  out_channel ->
  bytes ->
  int ->
  int ->
  unit
  = "caml_ml_output_bytes"

external unsafe_output_string
  :  out_channel ->
  string ->
  int ->
  int ->
  unit
  = "caml_ml_output"

external set_in_channel_name
  :  in_channel ->
  string ->
  unit
  = "caml_ml_set_channel_name"

external unsafe_input
  :  in_channel ->
  bytes ->
  int ->
  int ->
  int
  = "caml_ml_input"

external format_int : string -> int -> string = "caml_format_int"
external format_float : string -> float -> string = "caml_format_float"
external random_seed : unit -> int array = "caml_sys_random_seed"

let seeded_hash_param meaningful total seed { v_; _ } =
  match v_ with
  | Bomb -> failwith "tried to hash 💣"
  | Hole _ -> failwith "tried to hash holeval"
  | Int n -> Hashtbl.seeded_hash_param meaningful total seed n
  | Int32 n -> Hashtbl.seeded_hash_param meaningful total seed n
  | Int64 n -> Hashtbl.seeded_hash_param meaningful total seed n
  | Nativeint n -> Hashtbl.seeded_hash_param meaningful total seed n
  | Float f -> Hashtbl.seeded_hash_param meaningful total seed f
  | Tuple _l -> 0
  | String s ->
    Hashtbl.seeded_hash_param meaningful total seed (Bytes.to_string s)
  | Constructor (c, _, _v) -> Hashtbl.seeded_hash_param meaningful total seed c
  | Object _ -> 0
  | Array _a -> 0
  | Record _r -> 0
  | Fexpr _ | Fun _ | Function _
  | InChannel _ | OutChannel _ | Prim _ | Lz _
  | ModVal _ | Fun_with_extra_args _ ->
    assert false
  | ExCall _ -> failwith "tried to hash ExCall"
  | ExDontCare -> failwith "tried to hash ExDontCare"

external digest_unsafe_string
  :  string ->
  int ->
  int ->
  string
  = "caml_md5_string"

external marshal_to_channel
  :  out_channel ->
  'a ->
  unit list ->
  unit
  = "caml_output_value"

external caml_output_value_to_string : 'a -> Marshal.extern_flags list -> string
  = "caml_output_value_to_string"

external append_prim : 'a array -> 'a array -> 'a array = "caml_array_append"
external input_scan_line : in_channel -> int = "caml_ml_input_scan_line"

external caml_int32_format : string -> int32 -> string = "caml_int32_format"
external caml_int64_format : string -> int64 -> string = "caml_int64_format"
external caml_nativeint_format : string -> nativeint -> string = "caml_nativeint_format"

external caml_sys_system_command: string -> int = "caml_sys_system_command"
