Add typed client template composition tool

ober

fd3b8cfd41b5401189d2a4e0a913e14a7cd0833e

diff --git a/tools/compose-client-template.ss b/tools/compose-client-template.ss
new file mode 100644
index 0000000..6a5333f
--- /dev/null
+++ b/tools/compose-client-template.ss
@@ -0,0 +1,83 @@
+(import (jerboa prelude))
+
+(def (read-all-forms path)
+  (with-input-from-string (read-file-string path)
+    (lambda ()
+      (let loop ((forms '()))
+        (let ((form (read)))
+          (if (eof-object? form)
+              (reverse forms)
+              (loop (cons form forms))))))))
+
+(def (unquote-form form)
+  (if (and (pair? form) (eq? (car form) 'quote) (pair? (cdr form)))
+      (cadr form)
+      form))
+
+(def (find-fragment forms path)
+  (or (for/or ((form forms))
+        (and (pair? form)
+             (eq? (car form) 'def)
+             (pair? (cdr form))
+             (eq? (cadr form) 'fragment)
+             (pair? (cddr form))
+             (unquote-form (caddr form))))
+      (error 'compose-client-template "fragment definition not found" path)))
+
+(def (kotlin-source-entry? item)
+  (and (pair? item)
+       (memq (car item) '(typed-kotlin-file kotlin-file kotlin-file-lines))
+       (pair? (cdr item))
+       (string? (cadr item))))
+
+(def (last-string-part value separator)
+  (let ((parts (string-split value separator)))
+    (if (null? parts) value (list-ref parts (- (length parts) 1)))))
+
+(def (source-base-name item)
+  (let ((filename (last-string-part (cadr item) #\/)))
+    (if (string-suffix? ".kt" filename)
+        (substring filename 0 (- (string-length filename) 3))
+        filename)))
+
+(def (existing-part-path directory base)
+  (let ((plain (path-join directory (string-append base ".ss")))
+        (qualified (path-join directory (string-append base ".kt.ss"))))
+    (cond
+      ((file-exists? plain) plain)
+      ((file-exists? qualified) qualified)
+      (else #f))))
+
+(def (render-fragment items)
+  (with-output-to-string
+    (lambda ()
+      (displayln "(import (jerboa prelude))")
+      (newline)
+      (pretty-print `(def fragment ',items)))))
+
+(def (compose-template input-path parts-directory output-path)
+  (let ((fragment (find-fragment (read-all-forms input-path) input-path))
+        (directory-name (last-string-part parts-directory #\/)))
+    (write-file-string
+      output-path
+      (render-fragment
+        (map (lambda (item)
+               (if (kotlin-source-entry? item)
+                   (let* ((base (source-base-name item))
+                          (part (existing-part-path parts-directory base)))
+                     (if part
+                         (list 'include-fragment
+                               (string-append directory-name "/"
+                                              (last-string-part part #\/)))
+                         item))
+                   item))
+             fragment)))))
+
+(def (main)
+  (let ((args (reverse (command-line))))
+    (if (< (length args) 3)
+        (error 'compose-client-template
+               "usage: compose-client-template.ss INPUT PARTS-DIR OUTPUT")
+        (compose-template (list-ref args 2) (list-ref args 1) (list-ref args 0)))))
+
+(main)