From b22de42e642298b434f3702fe73bd6357020031a Mon Sep 17 00:00:00 2001 From: Kate Date: Tue, 20 Aug 2024 16:42:27 +0100 Subject: [PATCH] Move OpamBuiltinZ3.Syntax to a new OpamCudfCriteria module and use it in OpamBuiltin0install --- src/solver/opamBuiltin0install.ml | 19 +++--- src/solver/opamBuiltinZ3.real.ml | 89 +-------------------------- src/solver/opamCudfCriteria.ml | 99 +++++++++++++++++++++++++++++++ src/solver/opamCudfCriteria.mli | 32 ++++++++++ 4 files changed, 144 insertions(+), 95 deletions(-) create mode 100644 src/solver/opamCudfCriteria.ml create mode 100644 src/solver/opamCudfCriteria.mli diff --git a/src/solver/opamBuiltin0install.ml b/src/solver/opamBuiltin0install.ml index b468e4b81d2..3c672a760a0 100644 --- a/src/solver/opamBuiltin0install.ml +++ b/src/solver/opamBuiltin0install.ml @@ -104,23 +104,24 @@ let parse_criteria criteria = prefer_installed = false; } in - let rec parse default = function - | [] | [""] -> default - | "+removed"::xs -> + let rec parse default (criteria : OpamCudfCriteria.criterion list) = + match criteria with + | [] -> default + | (Plus, Removed, None)::xs -> parse {default with drop_installed_packages = true} xs - | "+count[version-lag"::"solution]"::xs -> + | (Plus, Solution, Some "version-lag")::xs -> parse {default with prefer_oldest = true} xs - | "-count[avoid-version"::"solution]"::xs -> + | (Minus, Solution, Some "avoid-version")::xs -> parse {default with handle_avoid_version = true} xs - | "-changed"::xs -> + | (Minus, Changed, None)::xs -> parse {default with prefer_installed = true} xs - | criteria::xs -> + | criterion::xs -> OpamConsole.warning "Criteria '%s' is not supported by the 0install solver" - criteria; + (OpamCudfCriteria.criterion_to_string criterion); parse default xs in - parse default (String.split_on_char ',' criteria) + parse default (OpamCudfCriteria.of_string criteria) let call ~criteria ?timeout:_ (preamble, universe, request) = let { diff --git a/src/solver/opamBuiltinZ3.real.ml b/src/solver/opamBuiltinZ3.real.ml index 24eada8bb34..3ffa167d6d1 100644 --- a/src/solver/opamBuiltinZ3.real.ml +++ b/src/solver/opamBuiltinZ3.real.ml @@ -273,17 +273,10 @@ let sum ctx (_, universe, _) filter value = [] universe -type filter = Installed | Changed | Removed | New | - Upgraded | Downgraded | Requested -type property = string option -type sign = Plus | Minus - -type criterion = sign * filter * property - let def_criterion ctx opt (preamble, universe, request as cudf) - (sign, filter, property : criterion) = + (sign, filter, property : OpamCudfCriteria.criterion) = let filter_f = match filter with - | Installed -> fun p -> psym ctx p + | Installed | Solution -> fun p -> psym ctx p | Changed -> fun p -> if p.Cudf.installed then @@ -367,82 +360,6 @@ let def_criterion ctx opt (preamble, universe, request as cudf) let def_criteria ctx opt cudf crits = List.iter (def_criterion ctx opt cudf) crits -module Syntax = struct - - let criterion_of_string (s,params) = - let sign = match s.[0] with - | '+' -> Plus - | '-' -> Minus - | c -> failwith (Printf.sprintf "criteria_of_string sign=%c" c) - | exception Invalid_argument _ -> - failwith "criteria_of_string sign=EOF" - in - let s = String.sub s 1 (String.length s - 1) in - let subset_of_string = function - | "new" -> New - | "removed" -> Removed - | "changed" -> Changed - | "up" -> Upgraded - | "down" -> Downgraded - | "installed" | "solution" -> Installed - | "request" -> Requested - | s -> failwith ("criteria_of_string subset="^s) - in - match s, params with - | "count", [field; subset] -> - sign, subset_of_string subset, Some field - | s, [] -> sign, subset_of_string s, None - | s, _ -> failwith ("criteria_of_string s="^s) -(* - let string_of_criterion (sign, filter, property: criterion) = - Printf.sprintf "%c%s%s" - (match sign with Plus -> '+' | Minus -> '-') - (match filter with - | Installed -> "installed" - | Changed -> "changed" - | Removed -> "removed" - | New -> "new" - | Upgraded -> "up" - | Downgraded -> "down" - | Requested -> "request") - (match property with None -> "" | Some p -> "["^p^"]") -*) - let criteria_of_string s = - let start = ref 0 in - let crits = ref [] in - let params = ref None in - for i = 0 to String.length s - 1 do - match s.[i] with - | ',' -> - let sub = String.sub s !start (i - !start) in - start := i + 1; - if sub <> "" then - (match !params with - | None -> crits := (sub, []) :: !crits - | Some (name, ps) -> params := Some (name, sub :: ps)) - | '[' -> - let sub = String.sub s !start (i - !start) in - start := i + 1; - if !params <> None then failwith "criteria_of_string"; - params := Some (sub, []) - | ']' -> - let sub = String.sub s !start (i - !start) in - start := i + 1; - (match !params with - | None -> failwith "criteria_of_string" - | Some (name, ps) -> - params := None; - crits := (name, List.rev (sub::ps)) :: !crits) - | _ -> () - done; - if !start < String.length s then - crits := (String.sub s !start (String.length s - !start), []) :: !crits; - if !params <> None then failwith "criteria_of_string"; - let r = List.rev_map criterion_of_string !crits in - r - -end - let extract_solution_packages universe opt = match Z3.Optimize.get_model opt with | Some model -> @@ -485,7 +402,7 @@ let call ~criteria ?timeout (preamble, universe, _ as cudf) = log "Generating optimization criteria"; let opt = Z3.Optimize.mk_opt ctx.z3 in let _criteria_def_handles = - def_criteria ctx opt cudf (Syntax.criteria_of_string criteria) + def_criteria ctx opt cudf (OpamCudfCriteria.of_string criteria) in log "Sending the problem to Z3"; let params = diff --git a/src/solver/opamCudfCriteria.ml b/src/solver/opamCudfCriteria.ml new file mode 100644 index 00000000000..b4b601e76e6 --- /dev/null +++ b/src/solver/opamCudfCriteria.ml @@ -0,0 +1,99 @@ +(**************************************************************************) +(* *) +(* Copyright 2017-2019 OCamlPro *) +(* *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1, with the special *) +(* exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type filter = + | Installed + | Solution + | Changed + | Removed + | New + | Upgraded + | Downgraded + | Requested + +type property = string option + +type sign = Plus | Minus + +type criterion = sign * filter * property + +let criterion_of_string (s,params) = + let sign = match s.[0] with + | '+' -> Plus + | '-' -> Minus + | c -> failwith (Printf.sprintf "criteria_of_string sign=%c" c) + | exception Invalid_argument _ -> + failwith "criteria_of_string sign=EOF" + in + let s = String.sub s 1 (String.length s - 1) in + let subset_of_string = function + | "new" -> New + | "removed" -> Removed + | "changed" -> Changed + | "up" -> Upgraded + | "down" -> Downgraded + | "installed" -> Installed + | "solution" -> Solution + | "request" -> Requested + | s -> failwith ("criteria_of_string subset="^s) + in + match s, params with + | "count", [field; subset] -> + sign, subset_of_string subset, Some field + | s, [] -> sign, subset_of_string s, None + | s, _ -> failwith ("criteria_of_string s="^s) + +let criterion_to_string (sign, filter, property: criterion) = + Printf.sprintf "%c%s%s" + (match sign with Plus -> '+' | Minus -> '-') + (match filter with + | Installed -> "installed" + | Solution -> "solution" + | Changed -> "changed" + | Removed -> "removed" + | New -> "new" + | Upgraded -> "up" + | Downgraded -> "down" + | Requested -> "request") + (match property with None -> "" | Some p -> "["^p^"]") + +let of_string s = + let start = ref 0 in + let crits = ref [] in + let params = ref None in + for i = 0 to String.length s - 1 do + match s.[i] with + | ',' -> + let sub = String.sub s !start (i - !start) in + start := i + 1; + if sub <> "" then + (match !params with + | None -> crits := (sub, []) :: !crits + | Some (name, ps) -> params := Some (name, sub :: ps)) + | '[' -> + let sub = String.sub s !start (i - !start) in + start := i + 1; + if !params <> None then failwith "criteria_of_string"; + params := Some (sub, []) + | ']' -> + let sub = String.sub s !start (i - !start) in + start := i + 1; + (match !params with + | None -> failwith "criteria_of_string" + | Some (name, ps) -> + params := None; + crits := (name, List.rev (sub::ps)) :: !crits) + | _ -> () + done; + if !start < String.length s then + crits := (String.sub s !start (String.length s - !start), []) :: !crits; + if !params <> None then failwith "criteria_of_string"; + let r = List.rev_map criterion_of_string !crits in + r diff --git a/src/solver/opamCudfCriteria.mli b/src/solver/opamCudfCriteria.mli new file mode 100644 index 00000000000..d4be548f29e --- /dev/null +++ b/src/solver/opamCudfCriteria.mli @@ -0,0 +1,32 @@ +(**************************************************************************) +(* *) +(* Copyright 2017-2019 OCamlPro *) +(* *) +(* All rights reserved. This file is distributed under the terms of the *) +(* GNU Lesser General Public License version 2.1, with the special *) +(* exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type filter = + | Installed + | Solution + | Changed + | Removed + | New + | Upgraded + | Downgraded + | Requested + +type property = string option + +type sign = Plus | Minus + +type criterion = sign * filter * property + +val criterion_to_string : criterion -> string + +(** [of_string s] Parses the string [s] as a CUDF optimization criteria. + + @raise {!Stdlib.Failure} if the string is invalid *) +val of_string : string -> criterion list