scope and source for evaluators

5 files changed, 305 insertions, 51 deletions

diff --git a/lib/evaluators/FOL.ml b/lib/evaluators/FOL.ml
index 1c52265..9980927 100644
--- a/lib/evaluators/FOL.ml
+++ b/lib/evaluators/FOL.ml
@@ -74,11 +74,12 @@ let rec term_of_bencode =
 let encode term = bencode_of_term term |> Bencode.to_blob
 let decode code = Bencode.of_blob code |> Utilities.Result.fmap term_of_bencode
 
+(* a program is FOL's if its evaluator's language is, as Source has it *)
+let ours evaluator = snd (Kernel.Source.reference evaluator) = name
+
 let stored relation =
-  Protocols.Handle.into relation (function
-    | Kernel.EphemeralRelation.Stored {evaluator; code} -> Some (evaluator, code)
-    | _ -> None )
-  |> Option.map (fun stored -> Protocols.Handle.invoke stored Fun.id)
+  Kernel.EphemeralRelation.stored relation
+  |> Option.map (fun (evaluator, code, _) -> evaluator, code)
 
 (* TODO: To strenghten our checks for self references, we need to
    construct a graph and see raise a condition if there are self
@@ -95,7 +96,7 @@ let instantiate resolve =
         | Some (evaluator, code) ->
             Protocols.Handle.release relation;
             let identity = Concepts.Hash.hash_of_blob code in
-            if not (String.equal evaluator name) then Error (Error.foreign_program evaluator)
+            if not (ours evaluator) then Error (Error.foreign_program evaluator)
             else if List.exists (Concepts.Hash.hash_equals identity) expanding then
               Error (Error.cyclic_program identity)
             else
@@ -207,7 +208,7 @@ class evaluator =
           stored program )
       with
       | Some plan, _ -> Protocols.Handle.invoke plan execute
-      | None, Some (evaluator, _) when not (String.equal evaluator name) ->
+      | None, Some (evaluator, _) when not (ours evaluator) ->
           Error (Error.foreign_program evaluator)
       | None, Some (_, code) ->
           let* term = decode code in
