You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
pollen/lang/inner-lang-helper.rkt

124 lines
4.9 KiB
Racket

#lang racket/base
(require (for-syntax racket/base))
(provide (all-defined-out))
;; A place to stash functions that don't change between compiles of Pollen files.
;; duplicate of contents of project-require.rkt.
;; Goes faster if it's not in a separate module.
;; todo: use include? But this one has to be available as syntax
;; todo: get rid of magic value
(define-for-syntax (project-require-file? path)
(define path-string (path->string path))
(equal? (substring path-string (- (string-length path-string) 3) (string-length path-string)) "rkt"))
;; list of all eligible requires in project require directory
(define-for-syntax (get-project-require-files)
(define extras-directory (build-path (current-directory) "pollen-require"))
(and (directory-exists? extras-directory)
;; #:build? option returns complete paths (instead of just file names)
(let ([files (filter project-require-file? (directory-list extras-directory #:build? #t))])
(and (not (equal? '() files)) files))))
(define-for-syntax (put-file-in-require-form file)
`(file ,(path->string file)))
(define-for-syntax (do-project-require-file-syntax stx #:provide? [provide? #f])
(define project-require-files (get-project-require-files))
(if project-require-files
(let ([files-in-require-form (map put-file-in-require-form project-require-files)])
(datum->syntax stx `(begin
(require ,@files-in-require-form)
,@(if provide?
(list `(provide (all-from-out ,@files-in-require-form)))
'()))))
; if no files to import, do nothing
#'(begin)))
(define-syntax (require-and-provide-project-require-files stx)
(do-project-require-file-syntax stx #:provide? #t))
(define-syntax (require-project-require-files stx)
(do-project-require-file-syntax stx))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Copied out from racket/contract/private/base to avoid import
; Importing racket/contract/region is slow
; Used to be called current-contract-region
;
(require racket/stxparam syntax/location)
(define-syntax-parameter current-file-path
(λ (stx)
(if (eq? (syntax-local-context) 'expression)
(let* ([ctxt (syntax-local-lift-context)]
[id (hash-ref (make-hasheq) ctxt #f)])
(with-syntax ([id (or id
(let ([id (syntax-local-lift-expression
(syntax/loc stx (quote-module-name)))])
(hash-set! (make-hasheq) ctxt (syntax-local-introduce id))
id))])
#'id))
(quasisyntax/loc stx (#%expression #,stx)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Copied out from racket/path to avoid import
;
(define (pollen-find-relative-path directory filename #:more-than-root? [more-than-root? #f])
(define (do-explode-path who orig-path)
(define l (explode-path orig-path))
(for ([p (in-list l)])
(when (not (path-for-some-system? p))
(raise-argument-error who
"(and/c path-for-some-system? simple-form?)"
orig-path)))
l)
(let ([dir (do-explode-path 'find-relative-path directory)]
[file (do-explode-path 'find-relative-path filename)])
(if (and (equal? (car dir) (car file))
(or (not more-than-root?)
(not (eq? 'unix (path-convention-type directory)))
(null? (cdr dir))
(null? (cdr file))
(equal? (cadr dir) (cadr file))))
(let loop ([dir (cdr dir)]
[file (cdr file)])
(cond [(null? dir) (if (null? file) filename (apply build-path file))]
[(null? file) (apply build-path/convention-type
(path-convention-type filename)
(map (lambda (x) 'up) dir))]
[(equal? (car dir) (car file))
(loop (cdr dir) (cdr file))]
[else
(apply build-path (append (map (lambda (x) 'up) dir) file))]))
filename)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax (get-here-path stx)
#'(begin
(let* ([cfp (current-file-path)]
[here-path (cond
;; file isn't yet saved in drracket
;; 'pollen-lang-module name is applied by reader
[(or (equal? 'pollen-lang-module cfp)
(and (list? cfp) (equal? (car cfp) 'pollen-lang-module)))
"unsaved-file"]
;; if current-file-path is called from within submodule, you get a list
;; in which case, just grab the path from the front
[(list? cfp) (path->string (car cfp))]
[else (path->string cfp)])])
here-path)))