#lang scheme

(require planet/util)

(require dynext/compile)
(require dynext/link)
(require dynext/file)

(require scheme/foreign)
(unsafe!)

(define (newer? source dest)
  (call/cc 
   (λ (return)
     (> (file-or-directory-modify-seconds source #f (λ () (display (format "source no ~s" source)) (sleep 200) (return #f)))
        (file-or-directory-modify-seconds dest #f (λ () (return #t)))))))

(define (compile-and-link name)
  ; compile and link a source file. If you want a literal file pass a path
  ; a string will be resolved as if you added the file in your
  ; primary-file list. Returns a path to the library created.
  (let ([base 
           (if (and (this-package-version-name) (string? name))
               (append-c-suffix
                (extract-base-filename/ss
                 (resolve-planet-path 
                  `(planet ,name (,(this-package-version-owner) 
                                  ,(this-package-version-name) 
                                  ,(this-package-version-maj)
                                  ,(this-package-version-min))))))
               name)])
    (let ([source base]
          [temp (append-object-suffix base)]
          [dest (append-extension-suffix base)])
;      (display (format "Compiling ~s ~s~n" source dest))
      (when (newer? source dest)
        (compile-extension
         #t
         source
         temp
         null)
        (link-extension
         #t
         (list temp)
         dest)
        (delete-file temp))
      dest)))

(define (c-require-p symbols types lib)
  (let loop ([symbols symbols] [types types] [result null])
    (if (null? symbols) (apply values (reverse result))
        (loop (cdr symbols) 
              (cdr types)
              (cons (get-ffi-obj (car symbols) lib (car types)) result)))))

(define-syntax c-require
  (syntax-rules ()
    [(_ (names ...) (c-names ...) (types ...) source-name)
     (define-values (names ...) (c-require-p '(c-names ...) (list types ...) (ffi-lib (compile-and-link source-name))))]
    [(_ (names ...) (types ...) source-name) (c-require names ... names ... types ... source-name)]))

(define (thunk? p)
  (and (procedure? p) (procedure-arity-includes? p 0)))


(define (min-args p)
  (let ([arity (procedure-arity p)])
    (if (arity-at-least? arity) (arity-at-least-value arity)
        arity)))

(define (make-thunk p make-args)
  (λ () (apply p (build-list (min-args p) make-args))))

(define (expand-thunks . rest)
  (let loop ([rest rest] [result null])
    (if (null? rest) result
        (loop
         (cdr rest)
         (append
          result
          (let ([what (car rest)])
            (cond
              [(thunk? what) (loop (list (what)) null)]
              [(procedure? what) (loop (list (make-thunk what (λ (i) (format "thing~a" i)))) null)]
              [(list? what) (loop what null)]
              [else (list what)])))))))

(define (de-path l)
  (apply values (map (λ (i) 
                       (cond
                         [(path? i) (path->string i)]
                         [(false? i) "#f"]
                         [(boolean? i) "#t"]
                         [else i])) l)))

(define (get-abi)
  ((compose
    string-append
    de-path
    flatten
    list)
     (expand-thunks
      (current-extension-compiler)
      (current-extension-compiler-flags)
      (current-make-compile-include-strings)
      (current-make-compile-input-strings)
      (current-make-compile-output-strings)
      (current-extension-preprocess-flags))
     (expand-thunks
      (current-extension-linker) 
      (current-extension-linker-flags)
      (current-make-link-input-strings)
      (current-make-link-output-strings)
      (current-standard-link-libraries)
      (current-use-mzdyn))))

; (c-require [nice-name other-nice-name] ["uglyname" "other_uglyName"] [(_fun -> _int) (_fun _char -> _string) ...] "sourcefile.c")
; (nice-name) (other-nice-name #\a) ...
        
(require (prefix-in c (only-in scheme/contract ->)))

(provide/contract
 [compile-and-link (path-string? . c-> . path?)]
 [get-abi (c-> string?)])
(provide c-require)