diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/disk.ml | 36 | ||||
| -rw-r--r-- | lib/planner.ml | 163 | ||||
| -rw-r--r-- | lib/relation.ml | 2 | ||||
| -rw-r--r-- | lib/server.ml | 2 |
4 files changed, 135 insertions, 68 deletions
diff --git a/lib/disk.ml b/lib/disk.ml index fbb6219..05f4d82 100644 --- a/lib/disk.ml +++ b/lib/disk.ml @@ -148,6 +148,7 @@ module Executor = struct | LInteger64 of int64 | LBoolean of bool | LRelation of int64*string + | LRelationNested of int64*string*((string*relational_literal) list) [@@deriving show, sexp, protocol ~driver:(module Xml_light)] type schema = (string * relational_type) list StringMap.t @@ -413,6 +414,7 @@ module Executor = struct end | Ok x -> x end + | LRelationNested _ -> Bytes.empty | LBoolean x -> Data_encoding.Binary.to_bytes_exn Data_encoding.bool x let read_location ~hash (locations: locations) (cast_type: relational_type): relational_literal = @@ -455,6 +457,7 @@ module Command = struct attributes: (string*Executor.relational_type) list } | NaturalJoin of {left_relation: string; right_relation: string} + | Nest of {relation_name: string} [@@deriving sexp, protocol ~driver:(module Xml_light)] let command_encoding = @@ -537,37 +540,4 @@ module Command = struct ComputedHash computed_hash_handle ) | Some _, None -> Error "Cannot write an entity without its referential." | None, _ -> Ok ((commit, locations), Nothing) - - let perform (commit : Executor.commit) (locations : Executor.locations) (command : t) = - match command with - | NaturalJoin {left_relation = _; right_relation = _} -> - Ok ((commit, locations), Nothing) - | SpecifyRelation {relation_name; attributes} -> - (* If it already exists under the relation name key, it will be replaced *) - Ok (({ commit with - schema = commit.schema - |> Executor.StringMap.add relation_name attributes}, locations), Nothing) - | SequentialRead { relation_name } -> - let relation_name = List.hd @@ String.split_on_char '/' relation_name in - let entities : (string * Executor.relational_type * string) list Executor.IntMap.t = - print_endline relation_name; - Executor.StringMap.find_opt relation_name commit.references - |> function - | Some entities -> entities - | None -> Executor.IntMap.empty - in - - let content: (int64 * (string*Executor.relational_literal) list) list = - Executor.IntMap.fold - (fun key elems acc -> - (key, - List.map - (fun (location, type', attribute_name) -> - (attribute_name, Executor.read_location ~hash:location locations type')) - elems) - :: acc) - entities [] - in - - Ok ((commit, locations), Read content) end diff --git a/lib/planner.ml b/lib/planner.ml index db48bca..c66e46b 100644 --- a/lib/planner.ml +++ b/lib/planner.ml @@ -8,7 +8,7 @@ end module Scan = struct open Disk - let execute (commit: Executor.commit) locations (entity : string) = + let execute (commit : Executor.commit) locations (entity : string) = (*Executor.read commit locations ~filename:("schema~" ^ entity) |> function | Some binary -> ( let relation = @@ -29,40 +29,51 @@ module Scan = struct | Error err -> failwith err) | None -> failwith "" *) - let entities : (string * Executor.relational_type * string) list Executor.IntMap.t = - Executor.StringMap.find_opt entity commit.references - |> function - | Some entities -> entities - | None -> Executor.IntMap.empty + let entities : + (string * Executor.relational_type * string) list Executor.IntMap.t = + Executor.StringMap.find_opt entity commit.references |> function + | Some entities -> entities + | None -> Executor.IntMap.empty in - let content: (int64 * (string*Executor.relational_literal) list) list = + let content : (int64 * (string * Executor.relational_literal) list) list = Executor.IntMap.fold (fun key elems acc -> - (key, - List.map - (fun (location, type', attribute_name) -> - (attribute_name, Executor.read_location ~hash:location locations type')) - elems) + ( key, + List.map + (fun (location, type', attribute_name) -> + ( attribute_name, + Executor.read_location ~hash:location locations type' )) + elems ) :: acc) entities [] - in content - + in + content end module Join = struct open Disk + module NestedLoop = struct let execute - (left: (int64 * (string*Executor.relational_literal) list) list) - (right: (int64 * (string*Executor.relational_literal) list) list) - (join_clause: ((int64 * (string*Executor.relational_literal) list) * - (int64 * (string*Executor.relational_literal) list)) -> bool) = + (left : (int64 * (string * Executor.relational_literal) list) list) + (right : (int64 * (string * Executor.relational_literal) list) list) + (join_clause : + (int64 * (string * Executor.relational_literal) list) + * (int64 * (string * Executor.relational_literal) list) -> + bool) = let result = ref [] in - List.iter (fun left_tuple -> List.iter (fun right_tuple -> if join_clause(left_tuple, right_tuple) - then result := (left_tuple,right_tuple)::(!result)) right) left; + List.iter + (fun left_tuple -> + List.iter + (fun right_tuple -> + if join_clause (left_tuple, right_tuple) then + result := (left_tuple, right_tuple) :: !result) + right) + left; !result end + (* open Disk let execute (left_attributes: bytes list) (right_attributes: bytes list) locations = (* Redundant operations that are already in the locations, but this is easier to implement now *) @@ -76,26 +87,112 @@ module Join = struct @@ List.find_opt (fun (_rindex, _rhash, references) -> List.exists ((=) lhash) references) references_locations_right) left_computed_hashes in List.map (fun (lindex, rindex, _, _) -> List.nth left_attributes lindex, List.nth right_attributes rindex) indexes *) open Disk + let natural commit locations left_relation right_relation = let left_scan = Scan.execute commit locations left_relation in let right_scan = Scan.execute commit locations right_relation in let common_attributes = - let left_attributes = commit.schema - |> Executor.StringMap.find left_relation in - let right_attributes = commit.schema - |> Executor.StringMap.find right_relation in - List.filter_map (fun left_attr -> if List.mem left_attr right_attributes - then Some (fst left_attr) - else None) left_attributes + let left_attributes = + commit.schema |> Executor.StringMap.find left_relation + in + let right_attributes = + commit.schema |> Executor.StringMap.find right_relation + in + List.filter_map + (fun left_attr -> + if List.mem left_attr right_attributes then Some (fst left_attr) + else None) + left_attributes in - let join_clause = fun ((_entity_id_1, left_tuple), (_entity_id_2,right_tuple)): bool -> + let join_clause = + fun ((_entity_id_1, left_tuple), (_entity_id_2, right_tuple)) : bool -> (* Check only the key name for now, not subtype, so literals must be equal for it to work *) - let left_tuple = Executor.StringMap.filter (fun key _ -> List.mem key common_attributes) - @@ Executor.StringMap.of_list left_tuple in - let right_tuple = Executor.StringMap.filter (fun key _ -> List.mem key common_attributes) - @@ Executor.StringMap.of_list right_tuple in + let left_tuple = + Executor.StringMap.filter (fun key _ -> List.mem key common_attributes) + @@ Executor.StringMap.of_list left_tuple + in + let right_tuple = + Executor.StringMap.filter (fun key _ -> List.mem key common_attributes) + @@ Executor.StringMap.of_list right_tuple + in left_tuple = right_tuple - in NestedLoop.execute left_scan right_scan join_clause + in + NestedLoop.execute left_scan right_scan join_clause + + let nest commit locations (relation: string) = + let parent_scan = Scan.execute commit locations relation in + let nested_attributes = + Executor.StringMap.find relation commit.schema + |> List.filter (fun (_, (elem : Executor.relational_type)) -> + match elem with Executor.Relation _ -> true | _ -> false) + in + let nested_scans = + List.concat_map + (fun (nested_relation_attr, _) -> + Scan.execute commit locations nested_relation_attr) + nested_attributes + in + List.map + (fun (entity_id, x) -> + ( entity_id, + List.map + (fun (name_attr, item) -> + match item with + | Executor.LRelation (nested_entity_id, nested_name_attr) -> + ( name_attr, + Executor.LRelationNested + ( nested_entity_id, + nested_name_attr, + List.find_map + (fun (iter_entity_id, iter_attrs) -> + if iter_entity_id = nested_entity_id then + Some iter_attrs + else None) + nested_scans + |> Option.to_list |> List.concat ) ) + | _ -> (name_attr, item)) + x )) + parent_scan end module Filter = struct end + +module Executor = struct + open Disk + open Disk.Executor + let perform (commit : Executor.commit) (locations : Executor.locations) (command : Command.t) = + match command with + | Nest {relation_name;} -> + let results = Join.nest commit locations relation_name in + Ok ((commit, locations), Command.Read results) + | NaturalJoin {left_relation = _; right_relation = _} -> + Ok ((commit, locations), Nothing) + | SpecifyRelation {relation_name; attributes} -> + (* If it already exists under the relation name key, it will be replaced *) + Ok (({ commit with + schema = commit.schema + |> Executor.StringMap.add relation_name attributes}, locations), Nothing) + | SequentialRead { relation_name } -> + let relation_name = List.hd @@ String.split_on_char '/' relation_name in + let entities : (string * Executor.relational_type * string) list Executor.IntMap.t = + print_endline relation_name; + Executor.StringMap.find_opt relation_name commit.references + |> function + | Some entities -> entities + | None -> Executor.IntMap.empty + in + + let content: (int64 * (string*Executor.relational_literal) list) list = + Executor.IntMap.fold + (fun key elems acc -> + (key, + List.map + (fun (location, type', attribute_name) -> + (attribute_name, Executor.read_location ~hash:location locations type')) + elems) + :: acc) + entities [] + in + + Ok ((commit, locations), Read content) +end diff --git a/lib/relation.ml b/lib/relation.ml index a7b86c1..b163d8a 100644 --- a/lib/relation.ml +++ b/lib/relation.ml @@ -354,7 +354,7 @@ let write_and_retrieve () = |> Command.transact commit locations in let+ _, (Command.Read content as response) = - Command.perform commit locations (SequentialRead { relation_name = "user" }) + Planner.Executor.perform commit locations (SequentialRead { relation_name = "user" }) in print_endline (Command.show_return response); (* Ok (commit, locations) *) diff --git a/lib/server.ml b/lib/server.ml index bc7dac2..d06f8e8 100644 --- a/lib/server.ml +++ b/lib/server.ml @@ -32,7 +32,7 @@ let client_read sock maxlen = (* let command = Protocol.command_of_xml_light_exn (Protocol_conv_xml.Xml_light.of_string x) in *) let Ok (commit, locations) = Relation.prepare () in let Ok (_, (Disk.Command.Read response)) = - Disk.Command.perform commit locations command + Planner.Executor.perform commit locations command in return @@ Sexplib.Sexp.to_string (Protocol.sexp_of_facts response) (* in return @@ Xml.to_string (Protocol.facts_to_xml_light response) *) (* match *) |