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
  15          symbol-documentation
  16          module-exports
  17          update-signature-cache
  18          get-help)
  19
  20 (require racket/help
  21          geiser/utils
  22          geiser/modules
  23          geiser/locations)
  24
  25 (define (get-help symbol mod)
  26   (if (eq? symbol mod)
  27       (get-mod-help mod)
  28       (with-handlers ([exn? (lambda (_)
  29                               (eval `(help ,symbol)))])
  30         (eval `(help ,symbol #:from ,(ensure-module-spec mod))))))
  31
  32 (define (get-mod-help mod)
  33   (let-values ([(ids syns) (module-identifiers mod)])
  34     (let ([sym (cond [(not (null? syns)) (car syns)]
  35                      [(not (null? ids)) (car ids)]
  36                      [else #f])])
  37       (and sym (get-help sym mod)))))
  38
  39 (define (symbol-documentation sym)
  40   (let* ([val (value sym (symbol-module sym))]
  41          [sign (autodoc* sym)])
  42     (and sign
  43          (list (cons 'signature (autodoc* sym #f))
  44                (cons 'docstring (docstring sym val sign))))))
  45
  46 (define (docstring sym val sign)
  47   (let* ([mod (assoc 'module (cdr sign))]
  48          [mod (if mod (cdr mod) "<unknown>")]
  49          [id (namespace-symbol->identifier sym)]
  50          [desc (if (identifier? id) (format "~%~%~a" (describe id sym)) "")])
  51     (if val
  52         (format "A ~a in module ~a.~a~a~a"
  53                 (if (procedure? val) "procedure" "variable")
  54                 mod
  55                 (if (procedure? val)
  56                     ""
  57                     (format "~%~%Value:~%~%  ~a" val))
  58                 (if (has-contract? val)
  59                     (format "~%~%Contract:~%~%  ~a"
  60                             (contract-name (value-contract val)))
  61                     "")
  62                 desc)
  63         (format "An identifier in module ~a.~a" mod desc))))
  64
  65 ;; Lifted from Eli's interactive.rkt
  66 (define (describe id s)
  67   (define b (identifier-binding id))
  68   (cond
  69    [(not b) (format "`~s' is a toplevel (or unbound) identifier." s)]
  70    [(eq? b 'lexical) (format "`~s' is a lexical identifier." s)]
  71    [(or (not (list? b)) (not (= 7 (length b))))
  72     "*** internal error, racket changed ***"]
  73    [else
  74     (let-values ([(source-mod source-id
  75                    nominal-source-mod nominal-source-id
  76                    source-phase import-phase
  77                    nominal-export-phase)
  78                   (apply values b)])
  79       (let ([aliased (not (eq? s source-id))]
  80             [for-syn (eqv? source-phase 1)]
  81             [amod (not (equal? source-mod nominal-source-mod))]
  82             [aid (not (eq? s nominal-source-id))])
  83         (if (or aliased for-syn amod aid)
  84             (string-append
  85              "Defined"
  86              (if for-syn " for syntax" "")
  87              (if aliased (format " as `~s' " source-id) "")
  88              (if amod
  89                  (format " in module ~a\nand required~a in module ~a"
  90                          (module-path-index->name source-mod)
  91                          (if (eqv? import-phase 1) "-for-syntax" "")
  92                          (module-path-index->name nominal-source-mod))
  93                  "")
  94              (if aid
  95                  (format ",\nwhere it is defined as `~s'" nominal-source-id)
  96                  "")
  97              ".")
  98             "")))]))
  99
 100 (define (value id mod)
 101   (with-handlers ([exn? (const #f)])
 102     (dynamic-require mod id (const #f))))
 103
 104 (define (autodoc ids)
 105   (if (not (list? ids))
 106       '()
 107       (map (lambda (id) (or (autodoc* id) (list id))) ids)))
 108
 109 (define (autodoc* id (extra #t))
 110   (define (val)
 111     (with-handlers ([exn? (const "")])
 112       (parameterize ([error-print-width 60])
 113         (format "~.a" (namespace-variable-value id)))))
 114   (and
 115    (symbol? id)
 116    (let* ([loc (symbol-location* id)]
 117           [name (car loc)]
 118           [path (cdr loc)]
 119           [sgns (and path (find-signatures path name id))]
 120           [value (if (and extra sgns (not (list? sgns)))
 121                      (list (cons 'value (val)))
 122                      '())]
 123           [mod (if (and extra sgns path)
 124                    (list (cons 'module
 125                                (module-path-name->name path)))
 126                    '())])
 127      (and sgns
 128           `(,id
 129             (name . ,name)
 130             (args ,@(if (list? sgns) (map format-signature sgns) '()))
 131             ,@value
 132             ,@mod)))))
 133
 134 (define (format-signature sign)
 135   (if (signature? sign)
 136       `((required ,@(signature-required sign))
 137         (optional ,@(signature-optional sign)
 138                   ,@(let ((rest (signature-rest sign)))
 139                       (if rest (list "...") '())))
 140         (key ,@(signature-keys sign)))
 141       '()))
 142
 143 (define signatures (make-hash))
 144
 145 (struct signature (required optional keys rest))
 146
 147 (define (find-signatures path name local-name)
 148   (let ([path (if (path? path) (path->string path) path)])
 149     (hash-ref! (hash-ref! signatures
 150                           path
 151                           (lambda () (parse-signatures path)))
 152                name
 153                (lambda () (infer-signatures local-name)))))
 154
 155 (define (parse-signatures path)
 156   (let ([result (make-hasheq)])
 157     (with-handlers ([exn? (lambda (e) result)])
 158       (with-input-from-file path
 159         (lambda ()
 160           (parameterize ([read-accept-reader #t])
 161             (let loop ([stx (read-syntax path)])
 162               (cond [(eof-object? stx) void]
 163                     [(syntax->datum stx) =>
 164                      (lambda (datum)
 165                        (parse-datum! datum result)
 166                        (loop (read-syntax path)))]
 167                     [else void]))))))
 168     result))
 169
 170 (define (parse-datum! datum store)
 171   (with-handlers ([exn? (lambda (_) void)])
 172     (match datum
 173       [`(module ,name ,lang (#%module-begin . ,forms))
 174        (for-each (lambda (f) (parse-datum! f store)) forms)]
 175       [`(module ,name ,lang . ,forms)
 176        (for-each (lambda (f) (parse-datum! f store)) forms)]
 177       [`(define ((,name . ,formals) . ,_) . ,_)
 178        (add-signature! name formals store)]
 179       [`(define (,name . ,formals) . ,_)
 180        (add-signature! name formals store)]
 181       [`(define ,name (lambda ,formals . ,_))
 182        (add-signature! name formals store)]
 183       [`(define ,name (case-lambda ,clauses ...))
 184        (for-each (lambda (c) (add-signature! name (car c) store))
 185                  (reverse clauses))]
 186       [`(,(or 'struct 'define-struct) ,name ,(? symbol? _)
 187          ,(list formals ...) . ,_)
 188        (add-signature! name formals store)]
 189       [`(,(or 'struct 'define-struct) ,name ,(list formals ...) . ,_)
 190        (add-signature! name formals store)]
 191       [`(define-for-syntax (,name . ,formals) . ,_)
 192        (add-signature! name formals store)]
 193       [`(define-for-syntax ,name (lambda ,formals . ,_))
 194        (add-signature! name formals store)]
 195       [`(define-syntax-rule (,name . ,formals) . ,_)
 196        (add-signature! name formals store)]
 197       [`(define-syntax ,name (syntax-rules ,specials . ,clauses))
 198        (for-each (lambda (c) (add-syntax-signature! name (cdar c) store))
 199                  (reverse clauses))]
 200       [`(define-syntax ,name (lambda ,_ (syntax-case ,_ . ,clauses)))
 201        (for-each (lambda (c) (add-syntax-signature! name (cdar c) store))
 202                  (reverse clauses))]
 203       [_ void])))
 204
 205 (define (add-signature! name formals store)
 206   (when (symbol? name)
 207     (hash-set! store
 208                name
 209                (cons (parse-formals formals)
 210                      (hash-ref store name '())))))
 211
 212 (define (add-syntax-signature! name formals store)
 213   (when (symbol? name)
 214     (hash-set! store
 215                name
 216                (cons (signature formals '() '() #f)
 217                      (hash-ref store name '())))))
 218
 219 (define (parse-formals formals)
 220   (let loop ([formals formals] [req '()] [opt '()] [keys '()])
 221     (cond [(null? formals)
 222            (signature (reverse req) (reverse opt) (reverse keys) #f)]
 223           [(symbol? formals)
 224            (signature (reverse req) (reverse opt) (reverse keys) formals)]
 225           [(pair? (car formals)) (loop (cdr formals)
 226                                        req
 227                                        (cons (car formals) opt)
 228                                        keys)]
 229           [(keyword? (car formals)) (let* ((kname (car formals))
 230                                            (arg-id (cadr formals))
 231                                            (name (if (pair? arg-id)
 232                                                      (list kname
 233                                                            (cadr arg-id))
 234                                                      (list kname))))
 235                                       (loop (cddr formals)
 236                                             req
 237                                             opt
 238                                             (cons name keys)))]
 239           [else (loop (cdr formals) (cons (car formals) req) opt keys)])))
 240
 241 (define (infer-signatures name)
 242   (with-handlers ([exn:fail:syntax? (const `(,(signature '(...) '() '() #f)))]
 243                   [exn:fail:contract:variable? (const #f)])
 244     (let ([v (namespace-variable-value name)])
 245       (if (procedure? v)
 246           (arity->signatures (procedure-arity v))
 247           'variable))))
 248
 249 (define (arity->signatures arity)
 250   (define (args count) (build-list count (const '_)))
 251   (define (arity->signature arity)
 252     (cond [(number? arity)
 253            (signature (args arity) '() '() #f)]
 254           [(arity-at-least? arity)
 255            (signature (args (arity-at-least-value arity)) '() '() 'rest)]))
 256   (define (conseq? lst)
 257     (cond [(< (length lst) 2) (number? (car lst))]
 258           [(and (number? (car lst))
 259                 (number? (cadr lst))
 260                 (eqv? (+ 1 (car lst)) (cadr lst)))
 261            (conseq? (cdr lst))]
 262           [else #f]))
 263   (cond [(and (list? arity) (conseq? arity))
 264          (let ((mi (apply min arity))
 265                (ma (apply max arity)))
 266            (list (signature (args mi) (args (- ma mi)) '() #f)))]
 267         [(list? arity) (map arity->signature arity)]
 268         [else (list (arity->signature arity))]))
 269
 270 (define (update-signature-cache path (form #f))
 271   (when (and (string? path)
 272              (or (not form)
 273                  (and (list? form)
 274                       (not (null? form))
 275                       (memq (car form)
 276                             '(define-syntax-rule struct
 277                                define-syntax define set! define-struct)))))
 278     (hash-remove! signatures path)))
 279
 280 (define (module-exports mod)
 281   (define (contracted id)
 282     (let ([v (value id mod)])
 283       (if (has-contract? v)
 284           (list id (cons 'info (contract-name (value-contract v))))
 285           (entry id))))
 286   (define (entry id)
 287     (let ((sign (eval `(,autodoc* ',id #f)
 288                       (module-spec->namespace mod #f #f))))
 289       (if sign (list id (cons 'signature sign)) (list id))))
 290   (define (classify-ids ids)
 291     (let loop ([ids ids] [procs '()] [vars '()])
 292       (cond [(null? ids)
 293              `((procs ,@(map entry (reverse procs)))
 294                (vars ,@(map list (reverse vars))))]
 295             [(procedure? (value (car ids) mod))
 296              (loop (cdr ids) (cons (car ids) procs) vars)]
 297             [else (loop (cdr ids) procs (cons (car ids) vars))])))
 298   (let-values ([(ids syn) (module-identifiers mod)])
 299     `(,@(classify-ids ids)
 300       (syntax ,@(map contracted syn))
 301       (modules ,@(map list (or (submodules mod) '()))))))