#lang racket/gui
(require (prefix-in scrbl: scribble/reader)
         racket/runtime-path
         (for-syntax racket/base)
         framework
         )

(provide item-callback)

;;;    ***************************************    ;;;
;;;    ***   On-Screen Signature Display   ***    ;;;
;;;    ***************************************    ;;;

;;; Laurent Orseau <laurent orseau gmail com> -- 2012-04-26


#| TODO:
- display module of the signature
- use an editor instead of canvas?
- warning: a "signature" seems to have a special meaning in Racket
- instead of showing all definition forms, show only one and allow cycling with shortkey/mouse?
|#


#| *** How it works ***

** Usage:

Put the cursor in the middle of a Racket function symbol, and
press the keyboard shortcut for this script, or launch it from the menu.
The signature of the function/form should appear in a frame, if it can find it.

To hide the frame, press the shortcut again.

The frame can be moved around by dragging it.

The default shortcut is suitable for my keyboard, but probably not for yours; 
change it as you see fit.


** Notes:

I could not figure how to use xref, so instead the script parses 
the .scrbl files in racket's scribblings directory.
Since this can take a few seconds, the generated dict is saved to a file,
so that the parsing is only done once (if you ever need to force reparsing, 
simply remove the file in the script subdirectory, it will regenerate it at the next call).

The script does not use syntax information, and in particular 
from where the bindings are imported.

Some scrbl files contain a #reader line that breaks `read-inside'.
For such cases, the file is loaded as a string, the offending #reader is removed
and the contents are read from the string again.
In case the file cannot be read anyway, it is skipped. (none as of today)

Not all definitions are parsed yet (e.g., no parameter), but the number should grow,
and not all information is reported (e.g., no contract for forms yet).

The code is a mess, and I did not bother much to make it better...

|#

;===========================;
;=== Parsing scribblings ===;
;===========================;


;; List of dirs for which to parse the scribble files.
;; Put the most common ones at the end, so that their definitions appear at the top.
(define scribblings-dirs
  '("slideshow"
    "scribble"
    "gui"
    "draw"
    "reference"
    ))

