Re-namespace general scheme code to bs

1 files changed, 221 insertions, 0 deletions

diff --git a/bs/core.scm b/bs/core.scm
new file mode 100644
index 0000000..d8e0060
--- /dev/null
+++ b/bs/core.scm
@@ -0,0 +1,221 @@
+(define-module (bs core)
+  #:use-module ((ice-9 format))
+  #:use-module ((system vm program))
+  #:use-module ((ice-9 rdelim) #:select (read-line))
+  #:use-module (srfi srfi-1)
+  #:export (fmt printf pr prn rest last butlast
+                true? false? some? empty?
+                -> ->> fn /. curry comp
+                repeat for seq turn
+                inc dec member? contains?
+                comment get-source* get-source source))
+
+(define (flip f)           (lambda (x y) (f y x)))
+(define (curry f a)        (lambda (b) (apply f (cons a (list b)))))
+(define pos?
+  (curry < 0))
+
+(define neg?
+  (curry > 0))
+
+(define (foldr f end lst)
+  (if (null? lst)
+      end
+      (f (car lst) (foldr f end (cdr lst)))))
+
+(define (foldl f acc lst)
+  (if (null? lst)
+      acc
+      (foldl f (f acc (car lst)) (cdr lst))))
+
+(define (sum lst)          (fold + 0 lst))
+(define (product lst)      (fold * 1 lst))
+
+(define count length)
+
+(define (pr . a)
+  "Print"
+  (for-each display a))
+
+(define (prn . a)
+  "Print, followed by a newline"
+  (apply pr a)
+  (newline))
+
+(define (false? x)
+  (not (eq? #t x)))
+
+(define (true? x)
+  (eq? #t x))
+
+(define (some? a)
+  (not (null? a)))
+
+(define (empty? a)
+  (equal? a '()))
+
+(define (ffirst a)
+  (first (first a)))
+
+(define (rest a)
+  "Returns a list of the items after the first."
+  (cdr a))
+
+(define (last coll)
+  "Return the last time in coll, in linear time."
+  (if (second coll)
+      (last (rest coll))
+      (first coll)))
+
+(define (butlast ls)
+  "Return everthing execpt the last element in ls."
+  (let ((len (length ls)))
+    (list-head ls (- len 1))))
+
+;; Ignores body, returns '().
+(define-syntax comment
+  (syntax-rules ()
+    ((_ ...) '())))
+
+(define (some pred coll)
+  (or (pred (first coll))
+      (some pred (second coll))))
+
+(define comp compose)
+
+(define (not-any? pred coll)
+  (comp not some))
+
+(define (printf . args)
+  (display (apply format args)))
+
+(define-syntax fmt
+  (syntax-rules ()
+    ((_ s args ...)
+     (format #f s args ...))))
+
+(define-syntax fn
+  (syntax-rules ()
+    ((_ args body ...)
+     (lambda args body ...))))
+
+(define-syntax ->
+  (syntax-rules ()
+    [(_ a) a]
+    [(_ a (b c ...))
+     (b a c ...)]
+    [(_ a b)
+     (-> a (b))]
+    [(_ a b c ...)
+     (-> (-> a b) c ...)]))
+
+(define-syntax ->>
+  (syntax-rules ()
+    [(_ a) a]
+    [(_ a (b ...))
+     (b ... a)]
+    [(_ a b)
+     (b a)]
+    [(_ a b c ...)
+     (->> (->> a b) c ...)]))
+
+;; Shen-like lambda
+(define-syntax /.
+  (syntax-rules ()
+    [(/. a b)
+     (lambda (a) b)]
+    [(/. a ... b)
+     (lambda (a ...) b)]
+    [(/. a ... (b ...))
+     (lambda (a ...) (b ...))]))
+
+(define (inc a) (+ a 1))
+(define (dec a) (- a 1))
+
+(define* (repeat a #:optional (n 10))
+  (do ((i 1 (inc i)))
+      ((> i n))
+    a))
+
+(define-syntax if-let
+  (syntax-rules ()
+    [(_ (binding value) then else)
+     (let ([binding value])
+       (if binding then else))]))
+
+(define-syntax when-let
+  (syntax-rules ()
+    [(_ (binding value) body ...)
+     (when binding body ...)]))
+
+
+;; source utils
+
+(define (skip-lines port n)
+  (cond
+   ((zero? n) port)
+   (else (read-line port) (skip-lines port (1- n)))))
+
+(define (get-source* source pname)
+  (let* ([file (source:file source)]
+         [filename (any (fn (x)
+                            (let ((f (string-append x "/" file)))
+                              (if (file-exists? f) f #f)))
+                        %load-path)]
+         [re (make-regexp (format #f "\\(define (~a|\\(~a.*\\))" pname pname))]
+         [read-between (lambda (in start end)
+                         (seek in 0 SEEK_SET)
+                         (skip-lines in (1- start))
+                         (call-with-output-string
+                           (lambda (out)
+                             (let self ((line (read-line in))
+                                        (cur start))
+                               (cond
+                                [(or (eof-object? line) (> cur end))
+                                 (close in)]
+                                [else
+                                 (format out "~a~%" line)
+                                 (self (read-line in) (inc cur))])))))])
+    (call-with-input-file filename
+      (lambda (in)
+        (let self ((line (read-line in)))
+          (cond
+           [(eof-object? line) #f]
+           [(regexp-exec re line)
+            (unread-string line in)
+            (let*  ((start (port-line in))
+                    (end (begin (read in) (port-line in))))
+              (read-between in start (inc end)))]
+           [else
+            (self (read-line in))]))))))
+
+(define (get-source p)
+  "Get the source of a procedure as a string."
+  (let ((psrc (program-source p 0)))
+    (cond
+     [(not psrc) (fmt "<~a: compiled C procedure>\n" p)]
+     [(not (source:file psrc)) #f]
+     [else (get-source* psrc (symbol->string (procedure-name p)))])))
+
+(define (source p)
+  "Print the source of a procedure."
+  (pr (get-source p)))
+
+(define member? member)
+
+(define (contains? ls x)
+  (member? x ls))
+
+(define (turn ls f)
+  (map f ls))
+
+(define (seq x)
+  (if (list? x)
+      x
+      (list x)))
+
+;; is this not in srfi-1?
+(define (flatten x)
+  (cond ((null? x) '())
+        ((pair? x) (append (flatten (car x)) (flatten (cdr x))))
+        (else (list x))))