Source file thing_at_point.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
117
118
119
120
121
open! Core_kernel
open! Import

module Q = struct
  include Q

  let bounds_of_thing_at_point = "bounds-of-thing-at-point" |> Symbol.intern
  and email = "email" |> Symbol.intern
  and filename = "filename" |> Symbol.intern
  and line = "line" |> Symbol.intern
  and page = "page" |> Symbol.intern
  and sentence = "sentence" |> Symbol.intern
  and url = "url" |> Symbol.intern
  and whitespace = "whitespace" |> Symbol.intern
  and word = "word" |> Symbol.intern
end

type t =
  | Defun
  | Email
  | Filename
  | Line
  | List
  | Number
  | Other of Symbol.t
  | Page
  | Sentence
  | Sexp
  | String_of of { chars : string }
  | Symbol
  | Url
  | Whitespace
  | Word
[@@deriving sexp_of]

(* Not giving [t] a [type_] because it's not quite the same as what gets
   passed to [thing-at-point]. In particular, [Custom_chars] means to pass
   ['filename] to [thing-at-point] but set [thing-at-point-file-name-chars]
   first. *)

let to_symbol = function
  | Defun -> Q.defun
  | Email -> Q.email
  | Filename -> Q.filename
  | Line -> Q.line
  | List -> Q.list
  | Number -> Q.number
  | Other sym -> sym
  | Page -> Q.page
  | Sentence -> Q.sentence
  | Sexp -> Q.sexp
  (* [chars] is passed separately through the [file_name_chars] variable. *)
  | String_of _ -> Q.filename
  | Symbol -> Q.symbol
  | Url -> Q.url
  | Whitespace -> Q.whitespace
  | Word -> Q.word
;;

let file_name_chars = Var.Wrap.("thing-at-point-file-name-chars" <: string)

let with_settings t ~f =
  match t with
  | String_of { chars } ->
    Current_buffer.set_value_temporarily Sync file_name_chars chars ~f
  | _ -> f ()
;;

let thing_at_point =
  Funcall.("thing-at-point" <: Symbol.t @-> bool @-> return (nil_or Text.t))
;;

let find ?(text_properties = false) thing =
  with_settings thing ~f:(fun () ->
    thing_at_point (thing |> to_symbol) (not text_properties))
;;

let forward_thing = Funcall.("forward-thing" <: Symbol.t @-> int @-> return bool)

let forward ?(n = 1) thing =
  with_settings thing ~f:(fun () -> forward_thing (thing |> to_symbol) n)
;;

let bounds_of_thing_at_point =
  Funcall.(
    "bounds-of-thing-at-point"
    <: Symbol.t @-> return (nil_or (tuple Position.t Position.t)))
;;

let bounds thing =
  with_settings thing ~f:(fun () -> bounds_of_thing_at_point (thing |> to_symbol))
;;

let did_not_raise f x =
  match f x with
  | _ -> true
  | exception _ -> false
;;

let beginning_of_thing = Funcall.("beginning-of-thing" <: Symbol.t @-> return nil)

let beginning_exn thing =
  with_settings thing ~f:(fun () -> beginning_of_thing (thing |> to_symbol))
;;

let beginning = did_not_raise beginning_exn
let end_of_thing = Funcall.("end-of-thing" <: Symbol.t @-> return nil)
let end_exn thing = with_settings thing ~f:(fun () -> end_of_thing (thing |> to_symbol))
let end_ = did_not_raise end_exn
let bounds_prop = Symbol.Property.create Q.bounds_of_thing_at_point Function.t

let defthing symbol loc ~(bounds : unit -> (Position.t * Position.t) option) =
  Symbol.Property.put
    bounds_prop
    symbol
    (Defun.lambda_nullary
       loc
       (Returns Value.Type.(nil_or (tuple Position.t Position.t)))
       bounds);
  Other symbol
;;