scheme/racket/geiser/autodoc.rkt

   1 ;;; autodoc.rkt -- suport for autodoc echo
   2
   3 ;; Copyright (C) 2009, 2010, 2011, 2012 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   (map (lambda (id) (or (autodoc* id) (list id)))
 106        (if (list? ids) ids '())))
 107
 108 (define (autodoc* id (extra #t))
 109   (define (val)
 110     (with-handlers ([exn? (const "")])
 111       (parameterize ([error-print-width 60])
 112         (format "~.a" (namespace-variable-value id)))))
 113   (and
 114    (symbol? id)
 115    (let* ([loc (symbol-location* id)]
 116           [name (car loc)]
 117           [path (cdr loc)]
 118           [sgns (and path (find-signatures path name id))]
 119           [value (if (and extra sgns (not (list? sgns)))
 120                      (list (cons "value" (val)))
 121                      '())]
 122           [mod (if (and extra sgns path)
 123                    (list (cons "module"
 124                                (module-path-name->name path)))
 125                    '())])
 126      (and sgns
 127           `(,id
 128             ("name" . ,name)
 129             ("args" ,@(if (list? sgns) (map format-signature sgns) '()))
 130             ,@value
 131             ,@mod)))))
 132
 133 (define (format-signature sign)
 134   (if (signature? sign)
 135       `(("required" ,@(signature-required sign))
 136         ("optional" ,@(signature-optional sign)
 137          ,@(let ((rest (signature-rest sign)))
 138              (if rest (list "...") '())))
 139         ("key" ,@(signature-keys sign)))
 140       '()))
 141
 142 (define signatures (make-hash))
 143
 144 (struct signature (required optional keys rest))
 145
 146 (define (find-signatures path name local-name)
 147   (let ([path (if (path? path) (path->string path) path)])
 148     (hash-ref! (hash-ref! signatures
 149                           path
 150                           (lambda () (parse-signatures path)))
 151                name
 152                (lambda () (infer-signatures local-name)))))
 153
 154 (define (parse-signatures path)
 155   (let ([result (make-hasheq)])
 156     (with-handlers ([exn? (lambda (e) result)])
 157       (with-input-from-file path
 158         (lambda ()
 159           (parameterize ([read-accept-reader #t])
 160             (let loop ([stx (read-syntax path)])
 161               (cond [(eof-object? stx) void]
 162                     [(syntax->datum stx) =>
 163                      (lambda (datum)
 164                        (parse-datum! datum result)
 165                        (loop (read-syntax path)))]
 166                     [else void]))))))
 167     result))
 168
 169 (define (parse-datum! datum store)
 170   (with-handlers ([exn? (lambda (_) void)])
 171     (match datum
 172       [`(module ,name ,lang (#%module-begin . ,forms))
 173        (for-each (lambda (f) (parse-datum! f store)) forms)]
 174       [`(module ,name ,lang . ,forms)
 175        (for-each (lambda (f) (parse-datum! f store)) forms)]
 176       [`(define ((,name . ,formals) . ,_) . ,_)
 177        (add-signature! name formals store)]
 178       [`(define (,name . ,formals) . ,_)
 179        (add-signature! name formals store)]
 180       [`(define ,name (lambda ,formals . ,_))
 181        (add-signature! name formals store)]
 182       [`(define ,name (case-lambda ,clauses ...))
 183        (for-each (lambda (c) (add-signature! name (car c) store))
 184                  (reverse clauses))]
 185       [`(,(or 'struct 'define-struct) ,name ,(? symbol? _)
 186          ,(list formals ...) . ,_)
 187        (add-signature! name formals store)]
 188       [`(,(or 'struct 'define-struct) ,name ,(list formals ...) . ,_)
 189        (add-signature! name formals store)]
 190       [`(define-for-syntax (,name . ,formals) . ,_)
 191        (add-signature! name formals store)]
 192       [`(define-for-syntax ,name (lambda ,formals . ,_))
 193        (add-signature! name formals store)]
 194       [`(define-syntax-rule (,name . ,formals) . ,_)
 195        (add-signature! name formals store)]
 196       [`(define-syntax ,name (syntax-rules ,specials . ,clauses))
 197        (for-each (lambda (c) (add-syntax-signature! name (cdar c) store))
 198                  (reverse clauses))]
 199       [`(define-syntax ,name (lambda ,_ (syntax-case ,_ . ,clauses)))
 200        (for-each (lambda (c) (add-syntax-signature! name (cdar c) store))
 201                  (reverse clauses))]
 202       [`(define-type ,_ . ,cases)
 203        (for-each (lambda (c) (add-signature! (car c) (cdr c) store)) cases)]
 204       [_ void])))
 205
 206 (define (add-signature! name formals store)
 207   (when (symbol? name)
 208     (hash-set! store
 209                name
 210                (cons (parse-formals formals)
 211                      (hash-ref store name '())))))
 212
 213 (define (add-syntax-signature! name formals store)
 214   (when (symbol? name)
 215     (hash-set! store
 216                name
 217                (cons (signature formals '() '() #f)
 218                      (hash-ref store name '())))))
 219
 220 (define (parse-formals formals)
 221   (let loop ([formals formals] [req '()] [opt '()] [keys '()])
 222     (cond [(null? formals)
 223            (signature (reverse req) (reverse opt) (reverse keys) #f)]
 224           [(symbol? formals)
 225            (signature (reverse req) (reverse opt) (reverse keys) formals)]
 226           [(pair? (car formals)) (loop (cdr formals)
 227                                        req
 228                                        (cons (car formals) opt)
 229                                        keys)]
 230           [(keyword? (car formals)) (let* ((kname (car formals))
 231                                            (arg-id (cadr formals))
 232                                            (name (if (pair? arg-id)
 233                                                      (list kname
 234                                                            (cadr arg-id))
 235                                                      (list kname))))
 236                                       (loop (cddr formals)
 237                                             req
 238                                             opt
 239                                             (cons name keys)))]
 240           [else (loop (cdr formals) (cons (car formals) req) opt keys)])))
 241
 242 (define (infer-signatures name)
 243   (with-handlers ([exn:fail:syntax? (const `(,(signature '(...) '() '() #f)))]
 244                   [exn:fail:contract:variable? (const #f)])
 245     (let ([v (namespace-variable-value name)])
 246       (if (procedure? v)
 247           (arity->signatures (procedure-arity v))
 248           'variable))))
 249
 250 (define (arity->signatures arity)
 251   (define (args count) (build-list count (const '_)))
 252   (define (arity->signature arity)
 253     (cond [(number? arity)
 254            (signature (args arity) '() '() #f)]
 255           [(arity-at-least? arity)
 256            (signature (args (arity-at-least-value arity)) '() '() 'rest)]))
 257   (define (conseq? lst)
 258     (cond [(< (length lst) 2) (number? (car lst))]
 259           [(and (number? (car lst))
 260                 (number? (cadr lst))
 261                 (eqv? (+ 1 (car lst)) (cadr lst)))
 262            (conseq? (cdr lst))]
 263           [else #f]))
 264   (cond [(and (list? arity) (conseq? arity))
 265          (let ((mi (apply min arity))
 266                (ma (apply max arity)))
 267            (list (signature (args mi) (args (- ma mi)) '() #f)))]
 268         [(list? arity) (map arity->signature arity)]
 269         [else (list (arity->signature arity))]))
 270
 271 (define (update-signature-cache path (form #f))
 272   (when (and (string? path)
 273              (or (not form)
 274                  (and (list? form)
 275                       (not (null? form))
 276                       (memq (car form)
 277                             '(define-syntax-rule struct
 278                                define-syntax define set! define-struct)))))
 279     (hash-remove! signatures path)))
 280
 281 (define (module-exports mod)
 282   (define (contracted id)
 283     (let ([v (value id mod)])
 284       (if (has-contract? v)
 285           (list id (cons "info" (contract-name (value-contract v))))
 286           (entry id))))
 287   (define (entry id)
 288     (let ((sign (eval `(,autodoc* ',id #f)
 289                       (module-spec->namespace mod #f #f))))
 290       (if sign (list id (cons "signature" sign)) (list id))))
 291   (define (classify-ids ids)
 292     (let loop ([ids ids] [procs '()] [vars '()])
 293       (cond [(null? ids)
 294              `(("procs" ,@(map entry (reverse procs)))
 295                ("vars" ,@(map list (reverse vars))))]
 296             [(procedure? (value (car ids) mod))
 297              (loop (cdr ids) (cons (car ids) procs) vars)]
 298             [else (loop (cdr ids) procs (cons (car ids) vars))])))
 299   (let-values ([(ids syn) (module-identifiers mod)])
 300     `(,@(classify-ids ids)
 301       ("syntax" ,@(map contracted syn))
 302       ("modules" ,@(map list (or (submodules mod) '()))))))