; for format
(print-as-expression #f)
(print-reader-abbreviations #t)

;; Returns the s-exp containing all s-exp in the input stream
;; in: input-stream?
(define (read-scrbl in [file ""])
  ;(void (read-language in)) ; don't care about the #lang line
  (scrbl:read-inside in))
  ;(syntax->datum (scrbl:read-syntax-inside file in)))

;; Loads all the defproc forms from a given file into the dictionary.
(define (index-defs dic file)
  (define f-in (open-input-file file))
  
  ; Try to lead directly from the file.
  ; If that fails, load the file into a string,
  ; remove all occurrences of #reader syntax,
  ; and try again from that string.
  ;(printf "File ~a\n" file)
  (define all 
    (with-handlers ([exn:fail? 
                     (λ _ 
                       (printf "Problem with file ~a, trying something else...\n" file)
                       (read-scrbl
                        (open-input-string
                         (regexp-replace* #px"#reader\\s*[^'\"\\(\\[\\{\\)\\}\\]\\s]+\\s*" ;(regexp-quote "#reader")
                                          (file->string file)
                                          ""))
                        file))])
      (read-scrbl f-in))) 
  
  (define (add-entry key l)
    (hash-set! dic key
               (cons l (hash-ref dic key '()))))
  
  (define (parse-class class-id subs)
    (for ([s subs])
      (match s
        [(list-rest 'defconstructor args text)
         (add-entry class-id (list 'defconstructor class-id args))]
        [(list-rest 'defmethod '#:mode mode (list-rest id args) cont-out text)
         (add-entry id (list 'defmethod class-id id args cont-out))]
        [(list-rest 'defmethod (list-rest id args) cont-out text)
         (add-entry id (list 'defmethod class-id id args cont-out))]
        [(list-rest 'defmethod* (list (list (list-rest ids argss) cont-outs) ...) text)
         (for ([id ids][args argss][cont-out cont-outs])
           (add-entry id (list 'defmethod class-id id args cont-out)))]
        [else #f])))
  
  ; matches only the "top-level" forms, i.e. does not go into examples, etc.
  ; (hopefully there aren't many false positives/negatives)
  (define (parse-all subs)
    (for ([s subs])
      (match s
        [(list-rest 'defproc (list-rest name args) cont-out text)
         (add-entry name (list 'defproc name args cont-out))]
        [(list-rest 'defproc* (list (list (list-rest names argss) cont-outs) ...) text)
         (for ([name names] [args argss] [cont-out cont-outs])
           (add-entry name (list 'defproc name args cont-out)))]
        [(list-rest (or 'defclass 'defclass/title) id super intf-ids subs)
         (add-entry id (list 'defclass id super intf-ids))
         (parse-class id subs)]
        [(list-rest (or 'definterface 'definterface/title) id intf-ids subs)
         (add-entry id (list 'definterface id intf-ids))
         (parse-class id subs)]
        [(list-rest (or 'defform 'defform/subs) (list-rest id args) text) ; TODO: + contracts & literals + subs
         (add-entry id (list 'defform id args))]
        [(list-rest (or 'defform* 'defform*/subs) (list (list-rest ids argss) ...) text)
         (for ([id ids][args argss])
           (add-entry id (list 'defform id args)))]
        [(list-rest 'deftogether subs text)
         (parse-all subs)]
        [else #f]
        )))
  
  (parse-all all)
  )

;; Displays a message in a (non-modal) frame.
(define (frame-message title message [show? #f] #:parent [parent #f])
  (define fr (new frame% [parent parent] [label title]))
  (new message% [parent fr] [label message])
  (when show? (send fr show #t))
  fr)

(define-runtime-path idx-file (build-path "def-index" "def-index.rktd"))
(make-directory* (path-only idx-file))

;; Constructs the index file if it does not exist, or load it,
;; and returns the generated index:
(define (create-index)
  
  (define (scribblings-path subdir)
    (build-path (find-system-path 'collects-dir)
                "scribblings" subdir))
  
  (if (file-exists? idx-file)
      (with-input-from-file idx-file read)
      (let* ([dic (make-hash)]
             [fr (frame-message "Making index" "Constructing documentation index for the first time.\nPlease wait..." #t)]
             [read-scrbl-dir 
              (λ(dir)
              (for ([f (in-directory dir)])
                (when (equal? (filename-extension f) #"scrbl")
                  ;(printf "Scribble file: ~a ~n" f)
                  (with-handlers ([exn:fail? (λ _ (printf "Warning: Could not read file ~a~n" f))])
                    (index-defs dic f)
                    ))))])
        
        (for ([dir scribblings-dirs])
          (read-scrbl-dir (scribblings-path dir)))
        
        (with-output-to-file idx-file
          (λ()(write dic)))
        (send fr show #f)
        dic)))

;=====================================;
;=== Formatting entries as strings ===;
;=====================================;

;; Helpers for def-name->string-list
(define (arg->head-string arg)
  (match arg
    [(list name cont)                      (symbol->string name)]
    [(list (? keyword? kw) name cont)      (format "~v ~v" kw name)]
    [(list name cont val)                  (format "[~v]" name)]
    [(list (? keyword? kw) name cont val)  (format "[~v ~v]" kw name)]
    ['...                                  "..."]
    ['...+                                 "...+"]
    ))

(define (arg->sig-string arg)
  (match arg
    [(list name cont)                      (format "  ~v: ~v" name cont)]
    [(list (? keyword? kw) name cont)      (format "  ~v: ~v" name cont)]
    [(list name cont val)                  (format "  ~v: ~v = ~v" name cont val)]
    [(list (? keyword? kw) name cont val)  (format "  ~v: ~v = ~v" name cont val)]
    ['...                                  #f]
    ['...+                                 #f]
    ))

;; Returns the list of signature in line-splitted string-format.
;; -> (list def-strings)
;; def-strings : (list string?)
(define (def-name->string-list dic name)
  (define entries (dict-ref dic name #f))
  (if entries
      (for/list ([entry entries])
        (match entry
          [(list 'defclass id super intf-ids)
           (list (format "~v : class?" id)
                 (format "  superclass: ~v" super)
                 (string-join (cons "  extends:" 
                                    (map symbol->string intf-ids))
                              " "))]
          [(list 'definterface id intf-ids)
           (list (format "~v : interface?" id)
                 (string-join (cons "  implements:"
                                    (map symbol->string intf-ids))
                              " "))]
          [(list 'defconstructor class-id args)
           (list* (string-append
                   (format "(new ~v " class-id)
                   (string-join (map arg->head-string args) " ")
                   ")")
                  (filter values (map arg->sig-string args)))]
          [(list 'defmethod class-id id args cont-out)
           (list*
            (string-append
             (format "(send a-~a ~a " class-id id)
             (string-join (map arg->head-string args) " ")
             ") -> "
             (format "~v" cont-out)
             )
            (filter values (map arg->sig-string args))
            )]
          [(list 'defproc id args cont-out)
           (list*
            (string-append
             "("
             (string-join (cons (symbol->string name)
                                (map arg->head-string args)) " ")
             ") -> "
             (format "~v" cont-out)
             )
            (filter values (map arg->sig-string args))
            )]
          [(list 'defform id args)
           (list (format "~v" (cons id args)))]
          [else (list (format "Unknown parsed form: ~a" entry))]
          ))
      '(("No entry found"))))

; The definition index. Since the script is persitent, it is loaded only once
(define def-index (create-index))

#| TESTS
(dict-ref def-index 'list)
(def-name->string-list def-index 'with-output-to-file)

;|#

;===========;
;=== GUI ===;
;===========;

;;; In the following, a 'text' is a list of strings.

; The font to use for the text
(define label-font
  (send the-font-list find-or-create-font
        8;(- (preferences:get 'framework:standard-style-list:font-size) 2)
        'modern 'normal 'normal #f))

(define inset 2)

; Calculate the minimum sizes of a string
(define (calc-min-sizes dc str label-font)
  (send dc set-font label-font)
  (let-values ([(w h a d) (send dc get-text-extent str label-font)])
    (let ([ans-w (max 0 (inexact->exact (ceiling w)))]
          [ans-h (max 0 (inexact->exact (ceiling h)))])
      (values ans-w ans-h))))

;; Calculate the total size of a text, with inset
(define (dc-text-size dc text label-font)
  (define w-h
    (for/list ([str text])
      (let-values ([(w h) (calc-min-sizes dc str label-font)])
        (list w h))))
  (values
   (+ inset inset (apply max (map car  w-h)))
   (+ inset inset (apply +   (map cadr w-h)))))

;; Draws the text (list of strings) in dc at x y,
;; each string on below the other, left-aligned.
(define (draw-text dc x y text)

  (define black-color  (make-object color% "black"))
  (define bg-color     (make-object color% "wheat"))
    
  (define-values (w h)
    (dc-text-size dc text label-font))
  
  ; background square
  (send dc set-pen (send the-pen-list find-or-create-pen
                         bg-color 1 'solid))
  (send dc set-brush (send the-brush-list find-or-create-brush
                           bg-color 'solid))
  (send dc draw-rectangle x y w h)
  
  ; boundaries
  (send dc set-pen (send the-pen-list find-or-create-pen
                         black-color 1 'solid))
  (send dc draw-line x y (+ x w) y)
  (send dc draw-line (+ x w) y (+ x w) (+ y h))
  (send dc draw-line (+ x w) (+ y h) x (+ y h))
  (send dc draw-line x (+ y h) x y)
  
  ; draw text into the square
  ; set colors, fonts, etc.
  (send dc set-text-foreground black-color)
  (send dc set-text-background bg-color)
  (send dc set-font label-font)
  (define ytot
    (for/fold ([ytot (+ y inset)])
      ([str text])
      (let-values ([(w h) (calc-min-sizes dc str label-font)])
        (send dc draw-text str (+ x inset) ytot)
        (values (+ h ytot)))))
  ; return value:
  (values w h))

(define tooltip-frame%
  (class frame%
    (init-field [text '()])
    (super-new [label ""]
               [style '(no-resize-border 
                        no-caption
                        no-system-menu
                        hide-menu-bar
                        float)]
               ;[min-height 400]
               ;[min-width 400]
               [stretchable-width #f]
               [stretchable-height #f]
               )
    
    (define/override (on-subwindow-char e k)
      (when (equal? (send k get-key-code) 'escape)
        (send this show #f))
      #f)
    
    (define hp (new horizontal-panel% [parent this]
                    [alignment '(left top)]))
    
    (new button% [parent hp][label "X"]
         [horiz-margin 0] [vert-margin 0]
         [callback (λ _ (send this show #f))])
    
    (define (this-frame) this)
    
    ;; Internal canvas class
    (define tooltip-canvas%
      (class canvas%
        (define x-start #f)
        (define y-start #f)
        (define/override (on-event ev)
          (when (send ev get-left-down)
            (if (send ev moving?)
                (let ([x (send ev get-x)] [y (send ev get-y)])
                  (let-values ([(x y) (send this client->screen x y)])
                    (send (this-frame) move (- x x-start) (- y y-start))))
                (begin (set! x-start (send ev get-x))
                       (set! y-start (send ev get-y))))))
        (super-new)
        ))
    
    (define cv (new tooltip-canvas% [parent hp]
                    [paint-callback 
                     (λ(cv dc)(draw-text dc 0 0 text))]))
    
    (define/public (set-text t)
      (set! text t)
      (define-values (w h) (dc-text-size (send cv get-dc) text label-font))
      (send cv min-width (+ w 1))
      (send cv min-height (+ h 1))
      (send this reflow-container)
      (send this stretchable-width #f)
      (send this stretchable-height #f)
      (send cv refresh))
    
    (unless (empty? text)
      (set-text text))
    ))

;::::::::::::::::;
;:: The script ::;
;::::::::::::::::;

(define (def-name->text sym)
  (define defs (def-name->string-list def-index sym))
  (append* (add-between defs '(""))))

;; persistent variables, to use always the same ones
(define tooltip-frame #f)
(define last-sym #f)

(define (item-callback str #:editor ed)
  (define start-pos (send ed get-start-position))
  (define end-pos   (send ed get-end-position)) 
  (define start-exp-pos
    (or (send ed get-backward-sexp start-pos) start-pos))
  (define end-exp-pos
    (or (send ed get-forward-sexp (- end-pos 1)) end-pos))
  (define str
    (send ed get-text start-exp-pos end-exp-pos))
  
  (define sym (string->symbol str))
  (define text (def-name->text sym))
  
  (define dc (send ed get-dc))
  
  (unless tooltip-frame
    (set! tooltip-frame (new tooltip-frame%)))
  
  ; if the new sym is the same as the old one,
  ; or if it is an invalid one, hide the frame,
  ; otherwise show it for the new symbol.
  (if (and (eq? sym last-sym) (send tooltip-frame is-shown?))
      (send tooltip-frame show #f)
      (let ()
        (define &x (box #f))
        (define &y (box #f))
        (send ed position-location start-exp-pos &x &y #f #t)
        (define-values (x y) (send ed editor-location-to-dc-location 
                                   (unbox &x) (unbox &y)))
        
        (let-values ([(x y) (send (send ed get-canvas)
                                  client->screen (inexact->exact x) (inexact->exact y))]
                     [(left top) (get-display-left-top-inset)])
          (send tooltip-frame move (- x left) (- y -2 top))
          (send tooltip-frame set-text text)
          (send tooltip-frame show #t)
          (set! last-sym sym)
          )))
  #f)


#| Tests
(define f (new tooltip-frame% 
               [text (def-name->text 'with-output-to-file)]))
(send f show #t)
;|#


; for tests:
#;(with-output-to-file list->string print                   error         make-module-evaluator        make-provide-transformer       list->string          with-output-to-file open-input-output-file	 regexp-replace
    
    button% set-label class get-top-level-window min-height refresh on-move get-x get-cursor focus
    )
; This is a very long line... This is a very long line... This is a very long line... This is a very long line... This is a very long line... This is a very long line... This is a very long line... This is a very long line... This is a very long line... This is a very long line... This is a very long line...