scheme/racket/geiser/autodoc.rkt

   1 ;;; autodoc.rkt -- suport for autodoc echo
   2
   3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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 (_) (eval `(help ,symbol)))])
  29         (eval `(help ,symbol #:from ,(ensure-module-spec mod))))))
  30
  31 (define (get-mod-help mod)
  32   (let-values ([(ids syns) (module-identifiers mod)])
  33     (let ([sym (cond [(not (null? syns)) (car syns)]
  34                      [(not (null? ids)) (car ids)]
  35                      [else #f])])
  36       (and sym (get-help sym mod)))))
  37
  38 (define (symbol-documentation sym)
  39   (let* ([val (value sym (symbol-module sym))]
  40          [sign (autodoc* sym)])
  41     (and sign
  42          (list (cons "signature" (autodoc* sym #f))
  43                (cons "docstring" (docstring sym val sign))))))
  44
  45 (define (docstring sym val sign)
  46   (let* ([mod (assoc "module" (cdr sign))]
  47          [mod (if mod (cdr mod) "<unknown>")]
  48          [id (namespace-symbol->identifier sym)]
  49          [desc (if (identifier? id) (format "~%~%~a" (describe id sym)) "")])
  50     (if val
  51         (format "A ~a in module ~a.~a~a~a"
  52                 (if (procedure? val) "procedure" "variable")
  53                 mod
  54                 (if (procedure? val)
  55                     ""
  56                     (format "~%~%Value:~%~%  ~a" val))
  57                 (if (has-contract? val)
  58                     (format "~%~%Contract:~%~%  ~a"
  59                             (contract-name (value-contract val)))
  60                     "")
  61                 desc)
  62         (format "An identifier in module ~a.~a" mod desc))))
  63
  64 ;; Lifted from Eli's interactive.rkt
  65 (define (describe id s)
  66   (define b (identifier-binding id))
  67   (cond
  68    [(not b) (format "`~s' is a toplevel (or unbound) identifier." s)]
  69    [(eq? b 'lexical) (format "`~s' is a lexical identifier." s)]
  70    [(or (not (list? b)) (not (= 7 (length b))))
  71     "*** internal error, racket changed ***"]
  72    [else
  73     (let-values ([(source-mod source-id
  74                    nominal-source-mod nominal-source-id
  75                    source-phase import-phase
  76                    nominal-export-phase)
  77                   (apply values b)])
  78       (let ([aliased (not (eq? s source-id))]
  79             [for-syn (eqv? source-phase 1)]
  80             [amod (not (equal? source-mod nominal-source-mod))]
  81             [aid (not (eq? s nominal-source-id))])
  82         (if (or aliased for-syn amod aid)
  83             (string-append
  84              "Defined"
  85              (if for-syn " for syntax" "")
  86              (if aliased (format " as `~s' " source-id) "")
  87              (if amod
  88                  (format " in module ~a\nand required~a in module ~a"
  89                          (module-path-index->name source-mod)
  90                          (if (eqv? import-phase 1) "-for-syntax" "")
  91                          (module-path-index->name nominal-source-mod))
  92                  "")
  93              (if aid
  94                  (format ",\nwhere it is defined as `~s'" nominal-source-id)
  95                  "")
  96              ".")
  97             "")))]))
  98
  99 (define (value id mod)
 100   (with-handlers ([exn? (const #f)])
 101     (dynamic-require mod id (const #f))))
 102
 103 (define (autodoc ids)
 104   (map (lambda (id) (or (autodoc* id) (list id)))
 105        (if (list? ids) ids '())))
 106
 107 (define (autodoc* id (extra #t))
 108   (define (val)
 109     (with-handlers ([exn? (const "")])
 110       (parameterize ([error-print-width 60])
 111         (format "~.a" (namespace-variable-value id)))))
 112   (and
 113    (symbol? id)
 114    (let* ([loc (symbol-location* id)]
 115           [name (car loc)]
 116           [path (cdr loc)]
 117           [sgns (and path (find-signatures path name id))]
 118           [value (if (and extra sgns (not (list? sgns)))
 119                      (list (cons "value" (val)))
 120                      '())]
 121           [mod (if (and extra sgns path)
 122                    (list (cons "module"
 123                                (module-path-name->name path)))
 124                    '())])
 125      (and sgns
 126           `(,id
 127             ("name" . ,name)
 128             ("args" ,@(if (list? sgns) (map format-signature sgns) '()))
 129             ,@value
 130             ,@mod)))))
 131
 132 (define (format-signature sign)
 133   (if (signature? sign)
 134       `(("required" ,@(signature-required sign))
 135         ("optional" ,@(signature-optional sign)
 136          ,@(let ((rest (signature-rest sign)))
 137              (if rest (list "...") '())))
 138         ("key" ,@(signature-keys sign)))
 139       '()))
 140
 141 (define signatures (make-hash))
 142
 143 (struct signature (required optional keys rest))
 144
 145 (define (find-signatures path name local-name)
 146   (let ([path (if (path? path) (path->string path) path)])
 147     (hash-ref! (hash-ref! signatures
 148                           path
 149                           (lambda () (parse-signatures path)))
 150                name
 151                (lambda () (infer-signatures local-name)))))
 152
 153 (define (parse-signatures path)
 154   (let ([result (make-hasheq)])
 155     (with-handlers ([exn? (lambda (e) result)])
 156       (with-input-from-file path
 157         (lambda ()
 158           (parameterize ([read-accept-reader #t])
 159             (let loop ([stx (read-syntax path)])
 160               (cond [(eof-object? stx) void]
 161                     [(syntax->datum stx) =>
 162                      (lambda (datum)
 163                        (parse-datum! datum result)
 164                        (loop (read-syntax path)))]
 165                     [else void]))))))
 166     result))
 167
 168 (define (parse-datum! datum store)
 169   (with-handlers ([exn? (lambda (_) void)])
 170     (match datum
 171       [`(module ,name ,lang (#%module-begin . ,forms))
 172        (for-each (lambda (f) (parse-datum! f store)) forms)]
 173       [`(module ,name ,lang . ,forms)
 174        (for-each (lambda (f) (parse-datum! f store)) forms)]
 175       [`(define ((,name . ,formals) . ,_) . ,_)
 176        (add-signature! name formals store)]
 177       [`(define (,name . ,formals) . ,_)
 178        (add-signature! name formals store)]
 179       [`(define ,name (lambda ,formals . ,_))
 180        (add-signature! name formals store)]
 181       [`(define ,name (case-lambda ,clauses ...))
 182        (for-each (lambda (c) (add-signature! name (car c) store))
 183                  (reverse clauses))]
 184       [`(,(or 'struct 'define-struct) ,name ,(? symbol? _)
 185          ,(list formals ...) . ,_)
 186        (add-signature! name formals store)]
 187       [`(,(or 'struct 'define-struct) ,name ,(list formals ...) . ,_)
 188        (add-signature! name formals store)]
 189       [`(define-for-syntax (,name . ,formals) . ,_)
 190        (add-signature! name formals store)]
 191       [`(define-for-syntax ,name (lambda ,formals . ,_))
 192        (add-signature! name formals store)]
 193       [`(define-syntax-rule (,name . ,formals) . ,_)
 194        (add-signature! name formals store)]
 195       [`(define-syntax ,name (syntax-rules ,specials . ,clauses))
 196        (for-each (lambda (c) (add-syntax-signature! name (cdar c) store))
 197                  (reverse clauses))]
 198       [`(define-syntax ,name (lambda ,_ (syntax-case ,_ . ,clauses)))
 199        (for-each (lambda (c) (add-syntax-signature! name (cdar c) store))
 200                  (reverse clauses))]
 201       [`(define-type ,_ . ,cases)
 202        (for-each (lambda (c) (add-signature! (car c) (cdr c) store)) cases)]
 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) '()))))))