commit ee5e6c31758d094073d1432f6df16cfb7e5b22fa · anil.recoil.org/ocaml-gpx

CLAUDE.md

···

       1
       1
       +
       My goal is to build a high quality GPX (GPS Exchange Format) in OCaml, using the xmlm streaming code library to make the core library portable. Then build a Unix-based layer over that to implement the IO.

     

       2
       2
       +
       

     

       3
       3
       +
       The GPX homepage is at https://www.topografix.com/gpx.asp with the XSD scheme at https://www.topografix.com/GPX/1/1/gpx.xsd and the docs at https://www.topografix.com/GPX/1/1/

     

       4
       4
       +
       

     

       5
       5
       +

+192

README.md

···

       1
       1
       +
       # mlgpx - OCaml GPX Library

     

       2
       2
       +
       

     

       3
       3
       +
       A high-quality OCaml library for parsing and generating GPX (GPS Exchange Format) files, designed with streaming performance and type safety in mind.

     

       4
       4
       +
       

     

       5
       5
       +
       ## Architecture Overview

     

       6
       6
       +
       

     

       7
       7
       +
       The library is split into two main components:

     

       8
       8
       +
       

     

       9
       9
       +
       ### Core Library (`gpx`)

     

       10
       10
       +
       - **Portable**: No Unix dependencies, works with js_of_ocaml

     

       11
       11
       +
       - **Streaming**: Uses xmlm for memory-efficient XML processing

     

       12
       12
       +
       - **Type-safe**: Strong typing with validation for coordinates and GPS data

     

       13
       13
       +
       - **Pure functional**: No side effects in the core parsing/writing logic

     

       14
       14
       +
       

     

       15
       15
       +
       ### Unix Layer (`gpx_unix`)  

     

       16
       16
       +
       - **File I/O**: Convenient functions for reading/writing GPX files

     

       17
       17
       +
       - **Validation**: Built-in validation with detailed error reporting

     

       18
       18
       +
       - **Utilities**: Helper functions for common GPX operations

     

       19
       19
       +
       

     

       20
       20
       +
       ## Key Features

     

       21
       21
       +
       

     

       22
       22
       +
       - ✅ **Complete GPX 1.1 support**: Waypoints, routes, tracks, metadata, extensions

     

       23
       23
       +
       - ✅ **Streaming parser/writer**: Memory-efficient for large files

     

       24
       24
       +
       - ✅ **Strong type safety**: Validated coordinates, GPS fix types, etc.

     

       25
       25
       +
       - ✅ **Comprehensive validation**: Detailed error and warning reporting

     

       26
       26
       +
       - ✅ **Extension support**: Handle custom XML elements

     

       27
       27
       +
       - ✅ **Cross-platform**: Core library has no Unix dependencies

     

       28
       28
       +
       

     

       29
       29
       +
       ## Module Structure

     

       30
       30
       +
       

     

       31
       31
       +
       ```

     

       32
       32
       +
       mlgpx/

     

       33
       33
       +
       ├── lib/

     

       34
       34
       +
       │   ├── gpx/                # Portable core library

     

       35
       35
       +
       │   │   ├── gpx_types.ml    # Type definitions with smart constructors

     

       36
       36
       +
       │   │   ├── gpx_parser.ml   # Streaming XML parser

     

       37
       37
       +
       │   │   ├── gpx_writer.ml   # Streaming XML writer

     

       38
       38
       +
       │   │   └── gpx_validate.ml # Validation and error checking

     

       39
       39
       +
       │   └── gpx_unix/           # Unix I/O layer

     

       40
       40
       +
       │       ├── gpx_io.ml       # File operations with error handling

     

       41
       41
       +
       │       └── gpx_unix.ml     # High-level convenience API

     

       42
       42
       +
       ├── examples/               # Usage examples

     

       43
       43
       +
       └── test/                   # Test suite

     

       44
       44
       +
       ```

     

       45
       45
       +
       

     

       46
       46
       +
       ## Type System Design

     

       47
       47
       +
       

     

       48
       48
       +
       ### Validated Coordinates

     

       49
       49
       +
       ```ocaml

     

       50
       50
       +
       type latitude = private float   (* -90.0 to 90.0 *)

     

       51
       51
       +
       type longitude = private float  (* -180.0 to < 180.0 *)

     

       52
       52
       +
       type degrees = private float    (* 0.0 to < 360.0 *)

     

       53
       53
       +
       

     

       54
       54
       +
       (* Smart constructors with validation *)

     

       55
       55
       +
       val latitude : float -> (latitude, string) result

     

       56
       56
       +
       val longitude : float -> (longitude, string) result

     

       57
       57
       +
       ```

     

       58
       58
       +
       

     

       59
       59
       +
       ### GPX Elements

     

       60
       60
       +
       - **Waypoint**: Standalone geographic point with metadata

     

       61
       61
       +
       - **Route**: Ordered list of waypoints representing a planned path

     

       62
       62
       +
       - **Track**: Recorded path consisting of track segments with track points

     

       63
       63
       +
       - **Metadata**: Document-level information (bounds, author, etc.)

     

       64
       64
       +
       

     

       65
       65
       +
       ### Extension System

     

       66
       66
       +
       ```ocaml

     

       67
       67
       +
       type extension = {

     

       68
       68
       +
         namespace : string option;

     

       69
       69
       +
         name : string;

     

       70
       70
       +
         attributes : (string * string) list;

     

       71
       71
       +
         content : extension_content;

     

       72
       72
       +
       }

     

       73
       73
       +
       ```

     

       74
       74
       +
       

     

       75
       75
       +
       ## API Design

     

       76
       76
       +
       

     

       77
       77
       +
       ### Streaming Operations

     

       78
       78
       +
       ```ocaml

     

       79
       79
       +
       (* Core streaming API *)

     

       80
       80
       +
       val Gpx_parser.parse : Xmlm.input -> gpx result

     

       81
       81
       +
       val Gpx_writer.write : Xmlm.output -> gpx -> unit result

     

       82
       82
       +
       

     

       83
       83
       +
       (* String convenience functions *)

     

       84
       84
       +
       val Gpx_parser.parse_string : string -> gpx result  

     

       85
       85
       +
       val Gpx_writer.write_string : gpx -> string result

     

       86
       86
       +
       ```

     

       87
       87
       +
       

     

       88
       88
       +
       ### File Operations

     

       89
       89
       +
       ```ocaml

     

       90
       90
       +
       (* Simple file I/O *)

     

       91
       91
       +
       val Gpx_unix.read : string -> gpx result

     

       92
       92
       +
       val Gpx_unix.write : string -> gpx -> unit result

     

       93
       93
       +
       

     

       94
       94
       +
       (* With validation *)

     

       95
       95
       +
       val Gpx_unix.read_validated : string -> gpx result

     

       96
       96
       +
       val Gpx_unix.write_validated : string -> gpx -> unit result

     

       97
       97
       +
       

     

       98
       98
       +
       (* With backup *)

     

       99
       99
       +
       val Gpx_unix.write_with_backup : string -> gpx -> string result

     

       100
       100
       +
       ```

     

       101
       101
       +
       

     

       102
       102
       +
       ### Validation

     

       103
       103
       +
       ```ocaml

     

       104
       104
       +
       type validation_result = {

     

       105
       105
       +
         issues : validation_issue list;

     

       106
       106
       +
         is_valid : bool;

     

       107
       107
       +
       }

     

       108
       108
       +
       

     

       109
       109
       +
       val Gpx_validate.validate_gpx : gpx -> validation_result

     

       110
       110
       +
       val Gpx_validate.is_valid : gpx -> bool

     

       111
       111
       +
       ```

     

       112
       112
       +
       

     

       113
       113
       +
       ## Error Handling Strategy

     

       114
       114
       +
       

     

       115
       115
       +
       The library uses a comprehensive error type:

     

       116
       116
       +
       

     

       117
       117
       +
       ```ocaml

     

       118
       118
       +
       type error =

     

       119
       119
       +
         | Invalid_xml of string

     

       120
       120
       +
         | Invalid_coordinate of string  

     

       121
       121
       +
         | Missing_required_attribute of string * string

     

       122
       122
       +
         | Missing_required_element of string

     

       123
       123
       +
         | Validation_error of string

     

       124
       124
       +
         | Xml_error of string

     

       125
       125
       +
         | IO_error of string

     

       126
       126
       +
       ```

     

       127
       127
       +
       

     

       128
       128
       +
       All operations return `('a, error) result` for explicit error handling.

     

       129
       129
       +
       

     

       130
       130
       +
       ## Performance Characteristics

     

       131
       131
       +
       

     

       132
       132
       +
       - **Memory usage**: O(1) for streaming operations, O(n) for complete document

     

       133
       133
       +
       - **Time complexity**: O(n) parsing/writing where n = file size

     

       134
       134
       +
       - **Validation**: Optional, can be disabled for performance-critical applications

     

       135
       135
       +
       - **Extensions**: Parsed lazily, minimal overhead when unused

     

       136
       136
       +
       

     

       137
       137
       +
       ## Usage Example

     

       138
       138
       +
       

     

       139
       139
       +
       ```ocaml

     

       140
       140
       +
       open Gpx_unix

     

       141
       141
       +
       

     

       142
       142
       +
       let create_simple_gpx () =

     

       143
       143
       +
         (* Create waypoints *)

     

       144
       144
       +
         let* waypoint = make_waypoint ~lat:37.7749 ~lon:(-122.4194) 

     

       145
       145
       +
                                       ~name:"San Francisco" () in

     

       146
       146
       +
         

     

       147
       147
       +
         (* Create track from coordinates *)

     

       148
       148
       +
         let coords = [(37.7749, -122.4194); (37.7849, -122.4094)] in

     

       149
       149
       +
         let* track = make_track_from_coords ~name:"Sample Track" coords in

     

       150
       150
       +
         

     

       151
       151
       +
         (* Create GPX document *)

     

       152
       152
       +
         let gpx = Types.make_gpx ~creator:"mlgpx example" in

     

       153
       153
       +
         let gpx = { gpx with waypoints = [waypoint]; tracks = [track] } in

     

       154
       154
       +
         

     

       155
       155
       +
         (* Validate and write *)

     

       156
       156
       +
         write_validated "output.gpx" gpx

     

       157
       157
       +
       

     

       158
       158
       +
       let () = 

     

       159
       159
       +
         match create_simple_gpx () with

     

       160
       160
       +
         | Ok () -> Printf.printf "GPX created successfully\n"

     

       161
       161
       +
         | Error e -> Printf.eprintf "Error: %s\n" (error_to_string e)

     

       162
       162
       +
       ```

     

       163
       163
       +
       

     

       164
       164
       +
       ## Dependencies

     

       165
       165
       +
       

     

       166
       166
       +
       - **xmlm**: Streaming XML parser/writer (core dependency)

     

       167
       167
       +
       - **ptime**: Time handling for timestamps

     

       168
       168
       +
       - **unix**: File I/O operations (Unix layer only)

     

       169
       169
       +
       

     

       170
       170
       +
       ## Testing Strategy

     

       171
       171
       +
       

     

       172
       172
       +
       - Unit tests for coordinate validation

     

       173
       173
       +
       - Roundtrip tests (parse → write → parse)

     

       174
       174
       +
       - Validation rule testing

     

       175
       175
       +
       - Large file streaming tests

     

       176
       176
       +
       - Cross-platform compatibility tests

     

       177
       177
       +
       

     

       178
       178
       +
       ## Future Considerations

     

       179
       179
       +
       

     

       180
       180
       +
       ### Potential Optimizations

     

       181
       181
       +
       - Custom coordinate type with packed representation

     

       182
       182
       +
       - Lazy extension parsing

     

       183
       183
       +
       - Memory-mapped file reading for very large files

     

       184
       184
       +
       - Streaming validation (validate while parsing)

     

       185
       185
       +
       

     

       186
       186
       +
       ### API Extensions

     

       187
       187
       +
       - GPX merging/splitting utilities

     

       188
       188
       +
       - Coordinate transformation functions

     

       189
       189
       +
       - Distance/bearing calculations

     

       190
       190
       +
       - GPX statistics and analysis tools

     

       191
       191
       +
       

     

       192
       192
       +
       This architecture provides a solid foundation for GPX processing in OCaml with excellent type safety, performance, and extensibility.

+10

dune-project

···

       1
       1
       +
       (lang dune 3.0)

     

       2
       2
       +
       

     

       3
       3
       +
       (package

     

       4
       4
       +
        (name mlgpx)

     

       5
       5
       +
        (depends ocaml dune xmlm ptime)

     

       6
       6
       +
        (synopsis "OCaml library for parsing and generating GPX files")

     

       7
       7
       +
        (description

     

       8
       8
       +
         "mlgpx is a streaming GPX (GPS Exchange Format) library for OCaml. It provides a portable core library using the xmlm streaming XML parser, with a separate Unix layer for file I/O operations. The library supports the complete GPX 1.1 specification including waypoints, routes, tracks, and metadata with strong type safety and validation.")

     

       9
       9
       +
        (license MIT)

     

       10
       10
       +
        (authors "Anil Madhavapeddy"))

examples/dune

···

       1
       1
       +
       (executable

     

       2
       2
       +
        (public_name simple_gpx)

     

       3
       3
       +
        (name simple_gpx)

     

       4
       4
       +
        (libraries gpx_unix))

+79

examples/simple_gpx.ml

···

       1
       1
       +
       (** Example demonstrating basic GPX operations *)

     

       2
       2
       +
       

     

       3
       3
       +
       open Gpx_unix

     

       4
       4
       +
       

     

       5
       5
       +
       let () =

     

       6
       6
       +
         (* Create a simple GPX document with waypoints and a track *)

     

       7
       7
       +
         let creator = "mlgpx example" in

     

       8
       8
       +
         let gpx = Types.make_gpx ~creator in

     

       9
       9
       +
         

     

       10
       10
       +
         (* Add some waypoints *)

     

       11
       11
       +
         let waypoints = [

     

       12
       12
       +
           (37.7749, -122.4194, "San Francisco", "Golden Gate Bridge area");

     

       13
       13
       +
           (40.7128, -74.0060, "New York", "Manhattan");

     

       14
       14
       +
           (51.5074, -0.1278, "London", "Central London");

     

       15
       15
       +
         ] in

     

       16
       16
       +
         

     

       17
       17
       +
         let create_waypoints acc (lat, lon, name, desc) =

     

       18
       18
       +
           match make_waypoint ~lat ~lon ~name ~desc () with

     

       19
       19
       +
           | Ok wpt -> wpt :: acc

     

       20
       20
       +
           | Error e -> 

     

       21
       21
       +
             Printf.eprintf "Error creating waypoint %s: %s\n" name 

     

       22
       22
       +
               (match e with Invalid_coordinate s -> s | _ -> "unknown");

     

       23
       23
       +
             acc

     

       24
       24
       +
         in

     

       25
       25
       +
         

     

       26
       26
       +
         let wpts = List.fold_left create_waypoints [] waypoints |> List.rev in

     

       27
       27
       +
         let gpx = { gpx with waypoints = wpts } in

     

       28
       28
       +
         

     

       29
       29
       +
         (* Create a simple track *)

     

       30
       30
       +
         let track_coords = [

     

       31
       31
       +
           (37.7749, -122.4194);

     

       32
       32
       +
           (37.7849, -122.4094);

     

       33
       33
       +
           (37.7949, -122.3994);

     

       34
       34
       +
           (37.8049, -122.3894);

     

       35
       35
       +
         ] in

     

       36
       36
       +
         

     

       37
       37
       +
         let track_result = make_track_from_coords ~name:"Sample Track" track_coords in

     

       38
       38
       +
         let gpx = match track_result with

     

       39
       39
       +
           | Ok track -> { gpx with tracks = [track] }

     

       40
       40
       +
           | Error e -> 

     

       41
       41
       +
             Printf.eprintf "Error creating track: %s\n" 

     

       42
       42
       +
               (match e with Invalid_coordinate s -> s | _ -> "unknown");

     

       43
       43
       +
             gpx

     

       44
       44
       +
         in

     

       45
       45
       +
         

     

       46
       46
       +
         (* Validate the GPX *)

     

       47
       47
       +
         let validation = validate gpx in

     

       48
       48
       +
         Printf.printf "GPX is valid: %s\n" (string_of_bool validation.is_valid);

     

       49
       49
       +
         

     

       50
       50
       +
         if not validation.is_valid then (

     

       51
       51
       +
           List.iter (fun issue ->

     

       52
       52
       +
             Printf.printf "%s\n" (Validate.format_issue issue)

     

       53
       53
       +
           ) validation.issues

     

       54
       54
       +
         );

     

       55
       55
       +
         

     

       56
       56
       +
         (* Print statistics *)

     

       57
       57
       +
         print_stats gpx;

     

       58
       58
       +
         

     

       59
       59
       +
         (* Write to file *)

     

       60
       60
       +
         (match write_validated "example.gpx" gpx with

     

       61
       61
       +
          | Ok () -> Printf.printf "GPX written to example.gpx\n"

     

       62
       62
       +
          | Error e -> 

     

       63
       63
       +
            Printf.eprintf "Error writing GPX: %s\n" 

     

       64
       64
       +
              (match e with 

     

       65
       65
       +
               | IO_error s | Validation_error s -> s 

     

       66
       66
       +
               | _ -> "unknown"));

     

       67
       67
       +
         

     

       68
       68
       +
         (* Read it back and verify *)

     

       69
       69
       +
         (match read_validated "example.gpx" with

     

       70
       70
       +
          | Ok gpx2 -> 

     

       71
       71
       +
            Printf.printf "Successfully read back GPX file\n";

     

       72
       72
       +
            let stats2 = get_stats gpx2 in

     

       73
       73
       +
            Printf.printf "Read back %d waypoints, %d tracks\n" 

     

       74
       74
       +
              stats2.waypoint_count stats2.track_count

     

       75
       75
       +
          | Error e ->

     

       76
       76
       +
            Printf.eprintf "Error reading GPX: %s\n"

     

       77
       77
       +
              (match e with 

     

       78
       78
       +
               | IO_error s | Validation_error s -> s 

     

       79
       79
       +
               | _ -> "unknown"))

