lib/kernel/Source.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

let program ~language text =
  Prototype.mixture
    [ EphemeralRelation.Stored
        {evaluator= language; code= Concepts.Blob.blob_of_bytes (Bytes.of_string text)} ]

let text handle =
  Protocols.Handle.into handle (function
    | EphemeralRelation.Stored {evaluator; code} ->
        Some (evaluator, Bytes.to_string (Concepts.Blob.bytes_of_blob code))
    | _ -> None )
  |> Option.map (fun i -> Protocols.Handle.invoke i Fun.id)

module Error = struct
  open Concepts.Condition

  let not_a_program language =
    condition "not-a-program" "An evaluator was given something that carries no source"
      ("language" |=| Concepts.Value.String language)

  let foreign language given =
    condition "foreign-program" "An evaluator was given source in another language"
      ("language" |=| Concepts.Value.String language & "given" |=| Concepts.Value.String given)

  let no_evaluator language =
    condition "no-evaluator" "No evaluator is registered for the language"
      ("language" |=| Concepts.Value.String language)
end

let evaluator ~language run =
  Protocols.Handle.make
    object (self)
      inherit Lifecycle.null
      inherit Identity.of_id
      method to_string = language ^ "-evaluator"
      method protocols : Protocols.Handle.protocol list = [Protocols.Evaluator.make self]

      method invoke program ~within =
        match text program with
        | None -> Error (Error.not_a_program language)
        | Some (given, _) when given <> language -> Error (Error.foreign language given)
        | Some (_, source) -> run ~within source
    end

let evaluators = Path.("system" @/ "evaluator" @/ this)

let bind directory ~within language program =
  let open Utilities.Result in
  let* evaluator =
    Path.lookup directory Path.(language @/ this)
    |> Result.map_error (fun _ -> Error.no_evaluator language)
  in
  Fun.protect
    ~finally:(fun () -> Protocols.Handle.release evaluator)
    (fun () ->
      let* evaluator = Protocols.Evaluator.require evaluator in
      Protocols.Evaluator.invoke evaluator program ~within )

let run root ~language ~within source =
  let open Utilities.Result in
  let* directory = Path.lookup root evaluators in
  bind directory ~within language (program ~language source)

let register root ~language evaluator =
  let open Utilities.Result in
  let* directory = Path.lookup root evaluators in
  let* registry = Protocols.Handle.require Protocols.Registry.from directory in
  let* _ = Protocols.Registry.update registry language None (Some evaluator) in
  Ok ()