Changing from racket to racket/base in xml, html, and web-server

This commit is contained in:
Jay McCarthy 2012-05-10 10:35:33 -06:00
parent f675514a2b
commit 611e8d0d17
83 changed files with 496 additions and 380 deletions

View File

@ -1,5 +1,6 @@
#lang racket
(require "sgml-reader.rkt")
#lang racket/base
(require racket/contract
"sgml-reader.rkt")
(provide/contract
[html-spec spec/c])

View File

@ -1,5 +1,6 @@
#lang racket
(require xml)
#lang racket/base
(require racket/contract
xml)
(define-struct html-element (attributes))
(define-struct (html-full html-element) (content))

View File

@ -1,9 +1,10 @@
#lang racket
#lang racket/base
;; copyright by Paul Graunke June 2000 AD
(require "html-structs.rkt"
"html-spec.rkt"
"sgml-reader.rkt"
racket/contract
xml)
(provide (all-from-out "html-structs.rkt")

View File

@ -1,9 +1,10 @@
;; copyright by Paul Graunke June 2000 AD
;; warning - this was copied from the XML collection.
;; It needs to be abstracted back in.
#lang racket
#lang racket/base
(require xml
(prefix-in racket: racket))
racket/contract
(prefix-in racket: racket/base))
;; Kid-lister : (Symbol -> (U (listof Symbol) #f))
(define kid-lister/c

View File

@ -1,5 +1,8 @@
#lang racket
(require racket/pretty
#lang racket/base
(require racket/contract
racket/list
(for-syntax racket/base)
racket/pretty
racket/runtime-path
"configuration-table-structs.rkt"
web-server/http/bindings)

View File

@ -1,5 +1,7 @@
#lang racket
(require racket/runtime-path)
#lang racket/base
(require racket/contract
racket/list
racket/runtime-path)
(define-runtime-module-path racket-module-spec racket)
(define mred-module-spec 'mred)

View File

@ -1,5 +1,7 @@
#lang racket
(require racket/runtime-path
#lang racket/base
(require racket/contract
(for-syntax racket/base)
racket/runtime-path
net/url
web-server/private/xexpr
web-server/http/xexpr

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
(require web-server/servlet)
(define (extract-number req)

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
(require web-server/servlet
web-server/formlets)
(provide (all-defined-out))

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
(require web-server/servlet
web-server/formlets)
(provide (all-defined-out))

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
(require web-server/servlet
web-server/formlets)
(provide (all-defined-out))

View File

@ -1,5 +1,6 @@
#lang racket
(require web-server/servlet)
#lang racket/base
(require racket/match
web-server/servlet)
(provide (all-defined-out))
(define interface-version 'v1)
(define timeout +inf.0)

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
;; Written by Don Felgar, edited by Greg Pettyjohn
;;
;; Multiple-choice quiz Racket servlet sample.
@ -13,7 +13,9 @@
;; correct-answer = integer, index into choices
;;
;; Configuration
(require racket/runtime-path)
(require racket/runtime-path
racket/file
(for-syntax racket/base))
(define-runtime-path *data-file*
(list 'lib
"web-server/default-web-root/htdocs/servlets/examples/english-measure-questions.rkt"))

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
(require web-server/templates
web-server/http
web-server/compat/0/coerce)

View File

@ -1,5 +1,6 @@
#lang racket
(require web-server/templates
#lang racket/base
(require racket/list
web-server/templates
web-server/http)
(provide (all-defined-out))
(define interface-version 'v1)

View File

@ -1,5 +1,6 @@
#lang racket
(require web-server/templates
#lang racket/base
(require racket/list
web-server/templates
web-server/http)
(provide (all-defined-out))
(define interface-version 'v1)

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
(require web-server/templates
web-server/http
xml)

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
(require web-server/servlet)
(define interface-version 'v1)
(define timeout +inf.0)

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
(require web-server/servlet)
(define interface-version 'v1)
(define timeout +inf.0)

View File

@ -1,5 +1,7 @@
#lang racket
(require racket/stxparam)
#lang racket/base
(require (for-syntax racket/base)
racket/match
racket/stxparam)
(define-syntax-parameter bidi-match-going-in? #t)

View File

@ -1,4 +1,7 @@
#lang racket
#lang racket/base
(require racket/contract
racket/match
(for-syntax racket/base))
(define (make-coerce-safe? coerce)
(lambda (x)

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
(require web-server/dispatch/coercion
web-server/dispatch/bidi-match)
(provide (all-from-out web-server/dispatch/coercion

View File

@ -1,5 +1,6 @@
#lang racket
(require net/url
#lang racket/base
(require racket/match
net/url
web-server/http)
(define-match-expander url/path

View File

@ -1,4 +1,7 @@
#lang racket
#lang racket/base
(require racket/list
racket/contract)
; A dispatch pattern is either
; - a string
; - a bidi match expander

View File

@ -1,5 +1,6 @@
#lang racket
(require web-server/servlet-env
#lang racket/base
(require racket/contract
web-server/servlet-env
web-server/servlet/servlet-structs
web-server/http)

View File

@ -1,10 +1,13 @@
#lang racket
(require racket/stxparam
#lang racket/base
(require racket/list
racket/match
racket/stxparam
net/url
web-server/dispatchers/dispatch
web-server/dispatch/http-expanders
web-server/dispatch/bidi-match
(for-syntax web-server/dispatch/pattern))
(for-syntax racket/base
web-server/dispatch/pattern))
(define (default-else req)
(next-dispatcher))

View File

@ -1,5 +1,6 @@
#lang racket
(require web-server/dispatch/coercion
#lang racket/base
(require racket/match
web-server/dispatch/coercion
web-server/dispatch/bidi-match)
(define-syntax define-bidi-match-expander/coercions

View File

@ -1,5 +1,7 @@
#lang racket
(require web-server/dispatchers/dispatch)
#lang racket/base
(require racket/contract
racket/list
web-server/dispatchers/dispatch)
(provide/contract
[interface-version dispatcher-interface-version/c]
[make (() () #:rest (listof dispatcher/c) . ->* . dispatcher/c)])

View File

@ -1,5 +1,7 @@
#lang racket
(require web-server/dispatchers/dispatch)
#lang racket/base
(require racket/contract
racket/list
web-server/dispatchers/dispatch)
(provide/contract
[interface-version dispatcher-interface-version/c]
[make ((number? dispatcher/c) (#:over-limit (symbols 'block 'kill-new 'kill-old)) . ->* . dispatcher/c)])

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
(require web-server/formlets/syntax
web-server/formlets/dyn-syntax
web-server/formlets/input

View File

@ -1,7 +1,12 @@
#lang racket
(require (for-syntax racket
#lang racket/base
(require (for-syntax racket/base
racket/local
racket/list
syntax/parse
syntax/strip-context)
racket/function
racket/list
racket/match
racket/stxparam
"lib.rkt"
"syntax.rkt"

View File

@ -1,5 +1,7 @@
#lang racket
(require web-server/http
#lang racket/base
(require racket/contract
racket/list
web-server/http
web-server/private/xexpr
(only-in "lib.rkt"
formlet/c

View File

@ -1,9 +1,11 @@
#lang racket
(require web-server/http
#lang racket/base
(require racket/list
racket/contract
racket/function
web-server/http
web-server/private/xexpr)
; Combinators
(define (const x) (lambda _ x))
(define (id x) x)
; Formlets

View File

@ -1,5 +1,6 @@
#lang racket
(require web-server/servlet
#lang racket/base
(require racket/contract
web-server/servlet
web-server/private/xexpr
"lib.rkt")

View File

@ -1,7 +1,9 @@
#lang racket
(require (for-syntax racket
#lang racket/base
(require (for-syntax racket/base
syntax/parse)
racket/stxparam
racket/match
racket/list
"lib.rkt"
(for-syntax "lib.rkt"))

View File

@ -1,5 +1,7 @@
#lang racket
(require net/base64
#lang racket/base
(require racket/contract
racket/match
net/base64
web-server/http/request-structs)
(define (request->basic-credentials req)

View File

@ -1,5 +1,7 @@
#lang racket
(require web-server/http/request-structs
#lang racket/base
(require racket/port
racket/match
web-server/http/request-structs
net/cookie
web-server/private/util
racket/contract)

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
(require net/cookie
web-server/http/request-structs
web-server/http/response-structs

View File

@ -1,5 +1,8 @@
#lang racket
(require net/base64
#lang racket/base
(require racket/port
racket/match
racket/contract
net/base64
file/md5
web-server/http/request-structs)

View File

@ -1,5 +1,8 @@
#lang racket
(require racket/serialize
#lang racket/base
(require racket/contract
racket/list
racket/match
racket/serialize
web-server/private/servlet
web-server/managers/manager
web-server/private/define-closure

View File

@ -1,5 +1,6 @@
#lang racket
(require syntax/free-vars
#lang racket/base
(require racket/list
syntax/free-vars
racket/syntax
(for-template
racket/base

View File

@ -1,5 +1,6 @@
#lang racket
(require file/md5)
#lang racket/base
(require racket/contract
file/md5)
(provide/contract
[make-labeling (bytes? . -> . (-> symbol?))])

View File

@ -1,6 +1,6 @@
#lang racket
#lang racket/base
(require web-server/lang/abort-resume
(for-syntax racket))
(for-syntax racket/base))
(define-syntax (define-native stx)
(syntax-case stx ()

View File

@ -1,6 +1,8 @@
#lang racket
(require racket/serialize
(for-syntax racket
#lang racket/base
(require racket/contract
racket/list
racket/serialize
(for-syntax racket/base
web-server/lang/closure
web-server/lang/labels))

View File

@ -1,5 +1,8 @@
#lang racket
(require racket/serialize)
#lang racket/base
(require racket/contract
racket/match
racket/local
racket/serialize)
(define-serializable-struct soft-state-record (thnk))
(define-struct some (value))

View File

@ -1,5 +1,7 @@
#lang racket
(require net/url
#lang racket/base
(require racket/contract
racket/list
net/url
racket/serialize
web-server/private/servlet
web-server/stuffers/stuffer

View File

@ -1,5 +1,7 @@
#lang racket
(require racket/serialize
#lang racket/base
(require racket/contract
racket/list
racket/serialize
web-server/lang/serial-lambda)
;; Implementation: Have a distinguished frame variable that is read and captured by send/suspend,
;; installed on invocations of continuations by the server (and NOT from other continuation invocations)

View File

@ -1,5 +1,6 @@
#lang racket
(require net/url
#lang racket/base
(require racket/match
net/url
racket/contract
racket/serialize
web-server/servlet/servlet-structs

View File

@ -1,5 +1,7 @@
#lang racket
(require racket/async-channel
#lang racket/base
(require racket/unit
racket/contract
racket/async-channel
web-server/private/util
unstable/contract
web-server/private/connection-manager)

View File

@ -1,5 +1,6 @@
#lang racket
(require file/gzip
#lang racket/base
(require racket/contract
file/gzip
file/gunzip)
(provide/contract

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
(require racket/cmdline
racket/unit
net/tcp-sig

View File

@ -1,4 +1,7 @@
#lang racket
#lang racket/base
(require racket/contract
racket/list
racket/match)
(provide/contract
[compress-serial (list? . -> . list?)]
[decompress-serial (list? . -> . list?)])

View File

@ -1,5 +1,8 @@
#lang racket
(require racket/pretty
#lang racket/base
(require racket/contract
racket/match
racket/list
racket/pretty
xml)
(define-struct (exn:pretty exn) (xexpr))

View File

@ -1,5 +1,7 @@
#lang racket
(require "../dummy-sqlite.rkt")
#lang racket/base
(require racket/list
racket/local
"../dummy-sqlite.rkt")
;; A blog is a (make-blog db)
;; where db is an sqlite database handle

View File

@ -1,4 +1,6 @@
#lang racket
#lang racket/base
(require racket/local
racket/list)
;; A blog is a (make-blog home posts)
;; where home is a string, posts is a (listof post)

View File

@ -1,5 +1,7 @@
#lang racket
(require db)
#lang racket/base
(require racket/list
racket/local
db)
;; A blog is a (make-blog db)
;; where db is an sqlite connection

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
;; A blog is a (make-blog posts)
;; where posts is a (listof post)

View File

@ -1,6 +1,7 @@
#lang racket
#lang racket/base
(require scribble/basic
(for-syntax racket/port)
(for-syntax racket/base
racket/port)
racket/include
(except-in scribble/manual link))
(provide external-file)

View File

@ -1,6 +1,7 @@
#lang racket
#lang racket/base
(require scribble/manual
scribble/eval
(for-syntax racket/base)
(for-label racket/base
racket/contract
racket/unit))

View File

@ -1,7 +1,9 @@
; Derived from plai/web/server, which was based on an older version of this
; Also derived from planet/untyped/instaservlet
#lang racket
#lang racket/base
(require (prefix-in net: net/sendurl)
racket/match
racket/local
racket/contract
racket/async-channel
racket/list

View File

@ -1,10 +1,11 @@
; Derived from plai/web/server, which was based on an older version of this
; Also derived from planet/untyped/instaservlet
#lang racket
#lang racket/base
(require racket/contract
racket/list
racket/serialize
racket/runtime-path)
racket/runtime-path
(for-syntax racket/base))
(require net/url
web-server/managers/lru
web-server/managers/manager

View File

@ -1,5 +1,7 @@
#lang racket
(require racket/serialize
#lang racket/base
(require racket/contract
racket/match
racket/serialize
web-server/managers/manager
web-server/managers/timeouts
web-server/managers/none

View File

@ -1,6 +1,8 @@
#lang racket
#lang racket/base
;; Implementation: Have a distinguished frame variable that is read and captured by send/suspend,
;; installed on invocations of continuations by the server (and NOT from other continuation invocations)
(require racket/list
racket/contract)
;; Data types
(define-struct primitive-wc (id))

View File

@ -1,5 +1,7 @@
#lang racket
(require net/url)
#lang racket/base
(require racket/contract
racket/list
net/url)
(require web-server/managers/manager
web-server/private/util
web-server/private/servlet

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
(require web-server/stuffers/stuffer
web-server/stuffers/base64
web-server/stuffers/gzip

View File

@ -1,5 +1,6 @@
#lang racket
(require web-server/stuffers/stuffer
#lang racket/base
(require racket/contract
web-server/stuffers/stuffer
net/base64)
(define base64-stuffer

View File

@ -1,5 +1,6 @@
#lang racket
(require web-server/private/gzip
#lang racket/base
(require racket/contract
web-server/private/gzip
web-server/stuffers/stuffer)
(define gzip-stuffer

View File

@ -1,5 +1,6 @@
#lang racket
(require web-server/stuffers/stuffer
#lang racket/base
(require racket/contract
web-server/stuffers/stuffer
web-server/stuffers/store
file/md5)

View File

@ -1,5 +1,6 @@
#lang racket
(require web-server/stuffers/stuffer
#lang racket/base
(require racket/contract
web-server/stuffers/stuffer
racket/runtime-path
openssl/libcrypto
(rename-in ffi/unsafe

View File

@ -1,5 +1,6 @@
#lang racket
(require racket/serialize
#lang racket/base
(require racket/contract
racket/serialize
web-server/stuffers/stuffer
web-server/private/util
web-server/private/mod-map)

View File

@ -1,4 +1,6 @@
#lang racket
#lang racket/base
(require racket/contract)
(define-struct store (write read))
(define (dir-store home)

View File

@ -1,4 +1,7 @@
#lang racket
#lang racket/base
(require racket/contract
racket/match)
(define-struct stuffer (in out))
(define (stuffer/c dom rng)
(define in (dom . -> . rng))

View File

@ -1,5 +1,7 @@
#lang racket
(require web-server/private/util
#lang racket/base
(require racket/unit
racket/contract
web-server/private/util
web-server/configuration/namespace
web-server/configuration/configuration-table-structs)

View File

@ -1,5 +1,7 @@
#lang racket
(require xml)
#lang racket/base
(require racket/list
racket/contract
xml)
; a dict is (list 'dict assoc-pair ...)
; an assoc-pair is (list 'assoc-pair key value)

View File

@ -1,5 +1,8 @@
#lang racket
(require "structures.rkt")
#lang racket/base
(require racket/contract
racket/list
racket/match
"structures.rkt")
(provide/contract
[read-xml (() (input-port?) . ->* . document?)]

View File

@ -1,5 +1,7 @@
#lang racket
(require "structures.rkt")
#lang racket/base
(require racket/contract
racket/list
"structures.rkt")
(provide/contract
[eliminate-whitespace (() ((listof symbol?) (boolean? . -> . boolean?)) . ->* . (element? . -> . element?))])

View File

@ -1,5 +1,7 @@
#lang racket
(require "structures.rkt"
#lang racket/base
(require racket/contract
racket/list
"structures.rkt"
"reader.rkt"
"xexpr.rkt")

View File

@ -1,5 +1,6 @@
#lang racket
(require "structures.rkt")
#lang racket/base
(require racket/contract
"structures.rkt")
(provide/contract
[write-xml ((document?) (output-port?) . ->* . void?)]

View File

@ -1,35 +1,35 @@
(module scheme-snipclass mzscheme
(require stepper/private/xml-snip-helpers
mzlib/class
mred)
(provide snip-class scheme-snip%)
#lang racket/base
(require stepper/private/xml-snip-helpers
mzlib/class
mred)
(define scheme-snip%
(class* editor-snip% (scheme-snip<%> readable-snip<%>)
(init-field splice?)
(define/public (get-splice?) splice?)
(provide snip-class scheme-snip%)
(define/public (read-special file line col pos)
(scheme-read-special this
file
line
col
pos))
(super-instantiate ())))
(define scheme-snipclass%
(class snip-class%
(define/override (read stream-in)
(let* ([splice? (zero? (send stream-in get-exact))]
[snip (instantiate scheme-snip% ()
(splice? splice?))])
(send (send snip get-editor) read-from-file stream-in #f)
snip))
(super-instantiate ())))
(define snip-class (make-object scheme-snipclass%))
(send snip-class set-version 1)
(send snip-class set-classname (format "~s" '(lib "scheme-snipclass.rkt" "xml")))
(send (get-the-snip-class-list) add snip-class))
(define scheme-snip%
(class* editor-snip% (scheme-snip<%> readable-snip<%>)
(init-field splice?)
(define/public (get-splice?) splice?)
(define/public (read-special file line col pos)
(scheme-read-special this
file
line
col
pos))
(super-instantiate ())))
(define scheme-snipclass%
(class snip-class%
(define/override (read stream-in)
(let* ([splice? (zero? (send stream-in get-exact))]
[snip (instantiate scheme-snip% ()
(splice? splice?))])
(send (send snip get-editor) read-from-file stream-in #f)
snip))
(super-instantiate ())))
(define snip-class (make-object scheme-snipclass%))
(send snip-class set-version 1)
(send snip-class set-classname (format "~s" '(lib "scheme-snipclass.rkt" "xml")))
(send (get-the-snip-class-list) add snip-class)

View File

@ -1,37 +1,37 @@
(module text-box-tool mzscheme
(require drscheme/tool
mred
framework
"text-snipclass.rkt"
mzlib/unit
mzlib/class
string-constants
mrlib/include-bitmap)
(provide tool@)
#lang racket/base
(require drscheme/tool
mred
framework
"text-snipclass.rkt"
mzlib/unit
mzlib/class
string-constants
mrlib/include-bitmap)
(define tool@
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
(define (phase1) (void))
(define (phase2) (void))
(define (text-box-mixin %)
(class %
(inherit get-insert-menu get-edit-target-object register-capability-menu-item)
(super-new)
(new menu-item%
(label (string-constant insert-text-box-item))
(parent (get-insert-menu))
(callback
(lambda (menu event)
(let ([c-box (new text-box%)]
[text (get-edit-target-object)])
(send text insert c-box)
(send text set-caret-owner c-box 'global)))))
(register-capability-menu-item 'drscheme:special:insert-text-box (get-insert-menu))))
(drscheme:get/extend:extend-unit-frame text-box-mixin)
(drscheme:language:register-capability 'drscheme:special:insert-text-box boolean? #t))))
(provide tool@)
(define tool@
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
(define (phase1) (void))
(define (phase2) (void))
(define (text-box-mixin %)
(class %
(inherit get-insert-menu get-edit-target-object register-capability-menu-item)
(super-new)
(new menu-item%
(label (string-constant insert-text-box-item))
(parent (get-insert-menu))
(callback
(lambda (menu event)
(let ([c-box (new text-box%)]
[text (get-edit-target-object)])
(send text insert c-box)
(send text set-caret-owner c-box 'global)))))
(register-capability-menu-item 'drscheme:special:insert-text-box (get-insert-menu))))
(drscheme:get/extend:extend-unit-frame text-box-mixin)
(drscheme:language:register-capability 'drscheme:special:insert-text-box boolean? #t)))

View File

@ -1,148 +1,148 @@
(module text-snipclass mzscheme
(require framework
mzlib/class
mred)
#lang racket/base
(require framework
mzlib/class
mred)
(provide text-box%
(rename snipclass snip-class))
(provide text-box%
(rename-out [snipclass snip-class]))
;; chunk-string: (listof any) -> (listof any)
(define (chunk-string s acc)
(cond
((and (null? s) (null? acc)) null)
((null? s) (list (list->string (reverse acc))))
((char? (car s)) (chunk-string (cdr s) (cons (car s) acc)))
((null? acc) (cons (car s) (chunk-string (cdr s) null)))
(else (cons (list->string (reverse acc)) (cons (car s) (chunk-string (cdr s) null))))))
(define get-icon
(let ([icon #f])
(λ ()
(unless icon
(let ()
(define str "“”")
(define bdc (make-object bitmap-dc% (make-object bitmap% 1 1)))
(define font (send the-font-list find-or-create-font 24 'default 'normal 'normal))
(define-values (w h _1 _2) (send bdc get-text-extent str font))
(define bmp (make-object bitmap% (floor (inexact->exact w)) (floor (inexact->exact h))))
(send bdc set-bitmap bmp)
(send bdc set-smoothing 'aligned)
(send bdc set-font font)
(send bdc clear)
(send bdc draw-text str 0 0)
(send bdc set-bitmap #f)
(set! icon bmp)))
icon)))
;; marshall: writable -> string
(define (marshall s)
(let ((os (open-output-string)))
(with-handlers ((exn:fail? (lambda (x) "")))
(write s os)
(get-output-string os))))
;; chunk-string: (listof any) -> (listof any)
(define (chunk-string s acc)
(cond
((and (null? s) (null? acc)) null)
((null? s) (list (list->string (reverse acc))))
((char? (car s)) (chunk-string (cdr s) (cons (car s) acc)))
((null? acc) (cons (car s) (chunk-string (cdr s) null)))
(else (cons (list->string (reverse acc)) (cons (car s) (chunk-string (cdr s) null))))))
(define snipclass-text-box%
(class decorated-editor-snipclass%
(define/override (make-snip stream-in) (new text-box%))
(super-instantiate ())))
(define old-snipclass (new snipclass-text-box%))
(send old-snipclass set-version 1)
(send old-snipclass set-classname "text-box%")
(send (get-the-snip-class-list) add old-snipclass)
(define get-icon
(let ([icon #f])
(λ ()
(unless icon
(let ()
(define str "“”")
(define bdc (make-object bitmap-dc% (make-object bitmap% 1 1)))
(define font (send the-font-list find-or-create-font 24 'default 'normal 'normal))
(define-values (w h _1 _2) (send bdc get-text-extent str font))
(define bmp (make-object bitmap% (floor (inexact->exact w)) (floor (inexact->exact h))))
(send bdc set-bitmap bmp)
(send bdc set-smoothing 'aligned)
(send bdc set-font font)
(send bdc clear)
(send bdc draw-text str 0 0)
(send bdc set-bitmap #f)
(set! icon bmp)))
icon)))
(define snipclass (new snipclass-text-box%))
(send snipclass set-version 1)
(send snipclass set-classname (format "~s" '(lib "text-snipclass.ss" "xml")))
(send (get-the-snip-class-list) add snipclass)
(define text-box%
(class* decorated-editor-snip% (readable-snip<%>)
(define/override (make-editor) (let ([e (new text:keymap%)])
(send e set-max-undo-history 'forever)
e))
(define/override (make-snip) (make-object text-box%))
(inherit get-editor get-admin)
(define/override (get-corner-bitmap)
(get-icon))
;; marshall: writable -> string
(define (marshall s)
(let ((os (open-output-string)))
(with-handlers ((exn:fail? (lambda (x) "")))
(write s os)
(get-output-string os))))
(define/override (get-menu)
(let ([menu (new popup-menu%)])
(new menu-item%
(label "Convert to string")
(parent menu)
(callback
(lambda (x y)
(let ([to-ed (find-containing-editor)])
(when to-ed
(let ([this-pos (find-this-position)])
(when this-pos
(let ([from-ed (get-editor)])
(send to-ed begin-edit-sequence)
(send from-ed begin-edit-sequence)
(send to-ed delete this-pos (+ this-pos 1))
(let* ((p (open-input-text-editor from-ed 0 'end
(lambda (s)
(values (box s) 1))))
(contents
(let loop ((next (read-char-or-special p)))
(cond
((eof-object? next) null)
(else
(cons next (loop (read-char-or-special p)))))))
(repaired-contents
(map (lambda (x)
(if (string? x)
(marshall x)
(send (unbox x) copy)))
(chunk-string contents null))))
(for-each
(lambda (x)
(send to-ed insert x this-pos))
(reverse repaired-contents)))
(send to-ed end-edit-sequence)
(send from-ed end-edit-sequence)))))))))
menu))
;; find-containing-editor : -> (union #f editor)
(define/private (find-containing-editor)
(let ([admin (get-admin)])
(and admin
(send admin get-editor))))
;; find-this-position : -> (union #f number)
(define/private (find-this-position)
(let ([ed (find-containing-editor)])
(and ed
(send ed get-snip-position this))))
(define snipclass-text-box%
(class decorated-editor-snipclass%
(define/override (make-snip stream-in) (new text-box%))
(super-instantiate ())))
;; input-port -> (union (listof char) char eof-object? syntax-object)
(define/private (get-next port)
(let ([v (read-char-or-special port)])
(if (special-comment? v)
(get-next port)
v)))
(define/public (read-special source line column position)
(let* ((ed (get-editor))
(port (open-input-text-editor ed))
(str (let loop ((next (get-next port)))
(cond
((eof-object? next) null)
((char? next)
(cons next (loop (get-next port))))
(else (cons #`(marshall #,next) (loop (get-next port))))))))
#`(let ((marshall
(lambda (s)
(let ((os (open-output-string)))
(with-handlers ((exn:fail? (lambda (x) "")))
(display s os)
(get-output-string os))))))
(string-append #,@(chunk-string str null)))))
(super-instantiate ())
(inherit set-snipclass)
(set-snipclass snipclass))))
(define old-snipclass (new snipclass-text-box%))
(send old-snipclass set-version 1)
(send old-snipclass set-classname "text-box%")
(send (get-the-snip-class-list) add old-snipclass)
(define snipclass (new snipclass-text-box%))
(send snipclass set-version 1)
(send snipclass set-classname (format "~s" '(lib "text-snipclass.ss" "xml")))
(send (get-the-snip-class-list) add snipclass)
(define text-box%
(class* decorated-editor-snip% (readable-snip<%>)
(define/override (make-editor) (let ([e (new text:keymap%)])
(send e set-max-undo-history 'forever)
e))
(define/override (make-snip) (make-object text-box%))
(inherit get-editor get-admin)
(define/override (get-corner-bitmap)
(get-icon))
(define/override (get-menu)
(let ([menu (new popup-menu%)])
(new menu-item%
(label "Convert to string")
(parent menu)
(callback
(lambda (x y)
(let ([to-ed (find-containing-editor)])
(when to-ed
(let ([this-pos (find-this-position)])
(when this-pos
(let ([from-ed (get-editor)])
(send to-ed begin-edit-sequence)
(send from-ed begin-edit-sequence)
(send to-ed delete this-pos (+ this-pos 1))
(let* ((p (open-input-text-editor from-ed 0 'end
(lambda (s)
(values (box s) 1))))
(contents
(let loop ((next (read-char-or-special p)))
(cond
((eof-object? next) null)
(else
(cons next (loop (read-char-or-special p)))))))
(repaired-contents
(map (lambda (x)
(if (string? x)
(marshall x)
(send (unbox x) copy)))
(chunk-string contents null))))
(for-each
(lambda (x)
(send to-ed insert x this-pos))
(reverse repaired-contents)))
(send to-ed end-edit-sequence)
(send from-ed end-edit-sequence)))))))))
menu))
;; find-containing-editor : -> (union #f editor)
(define/private (find-containing-editor)
(let ([admin (get-admin)])
(and admin
(send admin get-editor))))
;; find-this-position : -> (union #f number)
(define/private (find-this-position)
(let ([ed (find-containing-editor)])
(and ed
(send ed get-snip-position this))))
;; input-port -> (union (listof char) char eof-object? syntax-object)
(define/private (get-next port)
(let ([v (read-char-or-special port)])
(if (special-comment? v)
(get-next port)
v)))
(define/public (read-special source line column position)
(let* ((ed (get-editor))
(port (open-input-text-editor ed))
(str (let loop ((next (get-next port)))
(cond
((eof-object? next) null)
((char? next)
(cons next (loop (get-next port))))
(else (cons #`(marshall #,next) (loop (get-next port))))))))
#`(let ((marshall
(lambda (s)
(let ((os (open-output-string)))
(with-handlers ((exn:fail? (lambda (x) "")))
(display s os)
(get-output-string os))))))
(string-append #,@(chunk-string str null)))))
(super-instantiate ())
(inherit set-snipclass)
(set-snipclass snipclass)))

View File

@ -1,35 +1,35 @@
(module xml-snipclass mzscheme
(require stepper/private/xml-snip-helpers
mzlib/class
mred)
(provide snip-class xml-snip%)
#lang racket/base
(require stepper/private/xml-snip-helpers
mzlib/class
mred)
(define xml-snip%
(class* editor-snip% (xml-snip<%> readable-snip<%>)
(init-field eliminate-whitespace-in-empty-tags?)
(define/public (read-special file line col pos)
(xml-read-special eliminate-whitespace-in-empty-tags?
this
file
line
col
pos))
(super-new)))
(define xml-snipclass%
(class snip-class%
(define/override (read stream-in)
(let* ([eliminate-whitespace-in-empty-tags? (zero? (send stream-in get-exact))]
[snip (instantiate xml-snip% ()
(eliminate-whitespace-in-empty-tags? eliminate-whitespace-in-empty-tags?))])
(send (send snip get-editor) read-from-file stream-in #f)
snip))
(super-new)))
(define snip-class (make-object xml-snipclass%))
(send snip-class set-version 1)
(send snip-class set-classname (format "~s" '(lib "xml-snipclass.rkt" "xml")))
(send (get-the-snip-class-list) add snip-class))
(provide snip-class xml-snip%)
(define xml-snip%
(class* editor-snip% (xml-snip<%> readable-snip<%>)
(init-field eliminate-whitespace-in-empty-tags?)
(define/public (read-special file line col pos)
(xml-read-special eliminate-whitespace-in-empty-tags?
this
file
line
col
pos))
(super-new)))
(define xml-snipclass%
(class snip-class%
(define/override (read stream-in)
(let* ([eliminate-whitespace-in-empty-tags? (zero? (send stream-in get-exact))]
[snip (instantiate xml-snip% ()
(eliminate-whitespace-in-empty-tags? eliminate-whitespace-in-empty-tags?))])
(send (send snip get-editor) read-from-file stream-in #f)
snip))
(super-new)))
(define snip-class (make-object xml-snipclass%))
(send snip-class set-version 1)
(send snip-class set-classname (format "~s" '(lib "xml-snipclass.rkt" "xml")))
(send (get-the-snip-class-list) add snip-class)

View File

@ -1,4 +1,4 @@
#lang racket
#lang racket/base
(require "private/structures.rkt"
"private/reader.rkt"
"private/space.rkt"