mprodrigues/emacs.d
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Initial commit

Browse Source
This commit is contained in:
Mateus Pinto Rodrigues
2017-11-11 15:15:10 -02:00
commit 58c3bd6728
1202 changed files with 434097 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

315
elpa/geiser-20171010.1610/scheme/racket/geiser/autodoc.rkt Normal file
View File

@@ -0,0 +1,315 @@
;;; autodoc.rkt -- suport for autodoc echo
;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Jose Antonio Ortega Ruiz
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
;; Start date: Sun May 03, 2009 14:45
#lang racket
(provide autodoc
symbol-documentation
module-exports
update-signature-cache
preload-help
get-help)
(require racket/help
geiser/utils
geiser/modules
geiser/locations)
(define loader-thread #f)
(define (preload-help)
(set! loader-thread
(thread (lambda ()
(with-output-to-string (lambda ()
(help meh-i-dont-exist)))))))
(define here (current-namespace))
(define (get-help symbol mod)
(when loader-thread
(thread-wait loader-thread)
(set! loader-thread #f))
(if (eq? symbol mod)
(get-mod-help mod)
(with-handlers ([exn? (lambda (_) (eval `(help ,symbol) here))])
(eval `(help ,symbol #:from ,(ensure-module-spec mod)) here))))
(define (get-mod-help mod)
(let-values ([(ids syns) (module-identifiers mod)])
(let ([sym (cond [(not (null? syns)) (car syns)]
[(not (null? ids)) (car ids)]
[else #f])])
(and sym (get-help sym mod)))))
(define (symbol-documentation sym)
(let* ([val (value sym (symbol-module sym))]
[sign (autodoc* sym)])
(and sign
(list (cons "signature" (autodoc* sym #f))
(cons "docstring" (docstring sym val sign))))))
(define (docstring sym val sign)
(let* ([mod (assoc "module" (cdr sign))]
[mod (if mod (cdr mod) "<unknown>")]
[id (namespace-symbol->identifier sym)]
[desc (if (identifier? id) (format "~%~%~a" (describe id sym)) "")])
(if val
(format "A ~a in module ~a.~a~a~a"
(if (procedure? val) "procedure" "variable")
mod
(if (procedure? val)
""
(format "~%~%Value:~%~% ~a" val))
(if (has-contract? val)
(format "~%~%Contract:~%~% ~a"
(contract-name (value-contract val)))
"")
desc)
(format "An identifier in module ~a.~a" mod desc))))
;; Lifted from Eli's interactive.rkt
(define (describe id s)
(define b (identifier-binding id))
(cond
[(not b) (format "`~s' is a toplevel (or unbound) identifier." s)]
[(eq? b 'lexical) (format "`~s' is a lexical identifier." s)]
[(or (not (list? b)) (not (= 7 (length b))))
"*** internal error, racket changed ***"]
[else
(let-values ([(source-mod source-id
nominal-source-mod nominal-source-id
source-phase import-phase
nominal-export-phase)
(apply values b)])
(let ([aliased (not (eq? s source-id))]
[for-syn (eqv? source-phase 1)]
[amod (not (equal? source-mod nominal-source-mod))]
[aid (not (eq? s nominal-source-id))])
(if (or aliased for-syn amod aid)
(string-append
"Defined"
(if for-syn " for syntax" "")
(if aliased (format " as `~s' " source-id) "")
(if amod
(format " in module ~a\nand required~a in module ~a"
(module-path-index->name source-mod)
(if (eqv? import-phase 1) "-for-syntax" "")
(module-path-index->name nominal-source-mod))
"")
(if aid
(format ",\nwhere it is defined as `~s'" nominal-source-id)
"")
".")
"")))]))
(define (value id mod)
(with-handlers ([exn? (const #f)])
(dynamic-require mod id (const #f))))
(define (autodoc ids)
(map (lambda (id) (or (autodoc* id) (list id)))
(if (list? ids) ids '())))
(define (autodoc* id (extra #t))
(define (val)
(with-handlers ([exn? (const "")])
(parameterize ([error-print-width 60])
(format "~.a" (namespace-variable-value id)))))
(and
(symbol? id)
(let* ([loc (symbol-location* id)]
[name (car loc)]
[path (cdr loc)]
[sgns (and path (find-signatures path name id))]
[value (if (and extra sgns (not (list? sgns)))
(list (cons "value" (val)))
'())]
[mod (if (and extra sgns path)
(list (cons "module"
(module-path-name->name path)))
'())])
(and sgns
`(,id
("name" . ,name)
("args" ,@(if (list? sgns) (map format-signature sgns) '()))
,@value
,@mod)))))
(define (format-signature sign)
(if (signature? sign)
`(("required" ,@(signature-required sign))
("optional" ,@(signature-optional sign)
,@(let ((rest (signature-rest sign)))
(if rest (list "...") '())))
("key" ,@(signature-keys sign)))
'()))
(define signatures (make-hash))
(struct signature (required optional keys rest))
(define (find-signatures path name local-name)
(let ([path (if (path? path) (path->string path) path)])
(hash-ref! (hash-ref! signatures
path
(lambda () (parse-signatures path)))
name
(lambda () (infer-signatures local-name)))))
(define (parse-signatures path)
(let ([result (make-hasheq)])
(with-handlers ([exn? (lambda (e) result)])
(with-input-from-file path
(lambda ()
(parameterize ([read-accept-reader #t])
(let loop ([stx (read-syntax path)])
(cond [(eof-object? stx) void]
[(syntax->datum stx) =>
(lambda (datum)
(parse-datum! datum result)
(loop (read-syntax path)))]
[else void]))))))
result))
(define (parse-datum! datum store)
(with-handlers ([exn? (lambda (_) void)])
(match datum
[`(module ,name ,lang (#%module-begin . ,forms))
(for-each (lambda (f) (parse-datum! f store)) forms)]
[`(module ,name ,lang . ,forms)
(for-each (lambda (f) (parse-datum! f store)) forms)]
[`(define ((,name . ,formals) . ,_) . ,_)
(add-signature! name formals store)]
[`(define (,name . ,formals) . ,_)
(add-signature! name formals store)]
[`(define ,name (lambda ,formals . ,_))
(add-signature! name formals store)]
[`(define ,name (case-lambda ,clauses ...))
(for-each (lambda (c) (add-signature! name (car c) store))
(reverse clauses))]
[`(,(or 'struct 'define-struct) ,name ,(? symbol? _)
,(list formals ...) . ,_)
(add-signature! name formals store)]
[`(,(or 'struct 'define-struct) ,name ,(list formals ...) . ,_)
(add-signature! name formals store)]
[`(define-for-syntax (,name . ,formals) . ,_)
(add-signature! name formals store)]
[`(define-for-syntax ,name (lambda ,formals . ,_))
(add-signature! name formals store)]
[`(define-syntax-rule (,name . ,formals) . ,_)
(add-signature! name formals store)]
[`(define-syntax ,name (syntax-rules ,specials . ,clauses))
(for-each (lambda (c) (add-syntax-signature! name (cdar c) store))
(reverse clauses))]
[`(define-syntax ,name (lambda ,_ (syntax-case ,_ . ,clauses)))
(for-each (lambda (c) (add-syntax-signature! name (cdar c) store))
(reverse clauses))]
[`(define-type ,_ . ,cases)
(for-each (lambda (c) (add-signature! (car c) (cdr c) store)) cases)]
[_ void])))
(define (add-signature! name formals store)
(when (symbol? name)
(hash-set! store
name
(cons (parse-formals formals)
(hash-ref store name '())))))
(define (add-syntax-signature! name formals store)
(when (symbol? name)
(hash-set! store
name
(cons (signature formals '() '() #f)
(hash-ref store name '())))))
(define (parse-formals formals)
(let loop ([formals formals] [req '()] [opt '()] [keys '()])
(cond [(null? formals)
(signature (reverse req) (reverse opt) (reverse keys) #f)]
[(symbol? formals)
(signature (reverse req) (reverse opt) (reverse keys) formals)]
[(pair? (car formals)) (loop (cdr formals)
req
(cons (car formals) opt)
keys)]
[(keyword? (car formals)) (let* ((kname (car formals))
(arg-id (cadr formals))
(name (if (pair? arg-id)
(list kname
(cadr arg-id))
(list kname))))
(loop (cddr formals)
req
opt
(cons name keys)))]
[else (loop (cdr formals) (cons (car formals) req) opt keys)])))
(define (infer-signatures name)
(with-handlers ([exn:fail:syntax? (const `(,(signature '(...) '() '() #f)))]
[exn:fail:contract:variable? (const #f)])
(let ([v (namespace-variable-value name)])
(if (procedure? v)
(arity->signatures (procedure-arity v))
'variable))))
(define (arity->signatures arity)
(define (args count) (build-list count (const '_)))
(define (arity->signature arity)
(cond [(number? arity)
(signature (args arity) '() '() #f)]
[(arity-at-least? arity)
(signature (args (arity-at-least-value arity)) '() '() 'rest)]))
(define (conseq? lst)
(cond [(< (length lst) 2) (number? (car lst))]
[(and (number? (car lst))
(number? (cadr lst))
(eqv? (+ 1 (car lst)) (cadr lst)))
(conseq? (cdr lst))]
[else #f]))
(cond [(and (list? arity) (conseq? arity))
(let ((mi (apply min arity))
(ma (apply max arity)))
(list (signature (args mi) (args (- ma mi)) '() #f)))]
[(list? arity) (map arity->signature arity)]
[else (list (arity->signature arity))]))
(define (update-signature-cache path (form #f))
(when (and (string? path)
(or (not form)
(and (list? form)
(not (null? form))
(memq (car form)
'(define-syntax-rule struct
define-syntax define set! define-struct)))))
(hash-remove! signatures path)))
(define (module-exports mod)
(define (contracted id)
(let ([v (value id mod)])
(if (has-contract? v)
(list id (cons "info" (contract-name (value-contract v))))
(entry id))))
(define (entry id)
(let ((sign (eval `(,autodoc* ',id #f)
(module-spec->namespace mod #f #f))))
(if sign (list id (cons "signature" sign)) (list id))))
(define (classify-ids ids)
(let loop ([ids ids] [procs '()] [vars '()])
(cond [(null? ids)
`(("procs" ,@(map entry (reverse procs)))
("vars" ,@(map list (reverse vars))))]
[(procedure? (value (car ids) mod))
(loop (cdr ids) (cons (car ids) procs) vars)]
[else (loop (cdr ids) procs (cons (car ids) vars))])))
(let-values ([(ids syn) (module-identifiers mod)])
`(,@(classify-ids ids)
("syntax" ,@(map contracted syn))
("modules" ,@(map list (or (submodules mod) '()))))))

29
elpa/geiser-20171010.1610/scheme/racket/geiser/completions.rkt Normal file
View File

@@ -0,0 +1,29 @@
;;; completions.rkt -- completion support
;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
;; Start date: Sun Apr 26, 2009 19:02
#lang racket
(provide symbol-completions
module-completions)
(require srfi/13 geiser/utils geiser/modules)
(define (filter-prefix prefix lst sort?)
(filter (lambda (s) (string-prefix? prefix s))
(if sort? (sort lst string<?) lst)))
(define (symbol-completions prefix)
(filter-prefix prefix
(map symbol->string (namespace-mapped-symbols))
#t))
(define (module-completions prefix)
(filter-prefix prefix (module-list) #f))

155
elpa/geiser-20171010.1610/scheme/racket/geiser/enter.rkt Normal file
View File

@@ -0,0 +1,155 @@
;;; enter.rkt -- custom module loaders
;; Copyright (C) 2010, 2012, 2013, 2014 Jose Antonio Ortega Ruiz
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
;; Start date: Wed Mar 31, 2010 21:53
#lang racket/base
(require syntax/modcode
(for-syntax racket/base)
racket/path)
(provide get-namespace visit-module module-loader)
(struct mod (name load-path timestamp depends) #:transparent)
(define (make-mod name path ts code)
(let ([deps (if code
(apply append (map cdr (module-compiled-imports code)))
null)])
(mod name (path->string path) ts deps)))
(define loaded (make-hash))
(define (mod->path mod)
(with-handlers ([exn? (lambda (_) #f)])
(let ([rp (module-path-index-resolve (module-path-index-join mod #f))])
(resolved-module-path-name rp))))
(define (visit-module mod)
(dynamic-require mod #f)
(check-latest mod))
(define (module-loader orig)
(make-loader orig #f))
(define inhibit-eval (make-parameter #f))
(define (get-namespace mod)
(let ([mod (cond [(symbol? mod) mod]
[(string? mod) (find-module! (string->path mod) mod)]
[(path? mod) (find-module! mod (path->string mod))]
[else mod])])
(and mod
(with-handlers ([exn? (lambda (_) #f)])
(parameterize ([inhibit-eval #t])
(module->namespace mod))))))
(define (find-module! path path-str)
(let ([m (or (hash-ref loaded path #f)
(let loop ([ps (remove path (resolve-paths path))]
[seen '()])
(cond [(null? ps) #f]
[(hash-ref loaded (car ps) #f) =>
(lambda (m)
(add-paths! m (cdr ps))
(add-paths! m (cons path seen))
m)]
[else (loop (cdr ps) (cons (car ps) seen))])))])
(list 'file (or (and m (mod-load-path m)) path-str))))
(define (add-paths! m ps)
(for-each (lambda (p) (hash-set! loaded p m)) ps))
(define (resolve-paths path)
(define (find root rest)
(let* ([alt-root (resolve-path root)]
[same? (equal? root alt-root)])
(cond [(null? rest) (cons root (if same? '() `(,alt-root)))]
[else (let* ([c (car rest)]
[cs (cdr rest)]
[rps (find (build-path root c) cs)])
(if same?
rps
(append rps (find (build-path alt-root c) cs))))])))
(let ([cmps (explode-path path)])
(find (car cmps) (cdr cmps))))
(define (notify re? path)
(when re? (fprintf (current-error-port) " [re-loading ~a]\n" path)))
(define (module-name? name)
(and name (not (and (pair? name) (not (car name))))))
(define (module-code re? name path)
(get-module-code path
"compiled"
(lambda (e)
(parameterize ([compile-enforce-module-constants #f])
(compile-syntax e)))
(lambda (ext loader?) (load-extension ext) #f)
#:notify (lambda (chosen) (notify re? chosen))))
(define ((make-loader orig re?) path name)
(when (inhibit-eval)
(raise (make-exn:fail "namespace not found" (current-continuation-marks))))
(if (module-name? name)
;; Module load:
(with-handlers ([(lambda (exn)
(and (pair? name) (exn:get-module-code? exn)))
;; Load-handler protocol: quiet failure when a
;; submodule is not found
(lambda (exn) (void))])
(let* ([code (module-code re? name path)]
[dir (or (current-load-relative-directory) (current-directory))]
[path (path->complete-path path dir)]
[path (normal-case-path (simplify-path path))])
(define-values (ts real-path) (get-timestamp path))
(add-paths! (make-mod name path ts code) (resolve-paths path))
(parameterize ([current-module-declare-source real-path])
(eval code))))
;; Not a module:
(begin (notify re? path) (orig path name))))
(define (get-timestamp path)
(let ([ts (file-or-directory-modify-seconds path #f (lambda () #f))])
(if ts
(values ts path)
(if (regexp-match? #rx#"[.]rkt$" (path->bytes path))
(let* ([alt-path (path-replace-suffix path #".ss")]
[ts (file-or-directory-modify-seconds alt-path
#f
(lambda () #f))])
(if ts
(values ts alt-path)
(values -inf.0 path)))
(values -inf.0 path)))))
(define (check-latest mod)
(define mpi (module-path-index-join mod #f))
(define done (make-hash))
(let loop ([mpi mpi])
(define rindex (module-path-index-resolve mpi))
(define rpath (resolved-module-path-name rindex))
(define path (if (pair? rpath) (car rpath) rpath))
(when (path? path)
(define npath (normal-case-path path))
(unless (hash-ref done npath #f)
(hash-set! done npath #t)
(define mod (hash-ref loaded rpath #f))
(when mod
(for-each loop (mod-depends mod))
(define-values (ts actual-path) (get-timestamp npath))
(when (> ts (mod-timestamp mod))
(define orig (current-load/use-compiled))
(parameterize ([current-load/use-compiled
(make-loader orig #f)]
[current-module-declare-name rindex]
[current-module-declare-source actual-path])
((make-loader orig #f) npath (mod-name mod)))))))))

83
elpa/geiser-20171010.1610/scheme/racket/geiser/eval.rkt Normal file
View File

@@ -0,0 +1,83 @@
;;; eval.rkt -- evaluation
;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Jose Antonio Ortega Ruiz
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
;; Start date: Sun Apr 26, 2009 00:44
#lang racket
(provide eval-in
load-file
macroexpand
add-to-load-path
make-repl-reader
call-with-result)
(require geiser/enter geiser/modules geiser/images)
(require errortrace/errortrace-lib)
(define last-result (void))
(define last-namespace (make-parameter (current-namespace)))
(define (exn-key e)
(vector-ref (struct->vector e) 0))
(define (set-last-error e)
(set! last-result `((error (key . ,(exn-key e)))))
(display (exn-message e))
(newline) (newline)
(parameterize ([error-context-display-depth 10])
(print-error-trace (current-output-port) e)))
(define (write-value v)
(with-output-to-string
(lambda () (maybe-write-image v))))
(define (set-last-result . vs)
(set! last-result `((result ,@(map write-value vs)))))
(define (call-with-result thunk)
(set-last-result (void))
(let ([output
(with-output-to-string
(lambda ()
(parameterize ([current-error-port (current-output-port)])
(with-handlers ([exn? set-last-error])
(call-with-values thunk set-last-result)))))])
(append last-result `(,(cons 'output output)))))
(define (eval-in form spec lang . non-top)
(write (call-with-result
(lambda ()
(eval (if (null? non-top) (cons '#%top-interaction form) form)
(module-spec->namespace spec lang)))))
(newline))
(define (load-file file)
(load-module file (current-output-port) (last-namespace)))
(define (macroexpand form . all)
(let ([all (and (not (null? all)) (car all))])
(with-output-to-string
(lambda ()
(pretty-print (syntax->datum ((if all expand expand-once) form)))))))
(define (add-to-load-path p)
(when (string? p)
(let ([p (string->path p)]
[cps (current-library-collection-paths)])
(unless (member p cps)
(current-library-collection-paths
(cons p cps)))))
#t)
(define (make-repl-reader reader)
(lambda ()
(last-namespace (current-namespace))
(reader)))

66
elpa/geiser-20171010.1610/scheme/racket/geiser/images.rkt Normal file
View File

@@ -0,0 +1,66 @@
;;; images.rkt -- support for image handline
;; Copyright (C) 2012, 2014 Jose Antonio Ortega Ruiz
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
;; Authors: Michael Wilber, Jose Antonio Ortega Ruiz <jao@gnu.org>
;; Start date: Sun Sep 2, 2012 18:54
#lang racket/base
(require racket/file file/convertible racket/pretty)
(provide image-cache
maybe-print-image
maybe-write-image
make-port-print-handler
make-pretty-print-size-hook
make-pretty-print-print-hook)
(define image-cache
(let ([ensure-dir (lambda (dir)
(if (path-string? dir)
(begin (make-directory* dir)
(if (path? dir) (path->string dir) dir))
(path->string (find-system-path 'temp-dir))))])
(make-parameter (ensure-dir #f) ensure-dir)))
(define (save-tmpimage imgbytes)
;; Save imgbytes to a new temporary file and return the filename
(define filename (make-temporary-file "geiser-img-~a.png" #f (image-cache)))
(with-output-to-file filename #:exists 'truncate
(lambda () (display imgbytes)))
(format "#<Image: ~a>" filename))
(define (maybe-save-image value)
(and (convertible? value)
;; (The above could be problematic if a future version of racket
;; suddenly decides it can "convert" strings to picts)
(save-tmpimage (convert value 'png-bytes))))
(define (maybe-print-image value)
(cond [(maybe-save-image value) => (lambda (s) (printf "~a\n" s))]
[else (unless (void? value)
(pretty-print value))]))
(define (maybe-write-image value)
(write (or (maybe-save-image value) value)))
(define (make-port-print-handler ph)
(lambda (value port . rest)
(apply ph (or (maybe-save-image value) value) port rest)))
(define (make-pretty-print-size-hook [orig (pretty-print-size-hook)])
(lambda (value display? port)
(if (convertible? value)
(pretty-print-columns)
(orig value display? port))))
(define (make-pretty-print-print-hook [orig (pretty-print-print-hook)])
(lambda (value display? port)
(let [(img (maybe-save-image value))]
(if img (print img port) (orig value display? port)))))

58
elpa/geiser-20171010.1610/scheme/racket/geiser/locations.rkt Normal file
View File

@@ -0,0 +1,58 @@
;;; locations.rkt -- locating symbols
;; Copyright (C) 2009, 2010, 2012 Jose Antonio Ortega Ruiz
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
;; Start date: Sun Apr 26, 2009 19:43
#lang racket
(provide symbol-location
symbol-location*
module-location
symbol-module
symbol-module-name)
(require geiser/utils geiser/modules)
(define (symbol-location* sym)
(let* ([id (namespace-symbol->identifier sym)]
[binding (and id (identifier-binding id))])
(if (list? binding)
(cons
(cadr binding)
(resolved-module-path-name
(module-path-index-resolve (car binding))))
(cons sym #f))))
(define (switch-extension path)
(if (regexp-match? "\\.rkt$" path)
(regexp-replace "\\.rkt$" path ".ss")
(regexp-replace "\\.ss$" path ".rkt")))
(define (make-location name path line)
(let* ([path (if (path? path) (path->string path) #f)]
[path (and path (if (file-exists? path) path (switch-extension path)))])
(list (cons "name" name)
(cons "file" (or path '()))
(cons "line" (or line '())))))
(define (symbol-location sym)
(let* ([loc (symbol-location* sym)]
[name (car loc)]
[path (cdr loc)])
(if path
(make-location name path #f)
(module-location sym))))
(define symbol-module (compose cdr symbol-location*))
(define symbol-module-name
(compose module-path-name->name symbol-module))
(define (module-location sym)
(make-location sym (module-spec->path-name sym) 1))

57
elpa/geiser-20171010.1610/scheme/racket/geiser/main.rkt Normal file
View File

@@ -0,0 +1,57 @@
;;; main.rkt -- exported interface for emacs
;; Copyright (C) 2010, 2011 Jose Antonio Ortega Ruiz
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
;; Start date: Wed Mar 31, 2010 21:14
#lang racket/base
(provide geiser:eval
geiser:compile
geiser:load-file
geiser:compile-file
geiser:macroexpand
geiser:completions
geiser:module-completions
geiser:symbol-location
geiser:module-location
geiser:module-exports
geiser:autodoc
geiser:symbol-documentation
geiser:help
geiser:no-values)
(require geiser/eval
geiser/modules
geiser/completions
geiser/locations
geiser/autodoc)
(define (geiser:eval lang)
(lambda (form spec)
(update-signature-cache spec form)
(eval-in form spec lang)))
(define geiser:compile geiser:eval)
(define (geiser:load-file file)
(update-signature-cache file)
(load-file file))
(define geiser:compile-file geiser:load-file)
(define geiser:add-to-load-path add-to-load-path)
(define geiser:autodoc autodoc)
(define geiser:help get-help)
(define geiser:completions symbol-completions)
(define geiser:module-completions module-completions)
(define geiser:symbol-location symbol-location)
(define geiser:module-location module-location)
(define geiser:module-exports module-exports)
(define geiser:macroexpand macroexpand)
(define geiser:symbol-documentation symbol-documentation)
(define (geiser:no-values) (values))

227
elpa/geiser-20171010.1610/scheme/racket/geiser/modules.rkt Normal file
View File

@@ -0,0 +1,227 @@
;;; modules.rkt -- module metadata
;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Jose Antonio Ortega Ruiz
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
;; Start date: Wed May 06, 2009 02:35
#lang racket
(provide load-module
ensure-module-spec
module-spec->namespace
namespace->module-name
namespace->module-path-name
module-path-name->name
module-spec->path-name
module-path-index->name
module-identifiers
module-list
submodules)
(require srfi/13
syntax/modcode
syntax/modresolve
geiser/enter)
(define (ensure-module-spec spec)
(cond [(symbol? spec) spec]
[(not (string? spec)) #f]
[else `(file ,spec)]))
(define (module-spec->namespace spec (lang #f) (current #t))
(define (try-lang)
(and lang
(with-handlers ([exn? (const #f)])
(load-module lang #f (current-namespace))
(module->namespace lang))))
(or (get-namespace spec)
(try-lang)
(and current (current-namespace))))
(define nowhere (open-output-nowhere))
(define (load-module spec (port #f) (ns #f))
(parameterize ([current-error-port (or port nowhere)])
(visit-module (ensure-module-spec spec))
(when (namespace? ns)
(current-namespace ns))))
(define (namespace->rmp ns)
(with-handlers ([exn? (const #f)])
(variable-reference->resolved-module-path
(eval '(#%variable-reference) (or ns (current-namespace))))))
(define (namespace->module-path-name ns (p #f))
(let ([rmp (namespace->rmp ns)])
(or (and (resolved-module-path? rmp)
(resolved-module-path-name rmp))
p)))
(define (module-spec->path-name spec)
(and (symbol? spec)
(or (get-path spec)
(register-path spec
(namespace->module-path-name
(module-spec->namespace spec #f #f))))))
(define unknown-module-name "*unresolved module*")
(define (unix-path->string path)
(regexp-replace* "\\\\" (path->string path) "/"))
(define (path->name path)
(if (path-string? path)
(let* ([cpaths (map (compose unix-path->string path->directory-path)
(current-library-collection-paths))]
[prefix-len (lambda (p)
(let ((pl (string-length p)))
(if (= pl (string-prefix-length p path))
pl
0)))]
[lens (map prefix-len cpaths)]
[real-path (substring path (apply max lens))])
(if (absolute-path? real-path)
(let-values ([(_ base __) (split-path path)])
(unix-path->string base))
(regexp-replace "\\.[^./]*$" real-path "")))
path))
(define (module-path-name->name path)
(cond [(path? path) (module-path-name->name (unix-path->string path))]
;; [(eq? path '#%kernel) "(kernel)"]
[(path-string? path) (path->name path)]
[(symbol? path) (symbol->string path)]
[(list? path) (string-join (map (compose path->name ~a) path) "/")]
[else (~a path)]))
(define (module-path-index->name mpi)
(let ([rmp (module-path-index-resolve mpi)])
(if (resolved-module-path? rmp)
(module-path-name->name (resolved-module-path-name rmp))
unknown-module-name)))
(define (namespace->module-name ns (p #f))
(module-path-name->name (namespace->module-path-name ns p)))
(define (module-identifiers mod)
(define (extract-ids ls)
(append-map (lambda (idls)
(map car (cdr idls)))
ls))
(let-values ([(reg syn)
(module-compiled-exports
(get-module-code (resolve-module-path
(ensure-module-spec mod) #f)))])
(values (extract-ids reg) (extract-ids syn))))
(define (skippable-dir? path)
(call-with-values (lambda () (split-path path))
(lambda (_ basename __)
(member (path->string basename) '(".svn" "compiled")))))
(define path->symbol (compose string->symbol unix-path->string))
(define (path->entry path)
(let ([ext (filename-extension path)])
(and ext
(or (bytes=? ext #"rkt") (bytes=? ext #"ss"))
(not (bytes=? (bytes-append #"main" ext) (path->bytes path)))
(let* ([path (unix-path->string path)]
[len (- (string-length path) (bytes-length ext) 1)])
(substring path 0 len)))))
(define (ensure-path datum)
(if (string? datum)
(string->path datum)
datum))
(define main-rkt (build-path "main.rkt"))
(define main-ss (build-path "main.ss"))
(define ((visit-module-path reg?) path kind acc)
(define (register e p)
(when reg?
(register-path (string->symbol e) (build-path (current-directory) p)))
(values (cons e acc) reg?))
(define (get-main path main)
(and (file-exists? main) (build-path path main)))
(define (find-main path)
(parameterize ([current-directory path])
(or (get-main path main-rkt) (get-main path main-ss))))
(case kind
[(file) (let ([entry (path->entry path)])
(if (not entry) acc (register entry path)))]
[(dir) (cond [(skippable-dir? path) (values acc #f)]
[(find-main path) => (curry register (unix-path->string path))]
[else (values acc reg?)])]
[else acc]))
(define ((find-modules reg?) path acc)
(if (directory-exists? path)
(parameterize ([current-directory path])
(fold-files (visit-module-path reg?) acc))
acc))
(define (take-while pred lst)
(let loop ([lst lst] [acc '()])
(cond [(null? lst) (reverse acc)]
[(pred (car lst)) (loop (cdr lst) (cons (car lst) acc))]
[else (reverse acc)])))
(define (submodules mod)
(let* ([mod-name (if (symbol? mod) mod (get-mod mod))]
[mod-str (and (symbol? mod-name) (symbol->string mod-name))])
(if mod-str
(let ([ms (member mod-str (module-list))])
(and ms
(take-while (lambda (m) (string-prefix? mod-str m))
(cdr ms))))
(find-submodules mod))))
(define (find-submodules path)
(and (path-string? path)
(let-values ([(dir base ign) (split-path path)])
(and (or (equal? base main-rkt)
(equal? base main-ss))
(map (lambda (m) (unix-path->string (build-path dir m)))
(remove "main" ((find-modules #f) dir '())))))))
(define (known-modules)
(sort (foldl (find-modules #t)
'()
(current-library-collection-paths))
string<?))
(define registered (make-hash))
(define registered-paths (make-hash))
(define (get-path mod)
(hash-ref registered mod #f))
(define (get-mod path)
(hash-ref registered-paths path #f))
(define (register-path mod path)
(hash-set! registered mod path)
(hash-set! registered-paths path mod)
path)
(define module-cache #f)
(define (update-module-cache)
(when (not module-cache) (set! module-cache (known-modules))))
(define (module-list)
(update-module-cache)
module-cache)
(define (startup)
(thread update-module-cache)
(void))
(startup)

16
elpa/geiser-20171010.1610/scheme/racket/geiser/server.rkt Normal file
View File

@@ -0,0 +1,16 @@
;;; server.rkt -- REPL server
;; Copyright (c) 2010 Jose Antonio Ortega Ruiz
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
;; Start date: Sat Nov 06, 2010 15:15
#lang racket/base
(require geiser/user)
(provide start-geiser)

15
elpa/geiser-20171010.1610/scheme/racket/geiser/startup.rkt Normal file
View File

@@ -0,0 +1,15 @@
;;; startup.rkt -- entry point
;; Copyright (C) 2009, 2010, 2013, 2014 Jose Antonio Ortega Ruiz
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
;; Start date: Sat Apr 25, 2009 22:36
;; (require errortrace)
(require geiser/user)
(init-geiser-repl)

172
elpa/geiser-20171010.1610/scheme/racket/geiser/user.rkt Normal file
View File

@@ -0,0 +1,172 @@
;;; user.rkt -- global bindings visible to geiser users
;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Jose Antonio Ortega Ruiz
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
;; Start date: Wed Mar 31, 2010 22:24
#lang racket
(provide init-geiser-repl run-geiser-server start-geiser)
(require (for-syntax racket/base)
mzlib/thread
racket/tcp
racket/help
geiser
geiser/autodoc
geiser/images
geiser/enter
geiser/eval
geiser/modules)
(define top-namespace (current-namespace))
(define last-entered (make-parameter ""))
(define (do-enter mod name)
(visit-module mod)
(last-entered name)
(current-namespace (module->namespace mod)))
(define (file-mod? mod)
(and (list? mod)
(= 2 (length mod))
(eq? 'file (car mod))
(path-string? (cadr mod))))
(define (submod-path mod)
(and (list? mod)
(eq? 'submod (car mod))
(> (length mod) 1)
(let ([parent (cadr mod)])
(cond [(path-string? parent) `(submod (file ,parent) ,@(cddr mod))]
[(file-mod? parent) mod]
[(symbol? parent) mod]
[else #f]))))
(define (module-error stx mod)
(raise-syntax-error #f "Invalid module path" stx mod))
(define (enter! mod stx)
(cond [(not mod)
(current-namespace top-namespace)
(last-entered "")]
[(symbol? mod) (do-enter mod (symbol->string mod))]
[(path-string? mod) (do-enter `(file ,mod) mod)]
[(file-mod? mod) (do-enter mod (cadr mod))]
[(submod-path mod) => (lambda (m) (do-enter m m))]
[else (module-error stx mod)]))
(define (geiser-eval)
(define geiser-main (module->namespace 'geiser))
(define (eval-here form) (eval form geiser-main))
(let* ([mod (read)]
[lang (read)]
[form (read)]
[res (cond [(equal? form '(unquote apply))
(let* ([proc (eval-here (read))]
[args (map eval-here (read))]
[ev (lambda () (apply proc args))])
(eval-in `(,ev) mod lang #t))]
[else ((geiser:eval lang) form mod)])])
(datum->syntax #f (list 'quote res))))
(define (geiser-load stx)
(let* ([mod (read)]
[res (call-with-result
(lambda ()
(visit-module (cond [(file-mod? mod) mod]
[(path-string? mod) `(file ,mod)]
[(submod-path mod)]
[else (module-error stx mod)]))
(void)))])
(datum->syntax stx (list 'quote res))))
(define ((geiser-read prompt))
(prompt)
(flush-output (current-error-port))
(flush-output (current-output-port))
(let* ([in ((current-get-interaction-input-port))]
[form ((current-read-interaction) (object-name in) in)])
(syntax-case form ()
[(uq cmd) (eq? 'unquote (syntax-e #'uq))
(case (syntax-e #'cmd)
[(start-geiser) (datum->syntax #f `(list 'port ,(start-geiser)))]
[(enter) (enter! (read) #'cmd)]
[(geiser-eval) (geiser-eval)]
[(geiser-load) (geiser-load #'cmd)]
[(geiser-no-values) (datum->syntax #f (void))]
[(add-to-load-path) (add-to-load-path (read))]
[(set-image-cache) (image-cache (read))]
[(help) (get-help (read) (read))]
[(image-cache) (image-cache)]
[(pwd) (~a (current-directory))]
[(cd) (current-directory (~a (read)))]
[else form])]
[_ form])))
(define geiser-prompt
(lambda ()
(let ([m (namespace->module-name (current-namespace) (last-entered))])
(printf "racket@~a> " (regexp-replace* " " m "_")))))
(define (geiser-prompt-read prompt)
(make-repl-reader (geiser-read prompt)))
(define (geiser-loader) (module-loader (current-load/use-compiled)))
(define (install-print-handler handler)
(let ([p (current-output-port)])
(handler p (make-port-print-handler (handler p)))))
(define (install-print-handlers)
(for-each install-print-handler (list port-print-handler
port-write-handler
port-display-handler))
(pretty-print-print-hook (make-pretty-print-print-hook))
(pretty-print-size-hook (make-pretty-print-size-hook)))
(define (init-geiser-repl)
(compile-enforce-module-constants #f)
(current-load/use-compiled (geiser-loader))
(preload-help)
(current-prompt-read (geiser-prompt-read geiser-prompt))
(current-print maybe-print-image)
(install-print-handlers))
(define (run-geiser-repl in out enforce-module-constants)
(parameterize [(compile-enforce-module-constants enforce-module-constants)
(current-input-port in)
(current-output-port out)
(current-error-port out)
(current-load/use-compiled (geiser-loader))
(current-prompt-read (geiser-prompt-read geiser-prompt))
(current-print maybe-print-image)
(pretty-print-print-hook (make-pretty-print-print-hook))
(pretty-print-size-hook (make-pretty-print-size-hook))]
(install-print-handlers)
(preload-help)
(read-eval-print-loop)))
(define server-channel (make-channel))
(define (run-geiser-server port enforce-module-constants (hostname #f))
(run-server port
(lambda (in out)
(run-geiser-repl in out enforce-module-constants))
#f
void
(lambda (p _ __)
(let ([lsner (tcp-listen p 4 #f hostname)])
(let-values ([(_ p __ ___) (tcp-addresses lsner #t)])
(channel-put server-channel p)
lsner)))))
(define (start-geiser (port 0) (hostname #f) (enforce-module-constants #f))
(thread (lambda ()
(run-geiser-server port enforce-module-constants hostname)))
(channel-get server-channel))

25
elpa/geiser-20171010.1610/scheme/racket/geiser/utils.rkt Normal file
View File

@@ -0,0 +1,25 @@
;;; utils.rkt -- generic utilities
;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
;; Start date: Sun May 03, 2009 03:09
#lang racket
(provide pair->list
keyword->symbol
symbol->keyword)
(define (pair->list pair)
(let loop ([d pair] [s '()])
(cond [(null? d) (reverse s)]
[(symbol? d) (reverse (cons d s))]
[else (loop (cdr d) (cons (car d) s))])))
(define keyword->symbol (compose string->symbol keyword->string))
(define (symbol->keyword sym) (string->keyword (format "~a" sym)))