Commit 340ad4bc authored by Amirouche's avatar Amirouche

release 0.7.0

Notables changes:

- remove helpers and higher abstractions

- use guile-bytestructures

- procedures have no default parameters

- no more use of exceptions

- cursor-key-ref and cursor-value-ref return multiple values

- fix bug in cursor-search-near that was misinterpreting a 32 bit
  integer as a 64 bit integer
parent d66cac47
wiredtiger/config.scm
*~
*log
db
......
......@@ -5,26 +5,14 @@ TEST_EXTENSIONS = .scm
TESTS_UTILS = \
tests/helpers.scm
TESTS = tests/wiredtiger.scm \
tests/extra.scm \
tests/feature-space.scm \
tests/grf3.scm \
tests/ix.scm
TESTS = tests/wiredtiger.scm
SCM_LOG_COMPILER = $(GUILE)
AM_SCM_LOG_FLAGS = --no-auto-compile -L $(top_srcdir)
SOURCES = \
microkanren.scm \
wiredtiger/config.scm \
wiredtiger/wiredtiger.scm \
wiredtiger/extra.scm \
wiredtiger/feature-space.scm \
wiredtiger/grf3.scm \
wiredtiger/html2text.scm \
wiredtiger/ix.scm \
wiredtiger/plain.scm \
wiredtiger/text.scm
wiredtiger/wiredtiger.scm
EXTRA_DIST = \
README.md \
......
AC_INIT([guile-wiredtiger], [0.6.4])
AC_INIT([guile-wiredtiger], [0.7.0])
AC_CONFIG_SRCDIR([wiredtiger])
AC_CONFIG_AUX_DIR([build-aux])
AC_CONFIG_MACRO_DIR([m4])
......@@ -23,7 +23,7 @@ AC_ARG_WITH([libwiredtiger-prefix],
[case "$withval" in
yes|no)
;;
*)
*) # TODO: fix that
LIBWIREDTIGER="libwiredtiger"
LIBWIREDTIGER_PREFIX="$withval"
LIBWIREDTIGER_LIBDIR="$withval/lib"
......
;; microKanren
;;
;; Implementation based on microKanren compatible with GNU Guile
;;
;; Forked from https://github.com/amirouche/microKanren
;;
;; Copyright (C) 2013 Jason Hemann and Daniel P. Friedman
;; Copyright (C) 2015-2016 Amirouche Boubekki
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
;;
(define-module (microkanren))
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-26))
(define-public (var c) (vector c))
(define-public (var? x) (vector? x))
(define-public var=? equal?)
(define (assp proc alist)
"Return the first assoc from ALIST for which PROC return TRUE"
(let next ((alist alist))
(if (null? alist)
#false
(if (proc (caar alist))
(car alist)
(next (cdr alist))))))
(define-public (walk u s)
"Find U substitution in S"
(let ((pr (and (var? u) (assp (lambda (v) (var=? u v)) s))))
(if pr (walk (cdr pr) s) u)))
;; (acons x v substitutions)
;; ie. add `v substitue x` to the list of substituations
(define ext-s acons)
(define-public (== u v)
(lambda (s/c)
(let ((s (unify u v (car s/c))))
(if s (unit (cons s (cdr s/c))) mzero))))
(define-public (=/= u v)
(lambda (s/c)
(let ((u* (walk u (car s/c)))
(v* (walk v (car s/c))))
(pk u* v* s/c)
(if (equal? u* v*)
mzero
s/c))))
(define-public (unit s/c) (cons s/c mzero))
(define-public mzero '())
(define-public (unify u v s)
;; resolve U and V according to substitution S
(let ((u (walk u s)) (v (walk v s)))
;; unify if possible
(cond
;; U and V are variable and they are the same substitution
((and (var? u) (var? v) (var=? u v)) s)
;; U is a variable, substitute with V
((var? u) (ext-s u v s))
;; V is a variable, substitute with U
((var? v) (ext-s v u s))
;; both U and V are pairs, substitute recursively
((and (pair? u) (pair? v))
(let ((s (unify (car u) (car v) s)))
(and s (unify (cdr u) (cdr v) s))))
;; otherwise, substitutions is ok, if U and V are EQV?
(else (and (equal? u v) s)))))
(define (call/fresh f)
(lambda (s/c)
(let ((c (cdr s/c)))
((f (var c)) (cons (car s/c) (+ c 1))))))
(define-public (disj g1 g2) (lambda (s/c) (mplus (g1 s/c) (g2 s/c))))
(define-public (conj g1 g2) (lambda (s/c) (bind (g1 s/c) g2)))
(define (mplus $1 $2)
(cond
((null? $1) $2)
((procedure? $1) (lambda () (mplus $2 ($1))))
(else (cons (car $1) (mplus (cdr $1) $2)))))
(define (bind $ g)
(cond
((null? $) mzero)
((procedure? $) (lambda () (bind ($) g)))
(else (mplus (g (car $)) (bind (cdr $) g)))))
;;;; How to make a simple minikanren
(define-syntax Zzz
(syntax-rules ()
((_ g) (lambda (s/c) (lambda () (g s/c))))))
(define-syntax conj+
(syntax-rules ()
((_ g) (Zzz g))
((_ g0 g ...) (conj (Zzz g0) (conj+ g ...)))))
(export conj+)
(define-syntax disj+
(syntax-rules ()
((_ g) (Zzz g))
((_ g0 g ...) (disj (Zzz g0) (disj+ g ...)))))
(export disj+)
(define-syntax fresh
(syntax-rules ()
((_ () g0 g ...) (conj+ g0 g ...))
((_ (x0 x ...) g0 g ...)
(call/fresh
(lambda (x0)
(fresh (x ...) g0 g ...))))))
(export fresh)
(define-syntax conde
(syntax-rules ()
((_ (g0 g ...) ...) (disj+ (conj+ g0 g ...) ...))))
(export conde)
;; (define-syntax run
;; (syntax-rules ()
;; ((_ n (x ...) g0 g ...)
;; (map reify-1st (take n (call/goal (fresh (x ...) g0 g ...)))))))
;; (export run)
(define-syntax run*
(syntax-rules ()
((_ (x ...) g0 g ...)
(map reify-1st (take-all (call/goal (fresh (x ...) g0 g ...)))))))
(export run*)
(define empty-state '(() . 0))
(define (call/goal g) (g empty-state))
(define (pull $)
(if (procedure? $) (pull ($)) $))
(define (take-all $)
(let (($ (pull $)))
(if (null? $) '() (cons (car $) (take-all (cdr $))))))
(define (take n $)
(if (zero? n) '()
(let (($ (pull $)))
(if (null? $) '() (cons (car $) (take (- n 1) (cdr $)))))))
(define (reify-1st s/c)
(let ((v (walk* (var 0) (car s/c))))
(walk* v (reify-s v '()))))
(define (reify v s/c)
(let ((v (walk* v (car s/c))))
(walk* v (reify-s v '()))))
(define (walk* v s)
(let ((v (walk v s)))
(cond
((var? v) v)
((pair? v) (cons (walk* (car v) s)
(walk* (cdr v) s)))
(else v))))
(define (reify-s v s)
(let ((v (walk v s)))
(cond
((var? v)
(let ((n (reify-name (length s))))
(cons `(,v . ,n) s)))
((pair? v) (reify-s (cdr v) (reify-s (car v) s)))
(else s))))
(define (reify-name n)
(string->symbol
(string-append "_" "." (number->string n))))
(define (fresh/nf n f)
(letrec
((app-f/v*
(lambda (n v*)
(cond
((zero? n) (apply f (reverse v*)))
(else (call/fresh
(lambda (x)
(app-f/v* (- n 1) (cons x v*)))))))))
(app-f/v* n '())))
;;;
(define (run goal . vars)
(take-all
(call/goal (apply goal vars))))
;;;
(define-public (reify-all goal . names)
(let* ((vars (map var names))
(s/c (apply run (cons goal vars))))
(map (lambda (s) (map (cut reify <> s) vars)) s/c)))
(define-syntax-rule (run* (names ...) goal)
"sugar syntax for reify-all"
(reify-all (lambda (names ...) (fresh() goal))
'names ...))
(export run*)
;;;
(define-public (disj* . gs)
"disj+ procedure"
(if (null? gs) (lambda (s/c) '())
(disj (car gs) (apply disj* (cdr gs)))))
(define-public (conj* . gs)
"conj+ procedure"
(if (null? gs) (lambda (s/c) s/c)
(conj (car gs) (apply conj* (cdr gs)))))
(define-module (tests extra))
(use-modules (ice-9 receive))
(use-modules (tests helpers))
(use-modules (wiredtiger wiredtiger))
(use-modules (wiredtiger extra))
(setlocale LC_ALL "")
(test-begin)
;; test declarative API
(test-check "create table config without index"
(config-prepare-create '(atoms
((uid . record))
((assoc . bytes))
()))
(list (list "table:atoms" "key_format=r,value_format=u,columns=(uid,assoc)")))
(test-check "create table config with index and projections"
(config-prepare-create '(arrows
((key . record))
((start . unsigned-integer)
(end . unsigned-integer))
;; index
((outgoings (uid,start) (uid end))
(incomings (end) ()))))
(list (list "table:arrows" "key_format=r,value_format=QQ,columns=(key,start,end)")
(list "index:arrows:outgoings" "columns=(uid,start)")
(list "index:arrows:incomings" "columns=(end)")))
(test-check "create cursor config without index"
(config-prepare-open '(atoms
((uid . record))
((assoc . bytes))
()))
(list (list 'atoms (list "table:atoms"))
(list 'atoms-append (list "table:atoms" "append"))))
(test-check "create cursor config with index with and without projection"
(config-prepare-open '(atoms
((uid . record))
((assoc . bytes))
((reversex (assoc) (uid))
(reverse (assoc) ()))))
(list (list 'atoms (list "table:atoms"))
(list 'atoms-append (list "table:atoms" "append"))
(list 'atoms-reversex (list "index:atoms:reversex(uid)"))
(list 'atoms-reverse (list "index:atoms:reverse"))))
;; test star API
(test-check "wiredtiger-open*"
(receive (cnx ctx)
(wiredtiger-open* "wt"
'(table ((key . record)) ((value . integer)) ()))
(with-cnx cnx #true))
#true)
(test-check "cursor-insert* and cursor-search*"
(receive (cnx ctx)
(wiredtiger-open* "wt"
'(terms ((key . record)) ((value . unsigned-integer)) ()))
(with-cnx cnx
(let ((append (context-ref ctx 'terms-append)))
(cursor-insert* append #nil (list 42))
(cursor-insert* append #nil (list 1337))
(cursor-insert* append #nil (list 1985)))))
3)
(test-check "cursor-range 0"
(receive (cnx ctx) (wiredtiger-open* "wt" '(table ((k . record))
((v . integer))
((reversed (v) (k)))))
(with-cnx cnx
(cursor-range (context-ref ctx 'table-reversed) 42)))
'())
(test-check "cursor-range 1"
(receive (cnx ctx) (wiredtiger-open* "wt" '(table ((k . record))
((v . integer))
((reversed (v) (k)))))
(cursor-insert* (context-ref ctx 'table-append) #nil '(1))
(cursor-insert* (context-ref ctx 'table-append) #nil '(42))
(cursor-insert* (context-ref ctx 'table-append) #nil '(42))
(cursor-insert* (context-ref ctx 'table-append) #nil '(42))
(cursor-insert* (context-ref ctx 'table-append) #nil '(1))
(with-cnx cnx
(cursor-range (context-ref ctx 'table-reversed) 42)))
'((4) (3) (2)))
(test-check "cursor-range 2"
(receive (cnx ctx) (wiredtiger-open* "wt" '(table ((k . record))
((v . integer))
((reversed (v) (k)))))
(cursor-insert* (context-ref ctx 'table-append) #nil '(1))
(cursor-insert* (context-ref ctx 'table-append) #nil '(1))
(with-cnx cnx
(cursor-range (context-ref ctx 'table-reversed) 42)))
'())
(test-check "cursor-range 3"
(receive (cnx ctx) (wiredtiger-open* "wt" '(table ((k . record))
((v . integer))
((reversed (v) (k)))))
(cursor-insert* (context-ref ctx 'table-append) #nil '(1))
(cursor-insert* (context-ref ctx 'table-append) #nil '(42))
(cursor-insert* (context-ref ctx 'table-append) #nil '(1))
(with-cnx cnx
(cursor-range (context-ref ctx 'table-reversed) 42)))
'((2)))
(test-check "cursor-range-prefix"
(receive (cnx ctx)
(wiredtiger-open* "wt"
'(table ((a . integer) (b . integer)) ((c . integer)) ()))
(let ((cursor (context-ref ctx 'table)))
(cursor-insert* cursor (list 0 0) (list 0))
(cursor-insert* cursor (list 1 1) (list 1))
(cursor-insert* cursor (list 1 2) (list 1))
(cursor-insert* cursor (list 2 0) (list 2))
(with-cnx cnx
(cursor-range-prefix cursor 1 0))))
'(((1 2) 1)
((1 1) 1)))
(test-check "cursor-range-prefix 2"
(receive (cnx ctx)
(wiredtiger-open* "wt"
'(table ((a . integer) (b . integer)) ((c . integer)) ()))
(let ((cursor (context-ref ctx 'table)))
(cursor-insert* cursor (list 1 1) (list 1))
(cursor-insert* cursor (list 1 2) (list 1))
(cursor-insert* cursor (list 2 0) (list 2))
(with-cnx cnx
(cursor-range-prefix cursor 1 0))))
'(((1 2) 1)
((1 1) 1)))
(test-check "cursor-range-prefix 3"
(receive (cnx ctx)
(wiredtiger-open* "wt"
'(table ((a . integer) (b . integer)) ((c . integer)) ()))
(let ((cursor (context-ref ctx 'table)))
(cursor-insert* cursor (list 2 0) (list 2))
(with-cnx cnx
(cursor-range-prefix cursor 1 0))))
'())
(test-check "cursor-range-prefix 3"
(receive (cnx ctx)
(wiredtiger-open* "wt"
'(table ((a . integer) (b . integer)) ((c . integer)) ()))
(let ((cursor (context-ref ctx 'table)))
(cursor-insert* cursor (list 0 0) (list 0))
(with-cnx cnx
(cursor-range-prefix cursor 1 0))))
'())
(test-check "cursor-range-prefix 4"
(receive (cnx ctx)
(wiredtiger-open* "wt"
'(table ((a . integer) (b . integer)) ((c . integer)) ()))
(let ((cursor (context-ref ctx 'table)))
(cursor-insert* cursor (list 0 0) (list 0))
(cursor-insert* cursor (list 1 0) (list 0))
(cursor-insert* cursor (list 1 1) (list 1))
(cursor-insert* cursor (list 1 2) (list 1))
(cursor-insert* cursor (list 2 0) (list 2))
(with-cnx cnx
(cursor-range-prefix cursor 1 0))))
'(((1 2) 1)
((1 1) 1)
((1 0) 0)))
(test-check "cursor-range-prefix 5"
(receive (cnx ctx)
(wiredtiger-open* "wt"
'(table ((a . integer) (b . integer)) ((c . integer)) ()))
(let ((cursor (context-ref ctx 'table)))
(cursor-insert* cursor (list 0 0) (list 0))
(cursor-insert* cursor (list 1 0) (list 0))
(cursor-insert* cursor (list 1 1) (list 1))
(cursor-insert* cursor (list 1 2) (list 1))
(with-cnx cnx
(cursor-range-prefix cursor 1 0))))
'(((1 2) 1)
((1 1) 1)
((1 0) 0)))
(test-check "cursor with empty range-prefix"
(receive (cnx ctx)
(wiredtiger-open* "wt"
'(table ((a . integer) (b . integer)) ((c . integer)) ()))
(let ((cursor (context-ref ctx 'table)))
(with-cnx cnx
(cursor-range-prefix cursor 1 0))))
'())
(test-check "cursor-value-ref* on empty table"
(receive (cnx ctx)
(wiredtiger-open* "wt"
'(table ((a . integer) (b . integer)) ((c . integer)) ()))
(let ((cursor (context-ref ctx 'table)))
(with-cnx cnx
(catch 'wiredtiger
(lambda ()
(cursor-value-ref* cursor 42))
(lambda (key . args)
#true)))))
#true)
(test-check "with-context"
(let ((env (env-open "wt" "create")))
(env-config-add env '(counter ((name . string)) ((value . integer)) ()))
(env-create env)
(let ((cnx (env-connection env)))
(with-cnx cnx
(with-context env
(call-with-cursor 'counter
(lambda (cursor)
(cursor-insert* cursor (list "counter") (list 42)))))
(with-context env
(call-with-cursor 'counter
(lambda (cursor)
(cursor-value-ref* cursor "counter")))))))
'(42))
(test-end)
(define-module (tests feature-space))
(use-modules (tests helpers))
(use-modules (wiredtiger wiredtiger))
(use-modules (wiredtiger extra))
(use-modules (wiredtiger feature-space))
(use-modules (microkanren))
(test-begin)
(test-check "open feature-space database"
(with-env (env-open* "wt" (list *feature-space*) "create")
42)
42)
(test-check "fs:find"
(with-env (env-open* "wt" (list *feature-space*) "create")
(fs:add! '((a . 42) (b . 1337)))
(fs:add! '((a . 0) (c . 1337)))
(length (fs:find 'b 1337)))
1)
(test-check "fs:remove!"
(with-env (env-open* "wt" (list *feature-space*) "create")
(fs:remove! (fs:add! '((a . 42) (b . 1337))))
(length (fs:find 'b 1337)))
0)
(test-check "fs:update!"
(with-env (env-open* "wt" (list *feature-space*) "create")
(fs:update! (fs:add! '((a . 42) (b . 1337))) '((a . 42)))
(length (fs:find 'b 1337)))
0)
(test-check "fs:query"
(with-env (env-open* "wt" (list *feature-space*) "create")
(fs:add! '((a . 42) (b . 1337)))
(fs:add! '((a . 0) (c . 1337)))
(length (fs:query uid? fs:where ((uid? 'a 42)))))
1)
(test-check "fs:query2"
(with-env (env-open* "wt" (list *feature-space*) "create")
(fs:add! '((a . 42) (b . 1337)))
(fs:add! '((a . 0) (c . 1337)))
(length (fs:query uid? fs:where ((uid? 'a 42) (uid? 'b 1337)))))
1)
(test-check "fs:query3"
(with-env (env-open* "wt" (list *feature-space*) "create")
(fs:add! '((a . 42) (b . 1337)))
(fs:add! '((a . 0) (c . 1337)))
(length (fs:query uid? fs:where ((uid? 'a 42) (uid? 'b 42)))))
0)
(test-check "fs:query4"
(with-env (env-open* "wt" (list *feature-space*) "create")
(let* ((concept/fruit (fs:add! (list '(name . "fruit"))))
(concept/strawberry (fs:add! (list '(name . "strawberry"))))
(concept/fig (fs:add! (list '(name . "fig"))))
(link/strawberry-is-a-good-fruit (fs:add! (list `(from . ,concept/strawberry)
`(name . "is good")
`(to . ,concept/fruit))))
(link/fig-is-a-good-fruit (fs:add! (list `(from . ,concept/fig)
`(name . "is good")
`(to . ,concept/fruit)))))
(define (what-is-a-good concept/name)
(map car (fs:query name-of-a-good-fruit?
fs:where ((concept?? 'name concept/name)
(link?? 'to concept??)
(link?? 'name "is good")
(link?? 'from a-fruit-that-is-good??)
(a-fruit-that-is-good?? 'name name-of-a-good-fruit?)))))
(sort (what-is-a-good "fruit") string<)))
'("fig" "strawberry"))
(test-check "microkanren fs:queryo"
(with-env (env-open* "wt" (list *feature-space*) "create")
;; fixture
(let* ((concept/fruit (fs:add! (list '(name . "fruit"))))
(concept/strawberry (fs:add! (list '(name . "strawberry"))))
(concept/fig (fs:add! (list '(name . "fig"))))
(link/strawberry-is-a-good-fruit (fs:add! (list `(from . ,concept/strawberry)
`(name . "is good")
`(to . ,concept/fruit))))
(link/fig-is-a-good-fruit (fs:add! (list `(from . ,concept/fig)
`(name . "is good")
`(to . ,concept/fruit)))))
;; execute query
(sort (map car
(run* (name?)
(fresh (concept?? link?? a-fruit-that-is-good??)
(fs:queryo concept?? 'name "fruit")
(fs:queryo link?? 'to concept??)
(fs:queryo link?? 'name "is good")
(fs:queryo link?? 'from a-fruit-that-is-good??)
(fs:queryo a-fruit-that-is-good?? 'name name?))))
string<)))
'("fig" "strawberry"))
(test-end)
(define-module (tests grf3))
(use-modules (tests helpers))
(use-modules (ice-9 receive))
(use-modules (srfi srfi-26))
(use-modules (wiredtiger wiredtiger))
(use-modules (wiredtiger extra))
(use-modules (wiredtiger feature-space))
(use-modules (wiredtiger grf3))
(test-begin)
(test-check "open database"
(with-env (env-open* "wt" (list *feature-space*) "create")
42)
42)
(test-check "create vertex"
(with-env (env-open* "wt" (list *feature-space*) "create")
(let ((vertex (create-vertex '((a . 42)))))
(vertex-ref (get (vertex-uid vertex)) 'a)))
42)
(test-check "create edge"
(with-env (env-open* "wt" (list *feature-space*) "create")
(let* ((start (create-vertex '()))
(end (create-vertex '()))
(edge (create-edge start end '((a . 42)))))
(edge-ref (get (edge-uid edge)) 'a)))
42)
(test-check "get unknown element"
(with-env (env-open* "wt" (list *feature-space*) "create")
(get "FOOBAR"))
#false)
(test-check "get-or-create-vertex new true"
(with-env (env-open* "wt" (list *feature-space*) "create")
(receive (new vertex) (get-or-create-vertex 'a 42)
new))
#true)
(test-check "get-or-create-vertex new false"
(with-env (env-open* "wt" (list *feature-space*) "create")
(receive (new vertex) (get-or-create-vertex 'a 42)
(receive (new vertex) (get-or-create-vertex 'a 42)
new)))
#false)
(test-check "save vertex"
(with-env (env-open* "wt" (list *feature-space*) "create")
(let* ((a (create-vertex '((a . 42))))
(a (vertex-set a 'b 1337)))
(save a)
(vertex-ref (get (vertex-uid a)) 'b)))
1337)
(test-check "save edge"
(with-env (env-open* "wt" (list *feature-space*) "create")
(let* ((start (create-vertex '()))
(end (create-vertex '()))
(edge (create-edge start end '((a . 42)))))
(save (edge-set edge 'b 1337))