Source file funcall.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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
open! Core
open! Import

type _ t =
  | ( :: ) : 'a Value.Type.t * 'b t -> ('a -> 'b) t
  | Nullary : 'b Value.Type.t -> (unit -> 'b) t
  | Return : 'a Value.Type.t -> 'a t

let return_type_of_value symbol (type_ : 'a Value.Type.t) value =
  match Value.Type.of_value_exn type_ value with
  | x -> x
  | exception exn ->
    raise_s
      [%message
        "funcall failed to convert return value."
          (symbol : Value.t)
          (type_ : _ Value.Type.t)
          (exn : Exn.t)]
;;

let arity t =
  let rec arity : type a. a t -> int -> int =
    fun t i ->
      match t with
      | Return _ -> i
      | Nullary _ -> i
      | _ :: t -> arity t (i + 1)
  in
  arity t 0
;;

let wrap : type a. a t -> Value.t -> a =
  fun t symbol ->
  let rec curry : type a. a t -> Value.t -> Value.t array -> int -> a =
    fun t symbol args i ->
      match t with
      | type_ :: t ->
        fun arg ->
          args.(i) <- Value.Type.to_value type_ arg;
          curry t symbol args (i + 1)
      | Nullary return_type ->
        assert (Int.( = ) i 0);
        fun _ -> Value.funcall0 symbol |> return_type_of_value symbol return_type
      | Return type_ ->
        Value.funcallN_array symbol args |> return_type_of_value symbol type_
  in
  let args = Array.create ~len:(arity t) Value.nil in
  curry t symbol args 0
;;

(* It's unclear how much this sort of unrolling matters, but the C bindings do it, so we
   might as well do it here. *)
let wrap_unrolled : type a. a t -> Value.t -> a =
  fun t symbol ->
  let ret type_ value = return_type_of_value symbol type_ value in
  match t with
  | Return type_ -> Value.funcall0 symbol |> ret type_
  | Nullary return_type -> fun _ -> Value.funcall0 symbol |> ret return_type
  | type1 :: Return type_ ->
    fun a1 -> Value.funcall1 symbol (a1 |> Value.Type.to_value type1) |> ret type_
  | type1 :: type2 :: Return type_ ->
    fun a1 a2 ->
      Value.funcall2
        symbol
        (a1 |> Value.Type.to_value type1)
        (a2 |> Value.Type.to_value type2)
      |> ret type_
  | type1 :: type2 :: type3 :: Return type_ ->
    fun a1 a2 a3 ->
      Value.funcall3
        symbol
        (a1 |> Value.Type.to_value type1)
        (a2 |> Value.Type.to_value type2)
        (a3 |> Value.Type.to_value type3)
      |> ret type_
  | type1 :: type2 :: type3 :: type4 :: Return type_ ->
    fun a1 a2 a3 a4 ->
      Value.funcall4
        symbol
        (a1 |> Value.Type.to_value type1)
        (a2 |> Value.Type.to_value type2)
        (a3 |> Value.Type.to_value type3)
        (a4 |> Value.Type.to_value type4)
      |> ret type_
  | type1 :: type2 :: type3 :: type4 :: type5 :: Return type_ ->
    fun a1 a2 a3 a4 a5 ->
      Value.funcall5
        symbol
        (a1 |> Value.Type.to_value type1)
        (a2 |> Value.Type.to_value type2)
        (a3 |> Value.Type.to_value type3)
        (a4 |> Value.Type.to_value type4)
        (a5 |> Value.Type.to_value type5)
      |> ret type_
  | t -> wrap t symbol
;;

let apply t f args ~on_parse_error =
  let wrong_number_of_args message =
    raise_s [%message message (arity t : int) (args : Value.t list)]
  in
  let rec apply : type a. a t -> a -> Value.t list -> Value.t =
    fun t f args ->
      match t with
      | type_ :: t ->
        (match args with
         | arg :: args ->
           (match Value.Type.of_value_exn type_ arg with
            | arg -> apply t (f arg) args
            | exception exn -> on_parse_error exn)
         | [] ->
           (* Emacs convention: missing arguments are nil. *)
           (match Value.Type.of_value_exn type_ Value.nil with
            | arg -> apply t (f arg) args
            | exception exn -> on_parse_error exn))
      | Return type_ ->
        (match args with
         | [] -> Value.Type.to_value type_ f
         | _ :: _ -> wrong_number_of_args "Extra args.")
      | Nullary type_ ->
        (match args with
         | [] -> Value.Type.to_value type_ (f ())
         | _ :: _ -> wrong_number_of_args "Extra args.")
  in
  apply t f args
;;

module Wrap = struct
  let return type_ = Return type_

  let nullary =
    Value.Type.create
      [%sexp "funcall-nullary-placeholder-value"]
      [%sexp_of: unit]
      ignore
      (const Value.nil)
  ;;

  let nil = Value.Type.ignored

  let ( @-> ) (type a b) (type_ : a Value.Type.t) (t : b t) =
    match t with
    | _ :: _ ->
      (match Type_equal.Id.same (Value.Type.id type_) (Value.Type.id nullary) with
       | true -> raise_s [%message "Function already has arguments, cannot be nullary."]
       | false -> type_ :: t)
    | Nullary _ -> raise_s [%message "Cannot add arguments to nullary function."]
    | Return return_type ->
      (match Type_equal.Id.same_witness (Value.Type.id type_) (Value.Type.id nullary) with
       | Some Type_equal.T -> Nullary return_type
       | None -> type_ :: t)
  ;;

  let ( <: ) elisp_function =
    let v = elisp_function |> Value.intern in
    fun t -> wrap_unrolled t v
  ;;

  include (Value.Type : Value.Type.S)
end

module Private = struct
  let apply = apply
  let wrap_unrolled = wrap_unrolled
end