[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [Chicken-users] ftl egg
From: |
Thomas Christian Chust |
Subject: |
Re: [Chicken-users] ftl egg |
Date: |
Fri, 29 Jun 2007 16:43:32 +0200 |
User-agent: |
Mozilla/5.0 (Macintosh; U; PPC Mac OS X Mach-O; en-US; rv:1.8.1.4) Gecko/20070509 SeaMonkey/1.1.2 |
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))))))))))