add duration parsing

src/ISO8601.ml

@@ -55,7 +55,7 @@ module Permissive = struct
         | Some tz -> gmtime (x +. tz)
       in
       let print_tz_hours fmt tz =
-        fprintf fmt "%0+3d" (Pervasives.truncate (tz /. 3600.))
+        fprintf fmt "%0+3d" (Stdlib.truncate (tz /. 3600.))
       in
       let print_tz_minutes fmt tz =
         fprintf fmt "%02.0f" (mod_float (abs_float (tz /. 60.)) 60.0)
@@ -164,3 +164,5 @@ module Permissive = struct
     let string_of_datetimezone_basic = string_of_aux pp_datetimezone_basic
 
 end
+
+module Duration = Duration

src/ISO8601.mli

@@ -164,3 +164,42 @@ module Permissive : sig
     val string_of_datetimezone_basic : (float * float) -> string
 
 end
+
+module Duration : sig
+
+    type date = Duration_type.date = {
+      year : float;
+      month : float;
+      day : float;
+      hour : float;
+      minute : float;
+      second : float;
+    }
+    (** type for date used to represent duration *)
+
+    type t =
+      | Week of float
+      | Date of date
+          (** type for duration.
+        A duration can be either a number of weeks or a [date] *)
+
+    val date_zero : date
+    (** correspond to date zero (= P0Y0M0DT0H0M0S) *)
+
+    val is_zero : t -> bool
+    (** [is_zero d] is [true] iif [d] correspond to zero *)
+
+    val parse_lex : Lexing.lexbuf -> t
+    (** [parse_lex lexbuf] convert [lexbuf] to [t]. raise exception *)
+
+    val parse : string -> t
+    (** [parse s] convert [s] to [t]. raise exception Failure and Parsing.Parse_error *)
+
+    val pp : Format.formatter -> t -> unit
+    (** [pp fmt d] print [d] to formatter [fmt] in valid duration format:
+        PnYnMnDTnHnMnS or PnW *)
+
+    val to_string : t -> string
+    (** [to_string d] is [d] as a string in valid duration format *)
+
+end

src/dune

@@ -3,6 +3,7 @@
  (public_name ISO8601)
  (flags :standard -warn-error -50)
  (wrapped true)
- (libraries unix))
+ (libraries unix stdlib-shims))
 
-(ocamllex ISO8601_lexer)
+(ocamllex ISO8601_lexer duration_lexer)
+(ocamlyacc duration_parser)

src/duration.ml

