cantish.el

;; Some macros to make ELisp more like Cant. Just for my own use.

(put 'be 'lisp-indent-function 1)
(put 'else 'lisp-indent-function 0)

;; TODO is there not a better way?
(font-lock-add-keywords 'emacs-lisp-mode
                        `((,(regexp-opt '("be" "begin" "else")) . font-lock-keyword-face)))

(defmacro hide (&rest body)
  "A block of definitions and expressions, in a subscope."
  (declare (indent 0))
  (pcase (cantish-expand-body body)
    (`(,e) e)
    (exps `(progn . ,exps))))

(defmacro to (template &rest body)
  "Define a function in Cantish."
  (declare (indent 1) (doc-string 2))
  `(defun . ,(cantish-local-def template body)))

(defun cantish-local-def (template body)
  ;; TODO support patterns, not just variables? But we want &rest and &optional too; don't those clash?
  (pcase-let ((`(,name . ,arglist) template))
    `(,name ,arglist . ,(cantish-expand-body body))))

(defun cantish-expand-body (body)
  "Transform a list of forms, each an expression or a local definition, into a list of expressions."
  (pcase body
    ('() '(nil))
    (`((to . ,_) . ,_) (cantish-expand-to-block '() body))
    (`(,e) (list (cantish-expand-exp e)))
    (`(,hd . ,tl) (cantish-expand-head hd (cantish-expand-body tl)))
    (_ (error "Bad body" body))))

(defun cantish-expand-to-block (defs-reversed forms)
  (pcase forms
    (`((to ,template . ,body) . ,rest)
     (cantish-expand-to-block (cons (cantish-local-def template body) defs-reversed)
                              rest))
    (_ `(labels ,(reverse reversed-defs) . ,(cantish-expand-body forms)))))

(defun cantish-expand-head (head expanded-body)
  (pcase head
    (`(let ,p ,e)
     `((pcase-let ((,p ,e)) ,@expanded-body)))
    (_ `(,head ,@expanded-body))))

(defun cantish-expand-exp (e)
  e)                                    ;for now

(defmacro may (e &rest clauses)
  "Like PCASE, but raising an error on non-match, and with a bit more syntax."
  (declare (indent 1))
  `(pcase ,e
     ,@(mapcar #'cantish-expand-may-clause clauses)
     ,@(if (cantish-exhaustivep clauses) '()
         '((value (cantish-match-error value))))))

(defun cantish-match-error (subject)
  (error "No match" subject))

(defun cantish-expand-may-clause (clause)
  "Transform a MAY clause into a PCASE clause."
  (pcase clause
    (`(be ,p . ,body)
     `(,p . ,(cantish-expand-body body)))
    (`(else . ,body)
     `(_ . ,(cantish-expand-body body)))
    (_ (error "Bad clause" clause))))

(defun cantish-exhaustivep (clauses)
  "True iff in matching these MAY clauses we certainly can't fall off the end."
  (pcase clauses
    ('() nil)
    (`(,clause . ,rest)
     (pcase clause
       (`(be ,p . ,_) (or (symbolp p) (cantish-exhaustivep rest))) ; XXX what if p=nil?
       (`(else . ,_)  t)
       (_ (error "Bad clause" clause))))
    (_ (error "Bad clauses" clauses))))

(defun cantish-variablep (x)
  (and (symbolp x) (not (null x))))

(defmacro begin (fname pairs &rest body)
  "Like named LET in Scheme. But the function name is optional, defaulting to AGAIN."
  (declare (indent 2)) ;TODO smarter indent rule that handles the optional-fname feature?
  (if (cantish-variablep fname)
      (cantish-expand-begin fname pairs body)
    (cantish-expand-begin 'again fname (cons pairs body))))

(defun cantish-expand-begin (fname pairs body)
  (unless (symbolp fname)
    (error "Syntax" fname))
  (cantish-check-pairs pairs)
  (let ((vars (mapcar 'car pairs))
        (init-exps (mapcar 'cadr pairs)))
    `(labels ((,fname ,vars . ,(cantish-expand-body body)))
       (,fname . ,init-exps))))

(defmacro for (callee pairs &rest body)
  "Like FOR in Cant."
  (declare (indent 2))
  (unless (symbolp callee)              ;TODO consider supporting general expressions
    (error "Syntax" callee))
  (cantish-check-pairs pairs)
  (let ((vars (mapcar 'car pairs))
        (arg-exps (mapcar 'cadr pairs)))
    `(,callee (lambda ,vars . ,(cantish-expand-body body)) . ,arg-exps)))

(defun cantish-check-pairs (pairs)
  "Check for legal syntax of LET-style binding pairs."
  (unless (every (lambda (pair) (pcase pair
                                  (`(,name ,_) (symbolp name))
                                  (_ nil)))
                 pairs)
    (error "Binding syntax" pairs)))

(defmacro hm (clause &rest rest)
  "Like HM in Cant."
  (declare (indent 0))
  ;; TODO better syntax error on fall-off-end
  (pcase clause
    (`(else . ,body)
     (unless (null rest) (error "ELSE clause is not last" rest))
     `(hide . ,(cantish-expand-body body)))
    ;; (`(do . ,body) ...)   ;; TODO find a name that works in ELisp
    (`(let . ,_)
     `(hide ,clause (hm . ,rest)))
    (`(if ,test . ,body)
     `(if ,test (hide . ,body) (hm . ,rest)))
    (`(may ,subject . ,may-clauses)
     `(may ,subject ,@may-clauses (else (hm . ,rest))))
    (_ (error "HM clause syntax" clause))))

;; conceivably also worth doing:
;; import export

(provide 'cantish)