Retropikzel
/
git-to-snow-repo
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add dependencies without cond-expand to list

This commit is contained in:
retropikzel 2025-09-06 08:42:39 +03:00
commit 3238d793fd
5 changed files with 242 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored Normal file
View File

@ -0,0 +1,3 @@
*.swp
*.swo
git-to-snow-repo

36
Dockerfile Normal file
View File

@ -0,0 +1,36 @@
FROM debian:trixie
RUN apt-get update && apt-get install -y \
build-essential \
make \
git \
ca-certificates \
chicken-bin \
pandoc \
libffi-dev \
tree \
file
RUN chicken-install r7rs
RUN git clone https://github.com/ashinn/chibi-scheme.git --depth=1
WORKDIR /chibi-scheme
RUN make
RUN make install
WORKDIR /build
RUN mkdir -p /usr/local/bin
RUN ls
COPY --from=retropikzel1/compile-r7rs /opt/compile-r7rs /opt/compile-r7rs
ENV PATH=/opt/compile-r7rs/bin:${PATH}
ARG SCHEME=chibi
ENV COMPILE_R7RS=${SCHEME}
RUN mkdir -p ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm
RUN snow-chibi --impls=${SCHEME} --always-yes install "(foreign c)"
RUN git clone https://git.sr.ht/~retropikzel/foreign-c-system --depth=1
RUN cd foreign-c-system && make SCHEME=${SCHEME} && make SCHEME=${SCHEME} force-install
#RUN snow-chibi --impls=${SCHEME} --always-yes install "(retropikzel system)"
RUN snow-chibi --impls=${SCHEME} --always-yes install "(srfi 170)"
RUN git clone https://git.sr.ht/~retropikzel/foreign-c-srfi-170 --depth=2
RUN cd foreign-c-srfi-170 && make SCHEME=${SCHEME} && make SCHEME=${SCHEME} force-install
COPY Makefile .
COPY git-to-snow-repo.scm .
RUN make SCHEME=${SCHEME}
RUN make PREFIX=/opt/git-to-snow-repo install
ENV PATH=/opt/git-to-snow-repo/bin:${PATH}

23
Makefile Normal file
View File

@ -0,0 +1,23 @@
PREFIX=/usr/local
SCHEME=chibi
COMPILE_R7RS=${SCHEME}
all: build
build:
compile-r7rs -o git-to-snow-repo git-to-snow-repo.scm
install:
mkdir -p ${PREFIX}/bin
install git-to-snow-repo ${PREFIX}/bin/git-to-snow-repo
test-docker:
docker build -f Dockerfile --tag=git-to-snow-repo-test .
docker run -v "${PWD}":/workdir -w /workdir -t git-to-snow-repo-test sh -c "git-to-snow-repo example-list.scm"
clean:
rm -rf git-to-snow-repo
clean-all: clean
rm -rf deps

10
example-list.scm Normal file
View File

@ -0,0 +1,10 @@
(((description "Small \"Hello world\" library to be used with testing of snow-fort")
(url "https://git.sr.ht/~retropikzel/scheme-hello-world")
(library (path "retropikzel/hello.sld"))
(library (path "retropikzel/hello/util.sld")))
((description "C Foreign Function Interface (FFI) library for R7RS Schemes")
(maintainers "Retropikzel") ; Optional, if left out will be looked from git url
(url "https://git.sr.ht/~retropikzel/foreign-c")
(library (path "foreign/c.sld")
(foreign-depends "ffi") ; Not optional if there is a dependency
)))

170
git-to-snow-repo.scm Normal file
View File

@ -0,0 +1,170 @@
(import (scheme base)
(scheme read)
(scheme write)
(scheme file)
(scheme process-context)
(retropikzel system)
(srfi 1)
(srfi 170))
(when (< (length (command-line)) 2)
(error "Pass the git repository list as first argument" (command-line)))
(define data
(with-input-from-file (list-ref (command-line) 1) (lambda () (read))))
(define (get ls check key)
(when (not (assq key ls))
(error (string-append "Could not find key: "
(symbol->string key)
" from data.")
ls))
(let ((value (car (cdr (assq key ls)))))
(when (not (apply check (list value)))
(error "Check failed on field value."
`((lib ,ls)
(check ,check)
(value ,value))))
value))
(define (rmdir-r path)
(if (not (file-info-directory? (file-info path #f)))
(delete-file path)
(let ((files (map (lambda (p)
(string-append path "/" p))
(directory-files path #t))))
(cond ((null? files) (delete-directory path))
(else (for-each rmdir-r (map real-path files))
(delete-directory path))))))
(define (shell->list command)
(call-with-temporary-filename
(lambda (file)
(system (string-append command " > " file))
(letrec* ((looper (lambda (result line)
(if (eof-object? line)
result
(looper (append result (list line)) (read-line))))))
(with-input-from-file
file
(lambda ()
(looper (list) (read-line))))))))
(define (get-created dir tag)
(let ((time (shell->list
(apply string-append
`("git -C "
,dir
" log -1 --format=%ai "
,tag
" | tr ' ' '\n'")))))
(string-append (list-ref time 0) "T" (list-ref time 1) (list-ref time 2))))
(define (collect ls key)
(let ((result (list)))
(for-each
(lambda (item)
(when (eq? (car item) key)
(set! result (append result (list item)))))
ls)
result))
(define (get-libraries dir lib)
(let ((result (list)))
(for-each
(lambda (item)
(when (equal? (car item) 'library)
(when (not (assq 'path (cdr item)))
(error "Library with no path" lib))
(when (not (string? (car (cdr (assq 'path (cdr item))))))
(error "Library with non string path" lib))
(let* ((file (car (cdr (assq 'path (cdr item)))))
(path (string-append dir "/" file)))
(if (not (file-exists? path))
(begin
(display "WARNING: Library with non existing path ignored")
(newline)
(display " ")
(write item)
(newline))
(let* ((data (with-input-from-file path (lambda () (read))))
(foreign-depends (if (assq 'foreign-depends (cdr item))
`((foreign-depends
,(car (cdr (assq 'foreign-depends
(cdr item))))))
'()))
(debug
(begin
;(display "HERE: ")
;(write (collect (cdr data) 'cond-expand))
;(newline)
1
))
(depends (map cdr (collect (cdr data) 'import))))
(set! result
(append result
(list (append `((name ,(list-ref data 1))
(path ,file))
foreign-depends
(if (null? depends)
'()
`((depends ,@(car depends))))
)))))))))
lib)
result))
(display "(repository")
(newline)
(for-each
(lambda (lib)
(let ((description (get lib string? 'description))
(url (get lib string? 'url)))
(call-with-temporary-filename
(lambda (dir)
(let* ((git-command (apply string-append
`("git clone "
,url
" "
,dir
" 2> /tmp/null")))
(git-output (system git-command))
(files (map (lambda (i)
(real-path (string-append dir "/" i)))
(directory-files dir)))
(tags (shell->list (apply string-append
`("git -C "
,dir
" tag 2>&1 > "
,(string-append dir "/tags"))))))
(for-each
(lambda (tag)
(let* ((hash (car (shell->list
(apply string-append
`("git -C "
,dir
" rev-parse "
,tag
" > "
,(string-append dir "/hash"))))))
(created (get-created dir tag))
(updated (get-created dir tag))
(libraries (get-libraries dir lib))
(data `(package (git (url ,url)
(tag ,tag)
(hash ,hash))
(version ,tag)
(created ,created)
,@libraries)))
(display " ")
(write data)
(newline)))
tags)
(rmdir-r dir))))))
data)
(display ")")
(newline)