joy-in-the-morning/language/joy/parser.scm

;;; parser.scm -- parse tokens for Joy.
;;; Copyright © 2016 Eric Bavier <bavier@member.fsf.org>
;;;
;;; Joy is free software; you can redistribute it and/or modify it under
;;; the terms of the GNU General Public License as published by the Free
;;; Software Foundation; either version 3 of the License, or (at your
;;; option) any later version.
;;;
;;; Joy is distributed in the hope that it will be useful, but WITHOUT
;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
;;; License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Joy.  If not, see <http://www.gnu.org/licenses/>.

(define-module (language joy parser)
  #:use-module (language joy lexer)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:export (parse-joy parse-joy*))

(define* (parse-error token msg . args)
  (apply error
         (format #f "~@[~a:~]~d:~d: ~a"
                 (source-property token 'filename)
                 (source-property token 'line)
                 (source-property token 'column)
                 msg)
         args))

(define (return result token)
  (if (pair? result)
      (set-source-properties!
       result
       (source-properties token)))
  result)

(define (lex-buffer lexer)
  "Given a lexer LEXER that returns tokens when invoked, return a new
lexer.  This lexer also returns tokens when invoked with no arguments
but can also \"unread\" tokens when invoked with arguments, saving
those tokens for later retrieval.

  E.g.
  (define lex (lex-buffer (get-lexer)))
  (lex)
  -> 'foo
  (lex 'foo)
  (lex)
  -> 'foo
  (lex)
  -> 'bar
"
  (let ((buffer '()))
    (lambda tokens
      (match tokens
	(() (match buffer
	      (() (lexer))
	      ((token rest ...)
	       (set! buffer rest)
	       token)))
	(tokens
	 (set! buffer (append tokens buffer)))))))

(define (get-quote lex)
  (let* ((token (lex))
	 (type (car token)))
    (case type
      ((eof)
       (parse-error token "unexpected end of file in quote"))
      ((square-open)
       (let* ((term (get-term lex #t))
	      (token (lex))
	      (type (car token)))
	 (case type
	   ((square-close)
	    term)
	   (else
	    (parse-error
	     token "expecting closing ']' in quote, got" token))))))))

(define* (get-definition-sequence lex #:optional (consume-newline? #f))
  "Parse a DEFINE block and return a sequence of '<name> <term> def'"
  (define (consume-newlines)
    (match (lex)
      (('newline . _) (consume-newlines))
      (other (lex other))))

  (define (get-definition)
    (match (lex)
      ((and token' ('symbol . name))
       (consume-newlines)
       (match (lex)
	 (('== . _)
	  (consume-newlines)
	  (let ((term (get-term lex)))
	    (match (lex)
	      (('semicolon . _)
	       (values (list name) term))
	      (token
	       (parse-error token
			    "expecting ';' at end of definition, got" token)))))
	 (token
	  (lex token' token)
	  (values #f #f))))
      (token'
       (lex token')
       (values #f #f))))

  (match (lex)
    ((and token ((or 'define 'public 'private) . _))
     (consume-newlines)
     (let iterate ((definitions '()))
       (when consume-newline?
	 (consume-newlines))
       (call-with-values (lambda () (get-definition))
	 (lambda (name term)
	   (if (and name term)
	       (iterate (cons* 'def term name definitions))
	       (begin
		 (match (lex)
		   (('end . _) #t)	;consume trailing 'END'
		   (other (lex other)))
		 (return (reverse definitions) token)))))))
    (token
     (parse-error token "expecting definition block, got" token))))

(define* (get-term lex #:optional (consume-newline? #t))
  (let iterate ((items '()))
    (let* ((token (lex))
	   (type (car token)))
      (case type
	((eof semicolon end square-close define public private)
	 (lex token)			;do not consume
	 (return (reverse items) token))
        ((==)
         (parse-error token "'==' outside definition"))

	((square-open)
	 (lex token)
	 (iterate (cons (get-quote lex) items)))
	((newline)
	 (if consume-newline?
	     (iterate items)		;ignore newline
	     (begin
	       (lex token)		;replace newline
	       (return (reverse items) token))))
	(else
	 (iterate (cons (cdr token) items)))))))

(define* (get-expression lex #:optional (consume-newline? #t))
  (let iterate ((items '()))
    (let* ((token (lex))
	   (type (car token)))
      (case type
	((eof)
	 (match items
	   (() (cdr token))
	   (else (apply append (reverse items)))))
	((== end)
	 (parse-error token (string-append "'" (cdr token)
					   "' outside definition")))
	((paren-open bracket-open)
	 (parse-error token "joy sets not implemented"))
	((paren-close brack-blose square-close semicolon)
	 (parse-error token "unexpected" (cdr token)))
	((public private define)
	 (lex token)
	 (let ((defs (get-definition-sequence lex consume-newline?)))
	   (iterate (cons defs items))))
	((newline)
	 (if consume-newline?
	     (iterate items)
	     (apply append (reverse items))))
	(else
	 (lex token)			;put token back
	 (iterate (cons (get-term lex consume-newline?)
			items)))))))

(define* (parse-joy* port #:optional (consume-newline? #t))
  (let ((lexer (lex-buffer (get-lexer port))))
    (get-expression lexer consume-newline?)))

(define (parse-joy port)
  (parse-joy* port))