Changeset 35364 in project


Ignore:
Timestamp:
03/31/18 06:15:24 (4 months ago)
Author:
kon
Message:

use csi+csc test runner, add types, broke it

Location:
release/4/directory-utils/trunk
Files:
1 added
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/directory-utils/trunk/directory-utils.meta

    r27650 r35364  
    1212        (list-utils "1.0.0")
    1313        (stack "2.1.1")
    14         (check-errors "1.11.0"))
     14        (check-errors "1.11.0")
     15        (stack "2.1.1")
     16        (typed-define "2.2.2"))
    1517 (test-depends test)
    16  (files "directory-utils.meta" "directory-utils.scm" "directory-utils.setup" "tests/run.scm" "directory-utils.release-info") )
     18 (files
     19  "directory-utils.meta" "directory-utils.setup" "directory-utils.release-info"
     20  "directory-utils.scm"
     21  "tests/run.scm" "tests/directory-utils-test.scm") )
  • release/4/directory-utils/trunk/directory-utils.scm

    r34127 r35364  
    1111  pathname? check-pathname error-pathname
    1212  filename? check-filename error-filename
     13  check-directory error-directory
     14  ;
    1315  dot-pathname? dot-filename?
    14   #;directory? check-directory error-directory
     16  ;
    1517  directory-fold
     18  ;
     19  directory-utility-stack
    1620  push-directory
    1721  pop-directory
    1822  pop-toplevel-directory
     23  ;
    1924  create-pathname-directory
    2025  make-program-filename
    2126  make-shell-filename
    22   file-exists/directory?
     27  file-exists-in-directory?
    2328  find-file-pathnames
    2429  find-program-pathnames
     
    2631  which-command-pathname
    2732  remove-dotfiles
    28   ; DEPRECATED
    29   create-directory/parents)
    30 
    31 (import scheme)
    32 
    33 (import
    34   chicken
     33  ;DEPRECATED
     34  create-directory/parents
     35  file-exists/directory?)
     36
     37(import scheme chicken)
     38(use
    3539  (only data-structures
    3640    string-split)
     
    4044    decompose-pathname decompose-directory)
    4145  (only posix
    42     directory directory? current-directory create-directory
    43     file-exists?)
     46    directory directory? current-directory create-directory)
    4447  (only srfi-1
    4548    first fold append! filter-map remove any)
    4649  (only srfi-13
    47     string-null? string-prefix?) )
    48 (require-library
    49   data-structures srfi-1 srfi-13 files posix)
    50 
    51 (import
     50    string-null? string-prefix?)
    5251  (only miscmacros
    53     until)
     52    define-parameter until)
    5453  (only list-utils
    5554    not-null? ensure-list)
    5655  (only stack
    57     make-stack stack-push! stack-empty? stack-pop!)
     56    make-stack stack?
     57    stack-empty?
     58    stack-push! stack-pop!)
    5859  (only type-checks
    5960    define-check+error-type
    60     check-procedure))
    61 (require-library
    62   miscmacros list-utils stack type-checks)
     61    check-procedure)
     62  typed-define)
    6363
    6464;;; Helpers
     65
     66;;
     67
     68(define-type stack (struct stack))
     69
     70(define-type filename string)
     71(define-type extension string)
     72(define-type basename string)
     73(define-type pathname string)
     74
     75;;
     76
     77(define (->boolean obj)
     78  (and obj #t) )
    6579
    6680(cond-expand
     
    7084(define +dot-directory+ (make-pathname "." #f))
    7185
    72 (define (dot-filename-prefix? str)
     86;;
     87
     88;no . or .. since directoryname
     89(define: (dot-filename-prefix? (str filename)) -> boolean
    7390  (and
    7491    (string-prefix? "." str)
     92    ;FIXME unix-centric
    7593    (not (or (string=? "." str) (string=? ".." str)))) )
    7694
    77 (define (pathname-maybe? obj)
    78   (string? obj) )
    79 
    8095;;;
    8196
     
    88103; detecting only an extension is impossible with string pathnames
    89104
     105(: pathname? (* -> boolean : pathname))
     106;
    90107(define (pathname? obj)
    91108  (and
    92     (pathname-maybe? obj)
    93     (let-values (((dir fil ext) (decompose-pathname obj)))
    94       (or dir fil))) )
     109    (string? obj)
     110    (receive (dir fil ext) (decompose-pathname obj)
     111      (->boolean (or dir fil)))) )
    95112
    96113(define-check+error-type pathname)
     
    98115;; Just a filename, no directory
    99116
     117(: filename? (* -> boolean : filename))
     118;
    100119(define (filename? obj)
    101120  (and
    102     (pathname-maybe? obj)
    103     (let-values (((dir fil ext) (decompose-pathname obj)))
    104       (and (not dir) fil))) )
     121    (string? obj)
     122    (receive (dir fil ext) (decompose-pathname obj)
     123      (not dir))) )
    105124
    106125(define-check+error-type filename)
     
    108127;;
    109128
     129(: dot-filename? (* -> boolean : filename))
     130;
    110131(define (dot-filename? obj)
    111132  (and
     
    115136;; Any pathname component is a dot-filename?
    116137
     138(: dot-pathname? (* -> boolean : pathname))
     139;
    117140(define (dot-pathname? obj)
    118141  (and
    119     (pathname-maybe? obj)
    120     (let-values (((dir fil ext) (decompose-pathname obj)))
     142    (string? obj)
     143    (let-values (
     144      ((dir fil ext) (decompose-pathname obj)) )
    121145      (or
    122146        (dot-filename-prefix? fil)
    123         (let-values (((org dir elts) (decompose-directory dir)))
     147        (let-values (
     148          ((org dir elts) (decompose-directory dir)) )
    124149          (and
    125150            elts
     
    128153;; Remove dot files from a directory list
    129154
    130 (define (remove-dotfiles files)
     155(define: (remove-dotfiles (files (list-of pathname))) -> (list-of pathname)
    131156        (remove
    132157          (lambda (pn)
     
    140165;attribute, the MacOS X birthtime, etc.
    141166
     167(: directory-fold (procedure * pathname #!rest -> *))
     168;
    142169(define (directory-fold func ident dir #!key (dotfiles? #f))
    143170  (fold
     
    148175;; Directory Stack
    149176
    150 ;FIXME should be "thread local storage" for the directory-stack.
    151 
    152 (define push-directory)
    153 (define pop-directory)
    154 (define pop-toplevel-directory)
    155 
    156 (let ((+directory-stack+ (make-stack)))
    157 
    158   (set! push-directory
    159     (lambda (dir)
    160       (stack-push! +directory-stack+ (current-directory))
    161       ; Don't cd unless necessary
    162       (when
    163           (and
    164             dir
    165             (not
    166               (or
    167                 (string-null? dir)
    168                 (string=? +dot-directory+ (make-pathname dir #f)))))
    169         (current-directory dir) ) ) )
    170 
    171   (set! pop-directory
    172     (lambda ()
    173       (unless (stack-empty? +directory-stack+)
    174         (current-directory (stack-pop! +directory-stack+)) ) ) )
    175 
    176   (set! pop-toplevel-directory
    177     (lambda ()
    178       (until (stack-empty? +directory-stack+)
    179         (pop-directory) ) ) ) )
    180 
    181 ;; Ensure the directory exists.
    182 
    183 #; ;Not Needed Anymore
    184 (define (create-directory/parents dir)
    185   (let loop ((dir dir))
    186     (when (and dir (not (directory? dir)))
    187       (loop (pathname-directory dir))
    188       (create-directory dir) ) ) )
    189 
    190 (define (create-directory/parents dir)
    191   (create-directory (check-pathname 'create-directory/parents dir) #t) )
     177(: directory-utility-stack (#!optional stack -> stack))
     178;
     179(define-parameter directory-utility-stack (make-stack)
     180  (lambda (x)
     181    (if (stack? x)
     182      x
     183      (begin
     184        (warning '+directory-stack+ "not a stack")
     185        (directory-utility-stack)))))
     186
     187(define: (ignored-directory? (dir pathname)) --> boolean
     188  (or
     189    (string-null? dir)
     190    (string=? +dot-directory+ (make-pathname dir #f))) )
     191
     192(define: (push-directory (dir (or boolean pathname)))
     193  (stack-push! (directory-utility-stack) (current-directory))
     194  ;don't cd unless necessary
     195  (when (and dir (not (ignored-directory? dir)))
     196    (current-directory dir) ) )
     197
     198(define: (pop-directory)
     199  (unless (stack-empty? (directory-utility-stack))
     200    (current-directory (stack-pop! (directory-utility-stack))) ) )
     201
     202(define: (pop-toplevel-directory)
     203  (until (stack-empty? (directory-utility-stack))
     204    (pop-directory) ) )
    192205
    193206;; Ensure the directory for the specified path exists.
    194207
    195 (define (create-pathname-directory pathname)
    196  (check-pathname 'create-pathname-directory pathname)
    197  (create-directory (pathname-directory pathname) #t) )
     208(define: (create-pathname-directory (pn pathname)) -> boolean
     209  (->boolean
     210    (create-directory
     211      (pathname-directory (check-pathname 'create-pathname-directory pn))
     212      #t)) )
    198213
    199214;; Platform specific program filename.
    200215
    201 (define (make-program-filename bn)
     216(define: (make-program-filename (bn basename)) -> filename
    202217  (cond-expand
    203218    (windows
     
    208223      bn ) ) )
    209224
    210 (define (make-shell-filename bn)
     225(define: (make-shell-filename (bn basename)) -> filename
    211226  (cond-expand
    212227    (windows
     
    221236;; Pathname if file exists in directory.
    222237
    223 (define (file-exists/directory? fil #!optional dir)
    224   (let ((path (make-pathname dir fil)))
    225     (and
    226       (file-exists? path)
    227       path ) ) )
     238(define: (file-exists-in-directory? (fil filename) . (opts (list pathname))) -> (or boolean pathname)
     239  (let* (
     240    (dir (optional opts #f))
     241    (path (make-pathname dir fil)) )
     242    (and (file-exists? path) path ) ) )
    228243
    229244;; List of all found pathnames.
    230245
    231 (define (find-file-pathnames/directory fil dir)
     246(define: (find-file-pathnames-in-directory (fil filename) (dir pathname)) -> (list-of pathname)
    232247  (filter-map
    233     (cut file-exists/directory? fil <>)
     248    (cut file-exists-in-directory? fil <>)
    234249    (ensure-list dir)) )
    235250
    236 (define (*find-file-pathnames fil dirs)
     251(define: (*find-file-pathnames (fil filename) (dirs (list-of pathname))) -> (or boolean (list-of pathname))
    237252  (let loop ((dirs dirs) (paths '()))
    238253    (if (null? dirs)
     
    242257        (append!
    243258          paths
    244           (find-file-pathnames/directory fil (car dirs)))) ) ) )
    245 
    246 (define (find-file-pathnames fil . dirs)
     259          (find-file-pathnames-in-directory fil (car dirs)))) ) ) )
     260
     261(define: (find-file-pathnames (fil filename) . (dirs (list-of pathname))) -> (or boolean (list-of pathname))
    247262  (*find-file-pathnames fil dirs) )
    248263
    249264;; All found program pathname in directories.
    250265
    251 (define (find-program-pathnames cmd . dirs)
     266(define: (find-program-pathnames (cmd filename) . (dirs (list pathname))) -> (or boolean list)
    252267  (cond-expand
    253268    (windows
    254       (if (pathname-extension cmd) (*find-file-pathnames cmd dirs)
    255         (let ((pfs (*find-file-pathnames (make-program-filename cmd) dirs))
    256               (sfs (*find-file-pathnames (make-shell-filename cmd) dirs)))
    257           (not-null? (append! (or pfs '()) (or sfs '()))) ) ) )
     269      (if (pathname-extension cmd)
     270        (*find-file-pathnames cmd dirs)
     271        (let (
     272          (founds
     273            (append!
     274              (or (*find-file-pathnames (make-program-filename cmd) dirs) '())
     275              (or (*find-file-pathnames (make-shell-filename cmd) dirs) '()))) )
     276          (not-null? founds) ) ) )
    258277    (else
    259278      (*find-file-pathnames (make-program-filename cmd) dirs) ) ) )
     
    261280;; All found program pathname in path.
    262281
    263 (define (which-command-pathnames cmd #!optional (varnam "PATH"))
    264   (and-let* ((path (get-environment-variable varnam)))
    265     (find-program-pathnames cmd (string-split path PATH-DELIMITER)) ) )
     282(define: (which-command-pathnames (cmd filename) . (opts (list string))) -> (or boolean list)
     283  (let (
     284    (varnam (optional opts "PATH")) )
     285    (and-let* (
     286      (path (get-environment-variable varnam)) )
     287      (find-program-pathnames cmd (string-split path PATH-DELIMITER)) ) ) )
    266288
    267289;; First found program pathname in path.
    268290
    269 (define (which-command-pathname cmd #!optional (varnam "PATH"))
    270   (and-let* ((ps (which-command-pathnames cmd varnam)))
    271     (first ps) ) )
     291(define: (which-command-pathname (cmd filename) . (opts (list string))) -> (or boolean list)
     292  (let (
     293    (varnam (optional opts "PATH")) )
     294    (and-let* (
     295      (ps (which-command-pathnames cmd varnam)) )
     296      (first ps) ) ) )
     297
     298;;
     299
     300;; Ensure the directory exists.
     301
     302(: create-directory/parents (deprecated create-directory))
     303(define (create-directory/parents dir)
     304  (create-directory (check-pathname 'create-directory/parents dir) #t) )
     305
     306#; ;Not Needed Anymore
     307(define (create-directory/parents dir)
     308  (let loop ((dir dir))
     309    (when (and dir (not (directory? dir)))
     310      (loop (pathname-directory dir))
     311      (create-directory dir) ) ) )
     312
     313(: file-exists/directory? (deprecated file-exists-in-directory?))
     314(define file-exists/directory? file-exists-in-directory?)
    272315
    273316) ;directory-utils
  • release/4/directory-utils/trunk/directory-utils.setup

    r34136 r35364  
    55(verify-extension-name "directory-utils")
    66
    7 (setup-shared-extension-module 'directory-utils (extension-version "1.0.6")
     7(setup-shared-extension-module 'directory-utils (extension-version "1.1.0")
     8  #:inline? #t
     9  #:types? #t
    810  #:compile-options '(
    911    -scrutinize
  • release/4/directory-utils/trunk/tests/run.scm

    r34134 r35364  
    1 (use test)
    21
    3 (use directory-utils)
     2(define EGG-NAME "directory-utils")
    43
    5 (test-assert (pathname? "abc/cbs.foo"))
    6 (test-assert (pathname? "abc/cbs"))
    7 (test-assert (pathname? ".abc"))
    8 (test-assert (not (pathname? "")))
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    95
    10 (test-assert (not (filename? "abc/cbs.foo")))
    11 (test-assert (filename? "cbs.foo"))
     6(use files)
    127
    13 (test-assert (not (dot-pathname? "abc/cbs.foo")))
    14 (test-assert (dot-pathname? "/abc/.hide/hidden"))
    15 (test-assert (not (dot-pathname? "/abc/cbs/./foo")))
    16 (test-assert (not (dot-pathname? "/abc/cbs/../foo")))
    17 (test-assert (dot-pathname? "/abc/cbs/../.foo"))
    18 (test-assert (dot-pathname? "/abc/cbs/../.foo/bar"))
     8;no -disable-interrupts
     9(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
    1910
    20 (test-assert (dot-filename? ".hide"))
    21 (test-assert (not (dot-filename? "/abc/.hide/hidden")))
    22 (test-assert (not (dot-filename? ".")))
    23 (test-assert (not (dot-filename? "..")))
     11(define *args* (argv))
    2412
    25 (test '("abc/cbs.foo") (remove-dotfiles '(".hide" "abc/cbs.foo")))
     13(define (test-name #!optional (eggnam EGG-NAME))
     14  (string-append eggnam "-test") )
    2615
    27 (test-assert (which-command-pathnames "mkdir"))
    28 (test-assert (not (which-command-pathnames "93274030#$%)#)$()")))
     16(define (egg-name #!optional (def EGG-NAME))
     17  (cond
     18    ((<= 4 (length *args*))
     19      (cadddr *args*) )
     20    (def
     21      def )
     22    (else
     23      (error 'test "cannot determine egg-name") ) ) )
    2924
    30 (test "directory-fold" 1 (directory-fold (lambda (fn ct) (fx+ ct 1) ) 0 "." #:dotfiles? #f))
     25;;;
    3126
    32 (test-assert (push-directory ".."))
     27(set! EGG-NAME (egg-name))
    3328
    34 (test-assert "directory-fold"
    35   (< 1 (directory-fold (lambda (fn ct) (fx+ ct 1) ) 0 "." #:dotfiles? #f)))
     29(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
     30  (let ((tstnam (test-name eggnam)))
     31    (print "*** csi ***")
     32    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     33    (newline)
     34    (print "*** csc (" cscopts ") ***")
     35    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
     36    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
    3637
    37 (test-assert (pop-toplevel-directory)) ;(pop-directory)
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
    3840
    39 (test-exit)
     41;;;
     42
     43(run-test)
Note: See TracChangeset for help on using the changeset viewer.