diff --git a/src/std/build-spec.ss b/src/std/build-spec.ss index 4e841fedbc..3a0e5f245b 100644 --- a/src/std/build-spec.ss +++ b/src/std/build-spec.ss @@ -30,6 +30,7 @@ "test" "stxparam" "stxutil" + "source" "lazy" "amb" (gxc: "interface" ,@(include-gambit-sharp)) diff --git a/src/std/misc/path.ss b/src/std/misc/path.ss index 90b9c092d6..cce8d1bf22 100644 --- a/src/std/misc/path.ss +++ b/src/std/misc/path.ss @@ -1,13 +1,128 @@ -(export - path-default-extension - path-force-extension) +;; Manipulate strings that denoting POSIX-style paths, independently from any underlying filesystem. +;; TODO: support Windows? +;; TODO: something inspired by UIOP:TRUENAMIZE, etc. + +(export #t) + +(import + :std/srfi/1 + :std/srfi/13 + :std/sugar) + +;; : String (OrFalse String) -> String (def (path-default-extension path ext) (if (and ext (string-empty? (path-extension path))) (string-append path ext) path)) +;; : String (OrFalse String) -> String (def (path-force-extension path ext) (if ext (string-append (path-strip-extension path) ext) path)) + +;; : String (OrFalse String) -> String +(def (path-extension-is? path extension) + (equal? (path-extension path) extension)) + +;; : String String ... -> String +(def (subpath top . sub-components) + (path-expand (string-join sub-components "/") top)) + +;; If `maybe-subpath` is a pathname that is under `base-path`, return a pathname object that +;; when used with `path-expand` with defaults `base-path`, yields `maybe-subpath`. +;; Otherwise, return #f. +;; : (OrFalse String) (OrFalse String) -> (OrFalse String) +(def (subpath? maybe-subpath base-path) + (and (string? maybe-subpath) (string? base-path) + (eq? (path-absolute? maybe-subpath) (path-absolute? base-path)) + (let ((ls (string-length maybe-subpath)) + (lb (string-length base-path)) + (sep? (lambda (s pos) (eqv? (string-ref s pos) #\/)))) + (cond + ((< ls lb) #f) ;; NB: this in particular concludes that /foo is not subpath of /foo/ ? + ((> ls lb) (and (or (sep? base-path (- lb 1)) (sep? maybe-subpath lb)) + (string-prefix? base-path maybe-subpath) + (let ((pos (string-index maybe-subpath (lambda (x) (not (eqv? x #\/))) lb))) + (if pos (substring maybe-subpath pos ls) "")))) + (else (and (equal? base-path maybe-subpath) "")))))) + +;; : String -> Bool +(def (path-absolute? path) + (string-prefix? "/" path)) + +;; : Any -> Bool +(def (absolute-path? path) + (and (string? path) (path-absolute? path))) + +;; Return the absolute path associated to a designator. +;; Throw an error if the designator is invalid or does not designate an absolute path. +;; A string designates itself. A thunk designates its result. #f designates the current-directory. +;; : (Or String False (-> String)) -> String +(def (get-absolute-path path-designator) + (cond + ((absolute-path? path-designator) path-designator) + ((string? path-designator) (error "Path not absolute" path-designator)) + ((not path-designator) (get-absolute-path (current-directory))) + ((procedure? path-designator) (get-absolute-path (path-designator))) + (else (error "Invalid path designator" path-designator)))) + +;; : String (Or String False (-> String)) -> String +(def (ensure-absolute-path path (base #f)) + (if (path-absolute? path) path + (path-expand path (get-absolute-path base)))) + +;; Normalize will fail if the file doesn't exist, or +;; if some funky business happens with symlink or magic mounts. +;; So we gracefully fall back to non-normalized path when that's the case. +;; : String -> String +(def (path-maybe-normalize path) + (with-catch (lambda (_) (path-simplify path)) (cut path-normalize path))) + +;; If `sub` is a pathname that is under `base`, return a pathname string that +;; when used with `path-expand` with defaults `base`, returns `sub`. +;; Compare CL:ENOUGH-NAMESTRING, UIOP:ENOUGH-PATHNAME. +;; : String <- String String +(def (path-enough sub base) + (or (and base (subpath? sub base)) sub)) + +;; : String -> String +(def (path-simplify-directory path) + (path-simplify (path-directory path))) + +;; : String -> String +(def (path-normalized-directory path) + (path-maybe-normalize (path-directory path))) + +;; : String -> String +(def (path-parent path) + (path-maybe-normalize (path-expand ".." path))) + +;; Given a path to a file that may or may exists on the current filesystem, +;; return a simplified path, eliminating redundant uses of "." or "/", +;; and, unless keep..? is true, also remove ".." +;; (assuming no weird symlinks or mounts that makes you want not to simplify foo/..) +;; NB: Always simplify away a trailing / except for the root directory /. +;; : String keep..?:Bool -> String +(def (path-simplify path keep..?: (keep..? #f)) + (def l (string-split path #\/)) + (def abs? (and (pair? l) (equal? (car l) ""))) + (set! l (remove (cut member <> '("" ".")) l)) + (unless keep..? + (let loop ((head (reverse l)) (tail '())) + (cond + ((and (pair? head) (pair? tail) (equal? (car tail) "..") (not (equal? (car head) ".."))) + (loop (cdr head) (cdr tail))) + ((pair? head) + (loop (cdr head) (cons (car head) tail))) + (else (set! l tail)))) + (when abs? + (while (and (pair? l) (equal? (car l) "..")) + (set! l (cdr l))))) + (if (null? l) + (if abs? "/" "") ;; "" is the standard "here" path, though we could have picked ".". + (begin + (when abs? + (set! l (cons "" l))) + (string-join l "/")))) diff --git a/src/std/source.ss b/src/std/source.ss index c76a647ade..10ad40fe4a 100644 --- a/src/std/source.ss +++ b/src/std/source.ss @@ -1,32 +1,32 @@ (export #t) -(import (for-syntax ./stxutil) - ./sugar) - -(begin-for-syntax +(import (for-syntax :std/stxutil + :std/misc/path + :std/misc/ports) + :std/stxutil + :std/sugar) ;;; Locations follow the Gambit convention: it's a vector of two values. ;;; The first value is either a string which is filename, or a list containing a symbol. ;;; The second value is a fixnum, either non-negative (+ (* 65536 column) line), ;;; or if the previous formula had overflows, negative file position. -(def (stx-source-file stx) - (let (loc (stx-source stx)) (and loc (vector-ref loc 0)))) -(def (stx-source-position stx) - (let (loc (stx-source stx)) (and loc (vector-ref loc 1)))) +(defsyntax-call (this-source-location ctx) + (stx-source ctx)) + +(defsyntax-call (this-source-file ctx) + (stx-source-file ctx)) -(def (stx-source-directory stx) - (let (file (stx-source-file stx)) (and file (path-directory file)))) +(defsyntax-call (this-source-position ctx) + (stx-source-position ctx)) -(def (stx-source-path stx . relpath) - (let (dir (stx-source-directory stx)) (and dir (apply subpath dir relpath)))) +(defsyntax-call (this-source-directory ctx) + (stx-source-directory ctx)) -(def (stx-source-content stx . relpath) - (let (path (apply stx-source-path stx relpath)) (and path (read-file-u8vector path))))) +(defsyntax-call (this-source-path ctx relpath) + (alet (dir (stx-source-directory ctx)) (apply subpath dir relpath))) -(defsyntax-call (this-source-location x) (stx-source x)) -(defsyntax-call (this-source-file x) (stx-source-file x)) -(defsyntax-call (this-source-position x) (stx-source-position x)) -(defsyntax-call (this-source-directory x) (stx-source-directory x)) -(defsyntax-call (this-source-path x relpath) (stx-source-path x relpath)) -(defsyntax-call (this-source-content x relpath) (stx-source-content x relpath)) +(defsyntax-call (this-source-content ctx relpath) + (alet (dir (stx-source-directory ctx)) + (alet (path (apply subpath dir ctx relpath)) + (read-file-u8vector path)))) diff --git a/src/std/stxutil.ss b/src/std/stxutil.ss index 9a7e7657d5..5b840846a5 100644 --- a/src/std/stxutil.ss +++ b/src/std/stxutil.ss @@ -67,3 +67,12 @@ (apply (lambda (ctx formals ...) body) (stx-car (stx-cdr stx)) (syntax->datum (stx-cdr (stx-cdr stx)))))) ((ctx formals ...) #'(ctx ctx formals ...)))))) + +(def (stx-source-file stx) + (alet (loc (stx-source stx)) (vector-ref loc 0))) + +(def (stx-source-position stx) + (alet (loc (stx-source stx)) (vector-ref loc 1))) + +(def (stx-source-directory stx) + (alet (file (stx-source-file stx)) (path-directory file)))