anil.recoil.org
Generate srcset images for a variety of resolutions from OCaml
tidy
+21
-21
lib/srcsetter.ml
+21
-21
lib/srcsetter.ml
···
1
(* Copyright (c) 2024, Anil Madhavapeddy <anil@recoil.org>
2
3
-
Permission to use, copy, modify, and/or distribute this software for
4
-
any purpose with or without fee is hereby granted, provided that the
5
-
above copyright notice and this permission notice appear in all
6
-
copies.
7
8
-
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
9
-
WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
10
-
WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
11
-
AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
12
-
DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA
13
-
OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
14
-
TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
15
-
PERFORMANCE OF THIS SOFTWARE.
16
-
*)
17
18
module MS = Map.Make (String)
19
···
26
}
27
28
let v name slug origin variants dims = { name; slug; origin; variants; dims }
29
-
let origin { origin; _ } = origin
30
-
let slug { slug; _ } = slug
31
-
let name { name; _ } = name
32
-
let dims { dims; _ } = dims
33
-
let variants { variants; _ } = variants
34
35
let dims_json_t =
36
let open Jsont in
37
-
let dec x y = (x, y) in
38
-
let enc (w, h) = function 0 -> w | _ -> h in
39
t2 ~dec ~enc uint16
40
41
let json_t =
···
50
|> finish
51
52
let list = Jsont.list json_t
53
-
let list_to_json es = Jsont_bytesrw.encode_string list ~format:Jsont.Indent es
54
let list_of_json = Jsont_bytesrw.decode_string list
···
1
(* Copyright (c) 2024, Anil Madhavapeddy <anil@recoil.org>
2
3
+
Permission to use, copy, modify, and/or distribute this software for
4
+
any purpose with or without fee is hereby granted, provided that the
5
+
above copyright notice and this permission notice appear in all
6
+
copies.
7
8
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
9
+
WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
10
+
WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
11
+
AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
12
+
DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA
13
+
OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
14
+
TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
15
+
PERFORMANCE OF THIS SOFTWARE. *)
16
17
module MS = Map.Make (String)
18
···
25
}
26
27
let v name slug origin variants dims = { name; slug; origin; variants; dims }
28
+
let name t = t.name
29
+
let slug t = t.slug
30
+
let origin t = t.origin
31
+
let dims t = t.dims
32
+
let variants t = t.variants
33
34
+
(** JSON codec for dimension pairs, encoded as a 2-element array. *)
35
let dims_json_t =
36
let open Jsont in
37
+
let dec w h = (w, h) in
38
+
let enc (w, h) i = if i = 0 then w else h in
39
t2 ~dec ~enc uint16
40
41
let json_t =
···
50
|> finish
51
52
let list = Jsont.list json_t
53
+
let list_to_json entries = Jsont_bytesrw.encode_string list ~format:Jsont.Indent entries
54
let list_of_json = Jsont_bytesrw.decode_string list
+56
-3
lib/srcsetter.mli
+56
-3
lib/srcsetter.mli
···
1
module MS : Map.S with type key = string
2
3
type t = {
4
name : string;
5
slug : string;
···
7
dims : int * int;
8
variants : (int * int) MS.t;
9
}
10
11
val v : string -> string -> string -> (int * int) MS.t -> int * int -> t
12
val origin : t -> string
13
-
val name : t -> string
14
val dims : t -> int * int
15
val variants : t -> (int * int) MS.t
16
val list_to_json : t list -> (string, string) result
17
val list_of_json : string -> (t list, string) result
18
-
val json_t : t Jsont.t
19
-
val list : t list Jsont.t
···
1
+
(** Image entry management for responsive image generation.
2
+
3
+
This module provides types and functions for managing image entries
4
+
that contain metadata about responsive images including their dimensions
5
+
and size variants. *)
6
+
7
+
(** {1 Types} *)
8
+
9
+
(** String map for storing image variants keyed by filename. *)
10
module MS : Map.S with type key = string
11
12
+
(** An image entry representing a source image and its generated variants.
13
+
14
+
Each entry tracks:
15
+
- The output filename ([name])
16
+
- A URL-safe identifier ([slug])
17
+
- The original source path ([origin])
18
+
- Image dimensions as [(width, height)]
19
+
- A map of variant filenames to their dimensions *)
20
type t = {
21
name : string;
22
slug : string;
···
24
dims : int * int;
25
variants : (int * int) MS.t;
26
}
27
+
28
+
(** {1 Constructors} *)
29
30
val v : string -> string -> string -> (int * int) MS.t -> int * int -> t
31
+
(** [v name slug origin variants dims] creates a new image entry.
32
+
33
+
@param name The output filename (e.g., ["photo.webp"])
34
+
@param slug A URL-safe identifier derived from the filename
35
+
@param origin The original source file path
36
+
@param variants Map of variant filenames to their [(width, height)] dimensions
37
+
@param dims The base image dimensions as [(width, height)] *)
38
+
39
+
(** {1 Accessors} *)
40
+
41
+
val name : t -> string
42
+
(** [name entry] returns the output filename. *)
43
+
44
+
val slug : t -> string
45
+
(** [slug entry] returns the URL-safe identifier. *)
46
+
47
val origin : t -> string
48
+
(** [origin entry] returns the original source file path. *)
49
+
50
val dims : t -> int * int
51
+
(** [dims entry] returns the base image dimensions as [(width, height)]. *)
52
+
53
val variants : t -> (int * int) MS.t
54
+
(** [variants entry] returns the map of variant filenames to dimensions. *)
55
+
56
+
(** {1 JSON Serialization} *)
57
+
58
+
val json_t : t Jsont.t
59
+
(** JSON codec for a single image entry. *)
60
+
61
+
val list : t list Jsont.t
62
+
(** JSON codec for a list of image entries. *)
63
+
64
val list_to_json : t list -> (string, string) result
65
+
(** [list_to_json entries] serializes a list of entries to a JSON string.
66
+
67
+
Returns [Ok json_string] on success, or [Error message] if encoding fails. *)
68
+
69
val list_of_json : string -> (t list, string) result
70
+
(** [list_of_json json_string] parses a JSON string into a list of entries.
71
+
72
+
Returns [Ok entries] on success, or [Error message] if parsing fails. *)
+170
-137
lib/srcsetter_cmd.ml
+170
-137
lib/srcsetter_cmd.ml
···
1
open Eio
2
3
type ('a, 'b) config = {
4
dummy : bool;
5
preserve : bool;
···
12
max_fibers : int;
13
}
14
15
let rec file_seq ~filter path =
16
-
Path.with_open_dir path Path.read_dir
17
-
|> List.fold_left
18
-
(fun (dirs, files) f ->
19
-
let fp = Path.(path / f) in
20
-
match Path.kind ~follow:false fp with
21
-
| `Regular_file when filter f -> (dirs, fp :: files)
22
-
| `Directory -> (f :: dirs, files)
23
-
| _ -> (dirs, files))
24
-
([], [])
25
-
|> fun (dirs, files) ->
26
Seq.append (List.to_seq files)
27
-
(Seq.flat_map
28
-
(fun f -> file_seq ~filter Path.(path / f))
29
-
(List.to_seq dirs))
30
31
let iter_seq_p ?max_fibers fn seq =
32
Eio.Switch.run ~name:"iter_seq_p" @@ fun sw ->
33
match max_fibers with
34
| None -> Seq.iter (fun v -> Fiber.fork ~sw @@ fun () -> fn v) seq
35
-
| Some mf when mf <= 0 -> invalid_arg "iter_seq_p max_fibers"
36
| Some mf ->
37
-
let s = Semaphore.make mf in
38
Seq.iter
39
(fun v ->
40
-
Semaphore.acquire s;
41
Fiber.fork ~sw @@ fun () ->
42
-
Fun.protect ~finally:(fun () -> Semaphore.release s) @@ fun () -> fn v)
43
seq
44
45
let relativize_path dir path =
46
let dir = Path.native_exn dir in
47
let path = Path.native_exn path in
48
match Fpath.(rem_prefix (v dir) (v path)) with
49
-
| None -> failwith "bad path prefix"
50
-
| Some v -> Fpath.to_string v
51
52
-
let dims { proc_mgr; _ } fl =
53
-
let fl = Path.native_exn fl in
54
-
let args = [ "identify"; "-ping"; "-format"; "%w %h"; fl ] in
55
-
let l = Process.parse_out proc_mgr Buf_read.take_all args in
56
-
Scanf.sscanf l "%d %d" (fun w h -> (w, h))
57
58
let run { dummy; proc_mgr; _ } args =
59
if not dummy then Process.run proc_mgr args
60
61
let convert ({ src_dir; dst_dir; dummy; _ } as cfg) (src, dst, size) =
62
-
if dummy then () (* TODO log skip *)
63
-
else
64
let dir =
65
if Filename.dirname dst = "." then dst_dir
66
else Path.(dst_dir / Filename.dirname dst)
67
in
68
-
Path.(mkdirs ~exists_ok:true ~perm:0o755 dir);
69
-
let src = Path.(native_exn (src_dir / src)) in
70
-
let dst = Path.(native_exn (dst_dir / dst)) in
71
let sz = Printf.sprintf "%dx" size in
72
-
let args =
73
[
74
-
"magick";
75
-
src;
76
-
"-auto-orient";
77
-
"-thumbnail";
78
-
sz;
79
-
"-quality";
80
-
"100";
81
-
"-gravity";
82
-
"center";
83
-
"-extent";
84
-
sz;
85
-
dst;
86
]
87
-
in
88
-
run cfg args
89
90
let convert_pdf cfg ~size ~dst ~src =
91
-
let src = Path.native_exn src in
92
-
let dst = Path.native_exn dst in
93
let sz = Printf.sprintf "%sx" size in
94
-
let args =
95
[
96
-
"magick";
97
-
"-density";
98
-
"300";
99
-
"-quality";
100
-
"100";
101
-
src ^ "[0]";
102
-
"-gravity";
103
-
"North";
104
-
"-crop";
105
-
"100%x50%+0+0";
106
-
"-resize";
107
-
sz;
108
-
dst;
109
]
110
-
in
111
-
run cfg args
112
113
let needed_sizes ~img_widths ~w = List.filter (fun tw -> tw <= w) img_widths
114
115
let translate { src_dir; dst_dir; preserve; _ } ?w src =
116
let src_file = relativize_path src_dir src in
117
-
let dst_file =
118
-
Printf.sprintf "%s%s.webp"
119
-
(Filename.chop_extension src_file)
120
-
(match w with None -> "" | Some w -> "." ^ string_of_int w)
121
-
in
122
let dst = Path.(dst_dir / dst_file) in
123
-
match (preserve, Path.is_file dst) with
124
-
| true, true -> (src_file, dst_file, w, false)
125
-
| _, false -> (src_file, dst_file, w, true)
126
-
| false, true -> (src_file, dst_file, w, true)
127
128
let calc_needed { src_dir; dst_dir; preserve; _ } ~img_widths ~w src =
129
-
let ent_of_dst fname tw =
130
let dst = Path.(dst_dir / fname) in
131
let ent = (src, dst, tw) in
132
-
match (preserve, Path.is_file dst) with
133
-
| true, true -> `Exists ent
134
-
| _, false -> `Todo ent
135
-
| false, true -> `Todo ent
136
in
137
let file = relativize_path src_dir src in
138
-
let base =
139
-
let fname = Printf.sprintf "%s.webp" (Filename.chop_extension file) in
140
-
ent_of_dst fname w
141
-
in
142
let variants =
143
List.filter_map
144
(fun tw ->
145
-
if tw <= w then
146
-
let fname =
147
-
Printf.sprintf "%s.%d.webp" (Filename.chop_extension file) tw
148
-
in
149
-
Some (ent_of_dst fname tw)
150
else None)
151
img_widths
152
in
153
(base, variants)
154
155
let main_bar total =
156
let style =
157
-
let open Progress.Line.Bar_style in
158
let open Progress.Color in
159
-
let bars = ("|", "|") in
160
-
v ~delims:bars ~color:(hex "#FFBA08") [ "█"; "▓"; "▒"; "░"; " " ]
161
in
162
-
let open Progress.Line in
163
list [ bar ~style:(`Custom style) total; ticker_to total ]
164
165
let main_bar_heading head total =
166
let open Progress.Multi in
167
line (Progress.Line.const head) ++ line (main_bar total) ++ blank
168
169
let one_bar total =
170
let style =
171
-
let open Progress.Line.Bar_style in
172
let open Progress.Color in
173
v ~delims:("{", "}") ~color:(ansi `blue) [ "="; ">"; " " ]
174
in
175
-
let open Progress.Line in
176
-
let a =
177
-
list
178
-
[
179
-
spinner ();
180
-
bar ~style:(`Custom style) ~width:(`Fixed 12) total;
181
-
const " ";
182
-
]
183
-
in
184
-
let b = string in
185
-
pair a b
186
187
let process_file cfg (display, main_rep) src =
188
let w, h = dims cfg src in
189
let needed_w = needed_sizes ~img_widths:cfg.img_widths ~w in
190
-
let ((base_src, base_dst, _, _) as base) = translate cfg src in
191
let needed = List.map (fun w -> translate cfg ~w src) needed_w in
192
let variants =
193
-
List.map (fun (_, dst, _, _) -> (dst, (0, 0))) needed
194
|> Srcsetter.MS.of_list
195
in
196
let slug = Filename.basename base_dst |> Filename.chop_extension in
197
-
(* TODO avsm check for clashing slugs *)
198
let ent = Srcsetter.v base_dst slug base_src variants (w, h) in
199
let todo =
200
List.filter_map
201
-
(fun (src, dst, sz, n) ->
202
-
let sz = match sz with None -> w | Some w -> w in
203
-
if n then Some (src, dst, sz) else None)
204
(base :: needed)
205
in
206
-
if List.length todo > 3 then (
207
-
let l = one_bar (List.length todo) in
208
-
let r = Progress.Display.add_line display l in
209
-
let fin = ref [] in
210
-
let rep sz =
211
-
if sz > 0 then fin := sz :: !fin;
212
-
let la = String.concat "," @@ List.map string_of_int !fin in
213
-
let flb =
214
-
Filename.basename (Path.native_exn src) |> Filename.chop_extension
215
-
in
216
-
let trim_string str max_length =
217
-
if String.length str <= max_length then str
218
-
else if max_length <= 3 then String.sub "..." 0 max_length
219
-
else
220
-
let trimmed_length = max_length - 3 in
221
-
let prefix = String.sub str 0 trimmed_length in
222
-
prefix ^ "..."
223
-
in
224
-
let label = Printf.sprintf "%25s -> %s" (trim_string flb 25) la in
225
-
Progress.Reporter.report r (1, label)
226
in
227
-
rep 0;
228
-
List.iter
229
-
(fun ((_, _, sz) as a) ->
230
-
rep sz;
231
-
convert cfg a)
232
-
todo;
233
main_rep 1;
234
-
Progress.Display.remove_line display r)
235
-
else (
236
-
List.iter (fun a -> convert cfg a) todo;
237
-
main_rep 1);
238
ent
···
1
+
(* Copyright (c) 2024, Anil Madhavapeddy <anil@recoil.org>
2
+
3
+
Permission to use, copy, modify, and/or distribute this software for
4
+
any purpose with or without fee is hereby granted, provided that the
5
+
above copyright notice and this permission notice appear in all
6
+
copies.
7
+
8
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
9
+
WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
10
+
WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
11
+
AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
12
+
DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA
13
+
OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
14
+
TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
15
+
PERFORMANCE OF THIS SOFTWARE. *)
16
+
17
+
(** Command-line image processing operations for srcsetter.
18
+
19
+
This module provides the core image processing pipeline including
20
+
file discovery, image conversion, and progress reporting. *)
21
+
22
open Eio
23
24
+
(** Configuration for the image processing pipeline.
25
+
26
+
@param dummy When true, skip actual image conversion (dry run)
27
+
@param preserve When true, skip conversion if destination exists
28
+
@param proc_mgr Eio process manager for running ImageMagick
29
+
@param src_dir Source directory containing original images
30
+
@param dst_dir Destination directory for generated images
31
+
@param img_widths List of target widths for responsive variants
32
+
@param img_exts File extensions to process (e.g., ["jpg"; "png"])
33
+
@param idx_file Name of the JSON index file to generate
34
+
@param max_fibers Maximum concurrent conversion operations *)
35
type ('a, 'b) config = {
36
dummy : bool;
37
preserve : bool;
···
44
max_fibers : int;
45
}
46
47
+
(** [file_seq ~filter path] recursively enumerates files in [path].
48
+
49
+
Returns a sequence of file paths where [filter filename] is true.
50
+
Directories are traversed depth-first. *)
51
let rec file_seq ~filter path =
52
+
let dirs, files =
53
+
Path.with_open_dir path Path.read_dir
54
+
|> List.fold_left
55
+
(fun (dirs, files) f ->
56
+
let fp = Path.(path / f) in
57
+
match Path.kind ~follow:false fp with
58
+
| `Regular_file when filter f -> (dirs, fp :: files)
59
+
| `Directory -> (f :: dirs, files)
60
+
| _ -> (dirs, files))
61
+
([], [])
62
+
in
63
Seq.append (List.to_seq files)
64
+
(Seq.flat_map (fun f -> file_seq ~filter Path.(path / f)) (List.to_seq dirs))
65
+
66
+
(** [iter_seq_p ?max_fibers fn seq] iterates [fn] over [seq] in parallel.
67
68
+
@param max_fibers Optional limit on concurrent fibers. Must be positive.
69
+
@raise Invalid_argument if [max_fibers] is not positive. *)
70
let iter_seq_p ?max_fibers fn seq =
71
Eio.Switch.run ~name:"iter_seq_p" @@ fun sw ->
72
match max_fibers with
73
| None -> Seq.iter (fun v -> Fiber.fork ~sw @@ fun () -> fn v) seq
74
+
| Some mf when mf <= 0 -> invalid_arg "iter_seq_p: max_fibers must be positive"
75
| Some mf ->
76
+
let sem = Semaphore.make mf in
77
Seq.iter
78
(fun v ->
79
+
Semaphore.acquire sem;
80
Fiber.fork ~sw @@ fun () ->
81
+
Fun.protect ~finally:(fun () -> Semaphore.release sem) @@ fun () ->
82
+
fn v)
83
seq
84
85
+
(** [relativize_path dir path] returns [path] relative to [dir].
86
+
87
+
@raise Failure if [path] is not under [dir]. *)
88
let relativize_path dir path =
89
let dir = Path.native_exn dir in
90
let path = Path.native_exn path in
91
match Fpath.(rem_prefix (v dir) (v path)) with
92
+
| None -> failwith "relativize_path: path is not under directory"
93
+
| Some rel -> Fpath.to_string rel
94
95
+
(** [dims cfg path] returns the [(width, height)] dimensions of an image.
96
97
+
Uses ImageMagick's [identify] command to read image metadata. *)
98
+
let dims { proc_mgr; _ } path =
99
+
let path = Path.native_exn path in
100
+
let args = [ "identify"; "-ping"; "-format"; "%w %h"; path ] in
101
+
let output = Process.parse_out proc_mgr Buf_read.take_all args in
102
+
Scanf.sscanf output "%d %d" (fun w h -> (w, h))
103
+
104
+
(** [run cfg args] executes a shell command unless in dummy mode. *)
105
let run { dummy; proc_mgr; _ } args =
106
if not dummy then Process.run proc_mgr args
107
108
+
(** [convert cfg (src, dst, size)] converts an image to WebP format.
109
+
110
+
Creates the destination directory if needed, then uses ImageMagick
111
+
to resize and convert the image with auto-orientation. *)
112
let convert ({ src_dir; dst_dir; dummy; _ } as cfg) (src, dst, size) =
113
+
if dummy then ()
114
+
else begin
115
let dir =
116
if Filename.dirname dst = "." then dst_dir
117
else Path.(dst_dir / Filename.dirname dst)
118
in
119
+
Path.mkdirs ~exists_ok:true ~perm:0o755 dir;
120
+
let src_path = Path.(native_exn (src_dir / src)) in
121
+
let dst_path = Path.(native_exn (dst_dir / dst)) in
122
let sz = Printf.sprintf "%dx" size in
123
+
run cfg
124
[
125
+
"magick"; src_path;
126
+
"-auto-orient"; "-thumbnail"; sz;
127
+
"-quality"; "100";
128
+
"-gravity"; "center"; "-extent"; sz;
129
+
dst_path;
130
]
131
+
end
132
+
133
+
(** [convert_pdf cfg ~size ~dst ~src] converts a PDF's first page to an image.
134
135
+
Renders at 300 DPI, crops the top half, and resizes to the target width. *)
136
let convert_pdf cfg ~size ~dst ~src =
137
+
let src_path = Path.native_exn src in
138
+
let dst_path = Path.native_exn dst in
139
let sz = Printf.sprintf "%sx" size in
140
+
run cfg
141
[
142
+
"magick"; "-density"; "300"; "-quality"; "100";
143
+
src_path ^ "[0]";
144
+
"-gravity"; "North"; "-crop"; "100%x50%+0+0";
145
+
"-resize"; sz;
146
+
dst_path;
147
]
148
149
+
(** [needed_sizes ~img_widths ~w] returns widths from [img_widths] that are <= [w]. *)
150
let needed_sizes ~img_widths ~w = List.filter (fun tw -> tw <= w) img_widths
151
152
+
(** [needs_conversion ~preserve dst] returns true if [dst] should be generated.
153
+
154
+
When [preserve] is true, existing files are skipped. *)
155
+
let needs_conversion ~preserve dst =
156
+
not (preserve && Path.is_file dst)
157
+
158
+
(** [translate cfg ?w src] computes source and destination paths for conversion.
159
+
160
+
Returns [(src_file, dst_file, width_opt, needs_work)] where [needs_work]
161
+
indicates whether the conversion should be performed. *)
162
let translate { src_dir; dst_dir; preserve; _ } ?w src =
163
let src_file = relativize_path src_dir src in
164
+
let width_suffix = Option.fold ~none:"" ~some:(fun w -> "." ^ string_of_int w) w in
165
+
let dst_file = Printf.sprintf "%s%s.webp" (Filename.chop_extension src_file) width_suffix in
166
let dst = Path.(dst_dir / dst_file) in
167
+
(src_file, dst_file, w, needs_conversion ~preserve dst)
168
+
169
+
(** [calc_needed cfg ~img_widths ~w src] computes which conversions are needed.
170
171
+
Returns [(base, variants)] where each is tagged with [`Exists] or [`Todo]. *)
172
let calc_needed { src_dir; dst_dir; preserve; _ } ~img_widths ~w src =
173
+
let check_dst fname tw =
174
let dst = Path.(dst_dir / fname) in
175
let ent = (src, dst, tw) in
176
+
if preserve && Path.is_file dst then `Exists ent else `Todo ent
177
in
178
let file = relativize_path src_dir src in
179
+
let base_name = Filename.chop_extension file in
180
+
let base = check_dst (Printf.sprintf "%s.webp" base_name) w in
181
let variants =
182
List.filter_map
183
(fun tw ->
184
+
if tw <= w then Some (check_dst (Printf.sprintf "%s.%d.webp" base_name tw) tw)
185
else None)
186
img_widths
187
in
188
(base, variants)
189
190
+
(** {1 Progress Bar Rendering} *)
191
+
192
+
(** [main_bar total] creates a progress bar for [total] items. *)
193
let main_bar total =
194
+
let open Progress.Line in
195
let style =
196
+
let open Bar_style in
197
let open Progress.Color in
198
+
v ~delims:("|", "|") ~color:(hex "#FFBA08") [ "█"; "▓"; "▒"; "░"; " " ]
199
in
200
list [ bar ~style:(`Custom style) total; ticker_to total ]
201
202
+
(** [main_bar_heading head total] creates a labeled progress display. *)
203
let main_bar_heading head total =
204
let open Progress.Multi in
205
line (Progress.Line.const head) ++ line (main_bar total) ++ blank
206
207
+
(** [one_bar total] creates a compact progress bar for individual file processing. *)
208
let one_bar total =
209
+
let open Progress.Line in
210
let style =
211
+
let open Bar_style in
212
let open Progress.Color in
213
v ~delims:("{", "}") ~color:(ansi `blue) [ "="; ">"; " " ]
214
in
215
+
let left = list [ spinner (); bar ~style:(`Custom style) ~width:(`Fixed 12) total; const " " ] in
216
+
pair left string
217
+
218
+
(** {1 Image Processing} *)
219
+
220
+
(** [truncate_string str max_len] truncates [str] to [max_len] chars with ellipsis. *)
221
+
let truncate_string str max_len =
222
+
if String.length str <= max_len then str
223
+
else if max_len <= 3 then String.sub "..." 0 max_len
224
+
else String.sub str 0 (max_len - 3) ^ "..."
225
+
226
+
(** [process_file cfg (display, main_rep) src] processes a single source image.
227
+
228
+
Converts the image to WebP format at multiple responsive sizes.
229
+
Shows a nested progress bar for files requiring many conversions.
230
231
+
@return An {!Srcsetter.t} entry with metadata about the generated images. *)
232
let process_file cfg (display, main_rep) src =
233
let w, h = dims cfg src in
234
let needed_w = needed_sizes ~img_widths:cfg.img_widths ~w in
235
+
let base_src, base_dst, _, _ as base = translate cfg src in
236
let needed = List.map (fun w -> translate cfg ~w src) needed_w in
237
let variants =
238
+
needed
239
+
|> List.map (fun (_, dst, _, _) -> (dst, (0, 0)))
240
|> Srcsetter.MS.of_list
241
in
242
let slug = Filename.basename base_dst |> Filename.chop_extension in
243
let ent = Srcsetter.v base_dst slug base_src variants (w, h) in
244
let todo =
245
List.filter_map
246
+
(fun (src, dst, sz, needs_work) ->
247
+
if needs_work then Some (src, dst, Option.value sz ~default:w) else None)
248
(base :: needed)
249
in
250
+
let num_todo = List.length todo in
251
+
if num_todo > 3 then begin
252
+
let line = one_bar num_todo in
253
+
let reporter = Progress.Display.add_line display line in
254
+
let completed = ref [] in
255
+
let report_progress sz =
256
+
if sz > 0 then completed := sz :: !completed;
257
+
let sizes_str = String.concat "," (List.map string_of_int !completed) in
258
+
let basename = Path.native_exn src |> Filename.basename |> Filename.chop_extension in
259
+
let label = Printf.sprintf "%25s -> %s" (truncate_string basename 25) sizes_str in
260
+
Progress.Reporter.report reporter (1, label)
261
in
262
+
report_progress 0;
263
+
List.iter (fun (_, _, sz as job) -> report_progress sz; convert cfg job) todo;
264
main_rep 1;
265
+
Progress.Display.remove_line display reporter
266
+
end
267
+
else begin
268
+
List.iter (convert cfg) todo;
269
+
main_rep 1
270
+
end;
271
ent