diff --git a/builder/builder.ml b/builder/builder.ml index 97a9f0d37..d8e625f68 100644 --- a/builder/builder.ml +++ b/builder/builder.ml @@ -396,18 +396,15 @@ let main () = (human_size size) output_filename (human_size blockdev_size); size in - let goal = - (* MUST *) - let goal_must = [ - `Filename, output_filename; - `Size, Int64.to_string output_size; - `Format, output_format - ] in + (* Goal: must *) + let must = [ + `Filename, output_filename; + `Size, Int64.to_string output_size; + `Format, output_format + ] in - (* MUST NOT *) - let goal_must_not = [ `Template, ""; `XZ, "" ] in - - goal_must, goal_must_not in + (* Goal: must not *) + let must_not = [ `Template, ""; `XZ, "" ] in let cache_dir = (open_guestfs ())#get_cachedir () in @@ -508,7 +505,7 @@ let main () = (* Plan how to create the disk image. *) message (f_"Planning how to build this image"); let plan = - try plan ~max_depth:5 transitions itags goal + try plan ~max_depth:5 transitions itags ~must ~must_not with Failure "plan" -> error (f_"no plan could be found for making a disk image with\nthe required size, format etc. This is a bug in libguestfs!\nPlease file a bug, giving the command line arguments you used."); diff --git a/common/mltools/planner.ml b/common/mltools/planner.ml index 12dfb267c..736cfee92 100644 --- a/common/mltools/planner.ml +++ b/common/mltools/planner.ml @@ -20,13 +20,15 @@ type ('name, 'value) tag = 'name * 'value type ('name, 'value) tags = ('name, 'value) tag list -type ('name, 'value, 'task) plan = - (('name, 'value) tags * 'task * ('name, 'value) tags) list +type ('name, 'value, 'task) transition = + ('name, 'value) tags * 'task * ('name, 'value) tags + +type ('name, 'value, 'task) plan = ('name, 'value, 'task) transition list type ('name, 'value, 'task) transitions_function = ('name, 'value) tags -> ('task * int * ('name, 'value) tags) list -let plan ?(max_depth = 10) transitions itags (goal_must, goal_must_not) = +let plan ?(max_depth = 10) transitions itags ~must ~must_not = (* Do the given output tags match the finish condition? *) let finished (otags, _, _) = let must = @@ -34,14 +36,14 @@ let plan ?(max_depth = 10) transitions itags (goal_must, goal_must_not) = List.for_all ( fun (name, value) -> try List.assoc name otags = value with Not_found -> false - ) goal_must in + ) must in let must_not = (* No tag from the MUST NOT list can appear. *) List.for_all ( fun (name, value) -> try List.assoc name otags <> value with Not_found -> true - ) goal_must_not in + ) must_not in must && must_not in diff --git a/common/mltools/planner.mli b/common/mltools/planner.mli index 6b5a12d55..8cd1c51c9 100644 --- a/common/mltools/planner.mli +++ b/common/mltools/planner.mli @@ -41,24 +41,41 @@ possible, but might not be optimal. *) type ('name, 'value) tag = 'name * 'value +(** A single tag. *) type ('name, 'value) tags = ('name, 'value) tag list - (** An assoc-list of tags. *) +(** An assoc-list of tags. *) -type ('name, 'value, 'task) plan = - (('name, 'value) tags * 'task * ('name, 'value) tags) list +type ('name, 'value, 'task) transition = + ('name, 'value) tags * 'task * ('name, 'value) tags +(** A transition is the 3 element tuple: + (input tags for this transition, + the task to perform, + the output tags after this transition). *) + +type ('name, 'value, 'task) plan = ('name, 'value, 'task) transition list +(** A plan (the returned value from the {!plan} function) is a list + of transitions. *) type ('name, 'value, 'task) transitions_function = ('name, 'value) tags -> ('task * int * ('name, 'value) tags) list +(** This is the type of the transition function. Given a set of + current tags, it returns the list of possible transitions out, + with a weight (higher number = more expensive) for each and the + resulting set of tags after that transition. *) -val plan : ?max_depth:int -> ('name, 'value, 'task) transitions_function -> ('name, 'value) tags -> ('name, 'value) tags * ('name, 'value) tags -> ('name, 'value, 'task) plan +val plan : ?max_depth:int -> ('name, 'value, 'task) transitions_function -> + ('name, 'value) tags -> + must: ('name, 'value) tags -> must_not: ('name, 'value) tags -> + ('name, 'value, 'task) plan (** Make a plan. - [plan transitions itags (goal_must, goal_must_not)] works out a + [plan transitions itags goal_must goal_must_not] works out a plan, which is a list of tasks that have to be carried out in - order to go from the input tags to the goal. The goal is passed - in as a pair of lists: tags that MUST appear and tags that MUST - NOT appear. + order to go from the input tags to the goal. + + The goal is passed in as a pair of lists: tags that MUST appear + and tags that MUST NOT appear. The returned value is a {!plan}.