Source file form.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
open! Core
open! Import

module Q = struct
  let eval = "eval" |> Symbol.intern
  let interactive = "interactive" |> Symbol.intern
  let lambda = "lambda" |> Symbol.intern
  let let_ = "let" |> Symbol.intern
  let progn = "progn" |> Symbol.intern
  let quote = "quote" |> Symbol.intern
  let read_from_whole_string = "read-from-whole-string" |> Symbol.intern
  let thingatpt = "thingatpt" |> Symbol.intern

  module A = struct
    let optional = "&optional" |> Symbol.intern
    let rest = "&rest" |> Symbol.intern
  end
end

include Value.Make_subtype (struct
    let name = "form"
    let here = [%here]
    let is_in_subtype _ = true
  end)

let string s = s |> Value.of_utf8_bytes |> of_value_exn
let symbol s = s |> Symbol.to_value |> of_value_exn
let int i = i |> Value.of_int_exn |> of_value_exn

let read =
  Feature.require Q.thingatpt;
  fun string ->
    Symbol.funcall1 Q.read_from_whole_string (string |> Value.of_utf8_bytes)
    |> of_value_exn
;;

module Blocking = struct
  let eval t = Symbol.funcall1 Q.eval (t |> to_value)
  let eval_i t = ignore (eval t : Value.t)
  let eval_string string = eval (read string)
end

let eval t = Value.Private.run_outside_async [%here] (fun () -> Blocking.eval t)
let eval_i t = Value.Private.run_outside_async [%here] (fun () -> Blocking.eval_i t)

let eval_string t =
  Value.Private.run_outside_async [%here] (fun () -> Blocking.eval_string t)
;;

let list ts = Value.list (ts : t list :> Value.t list) |> of_value_exn
let nil = list []
let q value = Value.list [ Symbol.to_value Q.quote; value ]
let quote value = q value |> of_value_exn
let progn ts = list (symbol Q.progn :: ts)

let let_ bindings body =
  Value.list
    [ Q.let_ |> Symbol.to_value
    ; bindings
      |> List.map ~f:(fun (v, e) -> Value.list [ v |> Symbol.to_value; e |> to_value ])
      |> Value.list
    ; body |> to_value
    ]
  |> of_value_exn
;;

let lambda =
  let some = Option.some in
  fun ?docstring ?interactive ?optional_args ?rest_arg here ~args ~body ->
    (match docstring with
     | None -> ()
     | Some docstring ->
       if String.mem docstring '\000'
       then raise_s [%message "docstring contains a NUL byte" (docstring : string)]);
    let args =
      [ args
      ; (match optional_args with
         | None | Some [] -> []
         | Some optional_args -> Q.A.optional :: optional_args)
      ; rest_arg
        |> Option.value_map ~default:[] ~f:(fun rest_arg -> [ Q.A.rest; rest_arg ])
      ]
      |> List.concat
      |> (fun x -> (x : Symbol.t list :> Value.t list))
      |> Value.list
    in
    let here =
      concat [ "Implemented at ["; here |> Source_code_position.to_string; "]." ]
    in
    let docstring =
      match docstring with
      | None -> here
      | Some s ->
        let s = String.strip s in
        concat [ (if String.is_empty s then "" else concat [ s; "\n\n" ]); here ]
    in
    [ Q.lambda |> Symbol.to_value |> some
    ; args |> some
    ; docstring |> Value.of_utf8_bytes |> some
    ; interactive
      |> Option.map ~f:(fun interactive ->
        Value.list [ Q.interactive |> Symbol.to_value; interactive ])
    ; body |> to_value |> some
    ]
    |> List.filter_opt
    |> Value.list
    |> of_value_exn
;;