;; find.scm -- directory walker with list of predicates

(define-module file.find
  (use srfi-1)    ;; list-library
  (use srfi-2)    ;; and-let*
  (use srfi-11)   ;; let-values
  (use srfi-13)   ;; string-library
  (use file.util) ;; file tests
  (use gauche.parameter)
  (export file-find))
(select-module file.find)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; general utilities

(define (every-pred pred-ls arg)
  (if (null? pred-ls)
    #t
    (and ((car pred-ls) arg)
         (every-pred (cdr pred-ls) arg))))

(define (any-pred pred-ls arg)
  (if (null? pred-ls)
    #f
    (or ((car pred-ls) arg)
        (any-pred (cdr pred-ls) arg))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Shell globbing functions (these are taken from gauche.reload, should
;; be refactored)

(define (glob->regexp pat)
  (with-input-from-string (if (string? pat) pat (symbol->string pat))
    (lambda ()
      (let ((in-brace? #f))
        (let loop ((c (read-char))
                   (ls '("^(?:.*/)?")))
          (if (eof-object? c)
            (string-concatenate-reverse (cons "$" ls))
            (case c
              ((#\\)
               (let ((c2 (read-char)))
                 (loop (read-char) (cons (string c2) ls))))
              ((#\*)
               (cond ((eq? #\* (peek-char))
                      (read-char)
                      (loop (read-char) (cons ".*" ls)))
                     (else
                      (loop (read-char) (cons "[^/]*?" ls)))))
              ((#\?) (loop (read-char) (cons "[^/]" ls)))
              ((#\[) (loop (read-char) (cons "[" ls)))
              ((#\]) (loop (read-char) (cons "]" ls)))
              ((#\{)
               (cond (in-brace?
                      (loop (read-char) (cons "\\{" ls)))
                     (else
                      (set! in-brace? #t)
                      (loop (read-char) (cons "(?:" ls)))))
              ((#\})
               (cond (in-brace?
                      (set! in-brace? #f)
                      (loop (read-char) (cons ")" ls)))
                     (else
                      (loop (read-char) (cons "\\}" ls)))))
              ((#\,)
               (if in-brace?
                 (loop (read-char) (cons "|" ls))
                 (loop (read-char) (cons "," ls))))
              ((#\|)
               (loop (read-char) (cons "\\" (cons (string c) ls))))
              (else (loop (read-char) (cons (string c) ls))))))))))

(define (glob-match pat string)
  (rxmatch (glob->regexp pat) string))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File testing and utility functions

;; types
(define (file-is-symlink? file)
  (eq? (file-type file :follow-link? #f) 'symlink))
(define (file-is-block? file)     (eq? (file-type file) 'block))
(define (file-is-character? file) (eq? (file-type file) 'character))
(define (file-is-socket? file)    (eq? (file-type file) 'socket))
(define (file-is-fifo? file)      (eq? (file-type file) 'fifo))

;; size
(define (file-size-test stest file size)
  (stest (file-size file) size))
(define file-size=?  (cut file-size-test =  <> <>))
(define file-size<?  (cut file-size-test <  <> <>))
(define file-size<=? (cut file-size-test <= <> <>))
(define file-size>?  (cut file-size-test >  <> <>))
(define file-size>=? (cut file-size-test >= <> <>))

(define (x->file-size x) (if (string? x) (file-size x) x))

;; user/group conversions
(define (file-is-owner? file uid) (= (file-uid file) uid))
(define (file-is-group? file gid) (= (file-gid file) gid))

(define (user-name->id x)  (if (string? x) (sys-user-name->uid x) x))
(define (group-name->id x) (if (string? x) (sys-group-name->gid x) x))

;; time conversions
(define (epoch->hours-ago x)
  (if (number? x) (- (sys-time) (* x 86400)) x))
(define (epoch->mins-ago x)
  (if (number? x) (- (sys-time) (* x 3600)) x))

;; the lookup table

(define *find-file-tests*
  (make-parameter
   ;; symbol    procedure           n-args arg-filters

   ;; basic file types
   `((f         ,file-is-regular?)
     (d         ,file-is-directory?)
     (l         ,file-is-symlink?)
     (r         ,file-is-readable?)
     (w         ,file-is-writable?)
     (x         ,file-is-executable?)
     (c         ,file-is-character?)
     (b         ,file-is-block?)
     (p         ,file-is-fifo?)
     (s         ,file-is-socket?)

     ;; miscellaneous file tests
     (empty     ,(cut file-size=? <> 0))
     (size      ,file-size=?          1    ,x->file-size)
     (size=     ,file-size=?          1    ,x->file-size)
     (size<     ,file-size<?          1    ,x->file-size)
     (size<=    ,file-size<=?         1    ,x->file-size)
     (size>     ,file-size>?          1    ,x->file-size)
     (size>=    ,file-size>=?         1    ,x->file-size)

     ;; miscellaneous tests
     (true      ,(lambda (f) #t))
     (false     ,(lambda (f) #f))

     ;; equality
     (eq?       ,file-eq?             1)
     (eqv?      ,file-eqv?            1)
     (equal?    ,file-equal?          1)

     ;; permissions
     (user      ,file-is-owner?       1    ,user-name->id)
     (group     ,file-is-group?       1    ,group-name->id)

     ;; modification time
     (mtime=    ,file-mtime=?         1    ,epoch->hours-ago)
     (mtime<    ,file-mtime<?         1    ,epoch->hours-ago)
     (mtime<=   ,file-mtime<=?        1    ,epoch->hours-ago)
     (mtime>    ,file-mtime>?         1    ,epoch->hours-ago)
     (mtime>=   ,file-mtime>=?        1    ,epoch->hours-ago)
     (mmin=     ,file-mtime=?         1    ,epoch->mins-ago)
     (mmin<     ,file-mtime<?         1    ,epoch->mins-ago)
     (mmin<=    ,file-mtime<=?        1    ,epoch->mins-ago)
     (mmin>     ,file-mtime>?         1    ,epoch->mins-ago)
     (mmin>=    ,file-mtime>=?        1    ,epoch->mins-ago)

     ;; access time
     (atime=    ,file-atime=?         1    ,epoch->hours-ago)
     (atime<    ,file-atime<?         1    ,epoch->hours-ago)
     (atime<=   ,file-atime<=?        1    ,epoch->hours-ago)
     (atime>    ,file-atime>?         1    ,epoch->hours-ago)
     (atime>=   ,file-atime>=?        1    ,epoch->hours-ago)
     (amin=     ,file-atime=?         1    ,epoch->mins-ago)
     (amin<     ,file-atime<?         1    ,epoch->mins-ago)
     (amin<=    ,file-atime<=?        1    ,epoch->mins-ago)
     (amin>     ,file-atime>?         1    ,epoch->mins-ago)
     (amin>=    ,file-atime>=?        1    ,epoch->mins-ago)

     ;; change time
     (ctime=    ,file-ctime=?         1    ,epoch->hours-ago)
     (ctime<    ,file-ctime<?         1    ,epoch->hours-ago)
     (ctime<=   ,file-ctime<=?        1    ,epoch->hours-ago)
     (ctime>    ,file-ctime>?         1    ,epoch->hours-ago)
     (ctime>=   ,file-ctime>=?        1    ,epoch->hours-ago)
     (cmin=     ,file-ctime=?         1    ,epoch->mins-ago)
     (cmin<     ,file-ctime<?         1    ,epoch->mins-ago)
     (cmin<=    ,file-ctime<=?        1    ,epoch->mins-ago)
     (cmin>     ,file-ctime>?         1    ,epoch->mins-ago)
     (cmin>=    ,file-ctime>=?        1    ,epoch->mins-ago)
     )))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Interface

(define (make-file-test pred-list . opt-collect)
  (if (null? pred-list)
    '()
    (letrec ((pred (car pred-list))
             (rest (cdr pred-list))
             (collect (if (pair? opt-collect) (car opt-collect) #f))
             (get-tail (cut make-file-test <> collect)))
      (cond ((procedure? pred)
             (cons pred (get-tail rest)))
            ((string? pred)
             (let ((rx (glob->regexp pred)))
               (cons (cut rxmatch rx <>) (get-tail rest))))
            ((regexp? pred)
             (cons (cut rxmatch pred <>) (get-tail rest)))
            ((eq? pred 'collect)
             (if collect
               (cons collect (get-tail rest))
               (error "no collector specified")))
            ((eq? pred 'not)
             ;; invert the next arg only
             (let* ((tail-preds (get-tail rest))
                    (first-pred (car tail-preds)))
               (cons (lambda (f) (not (first-pred f)))
                     (cdr tail-preds))))
            ((pair? pred)
             ;; handle boolean logic in lists
             (append
              (case (car pred)
                ((and)
                 (get-tail (cdr pred)))
                ((or)
                 (let ((or-preds (get-tail (cdr pred))))
                   (list (lambda (f) (any-pred or-preds f)))))
                (else
                 ;; be liberal and treat other lists as implicit and's
                 (get-tail pred)))
              (get-tail rest)))
            ((symbol? pred)
             ;; mnemonic symbol lookup
             (or (and-let* ((mnemonic (assq pred (*find-file-tests*)))
                            (proc (cadr mnemonic))
                            (args (cddr mnemonic)))
                   (if (and (pair? args) (> (car args) 0))
                     ;; this symbolic predicate takes arguments
                     (let-values (((pred-args rem-preds)
                                   (split-at! rest (car args))))
                       ;; modify fixed args
                       (let loop ((pa pred-args)
                                  (ls (cdr args)))
                         (when (pair? ls)
                           (set-car! pa ((car ls) (car pa)))
                           (loop (cdr pa) (cdr ls))))
                       (format #t "modified args: ~S (~S)\n" pred-args (sys-time))
                       ;; add a partial application of the given args,
                       ;; and recurse on the remaining predicates
                       (cons (cut apply proc <> pred-args)
                             (get-tail rem-preds)))
                     ;; simple symbolic predicate
                     (cons proc (get-tail rest))))
                 (error "unknown find mnemonic: " mnemonic)))
            (else
             (error "unknown find test: " pred) )))))

(define (directory-list-full dir)
  (with-error-handler
      (lambda (err) (warn "error reading dir ~S: ~S" dir err) '())
    (lambda ()
      (map (cut string-append dir "/" <>)
           (sort (cddr (sys-readdir dir)))))))

;; basic breadth-first file-find
(define (file-find location . args)
  (letrec ((loc (expand-path (if (string=? location "") "." location)))
           (res (list))
           (collect (lambda (f) (push! res f))))
    (let ((preds (make-file-test args collect)))
      (if (file-is-directory? loc)
        (let loop ((dir loc))
          (let ((subls (list)))
            (for-each
             (lambda (file)
               (every-pred preds file)
               (if (file-is-directory? file)
                 (push! subls file)))
             (directory-list-full dir))
            (for-each loop (reverse! subls))))
        (every-pred preds loc) ))
    (reverse! res)))

(provide "file/find")