Source file writer.ml

(** GPX XML writer with complete spec coverage *)

(** Result binding operators *)
let (let*) = Result.bind

(** Helper to write XML elements *)
let output_element_start writer name attrs =
  try
    Xmlm.output writer (`El_start ((("", name), attrs)));
    Ok ()
  with exn ->
    Error (Error.xml_error (Printexc.to_string exn))

let output_element_end writer =
  try
    Xmlm.output writer `El_end;
    Ok ()
  with exn ->
    Error (Error.xml_error (Printexc.to_string exn))

let output_data writer text =
  try
    Xmlm.output writer (`Data text);
    Ok ()
  with exn ->
    Error (Error.xml_error (Printexc.to_string exn))

let output_text_element writer name text =
  let attrs = [] in
  let* () = output_element_start writer name attrs in
  let* () = output_data writer text in
  output_element_end writer

let output_optional_text_element writer name = function
  | Some text -> output_text_element writer name text
  | None -> Ok ()

let output_optional_float_element writer name = function
  | Some value -> output_text_element writer name (Printf.sprintf "%.6f" value)
  | None -> Ok ()

let output_optional_degrees_element writer name = function
  | Some degrees -> output_text_element writer name (Printf.sprintf "%.6f" (Coordinate.degrees_to_float degrees))
  | None -> Ok ()

let output_optional_int_element writer name = function
  | Some value -> output_text_element writer name (string_of_int value)
  | None -> Ok ()

let output_optional_time_element writer name = function
  | Some time -> output_text_element writer name (Ptime.to_rfc3339 time)
  | None -> Ok ()

let output_optional_fix_element writer name = function
  | Some fix_type -> output_text_element writer name (Waypoint.fix_type_to_string fix_type)
  | None -> Ok ()

(** Write link elements *)
let output_link writer link =
  let href = Link.href link in
  let attrs = [(("", "href"), href)] in
  let* () = output_element_start writer "link" attrs in
  let* () = output_optional_text_element writer "text" (Link.text link) in
  let* () = output_optional_text_element writer "type" (Link.type_ link) in
  output_element_end writer

let output_links writer links =
  let rec write_links = function
    | [] -> Ok ()
    | link :: rest ->
        let* () = output_link writer link in
        write_links rest
  in
  write_links links

(** Write person (author) element *)
let output_person writer person =
  let* () = output_element_start writer "author" [] in
  let* () = output_optional_text_element writer "name" (Link.person_name person) in
  let* () = match Link.person_email person with
    | Some email ->
        (* Parse email into id and domain *)
        (match String.index_opt email '@' with
         | Some at_pos ->
             let id = String.sub email 0 at_pos in
             let domain = String.sub email (at_pos + 1) (String.length email - at_pos - 1) in
             let attrs = [(("", "id"), id); (("", "domain"), domain)] in
             let* () = output_element_start writer "email" attrs in
             output_element_end writer
         | None ->
             (* Invalid email format, skip *)
             Ok ())
    | None -> Ok ()
  in
  let* () = match Link.person_link person with
    | Some link -> output_link writer link
    | None -> Ok ()
  in
  output_element_end writer

(** Write copyright element *)
let output_copyright writer copyright =
  let author = Link.copyright_author copyright in
  let attrs = [(("", "author"), author)] in
  let* () = output_element_start writer "copyright" attrs in
  let* () = output_optional_int_element writer "year" (Link.copyright_year copyright) in
  let* () = output_optional_text_element writer "license" (Link.copyright_license copyright) in
  output_element_end writer

(** Write bounds element *)
let output_bounds writer bounds =
  let (minlat, minlon, maxlat, maxlon) = Metadata.Bounds.bounds bounds in
  let attrs = [
    (("", "minlat"), Printf.sprintf "%.6f" (Coordinate.latitude_to_float minlat));
    (("", "minlon"), Printf.sprintf "%.6f" (Coordinate.longitude_to_float minlon));
    (("", "maxlat"), Printf.sprintf "%.6f" (Coordinate.latitude_to_float maxlat));
    (("", "maxlon"), Printf.sprintf "%.6f" (Coordinate.longitude_to_float maxlon));
  ] in
  let* () = output_element_start writer "bounds" attrs in
  output_element_end writer

(** Write extensions element *)
let output_extensions writer extensions =
  if extensions = [] then Ok ()
  else
    let* () = output_element_start writer "extensions" [] in
    (* For now, skip writing extension content - would need full extension serialization *)
    output_element_end writer

(** Write metadata element *)
let output_metadata writer metadata =
  let* () = output_element_start writer "metadata" [] in
  let* () = output_optional_text_element writer "name" (Metadata.name metadata) in
  let* () = output_optional_text_element writer "desc" (Metadata.description metadata) in
  let* () = match Metadata.author metadata with
    | Some author -> output_person writer author
    | None -> Ok ()
  in
  let* () = match Metadata.copyright metadata with
    | Some copyright -> output_copyright writer copyright
    | None -> Ok ()
  in
  let* () = output_links writer (Metadata.links metadata) in
  let* () = output_optional_time_element writer "time" (Metadata.time metadata) in
  let* () = output_optional_text_element writer "keywords" (Metadata.keywords metadata) in
  let* () = match Metadata.bounds_opt metadata with
    | Some bounds -> output_bounds writer bounds
    | None -> Ok ()
  in
  let* () = output_extensions writer (Metadata.extensions metadata) in
  output_element_end writer

(** Write waypoint elements (used for wpt, rtept, trkpt) *)
let output_waypoint_data writer waypoint =
  let* () = output_optional_float_element writer "ele" (Waypoint.elevation waypoint) in
  let* () = output_optional_time_element writer "time" (Waypoint.time waypoint) in
  let* () = output_optional_degrees_element writer "magvar" (Waypoint.magvar waypoint) in
  let* () = output_optional_float_element writer "geoidheight" (Waypoint.geoidheight waypoint) in
  let* () = output_optional_text_element writer "name" (Waypoint.name waypoint) in
  let* () = output_optional_text_element writer "cmt" (Waypoint.comment waypoint) in
  let* () = output_optional_text_element writer "desc" (Waypoint.description waypoint) in
  let* () = output_optional_text_element writer "src" (Waypoint.source waypoint) in
  let* () = output_links writer (Waypoint.links waypoint) in
  let* () = output_optional_text_element writer "sym" (Waypoint.symbol waypoint) in
  let* () = output_optional_text_element writer "type" (Waypoint.type_ waypoint) in
  let* () = output_optional_fix_element writer "fix" (Waypoint.fix waypoint) in
  let* () = output_optional_int_element writer "sat" (Waypoint.sat waypoint) in
  let* () = output_optional_float_element writer "hdop" (Waypoint.hdop waypoint) in
  let* () = output_optional_float_element writer "vdop" (Waypoint.vdop waypoint) in
  let* () = output_optional_float_element writer "pdop" (Waypoint.pdop waypoint) in
  let* () = output_optional_float_element writer "ageofdgpsdata" (Waypoint.ageofdgpsdata waypoint) in
  let* () = output_optional_int_element writer "dgpsid" (Waypoint.dgpsid waypoint) in
  output_extensions writer (Waypoint.extensions waypoint)

(** Write waypoints *)
let output_waypoints writer waypoints =
  let rec write_waypoints = function
    | [] -> Ok ()
    | wpt :: rest ->
        let lat = Coordinate.latitude_to_float (Waypoint.lat wpt) in
        let lon = Coordinate.longitude_to_float (Waypoint.lon wpt) in
        let attrs = [
          (("", "lat"), Printf.sprintf "%.6f" lat);
          (("", "lon"), Printf.sprintf "%.6f" lon);
        ] in
        let* () = output_element_start writer "wpt" attrs in
        let* () = output_waypoint_data writer wpt in
        let* () = output_element_end writer in
        write_waypoints rest
  in
  write_waypoints waypoints

(** Write route points *)
let output_route_points writer points element_name =
  let rec write_points = function
    | [] -> Ok ()
    | pt :: rest ->
        let lat = Coordinate.latitude_to_float (Waypoint.lat pt) in
        let lon = Coordinate.longitude_to_float (Waypoint.lon pt) in
        let attrs = [
          (("", "lat"), Printf.sprintf "%.6f" lat);
          (("", "lon"), Printf.sprintf "%.6f" lon);
        ] in
        let* () = output_element_start writer element_name attrs in
        let* () = output_waypoint_data writer pt in
        let* () = output_element_end writer in
        write_points rest
  in
  write_points points

(** Write routes *)
let output_routes writer routes =
  let rec write_routes = function
    | [] -> Ok ()
    | route :: rest ->
        let* () = output_element_start writer "rte" [] in
        let* () = output_optional_text_element writer "name" (Route.name route) in
        let* () = output_optional_text_element writer "cmt" (Route.comment route) in
        let* () = output_optional_text_element writer "desc" (Route.description route) in
        let* () = output_optional_text_element writer "src" (Route.source route) in
        let* () = output_links writer (Route.links route) in
        let* () = output_optional_int_element writer "number" (Route.number route) in
        let* () = output_optional_text_element writer "type" (Route.type_ route) in
        let* () = output_extensions writer (Route.extensions route) in
        let* () = output_route_points writer (Route.points route) "rtept" in
        let* () = output_element_end writer in
        write_routes rest
  in
  write_routes routes

(** Write track segments *)
let output_track_segments writer segments =
  let rec write_segments = function
    | [] -> Ok ()
    | seg :: rest ->
        let* () = output_element_start writer "trkseg" [] in
        let* () = output_route_points writer (Track.Segment.points seg) "trkpt" in
        let* () = output_extensions writer (Track.Segment.extensions seg) in
        let* () = output_element_end writer in
        write_segments rest
  in
  write_segments segments

(** Write tracks *)
let output_tracks writer tracks =
  let rec write_tracks = function
    | [] -> Ok ()
    | track :: rest ->
        let* () = output_element_start writer "trk" [] in
        let* () = output_optional_text_element writer "name" (Track.name track) in
        let* () = output_optional_text_element writer "cmt" (Track.comment track) in
        let* () = output_optional_text_element writer "desc" (Track.description track) in
        let* () = output_optional_text_element writer "src" (Track.source track) in
        let* () = output_links writer (Track.links track) in
        let* () = output_optional_int_element writer "number" (Track.number track) in
        let* () = output_optional_text_element writer "type" (Track.type_ track) in
        let* () = output_extensions writer (Track.extensions track) in
        let* () = output_track_segments writer (Track.segments track) in
        let* () = output_element_end writer in
        write_tracks rest
  in
  write_tracks tracks

(** Write a complete GPX document *)
let write ?(validate=false) output gpx =
  let writer = Xmlm.make_output output in
  
  let result =
    try
      (* Write XML declaration and GPX root element *)
      let version = Doc.version gpx in
      let creator = Doc.creator gpx in
      let attrs = [
        (("", "version"), version);
        (("", "creator"), creator);
        (("", "xsi:schemaLocation"), "http://www.topografix.com/GPX/1/1 http://www.topografix.com/GPX/1/1/gpx.xsd");
        (("xmlns", "xsi"), "http://www.w3.org/2001/XMLSchema-instance");
        (("", "xmlns"), "http://www.topografix.com/GPX/1/1")
      ] in
      
      let* () = output_element_start writer "gpx" attrs in
      
      (* Write metadata if present *)
      let* () = match Doc.metadata gpx with
        | Some metadata -> output_metadata writer metadata
        | None -> Ok ()
      in
      
      (* Write waypoints *)
      let* () = output_waypoints writer (Doc.waypoints gpx) in
      
      (* Write routes *)
      let* () = output_routes writer (Doc.routes gpx) in
      
      (* Write tracks *)
      let* () = output_tracks writer (Doc.tracks gpx) in
      
      (* Write root-level extensions *)
      let* () = output_extensions writer (Doc.extensions gpx) in
      
      output_element_end writer
      
    with
    | Xmlm.Error ((line, col), error) ->
      Error (Error.xml_error (Printf.sprintf "XML error at line %d, column %d: %s"
                       line col (Xmlm.error_message error)))
    | exn ->
      Error (Error.xml_error (Printexc.to_string exn))
  in
  
  match result, validate with
  | Ok (), true ->
    let validation = Validate.validate_gpx gpx in
    if validation.is_valid then
      Ok ()
    else
      let error_msgs = List.filter (fun issue -> issue.Validate.level = `Error) validation.issues
                      |> List.map (fun issue -> issue.Validate.message)
                      |> String.concat "; " in
      Error (Error.validation_error error_msgs)
  | result, false -> result
  | Error _ as result, true -> result (* Pass through write errors even when validating *)

(** Write GPX to string *)
let write_string ?(validate=false) gpx =
  let buffer = Buffer.create 1024 in
  let dest = `Buffer buffer in
  let* () = write ~validate dest gpx in
  Ok (Buffer.contents buffer)