From ae57ce9377c6eae060cab6c7fc5f57efdbbfc8a9 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 13 Oct 2013 10:11:50 -0500 Subject: [PATCH] adjust the way the header is saved in teaching language files to match 5.3.6 and older versions This is another problem introduced in 480afa4 closes PR 14089 --- .../deinprogramm/deinprogramm-langs.rkt | 54 +++++++++++++-- pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt | 69 ++++++++++++++++--- 2 files changed, 108 insertions(+), 15 deletions(-) diff --git a/pkgs/deinprogramm/deinprogramm/deinprogramm-langs.rkt b/pkgs/deinprogramm/deinprogramm/deinprogramm-langs.rkt index 71f4fb45ab..e0db4f9037 100644 --- a/pkgs/deinprogramm/deinprogramm/deinprogramm-langs.rkt +++ b/pkgs/deinprogramm/deinprogramm/deinprogramm-langs.rkt @@ -12,6 +12,8 @@ mzlib/list racket/match racket/path + (only-in racket/list add-between last) + racket/contract mzlib/struct mzlib/compile drscheme/tool @@ -79,8 +81,10 @@ ;; tracing? : boolean ;; teachpacks : (listof require-spec) (define-struct (deinprogramm-lang-settings drscheme:language:simple-settings) - (writing-style tracing? teachpacks)) + (writing-style tracing? teachpacks)) (define deinprogramm-lang-settings->vector (make-->vector deinprogramm-lang-settings)) + (define deinprogramm-teachpacks-field-index + (+ (procedure-arity drscheme:language:simple-settings) 2)) (define image-string "") @@ -829,6 +833,9 @@ (inherit-field reader-module) (define/override (get-reader-module) reader-module) (define/override (get-metadata modname settings) + (define parsed-tps + (marshall-teachpack-settings + (deinprogramm-lang-settings-teachpacks settings))) (string-append ";; Die ersten drei Zeilen dieser Datei wurden von DrRacket eingefügt. Sie enthalten Metadaten\n" ";; über die Sprachebene dieser Datei in einer Form, die DrRacket verarbeiten kann.\n" @@ -836,8 +843,13 @@ reader-module `((modname ,modname) (read-case-sensitive ,(drscheme:language:simple-settings-case-sensitive settings)) - (teachpacks ,(deinprogramm-lang-settings-teachpacks settings)) - (deinprogramm-settings ,(deinprogramm-lang-settings->vector settings)))))) + (teachpacks ,parsed-tps) + (deinprogramm-settings + ,(for/vector ([e (in-vector (deinprogramm-lang-settings->vector settings))] + [i (in-naturals)]) + (cond + [(= i deinprogramm-teachpacks-field-index) parsed-tps] + [else e]))))))) (inherit default-settings) (define/override (metadata->settings metadata) @@ -847,10 +859,44 @@ (let ([settings-list (vector->list (cadr ssv))]) (if (equal? (length settings-list) (procedure-arity make-deinprogramm-lang-settings)) - (apply make-deinprogramm-lang-settings settings-list) + (apply make-deinprogramm-lang-settings + (for/list ([i (in-naturals)] + [e (in-list settings-list)]) + (cond + [(= i deinprogramm-teachpacks-field-index) + (unmarshall-teachpack-settings e)] + [else e]))) (default-settings))) (default-settings)))) + ;; these are used for the benefit of v5.3.6 and earlier drracket's + ;; specifically, those language doesn't work right with teachpack + ;; paths of the form (lib "a/b/c.rkt"), but they do with ones of the + ;; form (lib "c.rkt" "a" "b"), so we do that conversion here when + ;; sending out a file that might go into 5.3.6. + + (define/private (unmarshall-teachpack-settings obj) + (cond + [(list? obj) + (for/list ([obj (in-list obj)]) + (match obj + [`(lib ,(? string? s1) ,(? string? s2) ...) + `(lib ,(apply string-append (add-between (append s2 (list s1)) "/")))] + [else obj]))] + [else obj])) + + (define/private (marshall-teachpack-settings obj) + (define (has-slashes? s) (regexp-match? #rx"/" s)) + (cond + [(list? obj) + (for/list ([obj (in-list obj)]) + (match obj + [`(lib ,(? (and/c string? has-slashes?) s)) + (define split (regexp-split #rx"/" s)) + `(lib ,(last split) ,@(reverse (cdr (reverse split))))] + [else obj]))] + [else obj])) + (define/private (metadata->table metadata) (let ([p (open-input-string metadata)]) (regexp-match #rx"\n#reader" p) ;; skip to reader diff --git a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt b/pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt index 7aa5d22b9d..284e18347c 100644 --- a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt @@ -54,6 +54,7 @@ ;; teachpacks : (listof require-spec) (define-struct (htdp-lang-settings drscheme:language:simple-settings) (tracing? teachpacks)) (define htdp-lang-settings->vector (make-->vector htdp-lang-settings)) + (define teachpacks-field-index (+ (procedure-arity drscheme:language:simple-settings) 1)) (define image-string "") @@ -619,6 +620,9 @@ (inherit-field reader-module) (define/override (get-reader-module) reader-module) (define/override (get-metadata modname settings) + (define parsed-tps + (marshall-teachpack-settings + (htdp-lang-settings-teachpacks settings))) (string-append (apply string-append (map (λ (x) (string-append x "\n")) @@ -628,20 +632,63 @@ `((modname ,modname) (read-case-sensitive ,(drscheme:language:simple-settings-case-sensitive settings)) - (teachpacks ,(htdp-lang-settings-teachpacks settings)) - (htdp-settings ,(htdp-lang-settings->vector settings)))))) + (teachpacks ,parsed-tps) + (htdp-settings + ,(for/vector ([e (in-vector (htdp-lang-settings->vector settings))] + [i (in-naturals)]) + (cond + [(= i teachpacks-field-index) parsed-tps] + [else e]))))))) (inherit default-settings) (define/override (metadata->settings metadata) - (let* ([table (massage-metadata (metadata->table metadata))] ;; extract the table - [ssv (assoc 'htdp-settings table)]) - (if ssv - (let ([settings-list (vector->list (cadr ssv))]) - (if (equal? (length settings-list) - (procedure-arity make-htdp-lang-settings)) - (apply make-htdp-lang-settings settings-list) - (default-settings))) - (default-settings)))) + (define table (massage-metadata (metadata->table metadata))) + (define ssv (assoc 'htdp-settings table)) + (cond + [ssv + (define settings-list (vector->list (cadr ssv))) + (cond + [(equal? (length settings-list) + (procedure-arity make-htdp-lang-settings)) + (define new-settings-list + (for/list ([i (in-naturals)] + [e (in-list settings-list)]) + (cond + [(= i teachpacks-field-index) + (unmarshall-teachpack-settings e)] + [else e]))) + (apply make-htdp-lang-settings new-settings-list)] + [else + (default-settings)])] + [else (default-settings)])) + + ;; these are used for the benefit of v5.3.6 and earlier drracket's + ;; specifically, those language doesn't work right with teachpack + ;; paths of the form (lib "a/b/c.rkt"), but they do with ones of the + ;; form (lib "c.rkt" "a" "b"), so we do that conversion here when + ;; sending out a file that might go into 5.3.6. + + (define/private (unmarshall-teachpack-settings obj) + (cond + [(list? obj) + (for/list ([obj (in-list obj)]) + (match obj + [`(lib ,(? string? s1) ,(? string? s2) ...) + `(lib ,(apply string-append (add-between (append s2 (list s1)) "/")))] + [else obj]))] + [else obj])) + + (define/private (marshall-teachpack-settings obj) + (define (has-slashes? s) (regexp-match? #rx"/" s)) + (cond + [(list? obj) + (for/list ([obj (in-list obj)]) + (match obj + [`(lib ,(? (and/c string? has-slashes?) s)) + (define split (regexp-split #rx"/" s)) + `(lib ,(last split) ,@(reverse (cdr (reverse split))))] + [else obj]))] + [else obj])) (define/private (massage-metadata md) (if (and (list? md)