simplify main-helper

pull/9/head
Matthew Butterick 11 years ago
parent 9095494bbf
commit c92b32fdf6

@ -108,11 +108,12 @@
#:single-prepend [single-pp '(squo)] #:single-prepend [single-pp '(squo)]
#:double-prepend [double-pp '(dquo)]) #:double-prepend [double-pp '(dquo)])
((tagged-xexpr?) (#:single-prepend list? #:double-prepend list?) . ->* . tagged-xexpr?) ((tagged-xexpr?) (#:single-prepend list? #:double-prepend list?) . ->* . tagged-xexpr?)
(define two-char-string? (λ(i) (and (string? i) (>= (len i) 2)))) (define two-or-more-char-string? (λ(i) (and (string? i) (>= (len i) 2))))
(define-values (tag attr elements) (break-tagged-xexpr nx)) (define-values (tag attr elements) (break-tagged-xexpr nx))
(define new-car-elements (make-tagged-xexpr tag attr
(match (car elements) (if (and (list? elements) (not (empty? elements)))
[(? two-char-string? tcs) (let ([new-car-elements (match (car elements)
[(? two-or-more-char-string? tcs)
(define str-first (get tcs 0)) (define str-first (get tcs 0))
(define str-rest (get tcs 1 'end)) (define str-rest (get tcs 1 'end))
(cond (cond
@ -124,15 +125,19 @@
`(,@single-pp ,(->string #\) ,str-rest)] `(,@single-pp ,(->string #\) ,str-rest)]
[else tcs])] [else tcs])]
[(? tagged-xexpr? nx) (wrap-hanging-quotes nx)] [(? tagged-xexpr? nx) (wrap-hanging-quotes nx)]
[else (car elements)])) [else (car elements)])])
(make-tagged-xexpr tag attr (cons new-car-elements (cdr elements)))) (cons new-car-elements (cdr elements)))
elements)))
(module+ test (module+ test
(check-equal? (wrap-hanging-quotes '(p "\"Hi\" there")) '(p (dquo "" "Hi\" there"))) (check-equal? (wrap-hanging-quotes '(p "\"Hi\" there")) '(p (dquo "" "Hi\" there")))
(check-equal? (wrap-hanging-quotes '(p "'Hi' there")) '(p (squo "" "Hi' there"))) (check-equal? (wrap-hanging-quotes '(p "'Hi' there")) '(p (squo "" "Hi' there")))
(check-equal? (wrap-hanging-quotes '(p "'Hi' there") #:single-prepend '(foo ((bar "ino")))) (check-equal? (wrap-hanging-quotes '(p "'Hi' there") #:single-prepend '(foo ((bar "ino"))))
'(p (foo ((bar "ino")) "" "Hi' there")))) '(p (foo ((bar "ino")) "" "Hi' there")))
;; make sure tagged-xexpr without elements passes through unscathed
(check-equal? (wrap-hanging-quotes '(div ((style "height:2em")))) '(div ((style "height:2em")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

@ -10,43 +10,27 @@
(module+ test (require rackunit)) (module+ test (require rackunit))
;; use define-for-syntax because this function supports (define-for-syntax (put-file-in-require-form file)
;; the two syntax transformers below `(file ,(->string file)))
(define-for-syntax (make-files-in-require-form file-directory)
;; This will be resolved in the context of current-directory.
;; So when called from outside the project directory,
;; current-directory must be properly set with 'parameterize'
(define (insert-directory-into-path path)
;; todo: document why this function is necessary (it definitely is, but I forgot why)
(define-values (start_dir name _ignore) (split-path (path->complete-path path)))
(build-path start_dir file-directory name))
(define files (map insert-directory-into-path (filter (λ(i) (has-ext? i 'rkt)) (directory-list file-directory))))
; this puts files in require form
(map (λ(file) `(file ,(->string file))) files))
;; Look for an EXTRAS_DIR directory local to the source file.
;; and require all the .rkt files therein.
;; optionally provide them.
(define-syntax (require-and-provide-extras stx) (define-syntax (require-and-provide-extras stx)
(cond (define project-require-files (get-project-require-files))
[(directory-exists? EXTRAS_DIR) (if project-require-files
(let ([files-in-require-form (make-files-in-require-form EXTRAS_DIR)]) (let ([files-in-require-form (map put-file-in-require-form project-require-files)])
(datum->syntax stx `(begin (datum->syntax stx `(begin
(require ,@files-in-require-form) (require ,@files-in-require-form)
(provide (all-from-out ,@files-in-require-form)))))] (provide (all-from-out ,@files-in-require-form)))))
; if no files to import, do nothing ; if no files to import, do nothing
[else #'(begin)])) #'(begin)))
(define-syntax (require-extras stx) (define-syntax (require-extras stx)
(cond (define project-require-files (get-project-require-files))
[(directory-exists? EXTRAS_DIR) (if project-require-files
(let ([files-in-require-form (make-files-in-require-form EXTRAS_DIR)]) (let ([files-in-require-form (map put-file-in-require-form project-require-files)])
(datum->syntax stx `(begin (datum->syntax stx `(begin
(require ,@files-in-require-form))))] (require ,@files-in-require-form))))
; if no files to import, do nothing ; if no files to import, do nothing
[else #'(begin)])) #'(begin)))
;; here = path of this file, relative to current directory. ;; here = path of this file, relative to current directory.

@ -36,7 +36,11 @@
;; therefore, use function by just listing out the paths ;; therefore, use function by just listing out the paths
(define/contract (store-refresh-in-mod-dates . rest-paths) (define/contract (store-refresh-in-mod-dates . rest-paths)
(() #:rest (listof path?) . ->* . void?) (() #:rest (listof path?) . ->* . void?)
(hash-set! mod-dates rest-paths (map path->mod-date-value rest-paths))) (report (current-directory))
;; todo next: make this work
(let* ([project-require-files (or (get-project-require-files) empty)]
[all-files-used-in-key (append rest-paths project-require-files)])
(hash-set! mod-dates (report all-files-used-in-key) (map path->mod-date-value all-files-used-in-key))))
(module+ test (module+ test
(reset-mod-dates) (reset-mod-dates)

@ -5,7 +5,7 @@
(require (only-in racket/string string-join)) (require (only-in racket/string string-join))
(require (only-in xml xexpr? xexpr/c)) (require (only-in xml xexpr? xexpr/c))
(require "readability.rkt" "debug.rkt" "predicates.rkt") (require "readability.rkt" "debug.rkt" "predicates.rkt" "world.rkt")
(provide (all-defined-out) (all-from-out "readability.rkt" "debug.rkt" "predicates.rkt")) (provide (all-defined-out) (all-from-out "readability.rkt" "debug.rkt" "predicates.rkt"))
;; setup for test cases ;; setup for test cases
@ -13,6 +13,18 @@
;; list of all eligible requires in project require directory
;; assumes current working directory is project directory
;; either for real, or via parameterize
;; todo: is it possible to check this via contract?
;; I don't think so: not possible to know ex ante whether you're in a project folder
(define (get-project-require-files)
(and (directory-exists? EXTRAS_DIR)
;; todo: allow more than just .rkt files?
(let ([files (filter (λ(i) (has-ext? i 'rkt)) (directory-list EXTRAS_DIR #:build? #t))])
(and (not (empty? files)) files))))
;; helper for comparison of values ;; helper for comparison of values
;; normal function won't work for this. Has to be syntax-rule ;; normal function won't work for this. Has to be syntax-rule
(define-syntax-rule (values->list vs) (define-syntax-rule (values->list vs)

Loading…
Cancel
Save