programs as invokable images

3 files changed, 60 insertions, 153 deletions

diff --git a/lib/kernel/Program.ml b/lib/kernel/Program.ml
new file mode 100644
index 0000000..b528c5b
--- /dev/null
+++ b/lib/kernel/Program.ml
@@ -0,0 +1,60 @@
+(* A program is an image just like PE, but we represent it as an
+   object. It should have the kind of executable it is, indicating the
+   evaluator needed for it to be executed and a type (generally it can
+   be a tree) that can be interpreted/compiled by said evaluator, and
+   finally the source code in plain text so we can display it for
+   debug. We can persist programs under
+   \system\branch\<b>\multigroup\<m>\program\, but we are not
+   obligated to, they can be merely temporary in memory. *)
+
+module Error = struct
+  open Concepts.Condition
+
+  let unloaded evaluator =
+    condition "unloaded-program" "A program has to be given a root before it can be run"
+      ("evaluator" |=| Concepts.Value.String evaluator)
+
+  let no_evaluator evaluator =
+    condition "no-evaluator" "No evaluator is registered under that name"
+      ("evaluator" |=| Concepts.Value.String evaluator)
+end
+
+type kind = Protocols.Evaluator.kind = ..
+type image = {evaluator: string; kind: kind; source: string}
+type Protocols.Handle.protocol += Program of image
+
+let image handle =
+  Protocols.Handle.into handle (function Program image -> Some image | _ -> None)
+  |> Option.map (fun i -> Protocols.Handle.invoke i Fun.id)
+
+let reference evaluator =
+  match String.rindex_opt evaluator ':' with
+  | None -> "system", evaluator
+  | Some i ->
+      String.sub evaluator 0 i, String.sub evaluator (i + 1) (String.length evaluator - i - 1)
+
+let lookup root evaluator =
+  let scope, language = reference evaluator in
+  Path.lookup root Path.(scope @/ "evaluator" @/ language @/ this)
+  |> Result.map_error (fun _ -> Error.no_evaluator evaluator)
+
+class program ?root image =
+  object (self)
+    inherit Lifecycle.null
+    inherit Identity.of_id
+    method to_string = image.source
+
+    method invoke inputs ~within =
+      let open Utilities.Result in
+      let* root = Option.to_result ~none:(Error.unloaded image.evaluator) root in
+      let* found = lookup root image.evaluator in
+      Protocols.Handle.releasing found (fun () ->
+          let* evaluator = Protocols.Evaluator.require found in
+          Protocols.Evaluator.eval evaluator image.kind inputs ~within )
+
+    method protocols : Protocols.Handle.protocol list =
+      [Program image; Protocols.Executable.make self]
+  end
+
+let make ?root ~evaluator ~source kind =
+  new program ?root {evaluator; kind; source} |> Protocols.Handle.make
diff --git a/lib/kernel/Source.ml b/lib/kernel/Source.ml
deleted file mode 100644
index f81499c..0000000
--- a/lib/kernel/Source.ml
+++ /dev/null
@@ -1,88 +0,0 @@
-let blob text = Concepts.Blob.blob_of_bytes (Bytes.of_string text)
-
-let stored_text ~language text =
-  EphemeralRelation.Stored {evaluator= language; code= blob text; name= None}
-
-let program ~language text = Prototype.mixture [stored_text ~language text]
-
-let view ~language ~heading text =
-  Prototype.mixture
-    [ stored_text ~language text;
-      Protocols.Schematics.make
-        object
-          method describe () = Ok (Protocols.Schematics.Relation heading)
-        end ]
-
-let stored handle =
-  EphemeralRelation.stored handle
-  |> Option.map (fun (evaluator, code, name) ->
-      evaluator, Bytes.to_string (Concepts.Blob.bytes_of_blob code), name )
-
-let text handle = Option.map (fun (evaluator, text, _) -> evaluator, text) (stored handle)
-
-let reference evaluator =
-  match String.rindex_opt evaluator ':' with
-  | None -> "system", evaluator
-  | Some i ->
-      String.sub evaluator 0 i, String.sub evaluator (i + 1) (String.length evaluator - i - 1)
-
-let language_of evaluator = snd (reference evaluator)
-
-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 evaluator =
-    condition "no-evaluator" "No evaluator is registered under that name"
-      ("evaluator" |=| Concepts.Value.String evaluator)
-end
-
-let evaluator ~language ?view 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 stored program with
-        | None -> Error (Error.not_a_program language)
-        | Some (given, _, _) when language_of given <> language ->
-            Error (Error.foreign language given)
-        | Some (_, source, name) -> (
-          match name, view with
-          | Some name, Some view -> view ~within ~name source
-          | _ -> run ~within source )
-    end
-
-let evaluators scope = Path.(scope @/ "evaluator" @/ this)
-
-let bind root ~within evaluator program =
-  let open Utilities.Result in
-  let scope, language = reference evaluator in
-  let* found =
-    Result.bind
-      (Path.lookup root (evaluators scope))
-      (fun directory -> Path.lookup directory Path.(language @/ this))
-    |> Result.map_error (fun _ -> Error.no_evaluator evaluator)
-  in
-  Protocols.Handle.releasing found (fun () ->
-      let* found = Protocols.Evaluator.require found in
-      Protocols.Evaluator.invoke found program ~within )
-
-let run root ~language ~within source = bind root ~within language (program ~language source)
-
-let register root ~scope ~language evaluator =
-  let open Utilities.Result in
-  let* directory = Path.lookup root (evaluators scope) in
-  let* registry = Protocols.Handle.require Protocols.Registry.from directory in
-  let* _ = Protocols.Registry.update registry language None (Some evaluator) in
-  Ok ()
diff --git a/lib/kernel/Source.mli b/lib/kernel/Source.mli
deleted file mode 100644
index b0479f2..0000000
--- a/lib/kernel/Source.mli
+++ /dev/null
@@ -1,65 +0,0 @@
-(** programs as source. A program in any language travels the tree as a
-    handle carrying [EphemeralRelation.Stored], with its text as the code,
-    so whoever holds one can run it through the evaluator of its language
-    without linking that language.
-
-    An evaluator is named [scope:language] and registered at
-    \[scope]\evaluator\[language]; a bare [language] is the system's. *)
-
-(** a program in [language], to run. *)
-val program : language:string -> string -> Protocols.Handle.t
-
-(** a program in [language] defining a relation of [heading], to store in
-    a branch, where reading it runs it. *)
-val view :
-  language:string ->
-  heading:Protocols.Schematics.relation_description ->
-  string ->
-  Protocols.Handle.t
-
-(** the evaluator and text a handle carries, if it is a program. *)
-val text : Protocols.Handle.t -> (string * string) option
-
-(** an evaluator name split into its scope and language. *)
-val reference : string -> string * string
-
-(** an evaluator for [language]. A stored relation read from a branch is
-    given to [view] with its name: what the source defines under that
-    name, read [within] the branch state. Anything else is given to
-    [run]. *)
-val evaluator :
-  language:string ->
-  ?view:
-    (within:Protocols.Handle.t ->
-    name:string ->
-    string ->
-    (Protocols.Handle.t, Concepts.Condition.condition) result ) ->
-  (within:Protocols.Handle.t -> string -> (Protocols.Handle.t, Concepts.Condition.condition) result) ->
-  Protocols.Handle.t
-
-(** run [program] through the evaluator named [evaluator] under [root],
-    [within] the given directory. Usable as an [EphemeralRelation.binding]
-    once [root] and [within] are given. *)
-val bind :
-  Protocols.Handle.t ->
-  within:Protocols.Handle.t ->
-  string ->
-  Protocols.Handle.t ->
-  (Protocols.Handle.t, Concepts.Condition.condition) result
-
-(** run [text] with the evaluator named [language] under [root], [within]
-    the given directory. *)
-val run :
-  Protocols.Handle.t ->
-  language:string ->
-  within:Protocols.Handle.t ->
-  string ->
-  (Protocols.Handle.t, Concepts.Condition.condition) result
-
-(** register [evaluator] as \[scope]\evaluator\[language] under [root]. *)
-val register :
-  Protocols.Handle.t ->
-  scope:string ->
-  language:string ->
-  Protocols.Handle.t ->
-  (unit, Concepts.Condition.condition) result