blob: b3a8f26d9c302078495ed431a99d17aa6d017609 (
plain) (
blame)
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
117
118
119
120
121
122
123
124
|
module L = Colitur_kernel.Layer
module Cel = Colitur_kernel.Celebration
module S = Colitur_kernel.Slug
module DS = Colitur_kernel.Date_spec
module Col = Colitur_kernel.Colour
type rank = Class1 | Class3 [@@deriving sexp]
let slug = S.of_string_exn
let cel ?(rank = Class3) ?(colour = Col.White) s =
Cel.make ~slug:(slug s) ~rank ~colour ~layer:"base" ()
let entry ?(month = 1) ?(day = 1) ?rank ?colour s =
{ L.date = (match DS.fixed ~month ~day with Ok d -> d | Error e -> failwith e);
cel = cel ?rank ?colour s }
let base () =
L.of_entries ~id:"base" ~name:"Test base"
[ entry ~month:1 ~day:5 "telesphorus"; entry ~month:1 ~day:14 "hilary" ]
(* First occurrence only -- used to corrupt one field (the slug atom) of an
otherwise well-formed serialised layer, without hand-writing the whole
sexp shape by hand. *)
let replace_first ~sub ~by s =
let sub_len = String.length sub and s_len = String.length s in
let rec find i =
if i + sub_len > s_len then None
else if String.sub s i sub_len = sub then Some i
else find (i + 1)
in
match find 0 with
| None -> s
| Some i -> String.sub s 0 i ^ by ^ String.sub s (i + sub_len) (s_len - i - sub_len)
let with_temp_file f =
let path = Filename.temp_file "colitur_layer" ".sexp" in
Fun.protect ~finally:(fun () -> try Sys.remove path with Sys_error _ -> ()) (fun () -> f path)
let test_layer_basics () =
let l = base () in
Alcotest.(check bool) "find present" true (L.find l (slug "hilary") <> None);
Alcotest.(check bool) "find absent" true (L.find l (slug "nobody") = None);
Alcotest.(check bool) "mem" true (L.mem l (slug "telesphorus"));
(* canonical order is by slug, so sexp output is byte-stable *)
Alcotest.(check (list string)) "canonical order" [ "hilary"; "telesphorus" ]
(List.map (fun e -> S.to_string e.L.cel.Cel.slug) l.L.entries)
let test_layer_index () =
let idx = L.index_by_date (base ()) in
Alcotest.(check int) "Jan 14 has one" 1 (List.length (L.on_date idx ~month:1 ~day:14));
Alcotest.(check int) "Jan 20 has none" 0 (List.length (L.on_date idx ~month:1 ~day:20))
(* Three entries sharing a date, inserted deliberately out of canonical
(by-slug) order: this is what actually pins accumulation (the bucket must
hold all three, not overwrite) and deterministic ordering (the bucket must
come back sorted regardless of insertion order). Entries already inserted
in sorted order would pass even with the sort dropped. *)
let test_layer_index_same_date () =
let l =
L.of_entries ~id:"base" ~name:"Test same-date"
[ entry ~month:3 ~day:17 "zeta"; entry ~month:3 ~day:17 "alpha"; entry ~month:3 ~day:17 "mu" ]
in
let idx = L.index_by_date l in
let bucket = L.on_date idx ~month:3 ~day:17 in
Alcotest.(check int) "three entries share Mar 17" 3 (List.length bucket);
Alcotest.(check (list string)) "bucket sorted by slug" [ "alpha"; "mu"; "zeta" ]
(List.map (fun e -> S.to_string e.L.cel.Cel.slug) bucket)
let test_layer_sexp () =
let l = base () in
let sexp = L.sexp_of_t sexp_of_rank l in
Alcotest.(check bool) "roundtrip" true (L.t_of_sexp rank_of_sexp sexp = l)
let test_layer_load_success () =
let l = base () in
with_temp_file (fun path ->
let oc = open_out path in
output_string oc (Sexplib.Sexp.to_string (L.sexp_of_t sexp_of_rank l));
close_out oc;
match L.load rank_of_sexp path with
| Ok loaded -> Alcotest.(check bool) "round-trip equal" true (loaded = l)
| Error msg -> Alcotest.failf "expected Ok, got Error %s" msg)
let test_layer_load_missing_file () =
let path = Filename.temp_file "colitur_layer_missing" ".sexp" in
Sys.remove path;
match L.load rank_of_sexp path with
| Ok _ -> Alcotest.fail "expected Error for a missing file"
| Error _ -> ()
let test_layer_load_malformed () =
with_temp_file (fun path ->
let oc = open_out path in
(* unterminated list -- sexplib raises Failure here, not Parse_error *)
output_string oc "((id \"x\") (name \"y\") (entries (";
close_out oc;
match L.load rank_of_sexp path with
| Ok _ -> Alcotest.fail "expected Error for a malformed sexp"
| Error _ -> ())
let test_layer_load_invalid_slug () =
let single = L.of_entries ~id:"base" ~name:"Test" [ entry ~month:2 ~day:2 "hilary" ] in
let text = Sexplib.Sexp.to_string (L.sexp_of_t sexp_of_rank single) in
let corrupted = replace_first ~sub:"hilary" ~by:"Bad_Slug!" text in
with_temp_file (fun path ->
let oc = open_out path in
output_string oc corrupted;
close_out oc;
match L.load rank_of_sexp path with
| Ok _ -> Alcotest.fail "expected Error for an invalid slug"
| Error _ -> ())
let suite =
( "Layer/Overlay",
[ Alcotest.test_case "layer basics" `Quick test_layer_basics;
Alcotest.test_case "layer by-date index" `Quick test_layer_index;
Alcotest.test_case "layer by-date index accumulates same date" `Quick
test_layer_index_same_date;
Alcotest.test_case "layer sexp" `Quick test_layer_sexp;
Alcotest.test_case "layer load success round-trip" `Quick test_layer_load_success;
Alcotest.test_case "layer load missing file" `Quick test_layer_load_missing_file;
Alcotest.test_case "layer load malformed sexp" `Quick test_layer_load_malformed;
Alcotest.test_case "layer load invalid slug" `Quick test_layer_load_invalid_slug ] )
|
