Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

More WIP ...

Start implementing the basics for repository plugins
  • Loading branch information...
commit ac99a15b489050e7c99f76a04c88926d8551b094 1 parent 9e7f045
@samoht samoht authored
View
1  .gitignore
@@ -6,6 +6,7 @@ src_ext/ocaml-re/
src_ext/ocamlgraph/
src_ext/ocaml-arg/
src/lexer.ml
+src/linelexer.ml
src/parser.ml
src/parser.mli
*.tar.bz2
View
26 Makefile
@@ -2,7 +2,7 @@ OCPBUILD ?= ./_obuild/unixrun ./boot/ocp-build.boot
OCAMLC=ocamlc
SRC_EXT=src_ext
-TARGET = ocp-get ocp-get-server
+TARGET = opam
.PHONY: all
@@ -21,24 +21,18 @@ opt: ./_obuild/unixrun
mkdir -p ./_obuild
$(OCAMLC) -o ./_obuild/unixrun -make-runtime unix.cma str.cma
-bootstrap: _obuild/unixrun _obuild/ocp-get/ocp-get.byte
- rm -f boot/ocp-get.boot
- ocp-bytehack -static _obuild/ocp-get/ocp-get.byte -o boot/ocp-get.boot
+bootstrap: _obuild/unixrun _obuild/opam/opam.byte
+ rm -f boot/opam.boot
+ ocp-bytehack -static _obuild/opam/opam.byte -o boot/opam.boot
-link: ocp-get ocp-get-server
+link: opam
@
-_obuild/ocp-get-server/ocp-get-server.asm:
- $(OCPBUILD) ocp-get-server
+_obuild/opam/opam.asm _obuild/opam/opam.byte:
+ $(OCPBUILD) opam
-_obuild/ocp-get/ocp-get.asm:
- $(OCPBUILD) ocp-get
-
-ocp-get-server: _obuild/ocp-get-server/ocp-get-server.asm
- ln -s $^ ocp-get-server
-
-ocp-get: _obuild/ocp-get/ocp-get.asm
- ln -s $^ ocp-get
+opam: _obuild/opam/opam.asm
+ ln -s $^ opam
compile: ./_obuild/unixrun clone
$(OCPBUILD) -init -scan -sanitize $(TARGET)
@@ -50,7 +44,7 @@ clone:
clean:
rm -rf _obuild
rm -rf src/*.annot bat/*.annot
- rm -f ocp-get ocp-get-server
+ rm -f opam
rm -f ocp-build.*
$(MAKE) -C $(SRC_EXT) clean
View
18 ocp-get.ocp → opam.ocp
@@ -7,11 +7,12 @@
comp = [ "-g" ]
link = [ "-g" ]
-begin library "get"
+begin library "opam-lib"
dirname = [ "src" ]
comp += [ "-annot" "-warn-error" "A" ]
files = [
"globals.ml"
+ "utils.ml"
"types.ml"
"run.ml"
"file_format.ml"
@@ -20,7 +21,7 @@ begin library "get"
"parser.mly"
"path.ml"
"file.ml"
- "server.ml"
+ "repositories.ml"
]
requires = [
@@ -34,20 +35,13 @@ begin library "get"
]
end
-begin program "ocp-get"
+begin program "opam"
dirname = [ "src" ]
comp += [ "-annot" "-warn-error" "A" ]
files = [
"solver.ml"
"client.ml"
- "ocp_get.ml"
+ "opam.ml"
]
- requires = [ "get" ]
-end
-
-begin program "ocp-get-server"
- dirname = [ "src" ]
- comp += [ "-annot" "-warn-error" "A" ]
- files = [ "ocp_get_server.ml" ]
- requires = [ "get" ]
+ requires = [ "opam-lib" ]
end
View
78 src/client.ml
@@ -13,48 +13,59 @@
(* *)
(***********************************************************************)
-open ExtList
-open Namespace
+open Types
open Path
-open Server
open Solver
-open Uri
-open Protocol
let log fmt =
Globals.log "CLIENT" fmt
-type remote_action =
+type remote_request =
| List
| Add of string
- | AddGit of string
| Rm of string
-type config_recursive =
- | Not_recursive
- | Recursive_large (* package + dependencies *)
- | Recursive_strict (* only dependencies, not package *)
-
-type config_request = Include | Bytelink | Asmlink | Ocp
+type options =
+ | Include of N.t list
+ | Bytecomp of (N.t * string) list
+ | Asmcomp of (N.t * string) list
+ | Bytelink of (N.t * string) list
+ | Asmlink of (N.t * string) list
+
+type compil_option = {
+ recursive: bool;
+ options : options;
+}
+
+type config_request =
+ | Compil of compil_option
+ | Variable of (N.t * Variable.t) list
+ | Subst of Filename.t list
+
+type upload_request = {
+ opam : Filename.t;
+ descr : Filename.t;
+ archive: Filename.t;
+}
module type CLIENT =
sig
type t
(** Initializes the client a consistent state. *)
- val init : url list -> unit
+ val init : repository list -> unit
(** Displays all available packages *)
val list : unit -> unit
(** Displays a general summary of a package. *)
- val info : name -> unit
+ val info : N.t -> unit
(** Depending on request, returns options or directories where the package is installed. *)
- val config : config_recursive (* search power *) -> config_request -> name list -> unit
+ val config : config_request -> unit
(** Installs the given package. *)
- val install : string -> unit
+ val install : N.t -> unit
(** Downloads the latest packages available. *)
val update : unit -> unit
@@ -64,39 +75,34 @@ sig
val upgrade : unit -> unit
(** Sends a new created package to the server. *)
- val upload : string -> unit
+ val upload : upload_request -> unit
(** Removes the given package. *)
- val remove : name -> unit
+ val remove : N.t -> unit
- (** Manage remote indexes *)
- val remote : remote_action -> unit
+ (** Manage remote repositories *)
+ val remote : remote_request -> unit
- (** Switch to an other version of ocaml *)
- val switch : string -> unit
end
module Client : CLIENT = struct
open File
- type t =
- { servers: url list
- ; home : Path.t (* ~/.opam *) }
-
- let find_ocaml_version config =
- match !Globals.ocamlc with
- | None -> File.Config.ocaml_version config
- | Some v -> Version (Run.Ocamlc.version (Run.Ocamlc.init v))
+ type t = {
+ global : Path.Global.t; (* ~/.opam/ *)
+ compiler : Path.Compiler.t; (* ~/.opam/<oversion>/ *)
+ config : File.Config.t; (* ~/.opam/config contents *)
+ }
(* Look into the content of ~/.opam/config to build the client state *)
(* Do not call RemoteServer functions here, as it implies a
network roundtrip *)
let load_state () =
- let home = Path.init !Globals.root_path in
- let config = File.Config.find_err (Path.config home) in
- let servers = File.Config.sources config in
- { servers
- ; home = Path.O.set_version home (find_ocaml_version config) }
+ let global = Global.create (d !Globals.root_path) in
+ let config = File.Config.read (Global.config global) in
+ let ocaml_version = File.Config.ocaml_version config in
+ let compiler = Compiler.create (Global.root global) ocaml_version in
+ { global; compiler; config }
let update_remote server home =
log "update-remote-server %s%s"
View
48 src/file.ml
@@ -61,6 +61,28 @@ module Lines : IO_FILE with type t = string list list = struct
end
+module Address : sig
+
+ include IO_FILE
+
+end = struct
+
+ let kind = "address"
+
+ type t = string
+
+ let empty = Globals.default_repository_address
+
+ let of_string filename t =
+ match Lines.of_string filename t with
+ | [[a]] -> a
+ | _ -> Globals.error_and_exit "address: bad contents"
+
+ let to_string filename a =
+ Lines.to_string filename [[a]]
+
+end
+
module Installed : sig
include IO_FILE with type t = V.t N.Map.t
end = struct
@@ -128,10 +150,7 @@ module Config : sig
include IO_FILE
- type repository = {
- path: string;
- kind: string;
- }
+ type repository = Types.repository
(** destruct *)
val opam_version : t -> V.t
@@ -145,19 +164,16 @@ end = struct
let kind = "config"
- type repository = {
- path: string;
- kind: string;
- }
+ type repository = Types.repository
- let to_repo (path, kind) =
- let kind = match kind with
+ let to_repo (repo_name, repo_kind) =
+ let repo_kind = match repo_kind with
| None -> Globals.default_repository_kind
| Some k -> k in
- { path; kind }
+ { repo_name; repo_kind }
let of_repo r =
- Option (String r.path, [ String r.kind ])
+ Option (String r.repo_name, [ String r.repo_kind ])
type t = {
opam_version : V.t ; (* opam version *)
@@ -175,8 +191,8 @@ end = struct
let empty = {
opam_version = V.of_string Globals.opam_version;
repositories = [ {
- path = Globals.default_repository;
- kind = Globals.default_repository_kind;
+ repo_name = Globals.default_repository_name;
+ repo_kind = Globals.default_repository_kind;
} ];
ocaml_version = V.of_string Sys.ocaml_version;
}
@@ -471,8 +487,6 @@ module PConfig : sig
| B of bool
| S of string
- module Variable : Abstract
-
module Section : Abstract
module type SECTION = sig
@@ -500,8 +514,6 @@ end = struct
let s str = S str
let b bool = B bool
- module Variable : Abstract = Base
-
module Section : Abstract = Base
type section = {
View
5 src/globals.ml
@@ -20,8 +20,9 @@ let debug = ref (
let version = "0.1+dev"
-let default_repository = "http://opam.ocamlpro.com"
-let default_repository_kind = "rsync"
+let default_repository_name = "default"
+let default_repository_address = "http://opam.ocamlpro.com"
+let default_repository_kind = "rsync"
let opam_version = "1"
View
40 src/ocp_get.ml → src/opam.ml
@@ -59,7 +59,7 @@ let global_args = [
let parse_args fn () =
fn (List.rev !ano_args)
-(* ocp-get init [HOSTNAME[:PORT]]*)
+(* opam init [HOSTNAME[:PORT]]*)
let init =
let git_repo = ref false in
{
@@ -87,7 +87,7 @@ let init =
| _ -> bad_argument "init" "Too many remote server")
}
-(* ocp-get list *)
+(* opam list *)
let list = {
name = "list";
usage = "";
@@ -98,7 +98,7 @@ let list = {
main = Client.list;
}
-(* ocp-get info [PACKAGE] *)
+(* opam info [PACKAGE] *)
let info = {
name = "info";
usage = "[package]+";
@@ -112,23 +112,19 @@ let info = {
| l -> List.iter (fun name -> Client.info (Namespace.name_of_string name)) l)
}
-(* ocp-get config [R] [Include|Bytelink|Asmlink] PACKAGE *)
+(* opam config [R] [Include|Bytelink|Asmlink] PACKAGE *)
let config =
- let recursive = ref Not_recursive in
+ let recursive = ref false in
let command = ref None in
- let set_include () = command := Some Include in
- let set_asmlink () = command := Some Asmlink in
- let set_bytelink () = command := Some Bytelink in
- let set_ocp () = command := Some Ocp in
- let set_rec_large () = recursive := Recursive_large in
- let set_rec_strict () = recursive := Recursive_strict in
+ let set c () = command := Some c in
+ let set_rec () = recursive := true in
let specs = [
- ("-r", Arg.Unit set_rec_large , " Recursive search (large)");
- ("-rstrict", Arg.Unit set_rec_strict , " Recursive search (strict)");
- ("-I", Arg.Unit set_include , " Display include options");
- ("-bytelink", Arg.Unit set_bytelink, " Display bytecode link options");
- ("-asmlink" , Arg.Unit set_asmlink , " Display native link options");
- ("-ocp" , Arg.Unit set_ocp , " Display ocp-build configuration");
+ ("-r" , Arg.Unit set_rec , " Recursive search (large)");
+ ("-I" , Arg.Unit (set Include) , " Display native compile options");
+ ("-bytecomp", Arg.Unit (set Bytecomp), " Display bytecode compile options");
+ ("-asmcomp" , Arg.Unit (set Asmcomp) , " Display native link options");
+ ("-bytelink", Arg.Unit (set Bytelink), " Display bytecode link options");
+ ("-asmlink" , Arg.Unit (set Asmlink) , " Display native link options");
] in
{
name = "config";
@@ -141,11 +137,11 @@ let config =
function () ->
let names = List.rev !ano_args in
let command = match !command with
- | None ->
- bad_argument
- "config" "Missing command [%s]"
- (String.concat "|" (List.map (fun (s,_,_) -> s) specs))
- | Some c -> c in
+ | None ->
+ bad_argument
+ "config" "Missing command [%s]"
+ (String.concat "|" (List.map (fun (s,_,_) -> s) specs))
+ | Some c -> c in
Client.config !recursive command (List.map (fun n -> Name n) names);
}
View
89 src/path.ml
@@ -113,6 +113,9 @@ module type GLOBAL = sig
val create: dirname -> t
+ (** Root dir: [$opam/] *)
+ val root: t -> dirname
+
(** Main configuration file: [$opam/config] *)
val config: t -> filename
@@ -140,6 +143,8 @@ module Global : GLOBAL = struct
let create opam = opam
+ let root opam = opam
+
let dirname_of_nv nv = Dirname.of_string (NV.to_string nv)
let config t = t // b "config"
@@ -199,6 +204,7 @@ module type COMPILER = sig
end
module Compiler : COMPILER = struct
+
type t = dirname
let create opam oversion =
@@ -225,7 +231,90 @@ module Compiler : COMPILER = struct
let config t n = config_dir t // b (N.to_string n ^ ".config")
end
+module type REPOSITORY = sig
+ type t
+
+ val create: dirname -> repository -> t
+
+ (** Return the repository folder: [$opam/repo/$repo] *)
+ val root: t -> dirname
+
+ (** Return the repository index: [$opam/repo/index] *)
+ val index: t -> dirname
+
+ (** Return the repository kind: [$opam/repo/$repo/kind] *)
+ val kind: t -> filename
+
+ (** Return the repository address: [$opam/repo/$repo/address] *)
+ val address: t -> filename
+
+ (** Return the OPAM file for a given package: [$opam/repo/$repo/opam/$NAME.$VERSION.opam] *)
+ val opam: t -> NV.t -> filename
+
+ (** Return the OPAM folder: [$opam/repo/$repo/opam/] *)
+ val opam_dir: t -> dirname
+
+ (** Return the description file for a given package: [$opam/repo/$repo/descr/$NAME.VERSION] *)
+ val descr: t -> NV.t -> filename
+
+ (** Return the description folder *)
+ val descr_dir: t -> dirname
+
+ (** Return the archive for a giben package: [$opam/repo/$repo/archives/$NAME.$VERSION.tar.gz *)
+ val archive: t -> NV.t -> filename
+
+ (** Return the archive folder: [$opam/repo/$repo/archives/] *)
+ val archive_dir: t -> dirname
+
+ (** Return the list of updated packages: [$opam/repo/$repo/updated] *)
+ val updated: t -> filename
+
+ (** Return the upload folder for a given version: [$opam/repo/$repo/upload/$NAME.$VERSION/] *)
+ val upload: t -> NV.t -> dirname
+
+ (** Return the upload folder: [$opam/repo/$repo/upload] *)
+ val upload_dir: t -> dirname
+end
+
+module Repository : REPOSITORY = struct
+ type t = {
+ root: dirname; (* [$opam/] *)
+ repo: dirname; (* [$opam/repo/$repo] *)
+ }
+
+ let create root r = {
+ root;
+ repo = root / d "repo" / d r.repo_name;
+ }
+
+ let root t = t.repo
+
+ let index t = t.root / d "repo" / d "index"
+
+ let kind t = t.repo // b "kind"
+
+ let address t = t.repo // b "address"
+
+ let opam_dir t = t.repo / d "opam"
+
+ let opam t nv = opam_dir t // b (NV.to_string nv ^ ".opam")
+
+ let descr_dir t = t.repo / d "descr"
+
+ let descr t nv = descr_dir t // b (NV.to_string nv)
+
+ let archive_dir t = t.repo / d "archives"
+
+ let archive t nv = archive_dir t // b (NV.to_string nv ^ ".tar.gz")
+
+ let updated t = t.repo // b "updated"
+
+ let upload_dir t = t.repo / d "upload"
+
+ let upload t nv = upload_dir t / d (NV.to_string nv)
+
+end
View
60 src/repositories.ml
@@ -0,0 +1,60 @@
+(***********************************************************************)
+(* *)
+(* Copyright 2012 OCamlPro *)
+(* Copyright 2012 INRIA *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Public License version 3.0. *)
+(* *)
+(* TypeRex is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(***********************************************************************)
+
+open Types
+open Path
+
+let log fmt = Globals.log "REPO" fmt
+
+module Script = struct
+ let opam_init r = Printf.sprintf "opam-%s-init" r.repo_kind
+ let opam_update r = Printf.sprintf "opam-%s-update" r.repo_kind
+ let opam_download r = Printf.sprintf "opam-%s-download" r.repo_kind
+ let opam_upload r = Printf.sprintf "opam-%s-upload" r.repo_kind
+end
+
+let run fn root repo =
+ let path = Repository.root (Repository.create root repo) in
+ let i = Run.in_dir (Dirname.to_string path) (fun () ->
+ Run.command "%s" (fn repo);
+ ) () in
+ if i <> 0 then
+ Globals.error_and_exit "%s failed" (fn repo)
+
+let opam_init root r =
+ log "opam-init: %s" (string_of_repository r);
+ run Script.opam_init root r;
+ (* XXX *)
+ ()
+
+(* Generic repository pluggins *)
+let opam_update root r =
+ log "opam-update: %s" (string_of_repository r);
+ run Script.opam_update root r;
+ (* XXX *)
+ ()
+
+let opam_download root r =
+ log "opam-download: %s" (string_of_repository r);
+ run Script.opam_download root r;
+ (* XXX *)
+ ()
+
+let opam_upload root r =
+ log "opam-upload: %s" (string_of_repository r);
+ run Script.opam_upload root r;
+ (* XXX *)
+ ()
+
View
0  src/server.ml → src/server/server.ml
File renamed without changes
View
308 src/solver.ml
@@ -13,20 +13,14 @@
(* *)
(***********************************************************************)
-open ExtList
-open Namespace
+open Types
open Path
-open Server
-open Protocol
let log fmt = Globals.log "SOLVER" fmt
-type 'a installed_status =
- | Was_installed of 'a
- | Was_not_installed
-
module Parallel_fold =
struct
+
module type G =
sig
include Graph.Topological.G
@@ -36,119 +30,124 @@ struct
module type TOPOLOGICAL =
sig
- (* This module considers the graph to fold as a forest where the children of each node are topologically ordered after their parent. *)
+
+ (** This module considers the graph to fold as a forest where the
+ children of each node are topologically ordered after their
+ parent. *)
module G : G
+ module S : Set.S with type elt = G.V.t
- type 'a plist = 'a list (* nodes with minimal in-degree are proposed simultaneously *)
+ (** Optimized structure to get easily all the nodes with null
+ in-degree *)
type t
- val root : G.t -> t * G.V.t plist (** several proposed choices that can be considered in parallel *)
+ (** Create an optimized structure *)
+ val init: G.t -> t
+
+ (** Get the null in-degree nodes from the optimized structure *)
+ val roots: t -> S.t
+
+ (** [remove t n] removes the node [n] from [t] and returns the new
+ optimized structure. It raises [Invalid_argument _] if [n] is
+ neither a root node or if has already been visited *)
+ val remove : t -> G.V.t -> t
- (** [Invalid_argument _] in case the children of [G.V.t] has already been requested before. *)
- val children : t -> G.V.t (** answers that we have consumed *) -> t * G.V.t plist (* new choices resulting from the consumption that we can append with [root] or with any previous calls to [children] *)
end
module Make (G : G) : TOPOLOGICAL with module G = G = struct
- module H = Hashtbl.Make (G.V)
+ module V = struct include G.V let compare = compare end
+ module M = Map.Make (V)
+ module S = Set.Make (V)
+
module G = G
module IntSet = Set.Make (struct type t = int let compare = compare end)
type 'a plist = 'a list (* nodes with minimal in-degree are proposed simultaneously *)
- type t =
- { graph : G.t
- ; visited_node : IntSet.t (* [int] represents the hash of [G.V.t] *)
- ; queue_size : int
- ; degree : int H.t }
-
- let root graph =
- let degree = H.create 997 in
- let l, queue_size =
+ type t = {
+ graph : G.t ;
+ visited_node : IntSet.t ; (* [int] represents the hash of [G.V.t] *)
+ queue_size : int ;
+ roots : S.t ;
+ degree : int M.t ;
+ }
+
+ let roots t = t.roots
+
+ let init graph =
+ let degree = ref M.empty in
+ let add_degree v d = degree := M.add v d !degree in
+ let roots, queue_size =
G.fold_vertex
(fun v (todo, queue_size) ->
let d = G.in_degree graph v in
- if d = 0 then v :: todo, succ queue_size
- else let () = H.add degree v d in todo, queue_size)
+ if d = 0 then
+ S.add v todo, succ queue_size
+ else (
+ add_degree v d;
+ todo, queue_size
+ )
+ )
graph
- ([], 0) in
- { graph ; degree ; queue_size ; visited_node = IntSet.empty }, l
+ (S.empty, 0) in
+ { graph ; roots ; degree = !degree ; queue_size ; visited_node = IntSet.empty }
- let children t x =
- let t =
- if IntSet.mem (G.V.hash x) t.visited_node then
- invalid_arg "This node has already been visited."
- else
- { t with visited_node = IntSet.add (G.V.hash x) t.visited_node } in
- let t, l =
- (* simulate the removing of [x] and the adding of the children of [x] *)
- let l, queue_size =
- G.fold_succ
- (fun x (l, queue_size) ->
- try
- let d = H.find t.degree x in
- if d = 1 then
- let () = H.remove t.degree x in
- x :: l, succ queue_size
- else
- let () = H.replace t.degree x (d-1) in
- l, queue_size
- with Not_found ->
- (* [x] already visited *)
- l, queue_size)
- t.graph
- x
- ([], pred t.queue_size) in
- { t with queue_size }, l in
-
- match t.queue_size, l with
- | 0, [] ->
- (* let's find any nodes of minimal degree *)
- let min =
- H.fold
- (fun v d acc ->
- match acc with
- | None -> Some ([v], d)
- | Some (l, min) ->
- if d < min then
- Some ([v], d)
- else if d = min then
- Some (v :: l, min)
- else
- acc)
- t.degree
- None
- in
- let l =
- match min with
- | None -> []
- | Some (l, min) ->
- let () = List.iter (H.remove t.degree) l in
- l in
- { t with queue_size = List.length l }, l
- | _ -> t, l
+ let remove t x =
+ if IntSet.mem (G.V.hash x) t.visited_node then
+ invalid_arg "This node has already been visited.";
+ if not (S.mem x t.roots) then
+ invalid_arg "This node is not a root node";
+ (* Add the node to the list of visited nodes *)
+ let t = { t with visited_node = IntSet.add (G.V.hash x) t.visited_node } in
+ (* Remove the node from the list of root nodes *)
+ let roots = S.remove x t.roots in
+ let degree = ref t.degree in
+ let remove_degree x = degree := M.remove x !degree in
+ let replace_degree x d = degree := M.add x d (M.remove x !degree) in
+ (* Update the children of the node by decreasing by 1 their in-degree *)
+ let roots, queue_size =
+ G.fold_succ
+ (fun x (l, queue_size) ->
+ let d = M.find x t.degree in
+ if d = 1 then (
+ remove_degree x;
+ S.add x l, succ queue_size
+ ) else (
+ replace_degree x (d-1);
+ l, queue_size
+ ))
+ t.graph
+ x
+ (roots, pred t.queue_size) in
+ { t with queue_size; roots }
+
end
end
module Action =
struct
+ type 'a installed_status =
+ | Was_installed of 'a
+ | Was_not_installed
+
type 'a request =
{ wish_install : 'a list
- ; wish_remove : 'a list
+ ; wish_remove : 'a list
; wish_upgrade : 'a list }
type 'a action =
(* The package must be installed. The package could have been present or not,
but if present, it is another version than the proposed solution. *)
- | To_change of 'a installed_status * 'a
+ | To_change of 'a installed_status * 'a
(* The package must be deleted. *)
| To_delete of 'a
(* The package is already installed, but it must be recompiled. *)
- | To_recompile of 'a
+ | To_recompile of 'a
module NV_graph =
struct
@@ -156,7 +155,7 @@ struct
struct
type t =
{ cudf : Cudf.package
- ; action : name_version action }
+ ; action : NV.t action }
(* NOTE the field [action] currently does not need to contain a boolean sum type
(i.e. something isomorphic to [name_version action option] where [None] means an action not to perform)
because the graph containing all these nodes is composed of 2 parts :
@@ -172,20 +171,20 @@ struct
module PG = Graph.Imperative.Digraph.ConcreteBidirectional (PkgV)
module PG_topo = Graph.Topological.Make (PG)
- module PG_topo_para = Parallel_fold.Make (PG)
+(* module PG_topo_para = Parallel_fold.Make (PG) *)
end
type solution =
- { to_remove : name_version list
+ { to_remove : NV.t list
; to_add : NV_graph.PG.t }
- let action_map f = function
+ let map_action f = function
| To_change (Was_installed p1, p2) -> To_change (Was_installed (f p1), f p2)
| To_change (Was_not_installed, p) -> To_change (Was_not_installed, f p)
| To_delete p -> To_delete (f p)
| To_recompile p -> To_recompile (f p)
- let solution_print f t =
+ let print_solution f t =
let pf = Globals.msg in
if t.to_remove = [] && NV_graph.PG.is_empty t.to_add then
pf "No actions will be performed, the current state satisfies the request.\n"
@@ -393,8 +392,8 @@ module Solver : SOLVER = struct
let filter_dependencies f_direction pkg_l l_pkg_pb =
let pkg_map =
List.fold_left
- (fun map pkg -> NV_map.add (Namespace.nv_of_dpkg pkg) pkg map)
- NV_map.empty
+ (fun map pkg -> NV.Map.add (NV.of_dpkg pkg) pkg map)
+ NV.Map.empty
l_pkg_pb in
get_table l_pkg_pb
(fun table pkglist ->
@@ -419,61 +418,55 @@ module Solver : SOLVER = struct
else
set, l)
g (pkg_set, []) in
- List.map (fun pkg ->
- NV_map.find
- (Namespace.name_of_string pkg.Cudf.package,
- Namespace.version_of_string
- (Debian.Debcudf.get_real_version
- table
- (pkg.Cudf.package, pkg.Cudf.version))
- ) pkg_map) l)
+ List.map (fun pkg -> NV.Map.find (NV.of_cudf table pkg) pkg_map) l)
let filter_backward_dependencies = filter_dependencies (fun x -> x)
let filter_forward_dependencies = filter_dependencies PO.O.mirror
- open BatMap
-
let resolve l_pkg_pb req =
get_table l_pkg_pb
- (fun table pkglist ->
- let package_map pkg =
- Namespace.name_of_string pkg.Cudf.package,
- Namespace.version_of_string
- (Debian.Debcudf.get_real_version
- table
- (pkg.Cudf.package, pkg.Cudf.version)) in
- let universe = Cudf.load_universe pkglist in
-
- BatOption.bind
- (let cons pkg act = Some (pkg, act) in
- fun l ->
- let l_del_p, l_del =
- List.filter_map (function
- | To_change (Was_installed pkg, _)
- | To_delete pkg -> Some pkg
- | _ -> None) l,
- List.filter_map (function
- | To_delete pkg -> Some pkg
- | _ -> None) l in
-
- let map_add =
- PkgMap.of_list (List.filter_map (function
- | To_change (_, pkg) as act -> cons pkg act
+ (fun table pkglist ->
+ let package_map pkg = NV.of_cudf table pkg in
+ let universe = Cudf.load_universe pkglist in
+
+ match
+ CudfDiff.resolve_diff universe
+ (request_map
+ (fun x ->
+ match Debian.Debcudf.ltocudf table [x] with
+ | [x] -> x
+ | _ -> failwith "to complete !") req)
+ with
+ | Some l ->
+
+ let l_del_p, l_del =
+ Utils.filter_map (function
+ | To_change (Was_installed pkg, _)
+ | To_delete pkg -> Some pkg
+ | _ -> None) l,
+ Utils.filter_map (function
+ | To_delete pkg -> Some pkg
+ | _ -> None) l in
+
+ let map_add =
+ Utils.map_of_list PkgMap.empty PkgMap.add (Utils.filter_map (function
+ | To_change (_, pkg) as act -> Some (pkg, act)
| To_delete _ -> None
| To_recompile _ -> assert false) l) in
- let graph_installed =
- PO.O.mirror
- (dep_reduction
- (Cudf.get_packages
- ~filter:(fun p -> p.Cudf.installed || PkgMap.mem p map_add)
- universe)) in
-
- let graph_installed =
- let graph_installed = PG.copy graph_installed in
- let () = List.iter (PG.remove_vertex graph_installed) l_del_p in
- graph_installed in
- let _, map_act =
+ let graph_installed =
+ PO.O.mirror
+ (dep_reduction
+ (Cudf.get_packages
+ ~filter:(fun p -> p.Cudf.installed || PkgMap.mem p map_add)
+ universe)) in
+
+ let graph_installed =
+ let graph_installed = PG.copy graph_installed in
+ List.iter (PG.remove_vertex graph_installed) l_del_p;
+ graph_installed in
+
+ let _, map_act =
let open NV_graph.PkgV in
PG_topo.fold
(fun pkg (set_recompile, l_act) ->
@@ -483,7 +476,7 @@ module Solver : SOLVER = struct
List.fold_left
(fun set x -> PkgSet.add x set) set (PG.succ graph_installed pkg)
with _ -> set),
- IntMap.add (PG.V.hash pkg) { cudf = pkg ; action = action_map package_map act } l_act in
+ Utils.IntMap.add (PG.V.hash pkg) { cudf = pkg ; action = map_action package_map act } l_act in
match PkgMap.Exceptionless.find pkg map_add with
| Some act ->
@@ -495,35 +488,28 @@ module Solver : SOLVER = struct
set_recompile, l_act)
graph_installed
- (PkgSet.empty, IntMap.empty) in
- let graph = NV_graph.PG.create () in
- let () =
- begin
- IntMap.iter (fun _ -> NV_graph.PG.add_vertex graph) map_act;
- PG.iter_edges
- (fun v1 v2 ->
- match
- IntMap.Exceptionless.find (PG.V.hash v1) map_act,
- IntMap.Exceptionless.find (PG.V.hash v2) map_act
- with
- | Some v1, Some v2 -> NV_graph.PG.add_edge graph v1 v2
- | _ -> ())
- graph_installed;
- end in
- Some { to_remove = List.rev_map package_map l_del ; to_add = graph })
-
- (CudfDiff.resolve_diff universe
- (request_map
- (fun x ->
- match Debian.Debcudf.ltocudf table [x] with
- | [x] -> x
- | _ -> failwith "to complete !") req)))
+ (PkgSet.empty, Utils.IntMap.empty) in
+ let graph = NV_graph.PG.create () in
+ Utils.IntMap.iter (fun _ -> NV_graph.PG.add_vertex graph) map_act;
+ PG.iter_edges
+ (fun v1 v2 ->
+ try
+ let v1 = Utils.IntMap.find (PG.V.hash v1) map_act in
+ let v2 = Utils.IntMap.find (PG.V.hash v2) map_act in
+ NV_graph.PG.add_edge graph v1 v2
+ with Not_found ->
+ ())
+ graph_installed;
+ Some { to_remove = List.rev_map package_map l_del ; to_add = graph }
+
+ | None -> None)
+
end
let filter_backward_dependencies = Graph.filter_backward_dependencies
let filter_forward_dependencies = Graph.filter_forward_dependencies
let resolve = Graph.resolve
- let resolve_list pkg = List.filter_map (resolve pkg)
+ let resolve_list pkg = Utils.filter_map (resolve pkg)
let delete_or_update t =
t.to_remove <> []
View
26 src/types.ml
@@ -55,6 +55,7 @@ module NV : sig
val version: t -> V.t
val create: N.t -> V.t -> t
val of_dpkg: Debian.Packages.package -> t
+ val of_cudf: Debian.Debcudf.tables -> Cudf.package -> t
end = struct
type t = {
@@ -81,6 +82,14 @@ end = struct
{ name = N.of_string d.Debian.Packages.name;
version = V.of_string d.Debian.Packages.version }
+ let of_cudf table pkg =
+ let real_version =
+ Debian.Debcudf.get_real_version
+ table
+ (pkg.Cudf.package, pkg.Cudf.version) in
+ { name = N.of_string pkg.Cudf.package;
+ version = V.of_string real_version; }
+
let to_string t =
Printf.sprintf "%s%c%s" (N.to_string t.name) sep (V.to_string t.version)
@@ -91,14 +100,13 @@ end = struct
end
(** OPAM repositories *)
-module R : Abstract = Base
-
-
-
-
-
-
-
-
+type repository = {
+ repo_name: string;
+ repo_kind: string;
+}
+let string_of_repository r =
+ Printf.sprintf "%s(%s)" r.repo_name r.repo_kind
+(** Variable names *)
+module Variable : Abstract = Base
View
28 src/utils.ml
@@ -0,0 +1,28 @@
+(***********************************************************************)
+(* *)
+(* Copyright 2012 OCamlPro *)
+(* Copyright 2012 INRIA *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Public License version 3.0. *)
+(* *)
+(* TypeRex is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(***********************************************************************)
+
+let filter_map f l =
+ let rec loop accu = function
+ | [] -> List.rev accu
+ | h :: t ->
+ match f h with
+ | None -> loop accu t
+ | Some x -> loop (x::accu) t in
+ loop [] l
+
+let map_of_list empty add l =
+ List.fold_left (fun map (k,v) -> add k v map) empty l
+
+module IntMap = Map.Make(struct type t = int let compare = compare end)
Please sign in to comment.
Something went wrong with that request. Please try again.