lib/gpx/dune

···

       1
       1
       +
       (library

     

       2
       2
       +
        (public_name mlgpx.core)

     

       3
       3
       +
        (name gpx)

     

       4
       4
       +
        (libraries xmlm ptime)

     

       5
       5
       +
        (modules gpx types parser writer validate))

+13

lib/gpx/gpx.ml

···

       1
       1
       +
       (** {1 MLGpx - OCaml GPX Library} *)

     

       2
       2
       +
       

     

       3
       3
       +
       (** Core types and data structures *)

     

       4
       4
       +
       module Types = Types

     

       5
       5
       +
       

     

       6
       6
       +
       (** Streaming parser *)  

     

       7
       7
       +
       module Parser = Parser

     

       8
       8
       +
       

     

       9
       9
       +
       (** Streaming writer *)

     

       10
       10
       +
       module Writer = Writer

     

       11
       11
       +
       

     

       12
       12
       +
       (** Validation engine *)

     

       13
       13
       +
       module Validate = Validate

+78

lib/gpx/gpx.mli

···

       1
       1
       +
       (** {1 MLGpx - OCaml GPX Library}

     

       2
       2
       +
       

     

       3
       3
       +
           A library for parsing and generating GPX (GPS Exchange Format) files.

     

       4
       4
       +
       

     

       5
       5
       +
           The library is split into two main components:

     

       6
       6
       +
           - {b Core Library (gpx)}: Portable core library with no Unix dependencies

     

       7
       7
       +
           - {b Unix Layer (gpx_unix)}: Convenient functions for file I/O and validation

     

       8
       8
       +
       

     

       9
       9
       +
           {2 Key Features}

     

       10
       10
       +
       

     

       11
       11
       +
           - ✅ Complete GPX 1.1 support: Waypoints, routes, tracks, metadata, extensions

     

       12
       12
       +
           - ✅ Streaming parser/writer: Memory-efficient for large files

     

       13
       13
       +
           - ✅ Strong type safety: Validated coordinates, GPS fix types, etc.

     

       14
       14
       +
           - ✅ Comprehensive validation: Detailed error and warning reporting

     

       15
       15
       +
           - ✅ Extension support: Handle custom XML elements

     

       16
       16
       +
           - ✅ Cross-platform: Core library has no Unix dependencies

     

       17
       17
       +
       

     

       18
       18
       +
           {2 Usage Example}

     

       19
       19
       +
       

     

       20
       20
       +
           {[

     

       21
       21
       +
             open Gpx

     

       22
       22
       +
       

     

       23
       23
       +
             let create_simple_gpx () =

     

       24
       24
       +
               (* Create waypoints *)

     

       25
       25
       +
               let* waypoint = Types.make_waypoint ~lat:37.7749 ~lon:(-122.4194) 

     

       26
       26
       +
                                                  ~name:"San Francisco" () in

     

       27
       27
       +
               

     

       28
       28
       +
               (* Create track from coordinates *)

     

       29
       29
       +
               let coords = [(37.7749, -122.4194); (37.7849, -122.4094)] in

     

       30
       30
       +
               let* track = make_track_from_coords ~name:"Sample Track" coords in

     

       31
       31
       +
               

     

       32
       32
       +
               (* Create GPX document *)

     

       33
       33
       +
               let gpx = Types.make_gpx ~creator:"mlgpx example" in

     

       34
       34
       +
               let gpx = { gpx with waypoints = [waypoint]; tracks = [track] } in

     

       35
       35
       +
               

     

       36
       36
       +
               (* Write to string *)

     

       37
       37
       +
               Writer.write_string gpx

     

       38
       38
       +
           ]}

     

       39
       39
       +
       

     

       40
       40
       +
           {2 Module Organization} *)

     

       41
       41
       +
       

     

       42
       42
       +
       (** {2 Core Types and Data Structures}

     

       43
       43
       +
           

     

       44
       44
       +
           All GPX data types, coordinate validation, and smart constructors. *)

     

       45
       45
       +
       module Types = Types

     

       46
       46
       +
       

     

       47
       47
       +
       (** {2 Streaming Parser}

     

       48
       48
       +
           

     

       49
       49
       +
           Memory-efficient streaming XML parser for GPX documents.

     

       50
       50
       +
           

     

       51
       51
       +
           Features:

     

       52
       52
       +
           - Validates coordinates and GPS fix types during parsing

     

       53
       53
       +
           - Handles extensions and custom elements

     

       54
       54
       +
           - Reports detailed parsing errors with location information

     

       55
       55
       +
           - Works with any [Xmlm.input] source *)

     

       56
       56
       +
       module Parser = Parser

     

       57
       57
       +
       

     

       58
       58
       +
       (** {2 Streaming Writer} 

     

       59
       59
       +
           

     

       60
       60
       +
           Memory-efficient streaming XML writer for GPX documents.

     

       61
       61
       +
           

     

       62
       62
       +
           Features:

     

       63
       63
       +
           - Generates compliant GPX 1.1 XML

     

       64
       64
       +
           - Handles proper namespace declarations

     

       65
       65
       +
           - Supports extensions and custom elements

     

       66
       66
       +
           - Works with any [Xmlm.output] destination *)

     

       67
       67
       +
       module Writer = Writer

     

       68
       68
       +
       

     

       69
       69
       +
       (** {2 Validation Engine}

     

       70
       70
       +
           

     

       71
       71
       +
           Comprehensive validation for GPX documents with detailed error reporting.

     

       72
       72
       +
           

     

       73
       73
       +
           Features:

     

       74
       74
       +
           - Validates coordinates are within proper ranges

     

       75
       75
       +
           - Checks required fields and proper structure

     

       76
       76
       +
           - Provides warnings for best practices

     

       77
       77
       +
           - Supports custom validation rules *)

     

       78
       78
       +
       module Validate = Validate

+519

lib/gpx/parser.ml

