Andy Wingo's fold

Catonano

unread,

Mar 21, 2020, 5:16:14 AM3/21/20

to racket

Hi,

in Guile there are some modules inspired by Andy Wingos paper: "applications of fold to xml transformation"

In Guile these concepts are used not only for xml processing but for tree processing in general

I was wondering if anything similar is available for Racket

I'm having a hard time in processing a tree with such a fold procedure and I could use some examples

Thanks

Stephen De Gabrielle

unread,

Jun 8, 2020, 10:34:25 AM6/8/20

to Racket Users

Hi Catonano

Did you resolve this

Kind regards

Stephen

Catonano

unread,

Jun 12, 2020, 2:46:58 AM6/12/20

to Stephen De Gabrielle, Racket Users

Hi Stephen,

Il giorno lun 8 giu 2020 alle ore 16:34 Stephen De Gabrielle <spdega...@gmail.com> ha scritto:

Hi Catonano

Did you resolve this

Kind regards

Stephen

No, I didn't resolve this

the original paper Andy Wingo refers to uses Haskell to express this operator and I can't read Haskell and I'm not willing to learn

My idea was to use some drawings of trees made in svg and maybe animations of trees being processed with the original operator (the one expressed in Haskell)

There's a scheme implementation, in my idea I would have traced it while running and I would have prepared a graphical representation

In order to explain the operator to myself, before than to anyone else

But frankly it's a lot of work

If this thing is expressed in such a poor way, maybe its authors are not interested in this idea being a thing

I account this to the cultural debt of the scheme community

Philip McGrath

unread,

Jun 12, 2020, 4:57:30 AM6/12/20

to Catonano, Stephen De Gabrielle, Racket Users

On Fri, Jun 12, 2020 at 2:46 AM Catonano <cato...@gmail.com> wrote:

the original paper Andy Wingo refers to uses Haskell to express this operator and I can't read Haskell and I'm not willing to learn

I'm confused about what you mean: in the version of "Applications of Fold to XML Transformation", on Andy Wingo's blog, all of the examples are in Scheme. Here is a version of the example from the paper that will run in Racket—most of the code is just copied and pasted from the figures:

#lang racket

;; Source: https://wingolog.org/pub/fold-and-xml-transformation.pdf

(module+ test
(require rackunit)
(check-equal?
(cartouche->svg
;; figure 16
'(cartouche (@ (line-color "red")
(text-height 56))
(para "Warning: Smoking Kills")))
;; figure 17
'(g (rect (@ (fill "none") (stroke "red")
(stroke-width "4")
(width "660") (height "120.0")
(x "0") (y "0")
(ry "20")))
(text (@ (xml:space "preserve")
(font-size "56")
(font-family "Georgia")
(x "32")
(y "88"))
(tspan (@ (x "32") (y "88"))
"Warning: Smoking Kills")))))

;; -----------------------------------------------------------------------------
;; -----------------------------------------------------------------------------

;; for Racket compatibility

(define (atom? v)
(not (pair? v)))

