diff --git a/INSTALL.txt b/INSTALL.txt new file mode 100644 index 0000000..97c10a0 --- /dev/null +++ b/INSTALL.txt @@ -0,0 +1,7 @@ +How to Install + +1. Unzip database.zip + +2. cd to the correct file path + +3. Run "make run" in the terminal diff --git a/Makefile b/Makefile index 8e5879c..4ba1f97 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,26 @@ -test: +build: + dune build lib + +code: + -dune build + code . + ! dune build --watch + +run: build + OCAMLRUNPARAM=b dune exec bin/main.exe + +test: build OCAMLRUNPARAM=b dune exec test/main.exe bisect: bisect-clean -dune exec --instrument-with bisect_ppx --force test/main.exe - bisect-ppx-report html \ No newline at end of file + bisect-ppx-report html + +bisect-clean: + rm -rf _coverage bisect*.coverage + +doc: + dune build @doc + +opendoc: doc + @bash opendoc.sh \ No newline at end of file diff --git a/cs3110project.yaml b/cs3110project.yaml new file mode 100644 index 0000000..e881654 --- /dev/null +++ b/cs3110project.yaml @@ -0,0 +1,30 @@ +--- +# Members of your group. +group: + - name: Thomas McFarland + netid: tfm62 + - name: JT Klenke + netid: jtk96 + - name: Raj Patel + netid: rsp224 +# Your PM. +pm: + name: Shashaank Aiyer + netid: saa244 +# Set to false if you don't want your gallery entry to be public. +publish: false +# Pithy title +title: "Strongly-typed Relational Database" +# OK if this is a Cornell Github link, but public gallery viewers won't be able to see it. +git-repo: "https://github.com/tf-mac/CS3110-Final-Project" +# If you have no demo screencast, replace the url string with an empty string "" +demo-video-url: "" +# Write a short, attention-grabbing description of your project. +desc: > + Our project is a relational database. We structure information in a + hash table. We can define custom types with OCaml primitives, + assign them to values, display those types to the user, and provide + references to other entries. The user can find values that match + certain expressions. The user can access all the functionality + through a command line interface that allows interaction with the + database. diff --git a/data/responses.json b/data/responses.json index d216733..1547ff5 100644 --- a/data/responses.json +++ b/data/responses.json @@ -1,18 +1,35 @@ { "err_create_field_DNE": "That field does not exist in this type\n| ", "err_create_field_wrong_type": "That value does not match the type of the field\n| ", - "err_create_empty_name": "Please enter a non-empty name\n| ", "err_create_field_no_value": "Please input a variable and a value\n| ", - "err_create_field_already_entered": "", - "err_assign_empty": "", - "err_assign_no_id": "", + "err_create_field_already_entered": "This field has already been entered\n| ", + "err_assign_empty": "Please input a type name and id\n|> ", + "err_assign_no_id": "Please input an id for this instance\n|> ", "err_assign_DNE": "That type does not exist\n|> ", "err_defn_needs_type_name": "Please enter a type name for the definition\n|> ", "err_defn_needs_ID_name": "Please enter a name for the ID of this type\n|> ", "err_defn_already_exists": "\n Type already defined\n|> ", "err_defn_no_name": "Please enter a name for this field\n| ", "err_defn_invalid_type": "Not a recognized type\n| ", - "err_unknown_command": "", - "err_at_no_id": "", - "help_message": "\nTo define a custom dataframe, type the following,\nall valueNames must be unique:\ndef TypeName IdName\n type valueName\n ...\n type valueName\n\n\nTo assign values to the custom types:\nassign TypeName IdValue\n valueName = value\n ...\n valueName = value\n\nTo save to a file, use 'save '\n\n|> " + "err_unknown_command": "Unknown command. Type help for a list of commands\n|> ", + "err_at_empty": "Please enter what the type and id of which to get an instance\n|> ", + "err_at_no_id": "Please enter an id of the instance you which to get\n|> ", + "err_at_column_not_int": "Column number should be an int\n|> ", + "err_at_invalid_type": "No type of that name\n|> ", + "err_at_column_out_of_range": "Column out of range. Hint: Index starts at 0\n|> ", + "err_at_id_DNE": "That ID does not exist\n|> ", + "unbound_type": "\n|> ", + "unbound_val": "\n|> ", + "no_entry": "No entry\n|> ", + "err_find_missing_type": "Must specify type in find\n|> ", + "err_find_invalid_expr": "Invalid comparison expression\n|> ", + "err_find_invalid_comparison": "Invalid comparison, use <> = > < >= <=\n|> ", + "err_find_invalid_type": "Cannot find type of that name\n|> ", + "err_find_wrong_type": "Wrong type in find expression\n|> ", + "err_find_var_DNE": "A variable in the expression does not exist\n|> ", + "help_message": "\nTo define a custom dataframe, type the following,\nall valueNames must be unique:\ndef TypeName IdName\n type valueName\n ...\n type valueName\n\n\nTo assign values to the custom types:\nassign TypeName IdValue\n valueName = value\n ...\n valueName = value\n\nTo save to a file, use 'save '\n\nTo find a file, type 'find TypeName expr'\n'expr' must be of the form: 'variable compare value' separated by spaces.\nValid compare opperators include <> = > < <= and >=\nexpr can be chained using 'and'\n\n|> ", + "indent_end": "| <|\n|> ", + "indent": "| ", + "default": "|> ", + "welcome": "\n\nWelcome to the 3110 Database Command Line\nPlease describe the data you want to store.\nType 'quit' to quit, 'help' for help.\n\n" } \ No newline at end of file diff --git a/lib/cli.ml b/lib/cli.ml index 9ef5de3..00d0a83 100644 --- a/lib/cli.ml +++ b/lib/cli.ml @@ -20,49 +20,15 @@ module CLI = struct | BuildType of (string * string * entry list) exception ParseError + exception InvalidExpr + exception InvalidComparison let current_state = ref Default - - let response_names = - [ - "err_create_empty_name"; - "err_create_field_DNE"; - "err_create_field_wrong_type"; - "err_create_field_no_value"; - "err_create_field_already_entered"; - "err_assign_empty"; - "err_assign_no_id"; - "err_assign_DNE"; - "err_defn_needs_type_name"; - "err_defn_needs_ID_name"; - "err_defn_already_exists"; - "err_defn_no_name"; - "err_defn_invalid_type"; - "err_unknown_command"; - "err_at_no_id"; - "help_message"; - ] - - let get_json_item file entry = - file |> to_assoc |> List.assoc entry |> to_string - let file_name = "data/responses.json" - let rec build_response_assoc_list res_names res_assoc = + let get_response response = let file = Yojson.Basic.from_file file_name in - match res_names with - | [] -> res_assoc - | h :: t -> - (h, get_json_item file h) :: res_assoc |> build_response_assoc_list t - - let responses = build_response_assoc_list response_names [] - - let rec find_response key lst = - match lst with - | [] -> failwith "response not found" - | (k, v) :: t -> if k = key then v else find_response key t - - let get_response response = find_response response responses + file |> to_assoc |> List.assoc response |> to_string let reset () = current_state := Default; @@ -83,21 +49,21 @@ module CLI = struct | Some b -> Bool b | None -> raise ParseError) | Chars -> Char (if String.length v = 1 then v.[0] else raise ParseError) - | Ids -> raise ParseError + | Ids -> + Id + (match v |> String.split_on_char '@' |> List.map String.trim with + | [] | [ _ ] | _ :: _ :: _ :: _ -> raise ParseError + | [ hd; tl ] -> (hd, String tl)) let rec build_instance (name, table, vals) input = match input |> String.split_on_char '=' |> List.map String.trim |> List.filter (fun s -> s <> "") with - | [] | [ "" ] -> + | [] -> DB.add_named_entry name vals !db; current_state := Default; - "| <|\n|> " - | "" :: tl -> - current_state := BuildInstance (name, table, vals); - get_response "err_create_empty_name" - (* "Please enter a non-empty name\n| " *) + get_response "indent_end" (* "| <|\n|> " *) | [ n ] -> current_state := BuildInstance (name, table, vals); get_response "err_create_field_no_value" @@ -114,7 +80,7 @@ module CLI = struct match parse_value v t with | x -> current_state := BuildInstance (name, table, (n, x) :: vals); - "| " + get_response "indent" (* "| " *) | exception ParseError -> current_state := BuildInstance (name, table, vals); get_response "err_create_field_wrong_type" @@ -122,12 +88,17 @@ module CLI = struct )) | Some _ -> current_state := BuildInstance (name, table, vals); - "This field has already been entered\n| ") + get_response "err_create_field_already_entered" + (* "This field has already been entered\n| " *)) let process_assign input = match input |> List.map String.trim |> List.filter (fun s -> s <> "") with - | [] | [ "" ] -> "Please input a type name and id\n|> " - | [ name ] -> "Please input an id for this instance\n|> " + | [] -> + get_response "err_assign_empty" + (* "Please input a type name and id\n|> " *) + | [ name ] -> + get_response "err_assign_no_id" + (* "Please input an id for this instance\n|> " *) | name :: id :: tl -> ( match DB.get_table name !db with | Some t -> @@ -138,10 +109,10 @@ module CLI = struct [ ( (match Tbl.header t with | Type (n, _) :: tl -> n - | _ -> raise ParseError), + | _ -> failwith "impossible" [@coverage off]), String id ); ] ); - "| " + get_response "indent" | None -> get_response "err_assign_DNE") (* "That type does not exist\n|> " *) @@ -151,7 +122,7 @@ module CLI = struct | "float" -> Type (name, Floats) | "string" -> Type (name, Strings) | "bool" -> Type (name, Bools) - | "chars" -> Type (name, Chars) + | "char" -> Type (name, Chars) | "id" -> Type (name, Ids) | _ -> raise ParseError @@ -161,26 +132,26 @@ module CLI = struct |> List.map String.trim |> List.filter (fun s -> s <> "") with - | [] | [ "" ] -> + | [] -> db := DB.build_table !db (Type (id, Strings) :: types) name; current_state := Default; - "| <|\n|> " + get_response "indent_end" (* "| <|\n|> " *) | [ typ ] -> get_response "err_defn_no_name" (* "Please enter a name for this field\n| " *) | typ :: field_name :: tl -> ( match parse_type (typ, field_name) with | Type _ as t -> current_state := BuildType (name, id, types @ [ t ]); - "| " + get_response "indent" (* "| " *) | exception ParseError -> current_state := BuildType (name, id, types); get_response "err_defn_invalid_type" (* "Not a recognized type\n| " *) - | _ -> raise (Failure "Should be impossible")) + | _ -> raise (Failure "Should be impossible") [@coverage off]) let process_type input = match List.filter (fun s -> s <> "") input with - | [] | [ "" ] -> get_response "err_defn_needs_type_name" + | [] -> get_response "err_defn_needs_type_name" (* "Please enter a type name for the definition\n|> " *) | [ name ] -> get_response "err_defn_needs_ID_name" @@ -192,19 +163,119 @@ module CLI = struct (* "\n Type already defined\n|> " *) | None -> current_state := BuildType (name, id, []); - "| ") + get_response "indent" (* "| " *)) - let process_at = function - | [] | [ "" ] -> - "Please enter what the type and id of which to get an instance\n|> " - | [ name ] -> "Please enter an id of the instance you which to get\n|> " - | name :: id :: tl -> ( + let process_at input = + match input |> List.map String.trim |> List.filter (fun s -> s <> "") with + | [] -> + get_response "err_at_empty" + (* "Please enter what the type and id of which to get an instance\n|> " *) + | [ name ] -> + get_response "err_at_no_id" + (* "Please enter an id of the instance you which to get\n|> " *) + | [ name; id ] -> ( + match DB.get_table name !db with + | Some x -> ( + try + (x |> Tbl.header |> optionize |> build_row) + ^ "\n" + ^ (String id |> Tbl.at x |> build_row) + ^ "\n|> " + with Not_found -> get_response "err_at_id_DNE") + | None -> + get_response "err_at_invalid_type" (* "No type of that name" *)) + | name :: id :: col :: tl -> ( match DB.get_table name !db with - | Some x -> - (x |> Tbl.header |> optionize |> build_row) - ^ "\n" - ^ (String id |> Tbl.at x |> build_row) - | None -> "No type of that name") + | Some x -> ( + try + let row = Tbl.at x (String id) in + match int_of_string_opt col with + | None -> + get_response "err_at_column_not_int" + (* "Column number should be an int" *) + | Some i -> ( + match List.nth_opt row i with + | Some e -> ( + match e with + | None -> get_response "no_entry" + | Some e -> ( + match e with + | Id (name, row) -> + (entry_to_string e ^ "=" + ^ + match DB.get_reference e !db with + | exception Not_found -> + get_response "unbound_type" + | l, r -> ( + "\n" + ^ build_row (optionize l) + ^ + match r with + | None -> get_response "unbound_val" + | Some v -> build_row v)) + ^ "\n|> " + | _ -> entry_to_string e ^ "\n|> ")) + | None -> get_response "err_at_column_out_of_range") + with Not_found -> get_response "err_at_id_DNE") + | None -> get_response "err_at_invalid_type") + + let split_on_substring sub str = + let idxs = ref [ 0 ] in + let sub_len = String.length sub in + for i = 0 to String.length str - sub_len do + if String.sub str i sub_len = sub then + idxs := !idxs @ [ i; i + String.length sub ] + else () + done; + idxs := !idxs @ [ String.length str ]; + let rec create_lst idxs sub_len str = + match idxs with + | [] -> [] + | s :: e :: t -> String.sub str s (e - s) :: create_lst t sub_len str + | _ -> failwith "odd" [@coverage off] + in + create_lst !idxs sub_len str + + let parse_compare_exp str = + let str_lst = String.split_on_char ' ' str in + if List.length str_lst <> 3 then raise InvalidExpr + else + match str_lst with + | [ var; compare; value ] -> + ( var, + (match compare with + | "=" -> EQ + | "<>" -> NEQ + | ">" -> GT + | "<" -> LT + | "<=" -> LTE + | ">=" -> GTE + | _ -> raise InvalidComparison), + value ) + | _ -> failwith "should be impossible" [@coverage off] + + let process_find lst = + let cleaned_lst = + lst |> List.map String.trim |> List.filter (fun s -> s <> "") + in + if cleaned_lst = [] then get_response "err_find_missing_type" + else + match DB.get_table (List.hd cleaned_lst) !db with + | None -> get_response "err_find_invalid_type" + | Some type_table -> ( + try + cleaned_lst |> List.tl + |> List.fold_left (fun s1 s2 -> s1 ^ " " ^ s2) "" + |> split_on_substring "and" |> List.map String.trim + |> List.filter (fun s -> s <> "") + |> (fun lst -> if lst = [] then raise InvalidExpr else lst) + |> List.map parse_compare_exp + |> Tbl.process_constraints type_table + with + | InvalidExpr -> get_response "err_find_invalid_expr" + | InvalidComparison -> get_response "err_find_invalid_comparison" + | TypeMismatch -> get_response "err_find_wrong_type" + | Not_found -> get_response "err_find_var_DNE") (** [parse_input input] takes in new input and determines the relevant command*) let parse_input input = @@ -213,24 +284,30 @@ module CLI = struct | BuildType v -> build_type v input | Default -> ( match String.split_on_char ' ' input with - | "quit" :: tl -> exit 0 + | "quit" :: tl -> exit 0 [@coverage off] | "help" :: tl -> get_response "help_message" | "def" :: tl -> process_type tl | "assign" :: tl -> process_assign tl - | "print" :: tl -> DB.db_to_string !db ^ "\n|> " - | "at" :: tl -> process_at tl ^ "\n|> " - | _ -> "Unknown command. Type help for a list of commands\n|> ") + | "print" :: tl -> DB.db_to_string !db ^ "|> " + | "at" :: tl -> process_at tl + | "find" :: tl -> process_find tl + | _ -> + get_response "err_unknown_command" + (* "Unknown command. Type help for a list of commands\n|> " *)) end (** [main ()] prompts for the script to start, then starts it. *) let main () = - print_string - "\n\n\ - Welcome to the 3110 Database Command Line\n\ - Please describe the data you want to store.\n\ - Type 'quit' to quit, 'help' for help.\n\n"; + let file_name = "data/responses.json" in + let welcom_string = + let file = Yojson.Basic.from_file file_name in + file |> Yojson.Basic.Util.to_assoc |> List.assoc "welcome" + |> Yojson.Basic.Util.to_string + in + print_string welcom_string; print_string "|> "; while true do read_line () |> CLI.parse_input |> print_string done + [@@coverage off] diff --git a/lib/cli.mli b/lib/cli.mli index f58acae..fd8a538 100644 --- a/lib/cli.mli +++ b/lib/cli.mli @@ -1,22 +1,21 @@ -(*type input = Empty | Malformed | Valid of string list - - val user_defined_types : string list ref - val lst_to_string : string list -> string - val check_value_defn : string list -> input - val parse_value_defn : string -> input - val add_type : string -> unit - val print_state : string -> string - val read_value_defn : string -> string list list - val parse_constructor_defn : string list -> string list list - val read_make : string -> string -> string list - val read_input : string -> unit*) +(** This module handles the command line interface, it allows easy use of the backend infrastructure + for storing and retrieving new types and data.*) val main : unit -> unit +(** [main ()] parses the user's input from the terminal using + CliHandler and prints the resulting message to the terminal until the user quits *) module type CliHandler = sig val parse_input : string -> string + (**[parse_input input] takes the string [input] and uses the internal state to produce an output string, which is equivalent to what would be printed in a CLI. Modifies internal state accordingly*) + val get_response : string -> string + (**[get_response addr] reads the responses json, giving a response string for a response string + Raises [Not_found] if [addr] is an invalid response*) + val reset : unit -> unit + (**[reset] changes the internal state to have an empty database and default internal state + *) end module CLI : CliHandler diff --git a/lib/cli2.ml b/lib/cli2.ml deleted file mode 100644 index 225695d..0000000 --- a/lib/cli2.ml +++ /dev/null @@ -1,157 +0,0 @@ -open Utils -open Database -open Tables -module Tbl = Tables.HashTable -module DB = Database (Tbl) - -let db = ref DB.empty - -exception ParseError - -let parse_value v = function - | Strings -> String v - | Ints -> ( - match int_of_string_opt v with - | Some i -> Int i - | None -> raise ParseError) - | Floats -> ( - match float_of_string_opt v with - | Some f -> Float f - | None -> raise ParseError) - | Bools -> ( - match bool_of_string_opt v with - | Some b -> Bool b - | None -> raise ParseError) - | Chars -> Char (if String.length v = 1 then v.[0] else raise ParseError) - | Ids -> raise ParseError - -let rec build_instance (name, table, vals) = - print_string "| "; - let input = read_line () in - match input |> String.split_on_char '=' |> List.map String.trim with - | [] | [ "" ] -> - print_endline "| <|\n"; - DB.add_named_entry name vals !db - | "" :: tl -> - print_endline "Please enter a non-empty name"; - build_instance (name, table, vals) - | [ n ] -> - print_endline "Please input a value"; - build_instance (name, table, vals) - | n :: v :: tl -> ( - match List.assoc_opt n vals with - | None -> ( - match Tbl.exists table n with - | exception TypeMismatch -> - print_endline "That field does not exist in this type"; - build_instance (name, table, vals) - | t -> ( - match parse_value v t with - | x -> build_instance (name, table, (n, x) :: vals) - | exception ParseError -> - print_endline - "That value does not match the type of the field"; - build_instance (name, table, vals))) - | Some _ -> - print_endline "This field has already been entered"; - build_instance (name, table, vals)) - -let process_assign = function - | [] | [ "" ] -> print_endline "Please input a type name and id" - | [ name ] -> print_endline "Please input an id for this instance" - | name :: id :: tl -> ( - match DB.get_table name !db with - | Some t -> - build_instance - ( name, - t, - [ - ( (match Tbl.header t with - | Type (n, _) :: tl -> n - | _ -> raise ParseError), - String id ); - ] ) - | None -> print_endline "That type does not exist") - -let parse_type (typ, name) = - match typ with - | "int" -> Type (name, Ints) - | "float" -> Type (name, Floats) - | "string" -> Type (name, Strings) - | "bool" -> Type (name, Bools) - | "chars" -> Type (name, Chars) - | "id" -> Type (name, Ids) - | _ -> raise ParseError - -let rec build_type (name, id, types) () = - print_string "| "; - let input = read_line () in - match String.split_on_char ' ' input with - | [] | [ "" ] -> - print_endline "| <|\n"; - db := DB.build_table !db (Type (id, Strings) :: types) name - | [ typ ] -> print_endline "Please enter a name for this field\n " - | typ :: field_name :: tl -> ( - match parse_type (typ, field_name) with - | Type _ as t -> build_type (name, id, types @ [ t ]) () - | exception ParseError -> - print_endline "Not a recognized type"; - build_type (name, id, types) () - | _ -> raise (Failure "Should be impossible")) - -let process_type = function - | [] | [ "" ] -> print_endline "Please enter a type name for the definition" - | [ name ] -> print_endline "Please enter a name for the ID of this type" - | name :: id :: tl -> ( - match DB.get_table name !db with - | Some _ -> print_endline ("| <|\n Type " ^ name ^ " already defined") - | None -> build_type (name, id, []) ()) - -let process_at = function - | [] | [ "" ] -> - print_endline "Please enter what type you which to get an instance of" - | [ name ] -> - print_endline "Please enter an id of the instance you which to get" - | name :: id :: tl -> ( - match DB.get_table name !db with - | Some x -> - print_endline (build_row (optionize (Tbl.header x))); - print_endline (build_row (Tbl.at x (String id))) - | None -> print_endline ("No type named " ^ name)) - -(** [parse_input input] takes in new input and determines the relevant command*) -let rec parse_input input = - (match String.split_on_char ' ' input with - | "quit" :: tl -> exit 0 - | "help" :: tl -> - print_endline - "\n\ - To define a custom dataframe, type all valueNames must be unique:\n\ - def TypeName IdName\n\ - \ type valueName\n\ - \ ...\n\ - \ type valueName\n\n\n\ - To assign values to the custom types:\n\ - assign TypeName IdValue\n\ - \ valueName = value\n\ - \ ...\n\ - \ valueName = value\n\n\ - To save to a file, use 'save '\n" - | "def" :: tl -> process_type tl - | "assign" :: tl -> process_assign tl - | "print" :: tl -> print_endline (DB.db_to_string !db) - | "at" :: tl -> process_at tl - | _ -> print_endline "Unknown command. Type help for a list of commands"); - print_string "|> "; - read_line () |> parse_input - -(** [main ()] prompts for the script to start, then starts it. *) - -let main () = - print_string - "\n\n\ - Welcome to the 3110 Database Command Line\n\ - Please describe the data you want to store.\n\ - Type 'quit' to quit, 'help' for help.\n\n"; - print_string "|> "; - read_line () |> parse_input diff --git a/lib/cli2.mli b/lib/cli2.mli deleted file mode 100644 index 86f37aa..0000000 --- a/lib/cli2.mli +++ /dev/null @@ -1 +0,0 @@ -val main : unit -> unit diff --git a/lib/database.ml b/lib/database.ml index bcdadab..08fd305 100644 --- a/lib/database.ml +++ b/lib/database.ml @@ -3,7 +3,6 @@ open Tables module Database (Table : Table) = struct exception NoEntry - exception WrongType exception TableExists type table = Table.t @@ -31,8 +30,18 @@ module Database (Table : Table) = struct let get_table name database = match List.assoc_opt name database with Some x -> Some !x | None -> None - (*Currently doesn't work...*) - let get_reference ent database = raise (Failure "Unimplemented") + let get_reference ent database = + match ent with + | Id (tbl, id) -> ( + let tbl = + match get_table tbl database with + | None -> raise Not_found + | Some v -> v + in + ( Table.header tbl, + match Table.at tbl id with exception Not_found -> None | v -> Some v + )) + | _ -> raise TypeMismatch let rec db_to_string database = match database with diff --git a/lib/database.mli b/lib/database.mli index 7a29948..83a8689 100644 --- a/lib/database.mli +++ b/lib/database.mli @@ -1,23 +1,53 @@ +(** This module handles the complete backend for data storage. It is able to handle multiple types + and build tables accordingly, data can be accessed and added to any type in various ways*) + open Utils open Tables module Database (Table : Table) : sig exception NoEntry - exception WrongType + (** Raised when an entry that does not exist is parsed. *) + exception TableExists + (** Raised when a table is attempted to be added which already exists*) type table = Table.t + (** Internal table of the database*) + type database + (** Internal database representation*) val empty : database + (** [empty] is a table containing no elements*) + val add_table : database -> table -> string -> database + (** [add_table database table name] adds table to [database] + Raises: [IndexExists] when the value associated with [name] exists + *) + val build_table : database -> entry list -> string -> database + (** [build_table database lst name] builds a new table inside [database] using [lst] as a header + Raises [IndexExists] if the name is already in use*) + val drop_table : string -> database -> database + (** [drop_table name database] returns a database with the table [name] removed*) + val get_table : string -> database -> table option - val get_reference : entry -> database -> string * table + (** [get_table name database] returns table option containing table [name], if it exists in [database]*) + + val get_reference : entry -> database -> entry list * entry option list option + (** [get_reference id database] returns a tuple containing the header of the table [id] refers to and the row in the table it describes, if that row exists + Raises [Not_found] if the table referenced doesn't exist + Raises [TypeMismatch] if id is not an entry Id*) + val db_to_string : database -> string + (** [db_to_string database] returns a string representation of database*) - (* Adds an entry to the table given by id. Raises [Not_found] if the table cannot be found*) val add_entry : string -> entry list -> database -> unit + (** [add_entry s lst db] Adds an entry to the table given by id. Raises [Not_found] if the table cannot be found*) + val add_named_entry : string -> (string * entry) list -> database -> unit + (** [add_named_entry table lst database] adds the lst to the table specified, where the list is tuples containing the name of the field wishing to be filled and the entry to fill it with + Raises [Not_found] if the table does not exist + Raises [TypeMismatch] if any of the entries do not match the type of their fields*) end diff --git a/lib/dune b/lib/dune index e6ef250..c56ae5c 100644 --- a/lib/dune +++ b/lib/dune @@ -1,3 +1,6 @@ (library (name RelationalDatabase) - (libraries yojson)) + (libraries yojson) + (public_name Database) + (instrumentation + (backend bisect_ppx))) diff --git a/lib/tables.ml b/lib/tables.ml index 6b6c1e8..9885e11 100644 --- a/lib/tables.ml +++ b/lib/tables.ml @@ -1,11 +1,8 @@ open Utils -exception IndexExists -exception TypeMismatch - let rec assert_types header a = match header with - | [] -> if a = [] then [] else raise TypeMismatch + | [] -> if a = [] then [] else raise TypeMismatch [@coverage off] | hd :: tl -> ( match a with | [] -> raise TypeMismatch @@ -59,6 +56,12 @@ let rec reorder_list (a : (string * entry) list) = function vl :: reorder_list rest tl | _ -> raise TypeMismatch +let rec get_type_index cnt name = function + | [] -> raise Not_found + | Type (n, _) :: tl -> + if n = name then cnt else get_type_index (cnt + 1) name tl + | _ -> raise TypeMismatch + module type Table = sig type t @@ -68,92 +71,26 @@ module type Table = sig val at : t -> entry -> entry option list val delete : t -> entry -> t val table_to_string : t -> string + val process_constraints : t -> (string * comparison * string) list -> string val header : t -> entry list val exists : t -> string -> types end -module ListTable : Table = struct - type t = entry option list list - - let rec optionize = function [] -> [] | hd :: tl -> Some hd :: optionize tl - let empty (ex : entry list) = [ optionize ex ] - - let insert (table : t) a = - match - List.find (fun b -> - match a with - | [] -> raise (Failure "Error") - | hd :: tl -> ( - match b with - | [] -> raise (Failure "Error") - | hdb :: tlb -> hd = hdb)) - with - | exception Not_found -> - table @ [ assert_types (List.hd table) (optionize a) ] - | x -> raise IndexExists - - let insert_named table elist = - let name, value = List.hd elist in - match List.find (fun a -> List.hd a = Some value) table with - | x -> raise IndexExists - | exception Not_found -> table @ [ reorder_list elist (List.hd table) ] - - let at (table : t) id = - List.find - (fun a -> - match a with - | [] -> raise (Failure "This shouldn't happen") - | hd :: tl -> ( match hd with Some x -> x = id | None -> false)) - table - - let delete (table : t) id = - List.filter - (fun a -> - match a with - | [] -> false - | a :: asd -> ( match a with Some x -> x = id | None -> false)) - table - - let rec table_to_string (table : t) = - match table with - | [] -> "" - | b :: xs -> build_row b ^ table_to_string xs ^ "\n" - - let rec deoptionize = function - | [] -> [] - | hd :: tl -> - (match hd with - | Some x -> x - | None -> raise (Failure "Deoptionize saw None")) - :: deoptionize tl - - let header = function - | [] -> raise (Failure "RI Violated for tables") - | hd :: tl -> deoptionize hd - - let exists table name = - let rec follow_header = function - | [] -> raise TypeMismatch - | Type (n, t) :: tl when n = name -> t - | _ :: tl -> follow_header tl - in - follow_header (header table) -end - module HashTable = struct type t = HashTab of entry list * (entry, entry option list) Hashtbl.t let rec deoptionize_list = function | [] -> [] | Some x :: tl -> x :: deoptionize_list tl - | None :: tl -> failwith "Deoptionize on None" + | None :: tl -> raise (Failure "Deoptionize on none") + [@@coverage off] let header = function HashTab (hd, _) -> hd let hshtable = function HashTab (_, hsh) -> hsh let deoptionize = function | Some x -> x - | None -> raise (Failure "Deoptionize on none") + | None -> raise (Failure "Deoptionize on none") [@coverage off] let rec optionize = function [] -> [] | hd :: tl -> Some hd :: optionize tl let empty (ex : entry list) = HashTab (ex, Hashtbl.create 0) @@ -177,7 +114,11 @@ module HashTable = struct | Some x -> raise IndexExists | None -> let copy = Hashtbl.copy (hshtable table) in - let reordered = reorder_list entries (optionize (header table)) in + let reordered = + assert_types + (header table |> optionize) + (reorder_list entries (optionize (header table))) + in Hashtbl.add copy (deoptionize (List.hd reordered)) (List.tl reordered); HashTab (header table, copy) @@ -194,6 +135,39 @@ module HashTable = struct (hshtable table) (build_row (optionize (header table))) + let rec process_constraints tbl lst = + let newHash = Hashtbl.create 0 in + match lst with + | [] -> table_to_string tbl + | hd :: tl -> + process_constraints + (match hd with + | name, cmp, vl -> + let ind = get_type_index 0 name (header tbl) in + let cmp_func = + match + List.find + (function + | Type (n, t) -> n = name | _ -> failwith "Impossible") + (header tbl) + with + | Type (n, t) -> ( + match process_entry vl t with e -> run_constraint cmp e) + | _ -> raise (Failure "Impossible") + in + Hashtbl.iter + (fun a b -> + if ind = 0 then + if cmp_func a then Hashtbl.add newHash a b else () + else + match List.nth b (ind - 1) with + | None -> () + | Some v -> + if cmp_func v then Hashtbl.add newHash a b else ()) + (hshtable tbl); + HashTab (header tbl, newHash)) + tl + let exists table name = let rec follow_header = function | [] -> raise TypeMismatch diff --git a/lib/tables.mli b/lib/tables.mli index fd5c359..3d20098 100644 --- a/lib/tables.mli +++ b/lib/tables.mli @@ -1,33 +1,44 @@ -open Utils +(** This module handles the backend implementation for storing data. It holds information in a table + that can be accesess and modified in various ways.*) -exception IndexExists -exception TypeMismatch +open Utils module type Table = sig type t + (** Type representation of the table*) - (* Creates a new table given a list of type definitions. Raises [TypeMismatch] if the list provided is not types*) val empty : entry list -> t + (** [empty lst] Creates a new table given a list of type definitions. Raises [TypeMismatch] if the list provided is not types**) - (* Adds a new set of entries to the table. Precondition: Entry list has at least one element + val insert : t -> entry list -> t + (** Adds a new set of entries to the table. Precondition: Entry list has at least one element Raises [IndexExists] if the index provided is already in the table. Raises [TypeMismatch] if the new row fits the type definition*) - val insert : t -> entry list -> t - (* Adds a new set of entries to the table, in the columns that the ids identify. Any non-entered rows will be a none + val insert_named : t -> (string * entry) list -> t + (** Adds a new set of entries to the table, in the columns that the ids identify. Any non-entered rows will be a none Raises [IndexExists] if the index provided is already in the table. Raises [TypeMismatch] if the new row fits the type definition*) - val insert_named : t -> (string * entry) list -> t + val at : t -> entry -> entry option list + (** [at t id] returns a list of entry options representing all entries [id] in the [t]*) + val delete : t -> entry -> t + (** [delete t id] removes the entire row in [t] containing [id]. It returns the updated table.*) + val table_to_string : t -> string + (** [table_to_string t] returns a string representation of [t]*) + + val process_constraints : t -> (string * comparison * string) list -> string + (** Processes a given list of constraints + Raises [Not_found] if a constraint isn't found + Raises [TypeMismatch] if the comparison value doesn't match the header*) - (* Returns the header of the table*) val header : t -> entry list + (** Returns the header of the table*) - (* Returns the type of the named column, if it exists. If not, raises [TypeMismatch]*) val exists : t -> string -> types + (** Returns the type of the named column, if it exists. If not, raises [TypeMismatch]*) end -module ListTable : Table module HashTable : Table diff --git a/lib/utils.ml b/lib/utils.ml index 3fc252a..8610a05 100644 --- a/lib/utils.ml +++ b/lib/utils.ml @@ -1,4 +1,8 @@ type types = Strings | Floats | Ints | Chars | Bools | Ids +type comparison = LT | LTE | EQ | NEQ | GT | GTE + +exception IndexExists +exception TypeMismatch type entry = | String of string @@ -9,16 +13,6 @@ type entry = | Id of (string * entry) | Type of (string * types) -let name_map_entry t = - match t with - | String _ -> "string" - | Float _ -> "float" - | Int _ -> "int" - | Char _ -> "char" - | Bool _ -> "bool" - | Id _ -> "id" - | Type _ -> "type" - let name_map_types t = match t with | Strings -> "string" @@ -28,6 +22,57 @@ let name_map_types t = | Bools -> "bool" | Ids -> "id" +let process_entry input = function + | Strings -> String input + | Floats -> ( + match float_of_string_opt input with + | None -> raise TypeMismatch + | Some v -> Float v) + | Ints -> ( + match int_of_string_opt input with + | None -> raise TypeMismatch + | Some v -> Int v) + | Chars -> + if String.length input = 1 then Char input.[0] else raise TypeMismatch + | Bools -> ( + match bool_of_string_opt input with + | None -> raise TypeMismatch + | Some v -> Bool v) + | _ -> raise TypeMismatch + +let make_compare cmp lhs rhs = + match cmp with + | LT -> lhs < rhs + | LTE -> lhs <= rhs + | EQ -> lhs = rhs + | NEQ -> lhs <> rhs + | GT -> lhs > rhs + | GTE -> lhs >= rhs + +let run_constraint (cmp : comparison) rhs lhs = + match rhs with + | Float r -> ( + match lhs with + | Float l -> make_compare cmp l r + | _ -> failwith "Typing error") + | Int r -> ( + match lhs with + | Int l -> make_compare cmp l r + | _ -> failwith "Typing error") + | Char r -> ( + match lhs with + | Char l -> make_compare cmp l r + | _ -> failwith "Typing error") + | Bool r -> ( + match lhs with + | Bool l -> make_compare cmp l r + | _ -> failwith "Typing error") + | String r -> ( + match lhs with + | String l -> make_compare cmp l r + | _ -> failwith "Typing error") + | _ -> raise TypeMismatch + let rec entry_to_string ent = match ent with | String x -> x diff --git a/lib/utils.mli b/lib/utils.mli index fa2efe7..7fef660 100644 --- a/lib/utils.mli +++ b/lib/utils.mli @@ -1,5 +1,18 @@ +(** This module holds utilities (both functions and types) that many other modules need.*) + +(** Representation of the type of some field*) type types = Strings | Floats | Ints | Chars | Bools | Ids +(** Representation of some comparison operation*) +type comparison = LT | LTE | EQ | NEQ | GT | GTE + +exception IndexExists +(** [IndexExists] occurs when trying to replace an index which already exists*) + +exception TypeMismatch +(** [TypeMismatch] occurs when some typing error occurs, e.g. true > "cat"*) + +(** The core of this project! The type holding every entry in every table*) type entry = | String of string | Float of float @@ -9,9 +22,25 @@ type entry = | Id of (string * entry) | Type of (string * types) -val name_map_entry : entry -> string +val process_entry : string -> types -> entry +(** Turns a string into the given entry type. + Raises [TypeMismatch] if this cannot occur*) + +val run_constraint : comparison -> entry -> entry -> bool +(**[run_constraint cmp rhs lhs] returns a bool equal to lhs (cmp) rhs + Raises [TypeMismatch] if type of lhs != rhs*) + val name_map_types : types -> string +(** [name_map_types t] maps each [t] to a string.*) + val entry_to_string : entry -> string +(**[entry_to_string entry] converts [entry] into a string*) + val shorten : string -> string +(** [shorten inp] shortens [inp] to a maximum of 16 characters*) + val build_row : entry option list -> string +(** [build_row entlist] converts [entlist] into a string, using shorten to limit the length of each entry.*) + val optionize : entry list -> entry option list +(** [optionize] wraps them in Some constructors*) diff --git a/test/main.ml b/test/main.ml index 6fdc04c..6c18d21 100644 --- a/test/main.ml +++ b/test/main.ml @@ -1,6 +1,407 @@ +(* We tested our code primarily using OUnit with some manual testing + of the command line interface to ensure they were equivalently implemented. + All modules were tested in some form by OUnit, the Table module was tested + directly and the Utils module was tested indirectly by testing the modules + that used Util. + + The CLI and Database modules were tested with OUnit with at least 95% test + coverage using glass box testing (according to bisect excluding defensive code). + + The Database and Table modules were also tested using black box testing to test + edge cases from the specification. Those specifications were also tested to make + sure that any error they were supposed to throw worked correctly. The CLI module + was tested with OUnit to make sure that the correct messages were returned + depending on the internal state of CLI and the input message. + + The only part of the code that was tested manually was the ‘quit’ statement in + CLI (because it would have quit the program if we tested it in OUnit) and the + ‘main’ function that took in inputs from the terminal and printed the responses. + We tested this manually to make sure that the terminal inputs and outputs + behaved the same as the OUnit to ensure the command line interface worked + correctly. + + This testing strategy demonstrated that the system is correct because we + achieved over 90% coverage over all of our modules and they acted correctly. + Additionally, our most important modules (that depended on others) were tested to + >95% coverage which gives us additional confidence that the most important parts + of our system work correctly. + + This gives us a lot of confidence that the whole system is correct. + Additionally, we tested edge cases wherever possible which ensured that even + weird inputs worked according to specifications. Finally, the manual testing of + the command line interface ensured that the OUnit tests were correctly + transferred to an actual user using the program through the terminal. *) + open OUnit2 +open RelationalDatabase.Tables +open RelationalDatabase.Database +open RelationalDatabase.Utils open RelationalDatabase.Cli +let trim str = + str |> String.split_on_char '\t' |> List.map String.trim + |> List.filter (fun a -> a <> "") + |> List.fold_left (fun s1 s2 -> s1 ^ " " ^ s2) "" + |> String.trim + +module TableTests (T : Table) = struct + (*Table Tests*) + + let make_test name act exp = name >:: fun _ -> assert_equal exp act + + let person = + T.empty + [ + Type ("name", Strings); + Type ("loc", Strings); + Type ("age", Ints); + Type ("net", Floats); + Type ("alive", Bools); + Type ("char", Chars); + Type ("ids", Ids); + ] + + let test_empty_table name ex expected = + name >:: fun _ -> assert_equal expected (T.empty ex) + + let test_insert name table elist expected = + name >:: fun _ -> + assert_equal expected (T.insert table elist) ~printer:T.table_to_string + + let test_insert_exception name table elist expected = + name >:: fun _ -> assert_raises expected (fun () -> T.insert table elist) + + let test_insert_named name table elist expected = + name >:: fun _ -> assert_equal expected (T.insert_named table elist) + + let test_insert_named_exception name table elist expected = + name >:: fun _ -> + assert_raises expected (fun () -> T.insert_named table elist) + + let test_at name table id expected = + name >:: fun _ -> assert_equal expected (T.at table id) + + let test_at_exception name table id expected = + name >:: fun _ -> assert_raises expected (fun () -> T.at table id) + + let test_delete name table id expected = + name >:: fun _ -> assert_equal expected (T.delete table id) + + let test_table_to_string name table expected = + name >:: fun _ -> assert_equal expected (T.table_to_string table |> trim) + + let test_exists_exception name table table_name expected = + name >:: fun _ -> + assert_raises expected (fun () -> T.exists table table_name) + + let test_exists name table table_name expected = + name >:: fun _ -> assert_equal expected (T.exists table table_name) + + let empty_table = T.empty [] + let table = T.empty [ Type ("name", Strings); Type ("age", Ints) ] + + let large_table = + T.empty + [ + Type ("String", Strings); + Type ("Floats", Floats); + Type ("Ints", Ints); + Type ("Bools", Bools); + Type ("Chars", Chars); + Type ("Ids", Ids); + ] + + let insert = + T.insert large_table + [ + String "John"; + Float 2.5; + Int 9; + Bool true; + Char 'a'; + Id ("Person", String "Johnathan"); + ] + + let elist = [ ("name", String "John") ] + let elist2 = [ ("age", Int 25) ] + let elist_exception = [ ("", String "s") ] + let elist_exception2 = [ ("name", String "John") ] + let elist_for_at = [ Some (String "John") ] + let insert_named = T.insert_named table elist + let partial_table = T.empty [ Type ("name", Strings) ] + let partial_insert = T.insert_named partial_table elist + + let table_tests = + [ + test_empty_table "empty table test" [] empty_table; + test_insert_named "add entry on existing table" table elist insert_named; + test_insert_named_exception "TypeMismatch thrown on insert_named" table + elist_exception TypeMismatch; + test_insert_named_exception "IndexExists thrown on insert_named" + insert_named elist_exception2 IndexExists; + test_insert "testing insert" large_table + [ + String "John"; + Float 2.5; + Int 9; + Bool true; + Char 'a'; + Id ("Person", String "Johnathan"); + ] + insert; + test_insert_exception "IndexExists thrown on insert" insert_named + [ String "John" ] IndexExists; + test_at "testing at for simple table" partial_insert (String "John") + elist_for_at; + test_at_exception "testing invalid string for at" insert_named + (String "invalid") Not_found; + test_at_exception "testing invalid type for at" insert_named (Int 25) + Not_found; + test_at_exception "testing at for an empty table" empty_table + (String "name") Not_found; + test_delete "testing invalid delete" partial_table (String "invalid") + partial_table; + test_delete "testing empty delete" empty_table (String "invalid") + empty_table; + test_exists "testing exists on existing table" table "name" Strings; + test_exists_exception "testing invalid exists on table" table "i" + TypeMismatch; + test_table_to_string "testing empty table to string" empty_table ""; + test_table_to_string "testing table to string" table "string name int age"; + make_test "No Strings insert" + (List.nth + ((T.insert_named person + [ + ("name", String "joe"); + ("age", Int 5); + ("net", Float 5.); + ("alive", Bool true); + ] + |> T.at) + (String "joe")) + 1) + None; + make_test "No Int insert" + (List.nth + ((T.insert_named person + [ + ("name", String "joe"); + ("loc", String "DC"); + ("net", Float 5.); + ("alive", Bool true); + ] + |> T.at) + (String "joe")) + 2) + None; + make_test "No Floats insert" + (List.nth + ((T.insert_named person + [ + ("name", String "joe"); + ("loc", String "DC"); + ("age", Int 5); + ("alive", Bool true); + ] + |> T.at) + (String "joe")) + 3) + None; + make_test "No Bools insert" + (List.nth + ((T.insert_named person + [ + ("name", String "joe"); + ("loc", String "DC"); + ("age", Int 5); + ("net", Float 5.); + ] + |> T.at) + (String "joe")) + 4) + None; + make_test "No chars insert" + (List.nth + ((T.insert_named person + [ + ("name", String "joe"); + ("loc", String "DC"); + ("age", Int 5); + ("net", Float 5.); + ] + |> T.at) + (String "joe")) + 5) + None; + make_test "No ids insert" + (List.nth + ((T.insert_named person + [ + ("name", String "joe"); + ("loc", String "DC"); + ("age", Int 5); + ("net", Float 5.); + ] + |> T.at) + (String "joe")) + 6) + None; + ] +end + +module HashTableTests = TableTests (HashTable) + +module DatabaseTests (T : Table) = struct + module PersonDB = Database (T) + + let test_empty_database name expected = + name >:: fun _ -> assert_equal expected PersonDB.empty + + let test_add_table fun_name database table name expected = + fun_name >:: fun _ -> + assert_equal (PersonDB.add_table database table name) expected + + let test_add_table_exception fun_name database table name expected = + fun_name >:: fun _ -> + assert_raises expected (fun () -> PersonDB.add_table database table name) + + let test_build_table fun_name database table name expected = + fun_name >:: fun _ -> + assert_equal (PersonDB.build_table database table name) expected + + let test_build_table_exception fun_name database table name expected = + fun_name >:: fun _ -> + assert_raises expected (fun () -> PersonDB.build_table database table name) + + let test_drop_table fun_name name database expected = + fun_name >:: fun _ -> + assert_equal (PersonDB.drop_table name database) expected + + let test_get_table fun_name name database expected = + fun_name >:: fun _ -> + assert_equal (PersonDB.get_table name database) expected + + let test_get_reference fun_name ent database expected = + fun_name >:: fun _ -> + assert_equal (PersonDB.get_reference ent database) expected + + let test_add_entry fun_name table_name new_row database expected = + fun_name >:: fun _ -> + assert_equal (PersonDB.add_entry table_name new_row database) expected + + let test_add_entry_exception fun_name table_name new_row database expected = + fun_name >:: fun _ -> + assert_raises expected (fun () -> + PersonDB.add_entry table_name new_row database) + + let test_get_reference_exception fun_name ent database expected = + fun_name >:: fun _ -> + assert_raises expected (fun () -> PersonDB.get_reference ent database) + + let test_add_named_entry fun_name table_name new_row database expected = + fun_name >:: fun _ -> + assert_equal (PersonDB.add_named_entry table_name new_row database) expected + + let test_add_named_entry_exception fun_name table_name new_row database + expected = + fun_name >:: fun _ -> + assert_raises expected (fun () -> + PersonDB.add_named_entry table_name new_row database) + + let test_database_to_string fun_name database expected = + fun_name >:: fun _ -> + assert_equal (PersonDB.db_to_string database |> trim) expected + + let database_person_ent_list = [ Type ("name", Strings); Type ("age", Ints) ] + + let database_airport_ent_list = + [ + Type ("location", Strings); + Type ("passengers", Strings); + Type ("delayed", Bools); + ] + + let t = T.empty [ Type ("name", Strings) ] + let new_table = T.empty [ Type ("name", Strings); Type ("age", Ints) ] + let elist = [ ("name", String "John"); ("age", Int 25) ] + let add_table = T.insert_named new_table elist + let reference = ([ String "name" ], Some [ Some (String "Person") ]) + + let table2 = + T.empty + [ + Type ("location", Strings); + Type ("passengers", Strings); + Type ("delayed", Bools); + ] + + let empty = PersonDB.empty + let add_table_database = PersonDB.add_table empty add_table "Person" + let person_database = PersonDB.add_table empty new_table "Person" + let airport_database = PersonDB.add_table empty table2 "Airport" + let large_database = PersonDB.add_table person_database table2 "Airport" + let small_database = PersonDB.add_table empty t "" + + let database_tests = + [ + test_empty_database "empty test" empty; + test_add_table "Testing add_table" empty new_table "Person" + person_database; + test_add_table "Testing add_table to non-empty database" person_database + table2 "Airport" large_database; + test_add_table_exception + "Raising failure by adding existing table to database" person_database + new_table "Person" PersonDB.TableExists; + test_drop_table "Testing drop_table" "Person" person_database empty; + test_drop_table "Testing drop_table on empty table" "Person" empty empty; + test_drop_table "Testing drop_table with invalid table" "Invalid" + person_database person_database; + test_drop_table "Testing drop_table on multi-table database" "Person" + large_database airport_database; + test_get_table "Testing Valid get_table" "Person" person_database + (Some new_table); + test_get_table "Testing Empty table for get_table" "Person" empty None; + test_get_table "Testing Invalid table for get_table" "Airport" + person_database None; + test_get_table "Testing Valid get_table in multitable database" "Airport" + large_database (Some table2); + test_build_table "Testing Valid build_table on empty database" empty + database_person_ent_list "Person" person_database; + test_build_table "Testing Valid build_table on existing database" + person_database database_airport_ent_list "Airport" large_database; + test_build_table_exception "Testing IndexExists exception on build_table" + person_database database_person_ent_list "Person" PersonDB.TableExists; + test_add_named_entry "Testing add_named_entry" "Person" + [ ("name", String "location") ] + person_database (); + test_add_named_entry_exception "Testing Not_found in add_named_entry" + "Invalid" + [ ("name", String "location") ] + person_database Not_found; + test_database_to_string "Testing to string on empty database" empty ""; + test_database_to_string "Testing db_to_string" small_database + "Table: \n\nstring name"; + test_get_reference "Test Get reference" + (Id ("Person", String "John")) + add_table_database + ( [ Type ("name", Strings); Type ("age", Ints) ], + Some [ Some (String "John"); Some (Int 25) ] ); + test_get_reference_exception "Testing Not Found for get reference" + (Id ("Invalid", String "John")) + add_table_database Not_found; + test_get_reference "Testing Type Mismatch for get reference" + (Id ("Person", String "Invalid")) + add_table_database + ([ Type ("name", Strings); Type ("age", Ints) ], None); + test_add_entry "Testing add_entry" "Person" [ String "Amy"; Int 30 ] + person_database (); + test_add_entry_exception "Testing Not_found in add_entry" "invalid" + [ String "Amy"; Int 30 ] person_database Not_found; + ] +end + +module DatabaseHashTable = DatabaseTests (HashTable) + module type StringList = sig val input_list : string list ref end @@ -8,6 +409,12 @@ end let better_print s = "'" ^ String.escaped s ^ "'" let get_response = CLI.get_response +let handle_table_prints str = + str |> String.split_on_char '\t' |> List.map String.trim + |> List.filter (fun a -> a <> "") + |> List.fold_left (fun s1 s2 -> s1 ^ " " ^ s2) "" + |> String.trim + let rec add_input lst = match lst with | [] -> () @@ -20,7 +427,7 @@ let cli_test (name : string) (actual_output : string) (expected_output : string) name >:: fun _ -> assert_equal expected_output actual_output ~printer:better_print -let rec make_test primer tests = +let rec make_test primer tests is_print = match tests with | [] -> [] | (reset, name, input, expected) :: t -> @@ -29,9 +436,35 @@ let rec make_test primer tests = CLI.reset (); add_input primer) else (); - cli_test name (CLI.parse_input input) expected + if is_print then + cli_test name (CLI.parse_input input |> handle_table_prints) expected + else cli_test name (CLI.parse_input input) expected in - placeholder :: make_test primer t + placeholder :: make_test primer t is_print + +let fully_defined_generic = + [ + "def Type ID"; + "int i"; + "float f"; + "char c"; + "bool b"; + "string s"; + "id d"; + ""; + ] + +let fully_assigned_generic = + fully_defined_generic + @ [ + "assign Type ID1"; + "i = 10"; + "f = 3.14"; + "c = a"; + "b = true"; + "s = hello there"; + ""; + ] let def_tests = ( [], @@ -49,15 +482,93 @@ let def_tests = "wrong type error", "flat float", get_response "err_defn_invalid_type" ); - (false, "wrong type error", "float ", get_response "err_defn_no_name"); + ( false, + "no name error when blank spaces", + "string ", + get_response "err_defn_no_name" ); + ( false, + "cannot define the same type twice, end of defn", + " ", + get_response "indent_end" ); + ( false, + "cannot define the same type twice, defn", + "def Person Name", + get_response "err_defn_already_exists" ); + ] ) + +let malformed_assign_states = + ( [ + "def City Name"; + "int sq_footage"; + "float coordinates"; + "string nickname"; + ""; + ], + [ + ( true, + "assign with no extra terms", + "assign ", + get_response "err_assign_empty" ); + ( true, + "assign with type and no id", + "assign City", + get_response "err_assign_no_id" ); + ( true, + "assign with incorrect type and no id", + "assign Coty", + get_response "err_assign_no_id" ); + ( true, + "assign with incorrect type and no id", + "assign Coty Ithaca", + get_response "err_assign_DNE" ); ] ) let pre_defn_assign_tests = - ( [ "def Person Name"; "int age"; "float bank"; ""; "assign Person John" ], + ( [ + "def Person Name"; + "int age"; + "float bank"; + "id friend"; + ""; + "assign Person John"; + ], [ - (true, "can define types out of order bank", "bank = 5.4", "| "); - (false, "can define types out of order age", "age = 23", "| "); - (false, "can define types out of order end", "", "| <|\n|> "); + ( true, + "can define types out of order bank", + "bank = 5.4", + get_response "indent" ); + ( false, + "can define types out of order age", + "age = 23", + get_response "indent" ); + ( false, + "cant define a type twice age", + "age = 25", + get_response "err_create_field_already_entered" ); + ( false, + "can define types out of order empty end", + "", + get_response "indent_end" ); + ( false, + "testing the id system doesnt throw errors 1", + "assign Person Jim", + get_response "indent" ); + ( false, + "testing the id system throws error when no @", + "friend = Person", + get_response "err_create_field_wrong_type" ); + ( false, + "testing the id system on multiple @", + "friend = Person @ John @ Jim", + get_response "err_create_field_wrong_type" ); + ( false, + "testing the id system doesnt throw errors 2", + "friend = Person @ John", + get_response "indent" ); + ( false, + "testing the id system doesnt throw errors 3", + "", + get_response "indent_end" ); ( true, "entry doesnt exist error", "test = 5", @@ -66,25 +577,247 @@ let pre_defn_assign_tests = "entry no value error", "age = ", get_response "err_create_field_no_value" ); + ( true, + "assign with no name error", + " = 5", + get_response "err_create_field_no_value" ); ( true, "entry wrong type error", "age = hello", get_response "err_create_field_wrong_type" ); ] ) +let assign_type_tests = + ( fully_defined_generic @ [ "assign Type ID1" ], + [ + ( true, + "incorrect float value", + "f = hello", + get_response "err_create_field_wrong_type" ); + ( true, + "incorrect int value", + "i = 3.2", + get_response "err_create_field_wrong_type" ); + ( true, + "incorrect bool value", + "b = 2", + get_response "err_create_field_wrong_type" ); + ( true, + "incorrect char value", + "c = abc", + get_response "err_create_field_wrong_type" ); + ] ) + +let find_errors_tests = + ( fully_assigned_generic, + [ + ( true, + "incorrect find comparison '_'", + "find Type s _ 3", + get_response "err_find_invalid_comparison" ); + ( true, + "find type DNE", + "find Tope i < 4", + get_response "err_find_invalid_type" ); + ( true, + "incorrect find expression", + "find Type s _", + get_response "err_find_invalid_expr" ); + ( true, + "incorrect find expression, empty", + "find Type s ", + get_response "err_find_invalid_expr" ); + ( true, + "incorrect find comparison '+' with and", + "find Type s > 4 and i = 2 and f + 3", + get_response "err_find_invalid_comparison" ); + ( true, + "incorrect find incorrect expr with and", + "find Type s < 4 and i =2 and f <= 3", + get_response "err_find_invalid_expr" ); + ( true, + "empty find expression", + "find ", + get_response "err_find_missing_type" ); + ( true, + "empty expr with and", + "find Type and ", + get_response "err_find_invalid_expr" ); + ( true, + "find Type with wrong type in expr", + "find Type i <= 3.2", + get_response "err_find_wrong_type" ); + ( true, + "find Type with wrong type in expr", + "find Type k <= 3.2", + get_response "err_find_var_DNE" ); + ] ) + +let find_tests = + ( fully_assigned_generic + @ [ + "assign Type ID2"; + "i = 1"; + "f = 2.71"; + "c = b"; + "b = false"; + "s = good bye"; + ""; + ], + [ + ( true, + "test find for no values with and", + "find Type i = 1 and b = true", + "string ID int i float f char c bool b string s id d" ); + ( true, + "test find for one value with and", + "find Type i = 1 and b = false", + "string ID int i float f char c bool b string s id d ID2 1 2.71 b \ + false good bye" ); + ( true, + "test find for two value with no and", + "find Type i <> 5", + "string ID int i float f char c bool b string s id d ID1 10 3.14 a \ + true hello there ID2 1 2.71 b false good bye" ); + ( true, + "test find for one value with no and", + "find Type i <= 1", + "string ID int i float f char c bool b string s id d ID2 1 2.71 b \ + false good bye" ); + ( true, + "test find for one value with no and", + "find Type f >= 3", + "string ID int i float f char c bool b string s id d ID1 10 3.14 a \ + true hello there" ); + ] ) + +let at_tests = + ( fully_assigned_generic, + [ + (true, "test empty at statement ", "at ", get_response "err_at_empty"); + (true, "test at with no id", "at Type", get_response "err_at_no_id"); + ( true, + "test at statement with invalid id ", + "at Type ID", + get_response "err_at_id_DNE" ); + ( true, + "test at statement with incorrect type name", + "at Tupe ID", + get_response "err_at_invalid_type" ); + ( true, + "test at statement with non int column number", + "at Type ID1 i", + get_response "err_at_column_not_int" ); + ( true, + "test at statement with out of range column number", + "at Type ID1 10", + get_response "err_at_column_out_of_range" ); + ( true, + "test at statement with out of range column number", + "at Type ID1", + "string ID\tint i\t\tfloat f\t\tchar c\t\tbool b\t\tstring s\tid \ + d\t\t\n\n\n\ + ID1\t\t10\t\t3.14\t\ta\t\ttrue\t\thello there\t\t\t\n\n\n\ + |> " ); + ( true, + "test at statement on no entry column", + "at Type ID1 6", + get_response "no_entry" ); + ( true, + "test at statement on column with int value 10 ", + "at Type ID1 1", + "10\n|> " ); + ( true, + "test empty at statement ", + "at Type ID 1", + get_response "err_at_id_DNE" ); + ( true, + "test empty at statement ", + "at Tye ID 1", + get_response "err_at_invalid_type" ); + ( true, + "test empty at statement ", + "assign Type ID2", + get_response "indent" ); + ( false, + "test empty at statement ", + "d = Type @ asdf", + get_response "indent" ); + (false, "test empty at statement ", "", get_response "indent_end"); + ( false, + "test empty at statement ", + "at Type ID2 6", + "Type@asdf=\n\ + string ID\tint i\t\tfloat f\t\tchar c\t\tbool b\t\tstring s\tid d\t\t\n\n\ + \n\ + |> \n\ + |> " ); + ] ) + +let print_tests = + ( fully_assigned_generic, + [ + ( true, + "test print on fully defined generic", + "print", + "Table: Type\n\n\ + string ID int i float f char c bool b string s id d ID1 10 3.14 a \ + true hello there |>" ); + ] ) + +let at_id_tests = + ( fully_assigned_generic @ [ "assign Type ID2"; "d = Type @ ID1"; "" ], + [ + ( true, + "at tests on id instance", + "at Type ID2 6", + "Type@ID1=\n\ + string ID int i float f char c bool b string s id d ID1 10 3.14 a \ + true hello there |>" ); + ] ) + let misc_tests = ( [], - [ (true, "help message is correct", "help", get_response "help_message") ] - ) + [ + (true, "help message is correct", "help", get_response "help_message"); + ( true, + "unknown command error on random input", + "asdf", + get_response "err_unknown_command" ); + ( true, + "unknown command error on typo input", + "fi nd", + get_response "err_unknown_command" ); + ] ) -let rec gather_tests tests = +let rec gather_tests_no_print tests = match tests with | [] -> [] - | (primer, tests) :: t -> make_test primer tests :: gather_tests t + | (primer, tests) :: t -> + make_test primer tests false @ gather_tests_no_print t + +let rec gather_tests_with_print tests = + match tests with + | [] -> [] + | (primer, tests) :: t -> + make_test primer tests true @ gather_tests_with_print t + +let tests = + ([ + def_tests; + misc_tests; + pre_defn_assign_tests; + find_errors_tests; + assign_type_tests; + malformed_assign_states; + at_tests; + ] + |> gather_tests_no_print) + @ ([ find_tests; print_tests; at_id_tests ] |> gather_tests_with_print) let suite = - "search test suite" - >::: ([ def_tests; misc_tests; pre_defn_assign_tests ] - |> gather_tests |> List.flatten) + "test suite" + >::: List.flatten + [ HashTableTests.table_tests; DatabaseHashTable.database_tests; tests ] let _ = run_test_tt_main suite