@@ -0,0 +1,50 @@
+type date = Duration_type.date = {
+  year : float;
+  month : float;
+  day : float;
+  hour : float;
+  minute : float;
+  second : float;
+}
+
+type t = Duration_type.t = Week of float | Date of date
+
+let date_zero = Duration_type.zero
+let is_zero = function Date d -> d = date_zero | Week i -> i = 0.
+
+let pp fmt d =
+  let aux fmt (f, c) =
+    (* don't print if 0 *)
+    if f = 0. then ()
+    else if Float.is_integer f then Format.fprintf fmt "%d%c" (int_of_float f) c
+    else
+      (* TODO rm trailing zeros (%g can use scientific notation on big number) *)
+      Format.fprintf fmt "%f%c" f c
+  in
+  match d with
+  | Week f -> Format.fprintf fmt "P%a" aux (f, 'W')
+  | Date d ->
+      if d.hour <> 0. || d.minute <> 0. || d.second <> 0. then
+        Format.fprintf fmt "P%a%a%aT%a%a%a" aux (d.year, 'Y') aux (d.month, 'M')
+          aux (d.day, 'D') aux (d.hour, 'H') aux (d.minute, 'M') aux (d.second, 'S')
+      else if d.year <> 0. || d.month <> 0. || d.day <> 0. then
+        Format.fprintf fmt "P%a%a%a" aux (d.year, 'Y') aux (d.month, 'M') aux
+          (d.day, 'D')
+      else
+        (* at least one number and its designator shall be present *)
+        Format.fprintf fmt "P0W"
+
+let parse_lex lexbuf = Duration_parser.main Duration_lexer.token lexbuf
+
+let parse s =
+  let lexbuf = Lexing.from_string s in
+  parse_lex lexbuf
+
+let to_string x =
+  (* TODO why?
+     use a local buffer, [str_formatter] is not recommended *)
+  let buf = Buffer.create 64 in
+  let fmt = Format.formatter_of_buffer buf in
+  pp fmt x;
+  Format.pp_print_flush fmt ();
+  Buffer.contents buf

src/duration_lexer.mll

@@ -0,0 +1,23 @@
+{
+  open Duration_parser
+
+  let frac = function
+    | "" -> 0.
+    | f -> float_of_string ("." ^ (String.sub f 1 (String.length f - 1)))
+}
+let digit = ['0'-'9']
+let frac = [',''.']digit+
+let n = digit+
+
+rule token = parse
+| (n as x) (frac? as f) {X (float_of_string x +. (frac f))}
+| 'S' {S}
+| 'M' {M}
+| 'H' {H}
+| 'T' {T}
+| 'D' {D}
+| 'W' {W}
+| 'M' {M}
+| 'Y' {Y}
+| 'P' {P}
+| eof {EOF}

src/duration_parser.mly

@@ -0,0 +1,95 @@
+%{
+  open Duration_type
+%}
+%token <float> X
+%token S
+%token M
+%token H
+%token T
+%token D
+%token W
+%token M
+%token Y
+%token P
+%token EOF
+%start main
+%type <Duration_type.t> main
+
+%%
+second :
+  X S
+  { {zero with second = $1} }
+  | EOF
+  { zero }
+;
+minute:
+  X M second
+  {
+    let minute = $1 in
+    let o = $3 in
+    {o with minute}}
+  | second
+  { $1 }
+;
+hour:
+  X H minute
+  {
+    let hour = $1 in
+    let o = $3 in
+    {o with hour}}
+  | minute
+  { $1 }
+;
+time:
+  T hour
+  {$2}
+ | EOF
+ { zero }
+;
+day:
+  X D time
+  {
+    let day = $1 in
+    let o = $3 in
+    {o with day}}
+  | time
+  { $1 }
+;
+month :
+  X M day
+  {
+    let o = $3 in
+    {o with month = $1}
+  }
+  | day
+  { $1 }
+;
+year:
+  X Y month
+  {
+    let o = $3 in
+    {o with year = $1}
+  }
+  | month
+  { $1 }
+;
+date:
+ | year
+  { $1 }
+;
+week :
+  X W
+  { $1 }
+;
+duration:
+   date
+  { Date $1 }
+ | week
+  { Week $1 }
+;
+main:
+  P duration EOF
+  { $2 }
+;
+
+%%

src/duration_type.ml

@@ -0,0 +1,12 @@
+type date = {
+  year : float;
+  month : float;
+  day : float;
+  hour : float;
+  minute : float;
+  second : float;
+}
+
+type t = Week of float | Date of date
+
+let zero = { year = 0.; month = 0.; day = 0.; hour = 0.; minute = 0.; second = 0. }

tests/ISO8601_PARSER.ml

@@ -4,7 +4,7 @@ let test ~p fn input expected =
   let result = fn input in
   let assert_equal =
     OUnit.assert_equal
-      ~cmp:(OUnit.cmp_float ~epsilon:Pervasives.epsilon_float)
+      ~cmp:(OUnit.cmp_float ~epsilon:Stdlib.epsilon_float)
       ~printer:(fun x -> Printf.sprintf "%.6f (as %s)" x (p x))
   in
   OUnit.(>::) input (fun () -> with_utc (fun () -> assert_equal expected result))

tests/UTILS_TEST.ml

@@ -3,7 +3,7 @@ let test a b =
     (string_of_float a)
     (fun _ ->
      OUnit.assert_equal
-     ~cmp:(OUnit.cmp_float ~epsilon:Pervasives.epsilon_float)
+     ~cmp:(OUnit.cmp_float ~epsilon:Stdlib.epsilon_float)
      ~printer:(fun f ->
          Printf.sprintf "%.5f (as %s)" f (ISO8601.Permissive.string_of_datetime_utc f))
      a b)

tests/dune

@@ -2,7 +2,7 @@
  (name ISO8601_TEST)
  (modules :standard \ Test)
  (flags :standard -warn-error -a)
- (libraries unix oUnit ISO8601))
+ (libraries unix oUnit ISO8601 stdlib-shims))
 
 (alias
  (name runtest)
@@ -14,7 +14,7 @@
  (name test)
  (modules test)
  (flags :standard -warn-error -a)
- (libraries unix alcotest ISO8601))
+ (libraries unix alcotest ISO8601 duration stdlib-shims))
 
 (alias
  (name runtest)

tests/test.ml

@@ -178,12 +178,65 @@ let rt_fixed_unix_time unix_time tz s () =
 let rt_tests =
   time_tests rt_test @ fixed_time_tests rt_fixed_unix_time
 
+module Tm_struct_duration : Alcotest.TESTABLE with type t = ISO8601.Duration.t = struct
+  open ISO8601.Duration
+  type nonrec t = t
+
+  let pp = pp
+
+  (* do not bother to implement "correct" comparaison of duration
+     also use equality on float *)
+  let equal a b = is_zero a && is_zero b || a = b
+end
+let tm_struct_duration = (module Tm_struct_duration : Alcotest.TESTABLE with type t = ISO8601.Duration.t)
+
+let parse_invalid_duration_test s () =
+  let open ISO8601.Duration in
+  Alcotest.(check bool) ("parse_invalid_duration " ^ s) false (
+    try let _ : t = parse s in true with Parsing.Parse_error | Failure _ -> false);
+  ()
+
+let parse_invalid_duration_tests =
+  let l = ["P1H01M01S"; "P46"; "PT46"; "PT01H46"; "PH1M0S1S"; "1H2M3D"; "AA" ] in
+  List.map (fun s -> s,`Quick, parse_invalid_duration_test s) l
+
+let parse_duration_test (s,d) () =
+  let open ISO8601.Duration in
+  let d2 = parse s in
+  Alcotest.check tm_struct_duration ("parse_duration " ^ s) d d2;
+  let d3 = parse (to_string d2) in
+  Alcotest.check tm_struct_duration ("parse_duration " ^ s) d d3;
+  ()
+
+let parse_duration_tests =
+  let open ISO8601.Duration in
+  let l = [
+       ("PT1H33M", Date {date_zero with hour =1.; minute = 33.})
+      ;("PT1H33S", Date {date_zero with hour=1.; second=33.})
+      ;("PT33M",Date {date_zero with minute=33.})
+      ;("P123456789Y33M450DT33H66M99S",Date {year=123456789.;month=33.;day=450.;hour=33.;minute=66.;second=99.})
+      ;("P0Y0M1DT0H0M0S",Date {date_zero with day=1.})
+      ;("P12W",Week 12.)
+      ;("P90001W",Week 90001.)
+      ;("P0Y",Date date_zero)
+      ;("P0Y0M0DT0H0M0S",Date date_zero)
+      ;("PT0H0M0S",Date date_zero)
+      ;("PT0S",Date date_zero)
+      ;("P0W",Week 0.)
+      ;("P0.3W",Week 0.3)
+      ;("P12.34Y33.66M450.054DT33.66H66.99M99.66S",Date {year=12.34;month=33.66;day=450.054;hour=33.66;minute=66.99;second=99.66})
+      ;("P12,34Y33,66M450,054DT33,66H66,99M99,66S",Date {year=12.34;month=33.66;day=450.054;hour=33.66;minute=66.99;second=99.66})
+  ]
+  in
+  List.map (fun o -> fst o,`Quick, parse_duration_test o) l
+
 let suites = [
   "parse", parse_tests;
   "print", print_tests;
   "rt",    rt_tests;
+  "invalid_duration", parse_invalid_duration_tests;
+  "parse_duration", parse_duration_tests;
 ]
 
-
 let () =
   Alcotest.run "ISO8601" suites