;;; $Id: sutil.scm,v 1.3 2007/04/30 10:16:19 hoesterholt Exp $

(module sutil mzscheme
  (require (lib "pregexp.ss" "mzlib"))
  (require (lib "file.ss" "mzlib"))
  (require (lib "list.ss" "mzlib"))
  (require (lib "time.ss" "srfi" "19"))
  (provide glob
           basename
           basedir
           home
           mkdir-p
           
           meta-apply
           
           post++
           ++
           
           while
           llet
           
           date<?
           date>?
           date=?
           date<=?
           date>=?
           
           leap-year?
           valid-date?
           
           substr
           
           (all-from (lib "list.ss" "mzlib"))
           )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Documentation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;=pod

;=syn scm,8

;=wikiwikiwiki

;=Name

;=SUtils - Various Utility Functions

;=Synopsis

;
;  Welcome to MzScheme version 300, Copyright (c) 2004-2005 PLT Scheme Inc.
;  > (require (planet "sutil.scm" ("oesterholt"  "ho-utils.plt"  1 0)))
;
;  > (glob "d:/build/sutil/*.scm")
;  ("d:/build/sutil/scfg.scm" "d:/build/sutil/sprefs.scm" "d:/build/sutil/sutil.scm" "d:/build/sutil/units.scm")
;  > (glob "d:/build/sutil/*.pod")
;  ("d:/build/sutil/index.pod" "d:/build/sutil/index.pod~")
;  > (glob "d:/build/sutil/*.pod$")
;  ("d:/build/sutil/index.pod")
;
;  > (basename "d:/build/sutil/index.pod")
;  "index.pod"
;  > (basedir (build-path "d:/build/sutil/index.pod"))
;  "d:/build/sutil/"
; 
;
;  > (home)
;  "C:\\Documents and Settings\\hdijkema\\."
; 
;  > (home "local" "test")
;  "C:\\Documents and Settings\\hdijkema\\local\\test"
; 
;  > (mkdir-p (home "local" "test"))
;  <executes make-directory* if directory doesn't exist already>
;
;  > (define a 10)
;  > (post++ a)
;  10
;  > a
;  11
;  > (++ a)
;  12
;  a
;  12
;
;  >(let ((i 0)) (while (< i 10) (display i)(++ i)) (newline))
; 0123456789
;
; >(llet (( (a b c) (list 1 2 3) ))
;    (display (format "~a, ~a, ~a~%" a b c)))
; 1 2 3
; >
;
;  >(require (lib "time.ss" "srfi" "19"))
;  >(define a (current-date));
;  >(sleep 3)(define b (current-date));
;  >(date<? a b)
;  #t
;  >(date>? a b)
;  #f
;  ;; And we've also got 'date<=?', 'date>=?' and 'date=?'
;
;=wikiwikiwiki
;
;=head1 API
;
;=head2 srfi:date functions
;
;=head3 C<(dateE<lt>? dt1:srfi:date dt2:srfi:date) : boolean>
;
;returns #t, if dt1E<lt>dt2; #f otherwise.
;
;=head3 C<(dateE<gt>=? dt1:srfi:date dt2:srfi:date) : boolean>
;
;returns #t, if dt1E<gt>=dt2; #f otherwise.
;
;=head3 C<(dateE<gt>? dt1:srfi:date dt2:srfi:date) : boolean>
;
;returns #t, if dt1E<gt>dt2; #f otherwise.
;
;=head3 C<(dateE<lt>=? dt1:srfi:date dt2:srfi:date) : boolean>
;
;returns #t, if dt1E<lt>=dt2; #f otherwise.
;
;=head3 C<(date=? dt1:srfi:date dt2:srfi:date) : boolean>
;
;returns #t, if dt1=dt2; #f otherwise.
;
;=head3 C<(leap-year? dt:srfi:date) : boolean>
;
;returns #t, if dt is a leap year; #f otherwise.
;
;=head3 C<(valid-date? year:number month:number day:number) : boolean>
;
;returns #t, year, month and day form a valid date.
;
;=head2 Directory browsing
;
;=head3 C<(glob file-pattern:path or string) : list of file:string>
;
;returns a list of files that match the given file pattern (empty list if nothing has been found).
;
;=head3 C<(basedir path:path or string) : directory part of path:string>
;
;returns the directory part of a given path.
;
;=head3 C<(basename path:path or string) : name of file:string>
;
;returns the name part of a given path, or "" if path is a directory.
;
;=head3 C<(mkdir-p path:path or string) : undefined>
;
;calls 'make-directory*' if path does not already exist.
;
;=head2 Incrementing
;
;=head3 C<(post++ x:number) : number (x)>
;
;Increments x, but returns it's original value.
;
;=head3 C<(++ x:number) : number>
;
;Increments x and returns the incremented value.
;
;=head2 Language constructs
;
;=head3 C<(while expression b1 ...)>
;
;Creates a while loop using expression as a continue rule. See also Synopsis.
;
;=head3 C<llet>
;
;"List let". With llet it is possible to assign a list returned
;by a function to individual variables (like perls construction: C<($a,$b,$c)=f(10);>)
;
;
;=head2 String utils
;
;=head3 C<(substr S:string from:integer . to:integer) : string>
;
;A perl like substr. If to isn't given, returns the part of S from 'from' until the end
;of S. Otherwise, does a (substring S from to). Prevents errors. Constrains the operation
;to what is possible with S.
;
;=wikiwikiwiki
;
;=Info
;
;(c) 2005 Hans !Oesterholt-Dijkema. Distributed undef LGPL.
;Contact: send email to hans in domain elemental-programming.org.
;Homepage: [http://www.elemental-programming.org].
;

;=wikiwikiwiki

;=cut
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Some Date predicates to extend srfi 19
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (date<? dt1 dt2)
    (time<? (date->time-utc dt1) (date->time-utc dt2)))
  
  (define (date>=? dt1 dt2)
    (not (date<? dt1 dt2)))
  
  (define (date>? dt1 dt2)
    (time>? (date->time-utc dt1) (date->time-utc dt2)))
  
  (define (date<=? dt1 dt2)
    (not (date>? dt1 dt2)))

  (define (date=? dt1 dt2)
    (time=? (date->time-utc dt1) (date->time-utc dt2)))
  
  (define (leap-year? dt)
    (let ((year (if (number? dt) dt (date-year dt))))
      (if (= (remainder year 4) 0)
          (if (= (remainder year 100) 0)
              (if (= (remainder year 1000) 0)
                  #t
                  #f)
              #t)
          #f)))
  
  (define (valid-date? year month day)
    (let ((days (vector 0 31 (if (leap-year? year) 29 28) 31 30 31 30 31 31 30 31  30 31)))
      (if (or (< month 1) (> month 12))
          #f
          (if (or (< day 1) (> day (vector-ref days month)))
              #f
              #t))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; glob on files using regular expressions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (do-normalize-path p)
  (let ((s (if (string? p)
               p
               (path->string p))))
    (let ((N (string-length s)))
      (do ((i 0 (+ i 1)))
          ((>= i N) s)
          (if (char=? (string-ref s i) #\\)
              (string-set! s i #\/)))
      s)))

(define (replaces p L)
  (if (null? L)
      p
      (let ((from (caar L))
	    (to   (cadar L)))
	(replaces (pregexp-replace* from p to)
		  (cdr L)))))

(define (glob-files closure path)
  (for-each (lambda (p)
	      (let ((pp (build-path path p)))
		(if (directory-exists? pp)
		    (closure pp 'dir)
		    (closure pp 'file))))
	    (directory-list path)))

(define (glob pattern)
  (let* ((patt  (do-normalize-path (normalize-path pattern)))
	 (bd    (basedir patt))
	 (p     (replaces patt (list '("^[.]"    "[.]")
                                     '("([^[])[.]" "\\1[.]")
                                     '("[*]"     ".*")
                                     '("[?]"     "."))))
         (exp   (pregexp p))
         (found (list)))

    (glob-files (lambda (path type)
		  (if (eq? type 'file)
		      (let ((pp (do-normalize-path path)))
			(if (not (eq? (pregexp-match exp pp) #f))
			    (set! found (cons pp found))))))
		bd)
    (reverse found)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; basename/basedir on files using regular expressions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (basedir path)
  (if (directory-exists? path)
      (do-normalize-path path)
      (call-with-values
       (lambda () (split-path path))
       (lambda (base name is-dir)
         (if (eq? base 'relative)
             "."
             (if (eq? base #f)
                 "/"
                 (do-normalize-path base)))))))

(define (basename path)
  (if (directory-exists? path)
      ""
      (call-with-values
	  (lambda () (split-path path))
	(lambda (base name is-dir)
	  (if (eq? name 'up)
	      "."
	      (if (eq? name 'down)
		  ".."
		  (do-normalize-path name)))))))


(define (home . path)
  (let ((p (if (null? path)
	       (list 'same)
	       path)))
    (path->string 
     (apply build-path (list (find-system-path 'home-dir) (apply build-path p))))))

(define (mkdir-p path)
  (if (not (directory-exists? path))
      (make-directory* path)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; meta-apply applies for functions with optional arguments to functions
;;; with optional arguments
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (meta-apply f . args)
  (define (mklist args)
    (if (null? (cdr args))
	(if (list? (car args))
	    (car args)
	    args)
	(cons (car args) (mklist (cdr args)))))
  (apply f (mklist args)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Increment a variable while returning the original value
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax post++
  (syntax-rules ()
    ((_ n)
     (let ((r n))
       (set! n (+ n 1))
       r))))

(define-syntax ++
  (syntax-rules ()
    ((_ i)
     (begin
       (set! i (+ i 1))
       i))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Implement while
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax while
  (syntax-rules ()
    ((_ expression b1 ...)
     (do
	 ()
	 ((not expression)
	  #t)
       (begin b1 ...)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Implement list let
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax llet
  (syntax-rules ()
    ((_ (((a1 ...) L)) body1 ...)
     (let* ((%L L)
	    (a1 (let ((l (car %L)))
		  (set! %L (cdr %L))
		  l))
	    ...)
       body1
       ...))
    ((_ (((a1 ...) L) . L2) body1 ...)
     (let* ((%L L)
	    (a1 (let ((l (car %L)))
		  (set! %L (cdr %L))
		  l))
	    ...)
       (llet L2 body1 ...)))
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; substr (perl like)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (substr s from . _to)
  (let ((L (string-length s)))
    (let ((to (if (null? _to)
                  L
                  (if (>= (car _to) L)
                      L
                      (car _to)))))
      (if (< to from)
          (let ((H to))
            (set! to from)
            (set! from H)))
      (if (>= from L)
          ""
          (substring s from to)))))

)