···

       1
       1
       +
       (** GPX streaming parser using xmlm *)

     

       2
       2
       +
       

     

       3
       3
       +
       open Types

     

       4
       4
       +
       

     

       5
       5
       +
       (** Parser state for streaming *)

     

       6
       6
       +
       type parser_state = {

     

       7
       7
       +
         input : Xmlm.input;

     

       8
       8
       +
         mutable current_element : string list; (* Stack of current element names *)

     

       9
       9
       +
         mutable text_buffer : Buffer.t;

     

       10
       10
       +
       }

     

       11
       11
       +
       

     

       12
       12
       +
       (** Create a new parser state *)

     

       13
       13
       +
       let make_parser input = {

     

       14
       14
       +
         input;

     

       15
       15
       +
         current_element = [];

     

       16
       16
       +
         text_buffer = Buffer.create 256;

     

       17
       17
       +
       }

     

       18
       18
       +
       

     

       19
       19
       +
       (** Utility functions *)

     

       20
       20
       +
       

     

       21
       21
       +
       let get_attribute name attrs =

     

       22
       22
       +
         try 

     

       23
       23
       +
           let value = List.find (fun ((_, n), _) -> n = name) attrs in

     

       24
       24
       +
           Some (snd value)

     

       25
       25
       +
         with Not_found -> None

     

       26
       26
       +
       

     

       27
       27
       +
       let require_attribute name attrs element =

     

       28
       28
       +
         match get_attribute name attrs with

     

       29
       29
       +
         | Some value -> Ok value

     

       30
       30
       +
         | None -> Error (Missing_required_attribute (element, name))

     

       31
       31
       +
       

     

       32
       32
       +
       let parse_float_opt s =

     

       33
       33
       +
         try Some (Float.of_string s)

     

       34
       34
       +
         with _ -> None

     

       35
       35
       +
       

     

       36
       36
       +
       let parse_int_opt s =

     

       37
       37
       +
         try Some (int_of_string s)

     

       38
       38
       +
         with _ -> None

     

       39
       39
       +
       

     

       40
       40
       +
       let parse_time s =

     

       41
       41
       +
         match Ptime.of_rfc3339 s with

     

       42
       42
       +
         | Ok (t, _, _) -> Some t

     

       43
       43
       +
         | Error _ -> None

     

       44
       44
       +
       

     

       45
       45
       +
       (** Result binding operators *)

     

       46
       46
       +
       let (let*) = Result.bind

     

       47
       47
       +
       

     

       48
       48
       +
       let parse_coordinates attrs element =

     

       49
       49
       +
         let* lat_str = require_attribute "lat" attrs element in

     

       50
       50
       +
         let* lon_str = require_attribute "lon" attrs element in

     

       51
       51
       +
         match (Float.of_string lat_str, Float.of_string lon_str) with

     

       52
       52
       +
         | (lat_f, lon_f) ->

     

       53
       53
       +
           let* lat = Result.map_error (fun s -> Invalid_coordinate s) (latitude lat_f) in

     

       54
       54
       +
           let* lon = Result.map_error (fun s -> Invalid_coordinate s) (longitude lon_f) in

     

       55
       55
       +
           Ok (lat, lon)

     

       56
       56
       +
         | exception _ -> Error (Invalid_coordinate "Invalid coordinate format")

     

       57
       57
       +
       

     

       58
       58
       +
       (** Parse waypoint data from XML elements *)

     

       59
       59
       +
       let rec parse_waypoint_data parser lat lon =

     

       60
       60
       +
         let wpt = make_waypoint_data lat lon in

     

       61
       61
       +
         parse_waypoint_elements parser wpt

     

       62
       62
       +
       

     

       63
       63
       +
       and parse_waypoint_elements parser wpt =

     

       64
       64
       +
         let rec loop wpt =

     

       65
       65
       +
           match Xmlm.input parser.input with

     

       66
       66
       +
           | `El_start ((_, name), attrs) ->

     

       67
       67
       +
             parser.current_element <- name :: parser.current_element;

     

       68
       68
       +
             (match name with

     

       69
       69
       +
              | "ele" -> 

     

       70
       70
       +
                let* text = parse_text_content parser in

     

       71
       71
       +
                (match parse_float_opt text with

     

       72
       72
       +
                 | Some ele -> loop { wpt with ele = Some ele }

     

       73
       73
       +
                 | None -> loop wpt)

     

       74
       74
       +
              | "time" ->

     

       75
       75
       +
                let* text = parse_text_content parser in

     

       76
       76
       +
                loop { wpt with time = parse_time text }

     

       77
       77
       +
              | "magvar" ->

     

       78
       78
       +
                let* text = parse_text_content parser in

     

       79
       79
       +
                (match parse_float_opt text with

     

       80
       80
       +
                 | Some f -> 

     

       81
       81
       +
                   (match degrees f with

     

       82
       82
       +
                    | Ok deg -> loop { wpt with magvar = Some deg }

     

       83
       83
       +
                    | Error _ -> loop wpt)

     

       84
       84
       +
                 | None -> loop wpt)

     

       85
       85
       +
              | "geoidheight" ->

     

       86
       86
       +
                let* text = parse_text_content parser in

     

       87
       87
       +
                (match parse_float_opt text with

     

       88
       88
       +
                 | Some h -> loop { wpt with geoidheight = Some h }

     

       89
       89
       +
                 | None -> loop wpt)

     

       90
       90
       +
              | "name" ->

     

       91
       91
       +
                let* text = parse_text_content parser in

     

       92
       92
       +
                loop { wpt with name = Some text }

     

       93
       93
       +
              | "cmt" ->

     

       94
       94
       +
                let* text = parse_text_content parser in

     

       95
       95
       +
                loop { wpt with cmt = Some text }

     

       96
       96
       +
              | "desc" ->

     

       97
       97
       +
                let* text = parse_text_content parser in

     

       98
       98
       +
                loop { wpt with desc = Some text }

     

       99
       99
       +
              | "src" ->

     

       100
       100
       +
                let* text = parse_text_content parser in

     

       101
       101
       +
                loop { wpt with src = Some text }

     

       102
       102
       +
              | "sym" ->

     

       103
       103
       +
                let* text = parse_text_content parser in

     

       104
       104
       +
                loop { wpt with sym = Some text }

     

       105
       105
       +
              | "type" ->

     

       106
       106
       +
                let* text = parse_text_content parser in

     

       107
       107
       +
                loop { wpt with type_ = Some text }

     

       108
       108
       +
              | "fix" ->

     

       109
       109
       +
                let* text = parse_text_content parser in

     

       110
       110
       +
                loop { wpt with fix = fix_type_of_string text }

     

       111
       111
       +
              | "sat" ->

     

       112
       112
       +
                let* text = parse_text_content parser in

     

       113
       113
       +
                (match parse_int_opt text with

     

       114
       114
       +
                 | Some s -> loop { wpt with sat = Some s }

     

       115
       115
       +
                 | None -> loop wpt)

     

       116
       116
       +
              | "hdop" | "vdop" | "pdop" ->

     

       117
       117
       +
                let* text = parse_text_content parser in

     

       118
       118
       +
                (match parse_float_opt text with

     

       119
       119
       +
                 | Some f -> 

     

       120
       120
       +
                   (match name with

     

       121
       121
       +
                    | "hdop" -> loop { wpt with hdop = Some f }

     

       122
       122
       +
                    | "vdop" -> loop { wpt with vdop = Some f }

     

       123
       123
       +
                    | "pdop" -> loop { wpt with pdop = Some f }

     

       124
       124
       +
                    | _ -> loop wpt)

     

       125
       125
       +
                 | None -> loop wpt)

     

       126
       126
       +
              | "ageofdgpsdata" ->

     

       127
       127
       +
                let* text = parse_text_content parser in

     

       128
       128
       +
                (match parse_float_opt text with

     

       129
       129
       +
                 | Some f -> loop { wpt with ageofdgpsdata = Some f }

     

       130
       130
       +
                 | None -> loop wpt)

     

       131
       131
       +
              | "dgpsid" ->

     

       132
       132
       +
                let* text = parse_text_content parser in

     

       133
       133
       +
                (match parse_int_opt text with

     

       134
       134
       +
                 | Some id -> loop { wpt with dgpsid = Some id }

     

       135
       135
       +
                 | None -> loop wpt)

     

       136
       136
       +
              | "link" ->

     

       137
       137
       +
                let* link = parse_link parser attrs in

     

       138
       138
       +
                loop { wpt with links = link :: wpt.links }

     

       139
       139
       +
              | "extensions" ->

     

       140
       140
       +
                let* extensions = parse_extensions parser in

     

       141
       141
       +
                loop { wpt with extensions = extensions @ wpt.extensions }

     

       142
       142
       +
              | _ -> 

     

       143
       143
       +
                (* Skip unknown elements *)

     

       144
       144
       +
                let* _ = skip_element parser in

     

       145
       145
       +
                loop wpt)

     

       146
       146
       +
           | `El_end ->

     

       147
       147
       +
             parser.current_element <- List.tl parser.current_element;

     

       148
       148
       +
             Ok wpt

     

       149
       149
       +
           | `Data _ ->

     

       150
       150
       +
             (* Ignore text data at this level *)

     

       151
       151
       +
             loop wpt

     

       152
       152
       +
           | `Dtd _ ->

     

       153
       153
       +
             loop wpt

     

       154
       154
       +
         in

     

       155
       155
       +
         loop wpt

     

       156
       156
       +
       

     

       157
       157
       +
       and parse_text_content parser =

     

       158
       158
       +
         Buffer.clear parser.text_buffer;

     

       159
       159
       +
         let rec loop () =

     

       160
       160
       +
           match Xmlm.input parser.input with

     

       161
       161
       +
           | `Data text ->

     

       162
       162
       +
             Buffer.add_string parser.text_buffer text;

     

       163
       163
       +
             loop ()

     

       164
       164
       +
           | `El_end ->

     

       165
       165
       +
             parser.current_element <- List.tl parser.current_element;

     

       166
       166
       +
             Ok (Buffer.contents parser.text_buffer)

     

       167
       167
       +
           | `El_start _ ->

     

       168
       168
       +
             Error (Invalid_xml "Unexpected element in text content")

     

       169
       169
       +
           | `Dtd _ ->

     

       170
       170
       +
             loop ()

     

       171
       171
       +
         in

     

       172
       172
       +
         loop ()

     

       173
       173
       +
       

     

       174
       174
       +
       and parse_link parser attrs =

     

       175
       175
       +
         let href = match get_attribute "href" attrs with

     

       176
       176
       +
           | Some h -> h

     

       177
       177
       +
           | None -> ""

     

       178
       178
       +
         in

     

       179
       179
       +
         let link = { href; text = None; type_ = None } in

     

       180
       180
       +
         parse_link_elements parser link

     

       181
       181
       +
       

     

       182
       182
       +
       and parse_link_elements parser link =

     

       183
       183
       +
         let rec loop link =

     

       184
       184
       +
           match Xmlm.input parser.input with

     

       185
       185
       +
           | `El_start ((_, name), _) ->

     

       186
       186
       +
             parser.current_element <- name :: parser.current_element;

     

       187
       187
       +
             (match name with

     

       188
       188
       +
              | "text" ->

     

       189
       189
       +
                let* text = parse_text_content parser in

     

       190
       190
       +
                loop { link with text = Some text }

     

       191
       191
       +
              | "type" ->

     

       192
       192
       +
                let* type_text = parse_text_content parser in

     

       193
       193
       +
                loop { link with type_ = Some type_text }

     

       194
       194
       +
              | _ ->

     

       195
       195
       +
                let* _ = skip_element parser in

     

       196
       196
       +
                loop link)

     

       197
       197
       +
           | `El_end ->

     

       198
       198
       +
             parser.current_element <- List.tl parser.current_element;

     

       199
       199
       +
             Ok link

     

       200
       200
       +
           | `Data _ ->

     

       201
       201
       +
             loop link

     

       202
       202
       +
           | `Dtd _ ->

     

       203
       203
       +
             loop link

     

       204
       204
       +
         in

     

       205
       205
       +
         loop link

     

       206
       206
       +
       

     

       207
       207
       +
       and parse_extensions parser =

     

       208
       208
       +
         let rec loop acc =

     

       209
       209
       +
           match Xmlm.input parser.input with

     

       210
       210
       +
           | `El_start ((ns, name), attrs) ->

     

       211
       211
       +
             parser.current_element <- name :: parser.current_element;

     

       212
       212
       +
             let* ext = parse_extension parser ns name attrs in

     

       213
       213
       +
             loop (ext :: acc)

     

       214
       214
       +
           | `El_end ->

     

       215
       215
       +
             parser.current_element <- List.tl parser.current_element;

     

       216
       216
       +
             Ok (List.rev acc)

     

       217
       217
       +
           | `Data _ ->

     

       218
       218
       +
             loop acc

     

       219
       219
       +
           | `Dtd _ ->

     

       220
       220
       +
             loop acc

     

       221
       221
       +
         in

     

       222
       222
       +
         loop []

     

       223
       223
       +
       

     

       224
       224
       +
       and parse_extension parser ns name attrs =

     

       225
       225
       +
         let namespace = if ns = "" then None else Some ns in

     

       226
       226
       +
         let attributes = List.map (fun ((_, n), v) -> (n, v)) attrs in

     

       227
       227
       +
         let* content = parse_extension_content parser in

     

       228
       228
       +
         Ok { namespace; name; attributes; content }

     

       229
       229
       +
       

     

       230
       230
       +
       and parse_extension_content parser =

     

       231
       231
       +
         Buffer.clear parser.text_buffer;

     

       232
       232
       +
         let rec loop elements =

     

       233
       233
       +
           match Xmlm.input parser.input with

     

       234
       234
       +
           | `Data text ->

     

       235
       235
       +
             Buffer.add_string parser.text_buffer text;

     

       236
       236
       +
             loop elements

     

       237
       237
       +
           | `El_start ((ns, name), attrs) ->

     

       238
       238
       +
             parser.current_element <- name :: parser.current_element;

     

       239
       239
       +
             let* ext = parse_extension parser ns name attrs in

     

       240
       240
       +
             loop (ext :: elements)

     

       241
       241
       +
           | `El_end ->

     

       242
       242
       +
             parser.current_element <- List.tl parser.current_element;

     

       243
       243
       +
             let text = String.trim (Buffer.contents parser.text_buffer) in

     

       244
       244
       +
             Ok (match (text, elements) with

     

       245
       245
       +
                 | ("", []) -> Text ""

     

       246
       246
       +
                 | ("", els) -> Elements (List.rev els)

     

       247
       247
       +
                 | (t, []) -> Text t

     

       248
       248
       +
                 | (t, els) -> Mixed (t, List.rev els))

     

       249
       249
       +
           | `Dtd _ ->

     

       250
       250
       +
             loop elements

     

       251
       251
       +
         in

     

       252
       252
       +
         loop []

     

       253
       253
       +
       

     

       254
       254
       +
       and skip_element parser =

     

       255
       255
       +
         let rec loop depth =

     

       256
       256
       +
           match Xmlm.input parser.input with

     

       257
       257
       +
           | `El_start _ -> loop (depth + 1)

     

       258
       258
       +
           | `El_end when depth = 0 -> Ok ()

     

       259
       259
       +
           | `El_end -> loop (depth - 1)

     

       260
       260
       +
           | `Data _ -> loop depth

     

       261
       261
       +
           | `Dtd _ -> loop depth

     

       262
       262
       +
         in

     

       263
       263
       +
         loop 0

     

       264
       264
       +
       

     

       265
       265
       +
       (** Parse a complete GPX document *)

     

       266
       266
       +
       let rec parse_gpx parser =

     

       267
       267
       +
         (* Find the GPX root element *)

     

       268
       268
       +
         let rec find_gpx_root () =

     

       269
       269
       +
           match Xmlm.input parser.input with

     

       270
       270
       +
           | `El_start ((_, "gpx"), attrs) ->

     

       271
       271
       +
             parser.current_element <- ["gpx"];

     

       272
       272
       +
             let* version = require_attribute "version" attrs "gpx" in

     

       273
       273
       +
             let* creator = require_attribute "creator" attrs "gpx" in

     

       274
       274
       +
             if version <> "1.1" then

     

       275
       275
       +
               Error (Validation_error ("Unsupported GPX version: " ^ version))

     

       276
       276
       +
             else

     

       277
       277
       +
               Ok (version, creator)

     

       278
       278
       +
           | `El_start _ ->

     

       279
       279
       +
             let* _ = skip_element parser in

     

       280
       280
       +
             find_gpx_root ()

     

       281
       281
       +
           | `Dtd _ ->

     

       282
       282
       +
             find_gpx_root ()

     

       283
       283
       +
           | `El_end ->

     

       284
       284
       +
             Error (Missing_required_element "gpx")

     

       285
       285
       +
           | `Data _ ->

     

       286
       286
       +
             find_gpx_root ()

     

       287
       287
       +
         in

     

       288
       288
       +
         

     

       289
       289
       +
         let* (version, creator) = find_gpx_root () in

     

       290
       290
       +
         let gpx = make_gpx ~creator in

     

       291
       291
       +
         parse_gpx_elements parser { gpx with version }

     

       292
       292
       +
       

     

       293
       293
       +
       and parse_gpx_elements parser gpx =

     

       294
       294
       +
         let rec loop gpx =

     

       295
       295
       +
           match Xmlm.input parser.input with

     

       296
       296
       +
           | `El_start ((_, name), attrs) ->

     

       297
       297
       +
             parser.current_element <- name :: parser.current_element;

     

       298
       298
       +
             (match name with

     

       299
       299
       +
              | "metadata" ->

     

       300
       300
       +
                let* metadata = parse_metadata parser in

     

       301
       301
       +
                loop { gpx with metadata = Some metadata }

     

       302
       302
       +
              | "wpt" ->

     

       303
       303
       +
                let* (lat, lon) = parse_coordinates attrs "wpt" in

     

       304
       304
       +
                let* waypoint = parse_waypoint_data parser lat lon in

     

       305
       305
       +
                loop { gpx with waypoints = waypoint :: gpx.waypoints }

     

       306
       306
       +
              | "rte" ->

     

       307
       307
       +
                let* route = parse_route parser in

     

       308
       308
       +
                loop { gpx with routes = route :: gpx.routes }

     

       309
       309
       +
              | "trk" ->

     

       310
       310
       +
                let* track = parse_track parser in

     

       311
       311
       +
                loop { gpx with tracks = track :: gpx.tracks }

     

       312
       312
       +
              | "extensions" ->

     

       313
       313
       +
                let* extensions = parse_extensions parser in

     

       314
       314
       +
                loop { gpx with extensions = extensions @ gpx.extensions }

     

       315
       315
       +
              | _ ->

     

       316
       316
       +
                let* _ = skip_element parser in

     

       317
       317
       +
                loop gpx)

     

       318
       318
       +
           | `El_end ->

     

       319
       319
       +
             Ok { gpx with 

     

       320
       320
       +
                  waypoints = List.rev gpx.waypoints;

     

       321
       321
       +
                  routes = List.rev gpx.routes;

     

       322
       322
       +
                  tracks = List.rev gpx.tracks }

     

       323
       323
       +
           | `Data _ ->

     

       324
       324
       +
             loop gpx

     

       325
       325
       +
           | `Dtd _ ->

     

       326
       326
       +
             loop gpx

     

       327
       327
       +
         in

     

       328
       328
       +
         loop gpx

     

       329
       329
       +
       

     

       330
       330
       +
       and parse_metadata parser =

     

       331
       331
       +
         let metadata = empty_metadata in

     

       332
       332
       +
         let rec loop (metadata : metadata) =

     

       333
       333
       +
           match Xmlm.input parser.input with

     

       334
       334
       +
           | `El_start ((_, name), attrs) ->

     

       335
       335
       +
             parser.current_element <- name :: parser.current_element;

     

       336
       336
       +
             (match name with

     

       337
       337
       +
              | "name" ->

     

       338
       338
       +
                let* text = parse_text_content parser in

     

       339
       339
       +
                loop { metadata with name = Some text }

     

       340
       340
       +
              | "desc" ->

     

       341
       341
       +
                let* text = parse_text_content parser in

     

       342
       342
       +
                loop { metadata with desc = Some text }

     

       343
       343
       +
              | "keywords" ->

     

       344
       344
       +
                let* text = parse_text_content parser in

     

       345
       345
       +
                loop { metadata with keywords = Some text }

     

       346
       346
       +
              | "time" ->

     

       347
       347
       +
                let* text = parse_text_content parser in

     

       348
       348
       +
                loop { metadata with time = parse_time text }

     

       349
       349
       +
              | "link" ->

     

       350
       350
       +
                let* link = parse_link parser attrs in

     

       351
       351
       +
                loop { metadata with links = link :: metadata.links }

     

       352
       352
       +
              | "extensions" ->

     

       353
       353
       +
                let* extensions = parse_extensions parser in

     

       354
       354
       +
                loop { metadata with extensions = extensions @ metadata.extensions }

     

       355
       355
       +
              | _ ->

     

       356
       356
       +
                let* _ = skip_element parser in

     

       357
       357
       +
                loop metadata)

     

       358
       358
       +
           | `El_end ->

     

       359
       359
       +
             parser.current_element <- List.tl parser.current_element;

     

       360
       360
       +
             Ok { metadata with links = List.rev metadata.links }

     

       361
       361
       +
           | `Data _ ->

     

       362
       362
       +
             loop metadata

     

       363
       363
       +
           | `Dtd _ ->

     

       364
       364
       +
             loop metadata

     

       365
       365
       +
         in

     

       366
       366
       +
         loop metadata

     

       367
       367
       +
       

     

       368
       368
       +
       and parse_route parser =

     

       369
       369
       +
         let route = { 

     

       370
       370
       +
           name = None; cmt = None; desc = None; src = None; links = [];

     

       371
       371
       +
           number = None; type_ = None; extensions = []; rtepts = []

     

       372
       372
       +
         } in

     

       373
       373
       +
         let rec loop (route : route) =

     

       374
       374
       +
           match Xmlm.input parser.input with

     

       375
       375
       +
           | `El_start ((_, name), attrs) ->

     

       376
       376
       +
             parser.current_element <- name :: parser.current_element;

     

       377
       377
       +
             (match name with

     

       378
       378
       +
              | "name" ->

     

       379
       379
       +
                let* text = parse_text_content parser in

     

       380
       380
       +
                loop { route with name = Some text }

     

       381
       381
       +
              | "cmt" ->

     

       382
       382
       +
                let* text = parse_text_content parser in

     

       383
       383
       +
                loop { route with cmt = Some text }

     

       384
       384
       +
              | "desc" ->

     

       385
       385
       +
                let* text = parse_text_content parser in

     

       386
       386
       +
                loop { route with desc = Some text }

     

       387
       387
       +
              | "src" ->

     

       388
       388
       +
                let* text = parse_text_content parser in

     

       389
       389
       +
                loop { route with src = Some text }

     

       390
       390
       +
              | "number" ->

     

       391
       391
       +
                let* text = parse_text_content parser in

     

       392
       392
       +
                (match parse_int_opt text with

     

       393
       393
       +
                 | Some n -> loop { route with number = Some n }

     

       394
       394
       +
                 | None -> loop route)

     

       395
       395
       +
              | "type" ->

     

       396
       396
       +
                let* text = parse_text_content parser in

     

       397
       397
       +
                loop { route with type_ = Some text }

     

       398
       398
       +
              | "rtept" ->

     

       399
       399
       +
                let* (lat, lon) = parse_coordinates attrs "rtept" in

     

       400
       400
       +
                let* rtept = parse_waypoint_data parser lat lon in

     

       401
       401
       +
                loop { route with rtepts = rtept :: route.rtepts }

     

       402
       402
       +
              | "link" ->

     

       403
       403
       +
                let* link = parse_link parser attrs in

     

       404
       404
       +
                loop { route with links = link :: route.links }

     

       405
       405
       +
              | "extensions" ->

     

       406
       406
       +
                let* extensions = parse_extensions parser in

     

       407
       407
       +
                loop { route with extensions = extensions @ route.extensions }

     

       408
       408
       +
              | _ ->

     

       409
       409
       +
                let* _ = skip_element parser in

     

       410
       410
       +
                loop route)

     

       411
       411
       +
           | `El_end ->

     

       412
       412
       +
             parser.current_element <- List.tl parser.current_element;

     

       413
       413
       +
             Ok { route with 

     

       414
       414
       +
                  rtepts = List.rev route.rtepts;

     

       415
       415
       +
                  links = List.rev route.links }

     

       416
       416
       +
           | `Data _ ->

     

       417
       417
       +
             loop route

     

       418
       418
       +
           | `Dtd _ ->

     

       419
       419
       +
             loop route

     

       420
       420
       +
         in

     

       421
       421
       +
         loop route

     

       422
       422
       +
       

     

       423
       423
       +
       and parse_track parser =

     

       424
       424
       +
         let track = {

     

       425
       425
       +
           name = None; cmt = None; desc = None; src = None; links = [];

     

       426
       426
       +
           number = None; type_ = None; extensions = []; trksegs = []

     

       427
       427
       +
         } in

     

       428
       428
       +
         let rec loop track =

     

       429
       429
       +
           match Xmlm.input parser.input with

     

       430
       430
       +
           | `El_start ((_, name), attrs) ->

     

       431
       431
       +
             parser.current_element <- name :: parser.current_element;

     

       432
       432
       +
             (match name with

     

       433
       433
       +
              | "name" ->

     

       434
       434
       +
                let* text = parse_text_content parser in

     

       435
       435
       +
                loop { track with name = Some text }

     

       436
       436
       +
              | "cmt" ->

     

       437
       437
       +
                let* text = parse_text_content parser in

     

       438
       438
       +
                loop { track with cmt = Some text }

     

       439
       439
       +
              | "desc" ->

     

       440
       440
       +
                let* text = parse_text_content parser in

     

       441
       441
       +
                loop { track with desc = Some text }

     

       442
       442
       +
              | "src" ->

     

       443
       443
       +
                let* text = parse_text_content parser in

     

       444
       444
       +
                loop { track with src = Some text }

     

       445
       445
       +
              | "number" ->

     

       446
       446
       +
                let* text = parse_text_content parser in

     

       447
       447
       +
                (match parse_int_opt text with

     

       448
       448
       +
                 | Some n -> loop { track with number = Some n }

     

       449
       449
       +
                 | None -> loop track)

     

       450
       450
       +
              | "type" ->

     

       451
       451
       +
                let* text = parse_text_content parser in

     

       452
       452
       +
                loop { track with type_ = Some text }

     

       453
       453
       +
              | "trkseg" ->

     

       454
       454
       +
                let* trkseg = parse_track_segment parser in

     

       455
       455
       +
                loop { track with trksegs = trkseg :: track.trksegs }

     

       456
       456
       +
              | "link" ->

     

       457
       457
       +
                let* link = parse_link parser attrs in

     

       458
       458
       +
                loop { track with links = link :: track.links }

     

       459
       459
       +
              | "extensions" ->

     

       460
       460
       +
                let* extensions = parse_extensions parser in

     

       461
       461
       +
                loop { track with extensions = extensions @ track.extensions }

     

       462
       462
       +
              | _ ->

     

       463
       463
       +
                let* _ = skip_element parser in

     

       464
       464
       +
                loop track)

     

       465
       465
       +
           | `El_end ->

     

       466
       466
       +
             parser.current_element <- List.tl parser.current_element;

     

       467
       467
       +
             Ok { track with

     

       468
       468
       +
                  trksegs = List.rev track.trksegs;

     

       469
       469
       +
                  links = List.rev track.links }

     

       470
       470
       +
           | `Data _ ->

     

       471
       471
       +
             loop track

     

       472
       472
       +
           | `Dtd _ ->

     

       473
       473
       +
             loop track

     

       474
       474
       +
         in

     

       475
       475
       +
         loop track

     

       476
       476
       +
       

     

       477
       477
       +
       and parse_track_segment parser =

     

       478
       478
       +
         let trkseg = { trkpts = []; extensions = [] } in

     

       479
       479
       +
         let rec loop trkseg =

     

       480
       480
       +
           match Xmlm.input parser.input with

     

       481
       481
       +
           | `El_start ((_, name), attrs) ->

     

       482
       482
       +
             parser.current_element <- name :: parser.current_element;

     

       483
       483
       +
             (match name with

     

       484
       484
       +
              | "trkpt" ->

     

       485
       485
       +
                let* (lat, lon) = parse_coordinates attrs "trkpt" in

     

       486
       486
       +
                let* trkpt = parse_waypoint_data parser lat lon in

     

       487
       487
       +
                loop { trkseg with trkpts = trkpt :: trkseg.trkpts }

     

       488
       488
       +
              | "extensions" ->

     

       489
       489
       +
                let* extensions = parse_extensions parser in

     

       490
       490
       +
                loop { trkseg with extensions = extensions @ trkseg.extensions }

     

       491
       491
       +
              | _ ->

     

       492
       492
       +
                let* _ = skip_element parser in

     

       493
       493
       +
                loop trkseg)

     

       494
       494
       +
           | `El_end ->

     

       495
       495
       +
             parser.current_element <- List.tl parser.current_element;

     

       496
       496
       +
             Ok { trkseg with trkpts = List.rev trkseg.trkpts }

     

       497
       497
       +
           | `Data _ ->

     

       498
       498
       +
             loop trkseg

     

       499
       499
       +
           | `Dtd _ ->

     

       500
       500
       +
             loop trkseg

     

       501
       501
       +
         in

     

       502
       502
       +
         loop trkseg

     

       503
       503
       +
       

     

       504
       504
       +
       (** Main parsing function *)

     

       505
       505
       +
       let parse input =

     

       506
       506
       +
         let parser = make_parser input in

     

       507
       507
       +
         try

     

       508
       508
       +
           parse_gpx parser

     

       509
       509
       +
         with

     

       510
       510
       +
         | Xmlm.Error ((line, col), error) ->

     

       511
       511
       +
           Error (Xml_error (Printf.sprintf "XML error at line %d, column %d: %s"

     

       512
       512
       +
                             line col (Xmlm.error_message error)))

     

       513
       513
       +
         | exn ->

     

       514
       514
       +
           Error (Invalid_xml (Printexc.to_string exn))

     

       515
       515
       +
       

     

       516
       516
       +
       (** Parse from string *)

     

       517
       517
       +
       let parse_string s =

     

       518
       518
       +
         let input = Xmlm.make_input (`String (0, s)) in

     

       519
       519
       +
         parse input

lib/gpx/parser.mli

···

       1
       1
       +
       (** GPX streaming parser using xmlm *)

     

       2
       2
       +
       

     

       3
       3
       +
       open Types

     

       4
       4
       +
       

     

       5
       5
       +
       (** Parse a GPX document from an xmlm input source *)

     

       6
       6
       +
       val parse : Xmlm.input -> gpx result

     

       7
       7
       +
       

     

       8
       8
       +
       (** Parse a GPX document from a string *)

     

       9
       9
       +
       val parse_string : string -> gpx result

+228

lib/gpx/types.ml

···

       1
       1
       +
       (** Core GPX types matching the GPX 1.1 XSD schema *)

     

       2
       2
       +
       

     

       3
       3
       +
       [@@@warning "-30"]

     

       4
       4
       +
       

     

       5
       5
       +
       (** Geographic coordinates with validation constraints *)

     

       6
       6
       +
       type latitude = private float

     

       7
       7
       +
       type longitude = private float  

     

       8
       8
       +
       type degrees = private float

     

       9
       9
       +
       

     

       10
       10
       +
       (** Smart constructors for validated coordinates *)

     

       11
       11
       +
       let latitude f =

     

       12
       12
       +
         if f >= -90.0 && f <= 90.0 then Ok (Obj.magic f : latitude)

     

       13
       13
       +
         else Error (Printf.sprintf "Invalid latitude: %f (must be between -90.0 and 90.0)" f)

     

       14
       14
       +
       

     

       15
       15
       +
       let longitude f =

     

       16
       16
       +
         if f >= -180.0 && f < 180.0 then Ok (Obj.magic f : longitude)

     

       17
       17
       +
         else Error (Printf.sprintf "Invalid longitude: %f (must be between -180.0 and 180.0)" f)

     

       18
       18
       +
       

     

       19
       19
       +
       let degrees f =

     

       20
       20
       +
         if f >= 0.0 && f < 360.0 then Ok (Obj.magic f : degrees)

     

       21
       21
       +
         else Error (Printf.sprintf "Invalid degrees: %f (must be between 0.0 and 360.0)" f)

     

       22
       22
       +
       

     

       23
       23
       +
       (** Convert back to float *)

     

       24
       24
       +
       let latitude_to_float (lat : latitude) = (lat :> float)

     

       25
       25
       +
       let longitude_to_float (lon : longitude) = (lon :> float)

     

       26
       26
       +
       let degrees_to_float (deg : degrees) = (deg :> float)

     

       27
       27
       +
       

     

       28
       28
       +
       (** GPS fix types as defined in GPX spec *)

     

       29
       29
       +
       type fix_type = 

     

       30
       30
       +
         | None_fix

     

       31
       31
       +
         | Fix_2d

     

       32
       32
       +
         | Fix_3d

     

       33
       33
       +
         | Dgps

     

       34
       34
       +
         | Pps

     

       35
       35
       +
       

     

       36
       36
       +
       (** Person information *)

     

       37
       37
       +
       type person = {

     

       38
       38
       +
         name : string option;

     

       39
       39
       +
         email : string option;

     

       40
       40
       +
         link : link option;

     

       41
       41
       +
       }

     

       42
       42
       +
       

     

       43
       43
       +
       (** Link information *)

     

       44
       44
       +
       and link = {

     

       45
       45
       +
         href : string;

     

       46
       46
       +
         text : string option;

     

       47
       47
       +
         type_ : string option;

     

       48
       48
       +
       }

     

       49
       49
       +
       

     

       50
       50
       +
       (** Copyright information *)

     

       51
       51
       +
       type copyright = {

     

       52
       52
       +
         author : string;

     

       53
       53
       +
         year : int option;

     

       54
       54
       +
         license : string option;

     

       55
       55
       +
       }

     

       56
       56
       +
       

     

       57
       57
       +
       (** Bounding box *)

     

       58
       58
       +
       type bounds = {

     

       59
       59
       +
         minlat : latitude;

     

       60
       60
       +
         minlon : longitude;

     

       61
       61
       +
         maxlat : latitude;

     

       62
       62
       +
         maxlon : longitude;

     

       63
       63
       +
       }

     

       64
       64
       +
       

     

       65
       65
       +
       (** Metadata container *)

     

       66
       66
       +
       type metadata = {

     

       67
       67
       +
         name : string option;

     

       68
       68
       +
         desc : string option;

     

       69
       69
       +
         author : person option;

     

       70
       70
       +
         copyright : copyright option;

     

       71
       71
       +
         links : link list;

     

       72
       72
       +
         time : Ptime.t option;

     

       73
       73
       +
         keywords : string option;

     

       74
       74
       +
         bounds : bounds option;

     

       75
       75
       +
         extensions : extension list;

     

       76
       76
       +
       }

     

       77
       77
       +
       

     

       78
       78
       +
       (** Extension mechanism for custom elements *)

     

       79
       79
       +
       and extension = {

     

       80
       80
       +
         namespace : string option;

     

       81
       81
       +
         name : string;

     

       82
       82
       +
         attributes : (string * string) list;

     

       83
       83
       +
         content : extension_content;

     

       84
       84
       +
       }

     

       85
       85
       +
       

     

       86
       86
       +
       and extension_content =

     

       87
       87
       +
         | Text of string

     

       88
       88
       +
         | Elements of extension list

     

       89
       89
       +
         | Mixed of string * extension list

     

       90
       90
       +
       

     

       91
       91
       +
       (** Base waypoint data shared by wpt, rtept, trkpt *)

     

       92
       92
       +
       type waypoint_data = {

     

       93
       93
       +
         lat : latitude;

     

       94
       94
       +
         lon : longitude;

     

       95
       95
       +
         ele : float option;

     

       96
       96
       +
         time : Ptime.t option;

     

       97
       97
       +
         magvar : degrees option;

     

       98
       98
       +
         geoidheight : float option;

     

       99
       99
       +
         name : string option;

     

       100
       100
       +
         cmt : string option;

     

       101
       101
       +
         desc : string option;

     

       102
       102
       +
         src : string option;

     

       103
       103
       +
         links : link list;

     

       104
       104
       +
         sym : string option;

     

       105
       105
       +
         type_ : string option;

     

       106
       106
       +
         fix : fix_type option;

     

       107
       107
       +
         sat : int option;

     

       108
       108
       +
         hdop : float option;

     

       109
       109
       +
         vdop : float option;

     

       110
       110
       +
         pdop : float option;

     

       111
       111
       +
         ageofdgpsdata : float option;

     

       112
       112
       +
         dgpsid : int option;

     

       113
       113
       +
         extensions : extension list;

     

       114
       114
       +
       }

     

       115
       115
       +
       

     

       116
       116
       +
       (** Waypoint *)

     

       117
       117
       +
       type waypoint = waypoint_data

     

       118
       118
       +
       

     

       119
       119
       +
       (** Route point *)

     

       120
       120
       +
       type route_point = waypoint_data

     

       121
       121
       +
       

     

       122
       122
       +
       (** Track point *)

     

       123
       123
       +
       type track_point = waypoint_data

     

       124
       124
       +
       

     

       125
       125
       +
       (** Route definition *)

     

       126
       126
       +
       type route = {

     

       127
       127
       +
         name : string option;

     

       128
       128
       +
         cmt : string option;

     

       129
       129
       +
         desc : string option;

     

       130
       130
       +
         src : string option;

     

       131
       131
       +
         links : link list;

     

       132
       132
       +
         number : int option;

     

       133
       133
       +
         type_ : string option;

     

       134
       134
       +
         extensions : extension list;

     

       135
       135
       +
         rtepts : route_point list;

     

       136
       136
       +
       }

     

       137
       137
       +
       

     

       138
       138
       +
       (** Track segment *)

     

       139
       139
       +
       type track_segment = {

     

       140
       140
       +
         trkpts : track_point list;

     

       141
       141
       +
         extensions : extension list;

     

       142
       142
       +
       }

     

       143
       143
       +
       

     

       144
       144
       +
       (** Track definition *)

     

       145
       145
       +
       type track = {

     

       146
       146
       +
         name : string option;

     

       147
       147
       +
         cmt : string option;

     

       148
       148
       +
         desc : string option;

     

       149
       149
       +
         src : string option;

     

       150
       150
       +
         links : link list;

     

       151
       151
       +
         number : int option;

     

       152
       152
       +
         type_ : string option;

     

       153
       153
       +
         extensions : extension list;

     

       154
       154
       +
         trksegs : track_segment list;

     

       155
       155
       +
       }

     

       156
       156
       +
       

     

       157
       157
       +
       (** Main GPX document *)

     

       158
       158
       +
       type gpx = {

     

       159
       159
       +
         version : string; (* Always "1.1" for this version *)

     

       160
       160
       +
         creator : string;

     

       161
       161
       +
         metadata : metadata option;

     

       162
       162
       +
         waypoints : waypoint list;

     

       163
       163
       +
         routes : route list;

     

       164
       164
       +
         tracks : track list;

     

       165
       165
       +
         extensions : extension list;

     

       166
       166
       +
       }

     

       167
       167
       +
       

     

       168
       168
       +
       (** Parser/Writer errors *)

     

       169
       169
       +
       type error =

     

       170
       170
       +
         | Invalid_xml of string

     

       171
       171
       +
         | Invalid_coordinate of string

     

       172
       172
       +
         | Missing_required_attribute of string * string

     

       173
       173
       +
         | Missing_required_element of string

     

       174
       174
       +
         | Validation_error of string

     

       175
       175
       +
         | Xml_error of string

     

       176
       176
       +
         | IO_error of string

     

       177
       177
       +
       

     

       178
       178
       +
       exception Gpx_error of error

     

       179
       179
       +
       

     

       180
       180
       +
       (** Result type for operations that can fail *)

     

       181
       181
       +
       type 'a result = ('a, error) Result.t

     

       182
       182
       +
       

     

       183
       183
       +
       (** Utility functions *)

     

       184
       184
       +
       

     

       185
       185
       +
       (** Convert fix_type to string *)

     

       186
       186
       +
       let fix_type_to_string = function

     

       187
       187
       +
         | None_fix -> "none"

     

       188
       188
       +
         | Fix_2d -> "2d" 

     

       189
       189
       +
         | Fix_3d -> "3d"

     

       190
       190
       +
         | Dgps -> "dgps"

     

       191
       191
       +
         | Pps -> "pps"

     

       192
       192
       +
       

     

       193
       193
       +
       (** Parse fix_type from string *)

     

       194
       194
       +
       let fix_type_of_string = function

     

       195
       195
       +
         | "none" -> Some None_fix

     

       196
       196
       +
         | "2d" -> Some Fix_2d

     

       197
       197
       +
         | "3d" -> Some Fix_3d

     

       198
       198
       +
         | "dgps" -> Some Dgps

     

       199
       199
       +
         | "pps" -> Some Pps

     

       200
       200
       +
         | _ -> None

     

       201
       201
       +
       

     

       202
       202
       +
       (** Create empty waypoint_data with required coordinates *)

     

       203
       203
       +
       let make_waypoint_data lat lon = {

     

       204
       204
       +
         lat; lon;

     

       205
       205
       +
         ele = None; time = None; magvar = None; geoidheight = None;

     

       206
       206
       +
         name = None; cmt = None; desc = None; src = None; links = [];

     

       207
       207
       +
         sym = None; type_ = None; fix = None; sat = None;

     

       208
       208
       +
         hdop = None; vdop = None; pdop = None; ageofdgpsdata = None;

     

       209
       209
       +
         dgpsid = None; extensions = [];

     

       210
       210
       +
       }

     

       211
       211
       +
       

     

       212
       212
       +
       (** Create empty metadata *)

     

       213
       213
       +
       let empty_metadata = {

     

       214
       214
       +
         name = None; desc = None; author = None; copyright = None;

     

       215
       215
       +
         links = []; time = None; keywords = None; bounds = None;

     

       216
       216
       +
         extensions = [];

     

       217
       217
       +
       }

     

       218
       218
       +
       

     

       219
       219
       +
       (** Create empty GPX document *)

     

       220
       220
       +
       let make_gpx ~creator = {

     

       221
       221
       +
         version = "1.1";

     

       222
       222
       +
         creator;

     

       223
       223
       +
         metadata = None;

     

       224
       224
       +
         waypoints = [];

     

       225
       225
       +
         routes = [];

     

       226
       226
       +
         tracks = [];

     

       227
       227
       +
         extensions = [];

     

       228
       228
       +
       }

+190

lib/gpx/types.mli

···

       1
       1
       +
       (** Core GPX types matching the GPX 1.1 XSD schema *)

     

       2
       2
       +
       

     

       3
       3
       +
       [@@@warning "-30"]

     

       4
       4
       +
       

     

       5
       5
       +
       (** Geographic coordinates with validation constraints *)

     

       6
       6
       +
       type latitude = private float

     

       7
       7
       +
       type longitude = private float

     

       8
       8
       +
       type degrees = private float

     

       9
       9
       +
       

     

       10
       10
       +
       (** Smart constructors for validated coordinates *)

     

       11
       11
       +
       val latitude : float -> (latitude, string) result

     

       12
       12
       +
       val longitude : float -> (longitude, string) result

     

       13
       13
       +
       val degrees : float -> (degrees, string) result

     

       14
       14
       +
       

     

       15
       15
       +
       (** Convert back to float *)

     

       16
       16
       +
       val latitude_to_float : latitude -> float

     

       17
       17
       +
       val longitude_to_float : longitude -> float

     

       18
       18
       +
       val degrees_to_float : degrees -> float

     

       19
       19
       +
       

     

       20
       20
       +
       (** GPS fix types as defined in GPX spec *)

     

       21
       21
       +
       type fix_type = 

     

       22
       22
       +
         | None_fix

     

       23
       23
       +
         | Fix_2d

     

       24
       24
       +
         | Fix_3d

     

       25
       25
       +
         | Dgps

     

       26
       26
       +
         | Pps

     

       27
       27
       +
       

     

       28
       28
       +
       (** Person information *)

     

       29
       29
       +
       type person = {

     

       30
       30
       +
         name : string option;

     

       31
       31
       +
         email : string option;

     

       32
       32
       +
         link : link option;

     

       33
       33
       +
       }

     

       34
       34
       +
       

     

       35
       35
       +
       (** Link information *)

     

       36
       36
       +
       and link = {

     

       37
       37
       +
         href : string;

     

       38
       38
       +
         text : string option;

     

       39
       39
       +
         type_ : string option;

     

       40
       40
       +
       }

     

       41
       41
       +
       

     

       42
       42
       +
       (** Copyright information *)

     

       43
       43
       +
       type copyright = {

     

       44
       44
       +
         author : string;

     

       45
       45
       +
         year : int option;

     

       46
       46
       +
         license : string option;

     

       47
       47
       +
       }

     

       48
       48
       +
       

     

       49
       49
       +
       (** Bounding box *)

     

       50
       50
       +
       type bounds = {

     

       51
       51
       +
         minlat : latitude;

     

       52
       52
       +
         minlon : longitude;

     

       53
       53
       +
         maxlat : latitude;

     

       54
       54
       +
         maxlon : longitude;

     

       55
       55
       +
       }

     

       56
       56
       +
       

     

       57
       57
       +
       (** Metadata container *)

     

       58
       58
       +
       type metadata = {

     

       59
       59
       +
         name : string option;

     

       60
       60
       +
         desc : string option;

     

       61
       61
       +
         author : person option;

     

       62
       62
       +
         copyright : copyright option;

     

       63
       63
       +
         links : link list;

     

       64
       64
       +
         time : Ptime.t option;

     

       65
       65
       +
         keywords : string option;

     

       66
       66
       +
         bounds : bounds option;

     

       67
       67
       +
         extensions : extension list;

     

       68
       68
       +
       }

     

       69
       69
       +
       

     

       70
       70
       +
       (** Extension mechanism for custom elements *)

     

       71
       71
       +
       and extension = {

     

       72
       72
       +
         namespace : string option;

     

       73
       73
       +
         name : string;

     

       74
       74
       +
         attributes : (string * string) list;

     

       75
       75
       +
         content : extension_content;

     

       76
       76
       +
       }

     

       77
       77
       +
       

     

       78
       78
       +
       and extension_content =

     

       79
       79
       +
         | Text of string

     

       80
       80
       +
         | Elements of extension list

     

       81
       81
       +
         | Mixed of string * extension list

     

       82
       82
       +
       

     

       83
       83
       +
       (** Base waypoint data shared by wpt, rtept, trkpt *)

     

       84
       84
       +
       type waypoint_data = {

     

       85
       85
       +
         lat : latitude;

     

       86
       86
       +
         lon : longitude;

     

       87
       87
       +
         ele : float option;

     

       88
       88
       +
         time : Ptime.t option;

     

       89
       89
       +
         magvar : degrees option;

     

       90
       90
       +
         geoidheight : float option;

     

       91
       91
       +
         name : string option;

     

       92
       92
       +
         cmt : string option;

     

       93
       93
       +
         desc : string option;

     

       94
       94
       +
         src : string option;

     

       95
       95
       +
         links : link list;

     

       96
       96
       +
         sym : string option;

     

       97
       97
       +
         type_ : string option;

     

       98
       98
       +
         fix : fix_type option;

     

       99
       99
       +
         sat : int option;

     

       100
       100
       +
         hdop : float option;

     

       101
       101
       +
         vdop : float option;

     

       102
       102
       +
         pdop : float option;

     

       103
       103
       +
         ageofdgpsdata : float option;

     

       104
       104
       +
         dgpsid : int option;

     

       105
       105
       +
         extensions : extension list;

     

       106
       106
       +
       }

     

       107
       107
       +
       

     

       108
       108
       +
       (** Waypoint *)

     

       109
       109
       +
       type waypoint = waypoint_data

     

       110
       110
       +
       

     

       111
       111
       +
       (** Route point *)

     

       112
       112
       +
       type route_point = waypoint_data

     

       113
       113
       +
       

     

       114
       114
       +
       (** Track point *)

     

       115
       115
       +
       type track_point = waypoint_data

     

       116
       116
       +
       

     

       117
       117
       +
       (** Route definition *)

     

       118
       118
       +
       type route = {

     

       119
       119
       +
         name : string option;

     

       120
       120
       +
         cmt : string option;

     

       121
       121
       +
         desc : string option;

     

       122
       122
       +
         src : string option;

     

       123
       123
       +
         links : link list;

     

       124
       124
       +
         number : int option;

     

       125
       125
       +
         type_ : string option;

     

       126
       126
       +
         extensions : extension list;

     

       127
       127
       +
         rtepts : route_point list;

     

       128
       128
       +
       }

     

       129
       129
       +
       

     

       130
       130
       +
       (** Track segment *)

     

       131
       131
       +
       type track_segment = {

     

       132
       132
       +
         trkpts : track_point list;

     

       133
       133
       +
         extensions : extension list;

     

       134
       134
       +
       }

     

       135
       135
       +
       

     

       136
       136
       +
       (** Track definition *)

     

       137
       137
       +
       type track = {

     

       138
       138
       +
         name : string option;

     

       139
       139
       +
         cmt : string option;

     

       140
       140
       +
         desc : string option;

     

       141
       141
       +
         src : string option;

     

       142
       142
       +
         links : link list;

     

       143
       143
       +
         number : int option;

     

       144
       144
       +
         type_ : string option;

     

       145
       145
       +
         extensions : extension list;

     

       146
       146
       +
         trksegs : track_segment list;

     

       147
       147
       +
       }

     

       148
       148
       +
       

     

       149
       149
       +
       (** Main GPX document *)

     

       150
       150
       +
       type gpx = {

     

       151
       151
       +
         version : string; (* Always "1.1" for this version *)

     

       152
       152
       +
         creator : string;

     

       153
       153
       +
         metadata : metadata option;

     

       154
       154
       +
         waypoints : waypoint list;

     

       155
       155
       +
         routes : route list;

     

       156
       156
       +
         tracks : track list;

     

       157
       157
       +
         extensions : extension list;

     

       158
       158
       +
       }

     

       159
       159
       +
       

     

       160
       160
       +
       (** Parser/Writer errors *)

     

       161
       161
       +
       type error =

     

       162
       162
       +
         | Invalid_xml of string

     

       163
       163
       +
         | Invalid_coordinate of string

     

       164
       164
       +
         | Missing_required_attribute of string * string

     

       165
       165
       +
         | Missing_required_element of string

     

       166
       166
       +
         | Validation_error of string

     

       167
       167
       +
         | Xml_error of string

     

       168
       168
       +
         | IO_error of string

     

       169
       169
       +
       

     

       170
       170
       +
       exception Gpx_error of error

     

       171
       171
       +
       

     

       172
       172
       +
       (** Result type for operations that can fail *)

     

       173
       173
       +
       type 'a result = ('a, error) Result.t

     

       174
       174
       +
       

     

       175
       175
       +
       (** Utility functions *)

     

       176
       176
       +
       

     

       177
       177
       +
       (** Convert fix_type to string *)

     

       178
       178
       +
       val fix_type_to_string : fix_type -> string

     

       179
       179
       +
       

     

       180
       180
       +
       (** Parse fix_type from string *)

     

       181
       181
       +
       val fix_type_of_string : string -> fix_type option

     

       182
       182
       +
       

     

       183
       183
       +
       (** Create empty waypoint_data with required coordinates *)

     

       184
       184
       +
       val make_waypoint_data : latitude -> longitude -> waypoint_data

     

       185
       185
       +
       

     

       186
       186
       +
       (** Create empty metadata *)

     

       187
       187
       +
       val empty_metadata : metadata

     

       188
       188
       +
       

     

       189
       189
       +
       (** Create empty GPX document *)

     

       190
       190
       +
       val make_gpx : creator:string -> gpx

+233

lib/gpx/validate.ml

···

       1
       1
       +
       (** GPX validation utilities *)

     

       2
       2
       +
       

     

       3
       3
       +
       open Types

     

       4
       4
       +
       

     

       5
       5
       +
       (** Validation error messages *)

     

       6
       6
       +
       type validation_issue = {

     

       7
       7
       +
         level : [`Error | `Warning];

     

       8
       8
       +
         message : string;

     

       9
       9
       +
         location : string option;

     

       10
       10
       +
       }

     

       11
       11
       +
       

     

       12
       12
       +
       type validation_result = {

     

       13
       13
       +
         issues : validation_issue list;

     

       14
       14
       +
         is_valid : bool;

     

       15
       15
       +
       }

     

       16
       16
       +
       

     

       17
       17
       +
       let make_error ?location message = {

     

       18
       18
       +
         level = `Error;

     

       19
       19
       +
         message;

     

       20
       20
       +
         location;

     

       21
       21
       +
       }

     

       22
       22
       +
       

     

       23
       23
       +
       let make_warning ?location message = {

     

       24
       24
       +
         level = `Warning;

     

       25
       25
       +
         message;

     

       26
       26
       +
         location;

     

       27
       27
       +
       }

     

       28
       28
       +
       

     

       29
       29
       +
       (** Validate waypoint data *)

     

       30
       30
       +
       let validate_waypoint_data wpt location =

     

       31
       31
       +
         let issues = ref [] in

     

       32
       32
       +
         

     

       33
       33
       +
         (* Check for negative satellite count *)

     

       34
       34
       +
         (match wpt.sat with

     

       35
       35
       +
          | Some sat when sat < 0 ->

     

       36
       36
       +
            issues := make_warning ~location ("Negative satellite count: " ^ string_of_int sat) :: !issues

     

       37
       37
       +
          | _ -> ());

     

       38
       38
       +
         

     

       39
       39
       +
         (* Check for unreasonable precision values *)

     

       40
       40
       +
         let check_precision name value =

     

       41
       41
       +
           match value with

     

       42
       42
       +
           | Some v when v < 0.0 ->

     

       43
       43
       +
             issues := make_warning ~location (Printf.sprintf "Negative %s value: %.2f" name v) :: !issues

     

       44
       44
       +
           | Some v when v > 1000.0 ->

     

       45
       45
       +
             issues := make_warning ~location (Printf.sprintf "Very large %s value: %.2f" name v) :: !issues

     

       46
       46
       +
           | _ -> ()

     

       47
       47
       +
         in

     

       48
       48
       +
         

     

       49
       49
       +
         check_precision "hdop" wpt.hdop;

     

       50
       50
       +
         check_precision "vdop" wpt.vdop;

     

       51
       51
       +
         check_precision "pdop" wpt.pdop;

     

       52
       52
       +
         

     

       53
       53
       +
         (* Check elevation reasonableness *)

     

       54
       54
       +
         (match wpt.ele with

     

       55
       55
       +
          | Some ele when ele < -15000.0 ->

     

       56
       56
       +
            issues := make_warning ~location (Printf.sprintf "Very low elevation: %.2f m" ele) :: !issues

     

       57
       57
       +
          | Some ele when ele > 15000.0 ->

     

       58
       58
       +
            issues := make_warning ~location (Printf.sprintf "Very high elevation: %.2f m" ele) :: !issues

     

       59
       59
       +
          | _ -> ());

     

       60
       60
       +
         

     

       61
       61
       +
         (* Check DGPS age *)

     

       62
       62
       +
         (match wpt.ageofdgpsdata with

     

       63
       63
       +
          | Some age when age < 0.0 ->

     

       64
       64
       +
            issues := make_error ~location "Negative DGPS age" :: !issues

     

       65
       65
       +
          | _ -> ());

     

       66
       66
       +
         

     

       67
       67
       +
         !issues

     

       68
       68
       +
       

     

       69
       69
       +
       (** Validate bounds *)

     

       70
       70
       +
       let validate_bounds bounds =

     

       71
       71
       +
         let issues = ref [] in

     

       72
       72
       +
         let location = "bounds" in

     

       73
       73
       +
         

     

       74
       74
       +
         if latitude_to_float bounds.minlat >= latitude_to_float bounds.maxlat then

     

       75
       75
       +
           issues := make_error ~location "minlat must be less than maxlat" :: !issues;

     

       76
       76
       +
         

     

       77
       77
       +
         if longitude_to_float bounds.minlon >= longitude_to_float bounds.maxlon then

     

       78
       78
       +
           issues := make_error ~location "minlon must be less than maxlon" :: !issues;

     

       79
       79
       +
         

     

       80
       80
       +
         !issues

     

       81
       81
       +
       

     

       82
       82
       +
       (** Validate metadata *)

     

       83
       83
       +
       let validate_metadata metadata =

     

       84
       84
       +
         let issues = ref [] in

     

       85
       85
       +
         

     

       86
       86
       +
         (* Validate bounds if present *)

     

       87
       87
       +
         (match metadata.bounds with

     

       88
       88
       +
          | Some bounds -> issues := validate_bounds bounds @ !issues

     

       89
       89
       +
          | None -> ());

     

       90
       90
       +
         

     

       91
       91
       +
         (* Check for reasonable copyright year *)

     

       92
       92
       +
         (match metadata.copyright with

     

       93
       93
       +
          | Some copyright ->

     

       94
       94
       +
            (match copyright.year with

     

       95
       95
       +
             | Some year when year < 1900 || year > 2100 ->

     

       96
       96
       +
               issues := make_warning ~location:"metadata.copyright" 

     

       97
       97
       +
                 (Printf.sprintf "Unusual copyright year: %d" year) :: !issues

     

       98
       98
       +
             | _ -> ())

     

       99
       99
       +
          | None -> ());

     

       100
       100
       +
         

     

       101
       101
       +
         !issues

     

       102
       102
       +
       

     

       103
       103
       +
       (** Validate route *)

     

       104
       104
       +
       let validate_route route =

     

       105
       105
       +
         let issues = ref [] in

     

       106
       106
       +
         let location = "route" in

     

       107
       107
       +
         

     

       108
       108
       +
         (* Check for empty route *)

     

       109
       109
       +
         if route.rtepts = [] then

     

       110
       110
       +
           issues := make_warning ~location "Route has no points" :: !issues;

     

       111
       111
       +
         

     

       112
       112
       +
         (* Validate route points *)

     

       113
       113
       +
         List.iteri (fun i rtept ->

     

       114
       114
       +
           let point_location = Printf.sprintf "route.rtept[%d]" i in

     

       115
       115
       +
           issues := validate_waypoint_data rtept point_location @ !issues

     

       116
       116
       +
         ) route.rtepts;

     

       117
       117
       +
         

     

       118
       118
       +
         !issues

     

       119
       119
       +
       

     

       120
       120
       +
       (** Validate track segment *)

     

       121
       121
       +
       let validate_track_segment trkseg seg_idx =

     

       122
       122
       +
         let issues = ref [] in

     

       123
       123
       +
         let location = Printf.sprintf "track.trkseg[%d]" seg_idx in

     

       124
       124
       +
         

     

       125
       125
       +
         (* Check for empty segment *)

     

       126
       126
       +
         if trkseg.trkpts = [] then

     

       127
       127
       +
           issues := make_warning ~location "Track segment has no points" :: !issues;

     

       128
       128
       +
         

     

       129
       129
       +
         (* Validate track points *)

     

       130
       130
       +
         List.iteri (fun i trkpt ->

     

       131
       131
       +
           let point_location = Printf.sprintf "%s.trkpt[%d]" location i in

     

       132
       132
       +
           issues := validate_waypoint_data trkpt point_location @ !issues

     

       133
       133
       +
         ) trkseg.trkpts;

     

       134
       134
       +
         

     

       135
       135
       +
         (* Check for time ordering if timestamps are present *)

     

       136
       136
       +
         let rec check_time_order prev_time = function

     

       137
       137
       +
           | [] -> ()

     

       138
       138
       +
           | trkpt :: rest ->

     

       139
       139
       +
             (match (prev_time, trkpt.time) with

     

       140
       140
       +
              | (Some prev, Some curr) when Ptime.compare prev curr > 0 ->

     

       141
       141
       +
                issues := make_warning ~location "Track points not in chronological order" :: !issues

     

       142
       142
       +
              | _ -> ());

     

       143
       143
       +
             check_time_order trkpt.time rest

     

       144
       144
       +
         in

     

       145
       145
       +
         check_time_order None trkseg.trkpts;

     

       146
       146
       +
         

     

       147
       147
       +
         !issues

     

       148
       148
       +
       

     

       149
       149
       +
       (** Validate track *)

     

       150
       150
       +
       let validate_track track =

     

       151
       151
       +
         let issues = ref [] in

     

       152
       152
       +
         let location = "track" in

     

       153
       153
       +
         

     

       154
       154
       +
         (* Check for empty track *)

     

       155
       155
       +
         if track.trksegs = [] then

     

       156
       156
       +
           issues := make_warning ~location "Track has no segments" :: !issues;

     

       157
       157
       +
         

     

       158
       158
       +
         (* Validate track segments *)

     

       159
       159
       +
         List.iteri (fun i trkseg ->

     

       160
       160
       +
           issues := validate_track_segment trkseg i @ !issues

     

       161
       161
       +
         ) track.trksegs;

     

       162
       162
       +
         

     

       163
       163
       +
         !issues

     

       164
       164
       +
       

     

       165
       165
       +
       (** Validate complete GPX document *)

     

       166
       166
       +
       let validate_gpx gpx =

     

       167
       167
       +
         let issues = ref [] in

     

       168
       168
       +
         

     

       169
       169
       +
         (* Check GPX version *)

     

       170
       170
       +
         if gpx.version <> "1.1" then

     

       171
       171
       +
           issues := make_error ~location:"gpx" 

     

       172
       172
       +
             (Printf.sprintf "Unsupported GPX version: %s" gpx.version) :: !issues;

     

       173
       173
       +
         

     

       174
       174
       +
         (* Check for empty creator *)

     

       175
       175
       +
         if String.trim gpx.creator = "" then

     

       176
       176
       +
           issues := make_error ~location:"gpx" "Creator cannot be empty" :: !issues;

     

       177
       177
       +
         

     

       178
       178
       +
         (* Validate metadata *)

     

       179
       179
       +
         (match gpx.metadata with

     

       180
       180
       +
          | Some metadata -> issues := validate_metadata metadata @ !issues

     

       181
       181
       +
          | None -> ());

     

       182
       182
       +
         

     

       183
       183
       +
         (* Validate waypoints *)

     

       184
       184
       +
         List.iteri (fun i wpt ->

     

       185
       185
       +
           let location = Printf.sprintf "waypoint[%d]" i in

     

       186
       186
       +
           issues := validate_waypoint_data wpt location @ !issues

     

       187
       187
       +
         ) gpx.waypoints;

     

       188
       188
       +
         

     

       189
       189
       +
         (* Validate routes *)

     

       190
       190
       +
         List.iteri (fun _i route ->

     

       191
       191
       +
           issues := validate_route route @ !issues

     

       192
       192
       +
         ) gpx.routes;

     

       193
       193
       +
         

     

       194
       194
       +
         (* Validate tracks *)

     

       195
       195
       +
         List.iteri (fun _i track ->

     

       196
       196
       +
           issues := validate_track track @ !issues

     

       197
       197
       +
         ) gpx.tracks;

     

       198
       198
       +
         

     

       199
       199
       +
         (* Check for completely empty GPX *)

     

       200
       200
       +
         if gpx.waypoints = [] && gpx.routes = [] && gpx.tracks = [] then

     

       201
       201
       +
           issues := make_warning ~location:"gpx" "GPX document contains no geographic data" :: !issues;

     

       202
       202
       +
         

     

       203
       203
       +
         let all_issues = !issues in

     

       204
       204
       +
         let has_errors = List.exists (fun issue -> issue.level = `Error) all_issues in

     

       205
       205
       +
         

     

       206
       206
       +
         { issues = all_issues; is_valid = not has_errors }

     

       207
       207
       +
       

     

       208
       208
       +
       (** Quick validation - returns true if document is valid *)

     

       209
       209
       +
       let is_valid gpx =

     

       210
       210
       +
         let result = validate_gpx gpx in

     

       211
       211
       +
         result.is_valid

     

       212
       212
       +
       

     

       213
       213
       +
       (** Get only error messages *)

     

       214
       214
       +
       let get_errors gpx =

     

       215
       215
       +
         let result = validate_gpx gpx in

     

       216
       216
       +
         List.filter (fun issue -> issue.level = `Error) result.issues

     

       217
       217
       +
       

     

       218
       218
       +
       (** Get only warning messages *)

     

       219
       219
       +
       let get_warnings gpx =

     

       220
       220
       +
         let result = validate_gpx gpx in

     

       221
       221
       +
         List.filter (fun issue -> issue.level = `Warning) result.issues

     

       222
       222
       +
       

     

       223
       223
       +
       (** Format validation issue for display *)

     

       224
       224
       +
       let format_issue issue =

     

       225
       225
       +
         let level_str = match issue.level with

     

       226
       226
       +
           | `Error -> "ERROR"

     

       227
       227
       +
           | `Warning -> "WARNING"

     

       228
       228
       +
         in

     

       229
       229
       +
         let location_str = match issue.location with

     

       230
       230
       +
           | Some loc -> " at " ^ loc

     

       231
       231
       +
           | None -> ""

     

       232
       232
       +
         in

     

       233
       233
       +
         Printf.sprintf "%s%s: %s" level_str location_str issue.message

