[racket] A function (in web-servlet) is expected to be invoked just once but seems to have more lives ...

There was a discussion about TOPSL paper not too long ago. I've been
reading it with much interest and studying the code from SourceForge
as well. In the course of my study, I wrote this code. (I think it's
the kind that TOPSL was designed to replace/obviate.) Anyway there is
one obvious bug in the following.:

#lang racket

(require web-server/servlet)

(struct gui (form parser))
(struct question (name form parser))

(define questions-table (make-hash))
(define answers-table (make-hash))
(define reverse-orders empty)

;one time only per Q but seem to fire off more than once???
(define (register-question! key val)
  (if (hash-has-key? questions-table key)
      (display (string-append
                (symbol->string key) " was already registered!\n"))
      (begin
        (display (string-append
                  "registering "
                  (symbol->string key) "\n"))
        (set! reverse-orders (cons key reverse-orders))
        (hash-set! answers-table key empty)
        (hash-set! questions-table key val))))

(define (update-answer! key val)
  (hash-set! answers-table key val))

(define (get-answers)
  (for/list ([key (reverse reverse-orders)])
            (list (hash-ref questions-table key)
                  (hash-ref answers-table key))))

(define (extract-single nom)
  (λ (binds)
    (extract-binding/single (string->symbol (symbol->string nom))
                            binds)))

(define (extract-multiple nom)
  (λ (binds)
    (extract-bindings (string->symbol (symbol->string nom))
                      binds)))

(define free
  (λ (nom)
    (gui (λ ()
           (list
            `(input ([type "text"]
                     [name ,(symbol->string nom)]
                     [size "40"]))))
         (extract-single nom))))

(define (pull-down-input val)
  `(option ([value ,val])
           ,val))


(define pull-down
  (λ args
    (λ (nom)
      (gui (λ ()
             (list `(select ([name ,(symbol->string nom)])
                            ,@(for/list ([i (in-naturals)]
                                         [arg args])
                                        (pull-down-input arg)))))
           (extract-multiple nom)))))

(define (radio-input nom val)
  `(input ([type "radio"]
           [name ,nom]
           [value ,val])
          ,val))

(define radio
  (λ args
    (λ (nom)
      (gui (λ ()
             (for/list ([i (in-naturals)]
                        [arg args])
                       (radio-input (symbol->string nom) arg)))
           (extract-single nom)))))

(define brands
  (pull-down "Côte d'Or"
             "Scharffen Burger"
             "Pierre Marcolini"
             "Others"))

(define yes-no
  (λ (nom)
    (gui (λ ()
           (list (radio-input (symbol->string nom) "yes")
                 (radio-input (symbol->string nom) "no")))
         (extract-single nom))))

;BUG?
(define ?
  (λ (name words gui-type)
    (let* ([nom (if name
                    name
                    (gensym 'q))]
           [title (apply string-append words)]
           [a-gui (gui-type nom)])
      (register-question! nom title)
      (question nom
                `(div
                  (p ,title)
                  ,@((gui-form a-gui)))
                (gui-parser a-gui)
                ))))

(define page
  (λ qs

    (define query
      (send/suspend
       (λ (k-url)
         (response/xexpr
          `(html (head (title ,(string-append "Page")))
                 (body
                  (form ([method "post"]
                         [action
                          ,k-url])

                        ,@(for/list ([q qs])
                                    (question-form q))

                        (br)
                        (input ([type "submit"]
                                [value "Go"])))))))))

    ;parse user input and then update table
    (for ([q qs])
         (let ([answer ((question-parser q) (request-bindings query))])
           (update-answer! (question-name q) answer)))

    answers-table))



(define (start req)

  (let ([results (page (? 'like-choco?  '("Do you like chocolate?") yes-no))])
    (let ([like-choco? (hash-ref results 'like-choco?)])

    (if (equal? "yes" like-choco?)
        (page (? #f  '("Which have you tried?") brands))
        (page (? #f '("Why do you NOT like chocolate?") free))))

    (response/xexpr
     `(html (head (title "Your answer:"))
            (body ,@(map (λ (q-a)
                           `(p ,(first q-a)
                               (br)
                               ,(if (list? (second q-a))
                                    (string-join (second q-a) ", ")
                                    (second q-a))))
                         (get-answers))
                  )
            ))))

(require web-server/servlet-env)
(serve/servlet start
               #:command-line? #t
               #:launch-browser? #t
               #:quit? #t
               #:listen-ip #f
               #:port 8080
               #:log-file "log"
               #:extra-files-paths (list (build-path
(current-directory) "htdocs"))
               #:servlet-path "/"
               #:servlet-regexp #rx"")

;end of source code

There is a code that registers a question (by writing to a global
hash-table) in (define ?...) [BTW this is macro in TOPSL]
In my understanding, it should go off just once but I get the
following in DrRacket when I run the code:

registering like-choco?
like-choco? was already registered!
registering q1671
like-choco? was already registered!
like-choco? was already registered!

It escapes me why it seems to run more than once. There seems to be
something going on behind the curtain, sorta speak.

Much thanks in advance as usual.

jGc

PS: By the way, TOPSL at SourceForge seems a bit dormant. Home page
mentions about a move to PlaneT depository, but nothing comes up in my
(google) search. Does any body know of the status?