(unless (throw-args-match (cdr expected) throw-args)
(error:handle (cons 'throw throw-args)))))))))
-;; (define-syntax paaqqck-forms
-;; (syntax-rules ()
-;; (_ <form>)
-;; )
-;; )
(define-syntax seal-clause
- (syntax-rules (=> !-->)
- ([_ <form> => <val> ...]
+ (syntax-rules (=> !--> ***)
+ ([_ f <args> ... *** <val>]
+ (seal-clause-expect-values (f <args> ...) (<val>)))
+ ([_ f <form> => <val> ...]
(seal-clause-expect-values <form> (<val> ...)))
- ([_ <form> !--> <val> ...]
+ ([_ f <form> !--> <val> ...]
(seal-clause-expect-throw <form> (<val> ...)))
- ([_ <form>]
+ ([_ f <form>]
(seal-clause-expect-values <form> (#t)))))
-;; (define-syntax seal-clause
-;; (syntax-rules (=> !-->)
-;; ((_ <form> => <val> <vals> ... )
-;; (let ((expected (cons 'values '(<val> <vals> ...))))
-;; 'CLAUSE-1
-;; (call-and-catch <form>
-;; (lambda args
-;; (unless (equal? args (cdr expected))
-;; (error:broken-seal '<form>
-;; expected
-;; (cons 'values args))))
-;; (lambda throw-args
-;; (error:broken-seal '<form>
-;; expected
-;; (cons 'throw throw-args))))))
-;; ((_ <form> <forms> ... => <val> <vals> ...)
-;; (seal-clause (<form> <forms> ...) => <val> <vals> ...))
-;; ((_ <form> !--> <val> ...)
-;; (let ((expected (cons 'throw '(<val> ...))))
-;; 'CLAUSE-2
-;; (call-and-catch <form>
-;; (lambda args
-;; (error:broken-seal '<form>
-;; (append expected '(....))
-;; (cons 'values args)))
-;; (lambda throw-args
-;; (unless (and (<= (length (cdr expected)) (length throw-args))
-;; (every equal? (cdr expected) throw-args))
-;; (error:broken-seal '<form>
-;; (append expected '(....))
-;; (cons 'throw throw-args)))))))
-;; ((_ <form> ... !--> <val> <vals> ...)
-;; #f
-;; ;; (let ('CLAUSE-X)
-;; ;; (seal-clause (<form> ...) !--> <val> ...))
-;; )
-;;; ((_ <form> ...) (seal-clause <form> ... => #t))
-;; ((_ obj ...)
-;; (error "Macro seal-clause usage:
-;; Assert, that evaluation of EXPR returns value(s).
-;; (seal-clause expr => value [values])
-;; Assert, that evaluation of EXPR is #t
-;; (seal-clause expr)
-;; Assert, that evaluation of EXPR throws with argument list, starting with value(s)
-;; (seal-clause expr --> value [values])
-;; In particular, (seal-clause expr -->) asserts, that EXPR throws something."))
-
-;; ))
-
-
(define-syntax sealed
(lambda (env)
(syntax-case env ()
(load-self-once)
(let ((& f))
(format #t "Checking seals with & = ~a... " 'f)
- (seal-clause obj ...) ...
+ (seal-clause f obj ...) ...
(format #t "ok\n"))))))))
;;; Currently, I have no idea how control compability of macroses.
;; Code:
(define-module (thales solver)
- :export (perform-solve generate-r1-contrain-solver))
+ :export (
+ perform-solve
+ generate-r1-contrain-solver
+ resolve-major-versions
+ make-version
+ version-compatible?
+ make-version*))
(use-modules (ice-9 match))
(use-modules (srfi srfi-1))
(use-modules (thales seal))
(use-modules (srfi srfi-26))
(use-modules (thales syntax))
+(use-modules (srfi srfi-9))
+
+
+(define-record-type <version>
+ (make-version major minor micro)
+ version?
+ (major major)
+ (minor minor)
+ (micro micro))
+(define* (make-version* #:optional (major 0) (minor 0) (micro 0))
+ (make-version major minor micro))
+
+(eval-when (load compile eval)
+ (read-hash-extend #\v
+ (lambda (ch stream)
+ (cons 'make-version* (read stream)))))
+
(sealed version-compatible?
- ([& '(1 2) '(1 2 0)] => #t)
- ([& '(1 2 3) '(1 2 2)] => #t))
-
-(define (version-compatible? v1 v2)
- "Version is compatible, if major versions is equal
-and minor is no less."
- (and (= (car v1) (car v2))
- (<= (cadr v1) (cadr v2))))
-(define-match (version-interchangeble? [major1 minor1 _ ...]
- [major2 minor2 _ ...])
+ (#v(1 1 3) #v(1 2 2) *** #t)
+ (#v(1 2 3) #v(3 2 1) *** #f))
+
+(define-match (version-compatible? [$ <version> major1 minor1 micro1]
+ [$ <version> major2 minor2 micro2])
+ (and (= major1 major2)
+ (<= minor1 minor2)))
+
+(sealed version-interchangeble?
+ (#v(1 2 3) #v(1 2 4) *** #t)
+ (#v(1 2 3) #v(1 3 0) *** #f))
+
+(define-match (version-interchangeble? [$ <version> major1 minor1]
+ [$ <version> major2 minor2])
(and (= major1 major2)
- (= minor1 minor2)))
+ (= minor1 minor2)))
+
+(define-record-type <constrain>
+ (make-constrain type name versions)
+ constrain?
+ (type constrain-type)
+ (name constrain-name)
+ (versions constrain-versions))
+(define* (make-constrain* type name #:rest versions)
+ (make-constrain type name versions))
+
+(define-record-type <package>
+ (make-package name version dependencies)
+ package?
+ (name package-name)
+ (version package-version)
+ (dependencies package-dependencies))
+
+(define* (make-package* name version #:rest dependencies)
+ (make-package name version dependencies))
(sealed satisfy
- [(& '(foo ? (1 0))
- '(foo (1 0 0)))
- => #t]
- [(& '(foo ? (2 0))
- '(foo (1 2 3)))
+ [(make-constrain* #:match 'foo #v(1))
+ (make-package* 'foo #v(1 2 0)) *** #t]
+ [(& (make-constrain* #:match 'foo #v(2 0))
+ (make-package* 'foo #v(1 2 3)))
=> #f]
- [(& '(foo ? (1 0))
- '(foo (1 2 3)))
+ [(& (make-constrain* #:match 'foo #v(1 0))
+ (make-package* 'foo #v(1 2 3)))
=> #t]
- [(& '(foo ? (1 0) (2 0))
- '(foo (1 2 3)))
+ [(& (make-constrain* #:match 'foo
+ #v(1 0)
+ #v(2 0))
+ (make-package* 'foo #v(1 2 3)))
=> #t]
- [(& '(foo = (1 2 3))
- '(foo (1 2 3)))
+ [(& (make-constrain* #:rigid 'foo #v(1 2 3))
+ (make-package* 'foo #v(1 2 3)))
=> #t]
- [(& '(foo = (1 2 4) (1 2 7))
- '(foo (1 2 5)))
+ [(& (make-constrain* #:rigid 'foo
+ #v(1 2 4)
+ #v(1 2 7))
+ (make-package* 'foo #(1 2 5)))
=> #f])
-(define version-equal? equal?)
+(define-match (satisfy [$ <constrain> constr-type constr-name constr-versions]
+ [$ <package> pkg-name pkg-version _])
+ (define version-comparator (case constr-type
+ [(#:rigid) equal?]
+ [(#:match) version-compatible?]))
+ (if (eq? constr-name pkg-name)
+ (any #[version-comparator <> pkg-version] constr-versions)
+ #f))
-(define-match (satisfy [?pkgname *cmp* ?versions ...]
- [pkgname pkg-version _ ...])
- (let ((cmp (case *cmp*
- [(?) version-compatible?]
- [(=) version-equal? ])))
- (and (eq? pkgname ?pkgname)
- (any #[cmp <> pkg-version] ?versions))))
(define* (generate-r1-contrain-solver installed availible
#:key (conservative #f))
by list of INSTALLED packages, if CONSERVATIVE is #f.
"
(let* ((cache (make-hash-table))
- (cache-get #[hash-ref cache <>])
- (cache-put #[hash-set! cache <> <>]))
- (lambda (constr)
+ (cache-get #[hash-ref cache])
+ (cache-put #[hash-set! cache]))
+ (lambda* (constr #:optional major-only)
(or (cache-get constr)
- (let ((result (filter #[satisfy constr <>] availible)))
+ (let ((result (filter #[satisfy constr] availible)))
(cache-put constr result)
result)))))
-(define* (perform-solve installed availible constrains
- #:key (conservative #f))
- "Resolve CONSTRAINS with AVAILIBLE packages.
+(sealed enumerate-list-combinations
+ ([& '((1 2))] => '((1) (2)))
+ ([& '((1 2) (3 4))] => '((1 3) (1 4) (2 3) (2 4))))
+
+(define-match (enumerate-list-combinations (head rest ...))
+ "Enumerate list combinations.
+
+FIXME: EXTREMELY INEFFICENT
+"
+ (if (null? rest)
+ (map list head)
+ (let ((recursive-processed (enumerate-list-combinations rest)))
+ (concatenate (map (lambda (arg)
+ (map #[cons arg] recursive-processed))
+ head)))))
+
+(sealed package-duplicate?
+ ([& (make-package* 'foo (make-version* 1 2))
+ (make-package* 'foo (make-version* 1 4))]
+ => #t))
+
+(define-match (package-duplicate? [$ <package> name1 [$ <version> major1]]
+ [$ <package> name2 [$ <version> major2]])
+ (if (eq? name1 name2)
+ (or (= major1 major2) (throw 'conflict))
+ #f))
+
+
+(eval-when (compile)
+ (define foo-102 (make-package* 'foo (make-version* 1 0 2)))
+ (define bar-201 (make-package* 'bar (make-version* 2 0 1)))
+ (define quaz-123 (make-package* 'quaz (make-version* 1 2 3))))
+
+;; (sealed optimize-pkglist
+;; ([& (list foo-102 bar-201)
+;; '()]
+;; => '())
+;; ([& (list foo-102 bar-201)
+;; (list foo-102 quaz-123)]
+;; => (list quaz-123)))
+
+;; (sealed optimize-pkglist
+;; ([& '((foo (1 0 2))
+;; (bar (2 0 1)))
+;; '((quaz (1 2 3))
+;; (foo (1 0 3)))]
+;; => '((quaz (1 2 3))))
+
+;; ([& '() '((foo (1 0 0)))]
+;; => '((foo (1 0 0))))
+
+;; ([& '((foo (1 0 2)))
+;; '((foo (2 1 2)))]
+;; => #f))
+
+;; Return list of packages in NEW, but not in STABLE. If packages in stable
+;; STABLE and NEW in union conflict, return #f.
+(define (optimize-pkglist stable new)
+ (catch 'conflict
+ (let iterate-new-packages ((result '())
+ (used stable)
+ (new new))
+ (if (null? new) result
+ (let ((current (car new))
+ (rest (cdr new)))
+ (if (any #[package-duplicate? current] used)
+ (iterate-new-packages result used rest)
+ (iterate-new-packages (cons current result)
+ (cons current used)
+ rest)))))
+ (const #f)))
+
+;; (define-match (iterate-new-packages result used
+;; (new:head new:rest ...))
+;; (if (any #[package-duplicate? new:head] used)
+;; (if (null? new:rest) result
+;; (iterate-new-packages result used new:rest))
+
+;; )
+;; )
+
+;; (let iterate-new-packages ((result '())
+;; (new new)
+;; (used stable))
+;; (match new
+
+;; )
+;; (if (null? new) result
+;; (if (any package-duplicate?))
+
+;; )
+
+;; )
+
+;; (define-match (duplicate? [$ <package> new-name
+;; [$ <version> new-major]])
+;; ;; Return #t if exists packages of same name and major version in STABLE,
+;; ;; throw 'conflict, if major versions do not match and #f otherwise.
+;; (define-match (pair-pkg-duplicate? [$ <package> pkg-name
+;; [$ <version> pkg-major]])
+;; (if (eq? pkg-name new-name)
+;; (or (= pkg-major new-major) (throw 'conflict))
+;; #f))
+;; (if (null? stable) #f
+;; (any pair-pkg-duplicate? stable)))
+;; (catch 'conflict #[filter (negate duplicate?) new] (const #f))
+
+;; (define (resolve-major-versions major-resolver constrains proposed)
+;; (define enum/list enumerate-list-combinations)
+;; (define possible-pkg-solutions ;; ((pkg))
+;; (filter-map (compose #[optimize-pkglist proposed] major-resolver)
+;; constrains))
+;; (define (pkg->depend-lists pkg)
+;; (cddr pkg)) ;; ((constr))
+;; (newline)
+;; (display possible-pkg-solutions)
+;; (newline)
+;; (newline)
+;; (display (car possible-pkg-solutions))
+;; (newline)
+;; (display (enum/list (map pkg->depend-lists (car possible-pkg-solutions))))
+;; (newline)
+;; (for (solution in possible-pkg-solutions)
+;; (for (next-constrains in (enum/list (map pkg->depend-lists solution)))
+;; (if (null? next-constrains)
+;; (throw 'found-result (cons solution proposed)))))
+;; #f)
+
-If CONSERVATIVE if #t, prefer use of INSTALLED packages, otherwise prefer
-new versions.
+;; (define* (perform-solve installed availible constrains
+;; #:key (conservative #f))
+;; "Resolve CONSTRAINS with AVAILIBLE packages.
-CONSTRAINS is list of constrains, that have following kinds:
+;; If CONSERVATIVE if #t, prefer use of INSTALLED packages, otherwise prefer
+;; new versions.
- * Ridid request for specified package. To be used, if bug happens
- and dependency have to be resolved manually.
- (<pkg-name> = (<major> <minor> <micro>) ...)
- * Request for package version, no less that specified.
- (<pkg-name> ? (<major> <minor>) ... )
+;; CONSTRAINS is list of constrains, that have following kinds:
-Both INSTALLED and AVAILIBLE are lists of package in form
- (<pkg-name> (<major> <minor> <micro>) <constrains>)
-where <constrains> are never rigid."
+;; * Ridid request for specified package. To be used, if bug happens
+;; and dependency have to be resolved manually.
+;; (<pkg-name> = (<major> <minor> <micro>) ...)
+;; * Request for package version, no less that specified.
+;; (<pkg-name> ? (<major> <minor>) ... )
-#f
-)
+;; Both INSTALLED and AVAILIBLE are lists of package in form
+;; (<pkg-name> (<major> <minor> <micro>) <constrains> ... )
+;; where <constrains> are never rigid."
+;; #f
+;; )
projects / irc / thales.git / commitdiff
