diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/evaluators/FOL.ml | 25 | ||||
| -rw-r--r-- | lib/kernel/Program.ml | 60 | ||||
| -rw-r--r-- | lib/kernel/Source.ml | 88 | ||||
| -rw-r--r-- | lib/kernel/Source.mli | 65 | ||||
| -rw-r--r-- | lib/protocols/Evaluator.ml | 10 | ||||
| -rw-r--r-- | lib/protocols/Evaluator.mli | 15 | ||||
| -rw-r--r-- | lib/protocols/Executable.ml | 12 | ||||
| -rw-r--r-- | lib/protocols/Executable.mli | 19 |
8 files changed, 116 insertions, 178 deletions
diff --git a/lib/evaluators/FOL.ml b/lib/evaluators/FOL.ml index 91e00ca..24006b1 100644 --- a/lib/evaluators/FOL.ml +++ b/lib/evaluators/FOL.ml @@ -41,7 +41,6 @@ let name = "fol" type 'r term = Base of 'r | Project of 'r term * string BatFingerTree.t type plan = Protocols.Handle.t term -type Protocols.Handle.protocol += Plan of plan module Bencode = Concepts.Encoding.Bencode @@ -74,15 +73,13 @@ 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 - (* TODO: To strenghten our checks for self references, we need to construct a graph and see raise a condition if there are self references. We partially do that here with the program calling self, but if the flow is alternated, say between program A and B, where B calls A and A calls B, we also must check. *) let instantiate resolve = + (* let open Utilities.Result in let rec bind expanding = function | Base reference -> ( @@ -103,19 +100,11 @@ let instantiate resolve = Ok (Project (plan, attributes)) in bind [] - -class program plan = - object - inherit Kernel.Lifecycle.null - inherit Kernel.Identity.of_id - method to_string = "fol-program" - method protocols : Protocols.Handle.protocol list = [Plan plan] - end - -let program plan = new program plan |> Protocols.Handle.make + *) + failwith "NOT IMPLEMENT" let restrict attributes description = - let open Utilities.Result in + (*let open Utilities.Result in BatFingerTree.fold_left (fun restricted name -> let* restricted = restricted in @@ -124,7 +113,9 @@ let restrict attributes description = |> Option.to_result ~none:(Error.unknown_attribute name) in Ok (BatMap.String.add name attribute restricted) ) - (Ok BatMap.String.empty) attributes + (Ok BatMap.String.empty) attributes + *) + failwith "NOT IMPLEMENT" let rec describe = let open Utilities.Result in @@ -200,7 +191,7 @@ class evaluator = method invoke program ~within = let open Utilities.Result in match - ( Protocols.Handle.into program (function Plan plan -> Some plan | _ -> None), + ( Protocols.Handle.into program (function Program plan -> Some plan_program | _ -> None), Kernel.EphemeralRelation.stored program ) with | Some plan, _ -> Protocols.Handle.invoke plan execute 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 diff --git a/lib/protocols/Evaluator.ml b/lib/protocols/Evaluator.ml index 9f4f5c6..6a63431 100644 --- a/lib/protocols/Evaluator.ml +++ b/lib/protocols/Evaluator.ml @@ -1,5 +1,10 @@ +type kind = .. + class type implementation = object - method invoke : Handle.t -> within:Handle.t -> (Handle.t, Concepts.Condition.condition) result + method parse : string -> (kind, Concepts.Condition.condition) result + + method eval : + kind -> Handle.t list -> within:Handle.t -> (Handle.t, Concepts.Condition.condition) result end type Handle.protocol += Evaluator of implementation @@ -8,4 +13,5 @@ type t = implementation let make impl = Evaluator (impl :> implementation) let from handle = Handle.into handle (function Evaluator impl -> Some impl | _ -> None) let require = Handle.require from -let invoke i program ~within = Handle.invoke i (fun o -> o#invoke program ~within) +let parse i source = Handle.invoke i (fun o -> o#parse source) +let eval i kind inputs ~within = Handle.invoke i (fun o -> o#eval kind inputs ~within) diff --git a/lib/protocols/Evaluator.mli b/lib/protocols/Evaluator.mli index 04b3612..934c5e3 100644 --- a/lib/protocols/Evaluator.mli +++ b/lib/protocols/Evaluator.mli @@ -1,18 +1,21 @@ type t +type kind = .. -(** [within] is the directory the program's paths resolve against: the - branch state a stored program was read through, or whatever part of - the tree a caller hands over. *) class type implementation = object - method invoke : Handle.t -> within:Handle.t -> (Handle.t, Concepts.Condition.condition) result + method parse : string -> (kind, Concepts.Condition.condition) result + + method eval : + kind -> Handle.t list -> within:Handle.t -> (Handle.t, Concepts.Condition.condition) result end val make : #implementation -> Handle.protocol val from : Handle.t -> t Handle.interface option val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result +val parse : t Handle.interface -> string -> (kind, Concepts.Condition.condition) result -val invoke : +val eval : t Handle.interface -> - Handle.t -> + kind -> + Handle.t list -> within:Handle.t -> (Handle.t, Concepts.Condition.condition) result diff --git a/lib/protocols/Executable.ml b/lib/protocols/Executable.ml new file mode 100644 index 0000000..5dea52c --- /dev/null +++ b/lib/protocols/Executable.ml @@ -0,0 +1,12 @@ +class type implementation = object + method invoke : + Handle.t list -> within:Handle.t -> (Handle.t, Concepts.Condition.condition) result +end + +type Handle.protocol += Executable of implementation +type t = implementation + +let make impl = Executable (impl :> implementation) +let from handle = Handle.into handle (function Executable impl -> Some impl | _ -> None) +let require = Handle.require from +let invoke i inputs ~within = Handle.invoke i (fun o -> o#invoke inputs ~within) diff --git a/lib/protocols/Executable.mli b/lib/protocols/Executable.mli new file mode 100644 index 0000000..ccb63e1 --- /dev/null +++ b/lib/protocols/Executable.mli @@ -0,0 +1,19 @@ +type t + +(** [within] is the directory the program's paths resolve against: the + branch state a stored program was read through, or whatever part of + the tree a caller hands over. *) +class type implementation = object + method invoke : + Handle.t list -> within:Handle.t -> (Handle.t, Concepts.Condition.condition) result +end + +val make : #implementation -> Handle.protocol +val from : Handle.t -> t Handle.interface option +val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result + +val invoke : + t Handle.interface -> + Handle.t list -> + within:Handle.t -> + (Handle.t, Concepts.Condition.condition) result |