mes/module/language/paren.mes

;;; -*-scheme-*-

;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2008 Derek Peschel
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; paren.mes: This file is part of Mes.
;;;
;;; Mes 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.
;;;
;;; Mes 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 Mes.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; paren.mes is a simple yet full lalr test for Mes taken from the
;;; Gambit wiki.
;;;
;;; Run with Guile:
;;;    echo '___P((()))' | guile -s <(echo '(paren-depth)' | cat cc/paren.mes -)

;;; Code:

(cond-expand
  (guile
    (use-modules (system base lalr))
   )
  (mes
   (mes-use-module (mes base-0))
   (mes-use-module (mes base))
   (mes-use-module (mes quasiquote))
   (mes-use-module (mes let))
   (mes-use-module (mes scm))
   (mes-use-module (mes psyntax-0))
   (mes-use-module (mes psyntax-pp))
   (mes-use-module (mes psyntax-1))
   (mes-use-module (srfi srfi-0))
   (mes-use-module (mes record-0))
   (mes-use-module (mes record))
   (mes-use-module (srfi srfi-9))
   (mes-use-module (mes lalr-0))
   (mes-use-module (mes lalr))
   ))

;;; Taken from http://gambitscheme.org/wiki/index.php/Lalr_example
;;; LGPL 2.1 / Apache 2.0

;;; Read C source code, breaking it into the following types of tokens:
;;; the identifier ___P, other identifiers, left and right parentheses,
;;; and any other non-spacing character.  White space (space, tab, and
;;; newline characters) is never a token and may come between any two
;;; tokens, before the first, or after the last.

;;; Whenever the identifier ___P is seen, read a left parenthesis
;;; followed by a body (zero or more tokens) followed by a right
;;; parenthesis.  If the body contains parentheses they must be properly
;;; paired.  Other tokens in the body, including ___P, have no effect.
;;; Count the deepest nesting level used in the body.  Count the maximum
;;; deepest level (of all the bodies seen so far).

;;; At the end of the file, print the maximum deepest level, or 0 if no
;;; bodies were found.


;;; Global variables used by lexical analyzer and parser.
;;; The lexical analyzer needs them to print the maximum level at the
;;; end of the file.

(define depth 0)
(define max-depth 0)

;;; Lexical analyzer.  Passes tokens to the parser.

(define (paren-depth-lexer errorp)
  (lambda ()

    ;; Utility functions, for identifying characters, skipping any
    ;; amount of white space, or reading multicharacter tokens.

    (letrec ((char-whitespace?
              (lambda (c)
                (or (char=? c #\space)
                    (char=? c #\tab)
                    (char=? c #\newline))))
             (skip-whitespace
              (lambda ()
                (let loop ((c (peek-char)))
                  (if (and (not (eof-object? c))
                           (char-whitespace? c))
                      (begin (read-char)
                             (loop (peek-char)))))))

             (char-in-id?
              (lambda (c)
                (or (char-alphabetic? c)
                    (char=? c #\_))))
             (read-___P-or-other-id
              (lambda (l)
                (let ((c (peek-char)))
                  (if (char-in-id? c)
                      (read-___P-or-other-id (cons (read-char) l))
                      ;; else
                      (if (equal? l '(#\P #\_ #\_ #\_))
                          '___P
                          ;; else
                          'ID))))))

      ;; The lexer function.

      (skip-whitespace)
      (let loop ((c (read-char)))
        (cond
         ((eof-object? c)      (begin (display "max depth ")
                                      (display max-depth)
                                      (newline)
                                      '*eoi*))
         ((char-whitespace? c) (begin (errorp "didn't expect whitespace " c)
                                      (loop (read-char))))
         ((char-in-id? c)      (read-___P-or-other-id (list c)))
         ((char=? c #\()       'LPAREN)
         ((char=? c #\))       'RPAREN)
         (else                 'CHAR))))))

;;; Parser.

(define paren-depth-parser
  (lalr-parser

   ;; Options.

   (expect: 0) ;; even one conflict is an error

   ;; List of terminal tokens.

   (CHAR LPAREN RPAREN ID ___P)

   ;; Grammar rules.

   (file       (newfile tokens))
   (newfile    ()                      : (begin (set! depth 0)
                                                (set! max-depth 0)))

   (tokens     (tokens token)
                (token))

   ;; When not after a ___P, the structure of the file is unimportant.
   (token      (CHAR)
                (LPAREN)
                (RPAREN)
                (ID)

   ;; But after a ___P, we start counting parentheses.
                (___P newexpr in LPAREN exprs RPAREN out)
                (___P newexpr in LPAREN       RPAREN out))
   (newexpr    ()                      : (set! depth 0))

   ;; Inside an expression, ___P is treated like all other identifiers.
   ;; Only parentheses do anything very interesting.  I'm assuming Lalr
   ;; will enforce the pairing of parentheses, so my in and out actions
   ;; don't check for too many or too few closing parens.

   (exprs      (exprs expr)
                (expr))

   (expr       (CHAR)
                (in LPAREN exprs RPAREN out)
                (in LPAREN       RPAREN out)
                (ID)
                (___P))
   (in         ()                      : (begin (set! depth (+ depth 1))
                                                (if (> depth max-depth)
                                                  (set! max-depth depth))))
   (out        ()                      : (set! depth (- depth 1)))))

;;; Main program.

(define paren-depth
  (let ((errorp
          (lambda args
            (for-each display args)
            (newline))))
    (lambda ()
      (paren-depth-parser (paren-depth-lexer errorp) errorp))))