+++ /dev/null
-(define-module (thales core-modules)
- #:export (guile-provides?))
-
-(define (guile-provides? modname)
- (and (member modname *guile-core-modules*)
- 'guile))
-
-(define *guile-core-modules* '((value-history) ;; ??
- (guile)
- (ice-9 peg cache)
- (ice-9 peg using-parsers)
- (ice-9 peg string-peg)
- (ice-9 peg codegen)
- (ice-9 peg simplify-tree)
- (ice-9 time)
- (ice-9 list)
- (ice-9 iconv)
- (ice-9 slib)
- (ice-9 poe)
- (ice-9 compile-psyntax)
- (ice-9 quasisyntax)
- (ice-9 arrays)
- (ice-9 pretty-print)
- (ice-9 posix)
- (ice-9 ls)
- (ice-9 history)
- (ice-9 hcons)
- (ice-9 null)
- (ice-9 receive)
- (ice-9 r5rs)
- (ice-9 top-repl)
- (ice-9 occam-channel)
- (ice-9 stack-catch)
- (ice-9 safe)
- (ice-9 syncase)
- (ice-9 boot-9)
- (ice-9 mapping)
- (ice-9 threads)
- (ice-9 test)
- (ice-9 rw)
- (ice-9 i18n)
- (ice-9 getopt-long)
- (ice-9 optargs)
- (ice-9 curried-definitions)
- (ice-9 control)
- (ice-9 local-eval)
- (ice-9 poll)
- (ice-9 vlist)
- (ice-9 lineio)
- (ice-9 scm-style-repl)
- (ice-9 rdelim)
- (ice-9 weak-vector)
- (ice-9 string-fun)
- (ice-9 command-line)
- (ice-9 binary-ports)
- (ice-9 futures)
- (ice-9 deprecated)
- (ice-9 regex)
- (ice-9 match)
- (ice-9 psyntax)
- (ice-9 format)
- (ice-9 match.upstream)
- (ice-9 debug)
- (ice-9 and-let-star)
- (ice-9 documentation)
- (ice-9 popen)
- (ice-9 psyntax-pp)
- (ice-9 peg)
- (ice-9 eval)
- (ice-9 channel)
- (ice-9 session)
- (ice-9 calling)
- (ice-9 runq)
- (ice-9 networking)
- (ice-9 r6rs-libraries)
- (ice-9 eval-string)
- (ice-9 safe-r5rs)
- (ice-9 serialize)
- (ice-9 streams)
- (ice-9 buffered-input)
- (ice-9 gap-buffer)
- (ice-9 expect)
- (ice-9 save-stack)
- (ice-9 ftw)
- (ice-9 common-list)
- (ice-9 q)
- (language value spec)
- (language glil spec)
- (language glil compile-assembly)
- (language ecmascript array)
- (language ecmascript tokenize)
- (language ecmascript compile-tree-il)
- (language ecmascript spec)
- (language ecmascript function)
- (language ecmascript impl)
- (language ecmascript parse)
- (language ecmascript base)
- (language bytecode spec)
- (language elisp runtime function-slot)
- (language elisp runtime value-slot)
- (language elisp falias)
- (language elisp compile-tree-il)
- (language elisp parser)
- (language elisp spec)
- (language elisp bindings)
- (language elisp lexer)
- (language elisp runtime)
- (language cps compile-rtl)
- (language cps contification)
- (language cps spec)
- (language cps reify-primitives)
- (language cps primitives)
- (language cps closure-conversion)
- (language cps dfg)
- (language cps slot-allocation)
- (language cps arities)
- (language cps verify)
- (language scheme compile-tree-il)
- (language scheme spec)
- (language scheme decompile-tree-il)
- (language tree-il inline)
- (language tree-il peval)
- (language tree-il fix-letrec)
- (language tree-il canonicalize)
- (language tree-il compile-cps)
- (language tree-il cse)
- (language tree-il spec)
- (language tree-il primitives)
- (language tree-il analyze)
- (language tree-il debug)
- (language tree-il optimize)
- (language tree-il effects)
- (language tree-il compile-glil)
- (language objcode elf)
- (language objcode spec)
- (language rtl spec)
- (language assembly spec)
- (language assembly compile-bytecode)
- (language assembly decompile-bytecode)
- (language assembly disassemble)
- (language brainfuck compile-tree-il)
- (language brainfuck spec)
- (language brainfuck compile-scheme)
- (language brainfuck parse)
- (language objcode)
- (language rtl)
- (language glil)
- (language assembly)
- (language tree-il)
- (language cps)
- (oop goops active-slot)
- (oop goops compile)
- (oop goops simple)
- (oop goops stklos)
- (oop goops describe)
- (oop goops accessors)
- (oop goops save)
- (oop goops composite-slot)
- (oop goops dispatch)
- (oop goops util)
- (oop goops internal)
- (oop goops)
- (texinfo plain-text)
- (texinfo docbook)
- (texinfo indexing)
- (texinfo string-utils)
- (texinfo html)
- (texinfo reflection)
- (texinfo serialize)
- (web server http)
- (web client)
- (web server)
- (web uri)
- (web http)
- (web request)
- (web response)
- (scripts help)
- (scripts snarf-check-and-output-texi)
- (scripts list)
- (scripts lint)
- (scripts read-text-outline)
- (scripts compile)
- (scripts read-scheme-source)
- (scripts display-commentary)
- (scripts generate-autoload)
- (scripts use2dot)
- (scripts frisk)
- (scripts doc-snarf)
- (scripts read-rfc822)
- (scripts summarize-guile-TODO)
- (scripts api-diff)
- (scripts punify)
- (scripts snarf-guile-m4-docs)
- (scripts autofrisk)
- (scripts scan-api)
- (scripts disassemble)
- (system base compile)
- (system base ck)
- (system base syntax)
- (system base message)
- (system base language)
- (system base lalr.upstream)
- (system base target)
- (system base pmatch)
- (system base lalr)
- (system vm disassembler)
- (system vm vm)
- (system vm program)
- (system vm coverage)
- (system vm trap-state)
- (system vm objcode)
- (system vm frame)
- (system vm elf)
- (system vm linker)
- (system vm traps)
- (system vm inspect)
- (system vm assembler)
- (system vm debug)
- (system vm instruction)
- (system vm trace)
- (system repl server)
- (system repl common)
- (system repl repl)
- (system repl describe)
- (system repl command)
- (system repl debug)
- (system repl error-handling)
- (system xref)
- (system foreign)
- (sxml ssax input-parse)
- (sxml upstream assert)
- (sxml upstream SXPath-old)
- (sxml upstream input-parse)
- (sxml upstream SXML-tree-trans)
- (sxml upstream SSAX)
- (sxml simple)
- (sxml xpath)
- (sxml fold)
- (sxml match)
- (sxml ssax)
- (sxml transform)
- (sxml apply-templates)
- (srfi srfi-67 compare)
- (srfi srfi-42 ec)
- (srfi srfi-9 gnu)
- (srfi srfi-4 gnu)
- (srfi srfi-16)
- (srfi srfi-27)
- (srfi srfi-4)
- (srfi srfi-45)
- (srfi srfi-38)
- (srfi srfi-42)
- (srfi srfi-26)
- (srfi srfi-34)
- (srfi srfi-69)
- (srfi srfi-19)
- (srfi srfi-18)
- (srfi srfi-88)
- (srfi srfi-13)
- (srfi srfi-31)
- (srfi srfi-60)
- (srfi srfi-11)
- (srfi srfi-2)
- (srfi srfi-37)
- (srfi srfi-39)
- (srfi srfi-98)
- (srfi srfi-9)
- (srfi srfi-6)
- (srfi srfi-67)
- (srfi srfi-1)
- (srfi srfi-14)
- (srfi srfi-41)
- (srfi srfi-17)
- (srfi srfi-10)
- (srfi srfi-35)
- (srfi srfi-8)
- (rnrs records syntactic)
- (rnrs records inspection)
- (rnrs records procedural)
- (rnrs arithmetic flonums)
- (rnrs arithmetic bitwise)
- (rnrs arithmetic fixnums)
- (rnrs io ports)
- (rnrs io simple)
- (rnrs syntax-case)
- (rnrs bytevectors)
- (rnrs r5rs)
- (rnrs control)
- (rnrs conditions)
- (rnrs sorting)
- (rnrs hashtables)
- (rnrs mutable-pairs)
- (rnrs exceptions)
- (rnrs programs)
- (rnrs files)
- (rnrs unicode)
- (rnrs lists)
- (rnrs eval)
- (rnrs base)
- (rnrs mutable-strings)
- (rnrs enums)
- (statprof)
- (texinfo)
- (rnrs)))
+++ /dev/null
-;;; solver.scm --- Thales solver --- implementation of core idea
-
-;; Copyright (C) 2013 Dmitry Bogatov <KAction@gnu.org>
-
-;; Author: Dmitry Bogatov <KAction@gnu.org>
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License
-;; as published by the Free Software Foundation; either version 3
-;; of the License, or (at your option) any later version.
-
-;; This program 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Core idea of Thales is packages manager, that eliminates dependencies
-;;; hell. In generic case --- when every package version can depend
-;;; on arbitary set of packages and their version, solution of dependencies
-;;; is exponencial problem. So idea is strictly order package versions
-;;; according following rules:
-;;; * Any incompatible change allowed only with major version bump.
-;;; * Adding dependencly requires major version bump.
-;;; * Increase in minor version of dependency is do not require
-;;; major version bump.
-;;; * Relaxing dependencies do not require major version bump.
-;;; * Each package may alternatively depend on several major version
-;;; of package
-;;;
-;;; Most of these requirements are managed automatically by seals (see
-;;; seals.scm) and analysis of modules interfaces. Of course, if programmer
-;;; wants to screw things, he will be able to.
-
-;;; Currently, I have no idea how control compability of macroses.
-;; Code:
-(define-module (thales 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?
- (#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)))
-
-(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
- [(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]
- [(& (make-constrain* #:match 'foo #v(1 0))
- (make-package* 'foo #v(1 2 3)))
- => #t]
- [(& (make-constrain* #:match 'foo
- #v(1 0)
- #v(2 0))
- (make-package* 'foo #v(1 2 3)))
- => #t]
- [(& (make-constrain* #:rigid 'foo #v(1 2 3))
- (make-package* 'foo #v(1 2 3)))
- => #t]
- [(& (make-constrain* #:rigid 'foo
- #v(1 2 4)
- #v(1 2 7))
- (make-package* 'foo #(1 2 5)))
- => #f])
-
-(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* (generate-r1-contrain-solver installed availible
- #:key (conservative #f))
- "Return function, that will packages, that satisfy constrain.
-
-Function, given constrain, return list of packages, that satistfy it,
-taking only one version from each major version. Order of packages influenced
-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 #:optional major-only)
- (or (cache-get constr)
- (let ((result (filter #[satisfy constr] availible)))
- (cache-put constr result)
- result)))))
-
-(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)
-
-
-;; (define* (perform-solve installed availible constrains
-;; #:key (conservative #f))
-;; "Resolve CONSTRAINS with AVAILIBLE packages.
-
-;; If CONSERVATIVE if #t, prefer use of INSTALLED packages, otherwise prefer
-;; new versions.
-
-;; CONSTRAINS is list of constrains, that have following kinds:
-
-;; * 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>) ... )
-
-;; 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
