move not-passing tests
svn: r9707 original commit: b7d6c442b68e896bdd10cf711bafc4c9b2934241
This commit is contained in:
Sam Tobin-Hochstadt
parent
46da2ae802
commit
5f3571f3d1
58
collects/tests/typed-scheme/xfail/foldo.scm
Normal file
58
collects/tests/typed-scheme/xfail/foldo.scm
Normal file
|
|
@ -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
|
||||
))
|
||||
)
|
||||
539
collects/tests/typed-scheme/xfail/metrics.ss
Normal file
539
collects/tests/typed-scheme/xfail/metrics.ss
Normal file
|
|
@ -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))
|
||||
|
||||
3
collects/tests/typed-scheme/xfail/patch.ss
Normal file
3
collects/tests/typed-scheme/xfail/patch.ss
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
(module patch scheme
|
||||
(define srfi48::format format)
|
||||
(provide srfi48::format))
|
||||
Loading…
Reference in New Issue
Block a user