scheme/racket/geiser/autodoc.rkt

   1 ;;; autodoc.rkt -- suport for autodoc echo
   2
   3 ;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the Modified BSD License. You should
   7 ;; have received a copy of the license along with this program. If
   8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
   9
  10 ;; Start date: Sun May 03, 2009 14:45
  11
  12 #lang racket
  13
  14 (provide autodoc module-exports update-signature-cache get-help)
  15
  16 (require racket/help
  17          syntax/modcode
  18          syntax/modresolve
  19          geiser/utils
  20          geiser/modules
  21          geiser/locations)
  22
  23 (define (get-help symbol mod)
  24   (with-handlers ([exn? (lambda (_)
  25                           (eval `(help ,symbol)))])
  26     (eval `(help ,symbol #:from ,(ensure-module-spec mod)))))
  27
  28 (define (autodoc ids)
  29   (if (not (list? ids))
  30       '()
  31       (map (lambda (id) (or (autodoc* id) (list id))) ids)))
  32
  33 (define (autodoc* id (extra #t))
  34   (define (val)
  35     (with-handlers ([exn? (const "")])
  36       (format "~.a" (namespace-variable-value id))))
  37   (and
  38    (symbol? id)
  39    (let* ([loc (symbol-location* id)]
  40           [name (car loc)]
  41           [path (cdr loc)]
  42           [sgns (and path (find-signatures path name id))]
  43           [value (if (and extra sgns (not (list? sgns)))
  44                      (list (cons 'value (val)))
  45                      '())]
  46           [mod (if (and extra sgns path)
  47                    (list (cons 'module
  48                                (module-path-name->name path)))
  49                    '())])
  50      (and sgns
  51           `(,id
  52             (name . ,name)
  53             (args ,@(if (list? sgns) (map format-signature sgns) '()))
  54             ,@value
  55             ,@mod)))))
  56
  57 (define (format-signature sign)
  58   (if (signature? sign)
  59       `((required ,@(signature-required sign))
  60         (optional ,@(signature-optional sign)
  61                   ,@(let ((rest (signature-rest sign)))
  62                       (if rest (list "...") '())))
  63         (key ,@(signature-keys sign)))
  64       '()))
  65
  66 (define signatures (make-hash))
  67
  68 (struct signature (required optional keys rest))
  69
  70 (define (find-signatures path name local-name)
  71   (let ([path (if (path? path) (path->string path) path)])
  72     (hash-ref! (hash-ref! signatures
  73                           path
  74                           (lambda () (parse-signatures path)))
  75                name
  76                (lambda () (infer-signatures local-name)))))
  77
  78 (define (parse-signatures path)
  79   (let ([result (make-hasheq)])
  80     (with-handlers ([exn? (lambda (e) result)])
  81       (with-input-from-file path
  82         (lambda ()
  83           (parameterize ([read-accept-reader #t])
  84             (let loop ([stx (read-syntax path)])
  85               (cond [(eof-object? stx) void]
  86                     [(syntax->datum stx) =>
  87                      (lambda (datum)
  88                        (parse-datum! datum result)
  89                        (loop (read-syntax path)))]
  90                     [else void]))))))
  91     result))
  92
  93 (define (parse-datum! datum store)
  94   (with-handlers ([exn? (lambda (_) void)])
  95     (match datum
  96       [`(module ,name ,lang (#%module-begin . ,forms))
  97        (for-each (lambda (f) (parse-datum! f store)) forms)]
  98       [`(module ,name ,lang . ,forms)
  99        (for-each (lambda (f) (parse-datum! f store)) forms)]
 100       [`(define ((,name . ,formals) . ,_) . ,_)
 101        (add-signature! name formals store)]
 102       [`(define (,name . ,formals) . ,_)
 103        (add-signature! name formals store)]
 104       [`(define ,name (lambda ,formals . ,_))
 105        (add-signature! name formals store)]
 106       [`(define ,name (case-lambda ,clauses ...))
 107        (for-each (lambda (c) (add-signature! name (car c) store))
 108                  (reverse clauses))]
 109       [`(,(or 'struct 'define-struct) ,name ,(? symbol? _)
 110          ,(list formals ...) . ,_)
 111        (add-signature! name formals store)]
 112       [`(,(or 'struct 'define-struct) ,name ,(list formals ...) . ,_)
 113        (add-signature! name formals store)]
 114       [`(define-for-syntax (,name . ,formals) . ,_)
 115        (add-signature! name formals store)]
 116       [`(define-for-syntax ,name (lambda ,formals . ,_))
 117        (add-signature! name formals store)]
 118       [`(define-syntax-rule (,name . ,formals) . ,_)
 119        (add-signature! name formals store)]
 120       [`(define-syntax ,name (syntax-rules ,specials . ,clauses))
 121        (for-each (lambda (c) (add-syntax-signature! name (cdar c) store))
 122                  (reverse clauses))]
 123       [`(define-syntax ,name (lambda ,_ (syntax-case ,_ . ,clauses)))
 124        (for-each (lambda (c) (add-syntax-signature! name (cdar c) store))
 125                  (reverse clauses))]
 126       [_ void])))
 127
 128 (define (add-signature! name formals store)
 129   (when (symbol? name)
 130     (hash-set! store
 131                name
 132                (cons (parse-formals formals)
 133                      (hash-ref store name '())))))
 134
 135 (define (add-syntax-signature! name formals store)
 136   (when (symbol? name)
 137     (hash-set! store
 138                name
 139                (cons (signature formals '() '() #f)
 140                      (hash-ref store name '())))))
 141
 142 (define (parse-formals formals)
 143   (let loop ([formals formals] [req '()] [opt '()] [keys '()])
 144     (cond [(null? formals)
 145            (signature (reverse req) (reverse opt) (reverse keys) #f)]
 146           [(symbol? formals)
 147            (signature (reverse req) (reverse opt) (reverse keys) formals)]
 148           [(pair? (car formals)) (loop (cdr formals)
 149                                        req
 150                                        (cons (car formals) opt)
 151                                        keys)]
 152           [(keyword? (car formals)) (let* ((kname (car formals))
 153                                            (arg-id (cadr formals))
 154                                            (name (if (pair? arg-id)
 155                                                      (list kname
 156                                                            (cadr arg-id))
 157                                                      (list kname))))
 158                                       (loop (cddr formals)
 159                                             req
 160                                             opt
 161                                             (cons name keys)))]
 162           [else (loop (cdr formals) (cons (car formals) req) opt keys)])))
 163
 164 (define (infer-signatures name)
 165   (with-handlers ([exn:fail:syntax? (const `(,(signature '(...) '() '() #f)))]
 166                   [exn:fail:contract:variable? (const #f)])
 167     (let ([v (namespace-variable-value name)])
 168       (if (procedure? v)
 169           (arity->signatures (procedure-arity v))
 170           'variable))))
 171
 172 (define (arity->signatures arity)
 173   (define (args count) (build-list count (const '_)))
 174   (define (arity->signature arity)
 175     (cond [(number? arity)
 176            (signature (args arity) '() '() #f)]
 177           [(arity-at-least? arity)
 178            (signature (args (arity-at-least-value arity)) '() '() 'rest)]))
 179   (define (conseq? lst)
 180     (cond [(< (length lst) 2) (number? (car lst))]
 181           [(and (number? (car lst))
 182                 (number? (cadr lst))
 183                 (eqv? (+ 1 (car lst)) (cadr lst)))
 184            (conseq? (cdr lst))]
 185           [else #f]))
 186   (cond [(and (list? arity) (conseq? arity))
 187          (let ((mi (apply min arity))
 188                (ma (apply max arity)))
 189            (list (signature (args mi) (args (- ma mi)) '() #f)))]
 190         [(list? arity) (map arity->signature arity)]
 191         [else (list (arity->signature arity))]))
 192
 193 (define (update-signature-cache path (form #f))
 194   (when (and (string? path)
 195              (or (not form)
 196                  (and (list? form)
 197                       (not (null? form))
 198                       (memq (car form)
 199                             '(define-syntax-rule struct
 200                                define-syntax define set! define-struct)))))
 201     (hash-remove! signatures path)))
 202
 203 (define (module-exports mod)
 204   (define (value id)
 205     (with-handlers ([exn? (const #f)])
 206       (dynamic-require mod id (const #f))))
 207   (define (contracted id)
 208     (let ([v (value id)])
 209       (if (has-contract? v)
 210           (list id (cons 'info (contract-name (value-contract v))))
 211           (entry id))))
 212   (define (entry id)
 213     (let ((sign (eval `(,autodoc* ',id #f)
 214                       (module-spec->namespace mod #f #f))))
 215       (if sign (list id (cons 'signature sign)) (list id))))
 216   (define (extract-ids ls)
 217     (append-map (lambda (idls)
 218                   (map car (cdr idls)))
 219                 ls))
 220   (define (classify-ids ids)
 221     (let loop ([ids ids] [procs '()] [vars '()])
 222       (cond [(null? ids)
 223              `((procs ,@(map entry (reverse procs)))
 224                (vars ,@(map list (reverse vars))))]
 225             [(procedure? (value (car ids)))
 226              (loop (cdr ids) (cons (car ids) procs) vars)]
 227             [else (loop (cdr ids) procs (cons (car ids) vars))])))
 228   (let-values ([(reg syn)
 229                 (module-compiled-exports
 230                  (get-module-code (resolve-module-path mod #f)))])
 231     (let ([syn (map contracted (extract-ids syn))]
 232           [reg (extract-ids reg)]
 233           [subm (map list (or (submodules mod) '()))])
 234       `((syntax ,@syn) ,@(classify-ids reg) (modules ,@subm)))))