diff --git a/lib/kernel/Scope.ml b/lib/kernel/Scope.ml
new file mode 100644
index 0000000..cfba6b3
--- /dev/null
+++ b/lib/kernel/Scope.ml
@@ -0,0 +1,148 @@
+type home = {multigroup: string; schema: string}
+
+class type implementation = object
+  method branch : Protocols.Handle.t
+  method home : home
+  method previous : (Protocols.Handle.t option, Concepts.Condition.condition) result
+  method catalog : (string list, Concepts.Condition.condition) result
+end
+
+type Protocols.Handle.protocol += Scope of implementation
+
+let require handle =
+  Protocols.Handle.into handle (function Scope i -> Some i | _ -> None)
+  |> Option.to_result
+       ~none:
+         Concepts.Condition.(
+           condition "not-a-scope" "A handle was expected to be a branch state read from a home"
+             empty )
+
+let relations {multigroup; schema} =
+  Path.("multigroup" @/ multigroup @/ "schema" @/ schema @/ "relation" @/ this)
+
+let path home relation = Path.(of_list (to_list (relations home) @ [relation]))
+
+(* A name leaves out, from the left, what it shares with its home. *)
+let resolve home text =
+  match String.split_on_char ':' text with
+  | names when List.mem "" names -> None
+  | [r] -> Some (home, r)
+  | [s; r] -> Some ({home with schema= s}, r)
+  | [m; s; r] -> Some ({multigroup= m; schema= s}, r)
+  | _ -> None
+
+let locate home text = Option.map (fun (h, r) -> path h r) (resolve home text)
+
+let attribute home relation text =
+  match List.rev (String.split_on_char ':' text) with
+  | [a] -> Some a
+  | a :: rest when resolve home (String.concat ":" (List.rev rest)) = resolve home relation ->
+      Some a
+  | _ -> None
+
+(* the names a directory lists, and what each reaches *)
+let children directory =
+  let open Utilities.Result in
+  let* listing = Protocols.Handle.require Protocols.Directory.from directory in
+  let* names = Protocols.Directory.list listing in
+  BatFingerTree.to_list names
+  |> List.map (fun name ->
+      let* found = Protocols.Directory.find listing name in
+      Ok (Option.map (fun child -> name, child) found) )
+  |> Utilities.List.sequence
+  |> Result.map (List.filter_map Fun.id)
+
+(* every relation of a branch state, as multigroup:schema:relation *)
+let catalog_of branch =
+  let open Utilities.Result in
+  let name prefix last = String.concat ":" (List.rev (last :: prefix)) in
+  let rec down prefix handle properties =
+    let* level = Path.find handle Path.(List.hd properties @/ this) in
+    match level, List.tl properties with
+    | None, _ -> Ok []
+    | Some level, [] ->
+        let* listing = Protocols.Handle.require Protocols.Directory.from level in
+        let* names = Protocols.Directory.list listing in
+        Ok (List.map (name prefix) (BatFingerTree.to_list names))
+    | Some level, rest ->
+        let* named = children level in
+        List.map (fun (n, child) -> down (n :: prefix) child rest) named
+        |> Utilities.List.sequence
+        |> Result.map List.concat
+  in
+  down [] branch ["multigroup"; "schema"; "relation"]
+
+let rec make branch home =
+  Prototype.mixture
+    [ Protocols.Directory.make
+        object
+          method list =
+            let open Utilities.Result in
+            let* found = Path.find branch (relations home) in
+            match found with
+            | None -> Ok BatFingerTree.empty
+            | Some found ->
+                let* listing = Protocols.Handle.require Protocols.Directory.from found in
+                Protocols.Directory.list listing
+
+          (* what is not a relation's name names no relation here *)
+          method find text =
+            match resolve home text with
+            | None -> Ok None
+            | Some (h, r) -> Path.find branch (path h r)
+        end;
+      Scope
+        object
+          method branch = branch
+          method home = home
+
+          method previous =
+            let open Utilities.Result in
+            let* previous = Path.find branch Path.("previous" @/ this) in
+            Ok (Option.map (fun p -> make p home) previous)
+
+          method catalog = catalog_of branch
+        end ]
+
+let heads = Path.("system" @/ "branch" @/ this)
+
+let of_root root ~branch home =
+  let open Utilities.Result in
+  let* state = Path.lookup root Path.("system" @/ "branch" @/ branch @/ this) in
+  Ok (make state home)
+
+let branch i = Protocols.Handle.invoke i (fun o -> o#branch)
+let home i = Protocols.Handle.invoke i (fun o -> o#home)
+let previous i = Protocols.Handle.invoke i (fun o -> o#previous)
+let catalog i = Protocols.Handle.invoke i (fun o -> o#catalog)
+
+module Error = struct
+  open Concepts.Condition
+
+  let malformed name =
+    condition "malformed-name"
+      "A relation is named relation, schema:relation or multigroup:schema:relation"
+      ("name" |=| Concepts.Value.String name)
+
+  let moved branch =
+    condition "serialization-conflict" "The branch moved on while this commit was made; retry it"
+      ("branch" |=| Concepts.Value.String branch)
+end
+
+let publish root ~branch ~home bindings =
+  let open Utilities.Result in
+  let* changes =
+    List.map
+      (fun (name, v) ->
+        match resolve home name with
+        | Some (h, r) -> Ok (relations h, r, v)
+        | None -> Error (Error.malformed name) )
+      bindings
+    |> Utilities.List.sequence
+  in
+  if List.is_empty changes then Ok ()
+  else
+    let* state = Path.lookup root Path.("system" @/ "branch" @/ branch @/ this) in
+    let* next = Path.assoc_all state changes in
+    let* landed = Path.update root heads branch (Some state) (Some next) in
+    if landed then Ok () else Error (Error.moved branch)
diff --git a/lib/kernel/Scope.mli b/lib/kernel/Scope.mli
new file mode 100644
index 0000000..aabdc61
--- /dev/null
+++ b/lib/kernel/Scope.mli
@@ -0,0 +1,65 @@
+(** A branch state read from a home: a [Directory] of relations where
+    [R] names the home schema's, [s:R] a schema's of the home multigroup,
+    and [m:s:R] anyone's in the branch state. It lists the home schema. *)
+
+type home = {multigroup: string; schema: string}
+
+class type implementation = object
+  (** the branch state read *)
+  method branch : Protocols.Handle.t
+
+  method home : home
+
+  (** the same home in the state before, if there is one *)
+  method previous : (Protocols.Handle.t option, Concepts.Condition.condition) result
+
+  (** every relation of the branch state, as [m:s:R] *)
+  method catalog : (string list, Concepts.Condition.condition) result
+end
+
+type Protocols.Handle.protocol += Scope of implementation
+
+val make : Protocols.Handle.t -> home -> Protocols.Handle.t
+
+(** [home] in the head of \system\branch\[branch]. *)
+val of_root :
+  Protocols.Handle.t ->
+  branch:string ->
+  home ->
+  (Protocols.Handle.t, Concepts.Condition.condition) result
+
+val require :
+  Protocols.Handle.t ->
+  (implementation Protocols.Handle.interface, Concepts.Condition.condition) result
+
+val branch : implementation Protocols.Handle.interface -> Protocols.Handle.t
+val home : implementation Protocols.Handle.interface -> home
+
+val previous :
+  implementation Protocols.Handle.interface ->
+  (Protocols.Handle.t option, Concepts.Condition.condition) result
+
+val catalog :
+  implementation Protocols.Handle.interface -> (string list, Concepts.Condition.condition) result
+
+(** \multigroup\[m]\schema\[s]\relation\[relation], from a branch state. *)
+val path : home -> string -> Path.t
+
+(** where [text] names a relation, read from [home], from a branch state. *)
+val locate : home -> string -> Path.t option
+
+(** the attribute [text] names of the relation named [relation], both read
+    from [home]: bare, or qualified with a name of that relation. *)
+val attribute : home -> string -> string -> string option
+
+(** bind each named relation to its value, or unbind it on [None], in the
+    head of \system\branch\[branch], as one successor state. A multigroup
+    or schema not there yet is made, and a value with no address is
+    stored as a schema stores it: a program as itself, a relation as its
+    tuples. If the head moved meanwhile nothing changes, and it fails. *)
+val publish :
+  Protocols.Handle.t ->
+  branch:string ->
+  home:home ->
+  (string * Protocols.Handle.t option) list ->
+  (unit, Concepts.Condition.condition) result
diff --git a/lib/kernel/Source.ml b/lib/kernel/Source.ml
index e5de6e8..16d2b04 100644
--- a/lib/kernel/Source.ml
+++ b/lib/kernel/Source.ml
@@ -1,14 +1,32 @@
-let program ~language text =
+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
-    [ EphemeralRelation.Stored
-        {evaluator= language; code= Concepts.Blob.blob_of_bytes (Bytes.of_string text)} ]
+    [ 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 =
-  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)
+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
@@ -21,12 +39,12 @@ module Error = struct
     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)
+  let no_evaluator evaluator =
+    condition "no-evaluator" "No evaluator is registered under that name"
+      ("evaluator" |=| Concepts.Value.String evaluator)
 end
 
-let evaluator ~language run =
+let evaluator ~language ?view run =
   Protocols.Handle.make
     object (self)
       inherit Lifecycle.null
@@ -35,34 +53,38 @@ let evaluator ~language run =
       method protocols : Protocols.Handle.protocol list = [Protocols.Evaluator.make self]
 
       method invoke program ~within =
-        match text program with
+        match stored program with
         | None -> Error (Error.not_a_program language)
-        | Some (given, _) when given <> language -> Error (Error.foreign language given)
-        | Some (_, source) -> run ~within source
+        | 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 = Path.("system" @/ "evaluator" @/ this)
+let evaluators scope = Path.(scope @/ "evaluator" @/ this)
 
-let bind directory ~within language program =
+let bind root ~within evaluator program =
   let open Utilities.Result in
-  let* evaluator =
-    Path.lookup directory Path.(language @/ this)
-    |> Result.map_error (fun _ -> Error.no_evaluator language)
+  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
   Fun.protect
-    ~finally:(fun () -> Protocols.Handle.release evaluator)
+    ~finally:(fun () -> Protocols.Handle.release found)
     (fun () ->
-      let* evaluator = Protocols.Evaluator.require evaluator in
-      Protocols.Evaluator.invoke evaluator program ~within )
+      let* found = Protocols.Evaluator.require found in
+      Protocols.Evaluator.invoke found 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 run root ~language ~within source = bind root ~within language (program ~language source)
 
-let register root ~language evaluator =
+let register root ~scope ~language evaluator =
   let open Utilities.Result in
-  let* directory = Path.lookup root evaluators 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
index 0961dcc..b0479f2 100644
--- a/lib/kernel/Source.mli
+++ b/lib/kernel/Source.mli
@@ -1,28 +1,45 @@
 (** 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. *)
+    without linking that language.
 
-(** a program in [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
 
-(** the language and text a handle carries, if it is a program. *)
+(** 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 for [language]: it runs the text of a program in that
-    language against the directory it is given, and refuses anything
-    else. *)
+(** 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
 
-(** where the evaluators are registered, from the root: \system\evaluator. *)
-val evaluators : Path.t
-
-(** run [program] through the evaluator of [language] found in
-    [directory], against [within]. Usable as an
-    [EphemeralRelation.binding] once [directory] and [within] are given. *)
+(** 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 ->
@@ -30,8 +47,8 @@ val bind :
   Protocols.Handle.t ->
   (Protocols.Handle.t, Concepts.Condition.condition) result
 
-(** run [text] in [language] against [within], with the evaluator
-    registered under [root]. *)
+(** run [text] with the evaluator named [language] under [root], [within]
+    the given directory. *)
 val run :
   Protocols.Handle.t ->
   language:string ->
@@ -39,9 +56,10 @@ val run :
   string ->
   (Protocols.Handle.t, Concepts.Condition.condition) result
 
-(** register [evaluator] for [language] under [root]. *)
+(** 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