;; SPKI SEXPs for Common Lisp

(in-package :spki-sexp)

(define-condition syntax-error (error) ())
(define-condition bad-length-prefix (syntax-error) ())
(define-condition bad-display-hint (syntax-error) ())
(define-condition bad-input-character (syntax-error) ())
(define-condition unexpected-close-paren (syntax-error) ())

(define-condition match-failure (error) ())

(defstruct display-hint hint body)

(defun write-integer (n output-stream)
  (labels ((w (n)
	     (when (plusp n)
	       (multiple-value-bind (top-half lower-digit)
		   (floor n 10)
		 (w top-half)
		 (write-byte (+ lower-digit 48) output-stream)))))
    (if (zerop n)
	(write-byte 48 output-stream)
	(w n))))

(defun write-sexp (sexp &optional (output-stream *standard-output*))
  (etypecase sexp
    ((array (unsigned-byte 8))
     (write-integer (length sexp) output-stream)
     (write-byte 58 output-stream) ;; #\:
     (write-sequence sexp output-stream))
    (cons
     (write-byte 40 output-stream) ;; #\(
     (loop for v in sexp do (write-sexp v output-stream))
     (write-byte 41 output-stream)) ;; #\)
    (display-hint
     (write-byte 91 output-stream)
     (write-sexp (display-hint-hint sexp) output-stream)
     (write-byte 93 output-stream)
     (write-sexp (display-hint-body sexp) output-stream))
    (string
     (write-sexp (flexi-streams:string-to-octets sexp :external-format :utf-8) output-stream))))

(defun read-simple-string (input-stream &optional (len 0))
  (loop (let ((c (read-byte input-stream)))
	  (if (eql c 58) ;; #\:
	      (let ((buf (make-array len :element-type '(unsigned-byte 8))))
		(read-sequence buf input-stream)
		(return buf))
	      (let ((v (digit-char-p c)))
		(if v
		    (setq len (+ (* len 10) v))
		    (error 'bad-length-prefix)))))))

(defun read-sexp-list (input-stream)
  (loop for v = (read-sexp-inner input-stream)
     until (eq v 'end-of-list-marker)
     collect v))

(defun read-sexp-inner (input-stream)
  (let (result)
    (tagbody :retry
       (setq result
	     (let ((c (read-byte input-stream)))
	       (cond
		 ((eql c 40) (read-sexp-list input-stream)) ;; #\(
		 ((eql c 41) 'end-of-list-marker) ;; #\)
		 ((eql c 91) ;; #\[
		  (let ((hint (read-simple-string input-stream)))
		    (when (not (eql (read-byte input-stream) 93)) ;; #\]
		      (error 'bad-display-hint))
		    (make-display-hint :hint hint :body (read-simple-string input-stream))))
		 ((<= 48 c 57) (read-simple-string input-stream (- c 48))) ;; digits
		 ((<= c 32) ;; whitespace - convenience for testing
		  (go :retry))
		 (t (error 'bad-input-character))))))
    result))

(defun read-sexp (&optional (input-stream *standard-input*))
  (let ((v (read-sexp-inner input-stream)))
    (if (eq v 'end-of-list-marker)
	(error 'unexpected-close-paren)
	v)))

(defun convert-sexp (val)
  (etypecase val
    ((array (unsigned-byte 8)) val)
    (cons (cons (convert-sexp (car val))
		(convert-sexp (cdr val))))
    (null nil)
    (display-hint (make-display-hint
		   :hint (convert-sexp (display-hint-hint val))
		   :body (convert-sexp (display-hint-body val))))
    (string (flexi-streams:string-to-octets val :external-format :utf-8))))

(defmacro sexp-quote (val)
  `(quote ,(convert-sexp val)))

(defun build-sexp (stx)
  (etypecase stx
    ((array (unsigned-byte 8)) stx)
    (cons (if (eq (car stx) '=)
	      (cadr stx)
	      `(cons ,(build-sexp (car stx))
		     ,(build-sexp (cdr stx)))))
    (null 'nil)
    (display-hint `(make-display-hint
		    :hint ,(build-sexp (display-hint-hint stx))
		    :body ,(build-sexp (display-hint-body stx))))
    (string (flexi-streams:string-to-octets stx :external-format :utf-8))))

(defmacro sexp-build (template)
  (build-sexp template))

(defun convert-match-pattern (pattern)
  (etypecase pattern
    ((array (unsigned-byte 8)) `(array (1 (unsigned-byte 8)) ,(coerce pattern 'list)))
    (cons `(cons ,(convert-match-pattern (car pattern))
		 ,(convert-match-pattern (cdr pattern))))
    (null 'nil)
    (display-hint `(struct display-hint
			   (:hint ,(convert-match-pattern (display-hint-hint pattern)))
			   (:body ,(convert-match-pattern (display-hint-body pattern)))))
    (string (convert-match-pattern
	     (flexi-streams:string-to-octets pattern :external-format :utf-8)))
    (symbol pattern)))

(defmacro match-sexp (val &rest clauses)
  `(cl-match:match ,val
     ,@(mapcar (lambda (clause)
		 `(,(convert-match-pattern (car clause)) ,@(cdr clause)))
	       clauses)))

(defmacro ematch-sexp (val &rest clauses)
  `(match-sexp ,val ,@clauses (_ (error 'match-failure))))

;; Useful for testing
(defun read-from-string (str &optional (external-format :utf-8))
  (read-sexp (flexi-streams:make-flexi-stream
	      (flexi-streams:make-in-memory-input-stream
	       (flexi-streams:string-to-octets str :external-format external-format))
	      :external-format external-format)))