(struct layout (x y)
#:constructor-name make-layout
#:transparent)

;; p. 7
;; "Figure 20 uses without definition the macro let-params,
;; which binds lexical variables from the parameters list."
;; p. 6
;; "... representing parameters as a list of association lists.
;; At each descent into a new SXML node, we cons the new parameters
;; onto the list. Lookup proceeds left-to-right in the parameters list,
;; stopping at the first alist in which a parameter is found."
(require syntax/parse/define)
(define-simple-macro (let-params params:expr (name:id ...)
body:expr ...+)
(let ([the-params params])
(let ([name (params-ref the-params 'name)]
...)
body ...)))
(define (params-ref params name)
(or (for*/first ([alist (in-list params)]
[pr (in-list alist)]
#:when (eq? name (car pr)))
(cadr pr))
(raise-argument-error 'params-ref "no binding found for parameter"
"name" name
"params" params)))

;; -----------------------------------------------------------------------------
;; -----------------------------------------------------------------------------

;; figure 7 (part)
(define (assq-ref alist key default)
(cond ((assq key alist) => cdr)
(else default)))

;; figure 11
(define (fold-values proc list . seeds)
(if (null? list)
(apply values seeds)
(call-with-values
(lambda ()
(apply proc (car list) seeds))
(lambda seeds
(apply fold-values proc (cdr list)
seeds)))))

;; figure 12
(define (foldts*-values fdown fup fhere
tree . seeds)
(if (atom? tree)
(apply fhere tree seeds)
(call-with-values
(lambda () (apply fdown tree seeds))
(lambda (tree . kseeds)
(call-with-values
(lambda ()
(apply fold-values
(lambda (tree . seeds)
(apply foldts*-values
fdown fup fhere
tree seeds))
tree kseeds))
(lambda kseeds
(apply fup tree
(append seeds kseeds))))))))

;; figure 13, but with fdown replaced by figure 14
(define (post-order bindings tree)
(define (err . args)
(error "no binding available" args))
(define (fdown tree bindings pcont ret)
(let ((tail (assq-ref bindings (car tree)
#f)))
(cond
((not tail)
(let ((default (assq-ref bindings
'*default* err)))
(values tree bindings default '())))
((pair? tail)
(let ((cont (cdr tail)))
(case (car tail)
((*preorder*)
(values '() bindings
(lambda x (reverse x))
(apply cont tree)))
((*macro*)
(fdown (apply cont tree) bindings
pcont ret))
(else
(let ((new-bindings (append (car tail)
bindings)))
(values tree new-bindings cont
'()))))))
(else
(values tree bindings tail '())))))
(define (fup tree bindings cont ret
kbindings kcont kret)
(values bindings cont
(cons (apply kcont (reverse kret))
ret)))
(define (fhere tree bindings cont ret)
(define (tcont x)
(if (symbol? x)
x ; pass tags through
((or (assq-ref bindings '*text* #f)
(assq-ref bindings '*default* err))
'*text* x)))
(values bindings cont
(cons (tcont tree) ret)))
(call-with-values
(lambda ()
(foldts*-values fdown fup fhere tree
bindings #f '()))
(lambda (bindings cont ret)
(car ret))))

;; figure 15, with fdown, fup, and fhere
;; filled in from figures 24, 15, and 26, respectively
(define (fold-layout bindings params layout tree)
(define (err . args)
(error "no binding available" args))
(define (fdown tree bindings pcont
params layout ret)
(define (fdown-helper new-bindings
new-layout cont)
(let ((cont-with-tag
(lambda args
(apply cont (car tree) args)))
(bindings
(if new-bindings
(append new-bindings bindings)
bindings)))
(cond
((null? (cdr tree))
(values
'() bindings cont-with-tag
(cons '() params) new-layout '()))
((and (pair? (cadr tree))
(eq? (caadr tree) '@))
(let ((params (cons (cdadr tree) params)))
(values
(cddr tree) bindings cont-with-tag
params new-layout '())))
(else
(values
(cdr tree) bindings cont-with-tag
(cons '() params) new-layout '())))))
(define (no-bindings)
(fdown-helper
#f layout
(assq-ref bindings '*default* err)))
(define (macro macro-handler)
(fdown (apply macro-handler tree)
bindings pcont params layout ret))
(define (pre pre-handler)
(values '() bindings
(lambda (params layout
old-layout kids)
(values layout (reverse kids)))
params layout
(apply pre-handler tree)))
(define (have-bindings tag-bindings)
(fdown-helper
(assq-ref tag-bindings 'bindings #f)
((assq-ref tag-bindings 'pre-layout
(lambda (tag params layout)
layout))
tree params layout)
(assq-ref tag-bindings 'post
(assq-ref bindings
'*default* err))))
(let ((tag-bindings (assq-ref bindings
(car tree)
#f)))
(cond
((not tag-bindings)
(no-bindings))
((assq-ref tag-bindings 'macro #f)
=> macro)
((assq-ref tag-bindings 'pre #f)
=> pre)
(else (have-bindings tag-bindings)))))
(define (fup tree bindings cont params layout ret
kbindings kcont kparams klayout kret)
(call-with-values
(lambda ()
(kcont kparams layout klayout
(reverse kret)))
(lambda (klayout kret)
(values bindings cont params klayout
(cons kret ret)))))
(define (fhere tree bindings cont params
layout ret)
(call-with-values
(lambda ()
((assq-ref bindings '*text* err)
tree params layout))
(lambda (tlayout tret)
(values bindings cont params tlayout
(cons tret ret)))))
(call-with-values
(lambda ()
(foldts*-values
fdown fup fhere tree
bindings #f params layout '()))
(lambda (bindings cont params layout ret)
(values (car ret) layout))))

;; figure 20
(define (cartouche-pre-layout tree params layout)
(let ((x (layout-x layout))
(y (layout-y layout)))
(let-params params (margin-left margin-top)
(make-layout (+ x margin-left)
(+ y margin-top)))))

;; figure 21
(define (make-text-x params layout)
(layout-x layout))
(define (make-text-y params layout)
(let-params params (text-height)
(+ text-height (layout-y layout))))
(define (layout-advance-text-line params layout)
(let-params params (text-height line-spacing)
(make-layout (layout-x layout)
(+ (* text-height line-spacing)
(layout-y layout)))))
(define (text-handler text params layout)
(values
(layout-advance-text-line params layout)
`(tspan
(@ (x ,(number->string
(make-text-x params layout)))
(y ,(number->string
(make-text-y params layout))))
,text)))

;; figure 22
(define (p-post tag params old-layout layout kids)
(values
layout
(let-params params (text-height font-family)
`(text
(@ (xml:space "preserve")
(font-size ,(number->string text-height))
(font-family ,font-family)
(x ,(number->string
(make-text-x params old-layout)))
(y ,(number->string
(make-text-y params old-layout))))
,@kids))))

;; figure 23
(define (cartouche-post tag params old-layout
layout kids)
(let ((oldx (layout-x old-layout))
(oldy (layout-y old-layout))
(newy (layout-y layout)))
(let-params params (margin-bottom stroke-width
line-color page-width)
(values
(make-layout oldx (+ newy margin-bottom))
`(g (rect
(@ (fill "none") (stroke ,line-color)
(stroke-width ,(number->string
stroke-width))
(width ,(number->string
(- page-width (* 2 oldx))))
(height ,(number->string
(+ newy margin-bottom))) ;; CORRECTION: was: (- newy oldy)
(x ,(number->string oldx))
(y ,(number->string oldy))
(ry "20"))) ; rounded corners
,@kids)))))

;; figure 27
(define *cartouche-stylesheet*
`((para
(post . ,p-post))
(cartouche
(pre-layout . ,cartouche-pre-layout)
(post . ,cartouche-post))
(*text* . ,text-handler)))
(define *default-params*
;; CORRECTION: was missing a layer of parentheses
'(((margin-left 32) (margin-right 32)
(margin-top 32) (margin-bottom 32)
(line-spacing 1.0)
(font-family "Georgia")
(stroke-width 4)
(line-color "blue")
(text-height 64)
(page-width 660))))
(define (cartouche->svg doc)
;; CORRECTION: was:
;; (fold-layout doc *cartouche-stylesheet*
;; *default-params*
;; (make-layout 0 0)))
(define-values [svg layout]
(fold-layout *cartouche-stylesheet*
*default-params*
(make-layout 0 0)
doc))
svg)

Catonano

unread,

Jun 14, 2020, 2:21:01 PM6/14/20

to Philip McGrath, Stephen De Gabrielle, Racket Users

Il giorno ven 12 giu 2020 alle ore 10:57 Philip McGrath <phi...@philipmcgrath.com> ha scritto:

On Fri, Jun 12, 2020 at 2:46 AM Catonano <cato...@gmail.com> wrote:
the original paper Andy Wingo refers to uses Haskell to express this operator and I can't read Haskell and I'm not willing to learn

I'm confused about what you mean: in the version of "Applications of Fold to XML Transformation", on Andy Wingo's blog, all of the examples are in Scheme. Here is a version of the example from the paper that will run in Racket—most of the code is just copied and pasted from the figures

I'm referring to a paper titled: "A better XML parser through functional
programming"

by Oleg Kiselyov

I'd like to understand how exactly I'm supposed to arrange the "up" and "down" functions that I should pass as arguments to Andy's operator

What are these operators supposed to take as arguments ?

And I was trying to start from the original paper Andy cites, because that's where the original operator is defined (in haskell)

I know Andy's examples work

But I don't understand why they do and what I should do to apply that thing to different use cases

i was trying to understand, not just running the examples

Philip McGrath

unread,

Jun 25, 2020, 6:41:35 PM6/25/20

to Catonano, Stephen De Gabrielle, Racket Users

On Sun, Jun 14, 2020 at 2:20 PM Catonano <cato...@gmail.com> wrote:

I'm referring to a paper titled: "A better XML parser through functional
programming"

by Oleg Kiselyov

Ah, I see. I'm not deeply familiar with it myself (I mostly use Racket's `xml` library), but there is a Racket port of Oleg's SSAX, and the source code includes extensive comments.

Code: https://github.com/jbclements/sxml

Package documentation (limited): https://docs.racket-lang.org/sxml/

Oleg's website also has some links, though some are broken: http://okmij.org/ftp/Scheme/xml.html#XML-parser

Hope this helps!

-Philip

Neil Van Dyke

unread,

Jun 25, 2020, 7:51:47 PM6/25/20

to Catonano, Racket Users

Catonano, I haven't yet studied that paper of Andy Wingo's (thank you
for mentioning it), but a couple ideas for answering your questions...

If people in Guile are using that tree fold approach, you might ask
about it on one of the Guile email lists. Incidentally, Andy has long
been a member of the community around Guile, as well as of the Scheme
community in general.

If you want to use that tree fold approach in Racket afterwards, most
Scheme code will still work in Racket. And you could probably port or
repackage most Guile utility libraries. (The main tricky part that
comes to mind, in porting RnRS Scheme code to Racket, is if the code
uses mutable pairs.)

Another option to keep in mind is that, normally when you read an
academic paper, once you've given it a close read, and made an effort to
be reasonably conversant in at least one aspect of the background
material, IMHO, it's perfectly proper to contact the author of the paper
directly, with good comments/questions. They might not be able to keep
up with their email, nor always sort it perfectly, but reaching out
about a paper is part of scholarly culture, so don't be too shy.

FWIW, here's another example of tree folding, which I did as an exercise
while trying to understand some of Oleg Kiselyov's XML work better:
https://www.neilvandyke.org/racket/json-parsing/ (If it doesn't
immediately help at all, don't waste your time looking at it any more.
I'd do the interface differently next time, and definitely not use
`syntax-rules` in the implementation again, but it's an example.)

Neil

Reply all

Reply to author

Forward