Re: [Chicken-users] ftl egg

[Thomas Christian Chust]

felix winkelmann wrote:

> [...]
> If you have any suggestions for algorithms and functions to add, please
> tell us so.
> [...]

Hello Felix,

as a usability test for the ftl egg I hacked together a generalized
parsing expression grammar pattern matcher using ftl interfaces plus two
additional own interfaces.

I don't know if this code is really worth to be published, but I post it
here anyway in case somebody wants to play around with it.

cu,
Thomas


-- 
Murphy's Law is recursive.  Washing your car to make it rain doesn't work.

;;;;
;;;; File:   ftl-peg-example.scm
;;;; Author: Thomas Chust <address@hidden>
;;;;
;;;; A small test for the ftl parsing expression grammar
;;;; extension. Parses a nested list of symbols from a string.
;;;;

(require-extension
 extras ftl ftl-peg)

;;; Supporting syntax
(define-macro (values-case production . clauses)
  `(call-with-values
       (lambda () ,production)
     (case-lambda
      ,@clauses)))

;;; Specialized accumulator interfaces
(define a=string-list
  (a-interface
   ;; unfold
   (lambda (dekons klist #!optional (dst '()))
     (let loop ((tail dst) (klist klist))
       (values-case (dekons klist)
         ((obj klist)
          (if (or (string? obj) (list? obj))
              (loop (cons obj tail) klist)
              (loop tail klist)))
         (()
          (reverse tail)))))))

(define a=list-item
  (a-interface
   ;; unfold
   (lambda (dekons klist #!optional dst)
     (let loop ((item dst) (klist klist))
       (values-case (dekons klist)
         ((obj klist)
          (if (list? obj)
              (loop obj klist)
              (loop item klist)))
         (()
          item))))))

;;; Specialized matcher interfaces
(define m=char-ci
  (m=item/%t t=char-ci))
(define m=char-in-string-ci
  (m=alternate-%g/%t g=string t=char-ci))
(define m=char-not-in-string-ci
  (m=not-alternate-%g/%t g=string t=char-ci))

(define m=symbol
  ((m=wildcard->%a a=string)
   (m=char-not-in-string-ci "( \t\r\n)") 1))
(define m=whitespace
  (m=char-in-string-ci " \t\r\n"))

(define m=parentheses
  (m-proxy))
(define m=content
  ((m=wildcard->%a a=string-list)
   (m=alternate
    (list
     m=symbol
     m=parentheses
     m=whitespace))))
(m-implement!
 m=parentheses
 ((m=sequence->%a a=list-item)
  (list
   (m=char-ci #\()
   m=content
   (m=char-ci #\)))))

;;; Main program
(pp
 (call-with-values
     (lambda ()
       ((%m-match-%mi m=content mi=string)
        '("blargh (foo (qux) b(a(a(a)))r)")))
   (project 0)))

;;;;
;;;; File:   ftl-peg.scm
;;;; Author: Thomas Chust <address@hidden>
;;;;
;;;; Generalized pattern matching on ftl interfaces with parsing
;;;; expression grammars.
;;;;

(define-extension
  ftl-peg
  (export
   o=string a=string
   mi-interface %mi-read %mi-mark %mi-restore %mi-forget
   mi=list mi=vector mi=reverse-vector mi=string mi=reverse-string
   m-interface m-proxy m-implement! %m-match-%mi
   m=anything m=wildcard-anything->%a
   m=item/%t m=not-item/%t m=wildcard-item/%t->%a m=wildcard-not-item/%t->%a
   m=sequence-%i/%t->%a m=alternate-%g/%t m=not-alternate-%g/%t
   m=wildcard->%a m=sequence->%a m=alternate))

(require-extension
 (srfi 9 16 26) extras ftl)

;;; Supporting syntax
(define-macro (let-escape esc . body)
  `(call-with-current-continuation
    (lambda (,esc)
      ,@body)))

