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) #: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 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 fold foldl)

(define (unfold f init pred)
  (if (pred init)
      (cons init '())
      (cons init (unfold f (f init) pred))))

(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 nil #nil)

(define (nil? x)
  (eq? nil x))

(define (some? a)
  (not (nil? a)))

(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 (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 (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 nil.
(define-syntax comment
  (syntax-rules ()
    ((_ ...) nil)))

(comment
 ;; nil is different from null. nil is supposed to be more like
 ;; 'Nothing' in Haskell, it is the absence of any value or type;
 ;; whereas null is specifically the empty list, which still has a type
 ;; of 'list'.
 (null? '()) ;; => #t
 (nil? '())  ;; => #f
 )

(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))