diff options
Diffstat (limited to 'lib/sublanguage_context.ml')
| -rw-r--r-- | lib/sublanguage_context.ml | 110 |
1 files changed, 49 insertions, 61 deletions
diff --git a/lib/sublanguage_context.ml b/lib/sublanguage_context.ml index 40aa543..df537a7 100644 --- a/lib/sublanguage_context.ml +++ b/lib/sublanguage_context.ml @@ -1,46 +1,40 @@ (** Execution context passed to every sublanguage. - - [write_handle] NT branch handle; sublanguages use it for mutations - (create_relation, link_tuple, etc). Read-only - sublanguages (DRL) ignore it. + - [write_handle] NT branch handle; sublanguages use it for mutations + (create_relation, link_tuple, etc). Read-only sublanguages (DRL) ignore + it. - - [branch] Structural view over the active branch — gives every - executor random-access to every multigroup bound to - the branch via [mg_of]. Schema lookups for an FQN - [{mg; name}] use [branch#mg_of mg |> Option.bind - (fun m -> m#get_relation name)]. + - [branch] Structural view over the active branch — gives every executor + random-access to every multigroup bound to the branch via [mg_of]. Schema + lookups for an FQN [{mg; name}] use + [branch#mg_of mg |> Option.bind (fun m -> m#get_relation name)]. - - [resolve] Builds an absolute RNT path for an FQN. Pass - [~branch:b] to address a relation on a different - live branch (cross-multigroup reads). + - [resolve] Builds an absolute RNT path for an FQN. Pass [~branch:b] to + address a relation on a different live branch (cross-multigroup reads). - - [switch_branch] Closes the current branch and opens the named one, - returning the delta describing the new branch's mg - set. Provided by the listener so VCL does not need - direct access to session state. *) + - [switch_branch] Closes the current branch and opens the named one, + returning the delta describing the new branch's mg set. Provided by the + listener so VCL does not need direct access to session state. *) -type branch_view = < - name : string; - tip : string; - mg_of : string -> Management.Multigroup.multigroup option; - multigroups : (string * Management.Multigroup.multigroup) list; - add_multigroup : name:string -> unit; - set_mg : name:string -> - Management.Multigroup.multigroup -> unit; - path : ?branch:string -> Qualified_name.t -> string; -> +type branch_view = + < name: string + ; tip: string + ; mg_of: string -> Management.Multigroup.multigroup option + ; multigroups: (string * Management.Multigroup.multigroup) list + ; add_multigroup: name:string -> unit + ; set_mg: name:string -> Management.Multigroup.multigroup -> unit + ; path: ?branch:string -> Qualified_name.t -> string > -type t = { - write_handle : Nt.branch_handle; - branch : branch_view; - resolve : ?branch:string -> Qualified_name.t -> string; - switch_branch : string -> - (Sublanguage_types.transition_delta, Condition.t) result; - session_hash : string; - (** RNT session hash owning this connection. Session-scoped ephemeral - relations (with DML [Define]) register under - /system/sessions/<session_hash>/ephemeral/<name>. *) -} +type t = + { write_handle: Nt.branch_handle; + branch: branch_view; + resolve: ?branch:string -> Qualified_name.t -> string; + switch_branch: string -> (Sublanguage_types.transition_delta, Condition.t) result; + session_hash: string + (** RNT session hash owning this connection. Session-scoped ephemeral + relations (with DML [Define]) register under + /system/sessions/<session_hash>/ephemeral/<name>. *) + } (** Absolute RNT path of a session-scoped ephemeral relation. An unqualified name in a DRL [Base] resolves here: named bindings shadow nothing since @@ -52,30 +46,24 @@ module Make (NT : Nt.S) = struct module Session = Session.Make (NT) module Branch = Branch.Make (NT) - let make_ctx - (session : Session.session) - (claims : string) - : t = + let make_ctx (session : Session.session) (claims : string) : t = let br = session#branch in - { - write_handle = br#branch_handle; - branch = (br :> branch_view); - resolve = br#path; - session_hash = session#id; - switch_branch = fun name -> - match br#close () with - | Error e -> Error e - | Ok () -> - begin match Branch.open_branch claims name with - | Error e -> - begin match Branch.open_branch claims "master" with - | Ok mbr -> session#set_branch mbr - | Error _ -> () - end; - Error e - | Ok new_br -> - session#set_branch new_br; - Ok new_br#multigroups - end - } + { write_handle= br#branch_handle; + branch= (br :> branch_view); + resolve= br#path; + session_hash= session#id; + switch_branch= + (fun name -> + match br#close () with + | Error e -> Error e + | Ok () -> + begin match Branch.open_branch claims name with + | Error e -> + begin match Branch.open_branch claims "master" with + | Ok mbr -> session#set_branch mbr + | Error _ -> () + end; + Error e + | Ok new_br -> session#set_branch new_br; Ok new_br#multigroups + end ) } end |