(define-macro (values-case production . clauses)
  `(call-with-values
       (lambda () ,production)
     (case-lambda
      ,@clauses)))

;;; A string output collector.
(define o=string
  (o-interface
   ;; create
   (lambda (#!optional dst)
     (or dst (open-output-string)))
   ;; write
   (lambda (obj out)
     (display obj out)
     out)
   ;; result
   get-output-string))

;;; A string output collector.
(define a=string
  (a=%o o=string))

;;; Interface: Mark input (mi)
(define-record-type
  mi-interface
  (mi-interface read empty? mark restore forget)
  mi-interface?
  ;; ((%mi-read mi) in) => (values) | (values obj in)
  ;; Reads the next token from the input. If there is no more input,
  ;; nothing is returned, otherwise the token and the new input are
  ;; returned.
  (read %mi-read)
  ;; ((%mi-empty? mi) in) => #t | #f
  ;; Returns whether the given input has no more tokens to read.
  (empty? %mi-empty?)
  ;; ((%mi-mark mi) in) => in
  ;; Returns an input to use for further reading if a future reset to
  ;; the current position may be necessary.
  (mark %mi-mark)
  ;; ((%mi-restore mi) in) => in
  ;; Returns the input reset to the last position stored by the mark
  ;; method.
  (restore %mi-restore)
  ;; ((%mi-forget mi) in) => in
  ;; Returns the input with the last position stored by the mark
  ;; method removed.
  (forget %mi-forget))

(define (v-empty? in)
  (unwrap
   (car in)
   (lambda (v s e)
     (fx>= s e))))

(define (list-stack-mark in)
  (cons (car in) in))

(define (list-stack-restore in)
  (cdr in))

(define (list-stack-forget in)
  (cons (car in) (cddr in)))

;;; A list, ins are list stacks of cdrs.
(define mi=list
  (mi-interface
   ;; read
   (lambda (in)
     (let ((top (car in)))
       (if (null? (car in))
           (values)
           (values
            (car top)
            (cons (cdr top) (cdr in))))))
   ;; empty?
   (lambda (in)
     (null? (car in)))
   ;; mark
   list-stack-mark
   ;; restore
   list-stack-restore
   ;; forget
   list-stack-forget))

;; A vector, ins are list stacks of subvectors.
(define mi=vector
  (mi-interface
   ;; read
   (lambda (in)
     (unwrap
      (car in)
      (lambda (v s e)
        (if (fx>= s e)
            (values)
            (values
             (vector-ref v s)
             (cons (sub v (fx+ s 1) e) (cdr in)))))))
   ;; empty?
   v-empty?
   ;; mark
   list-stack-mark
   ;; restore
   list-stack-restore
   ;; forget
   list-stack-forget))

;; A vector backwards, ins are list stacks of subvectors.
(define mi=reverse-vector
  (mi-interface
   ;; read
   (lambda (in)
     (unwrap
      (car in)
      (lambda (v s e)
        (if (fx>= s e)
            (values)
            (let ((i (fx- e 1)))
              (values
               (vector-ref v i)
               (cons (sub v s i) (cdr in))))))))
   ;; empty?
   v-empty?
   ;; mark
   list-stack-mark
   ;; restore
   list-stack-restore
   ;; forget
   list-stack-forget))

;; A string, ins are list stacks of substrings.
(define mi=string
  (mi-interface
   ;; read
   (lambda (in)
     (unwrap
      (car in)
      (lambda (v s e)
        (if (fx>= s e)
            (values)
            (values
             (string-ref v s)
             (cons (sub v (fx+ s 1) e) (cdr in)))))))
   ;; empty?
   v-empty?
   ;; mark
   list-stack-mark
   ;; restore
   list-stack-restore
   ;; forget
   list-stack-forget))

;; A string backwards, ins are list stacks of substrings.
(define mi=reverse-string
  (mi-interface
   ;; read
   (lambda (in)
     (unwrap
      (car in)
      (lambda (v s e)
        (if (fx>= s e)
            (values)
            (let ((i (fx- e 1)))
              (values
               (string-ref v i)
               (cons (sub v s i) (cdr in))))))))
   ;; empty?
   v-empty?
   ;; mark
   list-stack-mark
   ;; restore
   list-stack-restore
   ;; forget
   list-stack-forget))

;;; Interface: Matcher (m)
(define-record-type
  m-interface
  (m-interface match-%mi)
  m-interface?
  ;; (((%m-match-%mi m) mi) in) => (values obj | #f in)
  ;; Compares the start of the given mark input to some pattern and
  ;; returns the matching object and the advanced mark input in case
  ;; of success or #f and the mark input restored to its former
  ;; position.
  (match-%mi %m-match-%mi* %m-set-match-%mi*!))

;;; (m-proxy) => <m-interface>
;;; Creates a proxy matcher interface with no stored procedure. You
;;; need this to be able to construct recursive matcher patterns.
(define (m-proxy)
  (m-interface #f))

;;; (m-implement! tgt-m src-m)
;;; Fixes a proxy matcher by copying the stored procedure from another
;;; matcher interface. Signals an error if the target interface is not
;;; a proxy or if the source interface is a proxy as well.
(define (m-implement! tgt-m src-m)
  (cond
   ((%m-match-%mi* tgt-m)
    (error 'm-implement! "Target interface is not a proxy" tgt-m))
   ((not (%m-match-%mi* src-m))
    (error 'm-implement! "Source interface is a proxy" src-m))
   (else
    (%m-set-match-%mi*! tgt-m (%m-match-%mi* src-m)))))

;; Extract a real matcher procedure for the given input type from a
;; matcher interface.
(define (%m-match-%mi m mi)
  ((%m-match-%mi* m) mi))

;;; m=anything
;;; Matcher that matches any single token from the input.
(define m=anything
  (m-interface
   (lambda (mi)
     (let ((mi-read (%mi-read mi))
           (mi-empty? (%mi-empty? mi)))
       (lambda (in)
         (if (mi-empty? in)
             (values #f in)
             (mi-read in)))))))

;; ((m=wildcard-anything->%a a)
;;  #!optional (min-repeat 0) (max-repeat #f) dst) => <m-interface>
;; Creates a matcher that matches a sequence of arbitrary tokens from
;; the input that is at least min-repeat long and at most max-repeat
;; long. If max-repeat is #f, any remaining input is eaten up. The
;; matched tokens are collected using the given accumulator interface.
(define (m=wildcard-anything->%a a)
  (let ((a-unfold (%a-unfold a)))
    (lambda args
      (call-with-values
          (lambda ()
            (apply
             (case-lambda
              ((min-repeat max-repeat . dst)
               (values min-repeat max-repeat dst))
              ((min-repeat)
               (values min-repeat #f '()))
              (()
               (values 0 #f '())))
             args))
        (lambda (min-repeat max-repeat dst)
          (m-interface
           (lambda (mi)
             (let ((mi-read (%mi-read mi))
                   (mi-empty? (%mi-empty? mi))
                   (mi-mark (%mi-mark mi))
                   (mi-restore (%mi-restore mi))
                   (mi-forget (%mi-forget mi)))
               (lambda (in)
                 (let-escape esc
                   (set! in (mi-mark in))
                   (values
                    (apply a-unfold
                      (lambda (count)
                        (if (or (and max-repeat
                                     (fx>= count max-repeat))
                                (mi-empty? in))
                            (if (fx>= count min-repeat)
                                (values)
                                (esc #f (mi-restore in)))
                            (let-values (((obj in*) (mi-read in)))
                              (set! in in*)
                              (values obj (fx+ count 1)))))
                      0 dst)
                    (mi-forget in))))))))))))

;;; ((m=item/%t t) f) => <m-interface>
;;; Creates a matcher that matches a single element satisfying the
;;; given test.
(define (m=item/%t t)
  (let ((t? (%t? t)))
    (lambda (f)
      (m-interface
       (lambda (mi)
         (let ((mi-read (%mi-read mi))
               (mi-empty? (%mi-empty? mi))
               (mi-mark (%mi-mark mi))
               (mi-restore (%mi-restore mi))
               (mi-forget (%mi-forget mi)))
           (lambda (in)
             (if (mi-empty? in)
                 (values #f in)
                 (let-values (((obj in) (mi-read (mi-mark in))))
                   (if (t? obj f)
                       (values obj (mi-forget in))
                       (values #f (mi-restore in))))))))))))

;;; ((m=not-item/%t t) f) => <m-interface>
;;; Creates a matcher that matches a single element not satisfying the
;;; given test.
(define (m=not-item/%t t)
  (m=item/%t (t=not-%t t)))

;; ((m=wildcard-item/%t->%a t a)
;;  f #!optional (min-repeat 1) (max-repeat #f) dst) => <m-interface>
;; Creates a matcher that matches a sequence of tokens matching the
;; given test that is at least min-repeat long and at most max-repeat
;; long. If max-repeat is #f, any remaining input is eaten up. The
;; matched tokens are collected using the given accumulator interface.
(define (m=wildcard-item/%t->%a t a)
  (let ((t? (%t? t))
        (a-unfold (%a-unfold a)))
    (lambda args
      (call-with-values
          (lambda ()
            (apply
             (case-lambda
              ((f min-repeat max-repeat . dst)
               (values f min-repeat max-repeat dst))
              ((f min-repeat)
               (values f min-repeat #f '()))
              ((f)
               (values f 1 #f '())))
             args))
        (lambda (f min-repeat max-repeat dst)
          (m-interface
           (lambda (mi)
             (let ((mi-read (%mi-read mi))
                   (mi-empty? (%mi-empty? mi))
                   (mi-mark (%mi-mark mi))
                   (mi-restore (%mi-restore mi))
                   (mi-forget (%mi-forget mi)))
               (lambda (in)
                 (let-escape esc
                   (set! in (mi-mark in))
                   (values
                    (apply a-unfold
                      (lambda (count)
                        (if (or (and max-repeat
                                     (fx>= count max-repeat))
                                (mi-empty? in))
                            (if (fx>= count min-repeat)
                                (values)
                                (esc #f (mi-restore in)))
                            (let-values (((obj in*) (mi-read (mi-mark in))))
                              (if (t? obj f)
                                  (begin
                                    (set! in (mi-forget in*))
                                    (values obj (fx+ count 1)))
                                  (begin
                                    (set! in (mi-restore in*))
                                    (if (fx>= count min-repeat)
                                        (values)
                                        (esc #f (mi-restore in))))))))
                      0 dst)
                    (mi-forget in))))))))))))

;; ((m=wildcard-not-item/%t->%a t a)
;;  f #!optional (min-repeat 1) (max-repeat #f) dst) => <m-interface>
;; Creates a matcher that matches a sequence of tokens not matching
;; the given test that is at least min-repeat long and at most
;; max-repeat long. If max-repeat is #f, any remaining input is eaten
;; up. The matched tokens are collected using the given accumulator
;; interface.
(define (m=wildcard-not-item/%t->%a t a)
  (m=wildcard-item/%t->%a (t=not-%t t) a))

;;; ((m=sequence-%i/%t->%a i t a) src #!optional dst) => <m-interface>
;;; Creates a matcher that matches all elements from the given input
;;; in sequence and collects them in the destination using the given
;;; accumulator.
(define (m=sequence-%i/%t->%a i t a)
  (let ((i-read (%i-read i))
        (t? (%t? t))
        (a-unfold (%a-unfold a)))
    (lambda (src . dst)
      (m-interface
       (lambda (mi)
         (let ((mi-read (%mi-read mi))
               (mi-empty? (%mi-empty? mi))
               (mi-mark (%mi-mark mi))
               (mi-restore (%mi-restore mi))
               (mi-forget (%mi-forget mi)))
           (lambda (in)
             (let-escape esc
               (set! in (mi-mark in))
               (values
                (apply a-unfold
                  (lambda (src)
                    (values-case (i-read src)
                      ((ref src)
                       (if (mi-empty? in)
                           (esc #f (mi-restore in))
                           (let-values (((obj in*) (mi-read in)))
                             (set! in in*)
                             (if (t? obj ref)
                                 (values obj src)
                                 (esc #f (mi-restore in))))))
                      (()
                       (values))))
                  src dst)
                 (mi-forget in))))))))))

;;; ((m=alternate-%g/%t g t) src) => <m-interface>
;;; Creates a matcher that matches any element of the given sequence
;;; using the given test.
(define (m=alternate-%g/%t g t)
  (let ((g-fold (%g-fold g))
        (t? (%t? t)))
    (lambda (src)
      (m-interface
       (lambda (mi)
         (let ((mi-read (%mi-read mi))
               (mi-empty? (%mi-empty? mi))
               (mi-mark (%mi-mark mi))
               (mi-restore (%mi-restore mi))
               (mi-forget (%mi-forget mi)))
           (lambda (in)
             (let-escape esc
               (values
                #f
                (g-fold
                  (lambda (ref in)
                    (if (mi-empty? in)
                        (esc #f in)
                        (let-values (((obj in) (mi-read (mi-mark in))))
                          (if (t? obj ref)
                              (esc obj (mi-forget in))
                              (mi-restore in)))))
                  in src))))))))))

;;; ((m=not-alternate-%g/%t g t) src) => <m-interface>
;;; Creates a matcher that matches any element not in the given
;;; sequence using the given test.
(define (m=not-alternate-%g/%t g t)
  (let ((g-fold (%g-fold g))
        (t? (%t? t)))
    (lambda (src)
      (m-interface
       (lambda (mi)
         (let ((mi-read (%mi-read mi))
               (mi-empty? (%mi-empty? mi))
               (mi-mark (%mi-mark mi))
               (mi-restore (%mi-restore mi))
               (mi-forget (%mi-forget mi)))
           (lambda (in)
             (if (mi-empty? in)
                 (values #f in)
                 (let-values (((obj in) (mi-read (mi-mark in))))
                   (let-escape esc
                     (values
                      obj
                      (mi-forget
                       (g-fold
                        (lambda (ref in)
                          (if (t? obj ref)
                              (esc #f (mi-restore in))
                              in))
                        in src)))))))))))))

;; ((m=wildcard->%a a)
;;  m #!optional (min-repeat 1) (max-repeat #f) dst) => <m-interface>
;; Creates a matcher that matches a sequence of tokens matching the
;; given matcher that is at least min-repeat long and at most
;; max-repeat long. If max-repeat is #f, any remaining matching input
;; is eaten up. The matched tokens are collected using the given
;; accumulator interface.
(define (m=wildcard->%a a)
  (let ((a-unfold (%a-unfold a)))
    (lambda args
      (call-with-values
          (lambda ()
            (apply
             (case-lambda
              ((m min-repeat max-repeat . dst)
               (values m min-repeat max-repeat dst))
              ((m min-repeat)
               (values m min-repeat #f '()))
              ((m)
               (values m 1 #f '())))
             args))
        (lambda (m min-repeat max-repeat dst)
          (m-interface
           (lambda (mi)
             (let ((mi-mark (%mi-mark mi))
                   (mi-restore (%mi-restore mi))
                   (mi-forget (%mi-forget mi)))
               (lambda (in)
                 (let-escape esc
                   (set! in (mi-mark in))
                   (values
                    (apply a-unfold
                      (lambda (count)
                        (if (and max-repeat
                                 (fx>= count max-repeat))
                            (if (fx>= count min-repeat)
                                (values)
                                (esc #f (mi-restore in)))
                            (let-values (((res in*) ((%m-match-%mi m mi)
                                                     (mi-mark in))))
                              (if res
                                  (begin
                                    (set! in (mi-forget in*))
                                    (values res (fx+ count 1)))
                                  (begin
                                    (set! in (mi-restore in*))
                                    (if (fx>= count min-repeat)
                                        (values)
                                        (esc #f (mi-restore in))))))))
                      0 dst)
                    (mi-forget in))))))))))))

;;; ((m=sequence->%a a) ms #!optional dst) => <m-interface>
;;; Creates a matcher that matches all the given matchers in sequence
;;; and collects their results in the destination using the given
;;; accumulator.
(define (m=sequence->%a a)
  (let ((a-unfold (%a-unfold a)))
    (lambda (ms . dst)
      (m-interface
       (lambda (mi)
         (let ((mi-mark (%mi-mark mi))
               (mi-restore (%mi-restore mi))
               (mi-forget (%mi-forget mi)))
           (lambda (in)
             (let-escape esc
               (set! in (mi-mark in))
               (values
                (apply a-unfold
                  (lambda (ms)
                    (if (null? ms)
                        (values)
                        (let-values (((res in*) ((%m-match-%mi (car ms) mi)
                                                 in)))
                          (set! in in*)
                          (if res
                              (values res (cdr ms))
                              (esc #f (mi-restore in))))))
                  ms dst)
                 (mi-forget in))))))))))

;;; (m=alternate ms) => <m-interface>
;;; Creates a matcher that matches any of the given matchers.
(define m=alternate
  (let ((list-fold (%g-fold g=list)))
    (lambda (ms)
      (m-interface
       (lambda (mi)
         (let ((mi-mark (%mi-mark mi))
               (mi-restore (%mi-restore mi))
               (mi-forget (%mi-forget mi)))
           (lambda (in)
             (let-escape esc
               (values
                #f
                (list-fold
                  (lambda (m in)
                    (let-values (((res in) ((%m-match-%mi m mi)
                                            (mi-mark in))))
                      (if res
                          (esc res (mi-forget in))
                          (mi-restore in))))
                  in ms))))))))))