diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/kernel/Branch.ml | 4 | ||||
| -rw-r--r-- | lib/kernel/EphemeralRelation.ml | 97 | ||||
| -rw-r--r-- | lib/kernel/Multigroup.ml | 6 | ||||
| -rw-r--r-- | lib/kernel/Program.ml | 26 |
4 files changed, 72 insertions, 61 deletions
diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml index 70e0711..ac8978b 100644 --- a/lib/kernel/Branch.ml +++ b/lib/kernel/Branch.ml @@ -108,7 +108,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct method protocols : Protocols.Handle.protocol list = let bind = - Option.map (fun root -> Source.bind root ~within:(Protocols.Handle.make {<>})) root + Option.map + (fun root -> {EphemeralRelation.root; within= Protocols.Handle.make {<>}}) + root in let multigroups = Prototype.mixture_of node (fun make node -> diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml index 7f1e79c..8cae91f 100644 --- a/lib/kernel/EphemeralRelation.ml +++ b/lib/kernel/EphemeralRelation.ml @@ -7,17 +7,6 @@ type t = | `Temporary of Protocols.Schematics.attribute_description BatMap.String.t ]; program: program option } -(* [name] is the relation a stored program defines, once it is read from - where it was stored under that name. *) -type Protocols.Handle.protocol += - | Stored of {evaluator: string; code: Concepts.Blob.t; name: string option} - -let stored handle = - Protocols.Handle.into handle (function - | Stored {evaluator; code; name} -> Some (evaluator, code, name) - | _ -> None ) - |> Option.map (fun i -> Protocols.Handle.invoke i Fun.id) - module Error = struct open Concepts.Condition @@ -70,7 +59,7 @@ let persisted = function Some {Persisted.name; schematics; program} | _ -> None -class ephemeral_relation ?code description value enumerate inputs = +class ephemeral_relation ?program description value enumerate inputs = object (self) inherit Lifecycle.counted inherit Identity.of_id @@ -93,34 +82,29 @@ class ephemeral_relation ?code description value enumerate inputs = Concepts.Hash.hash_equals (Concepts.Tuple.hash member) (Concepts.Tuple.hash tuple) ) ) method protocols : Protocols.Handle.protocol list = - let protocols = Protocols.[Relation.make self; Enumerable.make self; Schematics.make self] in + let protocols = + Protocols.[Relation.make self; Enumerable.make self; Schematics.make self] + @ Option.fold ~none:[] ~some:Protocols.Handle.protocols program + in match persisted relation with | None -> protocols | Some record -> - let stored = - Option.fold ~none:protocols - ~some:(fun code -> - Stored {evaluator= record.program.evaluator; code; name= Some record.name} - :: protocols ) - code - in Protocols.Addressable.make object method address = Persisted.Representation.to_blob record |> Concepts.Hash.hash_of_blob end - :: stored + :: protocols end -let instantiate ?(inputs = []) ?code description value enumerate = - new ephemeral_relation ?code description value enumerate inputs |> Protocols.Handle.make +let instantiate ?(inputs = []) ?program description value enumerate = + new ephemeral_relation ?program description value enumerate inputs |> Protocols.Handle.make let literal description tuples = instantiate description {name= None; schematics= `Temporary description; program= None} (fun () -> Ok (Generator.cursor_of (fun ~yield -> List.iter yield tuples; Ok ()))) -type binding = - string -> Protocols.Handle.t -> (Protocols.Handle.t, Concepts.Condition.condition) result +type binding = {root: Protocols.Handle.t; within: Protocols.Handle.t} (* The relation a program produced has to outlive the cursor over it. *) let enumerate_owned relation = @@ -144,44 +128,55 @@ let enumerate_owned relation = method to_string = Protocols.Handle.to_string cursor end ) +let run name program within () = + let open Utilities.Result in + match program, within with + | Some program, Some within -> + let* executable = Protocols.Executable.require program in + Result.bind (Protocols.Executable.invoke executable [] ~within) enumerate_owned + | _ -> Error (Error.unbound_program name) + +let view ?within description program = + instantiate ~program description + {name= None; schematics= `Temporary description; program= None} + (run (Protocols.Handle.to_string program) (Some program) within) + module Make (S : Abstract.Storage.STORAGE) = struct module SI = Storage.Make (S) module R = SubstantialRelation.Make (S) - (* Unbound, a stored program is only its source. Bound, enumerating - it runs the program through its evaluator, afresh each time. *) - let restore ?bind ~code ({Persisted.name; schematics; program} : Persisted.t) description = - let enumerate () = - match bind with - | None -> Error (Error.unbound_program name) - | Some bind -> - let source = - Prototype.mixture [Stored {evaluator= program.evaluator; code; name= Some name}] - in - Result.bind (bind program.evaluator source) enumerate_owned - in - instantiate ~code description - {name= Some name; schematics= `Persisted schematics; program= Some program} - enumerate + let restore ?program ?within ({Persisted.name; schematics; program= pointer} : Persisted.t) + description = + instantiate ?program description + {name= Some name; schematics= `Persisted schematics; program= Some pointer} + (run name program within) let load ?bind connection (record : Persisted.t) = - SI.with_read connection (fun tx -> - let open Utilities.Result in - let* description = R.schema_of tx record.schematics in - let* code = SI.get_req tx (S.Hash record.program.code) in - Ok (restore ?bind ~code record description) ) + let open Utilities.Result in + let* description, source = + SI.with_read connection (fun tx -> + let* description = R.schema_of tx record.schematics in + let* code = SI.get_req tx (S.Hash record.program.code) in + Ok (description, Bytes.to_string (Concepts.Blob.bytes_of_blob code)) ) + in + match bind with + | None -> Ok (restore record description) + | Some {root; within} -> + let* program = Program.load root ~evaluator:record.program.evaluator ~source in + Ok (restore ~program ~within record description) - let store tx ~name ~evaluator ~code description = + let store tx ~name ~evaluator ~source description = let open Utilities.Result in let* schematics = R.store_schema tx description in - let* address = SI.store_blob tx code in + let* address = SI.store_blob tx (Concepts.Blob.blob_of_bytes (Bytes.of_string source)) in let record = {Persisted.name; schematics; program= {evaluator; code= address}} in let* _ = SI.store_blob tx (Persisted.Representation.to_blob record) in Ok record - let persist connection ~name ~evaluator ~code description = + let persist connection ~name program description = + let open Utilities.Result in + let* {Program.evaluator; source; _} = Program.require program in SI.with_transaction connection (fun tx -> - let open Utilities.Result in - let* record = store tx ~name ~evaluator ~code description in - Ok (restore ~code record description) ) + let* record = store tx ~name ~evaluator ~source description in + Ok (restore ~program record description) ) end diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml index 5a3390d..eaef8c3 100644 --- a/lib/kernel/Multigroup.ml +++ b/lib/kernel/Multigroup.ml @@ -31,12 +31,12 @@ module Make (S : Abstract.Storage.STORAGE) = struct let admit name h = let open Utilities.Result in let address entry = Concepts.Hash.hash_of_blob (encode entry) in - match EphemeralRelation.stored h with - | Some (evaluator, code, _) -> + match Program.image h with + | Some {evaluator; source; _} -> let* description = Protocols.Relation.heading h in Ok (fun tx -> - let* record = E.store tx ~name ~evaluator ~code description in + let* record = E.store tx ~name ~evaluator ~source description in Ok (address (Ephemeral record)) ) | None -> let* description, tuples = Protocols.Relation.read h in diff --git a/lib/kernel/Program.ml b/lib/kernel/Program.ml index b528c5b..64a9fcf 100644 --- a/lib/kernel/Program.ml +++ b/lib/kernel/Program.ml @@ -17,6 +17,10 @@ module Error = struct let no_evaluator evaluator = condition "no-evaluator" "No evaluator is registered under that name" ("evaluator" |=| Concepts.Value.String evaluator) + + let not_a_program name = + condition "not-a-program" "A handle was expected to carry a program and did not" + ("object" |=| Concepts.Value.String name) end type kind = Protocols.Evaluator.kind = .. @@ -33,10 +37,17 @@ let reference evaluator = | Some i -> String.sub evaluator 0 i, String.sub evaluator (i + 1) (String.length evaluator - i - 1) -let lookup root evaluator = +let require handle = + image handle |> Option.to_result ~none:(Error.not_a_program (Protocols.Handle.to_string handle)) + +let with_evaluator root evaluator f = + let open Utilities.Result in let scope, language = reference evaluator in - Path.lookup root Path.(scope @/ "evaluator" @/ language @/ this) - |> Result.map_error (fun _ -> Error.no_evaluator evaluator) + let* found = + Path.lookup root Path.(scope @/ "evaluator" @/ language @/ this) + |> Result.map_error (fun _ -> Error.no_evaluator evaluator) + in + Protocols.Handle.releasing found (fun () -> Result.bind (Protocols.Evaluator.require found) f) class program ?root image = object (self) @@ -47,9 +58,7 @@ class program ?root image = 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 + with_evaluator root image.evaluator (fun evaluator -> Protocols.Evaluator.eval evaluator image.kind inputs ~within ) method protocols : Protocols.Handle.protocol list = @@ -58,3 +67,8 @@ class program ?root image = let make ?root ~evaluator ~source kind = new program ?root {evaluator; kind; source} |> Protocols.Handle.make + +let load root ~evaluator ~source = + with_evaluator root evaluator (fun found -> + Protocols.Evaluator.parse found source + |> Result.map (make ~root ~evaluator ~source) ) |