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))))))
(lookup-environment name))))
(define* (add-layer env layer #:optional (onto 'current))
;; TODO currently ignores stree structure of tree file!!
(define* (add-layer env layer #:optional (onto 'current) (tag onto))
;; TODO deduplicate with init-env
(unless (file-exists? layer)
(throw 'add-layer-directory-doesnt-exist!))
@ -246,18 +245,57 @@
(new-pin (decode-hash-link-encode pin dirhash))
(stack (environment-tag-layers env onto))
(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
(unless (file-exists? loc)
(copy-recursively/overlay layer loc)
;; TODO: check for collisions
(symlink-layer! dirhash))
(with-directory-excursion (metadata-file name)
(when (symbolic-link? "./tags/current")
(delete-file "./tags/current"))
(with-output-to-file "./tags/current"
(λ () (display new-pin)))
(let ((tags/tag (string-append "./tags/" (symbol->string tag))))
(when (and (file-exists? tags/tag) (symbolic-link? tags/tag))
(delete-file tags/tag))
(with-output-to-file tags/tag
(λ () (display new-pin))))
(with-output-to-file "./tree"
(λ () (write (append stack (list dirhash))))))
(λ () (write (grow (environment-tree env) pin dirhash)))))
(lookup-environment name)))
(define* (roll-back! env #:optional (tag 'current))