Initial commit

1 files changed, 152 insertions, 0 deletions

@@ -0,0 +1,152 @@
+(declare (module scramble))
+
+(import scheme (chicken base)
+        (chicken file)
+        (chicken format)
+        (chicken pathname)
+        (chicken process)
+        (chicken process-context)
+        (chicken string)
+        (srfi 1))
+
+;; dependencies should be like
+;; (((output jimmy.util) (source jimmy.util))
+;;  ((output jimmy.read) (source jimmy.read) (source jimmy.util))
+;;  ((output jimmy.emit) (source jimmy.emit) (source jimmy.util)))
+
+(define egg (make-parameter #f))
+(define build-dir (make-parameter "build"))
+
+(define csc-options '("-setup-mode"
+                      "-host"
+                      "-D compiling-extension"
+                      "-emit-all-import-libraries"
+                      "-dynamic"
+                      "-regenerate-import-libraries"
+                      "-I $(PWD)"
+                      "-C -I$(PWD)"))
+
+(define source-extensions
+  ;; The possible extensions source files can take.
+  (make-parameter '("scm" "sld" "ss")))
+
+(define (read-egg #!optional egg-file)
+  ;; Read EGG-FILE and return the structure inside.
+  (unless egg-file
+    (set! egg-file
+      (receive (_ _ dirs) (decompose-directory (current-directory))
+        (make-pathname (current-directory) (car (reverse dirs)) "egg"))))
+  (assert (file-exists? egg-file) "Can't find egg file" egg-file)
+  (assert (file-readable? egg-file) "Can't read egg file" egg-file)
+  (cons* `(egg-directory ,(pathname-directory egg-file))
+         `(egg-name ,(string->symbol (pathname-file egg-file)))
+         (with-input-from-file egg-file read)))
+
+(define (egg-directory) (alist-ref 'egg-directory (egg)))
+(define (egg-name) (car (alist-ref 'egg-name (egg))))
+(define (egg-components) (alist-ref 'components (egg)))
+(define (egg-csc-options)
+  (let ((opts (alist-walk (egg) 'component-options 'csc-options)))
+    (if opts (map ->string opts) '())))
+
+(define (source-of c)
+  ;; Find the source file of C and return it.  If not found, error.
+  (cond
+   ((alist-ref 'source (cddr (find-component c)))
+    => (lambda (s)
+         (receive (dirs file ext) (decompose-pathname (->string (car s)))
+           (make-pathname (append (egg-directory)
+                                  (if (list? dirs) dirs (list dirs)))
+                          file ext))))
+   (else
+    (let loop ((ext (source-extensions)))
+      (if (null? ext) #f
+          (let ((cand (make-pathname (egg-directory) c ext)))
+            (if (file-exists? cand) cand
+                (loop (cdr ext)))))))))
+
+(define (output-of c)
+  ;; Return the output file of C.  It's okay if it doesn't exist.
+  (make-pathname (append (egg-directory) (list (build-dir)))
+                 (->string c)
+                 (case (car (find-component c))
+                   ((extension) "so")
+                   ((program)))))
+
+(define (find-component name)
+  (find (lambda (c) (eq? name (cadr c)))
+        (alist-ref 'components (egg))))
+
+(define (dependency-graph)
+  ;; Build a dependency graph from the egg.
+  (define (component->deps c)
+    (let* ((c-name (cadr c))
+           (c-info (cddr c))
+           (c-deps (or (alist-ref 'component-dependencies c-info) '()))
+           (s-deps (or (alist-ref 'source-dependencies c-info) '())))
+      (if (null? (append c-deps s-deps))
+          `(,c-name ,c-name)
+          `(,c-name . ,(cons c-name
+                             (append c-deps
+                                     (map ->string s-deps)))))))
+  (filter-map component->deps (egg-components)))
+
+(define (alist-walk lis . keys)
+  (if (null? keys)
+      lis
+      (let ((kv (assoc (car keys) lis)))
+        (cond
+         ((not kv) #f)
+         ((atom? (cdr kv))
+          (and (null? (cdr keys))       ; this shouldn't error...
+               (cdr kv)))
+         ((list? (cdr kv))
+          (apply alist-walk (cdr kv) (cdr keys)))))))
+
+(define (string-join ss)
+  (string-intersperse ss " "))
+
+(define (find-executable name)
+  (let loop ((path (string-split (get-environment-variable "PATH") ":")))
+    (cond
+     ;; If no executable is found, return just the name.  Another option would
+     ;; be to error out if there isn't an executable here ...
+     ((null? path) name)
+     ((and (directory-exists? (car path))
+           (member name (directory (car path) 'with-dotfiles)))
+      (make-pathname (car path) name))
+     (else (loop (cdr path))))))
+
+(define (rule c)
+  (let ((deps (alist-ref c (dependency-graph))))
+    (sprintf "~a: ~a $(BUILD)\n\t~a\n\t-mv ~a.import.scm $(BUILD)/"
+             (output-of c)
+             (string-join (cons (source-of (car deps))
+                                (map output-of (cdr deps))))
+             "$(CSC) $(CSC_OPTIONS) $(CSC_OPTIONS_EXTRA) $< -o $@"
+             c)))
+
+(define (emit-makefile egg-file)
+  (parameterize ((egg (read-egg egg-file)))
+    (print "# Automatically generated by scramble") (newline)
+    (print "NAME = " (egg-name))
+    (print "CSC = " (find-executable "csc"))
+    (print "CSC_OPTIONS = " (string-join csc-options))
+    (print "CSC_OPTIONS_EXTRA = " (string-join (egg-csc-options)))
+    (print "CSI = " (find-executable "csi"))
+    (print "BUILD = $(PWD)/" (build-dir))
+    (print "TESTS = $(PWD)/tests")
+    (print "TEST_ENV = env BUILD=$(BUILD) TESTS=$(TESTS)")
+    (newline)
+    (print ".PHONY: all test clean install uninstall")
+    (print "all: " (string-join (map (o source-of car) (dependency-graph))))
+    (print "test: build"
+           "\n\t" "cd $(BUILD) && "
+           "$(TEST_ENV) $(CSI) -setup-mode -s $(TESTS)/run.scm $(NAME)")
+    (print "clean:\n\t-rm -rf $(BUILD)")
+    (print "install:\n\tchicken-install -s")
+    (print "uninstall:\n\tchicken-uninstall -s")
+    (newline) (print "# " (egg-name)) (newline)
+    (print "$(BUILD):\n\t-mkdir $(BUILD)")
+    (for-each (o print rule cadr) (egg-components))
+    ))