+31

lib/gpx/validate.mli

···

       1
       1
       +
       (** GPX validation utilities *)

     

       2
       2
       +
       

     

       3
       3
       +
       open Types

     

       4
       4
       +
       

     

       5
       5
       +
       (** Validation issue representation *)

     

       6
       6
       +
       type validation_issue = {

     

       7
       7
       +
         level : [`Error | `Warning];

     

       8
       8
       +
         message : string;

     

       9
       9
       +
         location : string option;

     

       10
       10
       +
       }

     

       11
       11
       +
       

     

       12
       12
       +
       (** Validation result *)

     

       13
       13
       +
       type validation_result = {

     

       14
       14
       +
         issues : validation_issue list;

     

       15
       15
       +
         is_valid : bool;

     

       16
       16
       +
       }

     

       17
       17
       +
       

     

       18
       18
       +
       (** Validate a complete GPX document *)

     

       19
       19
       +
       val validate_gpx : gpx -> validation_result

     

       20
       20
       +
       

     

       21
       21
       +
       (** Quick validation - returns true if document is valid *)

     

       22
       22
       +
       val is_valid : gpx -> bool

     

       23
       23
       +
       

     

       24
       24
       +
       (** Get only error messages *)

     

       25
       25
       +
       val get_errors : gpx -> validation_issue list

     

       26
       26
       +
       

     

       27
       27
       +
       (** Get only warning messages *)

     

       28
       28
       +
       val get_warnings : gpx -> validation_issue list

     

       29
       29
       +
       

     

       30
       30
       +
       (** Format validation issue for display *)

     

       31
       31
       +
       val format_issue : validation_issue -> string

