Source file `form.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
(* Copyright 2024 Yawar Amin

   This file is part of dream-html.

   dream-html is free software: you can redistribute it and/or modify it
   under the terms of the GNU General Public License as published by the Free
   Software Foundation, either version 3 of the License, or (at your option) any
   later version.

   dream-html is distributed in the hope that it will be useful, but
   WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
   FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
   details.

   You should have received a copy of the GNU General Public License along with
   dream-html. If not, see <https://www.gnu.org/licenses/>. *)

type 'a ty = string -> ('a, string) result
type 'a t = (string, string) Hashtbl.t -> ('a, (string * string) list) result

let error_expected_bool = "error.expected.bool"
let error_expected_char = "error.expected.char"
let error_expected_single = "error.expected.single"
let error_expected_int = "error.expected.int"
let error_expected_int32 = "error.expected.int32"
let error_expected_int64 = "error.expected.int64"
let error_expected_number = "error.expected.number"
let error_required = "error.required"
let error name msg = Error [name, msg]

let ensure message condition field ty name values =
  match field ty name values with
  | Ok v as ok -> if condition v then ok else error name message
  | Error _ as error -> error

let rec all ty result = function
  | [] -> result
  | x :: xs -> (
    match ty x, result with
    | Ok t, Ok r -> all ty (Ok (t :: r)) xs
    | (Error _ as e), _ -> e
    | _, (Error _ as e) -> e)

let all ty = all ty (Ok [])

let list ty name values =
  match all ty (Hashtbl.find_all values name) with
  | Ok _ as ok -> ok
  | Error msg -> error name msg

let optional ty name values =
  match Hashtbl.find_opt values name with
  | None -> Ok None
  | Some s -> (
    match ty s with
    | Ok v -> Ok (Some v)
    | Error msg -> error name msg)

let required ty name values =
  match Hashtbl.find_opt values name with
  | None -> error name error_required
  | Some s -> (
    match ty s with
    | Ok v -> Ok v
    | Error msg -> error name msg)

let string s = Ok s

let int s =
  try Ok (int_of_string s) with Failure _ -> Error error_expected_int

let int32 s =
  try Ok (Int32.of_string s) with Failure _ -> Error error_expected_int32

let int64 s =
  try Ok (Int64.of_string s) with Failure _ -> Error error_expected_int64

let char s =
  if String.length s = 1 then
    Ok s.[0]
  else
    Error error_expected_char

let float s =
  try Ok (float_of_string s) with Failure _ -> Error error_expected_number

let bool = function
  | "true" -> Ok true
  | "false" -> Ok false
  | _ -> Error error_expected_bool

let ( let+ ) form f values =
  match form values with
  | Ok v -> Ok (f v)
  | Error e -> Error e

let ( and+ ) form1 form2 values =
  match form1 values, form2 values with
  | Ok v1, Ok v2 -> Ok (v1, v2)
  | Ok _, Error e2 -> Error e2
  | Error e1, Ok _ -> Error e1
  | Error e1, Error e2 -> Error (e2 @ e1)

let ( or ) form1 form2 values =
  match form1 values with
  | Ok _ as ok -> ok
  | Error _ -> form2 values

let validate form values =
  let htbl = Hashtbl.create 10 in
  List.iter (fun (name, value) -> Hashtbl.add htbl name value) values;
  form htbl

let pp_error =
  let open Fmt in
  brackets (list ~sep:semi (pair ~sep:comma string string))