Include type information for DrRacket via 'mouse-over-tooltips

closes #53

Author: lexi-lambda

hackett-lib/hackett/private/base.rkt

@@ -163,7 +163,11 @@
     ; We add the internal definition context’s scope to each temporary identifier to allow them to be
     ; used in reference and binding positions. We’ll need to return these at the end, to allow callers
     ; to arrange for these identifiers to appear in binding positions.
-    (define xs-* (map #{internal-definition-context-introduce intdef-ctx %} xs-))
+    (define xs-* (for/list ([x (in-list xs)]
+                            [x- (in-list xs-)]
+                            [t_x (in-list ts_xs)])
+                   (attach-type (internal-definition-context-introduce intdef-ctx x-) t_x
+                                #:tooltip-src x)))
     (for ([x (in-list xs)]
           [x-* (in-list xs-*)]
           [t_x (in-list ts_xs)])
@@ -308,18 +312,20 @@
 
 (define-syntax-parser @%module-begin
   [(_ form ...)
-   (value-namespace-introduce
-    (syntax/loc this-syntax
-      (#%plain-module-begin- form ...)))])
+   (~> (local-expand (value-namespace-introduce
+                      (syntax/loc this-syntax
+                        (#%plain-module-begin- form ...)))
+                     'module-begin '())
+       apply-current-subst-in-tooltips)])
 
 (define-syntax-parser @%datum
   [(_ . n:exact-integer)
-   (attach-type #'(#%datum . n) (expand-type #'Integer))]
+   (attach-type #'(#%datum . n) (expand-type #'Integer) #:tooltip-src #'n)]
   [(_ . n:number)
    #:when (double-flonum? (syntax-e #'n))
-   (attach-type #'(#%datum . n) (expand-type #'Double))]
+   (attach-type #'(#%datum . n) (expand-type #'Double) #:tooltip-src #'n)]
   [(_ . s:str)
-   (attach-type #'(#%datum . s) (expand-type #'String))]
+   (attach-type #'(#%datum . s) (expand-type #'String) #:tooltip-src #'n)]
   [(_ . x)
    (raise-syntax-error #f "literal not supported" #'x)])
 
@@ -359,7 +365,7 @@
    #:do [(define-values [f- t_f] (τ⇒! #'f))
          (define-values [r- t_r] (τ⇒app! f- (apply-current-subst t_f) #'e
                                          #:src this-syntax))]
-   (attach-type r- t_r)])
+   (attach-type r- t_r #:tooltip-src this-syntax)])
 
 (define-syntax-parser def
   #:literals [:]

hackett-lib/hackett/private/kernel.rkt

@@ -3,7 +3,8 @@
 (require (for-syntax hackett/private/infix
                      racket/base
                      syntax/parse/class/paren-shape
-                     syntax/parse/experimental/template)
+                     syntax/parse/experimental/template
+                     threading)
          syntax/parse/define
 
          (rename-in hackett/private/base
@@ -97,10 +98,14 @@
 
      (define-syntax-parser @%app/prefix
        [(_ f:expr) #'f]
+       [(_ f:expr x:expr)
+        (syntax/loc this-syntax
+          (@%app1 f x))]
        [(_ f:expr x:expr xs:expr ...)
         (quasisyntax/loc this-syntax
-          (@%app/prefix #,(syntax/loc this-syntax
-                            (@%app1 f x))
+          (@%app/prefix #,(~> (syntax/loc this-syntax
+                                (@%app1 f x))
+                              (syntax-property 'omit-type-tooltip #t))
                         xs ...))])
 
      (define-syntax-parser @%app/infix
@@ -110,8 +115,9 @@
         #:fail-unless (andmap #{eq? % 'left} (attribute ops.fixity))
                       "cannot mix left- and right-associative operators in the same infix expression"
         (quasitemplate/loc this-syntax
-          (@%app/infix #,(syntax/loc this-syntax
-                           (@%app/infix a op b))
+          (@%app/infix #,(~> (syntax/loc this-syntax
+                               (@%app/infix a op b))
+                             (syntax-property 'omit-type-tooltip #t))
                        {?@ ops bs} ...))]
        [(_ {~seq as:expr ops:infix-operator} ...+ a:expr op:infix-operator b:expr)
         #:when (eq? 'right (attribute op.fixity))
@@ -120,8 +126,9 @@
                       "cannot mix left- and right-associative operators in the same infix expression"
         (quasitemplate/loc this-syntax
           (@%app/infix {?@ as ops} ...
-                       #,(syntax/loc this-syntax
-                           (@%app/infix a op b))))]
+                       #,(~> (syntax/loc this-syntax
+                               (@%app/infix a op b))
+                             (syntax-property 'omit-type-tooltip #t))))]
        [(_ a:expr op:expr b:expr)
         (syntax/loc this-syntax
           (@%app/prefix op a b))]

hackett-lib/hackett/private/typecheck.rkt

@@ -51,7 +51,8 @@
          current-type-context modify-type-context
          register-global-class-instance! constr->instances lookup-instance!
          reduce-context type-reduce-context
-         attach-type attach-expected get-type get-expected make-typed-var-transformer
+         attach-type attach-expected get-type get-expected apply-current-subst-in-tooltips
+         make-typed-var-transformer
 
          (for-template (all-from-out hackett/private/type-language)
                        local-class-instances @%superclasses-key))
@@ -576,9 +577,51 @@
 
 ;; -------------------------------------------------------------------------------------------------
 
-(define/contract (attach-type stx t)
-  (-> syntax? type? syntax?)
-  (syntax-property stx ': t))
+; To support type tooltips, we attach 'mouse-over-tooltips properties to syntax objects whenever we
+; attach a type, unless the 'omit-type-tooltip property is already present. When we attach these
+; tooltips, we might not know the fully-solved type yet, so we perform a second pass after the module
+; is fully-expanded that applies the current substitution whenever it sees a type. It’s important to
+; apply this substitution while the module is still being expanded, since otherwise, the type context
+; will be empty!
+;
+; To support this, we wrap the type inside a deferred-type-in-tooltip struct. This struct cooperates
+; with the 'mouse-over-tooltips property by being a procedure, so even if we somehow fail to discover
+; the property and evaluate it earlier, we’ll at least get *some* information. When
+; apply-current-subst-in-tooltips is called, however, we evaluate the thunk early and replace the
+; property with the new value, improving the information in the tooltips.
+
+(struct deferred-type-in-tooltip (type)
+  #:property prop:procedure
+  (λ (self) (type->string (apply-current-subst (deferred-type-in-tooltip-type self)))))
+
+(define/contract (attach-type stx t #:tooltip-src [tooltip-src stx])
+  (->* [syntax? type?] [#:tooltip-src any/c] syntax?)
+  (let ([stx* (syntax-property stx ': t)])
+    (if (and (not (syntax-property tooltip-src 'omit-type-tooltip))
+             (syntax-source tooltip-src)
+             (syntax-position tooltip-src)
+             (syntax-span tooltip-src))
+        (syntax-property
+         stx* 'mouse-over-tooltips
+         (syntax-parse tooltip-src
+           ; If it’s a pair, just add the tooltip “on the parens”.
+           [(_ . _)
+            (cons
+             (vector tooltip-src
+                     (sub1 (syntax-position tooltip-src))
+                     (syntax-position tooltip-src)
+                     (deferred-type-in-tooltip t))
+             (vector tooltip-src
+                     (+ (sub1 (syntax-position tooltip-src)) (sub1 (syntax-span tooltip-src)))
+                     (+ (sub1 (syntax-position tooltip-src)) (syntax-span tooltip-src))
+                     (deferred-type-in-tooltip t)))]
+           ; Otherwise, add the tooltip on the whole region.
+           [_
+            (vector tooltip-src
+                    (sub1 (syntax-position tooltip-src))
+                    (+ (sub1 (syntax-position tooltip-src)) (syntax-span tooltip-src))
+                    (deferred-type-in-tooltip t))]))
+        stx*)))
 (define/contract (attach-expected stx t)
   (-> syntax? type? syntax?)
   (syntax-property stx ':⇐ t))
@@ -592,6 +635,17 @@
   (let loop ([val (syntax-property stx ':⇐)])
     (if (pair? val) (loop (car val)) val)))
 
+(define (apply-current-subst-in-tooltips stx)
+  (recursively-adjust-property
+   stx 'mouse-over-tooltips
+   (match-lambda
+     [(vector a b c (? deferred-type-in-tooltip? d))
+      (vector a b c (d))]
+     [other other])))
+
 (define/contract (make-typed-var-transformer x t)
   (-> identifier? type? any)
-  (make-variable-like-transformer (attach-type x t)))
+  (make-variable-like-transformer
+   ; Adjust source location information before calling attach-type so that tooltips end up in the
+   ; right place.
+   (λ (stx) (attach-type (replace-stx-loc x stx) t))))

hackett-lib/hackett/private/util/stx.rkt

@@ -8,7 +8,8 @@
          racket/match
          syntax/parse
          syntax/parse/define
-         syntax/parse/experimental/template)
+         syntax/parse/experimental/template
+         threading)
 
 (provide (contract-out [replace-stx-loc (-> syntax? syntax? syntax?)]
                        [make-variable-like-transformer (-> (or/c syntax? (-> identifier? syntax?))
@@ -17,7 +18,9 @@
                                                                 pattern-expander?)]
                        [preservable-property->expression (-> any/c syntax?)]
                        [generate-bound-temporaries (-> (or/c syntax? list?) (listof identifier?))]
-                       [generate-bound-temporary (-> any/c identifier?)])
+                       [generate-bound-temporary (-> any/c identifier?)]
+                       [adjust-property (-> syntax? any/c (-> any/c any/c) syntax?)]
+                       [recursively-adjust-property (-> syntax? any/c (-> any/c any/c) syntax?)])
          syntax/loc/props quasisyntax/loc/props template/loc/props quasitemplate/loc/props)
 
 ; These two functions are taken with modifications from macrotypes/stx-utils, which implement a
@@ -102,3 +105,32 @@
 (define (generate-bound-temporary [name-base 'g])
   (first (generate-bound-temporaries (list name-base))))
 
+; Modifies the property of a syntax object by applying a procedure to its value. If the syntax object
+; does not contain any such property, the original syntax object is returned. Otherwise, the
+; property’s value is recursively traversed as a tree of cons pairs, and the procedure is applied to
+; each leaf to produce a new result.
+(define (adjust-property stx key proc)
+  (let ([val (syntax-property stx key)])
+    (if val
+        (syntax-property stx key
+                         (let loop ([val val])
+                           (cond [(list? val) (map loop val)]
+                                 [(pair? val) (cons (loop (car val)) (loop (cdr val)))]
+                                 [else (proc val)])))
+        stx)))
+
+; Like adjust-property, but recursively walks the syntax object and applies the function to each
+; subform. Handles arming and disarming as necessary.
+(define (recursively-adjust-property stx key proc)
+  (let loop ([stx stx])
+    (let* ([disarmed (syntax-disarm stx #f)]
+           [result (~> (match (syntax-e disarmed)
+                         [(list a ...) (map loop a)]
+                         [(list* a ..1 b) (append (map loop a) (loop b))]
+                         [a a])
+                       (datum->syntax disarmed _ disarmed disarmed)
+                       (adjust-property key proc)
+                       (syntax-rearm stx))])
+      (when (syntax-tainted? result)
+        (raise-syntax-error 'recursively-adjust-property "could not disarm syntax object" stx))
+      result)))