+358

lib/gpx/writer.ml

···

       1
       1
       +
       (** GPX streaming writer using xmlm *)

     

       2
       2
       +
       

     

       3
       3
       +
       open Types

     

       4
       4
       +
       

     

       5
       5
       +
       (** Result binding operators *)

     

       6
       6
       +
       let (let*) = Result.bind

     

       7
       7
       +
       

     

       8
       8
       +
       (** Writer state for streaming *)

     

       9
       9
       +
       type writer_state = {

     

       10
       10
       +
         output : Xmlm.output;

     

       11
       11
       +
       }

     

       12
       12
       +
       

     

       13
       13
       +
       (** Create a new writer state *)

     

       14
       14
       +
       let make_writer output = { output }

     

       15
       15
       +
       

     

       16
       16
       +
       (** Utility functions *)

     

       17
       17
       +
       

     

       18
       18
       +
       let convert_attributes attrs =

     

       19
       19
       +
         List.map (fun (name, value) -> (("", name), value)) attrs

     

       20
       20
       +
       

     

       21
       21
       +
       let output_signal writer signal =

     

       22
       22
       +
         try

     

       23
       23
       +
           Xmlm.output writer.output signal;

     

       24
       24
       +
           Ok ()

     

       25
       25
       +
         with

     

       26
       26
       +
         | Xmlm.Error ((line, col), error) ->

     

       27
       27
       +
           Error (Xml_error (Printf.sprintf "XML error at line %d, column %d: %s"

     

       28
       28
       +
                             line col (Xmlm.error_message error)))

     

       29
       29
       +
         | exn ->

     

       30
       30
       +
           Error (Invalid_xml (Printexc.to_string exn))

     

       31
       31
       +
       

     

       32
       32
       +
       let output_element_start writer name attrs =

     

       33
       33
       +
         output_signal writer (`El_start (("", name), attrs))

     

       34
       34
       +
       

     

       35
       35
       +
       let output_element_end writer =

     

       36
       36
       +
         output_signal writer `El_end

     

       37
       37
       +
       

     

       38
       38
       +
       let output_data writer text =

     

       39
       39
       +
         if text <> "" then

     

       40
       40
       +
           output_signal writer (`Data text)

     

       41
       41
       +
         else

     

       42
       42
       +
           Ok ()

     

       43
       43
       +
       

     

       44
       44
       +
       let output_text_element writer name text =

     

       45
       45
       +
         let* () = output_element_start writer name [] in

     

       46
       46
       +
         let* () = output_data writer text in

     

       47
       47
       +
         output_element_end writer

     

       48
       48
       +
       

     

       49
       49
       +
       let output_optional_text_element writer name = function

     

       50
       50
       +
         | Some text -> output_text_element writer name text

     

       51
       51
       +
         | None -> Ok ()

     

       52
       52
       +
       

     

       53
       53
       +
       let output_float_element writer name f =

     

       54
       54
       +
         output_text_element writer name (Printf.sprintf "%.6f" f)

     

       55
       55
       +
       

     

       56
       56
       +
       let output_optional_float_element writer name = function

     

       57
       57
       +
         | Some f -> output_float_element writer name f

     

       58
       58
       +
         | None -> Ok ()

     

       59
       59
       +
       

     

       60
       60
       +
       let output_int_element writer name i =

     

       61
       61
       +
         output_text_element writer name (string_of_int i)

     

       62
       62
       +
       

     

       63
       63
       +
       let output_optional_int_element writer name = function

     

       64
       64
       +
         | Some i -> output_int_element writer name i

     

       65
       65
       +
         | None -> Ok ()

     

       66
       66
       +
       

     

       67
       67
       +
       let output_time_element writer name time =

     

       68
       68
       +
         output_text_element writer name (Ptime.to_rfc3339 time)

     

       69
       69
       +
       

     

       70
       70
       +
       let output_optional_time_element writer name = function

     

       71
       71
       +
         | Some time -> output_time_element writer name time

     

       72
       72
       +
         | None -> Ok ()

     

       73
       73
       +
       

     

       74
       74
       +
       (** Write GPX header and DTD *)

     

       75
       75
       +
       let write_header writer =

     

       76
       76
       +
         let* () = output_signal writer (`Dtd (Some "<?xml version=\"1.0\" encoding=\"UTF-8\"?>")) in

     

       77
       77
       +
         Ok ()

     

       78
       78
       +
       

     

       79
       79
       +
       (** Write link element *)

     

       80
       80
       +
       let write_link writer link =

     

       81
       81
       +
         let attrs = [(("" , "href"), link.href)] in

     

       82
       82
       +
         let* () = output_element_start writer "link" attrs in

     

       83
       83
       +
         let* () = output_optional_text_element writer "text" link.text in

     

       84
       84
       +
         let* () = output_optional_text_element writer "type" link.type_ in

     

       85
       85
       +
         output_element_end writer

     

       86
       86
       +
       

     

       87
       87
       +
       (** Write list of links *)

     

       88
       88
       +
       let write_links writer links =

     

       89
       89
       +
         let rec loop = function

     

       90
       90
       +
           | [] -> Ok ()

     

       91
       91
       +
           | link :: rest ->

     

       92
       92
       +
             let* () = write_link writer link in

     

       93
       93
       +
             loop rest

     

       94
       94
       +
         in

     

       95
       95
       +
         loop links

     

       96
       96
       +
       

     

       97
       97
       +
       (** Write extension content *)

     

       98
       98
       +
       let rec write_extension_content writer = function

     

       99
       99
       +
         | Text text -> output_data writer text

     

       100
       100
       +
         | Elements extensions -> write_extensions writer extensions

     

       101
       101
       +
         | Mixed (text, extensions) ->

     

       102
       102
       +
           let* () = output_data writer text in

     

       103
       103
       +
           write_extensions writer extensions

     

       104
       104
       +
       

     

       105
       105
       +
       (** Write extensions *)

     

       106
       106
       +
       and write_extensions writer extensions =

     

       107
       107
       +
         let rec loop = function

     

       108
       108
       +
           | [] -> Ok ()

     

       109
       109
       +
           | ext :: rest ->

     

       110
       110
       +
             let* () = write_extension writer ext in

     

       111
       111
       +
             loop rest

     

       112
       112
       +
         in

     

       113
       113
       +
         loop extensions

     

       114
       114
       +
       

     

       115
       115
       +
       and write_extension writer ext =

     

       116
       116
       +
         let name = match ext.namespace with

     

       117
       117
       +
           | Some ns -> ns ^ ":" ^ ext.name

     

       118
       118
       +
           | None -> ext.name

     

       119
       119
       +
         in

     

       120
       120
       +
         let* () = output_element_start writer name (convert_attributes ext.attributes) in

     

       121
       121
       +
         let* () = write_extension_content writer ext.content in

     

       122
       122
       +
         output_element_end writer

     

       123
       123
       +
       

     

       124
       124
       +
       (** Write waypoint data (shared by wpt, rtept, trkpt) *)

     

       125
       125
       +
       let write_waypoint_data writer element_name wpt =

     

       126
       126
       +
         let attrs = [

     

       127
       127
       +
           (("", "lat"), Printf.sprintf "%.6f" (latitude_to_float wpt.lat));

     

       128
       128
       +
           (("", "lon"), Printf.sprintf "%.6f" (longitude_to_float wpt.lon));

     

       129
       129
       +
         ] in

     

       130
       130
       +
         let* () = output_element_start writer element_name attrs in

     

       131
       131
       +
         let* () = output_optional_float_element writer "ele" wpt.ele in

     

       132
       132
       +
         let* () = output_optional_time_element writer "time" wpt.time in

     

       133
       133
       +
         let* () = (match wpt.magvar with

     

       134
       134
       +
                    | Some deg -> output_float_element writer "magvar" (degrees_to_float deg)

     

       135
       135
       +
                    | None -> Ok ()) in

     

       136
       136
       +
         let* () = output_optional_float_element writer "geoidheight" wpt.geoidheight in

     

       137
       137
       +
         let* () = output_optional_text_element writer "name" wpt.name in

     

       138
       138
       +
         let* () = output_optional_text_element writer "cmt" wpt.cmt in

     

       139
       139
       +
         let* () = output_optional_text_element writer "desc" wpt.desc in

     

       140
       140
       +
         let* () = output_optional_text_element writer "src" wpt.src in

     

       141
       141
       +
         let* () = write_links writer wpt.links in

     

       142
       142
       +
         let* () = output_optional_text_element writer "sym" wpt.sym in

     

       143
       143
       +
         let* () = output_optional_text_element writer "type" wpt.type_ in

     

       144
       144
       +
         let* () = (match wpt.fix with

     

       145
       145
       +
                    | Some fix -> output_text_element writer "fix" (fix_type_to_string fix)

     

       146
       146
       +
                    | None -> Ok ()) in

     

       147
       147
       +
         let* () = output_optional_int_element writer "sat" wpt.sat in

     

       148
       148
       +
         let* () = output_optional_float_element writer "hdop" wpt.hdop in

     

       149
       149
       +
         let* () = output_optional_float_element writer "vdop" wpt.vdop in

     

       150
       150
       +
         let* () = output_optional_float_element writer "pdop" wpt.pdop in

     

       151
       151
       +
         let* () = output_optional_float_element writer "ageofdgpsdata" wpt.ageofdgpsdata in

     

       152
       152
       +
         let* () = output_optional_int_element writer "dgpsid" wpt.dgpsid in

     

       153
       153
       +
         let* () = (if wpt.extensions <> [] then

     

       154
       154
       +
                    let* () = output_element_start writer "extensions" [] in

     

       155
       155
       +
                    let* () = write_extensions writer wpt.extensions in

     

       156
       156
       +
                    output_element_end writer

     

       157
       157
       +
                  else Ok ()) in

     

       158
       158
       +
         output_element_end writer

     

       159
       159
       +
       

     

       160
       160
       +
       (** Write waypoint *)

     

       161
       161
       +
       let write_waypoint writer wpt =

     

       162
       162
       +
         write_waypoint_data writer "wpt" wpt

     

       163
       163
       +
       

     

       164
       164
       +
       (** Write route point *)

     

       165
       165
       +
       let write_route_point writer rtept =

     

       166
       166
       +
         write_waypoint_data writer "rtept" rtept

     

       167
       167
       +
       

     

       168
       168
       +
       (** Write track point *)

     

       169
       169
       +
       let write_track_point writer trkpt =

     

       170
       170
       +
         write_waypoint_data writer "trkpt" trkpt

     

       171
       171
       +
       

     

       172
       172
       +
       (** Write person *)

     

       173
       173
       +
       let write_person writer (p : person) =

     

       174
       174
       +
         let* () = output_element_start writer "author" [] in

     

       175
       175
       +
         let* () = output_optional_text_element writer "name" p.name in

     

       176
       176
       +
         let* () = output_optional_text_element writer "email" p.email in

     

       177
       177
       +
         let* () = (match p.link with

     

       178
       178
       +
                    | Some link -> write_link writer link

     

       179
       179
       +
                    | None -> Ok ()) in

     

       180
       180
       +
         output_element_end writer

     

       181
       181
       +
       

     

       182
       182
       +
       (** Write copyright *)

     

       183
       183
       +
       let write_copyright writer (copyright : copyright) =

     

       184
       184
       +
         let attrs = [(("", "author"), copyright.author)] in

     

       185
       185
       +
         let* () = output_element_start writer "copyright" attrs in

     

       186
       186
       +
         let* () = (match copyright.year with

     

       187
       187
       +
                    | Some year -> output_int_element writer "year" year

     

       188
       188
       +
                    | None -> Ok ()) in

     

       189
       189
       +
         let* () = output_optional_text_element writer "license" copyright.license in

     

       190
       190
       +
         output_element_end writer

     

       191
       191
       +
       

     

       192
       192
       +
       (** Write bounds *)

     

       193
       193
       +
       let write_bounds writer bounds =

     

       194
       194
       +
         let attrs = [

     

       195
       195
       +
           (("", "minlat"), Printf.sprintf "%.6f" (latitude_to_float bounds.minlat));

     

       196
       196
       +
           (("", "minlon"), Printf.sprintf "%.6f" (longitude_to_float bounds.minlon));

     

       197
       197
       +
           (("", "maxlat"), Printf.sprintf "%.6f" (latitude_to_float bounds.maxlat));

     

       198
       198
       +
           (("", "maxlon"), Printf.sprintf "%.6f" (longitude_to_float bounds.maxlon));

     

       199
       199
       +
         ] in

     

       200
       200
       +
         let* () = output_element_start writer "bounds" attrs in

     

       201
       201
       +
         output_element_end writer

     

       202
       202
       +
       

     

       203
       203
       +
       (** Write metadata *)

     

       204
       204
       +
       let write_metadata writer (metadata : metadata) =

     

       205
       205
       +
         let* () = output_element_start writer "metadata" [] in

     

       206
       206
       +
         let* () = output_optional_text_element writer "name" metadata.name in

     

       207
       207
       +
         let* () = output_optional_text_element writer "desc" metadata.desc in

     

       208
       208
       +
         let* () = (match metadata.author with

     

       209
       209
       +
                    | Some author -> write_person writer author

     

       210
       210
       +
                    | None -> Ok ()) in

     

       211
       211
       +
         let* () = (match metadata.copyright with

     

       212
       212
       +
                    | Some copyright -> write_copyright writer copyright

     

       213
       213
       +
                    | None -> Ok ()) in

     

       214
       214
       +
         let* () = write_links writer metadata.links in

     

       215
       215
       +
         let* () = output_optional_time_element writer "time" metadata.time in

     

       216
       216
       +
         let* () = output_optional_text_element writer "keywords" metadata.keywords in

     

       217
       217
       +
         let* () = (match metadata.bounds with

     

       218
       218
       +
                    | Some bounds -> write_bounds writer bounds

     

       219
       219
       +
                    | None -> Ok ()) in

     

       220
       220
       +
         let* () = (if metadata.extensions <> [] then

     

       221
       221
       +
                    let* () = output_element_start writer "extensions" [] in

     

       222
       222
       +
                    let* () = write_extensions writer metadata.extensions in

     

       223
       223
       +
                    output_element_end writer

     

       224
       224
       +
                  else Ok ()) in

     

       225
       225
       +
         output_element_end writer

     

       226
       226
       +
       

     

       227
       227
       +
       (** Write route *)

     

       228
       228
       +
       let write_route writer (route : route) =

     

       229
       229
       +
         let* () = output_element_start writer "rte" [] in

     

       230
       230
       +
         let* () = output_optional_text_element writer "name" route.name in

     

       231
       231
       +
         let* () = output_optional_text_element writer "cmt" route.cmt in

     

       232
       232
       +
         let* () = output_optional_text_element writer "desc" route.desc in

     

       233
       233
       +
         let* () = output_optional_text_element writer "src" route.src in

     

       234
       234
       +
         let* () = write_links writer route.links in

     

       235
       235
       +
         let* () = output_optional_int_element writer "number" route.number in

     

       236
       236
       +
         let* () = output_optional_text_element writer "type" route.type_ in

     

       237
       237
       +
         let* () = (if route.extensions <> [] then

     

       238
       238
       +
                    let* () = output_element_start writer "extensions" [] in

     

       239
       239
       +
                    let* () = write_extensions writer route.extensions in

     

       240
       240
       +
                    output_element_end writer

     

       241
       241
       +
                  else Ok ()) in

     

       242
       242
       +
         let* () = 

     

       243
       243
       +
           let rec loop = function

     

       244
       244
       +
             | [] -> Ok ()

     

       245
       245
       +
             | rtept :: rest ->

     

       246
       246
       +
               let* () = write_route_point writer rtept in

     

       247
       247
       +
               loop rest

     

       248
       248
       +
           in

     

       249
       249
       +
           loop route.rtepts

     

       250
       250
       +
         in

     

       251
       251
       +
         output_element_end writer

     

       252
       252
       +
       

     

       253
       253
       +
       (** Write track segment *)

     

       254
       254
       +
       let write_track_segment writer trkseg =

     

       255
       255
       +
         let* () = output_element_start writer "trkseg" [] in

     

       256
       256
       +
         let* () = 

     

       257
       257
       +
           let rec loop = function

     

       258
       258
       +
             | [] -> Ok ()

     

       259
       259
       +
             | trkpt :: rest ->

     

       260
       260
       +
               let* () = write_track_point writer trkpt in

     

       261
       261
       +
               loop rest

     

       262
       262
       +
           in

     

       263
       263
       +
           loop trkseg.trkpts

     

       264
       264
       +
         in

     

       265
       265
       +
         let* () = (if trkseg.extensions <> [] then

     

       266
       266
       +
                    let* () = output_element_start writer "extensions" [] in

     

       267
       267
       +
                    let* () = write_extensions writer trkseg.extensions in

     

       268
       268
       +
                    output_element_end writer

     

       269
       269
       +
                  else Ok ()) in

     

       270
       270
       +
         output_element_end writer

     

       271
       271
       +
       

     

       272
       272
       +
       (** Write track *)

     

       273
       273
       +
       let write_track writer track =

     

       274
       274
       +
         let* () = output_element_start writer "trk" [] in

     

       275
       275
       +
         let* () = output_optional_text_element writer "name" track.name in

     

       276
       276
       +
         let* () = output_optional_text_element writer "cmt" track.cmt in

     

       277
       277
       +
         let* () = output_optional_text_element writer "desc" track.desc in

     

       278
       278
       +
         let* () = output_optional_text_element writer "src" track.src in

     

       279
       279
       +
         let* () = write_links writer track.links in

     

       280
       280
       +
         let* () = output_optional_int_element writer "number" track.number in

     

       281
       281
       +
         let* () = output_optional_text_element writer "type" track.type_ in

     

       282
       282
       +
         let* () = (if track.extensions <> [] then

     

       283
       283
       +
                    let* () = output_element_start writer "extensions" [] in

     

       284
       284
       +
                    let* () = write_extensions writer track.extensions in

     

       285
       285
       +
                    output_element_end writer

     

       286
       286
       +
                  else Ok ()) in

     

       287
       287
       +
         let* () = 

     

       288
       288
       +
           let rec loop = function

     

       289
       289
       +
             | [] -> Ok ()

     

       290
       290
       +
             | trkseg :: rest ->

     

       291
       291
       +
               let* () = write_track_segment writer trkseg in

     

       292
       292
       +
               loop rest

     

       293
       293
       +
           in

     

       294
       294
       +
           loop track.trksegs

     

       295
       295
       +
         in

     

       296
       296
       +
         output_element_end writer

     

       297
       297
       +
       

     

       298
       298
       +
       (** Write complete GPX document *)

     

       299
       299
       +
       let write_gpx writer gpx =

     

       300
       300
       +
         let* () = write_header writer in

     

       301
       301
       +
         let attrs = [

     

       302
       302
       +
           (("", "version"), gpx.version);

     

       303
       303
       +
           (("", "creator"), gpx.creator);

     

       304
       304
       +
           (("xmlns", "xsi"), "http://www.w3.org/2001/XMLSchema-instance");

     

       305
       305
       +
           (("", "xmlns"), "http://www.topografix.com/GPX/1/1");

     

       306
       306
       +
           (("xsi", "schemaLocation"), "http://www.topografix.com/GPX/1/1 http://www.topografix.com/GPX/1/1/gpx.xsd");

     

       307
       307
       +
         ] in

     

       308
       308
       +
         let* () = output_element_start writer "gpx" attrs in

     

       309
       309
       +
         let* () = (match gpx.metadata with

     

       310
       310
       +
                    | Some metadata -> write_metadata writer metadata

     

       311
       311
       +
                    | None -> Ok ()) in

     

       312
       312
       +
         let* () = 

     

       313
       313
       +
           let rec loop = function

     

       314
       314
       +
             | [] -> Ok ()

     

       315
       315
       +
             | wpt :: rest ->

     

       316
       316
       +
               let* () = write_waypoint writer wpt in

     

       317
       317
       +
               loop rest

     

       318
       318
       +
           in

     

       319
       319
       +
           loop gpx.waypoints

     

       320
       320
       +
         in

     

       321
       321
       +
         let* () = 

     

       322
       322
       +
           let rec loop = function

     

       323
       323
       +
             | [] -> Ok ()

     

       324
       324
       +
             | rte :: rest ->

     

       325
       325
       +
               let* () = write_route writer rte in

     

       326
       326
       +
               loop rest

     

       327
       327
       +
           in

     

       328
       328
       +
           loop gpx.routes

     

       329
       329
       +
         in

     

       330
       330
       +
         let* () = 

     

       331
       331
       +
           let rec loop = function

     

       332
       332
       +
             | [] -> Ok ()

     

       333
       333
       +
             | trk :: rest ->

     

       334
       334
       +
               let* () = write_track writer trk in

     

       335
       335
       +
               loop rest

     

       336
       336
       +
           in

     

       337
       337
       +
           loop gpx.tracks

     

       338
       338
       +
         in

     

       339
       339
       +
         let* () = (if gpx.extensions <> [] then

     

       340
       340
       +
                    let* () = output_element_start writer "extensions" [] in

     

       341
       341
       +
                    let* () = write_extensions writer gpx.extensions in

     

       342
       342
       +
                    output_element_end writer

     

       343
       343
       +
                  else Ok ()) in

     

       344
       344
       +
         output_element_end writer

     

       345
       345
       +
       

     

       346
       346
       +
       (** Main writing function *)

     

       347
       347
       +
       let write output gpx =

     

       348
       348
       +
         let writer = make_writer output in

     

       349
       349
       +
         write_gpx writer gpx

     

       350
       350
       +
       

     

       351
       351
       +
       (** Write to string *)

     

       352
       352
       +
       let write_string gpx =

     

       353
       353
       +
         let buffer = Buffer.create 1024 in

     

       354
       354
       +
         let output = Xmlm.make_output (`Buffer buffer) in

     

       355
       355
       +
         let result = write output gpx in

     

       356
       356
       +
         match result with

     

       357
       357
       +
         | Ok () -> Ok (Buffer.contents buffer)

     

       358
       358
       +
         | Error e -> Error e

lib/gpx/writer.mli

···

       1
       1
       +
       (** GPX streaming writer using xmlm *)

     

       2
       2
       +
       

     

       3
       3
       +
       open Types

     

       4
       4
       +
       

     

       5
       5
       +
       (** Write a GPX document to an xmlm output destination *)

     

       6
       6
       +
       val write : Xmlm.output -> gpx -> unit result

     

       7
       7
       +
       

     

       8
       8
       +
       (** Write a GPX document to a string *)

     

       9
       9
       +
       val write_string : gpx -> string result

lib/gpx_unix/dune

···

       1
       1
       +
       (library

     

       2
       2
       +
        (public_name mlgpx.unix)

     

       3
       3
       +
        (name gpx_unix)

     

       4
       4
       +
        (libraries unix xmlm ptime gpx)

     

       5
       5
       +
        (modules gpx_io gpx_unix))

+114

lib/gpx_unix/gpx_io.ml

···

       1
       1
       +
       (** GPX Unix I/O operations *)

     

       2
       2
       +
       

     

       3
       3
       +
       open Gpx.Types

     

       4
       4
       +
       

     

       5
       5
       +
       (** Result binding operators *)

     

       6
       6
       +
       let (let*) = Result.bind

     

       7
       7
       +
       

     

       8
       8
       +
       (** Read GPX from file *)

     

       9
       9
       +
       let read_file filename =

     

       10
       10
       +
         try

     

       11
       11
       +
           let ic = open_in filename in

     

       12
       12
       +
           let input = Xmlm.make_input (`Channel ic) in

     

       13
       13
       +
           let result = Gpx.Parser.parse input in

     

       14
       14
       +
           close_in ic;

     

       15
       15
       +
           result

     

       16
       16
       +
         with

     

       17
       17
       +
         | Sys_error msg -> Error (IO_error msg)

     

       18
       18
       +
         | exn -> Error (IO_error (Printexc.to_string exn))

     

       19
       19
       +
       

     

       20
       20
       +
       (** Write GPX to file *)

     

       21
       21
       +
       let write_file filename gpx =

     

       22
       22
       +
         try

     

       23
       23
       +
           let oc = open_out filename in

     

       24
       24
       +
           let output = Xmlm.make_output (`Channel oc) in

     

       25
       25
       +
           let result = Gpx.Writer.write output gpx in

     

       26
       26
       +
           close_out oc;

     

       27
       27
       +
           result

     

       28
       28
       +
         with

     

       29
       29
       +
         | Sys_error msg -> Error (IO_error msg)

     

       30
       30
       +
         | exn -> Error (IO_error (Printexc.to_string exn))

     

       31
       31
       +
       

     

       32
       32
       +
       (** Read GPX from stdin *)

     

       33
       33
       +
       let read_stdin () =

     

       34
       34
       +
         let input = Xmlm.make_input (`Channel stdin) in

     

       35
       35
       +
         Gpx.Parser.parse input

     

       36
       36
       +
       

     

       37
       37
       +
       (** Write GPX to stdout *)

     

       38
       38
       +
       let write_stdout gpx =

     

       39
       39
       +
         let output = Xmlm.make_output (`Channel stdout) in

     

       40
       40
       +
         Gpx.Writer.write output gpx

     

       41
       41
       +
       

     

       42
       42
       +
       (** Read GPX from file with validation *)

     

       43
       43
       +
       let read_file_validated filename =

     

       44
       44
       +
         let* gpx = read_file filename in

     

       45
       45
       +
         let validation = Gpx.Validate.validate_gpx gpx in

     

       46
       46
       +
         if validation.is_valid then

     

       47
       47
       +
           Ok gpx

     

       48
       48
       +
         else

     

       49
       49
       +
           let errors = List.filter (fun issue -> issue.Gpx.Validate.level = `Error) validation.issues in

     

       50
       50
       +
           let error_msgs = List.map Gpx.Validate.format_issue errors in

     

       51
       51
       +
           Error (Validation_error (String.concat "; " error_msgs))

     

       52
       52
       +
       

     

       53
       53
       +
       (** Write GPX to file with validation *)

     

       54
       54
       +
       let write_file_validated filename gpx =

     

       55
       55
       +
         let validation = Gpx.Validate.validate_gpx gpx in

     

       56
       56
       +
         if not validation.is_valid then

     

       57
       57
       +
           let errors = List.filter (fun issue -> issue.Gpx.Validate.level = `Error) validation.issues in

     

       58
       58
       +
           let error_msgs = List.map Gpx.Validate.format_issue errors in

     

       59
       59
       +
           Error (Validation_error (String.concat "; " error_msgs))

     

       60
       60
       +
         else

     

       61
       61
       +
           write_file filename gpx

     

       62
       62
       +
       

     

       63
       63
       +
       (** Check if file exists and is readable *)

     

       64
       64
       +
       let file_exists filename =

     

       65
       65
       +
         try

     

       66
       66
       +
           let _ = Unix.stat filename in

     

       67
       67
       +
           true

     

       68
       68
       +
         with

     

       69
       69
       +
         | Unix.Unix_error _ -> false

     

       70
       70
       +
       

     

       71
       71
       +
       (** Get file size *)

     

       72
       72
       +
       let file_size filename =

     

       73
       73
       +
         try

     

       74
       74
       +
           let stats = Unix.stat filename in

     

       75
       75
       +
           Ok stats.st_size

     

       76
       76
       +
         with

     

       77
       77
       +
         | Unix.Unix_error (errno, _, _) -> 

     

       78
       78
       +
           Error (IO_error (Unix.error_message errno))

     

       79
       79
       +
       

     

       80
       80
       +
       (** Create backup of file before overwriting *)

     

       81
       81
       +
       let create_backup filename =

     

       82
       82
       +
         if file_exists filename then

     

       83
       83
       +
           let backup_name = filename ^ ".bak" in

     

       84
       84
       +
           try

     

       85
       85
       +
             let ic = open_in filename in

     

       86
       86
       +
             let oc = open_out backup_name in

     

       87
       87
       +
             let rec copy () =

     

       88
       88
       +
               match input_char ic with

     

       89
       89
       +
               | c -> output_char oc c; copy ()

     

       90
       90
       +
               | exception End_of_file -> ()

     

       91
       91
       +
             in

     

       92
       92
       +
             copy ();

     

       93
       93
       +
             close_in ic;

     

       94
       94
       +
             close_out oc;

     

       95
       95
       +
             Ok backup_name

     

       96
       96
       +
           with

     

       97
       97
       +
           | Sys_error msg -> Error (IO_error msg)

     

       98
       98
       +
           | exn -> Error (IO_error (Printexc.to_string exn))

     

       99
       99
       +
         else

     

       100
       100
       +
           Ok ""

     

       101
       101
       +
       

     

       102
       102
       +
       (** Write GPX to file with backup *)

     

       103
       103
       +
       let write_file_with_backup filename gpx =

     

       104
       104
       +
         let* backup_name = create_backup filename in

     

       105
       105
       +
         match write_file filename gpx with

     

       106
       106
       +
         | Ok () -> Ok backup_name

     

       107
       107
       +
         | Error _ as err ->

     

       108
       108
       +
           (* Try to restore backup if write failed *)

     

       109
       109
       +
           if backup_name <> "" && file_exists backup_name then (

     

       110
       110
       +
             try

     

       111
       111
       +
               Sys.rename backup_name filename

     

       112
       112
       +
             with _ -> ()

     

       113
       113
       +
           );

     

       114
       114
       +
           err

+33

lib/gpx_unix/gpx_io.mli

···

       1
       1
       +
       (** GPX Unix I/O operations *)

     

       2
       2
       +
       

     

       3
       3
       +
       open Gpx.Types

     

       4
       4
       +
       

     

       5
       5
       +
       (** Read GPX from file *)

     

       6
       6
       +
       val read_file : string -> gpx result

     

       7
       7
       +
       

     

       8
       8
       +
       (** Write GPX to file *)

     

       9
       9
       +
       val write_file : string -> gpx -> unit result

     

       10
       10
       +
       

     

       11
       11
       +
       (** Read GPX from stdin *)

     

       12
       12
       +
       val read_stdin : unit -> gpx result

     

       13
       13
       +
       

     

       14
       14
       +
       (** Write GPX to stdout *)

     

       15
       15
       +
       val write_stdout : gpx -> unit result

     

       16
       16
       +
       

     

       17
       17
       +
       (** Read GPX from file with validation *)

     

       18
       18
       +
       val read_file_validated : string -> gpx result

     

       19
       19
       +
       

     

       20
       20
       +
       (** Write GPX to file with validation *)

     

       21
       21
       +
       val write_file_validated : string -> gpx -> unit result

     

       22
       22
       +
       

     

       23
       23
       +
       (** Check if file exists and is readable *)

     

       24
       24
       +
       val file_exists : string -> bool

     

       25
       25
       +
       

     

       26
       26
       +
       (** Get file size *)

     

       27
       27
       +
       val file_size : string -> int result

     

       28
       28
       +
       

     

       29
       29
       +
       (** Create backup of file before overwriting *)

     

       30
       30
       +
       val create_backup : string -> string result

     

       31
       31
       +
       

     

       32
       32
       +
       (** Write GPX to file with backup *)

     

       33
       33
       +
       val write_file_with_backup : string -> gpx -> string result

+179

lib/gpx_unix/gpx_unix.ml

···

       1
       1
       +
       (** High-level Unix API for GPX operations *)

     

       2
       2
       +
       

     

       3
       3
       +
       (** Result binding operators *)

     

       4
       4
       +
       let (let*) = Result.bind

     

       5
       5
       +
       

     

       6
       6
       +
       (* Re-export core modules *)

     

       7
       7
       +
       module Types = Gpx.Types

     

       8
       8
       +
       module Parser = Gpx.Parser  

     

       9
       9
       +
       module Writer = Gpx.Writer

     

       10
       10
       +
       module Validate = Gpx.Validate

     

       11
       11
       +
       module IO = Gpx_io

     

       12
       12
       +
       

     

       13
       13
       +
       (* Re-export common types *)

     

       14
       14
       +
       open Gpx.Types

     

       15
       15
       +
       

     

       16
       16
       +
       (** Convenience functions for common operations *)

     

       17
       17
       +
       

     

       18
       18
       +
       (** Read and parse GPX file *)

     

       19
       19
       +
       let read = IO.read_file

     

       20
       20
       +
       

     

       21
       21
       +
       (** Read and parse GPX file with validation *)

     

       22
       22
       +
       let read_validated = IO.read_file_validated

     

       23
       23
       +
       

     

       24
       24
       +
       (** Write GPX to file *)

     

       25
       25
       +
       let write = IO.write_file

     

       26
       26
       +
       

     

       27
       27
       +
       (** Write GPX to file with validation *)

     

       28
       28
       +
       let write_validated = IO.write_file_validated

     

       29
       29
       +
       

     

       30
       30
       +
       (** Write GPX to file with backup *)

     

       31
       31
       +
       let write_with_backup = IO.write_file_with_backup

     

       32
       32
       +
       

     

       33
       33
       +
       (** Convert GPX to string *)

     

       34
       34
       +
       let to_string = Writer.write_string

     

       35
       35
       +
       

     

       36
       36
       +
       (** Parse GPX from string *)

     

       37
       37
       +
       let from_string = Parser.parse_string

     

       38
       38
       +
       

     

       39
       39
       +
       (** Quick validation check *)

     

       40
       40
       +
       let is_valid = Validate.is_valid

     

       41
       41
       +
       

     

       42
       42
       +
       (** Get validation issues *)

     

       43
       43
       +
       let validate = Validate.validate_gpx

     

       44
       44
       +
       

     

       45
       45
       +
       (** Create simple waypoint *)

     

       46
       46
       +
       let make_waypoint ~lat ~lon ?name ?desc () =

     

       47
       47
       +
         match (latitude lat, longitude lon) with

     

       48
       48
       +
         | (Ok lat, Ok lon) ->

     

       49
       49
       +
           let wpt = make_waypoint_data lat lon in

     

       50
       50
       +
           Ok { wpt with name; desc }

     

       51
       51
       +
         | (Error e, _) | (_, Error e) -> Error (Invalid_coordinate e)

     

       52
       52
       +
       

     

       53
       53
       +
       (** Create simple track from coordinate list *)

     

       54
       54
       +
       let make_track_from_coords ~name coords =

     

       55
       55
       +
         let make_trkpt (lat, lon) =

     

       56
       56
       +
           match (latitude lat, longitude lon) with

     

       57
       57
       +
           | (Ok lat, Ok lon) -> Ok (make_waypoint_data lat lon)

     

       58
       58
       +
           | (Error e, _) | (_, Error e) -> Error (Invalid_coordinate e)

     

       59
       59
       +
         in

     

       60
       60
       +
         let rec convert_coords acc = function

     

       61
       61
       +
           | [] -> Ok (List.rev acc)

     

       62
       62
       +
           | coord :: rest ->

     

       63
       63
       +
             match make_trkpt coord with

     

       64
       64
       +
             | Ok trkpt -> convert_coords (trkpt :: acc) rest

     

       65
       65
       +
             | Error e -> Error e

     

       66
       66
       +
         in

     

       67
       67
       +
         let* trkpts = convert_coords [] coords in

     

       68
       68
       +
         let trkseg = { trkpts; extensions = [] } in

     

       69
       69
       +
         Ok {

     

       70
       70
       +
           name = Some name;

     

       71
       71
       +
           cmt = None; desc = None; src = None; links = [];

     

       72
       72
       +
           number = None; type_ = None; extensions = [];

     

       73
       73
       +
           trksegs = [trkseg];

     

       74
       74
       +
         }

     

       75
       75
       +
       

     

       76
       76
       +
       (** Create simple route from coordinate list *)

     

       77
       77
       +
       let make_route_from_coords ~name coords =

     

       78
       78
       +
         let make_rtept (lat, lon) =

     

       79
       79
       +
           match (latitude lat, longitude lon) with

     

       80
       80
       +
           | (Ok lat, Ok lon) -> Ok (make_waypoint_data lat lon)

     

       81
       81
       +
           | (Error e, _) | (_, Error e) -> Error (Invalid_coordinate e)

     

       82
       82
       +
         in

     

       83
       83
       +
         let rec convert_coords acc = function

     

       84
       84
       +
           | [] -> Ok (List.rev acc)

     

       85
       85
       +
           | coord :: rest ->

     

       86
       86
       +
             match make_rtept coord with

     

       87
       87
       +
             | Ok rtept -> convert_coords (rtept :: acc) rest

     

       88
       88
       +
             | Error e -> Error e

     

       89
       89
       +
         in

     

       90
       90
       +
         let* rtepts = convert_coords [] coords in

     

       91
       91
       +
         Ok {

     

       92
       92
       +
           name = Some name;

     

       93
       93
       +
           cmt = None; desc = None; src = None; links = [];

     

       94
       94
       +
           number = None; type_ = None; extensions = [];

     

       95
       95
       +
           rtepts;

     

       96
       96
       +
         }

     

       97
       97
       +
       

     

       98
       98
       +
       (** Extract coordinates from waypoints *)

     

       99
       99
       +
       let waypoint_coords wpt =

     

       100
       100
       +
         (latitude_to_float wpt.lat, longitude_to_float wpt.lon)

     

       101
       101
       +
       

     

       102
       102
       +
       (** Extract coordinates from track *)

     

       103
       103
       +
       let track_coords track =

     

       104
       104
       +
         List.fold_left (fun acc trkseg ->

     

       105
       105
       +
           List.fold_left (fun acc trkpt ->

     

       106
       106
       +
             waypoint_coords trkpt :: acc

     

       107
       107
       +
           ) acc trkseg.trkpts

     

       108
       108
       +
         ) [] track.trksegs

     

       109
       109
       +
         |> List.rev

     

       110
       110
       +
       

     

       111
       111
       +
       (** Extract coordinates from route *)

     

       112
       112
       +
       let route_coords route =

     

       113
       113
       +
         List.map waypoint_coords route.rtepts

     

       114
       114
       +
       

     

       115
       115
       +
       (** Count total points in GPX *)

     

       116
       116
       +
       let count_points gpx =

     

       117
       117
       +
         let waypoint_count = List.length gpx.waypoints in

     

       118
       118
       +
         let route_count = List.fold_left (fun acc route ->

     

       119
       119
       +
           acc + List.length route.rtepts

     

       120
       120
       +
         ) 0 gpx.routes in

     

       121
       121
       +
         let track_count = List.fold_left (fun acc track ->

     

       122
       122
       +
           List.fold_left (fun acc trkseg ->

     

       123
       123
       +
             acc + List.length trkseg.trkpts

     

       124
       124
       +
           ) acc track.trksegs

     

       125
       125
       +
         ) 0 gpx.tracks in

     

       126
       126
       +
         waypoint_count + route_count + track_count

     

       127
       127
       +
       

     

       128
       128
       +
       (** Get GPX statistics *)

     

       129
       129
       +
       type gpx_stats = {

     

       130
       130
       +
         waypoint_count : int;

     

       131
       131
       +
         route_count : int;

     

       132
       132
       +
         track_count : int;

     

       133
       133
       +
         total_points : int;

     

       134
       134
       +
         has_elevation : bool;

     

       135
       135
       +
         has_time : bool;

     

       136
       136
       +
       }

     

       137
       137
       +
       

     

       138
       138
       +
       let get_stats gpx =

     

       139
       139
       +
         let waypoint_count = List.length gpx.waypoints in

     

       140
       140
       +
         let route_count = List.length gpx.routes in

     

       141
       141
       +
         let track_count = List.length gpx.tracks in

     

       142
       142
       +
         let total_points = count_points gpx in

     

       143
       143
       +
         

     

       144
       144
       +
         let has_elevation = 

     

       145
       145
       +
           List.exists (fun wpt -> wpt.ele <> None) gpx.waypoints ||

     

       146
       146
       +
           List.exists (fun route -> 

     

       147
       147
       +
             List.exists (fun rtept -> rtept.ele <> None) route.rtepts

     

       148
       148
       +
           ) gpx.routes ||

     

       149
       149
       +
           List.exists (fun track ->

     

       150
       150
       +
             List.exists (fun trkseg ->

     

       151
       151
       +
               List.exists (fun trkpt -> trkpt.ele <> None) trkseg.trkpts

     

       152
       152
       +
             ) track.trksegs

     

       153
       153
       +
           ) gpx.tracks

     

       154
       154
       +
         in

     

       155
       155
       +
         

     

       156
       156
       +
         let has_time =

     

       157
       157
       +
           List.exists (fun wpt -> wpt.time <> None) gpx.waypoints ||

     

       158
       158
       +
           List.exists (fun route ->

     

       159
       159
       +
             List.exists (fun rtept -> rtept.time <> None) route.rtepts

     

       160
       160
       +
           ) gpx.routes ||

     

       161
       161
       +
           List.exists (fun track ->

     

       162
       162
       +
             List.exists (fun trkseg ->

     

       163
       163
       +
               List.exists (fun trkpt -> trkpt.time <> None) trkseg.trkpts

     

       164
       164
       +
             ) track.trksegs

     

       165
       165
       +
           ) gpx.tracks

     

       166
       166
       +
         in

     

       167
       167
       +
         

     

       168
       168
       +
         { waypoint_count; route_count; track_count; total_points; has_elevation; has_time }

     

       169
       169
       +
       

     

       170
       170
       +
       (** Pretty print GPX statistics *)

     

       171
       171
       +
       let print_stats gpx =

     

       172
       172
       +
         let stats = get_stats gpx in

     

       173
       173
       +
         Printf.printf "GPX Statistics:\n";

     

       174
       174
       +
         Printf.printf "  Waypoints: %d\n" stats.waypoint_count;

     

       175
       175
       +
         Printf.printf "  Routes: %d\n" stats.route_count;

     

       176
       176
       +
         Printf.printf "  Tracks: %d\n" stats.track_count;

     

       177
       177
       +
         Printf.printf "  Total points: %d\n" stats.total_points;

     

       178
       178
       +
         Printf.printf "  Has elevation data: %s\n" (if stats.has_elevation then "yes" else "no");

     

       179
       179
       +
         Printf.printf "  Has time data: %s\n" (if stats.has_time then "yes" else "no")

+77

lib/gpx_unix/gpx_unix.mli

···

       1
       1
       +
       (** High-level Unix API for GPX operations *)

     

       2
       2
       +
       

     

       3
       3
       +
       (* Re-export core modules *)

     

       4
       4
       +
       module Types = Gpx.Types

     

       5
       5
       +
       module Parser = Gpx.Parser

     

       6
       6
       +
       module Writer = Gpx.Writer

     

       7
       7
       +
       module Validate = Gpx.Validate

     

       8
       8
       +
       module IO = Gpx_io

     

       9
       9
       +
       

     

       10
       10
       +
       (* Re-export common types *)

     

       11
       11
       +
       open Gpx.Types

     

       12
       12
       +
       

     

       13
       13
       +
       (** Convenience functions for common operations *)

     

       14
       14
       +
       

     

       15
       15
       +
       (** Read and parse GPX file *)

     

       16
       16
       +
       val read : string -> gpx result

     

       17
       17
       +
       

     

       18
       18
       +
       (** Read and parse GPX file with validation *)

     

       19
       19
       +
       val read_validated : string -> gpx result

     

       20
       20
       +
       

     

       21
       21
       +
       (** Write GPX to file *)

     

       22
       22
       +
       val write : string -> gpx -> unit result

     

       23
       23
       +
       

     

       24
       24
       +
       (** Write GPX to file with validation *)

     

       25
       25
       +
       val write_validated : string -> gpx -> unit result

     

       26
       26
       +
       

     

       27
       27
       +
       (** Write GPX to file with backup *)

     

       28
       28
       +
       val write_with_backup : string -> gpx -> string result

     

       29
       29
       +
       

     

       30
       30
       +
       (** Convert GPX to string *)

     

       31
       31
       +
       val to_string : gpx -> string result

     

       32
       32
       +
       

     

       33
       33
       +
       (** Parse GPX from string *)

     

       34
       34
       +
       val from_string : string -> gpx result

     

       35
       35
       +
       

     

       36
       36
       +
       (** Quick validation check *)

     

       37
       37
       +
       val is_valid : gpx -> bool

     

       38
       38
       +
       

     

       39
       39
       +
       (** Get validation issues *)

     

       40
       40
       +
       val validate : gpx -> Gpx.Validate.validation_result

     

       41
       41
       +
       

     

       42
       42
       +
       (** Create simple waypoint *)

     

       43
       43
       +
       val make_waypoint : lat:float -> lon:float -> ?name:string -> ?desc:string -> unit -> waypoint result

     

       44
       44
       +
       

     

       45
       45
       +
       (** Create simple track from coordinate list *)

     

       46
       46
       +
       val make_track_from_coords : name:string -> (float * float) list -> track result

     

       47
       47
       +
       

     

       48
       48
       +
       (** Create simple route from coordinate list *)

     

       49
       49
       +
       val make_route_from_coords : name:string -> (float * float) list -> route result

     

       50
       50
       +
       

     

       51
       51
       +
       (** Extract coordinates from waypoints *)

     

       52
       52
       +
       val waypoint_coords : waypoint_data -> float * float

     

       53
       53
       +
       

     

       54
       54
       +
       (** Extract coordinates from track *)

     

       55
       55
       +
       val track_coords : track -> (float * float) list

     

       56
       56
       +
       

     

       57
       57
       +
       (** Extract coordinates from route *)

     

       58
       58
       +
       val route_coords : route -> (float * float) list

     

       59
       59
       +
       

     

       60
       60
       +
       (** Count total points in GPX *)

     

       61
       61
       +
       val count_points : gpx -> int

     

       62
       62
       +
       

     

       63
       63
       +
       (** GPX statistics *)

     

       64
       64
       +
       type gpx_stats = {

     

       65
       65
       +
         waypoint_count : int;

     

       66
       66
       +
         route_count : int;

     

       67
       67
       +
         track_count : int;

     

       68
       68
       +
         total_points : int;

     

       69
       69
       +
         has_elevation : bool;

     

       70
       70
       +
         has_time : bool;

     

       71
       71
       +
       }

     

       72
       72
       +
       

     

       73
       73
       +
       (** Get GPX statistics *)

     

       74
       74
       +
       val get_stats : gpx -> gpx_stats

     

       75
       75
       +
       

     

       76
       76
       +
       (** Pretty print GPX statistics *)

     

       77
       77
       +
       val print_stats : gpx -> unit

test/dune

···

       1
       1
       +
       (executable

     

       2
       2
       +
        (public_name test_gpx)

     

       3
       3
       +
        (name test_gpx)

     

       4
       4
       +
        (libraries gpx gpx_unix))

+98

test/test_gpx.ml

···

       1
       1
       +
       (** Basic tests for GPX library *)

     

       2
       2
       +
       

     

       3
       3
       +
       open Gpx

     

       4
       4
       +
       

     

       5
       5
       +
       let test_coordinate_validation () =

     

       6
       6
       +
         (* Test valid coordinates *)

     

       7
       7
       +
         assert (Result.is_ok (Types.latitude 45.0));

     

       8
       8
       +
         assert (Result.is_ok (Types.longitude (-122.0)));

     

       9
       9
       +
         assert (Result.is_ok (Types.degrees 180.0));

     

       10
       10
       +
         

     

       11
       11
       +
         (* Test invalid coordinates *)

     

       12
       12
       +
         assert (Result.is_error (Types.latitude 91.0));

     

       13
       13
       +
         assert (Result.is_error (Types.longitude 180.0));

     

       14
       14
       +
         assert (Result.is_error (Types.degrees 360.0));

     

       15
       15
       +
         

     

       16
       16
       +
         Printf.printf "✓ Coordinate validation tests passed\n"

     

       17
       17
       +
       

     

       18
       18
       +
       let test_fix_type_conversion () =

     

       19
       19
       +
         (* Test fix type string conversion *)

     

       20
       20
       +
         assert (Types.fix_type_to_string Types.Fix_2d = "2d");

     

       21
       21
       +
         assert (Types.fix_type_of_string "3d" = Some Types.Fix_3d);

     

       22
       22
       +
         assert (Types.fix_type_of_string "invalid" = None);

     

       23
       23
       +
         

     

       24
       24
       +
         Printf.printf "✓ Fix type conversion tests passed\n"

     

       25
       25
       +
       

     

       26
       26
       +
       let test_gpx_creation () =

     

       27
       27
       +
         let creator = "test" in

     

       28
       28
       +
         let gpx = Types.make_gpx ~creator in

     

       29
       29
       +
         assert (gpx.creator = creator);

     

       30
       30
       +
         assert (gpx.version = "1.1");

     

       31
       31
       +
         assert (gpx.waypoints = []);

     

       32
       32
       +
         

     

       33
       33
       +
         Printf.printf "✓ GPX creation tests passed\n"

     

       34
       34
       +
       

     

       35
       35
       +
       let test_simple_parsing () =

     

       36
       36
       +
         let gpx_xml = {|<?xml version="1.0" encoding="UTF-8"?>

     

       37
       37
       +
       <gpx version="1.1" creator="test" xmlns="http://www.topografix.com/GPX/1/1">

     

       38
       38
       +
         <wpt lat="37.7749" lon="-122.4194">

     

       39
       39
       +
           <name>San Francisco</name>

     

       40
       40
       +
           <desc>The Golden Gate Bridge area</desc>

     

       41
       41
       +
         </wpt>

     

       42
       42
       +
       </gpx>|} in

     

       43
       43
       +
         

     

       44
       44
       +
         match Gpx_parser.parse_string gpx_xml with

     

       45
       45
       +
         | Ok gpx ->

     

       46
       46
       +
           assert (gpx.creator = "test");

     

       47
       47
       +
           assert (List.length gpx.waypoints = 1);

     

       48
       48
       +
           let wpt = List.hd gpx.waypoints in

     

       49
       49
       +
           assert (wpt.name = Some "San Francisco");

     

       50
       50
       +
           Printf.printf "✓ Simple parsing tests passed\n"

     

       51
       51
       +
         | Error e ->

     

       52
       52
       +
           Printf.printf "✗ Parsing failed: %s\n" 

     

       53
       53
       +
             (match e with 

     

       54
       54
       +
              | Invalid_xml s | Invalid_coordinate s | Validation_error s -> s

     

       55
       55
       +
              | _ -> "unknown error");

     

       56
       56
       +
           assert false

     

       57
       57
       +
       

     

       58
       58
       +
       let test_simple_writing () =

     

       59
       59
       +
         let lat = Result.get_ok (Types.latitude 37.7749) in

     

       60
       60
       +
         let lon = Result.get_ok (Types.longitude (-122.4194)) in

     

       61
       61
       +
         let wpt = { (Types.make_waypoint_data lat lon) with

     

       62
       62
       +
                     name = Some "Test Point";

     

       63
       63
       +
                     desc = Some "A test waypoint" } in

     

       64
       64
       +
         let gpx = { (Types.make_gpx ~creator:"test") with

     

       65
       65
       +
                     waypoints = [wpt] } in

     

       66
       66
       +
         

     

       67
       67
       +
         match Writer.write_string gpx with

     

       68
       68
       +
         | Ok xml_string ->

     

       69
       69
       +
           assert (try ignore (String.index xml_string 'T'); true with Not_found -> false);

     

       70
       70
       +
           assert (try ignore (String.index xml_string '3'); true with Not_found -> false);

     

       71
       71
       +
           Printf.printf "✓ Simple writing tests passed\n"

     

       72
       72
       +
         | Error e ->

     

       73
       73
       +
           Printf.printf "✗ Writing failed: %s\n"

     

       74
       74
       +
             (match e with 

     

       75
       75
       +
              | Invalid_xml s | Xml_error s -> s

     

       76
       76
       +
              | _ -> "unknown error");

     

       77
       77
       +
           assert false

     

       78
       78
       +
       

     

       79
       79
       +
       let test_validation () =

     

       80
       80
       +
         let gpx = Types.make_gpx ~creator:"" in

     

       81
       81
       +
         let validation = Validate.validate_gpx gpx in

     

       82
       82
       +
         assert (not validation.is_valid);

     

       83
       83
       +
         let errors = List.filter (fun issue -> issue.Validate.level = `Error) validation.issues in

     

       84
       84
       +
         assert (List.length errors > 0);

     

       85
       85
       +
         

     

       86
       86
       +
         Printf.printf "✓ Validation tests passed\n"

     

       87
       87
       +
       

     

       88
       88
       +
       let run_tests () =

     

       89
       89
       +
         Printf.printf "Running GPX library tests...\n";

     

       90
       90
       +
         test_coordinate_validation ();

     

       91
       91
       +
         test_fix_type_conversion ();

     

       92
       92
       +
         test_gpx_creation ();

     

       93
       93
       +
         test_simple_parsing ();

     

       94
       94
       +
         test_simple_writing ();

     

       95
       95
       +
         test_validation ();

     

       96
       96
       +
         Printf.printf "All tests passed! ✓\n"

     

       97
       97
       +
       

     

       98
       98
       +
       let () = run_tests ()