From f43b08eba38b98caa2b9334377682e84cd9555ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 19 Nov 2015 14:17:35 +0100 Subject: [PATCH] [make works] Added raco test to makefile, fixed long lines in all *.rkt files. --- graph/graph/_examples_cond-abort.rkt | 190 ------------------ .../graph/_examples_differentiate_unions.rkt | 18 -- graph/graph/equatable.rkt | 50 +++-- graph/graph/graph.lp2.rkt | 19 +- graph/graph/queue.lp2.rkt | 7 +- graph/graph/rewrite-type.lp2.rkt | 6 +- graph/lib/doc.rkt | 24 ++- graph/lib/lib.rkt | 21 +- graph/lib/low-untyped.rkt | 5 +- graph/lib/test-framework.rkt | 21 +- graph/lib/untyped/for-star-list-star.rkt | 75 ++++--- graph/main.rkt | 3 +- graph/make/lib.rkt | 114 ++++++++--- graph/make/make.rkt | 121 +++++++++-- 14 files changed, 348 insertions(+), 326 deletions(-) delete mode 100644 graph/graph/_examples_cond-abort.rkt delete mode 100644 graph/graph/_examples_differentiate_unions.rkt diff --git a/graph/graph/_examples_cond-abort.rkt b/graph/graph/_examples_cond-abort.rkt deleted file mode 100644 index fd7c1138..00000000 --- a/graph/graph/_examples_cond-abort.rkt +++ /dev/null @@ -1,190 +0,0 @@ -#lang typed/racket - -(require "cond-abort.rkt") -(require "variant.lp2.rkt") -(require typed/rackunit) - -(check-equal? - (match-abort '(1 (a b) 3) - [(list x y z) - (let-abort ([new-x x] - [new-y (match-abort y - [(list n p) (list 'A n p)] - [(list q r s) (list 'B q r s)])] - [new-z z]) - (list new-x new-y new-z))]) - '(1 (A a b) 3)) - -(let () - (λ ([x : (U (Vector Number) (Vector String String))]) - (if (= (vector-length x) 1) - x ;; Occurrence typing didn't narrow the type of x to (Vector Number). - x)) - (void)) - -#| - -(λ ((v : (List Symbol String))) - (match-abort - v - ((list Symbol1 String2) - (let-abort - ((Symbol3 (protected Symbol1)) (String4 (match-abort String2 ((and String5) (string-length String5))))) - (list (unprotect Symbol3) (unprotect String4)))))) - -(λ ([v : (List Symbol String)]) - (match-abort - v - ((list Symbol1 String2) - (let-abort - ((Symbol3 #t) (String4 (match-abort String2 ((and String5) (string-length String5))))) - (list Symbol3 String4))))) - -(λ ((v : (List Symbol String))) - (unprotect - (match-abort - v - ((list Symbol1 String2) - (let-abort - ((Symbol3 (protected Symbol1)) (String4 (match-abort String2 ((and String5) (protected (string-length String5)))))) - (protected (list (unprotect Symbol3) (unprotect String4)))))))) - -|# - - - -(check-equal? - (foldl - (λ (x acc) - (if (null? x) - acc;(reverse acc) - (if (eq? x 'boo) - 'continue - (cons x acc)))) - '() - '(a b c)) - '(c b a)) - - -(begin - (: - test1a - (→ - (List (Pairof (List Symbol (Listof String)) String)) - (List (Pairof (List Symbol (Listof Number)) Number)))) - (define (test1a v) - (let-values (((temp2) (apply values v))) - (list - (let ((val-cache3 temp2)) - (cons - (let-values (((Symbol5 temp6) (apply values (car val-cache3)))) - (list Symbol5 (map (λ ((String9 : String)) (string-length String9)) temp6))) - (string-length (cdr val-cache3)))))))) - - - -(begin - (: - test1 - (→ - (List - (Pairof - (U - (List 'tag1 (List (Vector Symbol) (Listof String))) - (List 'tag2 (List (Vector Symbol) (Listof String)))) - String)) - (List - (Pairof - (U - (List 'tag1 (List (Vector Symbol) (Listof Number))) - (List 'tag2 (List (Vector Symbol) (Listof Number)))) - Number)))) - (define (test1 v) - (let-values (((temp2) (apply values v))) - (list - (let ((val-cache3 temp2)) - (cons - (let ((val-cache4 (car val-cache3))) - (cond - ((and (list? val-cache4) (eq? 'tag1 (car val-cache4))) - (let-values (((temp6 temp7) (apply values val-cache4))) - (list - temp6 - (let-values (((temp10 temp11) (apply values temp7))) - (list - (let ((val-cache12 temp10)) - (let ((Symbol13 (vector-ref val-cache12 0))) (vector Symbol13))) - (map (λ ((String16 : String)) (string-length String16)) temp11)))))) - ((and (list? val-cache4) (eq? 'tag2 (car val-cache4))) - (let-values (((temp20 temp21) (apply values val-cache4))) - (list - temp20 - (let-values (((temp24 temp25) (apply values temp21))) - (list - (let ((val-cache26 temp24)) - (let ((Symbol27 (vector-ref val-cache26 0))) (vector Symbol27))) - (map (λ ((String30 : String)) (string-length String30)) temp25)))))))) - (string-length (cdr val-cache3)))))))) - -#| -(define-syntax-rule (map-abort lst v . body) - #;(let ([l (foldl (λ (v acc) - (let ([result (let () . body)]) - (if (eq? result 'continue) - 'continue - (if (eq? result 'break) - 'break - (cons (unprotect result) acc))))) - '() - lst)]) - (if (or (eq? l 'continue) (eq? l 'break)) - l - (reverse l)))) - -(begin - (: - test1 - (→ - (List (Pairof (List Symbol (Listof String)) String)) - (List (Pairof (List Symbol (Listof Number)) Number)))) - (define (test1 v) - (unprotect - (match-abort - v - ((list temp1) - (let-abort - ((temp2 - (match-abort - temp1 - ((cons temp3 String4) - (let-abort - ((temp5 - (match-abort - temp3 - ((list Symbol7 temp8) - (let-abort - ((Symbol9 (protected Symbol7)) - (temp10 - #;(match-abort - temp8 - ((list String11 ...) - (begin String11 (error "e")))) - (match-abort - temp8 - ((list String11 ...) - (map-abort - String11 - String12 - (match-abort - String12 - ((and String13) - (protected (string-length String13))))))))) - (protected - (list (unprotect Symbol9) (unprotect temp10))))))) - (String6 - (match-abort - String4 - ((and String14) (protected (string-length String14)))))) - (protected (cons (unprotect temp5) (unprotect String6)))))))) - (protected (list (unprotect temp2))))))))) -|# \ No newline at end of file diff --git a/graph/graph/_examples_differentiate_unions.rkt b/graph/graph/_examples_differentiate_unions.rkt deleted file mode 100644 index 9161b361..00000000 --- a/graph/graph/_examples_differentiate_unions.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang typed/racket/no-check - - -#;(λ ([x : (U (Vector Number) (Vector String String))]) - (ann (vector-ref x 0) (U Number String))) - -(let () - (ann (λ ([x : (U (Vector Number) (Vector String String) Symbol)]) - (if (vector? x) - x - #f)) - (→ (U (Vector Number) (Vector String String) Symbol) - (U False (Vector Number) (Vector String String)))) - - - (λ ([x : (U (→ Number Number Number) (→ Number Number))]) - (procedure-arity x)) - (void)) \ No newline at end of file diff --git a/graph/graph/equatable.rkt b/graph/graph/equatable.rkt index 384f69a1..3ca9ae67 100644 --- a/graph/graph/equatable.rkt +++ b/graph/graph/equatable.rkt @@ -5,13 +5,27 @@ (define-struct untyped-object () #:transparent - ;#:property prop:procedure (λ (self . rest) (apply (untyped-object-proc self) rest)) + ;#:property prop:procedure (λ (self . rest) + ; (apply (untyped-object-proc self) rest)) #:methods gen:custom-write - [(define write-proc (λ (self port mode) (((vector-ref (struct->vector self) 1) 'write-proc) port mode)))] + [(define write-proc (λ (self port mode) + (let* ([f (vector-ref (struct->vector self) 1)] + [write-proc (f 'write-proc)]) + (write-proc port mode))))] #:methods gen:equal+hash - [(define equal-proc (λ (x y recursive-equal?) (((vector-ref (struct->vector x) 1) 'equal-proc) y recursive-equal?))) - (define hash-proc (λ (x recursive-equal-hash-code?) (((vector-ref (struct->vector x) 1) 'hash-proc) recursive-equal-hash-code?))) - (define hash2-proc (λ (x recursive-equal-secondary-hash-code?) (((vector-ref (struct->vector x) 1) 'hash2-proc) recursive-equal-secondary-hash-code?)))])) + [(define equal-proc (λ (x y recursive-equal?) + (let* ([f (vector-ref (struct->vector x) 1)] + [equal-proc (f 'equal-proc)]) + (f y recursive-equal?)))) + (define hash-proc (λ (x recursive-equal-hash-code?) + (let* ([f (vector-ref (struct->vector x) 1)] + [hash-proc (f 'hash-proc)]) + (hash-proc recursive-equal-hash-code?)))) + (define hash2-proc (λ (x recursive-equal-secondary-hash-code?) + (let* ([f (vector-ref (struct->vector x) 1)] + [hash2-proc (f 'hash2-proc)]) + (hash2-proc + recursive-equal-secondary-hash-code?))))])) (module typed typed/racket @@ -19,23 +33,31 @@ [#:struct untyped-object ()]) (define-type Field-Present (Vector Any)) - + (: field-present (→ Any Field-Present)) (define (field-present x) (vector x)) - + (: field-present-get-value (→ Field-Present Any)) (define (field-present-get-value fp) (vector-ref fp 0)) (struct (T) Equatable untyped-object - ([f : (case→ [→ 'value T] ;; Sadly, we can't extend a case→ described by T, so we have to chain two calls to access any field. + ([f : (case→ [→ 'value T] + ;; Above: Sadly, we can't extend a case→ described by T, + ;; so we have to chain two calls to access any field. + ;; TODO: we could just directly accept the other parameters - [→ 'write-proc (→ Output-Port (U #t #f 0 1) Any)] - [→ 'equal-proc (→ (U Equatable Any) (→ Any Any Boolean) Boolean)] - [→ 'hash-proc (→ (→ Any Fixnum) Fixnum)] - [→ 'hash2-proc (→ (→ Any Fixnum) Fixnum)] - [→ 'reflect (→ (U Index Symbol) (U Field-Present #f))])]) + [→ 'write-proc (→ Output-Port (U #t #f 0 1) + Any)] + [→ 'equal-proc (→ (U Equatable Any) (→ Any Any Boolean) + Boolean)] + [→ 'hash-proc (→ (→ Any Fixnum) + Fixnum)] + [→ 'hash2-proc (→ (→ Any Fixnum) + Fixnum)] + [→ 'reflect (→ (U Index Symbol) + (U Field-Present #f))])]) #:transparent) - + (: Equatable-value (∀ (T) (→ (Equatable T) T))) (define (Equatable-value e) ((Equatable-f e) 'value)) diff --git a/graph/graph/graph.lp2.rkt b/graph/graph/graph.lp2.rkt index ee20603c..957743ae 100644 --- a/graph/graph/graph.lp2.rkt +++ b/graph/graph/graph.lp2.rkt @@ -188,14 +188,14 @@ Here is an overview of the architecture of the graph constructor: #`(let () - - (let () - - - - - - make-graph-database)))] + + (let () + + + + + + make-graph-database)))] @chunk[ (define make-g (make-graph-constructor @@ -412,7 +412,8 @@ those to the queue. (let* ([transformed : transform/result-node/incomplete (apply transform/link-request→incomplete - (cdr (transform/link-request-pre-declared-key request)))] + (cdr (transform/link-request-pre-declared-key + request)))] [transform/transformed (cons transformed transform/transformed)] [extracted diff --git a/graph/graph/queue.lp2.rkt b/graph/graph/queue.lp2.rkt index 637447b2..41336edd 100644 --- a/graph/graph/queue.lp2.rkt +++ b/graph/graph/queue.lp2.rkt @@ -64,7 +64,12 @@ some of those need to be deleted before being processed). Result)))] @chunk[ - (define (fold-queue initial-queue accumulator last-result dequeue empty? process) + (define (fold-queue initial-queue + accumulator + last-result + dequeue + empty? + process) (let process-rest ([queue initial-queue] [accumulator accumulator]) (if (empty? queue) (last-result accumulator) diff --git a/graph/graph/rewrite-type.lp2.rkt b/graph/graph/rewrite-type.lp2.rkt index 92a4c530..1b64a809 100644 --- a/graph/graph/rewrite-type.lp2.rkt +++ b/graph/graph/rewrite-type.lp2.rkt @@ -556,8 +556,7 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and "variant.lp2.rkt" "../type-expander/multi-id.lp2.rkt" "../type-expander/type-expander.lp2.rkt" - "../lib/low.rkt" - "cond-abort.rkt") + "../lib/low.rkt") (begin-for-syntax (provide replace-in-type ;replace-in-instance fold-instance @@ -582,8 +581,7 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and "structure.lp2.rkt" "variant.lp2.rkt" "../type-expander/multi-id.lp2.rkt" - "../type-expander/type-expander.lp2.rkt" - "cond-abort.rkt") + "../type-expander/type-expander.lp2.rkt") diff --git a/graph/lib/doc.rkt b/graph/lib/doc.rkt index 77a076db..6d2e1c7a 100644 --- a/graph/lib/doc.rkt +++ b/graph/lib/doc.rkt @@ -38,7 +38,8 @@ (require (for-syntax mzlib/etc)) (define-syntax (doc-lib-setup stx) - ;(display (build-path (this-expression-source-directory) (this-expression-file-name))) + ;(display (build-path (this-expression-source-directory) + ; (this-expression-file-name))) #'setup-math) ;; NOTE: setup-math must be returned, not just called! (provide doc-lib-setup) @@ -56,10 +57,12 @@ -;; Copied from /usr/local/racket-6.2.900.6/share/pkgs/scribble-lib/scribble/private/lp.rkt +;; Copied from the file: +;; /usr/local/racket-6.2.900.6/share/pkgs/scribble-lib/scribble/private/lp.rkt (require (for-syntax racket/base syntax/boundmap) - scribble/scheme scribble/decode scribble/manual (except-in scribble/struct table)) + scribble/scheme scribble/decode scribble/manual + (except-in scribble/struct table)) (begin-for-syntax ;; maps chunk identifiers to a counter, so we can distinguish multiple uses @@ -68,7 +71,10 @@ (define (get-chunk-number id) (free-identifier-mapping-get chunk-numbers id (lambda () #f))) (define (inc-chunk-number id) - (free-identifier-mapping-put! chunk-numbers id (+ 1 (free-identifier-mapping-get chunk-numbers id)))) + (free-identifier-mapping-put! chunk-numbers id + (+ 1 + (free-identifier-mapping-get chunk-numbers + id)))) (define (init-chunk-number id) (free-identifier-mapping-put! chunk-numbers id 2))) @@ -85,7 +91,9 @@ (when n (inc-chunk-number (syntax-local-introduce #'name))) - (syntax-local-lift-expression #'(quote-syntax (a-chunk name expr (... ...)))) + (syntax-local-lift-expression #'(quote-syntax (a-chunk name + expr + (... ...)))) (with-syntax ([tag tag] [str str] @@ -93,13 +101,15 @@ (map (lambda (expr) (syntax-case expr (require) [(require mod (... ...)) - (let loop ([mods (syntax->list #'(mod (... ...)))]) + (let loop + ([mods (syntax->list #'(mod (... ...)))]) (cond [(null? mods) null] [else (syntax-case (car mods) (for-syntax) [(for-syntax x (... ...)) - (append (loop (syntax->list #'(x (... ...)))) + (append (loop (syntax->list + #'(x (... ...)))) (loop (cdr mods)))] [x (cons #'x (loop (cdr mods)))])]))] diff --git a/graph/lib/lib.rkt b/graph/lib/lib.rkt index 7142ffca..9b177fb1 100644 --- a/graph/lib/lib.rkt +++ b/graph/lib/lib.rkt @@ -35,10 +35,13 @@ Symbol Char Void - ;Input-Port ;; Not quite mutable, but not really immutable either. - ;Output-Port ;; Not quite mutable, but not really immutable either. - ;Port ;; Not quite mutable, but not really immutable either. - #| I haven't checked the mutability of the ones in the #||# comments below + ;Input-Port ;; Not quite mutable, nor immutable. + ;Output-Port ;; Not quite mutable, nor immutable. + ;Port ;; Not quite mutable, nor immutable. + + ;; I haven't checked the mutability of the ones + ;; inside in the #||# comments below + #| Path Path-For-Some-System Regexp @@ -55,7 +58,11 @@ EOF Continuation-Mark-Set |# - ; Undefined ;; We definitely don't want that one, it's not mutable but it's an error if present anywhere 99.9% of the time. + ;; We definitely don't Undefined, it's not mutable + ;; but it's an error if present anywhere 99.9% of + ;; the time. Typed/racket is moving towards making + ;; occurrences of this type an error, anyway. + ; Undefined #| Module-Path Module-Path-Index @@ -92,7 +99,9 @@ (Pairof AnyImmutable AnyImmutable) (Listof AnyImmutable) ; Plus many others, not added yet. - ; -> ; Not closures, because they can contain mutable variables, and we can't eq? them + ;; Don't include closures, because they can contain + ;; mutable variables, and we can't eq? them. + ; -> ; maybe Prefab? Or are they mutable? )) diff --git a/graph/lib/low-untyped.rkt b/graph/lib/low-untyped.rkt index 67e68d50..24dbd9c0 100644 --- a/graph/lib/low-untyped.rkt +++ b/graph/lib/low-untyped.rkt @@ -1,7 +1,8 @@ #lang typed/racket/no-check -;; When creating the html document with scribble/lp2, it does not see the macros defined in low.rkt when including it with sugar/include. -;; Using a raw include/reader works. +;; When creating the html document with scribble/lp2, it does not see the macros +;; defined in low.rkt when including it with sugar/include. +;; But using a raw include/reader works. ;(require sugar/include) ;(include-without-lang-line "low.rkt") diff --git a/graph/lib/test-framework.rkt b/graph/lib/test-framework.rkt index 0a0eda22..9c3e360d 100644 --- a/graph/lib/test-framework.rkt +++ b/graph/lib/test-framework.rkt @@ -2,9 +2,12 @@ ;; Using check-equal? on our variants result in the following error message: ;; Attempted to use a higher-order value passed as `Any` in untyped code -;; check-equal? and check-not-equal? are replaced by versions that work with “higher-order values” below. +;; check-equal? and check-not-equal? are replaced by versions that work with +;; “higher-order values” below. -(require (except-in (only-meta-in 0 typed/rackunit) ;; typed/racket risks complaining that it can't do for-meta in all-from-out otherwise. +(require (except-in (only-meta-in 0 typed/rackunit) + ;; Above: typed/racket risks complaining that it can't do + ;; for-meta in all-from-out if we don't use `only-meta-in`. check-equal? check-not-equal?)) @@ -26,15 +29,23 @@ (check-true (not (equal? x y)) . message)) (define-simple-macro (check-eval-equal? to-eval y . message) - (check-true (equal? (eval-get-values to-eval (variable-reference->namespace (#%variable-reference))) y) . message)) + (check-true (equal? (eval-get-values to-eval + (variable-reference->namespace + (#%variable-reference))) + y) + . message)) (define-simple-macro (check-eval-string-equal? to-eval y . message) - (check-true (equal? (eval-get-values (read (open-input-string to-eval)) (variable-reference->namespace (#%variable-reference))) + (check-true (equal? (eval-get-values (read (open-input-string to-eval)) + (variable-reference->namespace + (#%variable-reference))) y) . message)) (define-simple-macro (check-eval-string-equal?/ns ns-anchor to-eval y . message) - (check-true (equal? (eval-get-values (read (open-input-string to-eval)) (namespace-anchor->namespace ns-anchor)) + (check-true (equal? (eval-get-values (read (open-input-string to-eval)) + (namespace-anchor->namespace + ns-anchor)) y) . message)) diff --git a/graph/lib/untyped/for-star-list-star.rkt b/graph/lib/untyped/for-star-list-star.rkt index 5bf781d6..6db7238e 100644 --- a/graph/lib/untyped/for-star-list-star.rkt +++ b/graph/lib/untyped/for-star-list-star.rkt @@ -11,36 +11,61 @@ #:with for-kind (if (attribute star) #'for*/list #'for/list))) (syntax-parse stx - [(_ sequences:sequences ... body) + [(_ [sequences:sequences ...] . body) (foldl (λ (for-kind clauses acc) #`(#,for-kind #,clauses #,acc)) - #'body + #'(let () . body) (reverse (syntax-e #'(sequences.for-kind ...))) - (reverse (syntax-e #'(([sequences.id sequences.seq-expr] ...) ...))))])) + (reverse (syntax-e #'(([sequences.id sequences.seq-expr] ...) + ...))))])) ;; Test for*/list* (module* test racket (require rackunit) (require (submod "..")) - (check-equal? (for*/list* ([x '(a b c)] - [y '(1 2 3)]) - (* [z '(d e f)] - [t '(4 5 6)]) - (list x y z t)) - '(((a 1 d 4) (a 1 d 5) (a 1 d 6) (a 1 e 4) (a 1 e 5) (a 1 e 6) (a 1 f 4) (a 1 f 5) (a 1 f 6)) - ((b 2 d 4) (b 2 d 5) (b 2 d 6) (b 2 e 4) (b 2 e 5) (b 2 e 6) (b 2 f 4) (b 2 f 5) (b 2 f 6)) - ((c 3 d 4) (c 3 d 5) (c 3 d 6) (c 3 e 4) (c 3 e 5) (c 3 e 6) (c 3 f 4) (c 3 f 5) (c 3 f 6)))) - (check-equal? (for*/list* ([x '(a b c)]) - ([y '(1 2 3)]) - (* [z '(d e f)] - [t '(4 5 6)]) - (list x y z t)) - '((((a 1 d 4) (a 1 d 5) (a 1 d 6) (a 1 e 4) (a 1 e 5) (a 1 e 6) (a 1 f 4) (a 1 f 5) (a 1 f 6)) - ((a 2 d 4) (a 2 d 5) (a 2 d 6) (a 2 e 4) (a 2 e 5) (a 2 e 6) (a 2 f 4) (a 2 f 5) (a 2 f 6)) - ((a 3 d 4) (a 3 d 5) (a 3 d 6) (a 3 e 4) (a 3 e 5) (a 3 e 6) (a 3 f 4) (a 3 f 5) (a 3 f 6))) - (((b 1 d 4) (b 1 d 5) (b 1 d 6) (b 1 e 4) (b 1 e 5) (b 1 e 6) (b 1 f 4) (b 1 f 5) (b 1 f 6)) - ((b 2 d 4) (b 2 d 5) (b 2 d 6) (b 2 e 4) (b 2 e 5) (b 2 e 6) (b 2 f 4) (b 2 f 5) (b 2 f 6)) - ((b 3 d 4) (b 3 d 5) (b 3 d 6) (b 3 e 4) (b 3 e 5) (b 3 e 6) (b 3 f 4) (b 3 f 5) (b 3 f 6))) - (((c 1 d 4) (c 1 d 5) (c 1 d 6) (c 1 e 4) (c 1 e 5) (c 1 e 6) (c 1 f 4) (c 1 f 5) (c 1 f 6)) - ((c 2 d 4) (c 2 d 5) (c 2 d 6) (c 2 e 4) (c 2 e 5) (c 2 e 6) (c 2 f 4) (c 2 f 5) (c 2 f 6)) - ((c 3 d 4) (c 3 d 5) (c 3 d 6) (c 3 e 4) (c 3 e 5) (c 3 e 6) (c 3 f 4) (c 3 f 5) (c 3 f 6)))))) \ No newline at end of file + (check-equal? (for*/list* [([x '(a b c)] + [y '(1 2 3)]) + (* [z '(d e f)] + [t '(4 5 6)])] + (list x y z t)) + '(((a 1 d 4) (a 1 d 5) (a 1 d 6) + (a 1 e 4) (a 1 e 5) (a 1 e 6) + (a 1 f 4) (a 1 f 5) (a 1 f 6)) + ((b 2 d 4) (b 2 d 5) (b 2 d 6) + (b 2 e 4) (b 2 e 5) (b 2 e 6) + (b 2 f 4) (b 2 f 5) (b 2 f 6)) + ((c 3 d 4) (c 3 d 5) (c 3 d 6) + (c 3 e 4) (c 3 e 5) (c 3 e 6) + (c 3 f 4) (c 3 f 5) (c 3 f 6)))) + (check-equal? (for*/list* [([x '(a b c)]) + ([y '(1 2 3)]) + (* [z '(d e f)] + [t '(4 5 6)])] + (list x y z t)) + '((((a 1 d 4) (a 1 d 5) (a 1 d 6) + (a 1 e 4) (a 1 e 5) (a 1 e 6) + (a 1 f 4) (a 1 f 5) (a 1 f 6)) + ((a 2 d 4) (a 2 d 5) (a 2 d 6) + (a 2 e 4) (a 2 e 5) (a 2 e 6) + (a 2 f 4) (a 2 f 5) (a 2 f 6)) + ((a 3 d 4) (a 3 d 5) (a 3 d 6) + (a 3 e 4) (a 3 e 5) (a 3 e 6) + (a 3 f 4) (a 3 f 5) (a 3 f 6))) + (((b 1 d 4) (b 1 d 5) (b 1 d 6) + (b 1 e 4) (b 1 e 5) (b 1 e 6) + (b 1 f 4) (b 1 f 5) (b 1 f 6)) + ((b 2 d 4) (b 2 d 5) (b 2 d 6) + (b 2 e 4) (b 2 e 5) (b 2 e 6) + (b 2 f 4) (b 2 f 5) (b 2 f 6)) + ((b 3 d 4) (b 3 d 5) (b 3 d 6) (b 3 e 4) + (b 3 e 5) (b 3 e 6) (b 3 f 4) + (b 3 f 5) (b 3 f 6))) + (((c 1 d 4) (c 1 d 5) (c 1 d 6) (c 1 e 4) + (c 1 e 5) (c 1 e 6) (c 1 f 4) + (c 1 f 5) (c 1 f 6)) + ((c 2 d 4) (c 2 d 5) (c 2 d 6) (c 2 e 4) + (c 2 e 5) (c 2 e 6) (c 2 f 4) + (c 2 f 5) (c 2 f 6)) + ((c 3 d 4) (c 3 d 5) (c 3 d 6) (c 3 e 4) + (c 3 e 5) (c 3 e 6) (c 3 f 4) + (c 3 f 5) (c 3 f 6)))))) \ No newline at end of file diff --git a/graph/main.rkt b/graph/main.rkt index 95ff75de..15aa9a84 100644 --- a/graph/main.rkt +++ b/graph/main.rkt @@ -54,7 +54,8 @@ (define-type to (List (Pairof String Boolean) (Listof String))) (: convert (case→ (→ from to) - (→ (Pairof (Listof Number) Null) (Pairof (Listof String) Null)) + (→ (Pairof (Listof Number) Null) + (Pairof (Listof String) Null)) (→ (Pairof Number Boolean) (Pairof String Boolean)) (→ (Listof Number) (Listof String)) (→ Number String) diff --git a/graph/make/lib.rkt b/graph/make/lib.rkt index 489e8208..c6886765 100644 --- a/graph/make/lib.rkt +++ b/graph/make/lib.rkt @@ -21,7 +21,8 @@ rkt->zo-file make-collection run - run!) + run! + find-executable-path-or-fail) (require/typed make [make/proc (→ (Listof (Pairof (U Path-String (Listof Path-String)) @@ -30,11 +31,17 @@ (List (-> Any)))))) (U String (Vectorof String) (Listof String)) Void)]) -;(require/typed make/collection [make-collection (→ Any (Listof Path-String) (U String (Vectorof String)) Void)]) +;(require/typed make/collection [make-collection (→ Any (Listof Path-String) +; (U String (Vectorof String)) +; Void)]) (require/typed srfi/13 - [string-suffix? (->* (String String) (Integer Integer Integer Integer) Boolean)] - [string-prefix? (->* (String String) (Integer Integer Integer Integer) Boolean)]) + [string-suffix? (->* (String String) + (Integer Integer Integer Integer) + Boolean)] + [string-prefix? (->* (String String) + (Integer Integer Integer Integer) + Boolean)]) (define (find-files-by-extension [ext : String]) (find-files (λ ([path : Path]) (string-suffix? ext (path->string path))))) @@ -50,13 +57,26 @@ (: rules (→ (U t-rule (Listof t-rule)) * (Listof t-rule))) (define (rules . rs) (apply append (map (λ ([x : (U t-rule (Listof t-rule))]) - (cond [(null? x) '()] ;; x = '() is an empty (Listof t-rule) - [(null? (cdr x)) x] ;; x = '([target dep maybe-proc]) is a (Listof t-rule) with just one element - [(null? (cadr x)) (list x)] ;; x = '[target () maybe-proc] is a t-rule with an empty list of dependencies - ;; Below, either x = '[target (dep₁ . ?) maybe-proc] or x = '([target dep maybe-proc] [target dep maybe-proc]) - [(null? (cdadr x)) (list x)] ;; x = '[target (dep₁ . ()) maybe-proc] - [(list? (cadadr x)) x] ;; x = '([target dep maybe-proc] [target (?) maybe-proc]) - [else (list x)])) ; x = '[target (dep₁ dep₂ . ()) maybe-proc] + (cond + ;; x = '() is an empty (Listof t-rule) + [(null? x) '()] + ;; x = '([target dep maybe-proc]) is a (Listof t-rule) + ;; with just one element + [(null? (cdr x)) x] + ;; x = '[target () maybe-proc] is a t-rule + ;; with an empty list of dependencies + [(null? (cadr x)) (list x)] + ;; Below, either x = '[target (dep₁ . ?) maybe-proc] + ;; or x = '([target dep maybe-proc] + ;; [target dep maybe-proc]) + [else (cond + ;; x = '[target (dep₁ . ()) maybe-proc] + [(null? (cdadr x)) (list x)] + ;; x = '([target dep maybe-proc] + ;; [target (?) maybe-proc]) + [(list? (cadadr x)) x] + ; x = '[target (dep₁ dep₂ . ()) maybe-proc] + [else (list x)])])) rs))) #| @@ -77,7 +97,8 @@ (list depend ...) (λ () body ...)))) -(define-syntax-rule (for/rules ([arg files] ...) (target ...) (depend ...) body ...) +(define-syntax-rule (for/rules ([arg files] ...) (target ...) (depend ...) + body ...) (map (implicit-rule (arg ...) (target ...) (depend ...) body ...) files ...)) (: path-string->string (→ Path-String String)) @@ -98,11 +119,13 @@ (path-string->string b)))) (define-syntax-rule (regexp-case input [pattern replacement] ...) - (let ([input-cache input]) ;; TODO: should also cache the patterns, but lazily. + (let ([input-cache input]) ;; TODO: should also cache the patterns, but lazily (cond - [(regexp-match pattern input-cache) (regexp-replace pattern input-cache replacement)] + [(regexp-match pattern input-cache) + (regexp-replace pattern input-cache replacement)] ... - [else input-cache]))) + [else + input-cache]))) (: dirname (→ Path Path)) (define (dirname p) @@ -132,15 +155,26 @@ #("zo") argv))) -;; make-collection from /usr/local/racket-6.2.900.6/share/pkgs/make/collection-unit.rkt -(require/typed compiler/compiler [compile-zos (->* (Any) (#:module? Any #:verbose? Any) (→ (Listof Path-String) (U Path-String #f 'auto) Void))]) -(require/typed dynext/file [append-zo-suffix (→ Path-String Path)]) +;; make-collection copied from the file +;; /usr/local/racket-6.2.900.6/share/pkgs/make/collection-unit.rkt +(require/typed compiler/compiler + [compile-zos (->* (Any) + (#:module? Any #:verbose? Any) + (→ (Listof Path-String) + (U Path-String #f 'auto) + Void))]) +(require/typed dynext/file + [append-zo-suffix (→ Path-String Path)]) (: cache (∀ (T) (→ (→ T) (→ T)))) (define (cache producer) - (let ([cache : (U False (List T)) #f]) ;; Use (List T) instead of T, so that if the producer returns #f, we don't call it each time. + ;; Use (List T) instead of T, so that if the producer returns #f, + ;; we don't call it each time. + (let ([cache : (U False (List T)) #f]) (λ () - (let ([c cache]) ;; since cache is mutated by set!, occurrence typing won't work on it, so we need to take a copy. + ;; since cache is mutated by set!, occurrence typing won't work on it, + ;; so we need to take a copy: + (let ([c cache]) (if c (car c) (let ((producer-result (producer))) @@ -153,9 +187,11 @@ (: rkt->zo-file (→ Path-String Path)) (define (rkt->zo-file src-file) - (build-path (rkt->zo-dir src-file) (append-zo-suffix (assert (file-name-from-path src-file))))) + (build-path (rkt->zo-dir src-file) + (append-zo-suffix (assert (file-name-from-path src-file))))) -(: make-collection (→ Any (Listof Path-String) (U String (Vectorof String)) Void)) +(: make-collection (→ Any (Listof Path-String) (U String (Vectorof String)) + Void)) (define (make-collection collection-name collection-files argv) (printf "building collection ~a: ~a\n" collection-name collection-files) (let* ([zo-compiler (cache (λ () (compile-zos #f)))] @@ -171,17 +207,23 @@ `(,zo (,rkt) ,(lambda () (let ([dest (rkt->zo-dir rkt)]) - (unless (directory-exists? dest) (make-directory dest)) + (unless (directory-exists? dest) + (make-directory dest)) ((zo-compiler) (list rkt) dest))))) rkts zos)]) (make/proc (append `(("zo" ,zos)) rkt->zo-list) argv))) -(: run (→ (U Path-String (Pairof Path-String (Listof (U Path-String Bytes)))) [#:set-pwd? Any] (U Path-String Bytes) * Boolean)) +(: run (→ (U Path-String (Pairof Path-String (Listof (U Path-String Bytes)))) + [#:set-pwd? Any] + (U Path-String Bytes) * + Boolean)) (define (run arg0 #:set-pwd? [set-pwd? #f] . args) (if (list? arg0) (apply run arg0) (begin - (displayln (string-append (string-join (cons (path-string->string arg0) (map (λ (x) (format "~a" x)) args)) " "))) + (displayln (string-join (cons (path-string->string arg0) + (map (λ (x) (format "~a" x)) args)) + " ")) (display "\033[1;34m") (flush-output) (let ((result (apply system* arg0 args))) @@ -191,4 +233,24 @@ (raise "Command failed.")) result)))) -(define-syntax-rule (run! . rest) (let () (run . rest) (values))) \ No newline at end of file +(define-syntax-rule (run! . rest) (let () (run . rest) (values))) + +(: find-executable-path-or-fail (->* (Path-String) + ((U Path-String False) Any) + Path)) +(define find-executable-path-or-fail + (let ((fn (λ ([executable-name : Path-String] + [a : (U Path-String False 'none)] + [b : (U (List Any) 'none)]) + : Path + (or (if (eq? a 'none) + (find-executable-path executable-name) + (if (eq? b 'none) + (find-executable-path executable-name a) + (find-executable-path executable-name a (car b)))) + (error (format "Can't find executable '~a'" + executable-name)))))) + (case-lambda + [(x) (fn x 'none 'none)] + [(x a) (fn x a 'none)] + [(x a b) (fn x a (list b))]))) \ No newline at end of file diff --git a/graph/make/make.rkt b/graph/make/make.rkt index d824a19e..e4caf3bf 100644 --- a/graph/make/make.rkt +++ b/graph/make/make.rkt @@ -1,4 +1,4 @@ -#lang typed/racket +#lang at-exp typed/racket (require "lib.rkt") @@ -9,11 +9,60 @@ ;raco pkg install alexis-util ;And some other collections too. ; -;cat graph/structure.lp2.rkt | awk '{if (length > 80) print NR "\t" length "\t" $0}' | sed -e 's/^\([0-9]*\t[0-9]*\t.\{80\}\)\(.*\)$/\1\x1b[0;30;41m\2\x1b[m/' +;cat graph/structure.lp2.rkt \ +;| awk '{if (length > 80) print NR "\t" length "\t" $0}' \ +;| sed -e 's/^\([0-9]*\t[0-9]*\t.\{80\}\)\(.*\)$/\1\x1b[0;30;41m\2\x1b[m/' +; +;for i in `find \( -path ./lib/doc/bracket -prune -and -false \) \ +; -or \( -name compiled -prune -and -false \) \ +; -or -name '*.rkt'`; +; do +; x=`cat "$i" \ +; | awk '{if (length > 80) print NR "\t" length "\t" $0}' \ +; | sed -e 's/^\([0-9]*\t[0-9]*\t.\{80\}\)\(.*\)$/\1\x1b[0;30;41m\2\x1b[m/'` +; [ -n "$x" ] && echo -e "\033[1;31m$i:\033[m" && echo $x +; done + +#| +"for i in `find \( -path ./lib/doc/bracket -prune -and -false \) \ + -or \( -name compiled -prune -and -false \) \ + -or -name '*.rkt'`; + do + x=`cat "$i" \ + | awk '{if (length > 80) print NR "\t" length "\t" $0}' \ + | sed -e 's/^\([0-9]*\t[0-9]*\t.\{80\}\)\(.*\)$/\1\x1b[0;30;41m\2\x1b[m/'` + [ -n "$x" ] && echo -e "\033[1;31m$i:\033[m" && echo $x + done" +|# + +(run! (list (find-executable-path-or-fail "sh") + "-c" + @string-append{ + fond_long_lines=0 + for i in `find \ + \( -path ./lib/doc/bracket -prune -and -false \) \ + -or \( -name compiled -prune -and -false \) \ + -or -name '*.rkt'` + do + x=`cat "$i" \ + | awk '{if (length > 80) print NR "\t" length "\t" $0}' \ + | sed -e 's/^\([0-9]*\t[0-9]*\t.\{80\}\)\(.*\)$/\1\x1b[0;30;41m\2\x1b[m/'` + if test -n "$x"; then + fond_long_lines=1 + printf '\033[1;31m%s:\033[m\n' "$i" && printf "%s\n" "$x" + fi + done + exit $fond_long_lines + })) ;; TODO: should directly exclude them in find-files-by-extension. -(define excluded-dirs (list "docs/" "bug/" "lib/doc/bracket/" "lib/doc/math-scribble/" "lib/doc/MathJax/")) -(define (exclude-dirs [files : (Listof Path)] [excluded-dirs : (Listof String) excluded-dirs]) +(define excluded-dirs (list "docs/" + "bug/" + "lib/doc/bracket/" + "lib/doc/math-scribble/" + "lib/doc/MathJax/")) +(define (exclude-dirs [files : (Listof Path)] + [excluded-dirs : (Listof String) excluded-dirs]) (filter-not (λ ([p : Path]) (ormap (λ ([excluded-dir : String]) (string-prefix? excluded-dir (path->string p))) @@ -24,11 +73,25 @@ (define lp2-files (exclude-dirs (find-files-by-extension ".lp2.rkt"))) (define rkt-files (exclude-dirs (find-files-by-extension ".rkt"))) (define doc-sources (append scrbl-files lp2-files)) -(define html-files (map (λ ([scrbl-or-lp2 : Path]) (build-path "docs/" (regexp-case (path->string scrbl-or-lp2) [#rx"\\.scrbl" ".html"] [#rx"\\.lp2\\.rkt" ".lp2.html"]))) +(define html-files (map (λ ([scrbl-or-lp2 : Path]) + (build-path "docs/" + (regexp-case (path->string scrbl-or-lp2) + [#rx"\\.scrbl" + ".html"] + [#rx"\\.lp2\\.rkt" + ".lp2.html"]))) doc-sources)) -(define pdf-files (map (λ ([scrbl-or-lp2 : Path]) (build-path "docs/" (regexp-case (path->string scrbl-or-lp2) [#rx"\\.scrbl" ".pdf"] [#rx"\\.lp2\\.rkt" ".lp2.pdf"]))) +(define pdf-files (map (λ ([scrbl-or-lp2 : Path]) + (build-path "docs/" + (regexp-case (path->string scrbl-or-lp2) + [#rx"\\.scrbl" + ".pdf"] + [#rx"\\.lp2\\.rkt" + ".lp2.pdf"]))) doc-sources)) -(define mathjax-links (map (λ ([d : Path]) (build-path d "MathJax")) (remove-duplicates (map dirname html-files)))) +(define mathjax-links (map (λ ([d : Path]) + (build-path d "MathJax")) + (remove-duplicates (map dirname html-files)))) (define-type ScribbleRenderers ; TODO: add --html-tree and '(other . "…") to be future-proof. @@ -36,14 +99,15 @@ "--text" "--markdown")) (: scribble (→ Path (Listof Path) ScribbleRenderers Any)) (define (scribble file all-files renderer) - (run `(,(or (find-executable-path "scribble") (error "Can't find executable 'scribble'")) + (run `(,(find-executable-path-or-fail "scribble") ,renderer "--dest" ,(build-path "docs/" (dirname file)) "+m" "--redirect-main" "http://docs.racket-lang.org/" "--info-out" ,(build-path "docs/" (path-append file ".sxref")) ,@(append-map (λ ([f : Path-String]) : (Listof Path-String) - (let ([sxref (build-path "docs/" (path-append f ".sxref"))]) + (let ([sxref (build-path "docs/" + (path-append f ".sxref"))]) (if (file-exists? sxref) (list "++info-in" sxref) (list)))) @@ -52,19 +116,29 @@ ;(make-collection "phc" rkt-files (argv)) ;(make-collection "phc" '("graph/all-fields.rkt") #("zo")) -;(require/typed compiler/cm [managed-compile-zo (->* (Path-String) ((→ Any Input-Port Syntax) #:security-guard Security-Guard) Void)]) +;(require/typed compiler/cm [managed-compile-zo +; (->* (Path-String) +; ((→ Any Input-Port Syntax) +; #:security-guard Security-Guard) +; Void)]) ;(managed-compile-zo (build-path (current-directory) "graph/all-fields.rkt")) -;; make-collection doesn't handle dependencies due to (require), so if a.rkt requires b.rkt, and b.rkt is changed, a.rkt won't be rebuilt. -;; this re-compiles each-time, even when nothing was changed. +;; make-collection doesn't handle dependencies due to (require), so if a.rkt +;; requires b.rkt, and b.rkt is changed, a.rkt won't be rebuilt. +;; Yhis re-compiles each-time, even when nothing was changed. ;((compile-zos #f) rkt-files 'auto) -;; This does not work, because it tries to create the directory /usr/local/racket-6.2.900.6/collects/syntax/parse/private/compiled/drracket/ -;(require/typed compiler/cm [managed-compile-zo (->* (Path-String) ((→ Any Input-Port Syntax) #:security-guard Security-Guard) Void)]) +;; This does not work, because it tries to create the following directory: +;; /usr/local/racket-6.2.900.6/collects/syntax/parse/private/compiled/drracket/ +;(require/typed compiler/cm [managed-compile-zo +; (->* (Path-String) +; ((→ Any Input-Port Syntax) +; #:security-guard Security-Guard) +; Void)]) ;(for ([rkt rkt-files]) ; (managed-compile-zo (build-path (current-directory) rkt))) -(run! `(,(or (find-executable-path "raco") (error "Can't find executable 'raco'")) +(run! `(,(find-executable-path-or-fail "raco") "make" ,@rkt-files)) @@ -85,10 +159,21 @@ (for/rules ([mathjax-link mathjax-links]) (mathjax-link) () - (make-file-or-directory-link (simplify-path (apply build-path `(same ,@(map (λ (x) 'up) (explode-path (dirname mathjax-link))) "lib" "doc" "MathJax")) #f) - mathjax-link))) + (let ([mathjax-dir + (simplify-path + (apply build-path + `(same + ,@(map (λ (x) 'up) + (explode-path (dirname mathjax-link))) + "lib" "doc" "MathJax")) + #f)]) + (make-file-or-directory-link mathjax-dir mathjax-link)))) (argv)) -(run! `(,(or (find-executable-path "raco") (error "Can't find executable 'raco'")) +(run! `(,(find-executable-path-or-fail "raco") "cover" ,@(exclude-dirs rkt-files (list "make/")))) + +(run! `(,(find-executable-path-or-fail "raco") + "test" + ,@(exclude-dirs rkt-files (list "make/"))))