(module
magic-pipes-runtime
(mpread
mpwrite
mplog
mplookup
dirent?
->dirent
dirent-path
dirent-inode-number
dirent-mode
dirent-number-of-links
dirent-uid
dirent-gid
dirent-size
dirent-access-time
dirent-change-time
dirent-modification-time
dirent-parent-device-id
dirent-device-id
dirent-block-size
dirent-number-of-blocks
dirent-link-target
dirent-type
dirent-regular-file?
dirent-directory?
dirent-fifo?
dirent-socket?
dirent-symbolic-link?
dirent-character-device?
dirent-block-device?
)
(import chicken)
(import scheme)
(use extras)
(use sql-de-lite)
(use srfi-69)
(use ports)
(use irregex)
(use alist-lib)
(use srfi-1)
(use srfi-13)
(use magic-pipes)
(: mpread (#!optional input-port -> *))
(define mpread data-read)
(: mpwrite (* #!optional output-port -> undefined))
(define mpwrite data-write)
(: mplookup-sqlite (string symbol boolean ->
(* #!optional * -> *) ;; Lookup b given a
(* * -> undefined) ;; Set a = b
(* -> undefined) ;; Delete a = *
(forall (acc) ((* * acc -> acc) acc -> acc)) ;; fold
(-> undefined) ;; close
))
(define (mplookup-sqlite mapfile dupmode reverse)
(let ((db (open-database mapfile)))
(with-exclusive-transaction
db
(lambda ()
(exec (sql/transient db "CREATE TABLE IF NOT EXISTS map(a TEXT, b TEXT);"))
(exec (sql/transient db "CREATE UNIQUE INDEX IF NOT EXISTS map_a ON map(a);"))
(exec (sql/transient db "CREATE INDEX IF NOT EXISTS map_b ON map(b);"))))
(let* ((lookup (sql db
(if reverse
"SELECT a FROM map WHERE b = ?;"
"SELECT b FROM map WHERE a = ?;")))
(set (sql db
(if reverse
"INSERT INTO map (b,a) VALUES (?,?);"
"INSERT INTO map (a,b) VALUES (?,?);")))
(delete (sql db
(if reverse
"DELETE FROM map WHERE b = ?"
"DELETE FROM map WHERE a = ?")))
(dump (sql db
(if reverse
"SELECT b, a FROM map;"
"SELECT a, b FROM map;"))))
(values
(lambda (in #!optional default)
(let ((col (query fetch-column lookup (unparse-data in))))
(case dupmode
((all) (map parse-data col))
((one) (if (pair? col) (parse-data (car col)) default)))))
(lambda (in out)
(let ((inkey (unparse-data in)))
(exec delete inkey)
(exec set inkey (unparse-data out)))
(void))
(lambda (in)
(exec delete (unparse-data in))
(void))
(lambda (kons knil)
(query (fold-rows
(lambda (row acc)
(kons (parse-data (car row))
(parse-data (cadr row))
acc))
knil) dump))
(lambda ()
(close-database db))))))
(: mplookup-hash (hash-table symbol ->
(* #!optional * -> *) ;; Lookup b given a
(* * -> undefined) ;; Set a = b
(* -> undefined) ;; Delete a = *
(forall (acc) ((* * acc -> acc) acc -> acc)) ;; fold
))
(define (mplookup-hash hash dupmode)
(values
(lambda (in #!optional (default (if (eq? dupmode 'all) '() #f)))
(hash-table-ref/default hash in default))
(lambda (in out)
(hash-table-set! hash in
(case dupmode
((all) (list out))
((one) out)))
(void))
(lambda (in)
(hash-table-delete! hash in)
(void))
(lambda (kons knil)
(hash-table-fold hash (case dupmode
((one) kons)
((all)
(lambda (key vals acc)
(fold (lambda (val acc)
(kons key val acc))
acc vals)))) knil))))
(: mplookup-file ((-> hash-table)
(hash-table -> undefined)
symbol ->
(* #!optional * -> *) ;; Lookup b given a
(* * -> undefined) ;; Set a = b
(* -> undefined) ;; Delete a = *
(forall (acc) ((* * acc -> acc) acc -> acc)) ;; fold
(-> undefined) ;; close
))
(define (mplookup-file loader saver dupmode)
(let ((hash (loader))
(updated #f))
(receive (get put del dump)
(mplookup-hash hash dupmode)
(values get
(lambda (in out)
(put in out)
(set! updated #t)
(void))
(lambda (in)
(del in)
(set! updated #t)
(void))
dump
(lambda ()
(when updated
(saver hash))
(set! hash (void)))))))
(: mplookup-aliases (string symbol boolean ->
(* #!optional * -> *) ;; Lookup b given a
(* * -> undefined) ;; Set a = b
(* -> undefined) ;; Delete a = *
(forall (acc) ((* * acc -> acc) acc -> acc)) ;; fold
(-> undefined) ;; close
))
(define (mplookup-aliases mapfile dupmode reverse)
(let ((line-re (irregex '(seq (* space)
($ (*? (~ #\:)))
(* space)
#\:
(* space)
($ (*? any))
(* space))))
(add-to-hash! (lambda (hash key val)
(let ((a (if reverse val key))
(b (if reverse key val)))
(case dupmode
((all)
(hash-table-update!/default hash a
(lambda (old)
(cons b old))
'()))
((one)
(hash-table-set! hash a b)))))))
(mplookup-file
(lambda () (if (file-exists? mapfile)
(with-input-from-file mapfile
(lambda ()
(port-fold
(lambda (line hash)
(let* ((hashpos (string-index line #\#))
(clean-line
(if hashpos
(string-take line hashpos)
line)))
(let ((m (irregex-match line-re clean-line)))
(when m
(add-to-hash! hash
(irregex-match-substring m 1)
(irregex-match-substring m 2)))))
hash)
(make-hash-table)
read-line)))
(make-hash-table)))
(lambda (hash) (with-output-to-file mapfile
(lambda ()
(hash-table-for-each
hash
(lambda (key val)
(case dupmode
((all)
(for-each
(lambda (val*)
(let ((a (if reverse val* key))
(b (if reverse key val*)))
(printf "~A: ~A\n" a b))) val))
((one)
(let ((a (if reverse val key))
(b (if reverse key val)))
(printf "~A: ~A\n" a b)))))))))
dupmode)))
(: mplookup-sexprs (string symbol boolean ->
(* #!optional * -> *) ;; Lookup b given a
(* * -> undefined) ;; Set a = b
(* -> undefined) ;; Delete a = *
(forall (acc) ((* * acc -> acc) acc -> acc)) ;; fold
(-> undefined) ;; close
))
(define (mplookup-sexprs mapfile dupmode reverse)
(let ((add-to-hash! (lambda (hash key val)
(let ((a (if reverse val key))
(b (if reverse key val)))
(case dupmode
((all)
(hash-table-update!/default hash a
(lambda (old)
(cons b old))
'()))
((one)
(hash-table-set! hash a b)))))))
(mplookup-file
(lambda () (if (file-exists? mapfile)
(with-input-from-file mapfile
(lambda ()
(port-fold
(lambda (pair hash)
(add-to-hash! hash
(car pair)
(cdr pair))
hash)
(make-hash-table)
data-read)))
(make-hash-table)))
(lambda (hash) (with-output-to-file mapfile
(lambda ()
(hash-table-for-each
hash
(lambda (key val)
(case dupmode
((all)
(for-each
(lambda (val*)
(let ((a (if reverse val* key))
(b (if reverse key val*)))
(data-write (cons a b)))) val))
((one)
(let ((a (if reverse val key))
(b (if reverse key val)))
(data-write (cons a b)))))
(newline))))))
dupmode)))
(: mplookup-alist (string symbol boolean ->
(* #!optional * -> *) ;; Lookup b given a
(* * -> undefined) ;; Set a = b
(* -> undefined) ;; Delete a = *
(forall (acc) ((* * acc -> acc) acc -> acc)) ;; fold
(-> undefined) ;; close
))
(define (mplookup-alist mapfile dupmode reverse)
(let ((add-to-hash! (lambda (hash key val)
(let ((a (if reverse val key))
(b (if reverse key val)))
(case dupmode
((all)
(hash-table-update!/default hash a
(lambda (old)
(cons b old))
'()))
((one)
(hash-table-set! hash a b)))))))
(mplookup-file
(lambda () (if (file-exists? mapfile)
(with-input-from-file mapfile
(lambda ()
(port-fold
(lambda (alist hash)
(alist-map
(lambda (key value)
(add-to-hash! hash key value))
alist)
hash)
(make-hash-table)
data-read)))
(make-hash-table)))
(lambda (hash) (with-output-to-file mapfile
(lambda ()
(printf "(")
(hash-table-for-each
hash
(lambda (key val)
(case dupmode
((all)
(for-each
(lambda (val*)
(let ((a (if reverse val* key))
(b (if reverse key val*)))
(data-write (cons a b)))) val))
((one)
(let ((a (if reverse val key))
(b (if reverse key val)))
(data-write (cons a b)))))
(newline)))
(printf ")\n"))))
dupmode)))
; (: mplookup (symbol string )) How do I declare the type of #!key?
(define (mplookup type mapfile #!key (dupmode 'one) (reverse #f))
(case dupmode
((all))
((one))
(else (error 'mplookup "Unknown duplicate mode (should be all or one)" dupmode)))
(case type
((sqlite) (mplookup-sqlite mapfile dupmode reverse))
((aliases) (mplookup-aliases mapfile dupmode reverse))
((alist) (mplookup-alist mapfile dupmode reverse))
((sexprs) (mplookup-sexprs mapfile dupmode reverse))
(else (error 'mplookup "Unknown mplookup map type (should be sqlite, aliases, alist or sexprs)" type)))
)
(define (mplog format . args)
(apply fprintf (append (list (current-error-port) format) args))
(newline (current-error-port)))
)
