path: root/Alpha/Core.scm

(define-module (Alpha 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
                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))))