* Where the next effort in prolog will be and a cool match hack!!
@ 2010-09-09 21:15 Stefan Israelsson Tampe
2010-09-10 8:50 ` Andy Wingo
2010-09-13 2:32 ` Alex Shinn
0 siblings, 2 replies; 6+ messages in thread
From: Stefan Israelsson Tampe @ 2010-09-09 21:15 UTC (permalink / raw)
To: guile-devel, Alex Shinn
[-- Attachment #1: Type: text/plain, Size: 7709 bytes --]
Hi,
I just wanted to share some ideas that come to my mind to churn the prolog
into something more useful.
So I have been trying to rework Shins hygienic version if ice-9 match so that
it can be used as a backbone for it.
I currently have two matchers, one a fast and severely insecure that I'm
playing with. and a prompt based version that only needs a slight change to
guile sources. Now, there is many other ways to do backtracking. Two things
come to my mind. 1) based on returning a backtrack symbol or based on closures
now Shins code has a local variable that represents the next continuation and
one can easally hook in code to make that variable explicit and pass it as an
appropriate Cut closure. So in principle making the prolog engine work with
this system is a no brainer and this is where I'm heading now. But there is
some
extra work still needed to add to the matcher. E.g. we need to replace
car,cdr,pair? null? equal? with appropriate versions of it and then just go
from there. Oh well I have another extension. I want to improve the prolog
compiler to be more user friendly giving some better clues of parse errors and
the next discussion will be inline with that.
So here is the extension match, (see match-phd.scm attached to this file).
the prototype is exemplified like this
(match abstractions ((<a> a1 a2 a3) (<b>) (<c> c1 c2) ...)
phd ((*car *cdr *pair? null? equal?) ;;default
functions
(+ (*car *cdr *pair? null? equal?)) ;;+ uses
functions
(- ( car cdr pair? null? equal?))) ;;- uses ordinary
match
... usual match stuff here)
So for this example
(- <a> <a> <b> . L) will match the sequence of subpattern where reault data
will be stored in variables a1, a2, void and standard matching (-) will be
used.
Let's see an interesting code. You can execute this after putting the matcher
following this mail in ice-9 directory!
(use-modules (ice-9 match-phd))
;; Setting up the xmatch environment
;; We will work with elements of the form (List Row Column Depth) here
(define (*car x) (match x (((h . l) r c d) `(,h ,r ,c ,d))))
(define (*cdr x) (match x (((h . l) r c d) `(,l ,r ,(+ c 1) ,d))))
(define (*pair? x) (match x ((x r c d) (pair? x))))
(define (*null? x) (match x ((x r c d) (null? x))))
(define (*equal? x y) (match x ((x r c d) (equal? x y))))
;; defining xmatch utility - this just will use match but automatically fill
in
;; the header and make sure to use correct syntactic environment.
;; (make-phd-matcher name phd abs)
;; defaults is to use (*car ...), - means usual match will be done by (car
...)
;; we also tell the matcher to use a set of abstractions with appropriate
;; variables to bind to. xmatch will be anaphoric though.
(make-phd-matcher xmatch
((*car *cdr *pair? *null? *equal?)
( (+ (*car *cdr *pair? *null? *equal?))
(- ( car cdr pair? null? equal?))))
((<ws> )
(<up> )
(<down> )
(<npar?> )
(<pk> )
(<+> plus )
(<atom> atom )
(<statement> st )
(<statements*> sts )
(<statements> sts )))
;; sp? is a predicate for white characters and w? is nonwhite characters and
;; not ( or )
(define (sp? x) (member (car x) '(#\space #\tab #\newline)))
(define (w? x) (and (not (member (car x) '(#\( #\)))) (not (sp? x))))
;; first matcher just silintly parse away whities
;; matches 0 or more white characters and make sure to count lines
;; a newline counts here a a white character.
;; note how we turn the matcher into ordinary matching to fetch statistics
(define (<ws> X)
(xmatch X
( [#\newline . (- L r c d)] (<ws> `(,L ,(+ r 1) 0 ,d)) )
( [(? sp?) . L ] (<ws> L) )
( L (cons 'ws L) )))
;; <*> an abstraction that matches 0 or more (? m?) characters.
(define (<*> m?)
(define (f L X)
(xmatch X
([(? m? M) . U] (f (cons M L) U))
(U (cons (reverse L) U))))
(lambda (X) (f '() X)))
;; <*> an abstraction that matches 1 or more (? m?) characters.
(define (<+> m?)
(define (f L X)
(xmatch X
([(? m? M) . U] (f (cons (car M) L) U))
(U (cons (reverse L) U))))
(lambda (X)
(xmatch X
([(? m? M) . L] (f (cons (car M) '()) L))
(_ #f))))
;; debugger, just put it into a macther list to spy :-) on the matching
(define (<pk> X) (begin (pk (car X)) (cons 'ok X)))
;; atoms is just a sequence of 1 or more nonwhite characters.
;; note the use of the <+> abstraction!
(define (<atom> X)
(xmatch X
([(<+> w?) . L] (cons `(<atom> ,(list->string plus) ,@(cdr X)) L))
(_ #f)))
;; <down> and <up> will make sure to handle depth statistics
(define (<down> X) (match X ([L r c d] (cons #t `(,L ,r ,c ,(+ d 1))))))
(define (<up> X) (match X ([L r c 0] (error (format #f
"to many ) parenthesis
at row ~a column ~a"
r c)))
([L r c d] (cons #t `(,L ,r ,c ,(- d 1)))))
;; just a check at the end that paranthesis matches.
(define (<npar?> X) (match X
([L r c 0] (cons #t `(,L ,r ,c 0)))
([L r c d] (error (format #f "~a ) is missing at
the end!!" d)))))
;; <statement> atom or ( 0 or more statements )
(define (<statement> X)
(xmatch X
([<ws> (and H #\() <down> <statements*> <ws> #\) <up> . L]
(cons `(list ,(cadr sts) ,@(cdr H)) L))
([<ws> <atom> . L]
(cons atom L))
(_ #f)))
;; 0 or more statments inside a paranthesis e.g. need to look for ) pattern
(define (<statements*> X)
(xmatch X
([<ws> #\) . L] (cons `(stms ( )
,@(cdr X )) X))
([<statement> <statements*> . L] (cons `(stms (,st ,@(cadr sts))
,@(cddr st)) L))
(_ #f)))
;; 1 or more toplevel statements is demanded here
(define (<statements> X)
(xmatch X
([<statement> <statements> . L] (cons `(stms (,st ,@(cadr sts))
,@(cddr st)) L))
([<statement> . L] (cons `(stms (,st )
,@(cddr st)) L))
(_ #f)))
;; Oh well here comes a parser primitive, Need to initiate the Matcher.
(define (parse X) (xmatch `(,(string->list X) 0 0 0) ([<statements> <npar?>
<ws>] sts)))
;; Example (one can improve column numbers slightly here :-))
(parse "
one
big
fat ( hacker eat (cucumber with mustard
(pokes the stomache)))
oh well
")
>>>
(stms ( (<atom> "one" 1 0 0)
(<atom> "big" 2 0 0)
(<atom> "fat" 3 0 0)
(list ( (<atom> "hacker" 3 6 1)
(<atom> "eat" 3 13 1)
(list ( (<atom> "cucumber" 3 18 2)
(<atom> "with" 3 27 2)
(<atom> "mustard" 3 32 2)
(list ( (<atom> "pokes" 4 9 3)
(<atom> "the" 4 15 3)
(<atom> "stomache" 4 19 3))
4 8 2))
3 17 1))
3 4 0)
(<atom> "oh" 5 0 0)
(<atom> "well" 5 3 0))
1 0 0)
Have fun
/Stefan
[-- Attachment #2: match-phd.scm --]
[-- Type: text/x-scheme, Size: 27571 bytes --]
;; 2010/05/20 - record matching for guile (Stefan Israelsson Tampe)
;; Modifying upstream version (match.upstream.scm) by Alex Shinn
;; 2010/08/29 - match abstractions and unquote added
(define-module (ice-9 match-phd)
#:use-module (srfi srfi-9)
#:export (match-define match-let* match-let match-letrec match-lambda*
match-lambda match make-phd-matcher))
(define-syntax match
(syntax-rules (abstractions phd)
((match)
(match-syntax-error "missing match expression"))
((match atom)
(match-syntax-error "no match clauses"))
((match abstractions abs phd p . l)
(match* (abs p) . l))
((match phd p abstractions abs . l)
(match* (abs p) . l))
((match abstractions abs . l)
(match* (abs ((car cdr pair? null? equal?) ())) . l))
((match phd p . l)
(match* (() p) . l))
((match x . l)
(match* (() ((car cdr pair? null? equal?) ())) x . l))))
(define-syntax match*
(syntax-rules ()
((match* abs (app ...) (pat . body) ...)
(let ((v (app ...)))
(match-next abs v ((app ...) (set! (app ...))) (pat . body) ...)))
((match* abs #(vec ...) (pat . body) ...)
(let ((v #(vec ...)))
(match-next abs v (v (set! v)) (pat . body) ...)))
((match* abs atom (pat . body) ...)
(let ((v atom))
(match-next abs v (atom (set! atom)) (pat . body) ...)))
))
(define-syntax match-next
(syntax-rules (=>)
;; no more clauses, the match failed
((match-next abs v g+s)
(error 'match "no matching pattern"))
;; named failure continuation
((match-next abs v g+s (pat (=> failure) . body) . rest)
(let ((failure (lambda () (match-next abs v g+s . rest))))
;; match-one analyzes the pattern for us
(match-one abs v pat g+s (match-drop-ids (begin . body)) (match-drop-ids (failure)) ())))
;; anonymous failure continuation, give it a dummy name
((match-next abs v g+s (pat . body) . rest)
(match-next abs v g+s (pat (=> failure) . body) . rest))))
(define-syntax match-one
(lambda (x)
(syntax-case x ()
((q . l)
;(pk `(match-one ,(syntax->datum (syntax l))))
(syntax (match-one* . l))))))
(define-syntax abs-drop
(syntax-rules ()
((_ a (k ...) v) (k ... v))))
(define-syntax match-one*
(syntax-rules ()
;; If it's a list of two or more values, check to see if the
;; second one is an ellipse and handle accordingly, otherwise go
;; to MATCH-TWO.
((match-one* abs v (p q . r) g+s sk fk i)
(match-check-ellipse
q
(match-extract-vars abs p (abs-drop (match-gen-ellipses abs v p r g+s sk fk i)) i ())
(match-two abs v (p q . r) g+s sk fk i)))
;; Go directly to MATCH-TWO.
((match-one* . x)
(match-two . x))))
(define-syntax insert-abs
(lambda (x)
(syntax-case x ()
((q . l)
;(pk `(insert-abs ,(syntax->datum (syntax l))))
(syntax (insert-abs* . l))))))
(define-syntax insert-abs*
(syntax-rules (begin)
((insert-abs abs (begin . l)) (begin . l))
((insert-abs abs (x)) (x))
((insert-abs abs (n nn ...)) (n abs nn ...))))
(define-syntax match-two
(lambda (x)
(syntax-case x ()
((q . l)
;(pk `(match-two ,(syntax->datum (syntax l))))
(syntax (match-two* . l))))))
(define-syntax match-two*
(syntax-rules (_ ___ *** <> unquote unquote-splicing quote quasiquote ? $ = and or not set! get!)
((match-two (abs ((car cdr pair? null? equal?) pp)) v () g+s (sk ...) fk i)
(if (null? v)
(insert-abs (abs ((car cdr pair? null? equal?) pp)) (sk ... i))
(insert-abs (abs ((car cdr pair? null? equal?) pp)) fk)))
((match-two (abs ((car cdr pair? null? equal?) pp)) v (quote p) g+s (sk ...) fk i)
(if (equal? v 'p)
(insert-abs (abs ((car cdr pair? null? equal?) pp)) (sk ... i))
(insert-abs (abs ((car cdr pair? null? equal?) pp)) fk)))
;;Stis uquote logic
((match-two (abs ((car cdr pair? null? equal?) pp)) v (unquote p) g+s (sk ...) fk i)
(if (equal? v 'p)
(insert-abs (abs ((car cdr pair? null? equal?) pp)) (sk ... i))
(insert-abs (abs ((car cdr pair? null? equal?) pp)) fk)))
((match-two (abs ((ccar ccdr ppair? null? equal?) rr)) v (unquote-splicing p) g+s (sk ...) fk i)
(let loop ((vv v)
(pp p))
(if (pair? pp)
(if (and (ppair? vv) (equal? (ccar vv) (car pp)))
(loop (ccdr vv) (cdr pp))
(insert-abs (abs ((ccar ccdr ppair? null? equal?) rr)) fk))
(insert-abs (abs ((ccar ccdr ppair? null? equal?) rr)) (sk ... i)))))
((match-two abs v (quasiquote p) . x)
(match-quasiquote abs v p . x))
((match-two abs v (and) g+s (sk ...) fk i) (insert-abs abs (sk ... i)))
((match-two abs v (and p q ...) g+s sk fk i)
(match-one abs v p g+s (match-one v (and q ...) g+s sk fk) fk i))
((match-two abs v (or) g+s sk fk i) (insert-abs abs fk))
((match-two abs v (or p) . x)
(match-one abs v p . x))
((match-two abs v (or p ...) g+s sk fk i)
(match-extract-vars abs (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
((match-two abs v (not p) g+s (sk ...) fk i)
(match-one abs v p g+s (match-drop-ids fk) (sk ... i) i))
((match-two abs v (get! getter) (g s) (sk ...) fk i)
(let ((getter (lambda () g))) (insert-abs abs (sk ... i))))
((match-two abs v (set! setter) (g (s ...)) (sk ...) fk i)
(let ((setter (lambda (x) (s ... x)))) (insert-abs abs (sk ... i))))
((match-two abs v (? pred . p) g+s sk fk i)
(if (pred v) (match-one abs v (and . p) g+s sk fk i) (insert-abs abs fk)))
;; stis, added $ support!
((match-two abs v ($ n) g-s sk fk i)
(if (n v)
(insert-abs abs sk)
(insert-abs abs fk)))
((match-two abs v ($ nn p ...) g+s sk fk i)
(if (nn v)
(match-$ abs (and) 0 (p ...) v sk fk i)
(insert-abs abs fk)))
;; stis, added the possibility to use set! and get to records
((match-two abs v (= 0 m p) g+s sk fk i)
(let ((w (struct-ref v m)))
(match-one abs w p ((struct-ref v m) (struct-set! v m)) sk fk i)))
((match-two abs v (= g s p) g+s sk fk i)
(let ((w (g v))) (match-one abs w p ((g v) (s v)) sk fk i)))
((match-two abs v (= proc p) g+s . x)
(let ((w (proc v))) '() (match-one abs w p . x)))
((match-two abs v ((<> (f ...) p) . l) g+s sk fk i)
(let ((res (f ... v)))
(if (car res)
(match-one abs (car res) g+s
(match-one (cdr res) l g+s sk fk)
fk i)
(isert-abs abs fk))))
((match-two abs v (p ___ . r) g+s sk fk i)
(match-extract-vars abs p (abs-drop (match-gen-ellipses abs v p r g+s sk fk i) i ())))
((match-two (abs phd) v p g+s sk fk i)
(match-abstract () abs phd v p g+s sk fk i))))
(define-syntax match-gen-or
(syntax-rules ()
((_ abs v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
(let ((sk2 (lambda (id ...) (insert-abs abs (sk ... (i ... id ...))))))
(match-gen-or-step abs v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
(define-syntax match-gen-or-step
(syntax-rules ()
((_ abs v () g+s sk fk . x)
;; no OR clauses, call the failure continuation
(insert-abs abs fk))
((_ abs v (p) . x)
;; last (or only) OR clause, just expand normally
(match-one abs v p . x))
((_ abs v (p . q) g+s sk fk i)
;; match one and try the remaining on failure
(match-one abs v p g+s sk (match-gen-or-step v q g+s sk fk i) i))
))
(define-syntax match-three
(lambda (x)
(syntax-case x ()
((q . l)
;(pk `(match-three ,(syntax->datum (syntax l))))
(syntax (match-three* . l))))))
(define-syntax match-three*
(syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
((match-two (abs ((car cdr pair? null?) rr)) v (p) g+s sk fk i)
(if (and (pair? v) (null? (cdr v)))
(let ((w (car v)))
(match-one (abs ((car cdr pair? null?) rr)) w p ((car v) (set-car! v)) sk fk i))
fk))
((match-two abs v (p *** q) g+s sk fk i)
(match-extract-vars abs p (match-gen-search v p q g+s sk fk i) i ()))
((match-two abs v (p *** . q) g+s sk fk i)
(match-syntax-error "invalid use of ***" (p *** . q)))
((match-two (abs ((car cdr pair? null? equal?) pp)) v (p . q) g+s sk fk i)
(if (pair? v)
(let ((w (car v)) (x (cdr v)))
(match-one (abs ((car cdr pair? null? equal?) pp)) w p ((car v) (set-car! v))
(match-one x q ((cdr v) (set-cdr! v)) sk fk)
fk
i))
(insert-abs (abs ((car cdr pair? null? equal?) pp)) fk)))
((match-two abs v #(p ...) g+s . x)
(match-vector abs v 0 () (p ...) . x))
((match-two abs v _ g+s (sk ...) fk i) (insert-abs abs (sk ... i)))
;; Not a pair or vector or special literal, test to see if it's a
;; new symbol, in which case we just bind it, or if it's an
;; already bound symbol or some other literal, in which case we
;; compare it with EQUAL?.
((match-two (abs ((car cdr pair? null? equal?) pp)) v x g+s (sk ...) fk (id ...))
(let-syntax
((new-sym?
(syntax-rules (id ...)
((new-sym? x sk2 fk2) sk2)
((new-sym? y sk2 fk2) fk2))))
(new-sym? random-sym-to-match
(let ((x v))
(insert-abs (abs ((car cdr pair? null? equal?) pp)) (sk ... (id ... x))))
(if (equal? v x)
(insert-abs (abs ((car cdr pair? null? equal?) pp)) (sk ... (id ...)))
(insert-abs (abs ((car cdr pair? null? equal?) pp)) fk)))))
))
(define-syntax match-abstract
(lambda (x)
(syntax-case x ()
((q . l)
;(pk `(match-abstract ,(syntax->datum (syntax l))))
(syntax (match-abstract* . l))))))
(define-syntax match-abstract*
(lambda (x)
(syntax-case x ()
((q x () phd y p . l)
(syntax (match-phd () phd x y p . l)))
((q (x ...) ((a) us ...) phd y ((b bs ...) . ps) g+s sk fk i)
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(syntax (let ((ret ((a bs ...) y)))
(if ret
(match-one (((a) us ... x ...) phd) (cdr ret) ps g+s sk fk i)
(insert-abs (((a) us ... x ...) phd) fk))))
(syntax (match-abstract ((a) x ...) (us ...) phd y ((b bs ...) . ps) g+s sk fk i))))
((q (x ...) ((a aa as ...) us ...) phd y ((b bs ...) . ps) g+s sk fk i)
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(syntax (let ((ret ((a bs ...) y)))
(if ret
(let ((aa (car ret)))
(match-one (((a as ...) us ... x ...) phd) (cdr ret) ps g+s sk fk (aa . i)))
(insert-abs (((a as ...) us ... x ...) phd) fk))))
(syntax (match-abstract ((a aa as ...) x ...) (us ...) phd y ((b bs ...) . ps) g+s sk fk i))))
((q (x ...) ((a) us ...) phd y (b . ps) g+s sk fk i)
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(syntax (let ((ret (a y)))
(if ret
(match-one (((a) us ... x ...) phd) (cdr ret) ps g+s sk fk i)
(insert-abs (((a) us ... x ...) phd) fk))))
(syntax (match-abstract ((a) x ...) (us ...) phd y (b . ps) g+s sk fk i))))
((q (x ...) ((a aa as ...) us ...) phd y (b . ps) g+s sk fk i)
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(syntax (let ((ret (a y)))
(if ret
(let ((aa (car ret)))
(match-one (((a as ...) us ... x ...) phd) (cdr ret) ps g+s sk fk (aa . i)))
(insert-abs (((a as ...) us ... x ...) phd) fk))))
(syntax (match-abstract ((a aa as ...) x ...) (us ...) phd y (b . ps) g+s sk fk i))))
((q () abs phd y p g+s sk fk i)
(syntax (match-phd () phd abs y p g+s sk fk i))))))
(define-syntax match-phd
(lambda (x)
(syntax-case x ()
((_ phd (c ( )) abs . l) (syntax (match-three (abs (c phd)) . l)))
((_ (phd ...) (c ((h a) hh ...)) abs v (h2 . l) g+s sk fk i)
(if (eq? (syntax->datum (syntax h)) (syntax->datum (syntax h2)))
(syntax (match-one (abs (a ((h a) hh ... phd ...))) v l g+s (set-phd-sk c sk) (set-phd-fk c fk) i))
(syntax (match-phd ((h a) phd ...) (c (hh ...)) abs v (h2 . l) g+s sk fk i))))
((_ () phd abs . l)
(syntax (match-three (abs phd) . l))))))
(define-syntax set-phd-fk
(syntax-rules (begin)
((_ abs cc (begin . l)) (begin . l))
((_ abs cc (fk)) (fk))
((_ (abs (c pp)) cc (fk fkk ...)) (fk (abs (cc pp)) fkk ...))))
(define-syntax set-phd-sk
(syntax-rules (begin)
((_ abs cc (begin . l) i ...) (begin . l))
((_ abs cc (fk) i ...) (fk))
((_ (abs (c pp)) cc (fk fkk ...) i ...) (fk (abs (cc pp)) fkk ... i ...))))
(define-syntax match-$
(lambda (x)
(syntax-case x ()
((q abs (a ...) m (p1 p2 ...) . v)
(with-syntax ((m+1 (datum->syntax (syntax q)
(+ (syntax->datum (syntax m)) 1))))
(syntax (match-$ abs (a ... (= 0 m p1)) m+1 (p2 ...) . v))))
((_ abs newpat m () v kt ke i)
(syntax (match-one abs v newpat () kt ke i))))))
(define-syntax match-gen-ellipses
(lambda (x)
(syntax-case x ()
((q . l)
;(pk `(match-gen-ellipses ,@(syntax->datum (syntax l))))
(syntax (match-gen-ellipses* . l))))))
(define-syntax match-gen-ellipses*
(syntax-rules ()
((_ abs v p () g+s (sk ...) fk i ((id id-ls) ...))
(match-check-identifier p
;; simplest case equivalent to (p ...), just bind the list
(let ((p v))
(if (list? p)
(insert-abs abs (sk ... i))
(insert-abs abs fk)))
;; simple case, match all elements of the list
(let loop ((ls v) (id-ls '()) ...)
(cond
((null? ls)
(let ((id (reverse id-ls)) ...) (insert-abs abs (sk ... i))))
((pair? ls)
(let ((w (car ls)))
(match-one abs w p ((car ls) (set-car! ls))
(match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
fk i)))
(else
(insert-abs abs fk))))))
((_ abs v p r g+s (sk ...) fk i ((id id-ls) ...))
;; general case, trailing patterns to match, keep track of the
;; remaining list length so we don't need any backtracking
(match-verify-no-ellipses
r
(let* ((tail-len (length 'r))
(ls v)
(len (length ls)))
(if (< len tail-len)
fk
(let loop ((ls ls) (n len) (id-ls '()) ...)
(cond
((= n tail-len)
(let ((id (reverse id-ls)) ...)
(match-one abs ls r (#f #f) (sk ...) fk i)))
((pair? ls)
(let ((w (car ls)))
(match-one abs w p ((car ls) (set-car! ls))
(match-drop-ids
(loop (cdr ls) (- n 1) (cons id id-ls) ...))
fk
i)))
(else
fk)))))))))
(define-syntax match-drop-ids
(syntax-rules ()
((_ abs expr ids ...) expr)))
(define-syntax match-gen-search
(syntax-rules ()
((match-gen-search abs v p q g+s sk fk i ((id id-ls) ...))
(letrec ((try (lambda (w fail id-ls ...)
(match-one abs w q g+s
(match-drop-ids
(let ((id (reverse id-ls)) ...)
sk))
(match-drop-ids (next w fail id-ls ...)) i)))
(next (lambda (w fail id-ls ...)
(if (not (pair? w))
(fail)
(let ((u (car w)))
(match-one
abs u p ((car w) (set-car! w))
(match-drop-ids
;; accumulate the head variables from
;; the p pattern, and loop over the tail
(let ((id-ls (cons id id-ls)) ...)
(let lp ((ls (cdr w)))
(if (pair? ls)
(try (car ls)
(lambda () (lp (cdr ls)))
id-ls ...)
(fail)))))
(fail) i))))))
;; the initial id-ls binding here is a dummy to get the right
;; number of '()s
(let ((id-ls '()) ...)
(try v (lambda () (insert-abs abs fk)) id-ls ...))))))
(define-syntax match-quasiquote
(syntax-rules (unquote unquote-splicing quasiquote)
((_ abs v (unquote p) g+s sk fk i)
(match-one abs v p g+s sk fk i))
((_ abs v ((unquote-splicing p) . rest) g+s sk fk i)
(if (pair? v)
(match-one abs v
(p . tmp)
(match-quasiquote tmp rest g+s sk fk)
fk
i)
(insert-abs abs fk)))
((_ abs v (quasiquote p) g+s sk fk i . depth)
(match-quasiquote abs v p g+s sk fk i #f . depth))
((_ abs v (unquote p) g+s sk fk i x . depth)
(match-quasiquote abs v p g+s sk fk i . depth))
((_ abs v (unquote-splicing p) g+s sk fk i x . depth)
(match-quasiquote abs v p g+s sk fk i . depth))
((_ abs v (p . q) g+s sk fk i . depth)
(if (pair? v)
(let ((w (car v)) (x (cdr v)))
(match-quasiquote
abs w p g+s
(match-quasiquote-step x q g+s sk fk depth)
fk i . depth))
(insert-abs abs fk)))
((_ abs v #(elt ...) g+s sk fk i . depth)
(if (vector? v)
(let ((ls (vector->list v)))
(match-quasiquote abs ls (elt ...) g+s sk fk i . depth))
(insert-abs abs fk)))
((_ abs v x g+s sk fk i . depth)
(match-one abs v 'x g+s sk fk i))))
(define-syntax match-quasiquote-step
(syntax-rules ()
((match-quasiquote-step abs x q g+s sk fk depth i)
(match-quasiquote abs x q g+s sk fk i . depth))))
(define-syntax match-extract-vars
(lambda (x)
(syntax-case x ()
((q . l)
;(pk `(match-extract-vars ,(syntax->datum (syntax l))))
(syntax (match-extract-vars* . l))))))
;;We must be able to extract vars in the new constructs!!
(define-syntax match-extract-vars*
(syntax-rules (_ ___ *** ? $ <> = quote quasiquote unquote unquote-splicing and or not get! set!)
((match-extract-vars abs (? pred . p) . x)
(match-extract-vars abs p . x))
((match-extract-vars abs ($ rec . p) . x)
(match-extract-vars abs p . x))
((match-extract-vars abs (= proc p) . x)
(match-extract-vars abs p . x))
((match-extract-vars abs (= u m p) . x)
(match-extract-vars abs p . x))
((match-extract-vars abs (quote x) (k kk ...) i v)
(k abs kk ... v))
((match-extract-vars abs (unquote x) (k kk ...) i v)
(k abs kk ... v))
((match-extract-vars abs (unquote-splicing x) (k kk ...) i v)
(k abs kk ... v))
((match-extract-vars abs (quasiquote x) k i v)
(match-extract-quasiquote-vars abs x k i v (#t)))
((match-extract-vars abs (and . p) . x)
(match-extract-vars abs p . x))
((match-extract-vars abs (or . p) . x)
(match-extract-vars abs p . x))
((match-extract-vars abs (not . p) . x)
(match-extract-vars abs p . x))
;; A non-keyword pair, expand the CAR with a continuation to
;; expand the CDR.
((match-extract-vars abs (<> f p) k i v)
(match-extract-vars abs p k i v))
((match-extract-vars (abs phd) p k i v)
(abs-extract-vars () abs phd p k i v))))
(define-syntax match-extract-vars2
(syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!)
((match-extract-vars abs (p q . r) k i v)
(match-check-ellipse
q
(match-extract-vars abs (p . r) k i v)
(match-extract-vars abs p (match-extract-vars-step (q . r) k i v) i ())))
((match-extract-vars abs (p . q) k i v)
(match-extract-vars abs p (match-extract-vars-step q k i v) i ()))
((match-extract-vars abs #(p ...) . x)
(match-extract-vars abs (p ...) . x))
((match-extract-vars abs _ (k kk ...) i v) (k abs kk ... v))
((match-extract-vars abs ___ (k kk ...) i v) (k abs kk ... v))
((match-extract-vars abs *** (k kk ...) i v) (k abs kk ... v))
;; This is the main part, the only place where we might add a new
;; var if it's an unbound symbol.
((match-extract-vars abs p (k kk ...) (i ...) v)
(let-syntax
((new-sym?
(syntax-rules (i ...)
((new-sym? p sk fk) sk)
((new-sym? x sk fk) fk))))
(new-sym? random-sym-to-match
(k abs kk ... ((p p-ls) . v))
(k abs kk ... v))))
))
(define-syntax abs-extract-vars
(lambda (x)
(syntax-case x ()
((q . l)
(pk `(abs-extract-vars ,@(syntax->datum (syntax l))))
(syntax (abs-extract-vars* . l))))))
(define-syntax abs-extract-vars*
(lambda (x)
(syntax-case x ()
((q abs () phd p . l) (syntax (match-extract-phd () phd abs p . l)))
((q (abs ...) ((a x . xs) us ...) phd ((b bs ...) w ...) k i v)
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(syntax (match-extract-vars
(((a . xs) us ... abs ...) phd) (w ...) k i ((x x-ls) . v)))
(syntax (abs-extract-vars
((a x . xs) abs ...) (us ...) phd ((b bs ...) w ...) k i v))))
((q (abs ...) ((a) us ...) phd ((b bs ...) w ...) k i v)
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(syntax (match-extract-vars
(((a) us ... abs ...) phd) (w ...) k i v)))
(syntax (abs-extract-vars
((a) abs ...) (us ...) phd ((b bs ...) w ...) k i v)))
((q (abs ...) ((a x . xs) us ...) phd (b w ...) k i v)
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(syntax (match-extract-vars
(((a . xs) us ... abs ...) phd) (w ...) k i ((x x-ls) . v)))
(syntax (abs-extract-vars
((a x . xs) abs ...) (us ...) phd (b w ...) k i v))))
((q (abs ...) ((a) us ...) phd (b w ...) k i v)
(if (eq? (syntax->datum (syntax a)) (syntax->datum (syntax b)))
(syntax (match-extract-vars
(((a) us ... abs ...) phd) (w ...) k i v))
(syntax (abs-extract-vars
((a) abs ...) (us ...) phd (b w ...) k i v))))
((q () a phd p k i v)
(syntax (match-extract-phd () phd a p k i v))))))
(define-syntax match-extract-phd
(syntax-rules ()
((_ _ phd abs . l) (match-extract-vars2 (abs phd) . l))))
(define-syntax match-extract-vars-step
(syntax-rules ()
((_ abs p k i v ((v2 v2-ls) ...))
(match-extract-vars abs p k (v2 ... . i) ((v2 v2-ls) ... . v)))
))
(define-syntax match-extract-quasiquote-vars
(syntax-rules (quasiquote unquote unquote-splicing)
((match-extract-quasiquote-vars abs (quasiquote x) k i v d)
(match-extract-quasiquote-vars abs x k i v (#t . d)))
((match-extract-quasiquote-vars abs (unquote-splicing x) k i v d)
(match-extract-quasiquote-vars abs (unquote x) k i v d))
((match-extract-quasiquote-vars abs (unquote x) k i v (#t))
(match-extract-vars abs x k i v))
((match-extract-quasiquote-vars abs (unquote x) k i v (#t . d))
(match-extract-quasiquote-vars abs x k i v d))
((match-extract-quasiquote-vars abs (x . y) k i v (#t . d))
(match-extract-quasiquote-vars abs
x
(match-extract-quasiquote-vars-step y k i v d) i ()))
((match-extract-quasiquote-vars abs #(x ...) k i v (#t . d))
(match-extract-quasiquote-vars abs (x ...) k i v d))
((match-extract-quasiquote-vars abs x (k kk ...) i v (#t . d))
(k abs kk ... v))
))
(define-syntax match-extract-quasiquote-vars-step
(syntax-rules ()
((_ abs x k i v d ((v2 v2-ls) ...))
(match-extract-quasiquote-vars abs x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
))
(define-syntax match-define
(syntax-rules (abstractions)
((q abstractions abs arg code)
(match-extract-vars abs arg (sieve (match-define-helper0 arg code) ()) () ()))
((q arg code)
(match-extract-vars () arg (sieve (match-define-helper0 arg code) ()) () ()))))
(define-syntax sieve
(syntax-rules ()
((_ cc (w ...) ((v q) v2 ...))
(sieve cc (v w ...) (v2 ...)))
((_ cc (w ...) (v v2 ...))
(sieve cc (v w ...) (v2 ...)))
((_ (cc ...) w ())
(cc ... w))))
(define-syntax match-define-helper0
(lambda (x)
(syntax-case x ()
((q arg code v)
(with-syntax ((vtemp (map (lambda (x)
(datum->syntax
(syntax q) (gensym "temp")))
(syntax->datum (syntax v)))))
(syntax (match-define-helper v vtemp arg code)))))))
(define-syntax match-define-helper
(syntax-rules ()
((_ (v ...) (vt ...) arg code)
(begin
(begin (define v 0)
...)
(let ((vt 0) ...)
(match code
(arg (begin (set! vt v)
...)))
(begin (set! v vt)
...))))))
;;;Reading the rest from upstream
;;Utility
(define-syntax include-from-path/filtered
(lambda (x)
(define (hit? sexp reject-list)
(if (null? reject-list)
#f
(let ((h (car reject-list))
(l (cdr reject-list)))
(if (and (pair? sexp)
(eq? 'define-syntax (car sexp))
(pair? (cdr sexp))
(eq? h (cadr sexp)))
#t
(hit? sexp l)))))
(define (read-filtered reject-list file)
(with-input-from-file (%search-load-path file)
(lambda ()
(let loop ((sexp (read)) (out '()))
(cond
((eof-object? sexp) (reverse out))
((hit? sexp reject-list)
(loop (read) out))
(else
(loop (read) (cons sexp out))))))))
(syntax-case x ()
((_ reject-list file)
(with-syntax (((exp ...) (datum->syntax
x
(read-filtered
(syntax->datum #'reject-list)
(syntax->datum #'file)))))
#'(begin exp ...))))))
(include-from-path/filtered
(match-extract-vars match-one match-gen-or match-gen-or-step
match-two match match-next match-gen-ellipses
match-drop-ids match-gen-search match-quasiquote
match-quasiquote-step match-extract-vars-step
match-extract-quasiquote-vars match-extract-quasiquote-vars-step)
"ice-9/match.upstream.scm")
(define-syntax make-phd-matcher
(syntax-rules ()
((_ name pd abs)
(define-syntax name
(lambda (x)
(syntax-case x ()
((_ . l)
(with-syntax ((aabs (datum->syntax x (syntax->datum (syntax abs)))))
(syntax (match abstractions aabs phd pd . l))))))))))
^ permalink raw reply [flat|nested] 6+ messages in thread* Re: Where the next effort in prolog will be and a cool match hack!!
2010-09-09 21:15 Where the next effort in prolog will be and a cool match hack!! Stefan Israelsson Tampe
@ 2010-09-10 8:50 ` Andy Wingo
2010-09-10 14:28 ` Andy Wingo
2010-09-13 2:32 ` Alex Shinn
1 sibling, 1 reply; 6+ messages in thread
From: Andy Wingo @ 2010-09-10 8:50 UTC (permalink / raw)
To: Stefan Israelsson Tampe; +Cc: guile-devel
Hi Stefan,
No comments on the actual code, but:
On Thu 09 Sep 2010 23:15, Stefan Israelsson Tampe <stefan.tampe@spray.se> writes:
> (use-modules (ice-9 match-phd))
I think this is the right approach (making a separate) :) Alex's code is
clean, understandable, and has a historical interface to respect. Your
has lots of interesting ideas but it is still in flux, and I don't
understand it all.
So a stis-match module does sound like the right thing here :)
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: Where the next effort in prolog will be and a cool match hack!!
2010-09-09 21:15 Where the next effort in prolog will be and a cool match hack!! Stefan Israelsson Tampe
2010-09-10 8:50 ` Andy Wingo
@ 2010-09-13 2:32 ` Alex Shinn
2010-09-13 12:20 ` Ludovic Courtès
2010-09-13 18:45 ` Stefan Israelsson Tampe
1 sibling, 2 replies; 6+ messages in thread
From: Alex Shinn @ 2010-09-13 2:32 UTC (permalink / raw)
To: Stefan Israelsson Tampe; +Cc: guile-devel
On Fri, Sep 10, 2010 at 6:15 AM, Stefan Israelsson Tampe
<stefan.tampe@spray.se> wrote:
>
> I just wanted to share some ideas that come to my mind to churn the prolog
> into something more useful.
Have you played with schelog and kanren?
> So I have been trying to rework Shins hygienic version if ice-9 match so that
> it can be used as a backbone for it.
[That's "Shinn" with two n's.]
> ;; defining xmatch utility - this just will use match but automatically fill in
> ;; the header and make sure to use correct syntactic environment.
> ;; (make-phd-matcher name phd abs)
> ;; defaults is to use (*car ...), - means usual match will be done by (car ...)
> ;; we also tell the matcher to use a set of abstractions with appropriate
> ;; variables to bind to. xmatch will be anaphoric though.
Right, a limitation of Wright's syntax is that "match" itself isn't
extensible, so to build on it you need to define syntax which
defines new pattern matchers.
The default matcher in Racket is extensible by dispatching
on the first symbol in each list, so a pair is (cons a b) and a
list would be (list a b c). This is slightly more verbose, and
looks like how you would generate the data rather than its
actual structure, but at least is extensible.
It would be possible to build on Wright's syntax with a
single hook, e.g. patterns of the form
(extended-match match-dispatcher data ...)
possibly abbreviated
(: match-dispatcher data ...)
where `match-dispatcher' is an extension macro following
some CPS API. A kludge, but perhaps better than
redefining a matcher for every extension.
--
Alex
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: Where the next effort in prolog will be and a cool match hack!!
2010-09-13 2:32 ` Alex Shinn
@ 2010-09-13 12:20 ` Ludovic Courtès
2010-09-13 18:45 ` Stefan Israelsson Tampe
1 sibling, 0 replies; 6+ messages in thread
From: Ludovic Courtès @ 2010-09-13 12:20 UTC (permalink / raw)
To: guile-devel
Hi,
Alex Shinn <alexshinn@gmail.com> writes:
> The default matcher in Racket is extensible by dispatching
> on the first symbol in each list, so a pair is (cons a b) and a
> list would be (list a b c). This is slightly more verbose, and
> looks like how you would generate the data rather than its
> actual structure, but at least is extensible.
That’s similar to what OCaml, Coq, Scala, & co. do. The nice thing is
that it’s expressive and makes for an extensible matcher.
> It would be possible to build on Wright's syntax with a
> single hook, e.g. patterns of the form
>
> (extended-match match-dispatcher data ...)
>
> possibly abbreviated
>
> (: match-dispatcher data ...)
>
> where `match-dispatcher' is an extension macro following
> some CPS API. A kludge, but perhaps better than
> redefining a matcher for every extension.
Sounds like a nice plan. :-)
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: Where the next effort in prolog will be and a cool match hack!!
2010-09-13 2:32 ` Alex Shinn
2010-09-13 12:20 ` Ludovic Courtès
@ 2010-09-13 18:45 ` Stefan Israelsson Tampe
1 sibling, 0 replies; 6+ messages in thread
From: Stefan Israelsson Tampe @ 2010-09-13 18:45 UTC (permalink / raw)
To: Alex Shinn; +Cc: guile-devel
Hi Alex,
On Monday, September 13, 2010 04:32:13 am Alex Shinn wrote:
> On Fri, Sep 10, 2010 at 6:15 AM, Stefan Israelsson Tampe
>
> <stefan.tampe@spray.se> wrote:
> > I just wanted to share some ideas that come to my mind to churn the
> > prolog into something more useful.
>
> Have you played with schelog and kanren?
Yeah, I looked briefly at schelog. I'm trying to have both a shelog like
version to code as well the possibility to link in code written in
pure prolog. Then there
is a C-backend which I play with quite severly investigating intersting
extensions to prolog. Like the ability to handle a massive number of
continuations sharing state in a compact way e.g. compress the redo tree. The
speed is ok and on par with non compiled gprolog programs (probably wam
bytecode). Also being guile centric, hence today leads to quite dramatic
speedups using a C backend with the drawback of complicating life :-)
Anyhow my view is that at the heart of a prolog system lies a matcher, just
like yours, where one just have redefined car,cdr,pair?,null? and equal? Ontop
of this is a small macro framework to facilitate tree search.
But point is taken and I will code some example in schelog to compare.
> > So I have been trying to rework Shins hygienic version if ice-9 match so
> > that it can be used as a backbone for it.
>
> [That's "Shinn" with two n's.]
Oh, hmm, to equalize the balance in universe you may call me stefann from
now on ;-),
> > ;; defining xmatch utility - this just will use match but automatically
> > fill in ;; the header and make sure to use correct syntactic
> > environment. ;; (make-phd-matcher name phd abs)
> > ;; defaults is to use (*car ...), - means usual match will be done by
> > (car ...) ;; we also tell the matcher to use a set of abstractions with
> > appropriate ;; variables to bind to. xmatch will be anaphoric though.
>
> Right, a limitation of Wright's syntax is that "match" itself isn't
> extensible, so to build on it you need to define syntax which
> defines new pattern matchers.
Yep that is a good point. On the other hand I think
that Wright's matchers look nicer on many common patterns than to
do the below ritual.
> The default matcher in Racket is extensible by dispatching
> on the first symbol in each list, so a pair is (cons a b) and a
> list would be (list a b c). This is slightly more verbose, and
> looks like how you would generate the data rather than its
> actual structure, but at least is extensible.
Yep, it's really not a stupid thing to design it this way.
> It would be possible to build on Wright's syntax with a
> single hook, e.g. patterns of the form
>
> (extended-match match-dispatcher data ...)
>
> possibly abbreviated
>
> (: match-dispatcher data ...)
>
> where `match-dispatcher' is an extension macro following
> some CPS API. A kludge, but perhaps better than
> redefining a matcher for every extension.
Yeah, cool. But replacing car cdr ... needs a separate code path added
letting the symbols used for list processing flow with the pattern
compilation process and then one can use the : syntax to define a
dispatcher that alters the meaning of the list processing like in the
example I made in the previous mail.
maybe (: (match-dispatcher1 data1 ...)
(match-dispatcher2 data2 ...))
and allow for this pattern only at the top of the match, so by doing
(match (:) ...) will be exactly Wrights matcher?
/Stefan
^ permalink raw reply [flat|nested] 6+ messages in thread
end of thread, other threads:[~2010-09-13 18:45 UTC | newest]
Thread overview: 6+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2010-09-09 21:15 Where the next effort in prolog will be and a cool match hack!! Stefan Israelsson Tampe
2010-09-10 8:50 ` Andy Wingo
2010-09-10 14:28 ` Andy Wingo
2010-09-13 2:32 ` Alex Shinn
2010-09-13 12:20 ` Ludovic Courtès
2010-09-13 18:45 ` Stefan Israelsson Tampe
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).