diff options
| -rw-r--r-- | lib/ast_types.ml | 126 | ||||
| -rw-r--r-- | lib/lexer.mll | 1 |
2 files changed, 86 insertions, 41 deletions
diff --git a/lib/ast_types.ml b/lib/ast_types.ml index 6996435..7189db7 100644 --- a/lib/ast_types.ml +++ b/lib/ast_types.ml @@ -13,7 +13,7 @@ type ast_row = [@@deriving show, eq] type ast_table = -(** In hindsight, this could've been represented as a list of tables instead using separated list command +(** In hindsight, this could've been represented as a list of tables instead using separated_list function TODO: Rewrite this to use a list of tables instead of a tree *) | Table of string * int * ast_row * ast_table @@ -53,46 +53,71 @@ let rec print = function (* AST to Fixtures *) type ast_row_relation = - | PRow of Fixture.t - | CRow of (string * string * (string list -> Fixture.t)) + | PColumn of Fixture.t + | CColumn of (string * string * (string list -> Fixture.t)) type ast_table_relation = | PTable of string * int * Fixture.t list - | CTable of string * string * string * int * (string list -> Fixture.t list) - (** parent, row, child_name, row *) + | CTable of (string * string) list * string * int * (string -> string list -> Fixture.t list) + (** parent (name, referenced id), row, child_name, fixture builder given a parent name and list of options *) (* TODO: Support multiple relations *) let table_name = function | PTable (n,_,_) -> n - | CTable (_,_,c,_,_) -> c + | CTable (_,c,_,_) -> c let rec ast_row_to_fixtures = function - | Uuidv4 (s, r) -> PRow (Fixture.Uuidv4 s) :: ast_row_to_fixtures r + | Uuidv4 (s, r) -> PColumn (Fixture.Uuidv4 s) :: ast_row_to_fixtures r | Foreign (p, r, c, next_row) -> - CRow (p, r, fun l -> Fixture.Foreign (c, l)) :: ast_row_to_fixtures next_row - | Name (s, r) -> PRow (Fixture.Name s) :: ast_row_to_fixtures r - | Int (s, min, max, r) -> PRow (Fixture.Int (s, min, max)) :: ast_row_to_fixtures r - | Const (s, v, r) -> PRow (Fixture.Const (s, v)) :: ast_row_to_fixtures r - | List (s, l, r) -> PRow (Fixture.List (s, l)) :: ast_row_to_fixtures r + CColumn (p, r, fun l -> Fixture.Foreign (c, l)) :: ast_row_to_fixtures next_row + | Name (s, r) -> PColumn (Fixture.Name s) :: ast_row_to_fixtures r + | Int (s, min, max, r) -> PColumn (Fixture.Int (s, min, max)) :: ast_row_to_fixtures r + | Const (s, v, r) -> PColumn (Fixture.Const (s, v)) :: ast_row_to_fixtures r + | List (s, l, r) -> PColumn (Fixture.List (s, l)) :: ast_row_to_fixtures r | End -> [] +let extend_table_with_row table row = + (** This function is magic, but essentially it takes a table and a column and extends the table. + For columns where we reference a parent table, we need to be able to resolve that parent in order to + know the fixtures, thus we need to instead build a function that takes the generated values for a parent and + adds the rows. + + For that, we constructuct a function that takes a parent name and a list of options + and applies it to the correct location. + + For understanding this kind of technique, look up contravariant functors + *) + match row with + | PColumn r -> + (match table with + | PTable (n, amount, l) -> PTable (n, amount, r :: l) + | CTable (parents,c, amount, f) -> CTable (parents, c, amount, fun p l -> r :: f p l) + ) + | CColumn (p,pr, f) -> + (match table with + | PTable (n, amount, l_p) -> CTable ([(p,pr)], n, amount, fun p' l -> + if p' = p then + f l :: l_p + else + [] + ) + | CTable (parents,c, amount, resolve_parents) -> + let new_resolver = fun requested_parent l -> + if requested_parent = p then + [f l] + else + resolve_parents requested_parent l + in + CTable ((p,pr) :: parents, c, amount, new_resolver) + ) let ast_table_to_table name amount rows = (** Convert an AST table to a Fixture table that we can more easily work with for feeding the generated data as input into fixtures that depend on the generated data from other fixtures *) List.fold_left - (fun tbl row -> - match row with - | PRow r -> - (match tbl with - | PTable (n, amount, l) -> PTable (n, amount, r :: l) - | CTable (p, pr, c, amount, f) -> CTable (p, pr, c, amount, fun l -> r :: f l)) - | CRow (p, pr, f) -> - (match tbl with - | PTable (c,amount, lr ) -> CTable (p, pr, c, amount, fun l -> f l :: lr) - | CTable _ -> failwith "Cannot have multiple relations")) + extend_table_with_row (PTable (name, amount, [])) rows @@ -114,6 +139,20 @@ let%test "ast_table_to_tables" = let generated_fixtures = ref (Hashtbl.create 10) (** Used to not regenerate a different fixture for the same table. Also theoretically speeds up the compilation process by not generating the same fixture twice. I do not know what kind of monstrosity of a fixture you'd need for it to matter, but neat regardless. *) +let collect_results result_list = + (** Collect the results of a list of results into a single result *) + let rec collect_results' = function + | [] -> Ok [] + | (Ok l) :: tl -> + (match collect_results' tl with + | Ok l' -> Ok (l @ l') + | Error e -> Error e + ) + | (Error e) :: _ -> Error e + in + collect_results' result_list + + let rec resolve_fixtures tables name = (* Verify if we have already generated fixtures for this table *) let maybe_fixtures = Hashtbl.find_opt !generated_fixtures name in @@ -128,21 +167,31 @@ let rec resolve_fixtures tables name = (* store the generated fixtures for this table *) Hashtbl.add !generated_fixtures name (snd resolved); resolved - | Some (CTable (p,pr,c, amount, create_fixtures)) -> ( - let (_, parent_fixtures) = resolve_fixtures tables p in - (* store the generated fixtures for this table *) - Hashtbl.add !generated_fixtures name parent_fixtures; - let generated_ids = Fixture.find_entries_for_header parent_fixtures pr in - match generated_ids with - | Ok ids -> (c, Fixture.compile ~amount (create_fixtures ids)) - | Error e -> failwith e + | Some (CTable (parents, c, amount, create_fixtures)) -> ( + resolve_along_with_parents tables name amount parents c create_fixtures ) | None -> failwith ("Could not find table " ^ name) +and resolve_along_with_parents tables name amount parents c create_fixtures = + let maybe_parents_fixtures = parents + |> List.map (fun (p,pr) -> (p,pr, resolve_fixtures tables p |> snd)) + |> List.map (fun (p,pr,parent_fixtures) -> ( + Fixture.find_entries_for_header parent_fixtures pr + |> Result.map (fun ids -> create_fixtures p ids)) + ) + |> collect_results + in + (* store the generated fixtures for this table *) + match maybe_parents_fixtures with + | Ok parents_fixtures -> + let compiled = Fixture.compile ~amount parents_fixtures in + Hashtbl.add !generated_fixtures name compiled; + (c, compiled) + | Error e -> failwith e let%test "resolve_fixtures" = let tables = [ PTable ("user", 1, [Fixture.Uuidv4 "id"; Fixture.Uuidv4 "uuid"]); - CTable ("user", "id", "posts", 1, fun ids -> [Fixture.Foreign ("user_id", ids)]) + CTable ([("user", "id")], "posts", 1, fun _ ids -> [Fixture.Foreign ("user_id", ids)]) ] in let (_, user_fixtures) = resolve_fixtures tables "user" in let (_, purchase_fixtures) = resolve_fixtures tables "posts" in @@ -155,7 +204,7 @@ let%test "resolve_fixtures" = let show_tables tables = let show_table = function | PTable (n,_,_) -> n - | CTable (_,_,c,_,_) -> c + | CTable (_,c,_,_) -> c in tables |> List.map show_table |> String.concat "\n" @@ -167,15 +216,10 @@ let compile ast = let (n,_,resolved) = (n, amount, Fixture.compile l ~amount) in Hashtbl.add !generated_fixtures n resolved; (n,resolved) - | CTable (p,pr,c, amount, create_fixtures) -> - let (_, parent_fixtures) = resolve_fixtures tables p in - Hashtbl.add !generated_fixtures c parent_fixtures; - let generated_ids = Fixture.find_entries_for_header parent_fixtures pr in - match generated_ids with - | Ok ids -> (c, Fixture.compile ~amount (create_fixtures ids)) - | Error e -> failwith e + | CTable (parents,c, amount, create_fixtures) -> + let (c, resolved) = resolve_along_with_parents tables c amount parents c create_fixtures in + Hashtbl.add !generated_fixtures c resolved; + (c,resolved) in let result = List.map resolve_fixtures' tables in result - - diff --git a/lib/lexer.mll b/lib/lexer.mll index c6f2b93..e2f6469 100644 --- a/lib/lexer.mll +++ b/lib/lexer.mll @@ -15,6 +15,7 @@ let id = ['a'-'z' 'A'-'Z' '-']* let newline = '\r' | '\n' | "\r\n" let many_newline = newline+ +(* TODO: Support _ and - in identifiers *) rule read = parse | "uuidv4" { UUIDV4 } |