diff options
| -rw-r--r-- | Alpha/Core.scm | 176 | ||||
| -rw-r--r-- | Alpha/Logic.scm | 7 | ||||
| -rw-r--r-- | Alpha/Repl.scm | 20 |
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))))) |