From 5f3571f3d13be0982fb20d86768a76af8ddb5eb4 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 6 May 2008 22:54:20 +0000 Subject: [PATCH] move not-passing tests svn: r9707 original commit: b7d6c442b68e896bdd10cf711bafc4c9b2934241 --- collects/tests/typed-scheme/xfail/foldo.scm | 58 ++ collects/tests/typed-scheme/xfail/metrics.ss | 539 +++++++++++++++++++ collects/tests/typed-scheme/xfail/patch.ss | 3 + 3 files changed, 600 insertions(+) create mode 100644 collects/tests/typed-scheme/xfail/foldo.scm create mode 100644 collects/tests/typed-scheme/xfail/metrics.ss create mode 100644 collects/tests/typed-scheme/xfail/patch.ss diff --git a/collects/tests/typed-scheme/xfail/foldo.scm b/collects/tests/typed-scheme/xfail/foldo.scm new file mode 100644 index 00000000..c8de9df6 --- /dev/null +++ b/collects/tests/typed-scheme/xfail/foldo.scm @@ -0,0 +1,58 @@ +(module foldo mzscheme + (require (lib "file.ss")(lib "match.ss")) + (provide apply-to-scheme-files) + + (define-syntax (define-excluder stx) + + (define (path->clause c) + (syntax-case c () + [(item ...) + #`[`(#,@(reverse (syntax-e #'(item ...))) ,_ (... ...)) #t]] + [item + #`[`(item) #t]])) + + (syntax-case stx () + [(_ name path ...) + (with-syntax ([(match-clause ...) (map path->clause (syntax-e #'(path ...)))]) + #`(define (name p ) + (let* ([dirnames (map path->string (explode-path p))]) + (match (reverse dirnames) ; goofy backwards matching because ... matches greedily + match-clause ... + [_ #f]))))])) + + (define-excluder default-excluder + "compiled" ".svn" #;("collects" "drscheme") #;("collects" "framework")) + + (define exclude-directory? (make-parameter default-excluder)) + + ;; ---------------------------------------- + ;; apply-to-scheme-files: (path[file] -> X) path[directory] -> (listof X) + ;; applies the given function to each .ss or .scm file in the given directory + ;; hierarchy; returns all results in a list + (define (apply-to-scheme-files f root ) + ;;FOLD-FILES + + (fold-files + (lambda (path kind acc) + (case kind + [(file) + (let ([extension (filename-extension path)]) + (cond + [(not extension) acc ] + [(regexp-match #rx"(ss|scm)$" extension) + (let ([resl (f path)]) + (if resl + (cons resl acc) + acc ))] + [else acc ]))] + [(dir) + (let* ([p (normalize-path path root)]) + (if ((exclude-directory?) p) + (values acc #f) + acc ))] + [(link) acc ] + [else (error "never happen")])) + '() + root + )) + ) \ No newline at end of file diff --git a/collects/tests/typed-scheme/xfail/metrics.ss b/collects/tests/typed-scheme/xfail/metrics.ss new file mode 100644 index 00000000..078d8152 --- /dev/null +++ b/collects/tests/typed-scheme/xfail/metrics.ss @@ -0,0 +1,539 @@ +#lang typed-scheme +(provide results run-all-tests) + +#;(require "../list.scm" + "../etc.ss") +(require/typed apply-to-scheme-files + ((Path -> (Listof (Listof (U #f (Listof (U Number #f)))))) + Path + -> (Listof (U #f (Listof (Listof ( U #f (Listof (U Number #f)))))))) "foldo.scm") + +(define-type-alias top Any) +(define-type-alias str String) + +(require/typed filename-extension (Path -> (U #f Bytes)) (lib "file.ss")) +(require/typed normalize-path (Path Path -> Path) (lib "file.ss")) +(require/typed explode-path (Path -> (Listof Path)) (lib "file.ss")) +(require/typed srfi48::format ( Port String String top .. -> top) "patch.ss") +;; FIXME - prefix +#;(require/typed srfi48:format ( Port String String top .. -> top) (prefix srfi48: (lib "48.ss" "srfi"))) +(require (lib "match.ss") + ;(lib "file.ss") + ;(lib "list.ss") + ;(lib "etc.ss") + (prefix-in srfi13: (lib "13.ss" "srfi")) + ;(prefix srfi48: (lib "48.ss" "srfi")) + ) + +(define-type-alias Sexpr Any) +(define-type-alias number Number) +(define-type-alias boolean Boolean) +(define-type-alias NumF (U number #f)) +(define-type-alias NumB (U boolean number)) +;;C is either Sexpr or Listof Sepr +;;X = (Listof (U number #f)) - not needed as a parameter +(define-type-alias (Unit X C) ((C -> X) -> (Path -> (Listof (U #f X))))) + +;; ============================================================ +;; CONFIG +(define: COLLECTS-PATH : (Parameter Path Path ) (make-parameter (build-path "/proj/scheme/plt/collects" #;"~/svn/plt/collects/"))) +(define: PLANET-CODE-PATH : (Parameter Path Path) (make-parameter (build-path "~/Desktop/most-recent-archives/" #;"~/local/src/planet/most-recent-archives/"))) + +; collects-path : a path to the collects directory to compare +; planet-code-path : a path to the "other" code to compare (i.e. unpacked, most recent versions +; of all planet packages) + +;; ============================================================ +;; STATS + +;; t-test : (listof number) (listof number) -> number +;; computes t value for the given sequences. t-tests measure +;; the extent to which difference in mean between two sets of +;; _interval-valued_ samples (e.g. distances, times, weights, counts ...) +;; can be explained by chance. Generally speaking, higher absolute +;; values of t correspond to higher confidence that an observed difference +;; in mean cannot be explained by chance. +(define: (t-test [seqA : (Listof number)] [seqB : (Listof number)]) : number + (manual-t-test + (avg seqA) (avg seqB) + (variance seqA) (variance seqB) + (length seqA) (length seqB))) + +(define: (manual-t-test [avga : number] [avgb : number] [vara : number] + [varb : number] [cta : number] [ctb : number]) : number + (/ (- avga avgb) + (sqrt (+ (/ vara cta) (/ varb ctb))))) + +;; chi-square : (listof [0,1]) (listof [0,1]) -> number +;; chi-square is a simple measure of the extent to which the +;; difference in the frequency of 0's and 1's in the first +;; sequence and their frequency in the second sequence can +;; be explained by chance. higher numbers means higher confidence +;; that they cannot. +(define: (chi-square [seqA : (Listof number)] [seqB : (Listof number)]) : number + (with-handlers ([exn:fail? (lambda: ([e : str]) +nan.0)]) + (let* ([ct-a (length seqA)] + [ct-b (length seqB)] + [total-subjects (+ ct-a ct-b)] + [a-hits (apply + seqA)] + [b-hits (apply + seqB)] ;; these assume that the data is coded as 1 = present, 0 = not present + [a-misses (- ct-a a-hits)] + [b-misses (- ct-b b-hits)] + [table + `((,a-hits ,b-hits) + (,a-misses ,b-misses))] + [expected (lambda: ([i : Integer] [j : Integer]) + (/ (* (row-total i table) (col-total j table)) total-subjects))]) + (exact->inexact + (table-sum + (lambda: ([i : Integer] [j : Integer]) + (/ (sqr (- (expected i j) (table-ref i j table))) (expected i j))) + table))))) + +;; ============================================================ +;; UNITS OF MEASUREMENT IMPLEMENTATIONS + +;; per-module : path ((listof expr) -> (number | #f)) -> (path -> (listof (number | #f))) === Unit P +(pdefine: (X) (per-module [f : ((Listof Sexpr) -> X )]) : (Path -> (cons (U #f X) '())) + (lambda: ([path : Path]) + (with-handlers ([exn:fail:read? (lambda: ([e : Void]) (list #f))]) ;; with handler + (let ([initial-sexp (with-input-from-file path read)]) + (match initial-sexp + [`(module ,_ ,_ . , (? list? bodies)) ;; FIXME - use ... instead of . + (list (f bodies))] + [_ (list #f)]))))) + + +;; per-module-top-level-expression : path (expr -> (number | #f)) -> (path -> (listof (number | #f))) +(define: (per-module-top-level-expression [f : (Sexpr -> (Listof NumF))] ) : ( Path -> (Listof (U #f (Listof NumF)))) + (let ([calc (per-module (lambda: ([exprs : (Listof Sexpr)]) (map f exprs)))]) + (lambda: ([p : Path]) (let* ([r (calc p)] + [carr (car r)]) ;;carr added + (if carr carr + (list carr)))))) ;; list carr instead of r + +;; ============================================================ +;; BASIC CALCULATIONS +;; (for use with metric definitions below) + +;; ---------------------------------------- +;; depth + +(define: (sexp-depth [sexp : Any]) : number + (cond + [(list? sexp) ;; (pair? sexp) + (+ (max-sexp-depth sexp) 1)] + [else 0])) + +(define: (max-sexp-depth [losx : (Listof Any)]) : number + (improper-foldr (lambda: ([t : Any] [r : number]) (max (sexp-depth t) r)) 0 losx)) + +(define: (avg-sexp-depth [sexps : (Listof Any)]) : number + (cond + [(null? sexps) 0] + [else (avg (map sexp-depth sexps))])) + +;; ---------------------------------------- +;; setbang counts + +(define-type-alias (IList e) (mu x (Un e '() (cons e x)))) + +;; count-setbangs/ilist : ((ilistof expr) -> number) +(define: (count-setbangs/ilist [exprs : (Listof Any)]) : number + (apply + (imap count-setbangs/expr exprs))) + +;; FIXME - changes having to do with match ... +(define: (count-setbangs/expr [expr : Any]) : number + (match expr + [`(,(? setbang?) . ,rest ) ;(,(? setbang?) ,rest ...) + (if (list? rest) + (+ 1 (count-setbangs/ilist rest)) + 0)] ;; mostly occurs in syntax patterns + [('quote _) 0] + [('quasiquote _) 0] ; undercount potentially, but how many `,(set! ...)'s can there be? + [`(,e1 . ,e2) + (if (list? expr) + (count-setbangs/ilist expr) + (error " l" expr ))] ;;FIXME - do something intelligent here + [_ 0])) + +;; setbang? : sexp -> boolean +(define: (setbang? [v : Any]) : Any + (and (symbol? v) + (regexp-match #rx"^set(-.*)?!" (symbol->string v)))) + +;; count-fns +(define: (count-fns-with-setbangs [exprs : (Listof Sexpr)]) : number + (apply + (map (lambda: ([e : Sexpr]) (if (= (count-setbangs/expr e) 0) 0 1)) exprs))) +(define: (module-has-setbangs? [exprs : (Listof Sexpr)]) : Boolean + (ormap expr-uses-setbangs? exprs)) +(define: (expr-uses-setbangs? [expr : Sexpr]) : Boolean + (not (= (count-setbangs/expr expr) 0))) + +(define: (setbangs-per-1000-atoms [exprs : (Listof Any)]) : NumF + (if (null? exprs) + #f + (let ([set!s (count-setbangs/ilist exprs)] + [atoms (atoms exprs)]) + (* (/ set!s atoms) 1000.0)))) + +;; ---------------------------------------- +;; contracts + + +(define: (uses-contracts [exprs : (Listof Sexpr)]) : Boolean + (ormap (lambda: ([e : Sexpr]) + (match e + [`(provide/contract . ,_) #t] + [_ #f])) + exprs)) + +(define: (contracted-provides [exprs : (Listof Sexpr)]): number + (foldl + (lambda: ([t : Sexpr] [r : number]) + (match t + ;; FIXME match ... + [`(provide/contract . ,p ) ;(provide/contract ,p ...) + (if (list? p) + (+ (length p) r) + r)] ;; extra case added + [_ r])) + 0 + exprs)) + +;; FIXME - same problem with match ... +(define: (uncontracted-provides [exprs : (Listof Sexpr)]) : number + (foldl + (lambda: ([t : Sexpr] [r : number]) + (match t + [`(provide . ,p ) ;(provide ,p ...) + (if (list? p) + (+ (length p) r) + r)] + [_ r])) + 0 + exprs)) + +;; ---------------------------------------- +;; macros + +(define: (number-of-macro-definitions [expr : Sexpr]) : number + (match expr + [`(define-syntax ,_ ...) 1] + [`(define-syntaxes (,s . ,r ). ,_ ) ;`(define-syntaxes (,s ...) ,_ ...) + (if (and (list? expr)(list? r)) + (length (cons s r));;s -> cadr expr + (error "corrupted file"))] + [`(define-syntax-set (,s . ,r) . ,_ ) ;(define-syntax-set (,s ...) ,_ ...) + (if (and (list? expr) (list? r)) + (length (cons s r)) + (error "corrupted file"))] + [_ 0])) + +(define: (num-of-define-syntax [exprs : (Listof Sexpr)]) : number + (foldl (lambda: ([t : Sexpr] [r : number]) (+ (number-of-macro-definitions t) r)) 0 exprs)) + +;; ---------------------------------------- +;; expression size + +(define: (atoms [sexp : Any]) : number + (cond + [(null? sexp) 0] + [(not (pair? sexp)) 1] + [else (+ (atoms (car sexp)) (atoms (cdr sexp)))])) + +(define: (max-atoms [exprs : (Listof Sexpr)]) : NumF + (let ([atom-counts (map atoms exprs)]) + (if (null? atom-counts) + #f + (apply max 0 atom-counts)))) ;; FIXME: expected at least 2 argument---> 0 added !!! + +(define: (avg-atoms [exprs : (Listof Sexpr)]) : NumF + (let ([atom-counts (map atoms exprs)]) + (if (null? atom-counts) + #f + (avg (map atoms exprs))))) + +(define: (total-atoms [exprs : (Listof Sexpr)]) : number + (apply + (map atoms exprs))) + + +;; ============================================================ +;; METRIC DEFINITIONS +;; 'a 'b metric : (string * (listof sexp -> 'a option) * ((listof 'a) (listof 'a) -> 'b) +(define-typed-struct (b c d) metric ([analysis-unit : (Unit (Listof NumF) c)] + [computation : (c -> d)] + [>display : ((Listof d) (Listof d) -> b)])) +(define-type-alias Metric metric) +(define-type-alias Table (Listof (Listof Number))) +(define-type-alias Atom-display (cons Symbol (Listof Number))) + +(define: (standard-display [name : Symbol] + [summarize : ((Listof number) -> number)] + [significance-test : ((Listof number)(Listof number) -> number)]) + : ((Listof NumF) (Listof NumF) -> Atom-display) + ;; FIXME - use lambda instead of (define (( + (lambda: ([seqA : (Listof NumF)] [seqB : (Listof NumF)]) + (let ([clean-seqA (nonfalses seqA)] + [clean-seqB (nonfalses seqB)]) + (list name (summarize clean-seqA) (summarize clean-seqB) (significance-test clean-seqA clean-seqB))))) + +(pdefine: (c) (interval [u : (Unit (Listof NumF) c)] + [name : Symbol] + [compute : (c -> NumF)]) + : (Metric Atom-display c NumF) + (make-metric u compute (standard-display name avg t-test))) + +(pdefine: (c) (count [u : (Unit (Listof NumF) c)] + [name : Symbol] + [compute : (c -> Boolean)]) + : (Metric Atom-display c NumF) + (make-metric u (lambda: ([es : c]) #{(if (compute es) 1 0) :: NumF}) (standard-display name avg chi-square))) + +(pdefine: (c) (combine-metrics [ms : (Listof (Metric Atom-display c NumF))]) + : (Metric (Listof Atom-display) c (Listof NumF)) + (let ([u (metric-analysis-unit (car ms))]) + ;; This test now redundant b/c of typechecking + (unless (andmap (lambda: ([m : (Metric Atom-display c NumF) ]) (eq? u (metric-analysis-unit m))) ms) + (error 'combine-metrics "all combined metrics must operate on the same unit of analysis")) + + (make-metric + u + (lambda: ([exprs : c] ) (map (lambda: ([m : (Metric Atom-display c NumF)]) ((metric-computation m) exprs)) ms)) + (lambda: ([seqA : (Listof (Listof NumF))] [seqB : (Listof (Listof NumF))]) + (map (lambda: ([m : (Metric Atom-display c NumF)] + [sA : (Listof NumF)] + [sB : (Listof NumF)]) + ((metric->display m) sA sB)) ms (pivot seqA) (pivot seqB)))))) + +;; FIXME - should go in helper file +;; FIXME - (filter (lambda (x) x) l) +(pdefine: (X) (nonfalses [l : (Listof (U #f X))]) : (Listof X) + (let: loop : (Listof X) ([lst :(Listof (U #f X)) l]) + (if (null? lst) + '() + (let ([x (car lst)]) + (if x + (cons x (loop (cdr lst))) + (loop (cdr lst))))))) + +(define: (avg [l : (Listof number)]) : number + (/ (exact->inexact (apply + l)) (length l))) +(define: (avg* [l : (Listof number)]) : number + (avg (nonfalses l))) + +(define-syntax define-metrics + (syntax-rules () + [(define-metrics all-metrics-id unit-of-analysis type (name kind fn) ...) ;;TYPE ADDED !!!! + (begin + (define: u : ((type -> (Listof NumF)) -> (Path -> (Listof (U #f(Listof NumF))))) unit-of-analysis ) + (define: name : (Metric Atom-display type NumF) (kind u 'name fn )) ... + (define: all-metrics-id : (Metric (Listof Atom-display) type (Listof NumF)) (combine-metrics (list name ...))))])) + +(define-metrics module-metrics #{ per-module @ (Listof NumF)} (Listof Sexpr) + (maximum-sexp-depth interval max-sexp-depth) + (average-sexp-depth interval avg-sexp-depth) + (number-of-setbangs/mod interval count-setbangs/ilist) + (number-of-exprs interval #{length @ (Listof Sexpr)}) + (uses-setbang?/mod count module-has-setbangs?) + (uses-contracts? count uses-contracts) + (number-of-contracts interval contracted-provides) + (num-uncontracted-provides interval uncontracted-provides) + (number-of-macro-defs interval num-of-define-syntax) + (maximum-num-atoms interval max-atoms) + (average-num-atoms interval avg-atoms) + (total-num-atoms/mod interval total-atoms) + (set!s-per-1000-atoms interval setbangs-per-1000-atoms)) + +(define-metrics tl-expr-metrics per-module-top-level-expression Sexpr + (uses-setbang?/fn count expr-uses-setbangs?) + (number-of-setbangs/fn interval count-setbangs/expr) + (total-num-atoms/fn interval atoms)) + +(define: all-metrics : (cons (Metric (Listof Atom-display) (Listof Sexpr) (Listof NumF)) + (cons (Metric (Listof Atom-display) Sexpr (Listof NumF)) + '() )) + (list module-metrics tl-expr-metrics)) + +;; ============================================================ +;; EXPERIMENT RUNNING + +;; FIXME - everything in untyped file (foldo.ss) b/c fold-files has terrible api +#;(define-syntax (define-excluder stx) + + (define (path->clause c) + (syntax-case c () + [(item ...) + #`[`(#,@(reverse (syntax-e #'(item ...))) ,_ (... ...)) #t]] + [item + #`[`(item) #t]])) + + (syntax-case stx () + [(_ name path ...) + (with-syntax ([(match-clause ...) (map path->clause (syntax-e #'(path ...)))]) + #`(define: (name [p : Path]) : top + (let* ([dirnames (map path->string (explode-path p))]) + (match (reverse dirnames) ; goofy backwards matching because ... matches greedily + match-clause ... + [_ #f]))))])) + +#;(define-excluder default-excluder + "compiled" ".svn" #;("collects" "drscheme") #;("collects" "framework")) + +#;(define: exclude-directory? : (Parameter (Path -> Any)) (make-parameter default-excluder)) + +;; ---------------------------------------- +;; apply-to-scheme-files: (path[file] -> X) path[directory] -> (listof X) +;; applies the given function to each .ss or .scm file in the given directory +;; hierarchy; returns all results in a list +#;(define: (apply-to-scheme-files [f : (Path -> (Listof(Listof(Listof NumF))))] + [root : Path]) + : (Listof (Listof(Listof(Listof NumF)))) ;;FOLD-FILES + + (fold-files + (lambda: ([path : Path] [kind : Symbol] + [acc : (Listof (Listof(Listof(Listof NumF))))]) + (case kind + [(file) + (let ([extension (filename-extension path)]) + (cond + [(not extension) #;acc (values acc #t)] + [(regexp-match #rx"(ss|scm)$" extension) + (let ([resl (f path)]) + (if resl + #;(cons resl acc) (values (cons resl acc) #t) ;;values added + #;acc (values acc #t)))] + [else #;acc (values acc #t)]))] + [(dir) + (let* ([p (normalize-path path root)]) + (if ((exclude-directory?) p) + #; acc (values acc #f) + #;acc (values acc #t)))] ;; values added + [(link) #;acc (values acc #t)] + [else (error "never happen")])) ;;error added + '() + root + #t)) ;;value added + +(define-typed-struct (a b c) result ([metric : (Metric b c a)] [seqA : (Listof a)] [seqB : (Listof a)])) +(define-type-alias Result result) + +;; get-sequences : (listof 'a metric) path -> (listof (listof 'a)) + +(pdefine: (b c C) (get-sequences [metrics : (Listof (U(Metric b c (Listof NumF))(Metric b C (Listof NumF))))] + [path : Path]) + : (Listof (Listof (Listof NumF))) + (let* ([metric-fns ; : (Listof (Path -> (Listof (U #f(Listof NumF))))) + (map (lambda: ([m : (Metric b c (Listof NumF))]) + ((metric-analysis-unit m) + (metric-computation m))) metrics)] + [result-seqs ; : (Listof (U #f (Listof (Listof ( U #f (Listof NumF)))))) + (apply-to-scheme-files + (lambda: ([file : Path]) + (map (lambda: ([fn : (Path -> (Listof (U #f (Listof NumF))))]) (fn file)) metric-fns)) path)]) + (map (lambda: ([l : (Listof(Listof (Listof NumF)))]) + ;; FIXME - problem with inference and ordering + (#{nonfalses @ (Listof NumF)} (apply append l))) + (pivot (#{nonfalses @ (Listof(Listof (U #f (Listof NumF))))} result-seqs))))) + +;; compare : (listof metric) -> (listof result) +(pdefine: ( b c C) (compare* [metrics : (Listof (U (Metric b c (Listof NumF)) (Metric b C (Listof NumF))))]) : (Listof (U (Result (Listof NumF) b C)(Result (Listof NumF) b c))) + (let* ([seqAs (get-sequences metrics (COLLECTS-PATH))] + [seqBs (get-sequences metrics (PLANET-CODE-PATH))]) + (map #{make-result @ (Listof NumF) b c} metrics seqAs seqBs))) + +(pdefine: (a b c) (show [result : (Result a b c)]) : b + ((metric->display (result-metric result)) + (result-seqA result ) + (result-seqB result ))) + +(define: (pretty-print-result [result : (Result (Listof NumF) (Listof Atom-display) Any)]) : Void + (for-each + (lambda: ([l : (Listof top)]) + (apply srfi48::format ;;sfri48:format + (current-output-port) + "~26F | ~8,2F | ~6,2F | ~12,2F\n" + (format "~a" (car l)) + (cdr l))) + #{(list* '("test name" "collects" "planet" "significance") ;;list instead of list* + '("---------" "--------" "------" "------------") + (show result )) :: List})) + +;; applies only to the combined metric [or more generally to listof-answer results] +(pdefine: (a b c) (total [experiment-number : Integer] [result : (Result (Listof number) b c)]) : (Listof number) + (define: (total/s [s : Table]) : number (apply + (list-ref (pivot s) experiment-number))) + (list (total/s (result-seqA result)) (total/s (result-seqB result)))) + +;; ============================================================ +;; UTILITY + +(pdefine: (X Y) (imap [f : (X -> Y)] [il : (Listof X)]) : (Listof Y) + (cond + [(null? il) '()] + [(not (pair? il)) (list (f il))] + [else (cons (f (car il)) (imap f (cdr il)))])) + +(pdefine: (X) (pivot [l : (Listof (Listof X))]): (Listof (Listof X)) + (cond + [(null? l) '()] + [else + (let ([n (length (car l))]) + (build-list n (lambda: ([i : Integer]) (map (lambda: ([j : (Listof X)]) (list-ref j i)) l))))])) + +(define: (sqr [x : number]) : number (* x x)) +(define: (variance [xs : (Listof number)]): number + (let ([avg (/ (apply + xs) (length xs))]) + (/ (apply + (map (lambda: ([x : number]) (sqr (- x avg))) xs)) + (sub1 (length xs))))) + +(define: (table-ref [i : Integer] [j : Integer] [table : Table]): number + (list-ref (list-ref table i) j)) +(define: (row-total [i : Integer] [table : Table]) : number + (apply + (list-ref table i))) +(define: (col-total [j : Integer] [table : Table]) : number + (apply + (map (lambda: ([x : (Listof number)]) (list-ref x j)) table))) +(define: (table-sum [f : (Integer Integer -> number)] [table : Table]) : number + (let ([rows (length table)] + [cols (length (car table))]) + (let: loop : number ([i : Integer 0] [j : Integer 0] [sum : number 0]) + (cond + [(>= j cols) sum] + [(>= i rows) (loop 0 (add1 j) sum)] + [else (loop (add1 i) j (+ sum (f i j)))])))) + +(pdefine: (Y) (improper-foldr [f : (Any Y -> Y)] [b : Y] [l : Any]) : Y + (cond + [(null? l) b] + [(not (pair? l)) + (f l b)] + [else + (f (car l) (improper-foldr f b (cdr l)))])) + +;; unused (and untypeable) +#;(define: (/* . [args : (Listof number)]) : number ;;((number)) against (number) and USELESS + (apply map (lambda: ([ns : number]) (apply / ns)) args)) + + +;; ============================================================ +;; MAIN ENTRY POINT + +(define: results : + Any + ;; FIXME bug in typed scheme when this type is used + #; + (Listof (U (Result (Listof NumF) (Listof Atom-display) (Listof Sexpr)) + (Result (Listof NumF) (Listof Atom-display) Sexpr))) + '()) +; just in case i want to do some more analysis on the results afterwards, +; so i don't have to waste a minute if i forget to bind the return value to something +(define: (run-all-tests) : top + (let: ([rs : (Listof (U (Result (Listof NumF) (Listof Atom-display) (Listof Sexpr)) + (Result (Listof NumF) (Listof Atom-display) Sexpr))) + (compare* + #{all-metrics :: + (Listof (U (Metric (Listof Atom-display) (Listof Sexpr) (Listof NumF)) + (Metric (Listof Atom-display) Sexpr (Listof NumF))))})]) + (set! results rs) + (for-each pretty-print-result rs) + rs)) + diff --git a/collects/tests/typed-scheme/xfail/patch.ss b/collects/tests/typed-scheme/xfail/patch.ss new file mode 100644 index 00000000..c4d18dc0 --- /dev/null +++ b/collects/tests/typed-scheme/xfail/patch.ss @@ -0,0 +1,3 @@ +(module patch scheme + (define srfi48::format format) + (provide srfi48::format)) \ No newline at end of file