#lang scheme/base
(require scheme/path
         scheme/match
         scheme/contract
         setup/main-collects
         planet/planet-archives
         "private/syntax-core.ss"
         "text.ss")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  SYNTAX OBJECTS
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  Source Locations
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (syntax-source-directory stx)
  ;; Adapted from this-expression-source-directory in mzlib/etc
  (let* ([source (syntax-source stx)])
    (and source (path? source)
         (let-values ([(base file dir?) (split-path source)])
           (and (path? base)
                (path->complete-path base
                                     (or (current-load-relative-directory)
                                         (current-directory))))))))

(define (syntax-source-file-name stx)
  ;; Adapted from this-expression-file-name in mzlib/etc
  (let* ([f (syntax-source stx)])
    (and f (path? f)
         (let-values ([(base file dir?) (split-path f)]) file))))

(define (syntax-source-planet-package stx)
  (let* ([dir (syntax-source-directory stx)])
    (and dir (this-package-version/proc dir))))

(define (syntax-source-planet-package-owner stx)
  (let* ([pkg (syntax-source-planet-package stx)])
    (and pkg (pd->owner pkg))))

(define (syntax-source-planet-package-name stx)
  (let* ([pkg (syntax-source-planet-package stx)])
    (and pkg (pd->name pkg))))

(define (syntax-source-planet-package-major stx)
  (let* ([pkg (syntax-source-planet-package stx)])
    (and pkg (pd->maj pkg))))

(define (syntax-source-planet-package-minor stx)
  (let* ([pkg (syntax-source-planet-package stx)])
    (and pkg (pd->min pkg))))

(define (syntax-source-planet-package-symbol stx [suffix #f])
  (match (syntax-source-planet-package stx)
    [(list owner name major minor)
     (string->symbol
      (format "~a/~a:~a:~a~a"
              owner
              (regexp-replace "\\.plt$" name "")
              major
              minor
              (if suffix (text->string "/" suffix) "")))]
    [#f #f]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; From planet/util:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (this-package-version/proc srcdir)
  (let* ([package-roots (get-all-planet-packages)]
         [thepkg (ormap (predicate->projection (contains-dir? srcdir))
                        package-roots)])
    (and thepkg (archive-retval->simple-retval thepkg))))

;; predicate->projection : #f \not\in X ==> (X -> boolean) -> (X -> X)
(define (predicate->projection pred) (λ (x) (if (pred x) x #f)))

;; contains-dir? : path -> pkg -> boolean
(define ((contains-dir? srcdir) alleged-superdir-pkg)
  (let* ([nsrcdir (normalize-path srcdir)]
         [nsuperdir (normalize-path (car alleged-superdir-pkg))]
         [nsrclist (explode-path nsrcdir)]
         [nsuperlist (explode-path nsuperdir)])
    (list-prefix? nsuperlist nsrclist)))

(define (list-prefix? sup sub)
  (let loop ([sub sub]
             [sup sup])
    (cond
      [(null? sup) #t]
      [(equal? (car sup) (car sub))
       (loop (cdr sub) (cdr sup))]
      [else #f])))

(define (archive-retval->simple-retval p)
  (list-refs p '(1 2 4 5)))

(define-values (pd->owner pd->name pd->maj pd->min)
  (apply values (map (λ (n) (λ (l) (list-ref l n))) '(0 1 2 3))))

(define (list-refs p ns)
  (map (λ (n) (list-ref p n)) ns))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  EXPORTS
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define stx/f (or/c syntax? #f))

(define nat? exact-nonnegative-integer?)

;; flat-contract/predicate? no longer exists, resorting to any/c for now.
(provide/contract
 [syntax-datum/c (-> any/c flat-contract?)]
 [syntax-listof/c (-> any/c flat-contract?)]
 [syntax-list/c
  (->* [] [] #:rest (listof any/c) flat-contract?)]
 [syntax-map (-> (-> syntax? any/c) (syntax-listof/c any/c) (listof any/c))]
 [to-syntax
  (->* [any/c]
       [#:stx stx/f #:src stx/f #:ctxt stx/f #:prop stx/f #:cert stx/f]
       syntax?)]
 [to-datum (-> any/c (not/c syntax?))]
 [syntax-source-file-name (-> syntax? (or/c path? #f))]
 [syntax-source-directory (-> syntax? (or/c path? #f))]
 [syntax-source-planet-package
  (-> syntax? (or/c (list/c string? string? nat? nat?) #f))]
 [syntax-source-planet-package-owner (-> syntax? (or/c string? #f))]
 [syntax-source-planet-package-name (-> syntax? (or/c string? #f))]
 [syntax-source-planet-package-major (-> syntax? (or/c nat? #f))]
 [syntax-source-planet-package-minor (-> syntax? (or/c nat? #f))]
 [syntax-source-planet-package-symbol
  (->* [syntax?] [(or/c text? #f)] (or/c symbol? #f))]
 [current-syntax (parameter/c (or/c syntax? false/c))]
 [syntax-error (->* [syntax? string?] [] #:rest list? none/c)])

(provide with-syntax*)