Source file Hit.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
(* Claude Code
 *
 * Copyright (C) 2026 Yoann Padioleau
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Library General Public License
 * (LGPL) as published by the Free Software Foundation; either version
 * 2 of the License, or (at your option) any later version.
 *)

(* See Hit.mli *)

(* the link on a line at [x]: in a fragment, or in the space between
 * two fragments of the same link *)
let rec on_line (fragments : Html_layout.fragment list) (x : float) : string option =
  match fragments with
  | [] -> None
  | f :: rest ->
      if x >= f.x && x <= f.x +. f.width then f.look.link
      else (
        match rest with
        | next :: _ when x > f.x +. f.width && x < next.x && f.look.link <> None && f.look.link = next.look.link ->
            f.look.link
        | _ -> on_line rest x)

let rec link_at (b : Html_layout.box) ~(x : float) ~(y : float) : string option =
  if y < b.y || y > b.y +. b.height then None
  else
    let in_lines =
      List.find_map
        (fun (l : Html_layout.line) -> if y >= l.top && y <= l.top +. l.height then on_line l.fragments x else None)
        b.lines
    in
    match in_lines with Some _ -> in_lines | None -> List.find_map (fun c -> link_at c ~x ~y) b.children

let rec fragment_at (b : Html_layout.box) ~(x : float) ~(y : float) : Html_layout.fragment option =
  if y < b.y || y > b.y +. b.height then None
  else
    let in_lines =
      List.find_map
        (fun (l : Html_layout.line) ->
          if y >= l.top && y <= l.top +. l.height then
            List.find_opt (fun (f : Html_layout.fragment) -> x >= f.x && x <= f.x +. f.width) l.fragments
          else None)
        b.lines
    in
    match in_lines with Some _ -> in_lines | None -> List.find_map (fun c -> fragment_at c ~x ~y) b.children

(* the element at a point: the fragment's there (a word, a picture, a
 * control, a float), else the innermost block around the point (a
 * table's cell, a list's item, the body) *)
let rec element_at (b : Html_layout.box) ~(x : float) ~(y : float) : Dom.element option =
  let inside (b : Html_layout.box) = x >= b.x && x <= b.x +. b.width && y >= b.y && y <= b.y +. b.height in
  let on (f : Html_layout.fragment) =
    let top = match f.picture with Some p -> f.baseline -. p.height | None -> f.baseline -. f.look.size in
    x >= f.x && x <= f.x +. f.width && y >= top && y <= f.baseline +. (0.3 *. f.look.size)
  in
  if not (inside b) && b.floats = [] then None
  else
    match List.find_opt on b.floats with
    | Some f -> Some f.element
    | None -> (
        match fragment_at b ~x ~y with
        | Some f when List.memq f (List.concat_map (fun (l : Html_layout.line) -> l.fragments) b.lines) -> Some f.element
        | _ -> (
            match List.find_map (fun c -> element_at c ~x ~y) b.children with
            | Some e -> Some e
            | None -> ( match b.kind with Block e when inside b -> Some e | _ -> None)))

let rec anchor (b : Html_layout.box) (name : string) : float option =
  match b.kind with
  | Block e when Dom.attribute "id" e = Some name -> Some b.y
  | _ -> (
      match List.find_opt (fun (l : Html_layout.line) -> List.mem name l.anchors) b.lines with
      | Some l -> Some l.top
      | None -> List.find_map (fun c -> anchor c name) b.children)