davie/guile-env
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

env: Respect tree structure when add-layer

Browse source
This commit is contained in:
Davie Li 2024-01-31 16:32:50 +01:00
parent 3bd101930e
commit cbf478cc4f
Signed by: davie
GPG key ID: 29FD88532FC91BF4
1 changed files with 45 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

52
env.scm
View file

@ -234,8 +234,7 @@
(with-output-to-file "tree" (λ () (write (list dirhash)))))) (with-output-to-file "tree" (λ () (write (list dirhash))))))
(lookup-environment name)))) (lookup-environment name))))
(define* (add-layer env layer #:optional (onto 'current)) (define* (add-layer env layer #:optional (onto 'current) (tag onto))
;; TODO currently ignores stree structure of tree file!!
;; TODO deduplicate with init-env ;; TODO deduplicate with init-env
(unless (file-exists? layer) (unless (file-exists? layer)
(throw 'add-layer-directory-doesnt-exist!)) (throw 'add-layer-directory-doesnt-exist!))
@ -246,18 +245,57 @@
(new-pin (decode-hash-link-encode pin dirhash)) (new-pin (decode-hash-link-encode pin dirhash))
(stack (environment-tag-layers env onto)) (stack (environment-tag-layers env onto))
(loc (layer-file dirhash))) (loc (layer-file dirhash)))
(define (grow tree pinned layer)
;; TODO abstract away
(let ((atom? (compose not pair?)))
(match tree
(() (throw 'missformed-tree))
((root) (if (equal? pinned root)
(list root layer)
(throw 'missformed-tree)))
((root _ ...)
(cons root
(let loop ((tree (cdr tree))
(hash (environment-root env)))
(match tree
(() '())
(((? atom? head))
(let ((h (decode-hash-link-encode hash head)))
(if (equal? pinned h)
(list head layer)
(list head))))
(((? atom? head) tail ...)
(let ((h (decode-hash-link-encode hash head)))
(if (equal? pinned h)
(list (list head (list layer) tail))
(cons head (loop tail h)))))
((((? atom? head)
(? pair? branch1)
(? pair? branch2)
(? pair? branch3) ...))
(let* ((h (decode-hash-link-encode hash head)))
(if (eq? pinned h)
(list (cons head
(cons (list layer)
(cons* branch1 branch2 branch3))))
(list (cons head (map (λ (br) (loop br h))
(cons* branch1 branch2 branch3)))))))
(else (throw 'missformed-tree)))))))))
;; TODO check if appendable ;; TODO check if appendable
(unless (file-exists? loc) (unless (file-exists? loc)
(copy-recursively/overlay layer loc) (copy-recursively/overlay layer loc)
;; TODO: check for collisions ;; TODO: check for collisions
(symlink-layer! dirhash)) (symlink-layer! dirhash))
(with-directory-excursion (metadata-file name) (with-directory-excursion (metadata-file name)
(when (symbolic-link? "./tags/current") (let ((tags/tag (string-append "./tags/" (symbol->string tag))))
(delete-file "./tags/current")) (when (and (file-exists? tags/tag) (symbolic-link? tags/tag))
(with-output-to-file "./tags/current" (delete-file tags/tag))
(λ () (display new-pin))) (with-output-to-file tags/tag
(λ () (display new-pin))))
(with-output-to-file "./tree" (with-output-to-file "./tree"
(λ () (write (append stack (list dirhash)))))) (λ () (write (grow (environment-tree env) pin dirhash)))))
(lookup-environment name))) (lookup-environment name)))
(define* (roll-back! env #:optional (tag 'current)) (define* (roll-back! env #:optional (tag 'current))