ybot_filesystem.xtm

(if *impc:compiler:with-cache* (sys:load "libs/aot-cache/ybot_filesystem.xtm" 'quiet))
(sys:load-preload-check 'ybot_filesystem)
(define *xtmlib-ybot_filesystem-loaded* #t)

(impc:aot:suppress-aot-do
 (sys:load "libs/external/apr.xtm")
 (sys:load "libs/contrib/ybot/ybot_base.xtm"))
(impc:aot:insert-forms
 (sys:load "libs/external/apr.xtm" 'quiet)
 (sys:load "libs/contrib/ybot/ybot_base.xtm" 'quiet))

(impc:aot:insert-header "xtmybot_filesystem")
(impc:aot:import-ll "xtmybot_filesystem")

(bind-val YFS_MAX_LINE_LENGTH i64 8096)

(cond
 ((string=? (sys:platform) "OSX") (bind-val fs i8 47))
 ((string=? (sys:platform) "Linux") (bind-val fs i8 47))
 ((string=? (sys:platform) "Windows") (bind-val fs i8 92)))

(cond
 ((string=? (sys:platform) "OSX") (bind-val return String* (String (let ((s:i8* (zalloc 2))) (pfill! s 10 0) s))))
 ((string=? (sys:platform) "Linux") (bind-val return String* (String (let ((s:i8* (zalloc 2))) (pfill! s 10 0) s))))
 ((string=? (sys:platform) "Windows") (bind-val return String* (String (let ((s:i8* (zalloc 3))) (pfill! s 13 10 0) s)))))

(bind-val slash String*
  (String (let ((s:i8* (zalloc 2))) (pfill! s fs 0) s)))
(bind-val comma String* (String ","))
(bind-val tab String* (String "\t"))

(bind-val little_endian bool #t)


;;;;;;;;;;;;;;;;;;;;; File name utilities ;;;;;;;;;;;;;;;;;;
(bind-func String2ByteList:[List{i8}*,String*]*
  (lambda (str)
    (let* ((n (length str))
           (cstr (cstring str))
           (loop
            (lambda (i output); ((i n) (output '()))
              (cond
               ((< i 0) output)
               (else (loop (- i 1) (cons (pref cstr i) output)))))))
      (loop (- n 1) '()))))


(bind-func ByteList2String:[String*,List{i8}*]*
  (lambda (lst)
    (let* ((n (length lst))
           (buf:i8* (zalloc (+ n 1)))
           (loop:[void,List{i8}*,i64]*
             (lambda (input i)
               (cond
                ((null? input) (pset! buf i 0) void)
                (else
                 (pset! buf  i (car input)) (loop (cdr input) (+ i 1)) void)))))
      (loop lst 0)
      (String buf))))


(bind-func String_flatten:[String*,List{String*}*]*
  (lambda (lst)
    (let ((mapper:[List{i8}*,String*]*
           (lambda (str) (String2ByteList str))))
      (ByteList2String (flatten (map mapper lst))))))


(bind-func yfs_join:[String*,String*,List{String*}*]*
  (lambda (delimiter:String* components:List{String*}*)
    (let ((n:i64 (length components)) (i:i64 0))
      (dotimes (i (- n 1))
        (insert components (+ (* i 2) 1) delimiter))
      (String_flatten components))))


(bind-func yfs_split:[List{String*}*,i8*]*
  (lambda (full_path)
    (let ((r:i8* (zalloc)))
      (pset! r 0 fs)
      (cdr (regex_split r (String full_path))))))
    
(bind-func yfs_name:[i8*,i8*]*
  (lambda (full_path)
    (let ((tokens (yfs_split full_path)))
      (if (= (length tokens) 0)
          full_path
          (cstring (car (last (yfs_split full_path))))))))
    
;; example 
;; ($ (cdr (reverse (cdr (yfs_split "/Users/s2805534/Documents/code/extempore/extempore-dev/extempore/libs/external/sndfile.xtm")))))

(bind-func yfs_base:[i8*,i8*]*
  (lambda (full_path)
    (cstring (yfs_join slash (reverse (cdr (reverse (yfs_split full_path))))))))

;($ (printf "%s" (yfs_base "/Users/s2805534/Documents/code/extempore/extempore-dev/extempore/libs/external/sndfile.xtm")))
;($ (print (yfs_split "/Users/s2805534/Documents/code/extempore/extempore-dev/extempore/libs/external/sndfile.xtm")))

(bind-func yfs_file_extension:[i8*,i8*]*
  (lambda (name_or_path)
    (let* ((name:i8* (yfs_name name_or_path))
           (r:i8* (zalloc 3)))
      (pset! r 0 (i64toi8 92))
      (pset! r 1 (i64toi8 46))
      (pset! r 2 (i64toi8 0))
      (let ((tokens (cdr (regex_split r (String name)))))
        (if (= (length tokens) 0)
            (cstring (String ""))
            (cstring (car (last (cdr (regex_split r (String name)))))))))))

(bind-val yfs_global_pool apr_pool_t* (convert 0))
;(bind-val yfs_global_pool apr_pool_t* (apr_pool_create))
(bind-func yfs_clear_global_pool:[void]*
  (lambda ()
    (apr_pool_destroy yfs_global_pool)
    (set! yfs_global_pool (apr_pool_create))
    void))
       
(bind-func yfs_init
  (lambda ()
    (apr_init)
    (set! yfs_global_pool (apr_pool_create))
    ))

;; (bind-func yfs_file_length:[i64,i8*]*
;;   (let ((pool:apr_pool_t* (apr_pool_create)))
;;     (zone_cleanup (apr_pool_destroy pool))
;;     (lambda (path)
;;       (let ((info:apr_finfo_t* (salloc)))
;;         (apr_stat info path APR_FINFO_SIZE pool)
;;         (apr_pool_destroy pool)
;;         (tref info 9)))))

(bind-func yfs_file_length:[i64,i8*]*
  (lambda (path)
    (let ((info:apr_finfo_t* (salloc)))
      (apr_stat info path APR_FINFO_CSIZE yfs_global_pool)
      (tref info 9))))


(bind-func yfs_is_directory:[bool,i8*]*
  (lambda (path)
    (let ((info:apr_finfo_t* (salloc)))
      (apr_stat info path APR_FINFO_TYPE yfs_global_pool)
      (= APR_DIR (tref info 3)))))


(bind-func yfs_is_regular_file:[bool,i8*]*
  (lambda (path)
    (let ((info:apr_finfo_t* (salloc)))
      (apr_stat info path APR_FINFO_TYPE yfs_global_pool)
      (= APR_REG (tref info 3)))))


;; (bind-func yfs_open:[apr_file_t*,i8*]*
;;   (let ((pool:apr_pool_t* (apr_pool_create)))
;;     (zone_cleanup (apr_pool_destroy pool))
;;     (lambda (path)
;;       (let ((handle_ref:apr_file_t** (zalloc)))
;;         (apr_file_open handle_ref path (+ APR_FOPEN_READ APR_FOPEN_WRITE) APR_FPROT_OS_DEFAULT pool)
;;         (pref handle_ref 0)))))


(bind-func yfs_open:[apr_file_t*,i8*]*
  (lambda (path)
    (let ((handle_ref:apr_file_t** (zalloc)))
        (apr_file_open handle_ref path (+ APR_FOPEN_READ APR_FOPEN_WRITE APR_FOPEN_CREATE) APR_FPROT_OS_DEFAULT yfs_global_pool)
        (pref handle_ref 0))))

(bind-func yfs_open_readonly:[apr_file_t*,i8*]*
  (lambda (path)
    (let ((handle_ref:apr_file_t** (zalloc)))
        (apr_file_open handle_ref path APR_FOPEN_READ APR_FPROT_OS_DEFAULT yfs_global_pool)
        (pref handle_ref 0))))

(bind-func yfs_close:[apr_status_t,apr_file_t*]*
  (lambda (handle)
    (apr_file_close handle)))


(bind-func yfs_current_playhead:[apr_off_t,apr_file_t*]*
  (let ((playhead_ref:apr_off_t* (zalloc)))
    (lambda (handle)
      (pset! playhead_ref 0 0)
      (apr_file_seek handle APR_CUR playhead_ref)
      (@ playhead_ref))))


(bind-func yfs_file_rewind:[apr_off_t,apr_file_t*]*
  (let ((playhead_ref:apr_off_t* (zalloc)))
    (lambda (handle)
      (pset! playhead_ref 0 0)
      (apr_file_seek handle APR_SET playhead_ref)
      (@ playhead_ref))))


(bind-func yfs_file_goto_end:[apr_off_t,apr_file_t*]*
  (let ((playhead_ref:apr_off_t* (zalloc)))
    (lambda (handle)
      (pset! playhead_ref 0 0)
      (apr_file_seek handle APR_END playhead_ref)
      (@ playhead_ref))))


(bind-func yfs_file_seek:[apr_off_t,apr_file_t*,apr_off_t]*
  (let ((playhead_ref:apr_off_t* (zalloc)))
    (lambda (handle index)
      (let*
          ((current (yfs_current_playhead handle))
           (forward:bool (>= index current))
           (style (if forward APR_CUR APR_SET))
           (offset (if forward (- index current) index)))
        (pset! playhead_ref 0 offset)
        (apr_file_seek handle style playhead_ref))
      (@ playhead_ref))))


(bind-func yfs_read_byte:[i8,apr_file_t*,bool*]*
  (let ((c:i8* (zalloc)))
    (lambda (handle pEOF)
      (pset! pEOF 0 (= (apr_file_getc c handle) APR_EOF))
      (@ c))))

(bind-func yfs_peek_byte:[i8,apr_file_t*]*
  (let ((playhead_ref:i64* (zalloc))
        (c:i8* (zalloc)))
    (lambda (handle)
      (apr_file_getc c handle)
      (pset! playhead_ref 0 -1)
      (apr_file_seek handle APR_CUR playhead_ref)
      (@ c))))

(bind-func yfs_read_line:[i8*,apr_file_t*,bool*]*
  (let ((buf:i8* (zalloc (+ YFS_MAX_LINE_LENGTH 1))))
    (lambda (handle pEOF)
      (let*
          ((finish
            (lambda (m:i64)
              (let ((output:i8* (zalloc m)))
                    (set! output (strcpy output buf))
                    output)))
           (loop
            (lambda (n:i64)
              (let ((c:i8 (yfs_read_byte handle pEOF)))
                (if (@ pEOF)
                    (finish n)
                    (begin
                      (cond
                       ((or (= c (i64toi8 10)) (= c (i64toi8 13)))
                        (pset! buf n 0)
                        (let ((d:i8 (yfs_peek_byte handle)))
                          (if (or (= d (i64toi8 10)) (= d (i64toi8 13)))
                              (yfs_read_byte handle pEOF)))
                        (finish n))
                     (else
                      (pset! buf n c)
                      (if (< n YFS_MAX_LINE_LENGTH)
                         (loop (+ n 1))
                         (begin
                           (pset! buf (+ n 1) 0)
                           (finish (+ n 1))))))))))))
        (loop 0)))))


(bind-func yfs_write_byte:[bool,apr_file_t*,i8]*
  (lambda (file value)
    (let ((psz:i64* (salloc))
          (data:i8* (salloc)))
      (pset! psz 0 1)
      (pset! data 0 value)
      (apr_file_write file data psz)
      (= 1 (@ psz)))))


(bind-func yfs_write_i32:[bool,apr_file_t*,i32]*
  (lambda (file value)
    (let ((psz:i64* (salloc))
          (bytes:i8* (salloc 4)))
          (let* ((byte1:i8 (i32toi8 (& value (i64toi32 255))))
                 (byte2:i8 (i32toi8 (& (>> value 8) (i64toi32 255))))
                 (byte3:i8 (i32toi8 (& (>> value 16) (i64toi32 255))))
                 (byte4:i8 (i32toi8 (& (>> value 24) (i64toi32 255)))))
            ;;(printf "%x %x %x %x\n" byte1 byte2 byte3 byte4)
            (pset! psz 0 4)
            (if little_endian
                (pfill! bytes byte1 byte2 byte3 byte4)
                (pfill! bytes byte4 byte3 byte2 byte1))
            (apr_file_write file bytes psz)
            (= 4 (@ psz))))))


(bind-func yfs_write_cstring:[bool,apr_file_t*,i8*]*
  (lambda (file cstr)
    (let ((sz:i64* (salloc))
          (n (strlen cstr)))
      (pset! sz 0 n)
      (apr_file_write file cstr sz)
      (= n (@ sz)))))


(bind-func yfs_write_string:[bool,apr_file_t*,String*]*
  (lambda (file str)
    (cond
     ((non-null str)
      (yfs_write_cstring file (cstring str)))
     (else #f))))


(bind-func yfs_file_count:[i64,i8*]*
  (lambda (path)
    (let* ((advertised_length:i64 (yfs_file_length path))
           (pEOF:bool* (zalloc))
           (handle:apr_file_t* (yfs_open path))
           (readloop:[i64,i64]*
            (lambda (cc)
              (if (not (@ pEOF))
                  (begin
                    (yfs_read_byte handle pEOF)
                    (if (= (modulo cc 1000000) 0)
                        (println (/ cc 1000000) " / " (/ advertised_length 1000000)))
                    (readloop (+ cc 1)))
                  (begin
                    (yfs_close handle)
                    (println cc)
                    cc)))))
      (readloop 0))))


(bind-func yfs_dir_open:[apr_dir_t*,i8*]*
  (lambda (path)
    (let ((handle_ref:apr_dir_t** (zalloc)))
        (apr_dir_open handle_ref path yfs_global_pool)
        (pref handle_ref 0))))


;; (bind-func yfs_read_pipe_named
;;   (lambda (name:i8*)
;;     (let ((pipe:apr_file_t* (yfs_open_readonly name))
;;           (pEOF:bool* (halloc)))
;;       (pset! pEOF 0 #f)
;;       (let ((loop:[bool]*
;;              (lambda ()
;;                (cond
;;                 ((pref pEOF 0)
;;                  (yfs_close pipe) #f)
;;                 (else
;;                  (let ((c:i8 (yfs_read_byte pipe pEOF)))
;;                    (printf "%c" c)
;;                    (loop)))))))
;;         (loop)))))


(bind-func yfs_read_pipe
  (lambda (pipe:apr_file_t* destination:i8*)
    (let ((pEOF:bool* (halloc)) (cc:i64 0))
      (pset! pEOF 0 #f)
      (let ((loop:[bool]*
             (lambda ()
               (cond
                ((pref pEOF 0) #f)
                (else
                 (let ((c:i8 (yfs_read_byte pipe pEOF)))
                   (pset! destination cc c)
                   (loop)))))))
        (loop)))))


(bind-val APR_ENOENT i32 2)

(bind-func yfs_process_recursive:[bool,i8*,[bool,i8*]*]*
  (lambda (path proc)
    (let ((pool:apr_pool_t* (apr_pool_create)))
        ;(printf "Path is %s\n" path)
      (cond
       ((yfs_is_regular_file path)
        ;(printf "Processing %s\n" path)
        (proc path)
        (apr_pool_destroy pool)
        #t)
       ((yfs_is_directory path)
        ;(printf "Descending into %s\n" path)
        (let* ((dir:apr_dir_t* (yfs_dir_open path))
               (loop:[bool]*
                (lambda ()
                  (let* ((info:apr_finfo_t* (salloc))
                         (status:apr_status_t (apr_dir_read info (+ APR_FINFO_TYPE APR_FINFO_NAME) dir))
                         (next_entry:i8* (tref info 14))
                         (pp:i8** (zalloc)))
                    (cond
                     ((= status APR_ENOENT)
                      ;(printf "\nDone with directory %s\n" path)
                      (apr_dir_close dir)
                      #f)
                     (else
                      (cond
                       ((= (pref next_entry 0) (i64toi8 46))
                        ;(printf "Ignoring hidden directory %s\n" next_entry)
                        (loop)
                        #t)
                       (else
                        (apr_filepath_merge pp path next_entry APR_FILEPATH_NATIVE pool)
                        (yfs_process_recursive (@ pp) proc)
                        (loop)
                        #t))))))))
            (loop)
            (apr_pool_destroy pool)
            #t))
         (else
          ;(printf "Ignoring irregular file %s\n" path)
          (apr_pool_destroy pool)
          #f)))))


(bind-func yfs_process_recursive:[bool,i8*,[bool,i8*,apr_file_t*]*,apr_file_t*]*
  (lambda (path proc logfile)
    (let ((pool:apr_pool_t* (apr_pool_create)))
      (cond
       ((yfs_is_regular_file path)
        ;(printf "Processing %s\n" path)
        (proc path logfile)
        (apr_pool_destroy pool)
        #t)
       ((yfs_is_directory path)
        ;(printf "Descending into %s\n" path)
        (let* ((dir:apr_dir_t* (yfs_dir_open path))
               (loop:[bool]*
                (lambda ()
                  (let* ((info:apr_finfo_t* (salloc))
                         (status:apr_status_t (apr_dir_read info (+ APR_FINFO_TYPE APR_FINFO_NAME) dir))
                         (next_entry:i8* (tref info 14))
                         (pp:i8** (zalloc)))
                    (cond
                     ((= status APR_ENOENT)
                      ;(printf "\nDone with directory %s\n" path)
                      (apr_dir_close dir)
                      #f)
                     (else
                      (cond
                       ((= (pref next_entry 0) (i64toi8 46))
                        ;(printf "Ignoring hidden directory %s\n" next_entry)
                        (loop)
                        #t)
                       (else
                        (apr_filepath_merge pp path next_entry APR_FILEPATH_NATIVE pool)
                        (yfs_process_recursive (@ pp) proc logfile)
                        (loop)
                        #t))))))))
            (loop)
            (apr_pool_destroy pool)
            #t))
         (else
          ;(printf "Ignoring irregular file %s\n" path)
          (apr_pool_destroy pool)
          #f)))))


(bind-func yfs_process_recursive:[bool,i8*,[bool,i8*,apr_file_t*,i8**]*,apr_file_t*,i8**]*
  (lambda (path proc logfile pData)
    (let ((pool:apr_pool_t* (apr_pool_create)))
      (cond
       ((yfs_is_regular_file path)
        (proc path logfile pData)
        (apr_pool_destroy pool) #t)
       ((yfs_is_directory path)
        (let* ((dir:apr_dir_t* (yfs_dir_open path))
               (loop:[bool]*
                (lambda ()
                  (let* ((info:apr_finfo_t* (salloc))
                         (status:apr_status_t (apr_dir_read info (+ APR_FINFO_TYPE APR_FINFO_NAME) dir))
                         (next_entry:i8* (tref info 14))
                         (pp:i8** (zalloc)))
                    (cond
                     ((= status APR_ENOENT)
                      (apr_dir_close dir) #f)
                     (else
                      (cond
                       ((= (pref next_entry 0) (i64toi8 46))
                        (loop) #t)
                       (else
                        (apr_filepath_merge pp path next_entry APR_FILEPATH_NATIVE pool)
                        (yfs_process_recursive (@ pp) proc logfile pData)
                        (loop) #t))))))))
            (loop) (apr_pool_destroy pool) #t))
         (else
          (apr_pool_destroy pool) #f)))))

                   
(impc:aot:insert-footer "xtmybot_filesystem")