Scheme hacking

3 files changed, 131 insertions, 72 deletions

diff --git a/Alpha/Core.scm b/Alpha/Core.scm
index b785a13..124081d 100644
--- a/Alpha/Core.scm
+++ b/Alpha/Core.scm
@@ -1,21 +1,15 @@
 (define-module (Alpha Core)
   #:use-module ((ice-9 format))
-  #:export (
-            ;; simple printing
-            fmt printf pr prn
-
-                ;; navigating data
-            first next second rest
-
-            ;; booleans
-            true? false? nil nil?
-
-            ;; control flow
-            -> ->> fn /.
-
-            ;; dev helpers
-            comment
-            ))
+  #:use-module ((system vm program))
+  #:use-module ((ice-9 rdelim) #:select (read-line))
+  #:use-module ((srfi srfi-1) #:select any)
+  #:export (fmt printf pr prn
+            first ffirst second rest last butlast
+            true? false? nil nil? some? empty?
+            -> ->> fn /. curry comp
+            repeat
+            inc dec
+            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)))))
@@ -27,61 +21,73 @@
 
 (define (foldr f end lst)
   (if (null? lst)
-    end
-    (f (car lst) (foldr f end (cdr 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))))
+      acc
+      (foldl f (f acc (car lst)) (cdr lst))))
 
 (define fold foldl)
 
 (define (unfold f init pred)
   (if (pred init)
-    (cons init '())
-    (cons init (unfold f (f init) pred))))
+      (cons init '())
+      (cons init (unfold f (f init) pred))))
 
 (define (sum lst)          (fold + 0 lst))
 (define (product lst)      (fold * 1 lst))
 
 (define count length)
 
-
-;;
-;; clojure-like stuff
-;;
-
 (define (pr . a)
+  "Print"
   (for-each display a))
 
-(define (prn . a) (apply pr a) (newline))
+(define (prn . a)
+  "Print, followed by a newline"
+  (apply pr a)
+  (newline))
 
-(define (first a)
-  "Return the first item in the collection."
-  (car a))
+(define (false? x)
+  (not (eq? #t x)))
 
-(define (rest a)
-  "Returns a list of the items after the first."
-  (cdr a))
+(define (true? x)
+  (eq? #t x))
 
-(define (next a)
-  "Returns the next item after the first."
-  (cadr a))
+(define nil #nil)
+
+(define (nil? x)
+  (eq? nil x))
+
+(define (some? a)
+  (not (nil? a)))
 
-;; same thing, easier to remember/read
-(define second next)
+(define (empty? a)
+  (equal? a '()))
+
+(define (first a)
+  "Return the first item in the collection."
+  (if (pair? a)
+      (car a)
+      nil))
 
 (define (ffirst a)
   (first (first a)))
 
-(define (nnext a)
-  (next (next a)))
+(define (second a)
+  "Returns the next item after the first."
+  (cadr 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 (next coll)
-      (last coll)
+  (if (second coll)
+      (last (rest coll))
       (first coll)))
 
 (define (butlast ls)
@@ -89,17 +95,6 @@
   (let ((len (length ls)))
     (list-head ls (- len 1))))
 
-(define (false? x)
-  (eq? #f x))
-
-(define (true? x)
-  (eq? #t x))
-
-(define nil #nil)
-
-(define (nil? x)
-  (eq? nil x))
-
 ;; Ignores body, returns nil.
 (define-syntax comment
   (syntax-rules ()
@@ -116,7 +111,7 @@
 
 (define (some pred coll)
   (or (pred (first coll))
-      (some pred (next coll))))
+      (some pred (second coll))))
 
 (define comp compose)
 
@@ -164,5 +159,74 @@
     [(/. a ... (b ...))
      (lambda (a ...) (b ...))]))
 
-(define (inc a) (+ 1 a))
+(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)))
diff --git a/Alpha/Logic.scm b/Alpha/Logic.scm
index e438a03..4b160d8 100644
--- a/Alpha/Logic.scm
+++ b/Alpha/Logic.scm
@@ -1,4 +1,5 @@
 ;; my mini kanren impl - basically untested so far
+;; TODO: https://github.com/webyrd/faster-miniKanren
 
 (define-module (Alpha Logic))
 
@@ -194,9 +195,9 @@
     (if (and n (zero? n))
         '()
         (case-inf (f) '()
-         [(a) a]
-         [(a f) (cons (car a) (take (and n (- n 1)) f))]
-         [(f) (take n f)]))))
+                  [(a) a]
+                  [(a f) (cons (car a) (take (and n (- n 1)) f))]
+                  [(f) (take n f)]))))
 
 (define-syntax conda
   (syntax-rules ()
diff --git a/Alpha/Repl.scm b/Alpha/Repl.scm
index f2d9160..f3f7898 100644
--- a/Alpha/Repl.scm
+++ b/Alpha/Repl.scm
@@ -1,11 +1,4 @@
-(define-module (Alpha Repl)
-  #:export ())
-
-
-;;
-;; repl customization
-;;
-
+(define-module (Alpha Repl))
 ;; (use-modules (system repl common))
 ;; (repl-default-option-set!
 ;;  'prompt
@@ -16,8 +9,9 @@
 ;;            (pwd))))
 
 ;; TODO(bsima): (doc x)
-;; TODO(bsima): (src x)
-;; TODO(bsima): ,src command
-;; TODO(bsima): ,shell command
-;; TODO(bsima): how to load this file on startup?
-;; for ,src and ,shell https://github.com/NalaGinrut/nala-repl
+
+(eval-when (compile load eval)
+  (define-meta-command ((src nala) repl (form))
+    "Print source code of specified Scheme procedure."
+    (call-with-values (repl-prepare-eval-thunk repl (repl-parse repl form))
+      (lambda args (for-each print-src args)))))