Improve the implementation of todo! to use the new elaboration system

Author: lexi-lambda

hackett-lib/hackett/prelude.rkt

@@ -6,6 +6,7 @@
          hackett/data/list
          hackett/data/maybe
          hackett/monad/base
+         hackett/todo
 
          (prefix-in prim: hackett/private/prim)
          hackett/private/prim
@@ -14,6 +15,7 @@
 (provide (all-from-out hackett/data/either)
          (all-from-out hackett/data/list)
          (all-from-out hackett/data/maybe)
+         (all-from-out hackett/todo)
 
          (data Unit) (data Bool) (data Tuple) (data Maybe) (data Either) (data List)
          || && not if fst snd

hackett-lib/hackett/private/base.rkt

@@ -27,7 +27,7 @@
          @%superclasses-key @%dictionary-placeholder @%with-dictionary
          define-primop define-base-type
          -> Integer Double String Bytes
-         : λ1 def let letrec todo!)
+         : λ1 def let letrec)
 
 (define-base-type Integer)
 (define-base-type Double)
@@ -444,33 +444,6 @@
                 (attribute fixity.fixity))
              (define- #,id- #,e-))))])
 
-(begin-for-syntax
-  (struct todo-item (full summary) #:prefab))
-
-(define-syntax todo!*
-  (make-elaborating-transformer
-   (syntax-parser
-     [(_ v e ...)
-      (match (syntax-local-elaborate-pass)
-        [(or 'expand 'elaborate)
-         (syntax-local-elaborate-defer this-syntax)]
-        ['finalize
-         (let* ([type-str (type->string (apply-current-subst #'(#%type:wobbly-var v)))]
-                [message (string-append (source-location->prefix this-syntax)
-                                        "todo! with type "
-                                        type-str)])
-           (syntax-property (quasisyntax/loc this-syntax (error '#,message))
-                            'todo (todo-item type-str type-str)))])])))
-
-(define-syntax todo!
-  (make-elaborating-transformer
-   #:allowed-passes '[expand]
-   (syntax-parser
-     [(_ e ...)
-      #:with var (generate-temporary #'t_todo!)
-      (attach-type (syntax-local-elaborate-defer (syntax/loc this-syntax (todo!* var e ...)))
-                   #'(#%type:wobbly-var var))])))
-
 (define-syntax let1
   (make-trampolining-expression-transformer
    (syntax-parser

hackett-lib/hackett/private/deferred-transformer.rkt

@@ -0,0 +1,38 @@
+#lang racket/base
+
+(require (for-syntax racket/base
+                     racket/contract
+                     racket/match
+                     racket/syntax
+
+                     hackett/private/expand+elaborate)
+         syntax/parse/define
+
+         hackett/private/base)
+
+(provide (for-syntax make-expected-type-transformer))
+
+(define-syntax deferred-expected-type-transformer
+  (make-elaborating-transformer
+   (syntax-parser
+     [(_ expected-type proc orig-stx)
+      (match (syntax-local-elaborate-pass)
+        [(or 'expand 'elaborate)
+         (attach-type (syntax-local-elaborate-defer this-syntax) #'expected-type)]
+        ['finalize
+         (τ⇐! #'(do-expected-type-transformer proc orig-stx) #'expected-type)])])))
+
+(define-syntax do-expected-type-transformer
+  (make-elaborating-transformer
+   #:allowed-passes '[finalize]
+   (syntax-parser
+     [(_ proc orig-stx)
+      ((syntax-e #'proc)
+       (attach-expected #'orig-stx (apply-current-subst (get-expected this-syntax))))])))
+
+(begin-for-syntax
+  (define/contract (make-expected-type-transformer proc)
+    (-> (-> syntax? syntax?) (-> syntax? syntax?))
+    (make-elaborating-transformer
+     (λ (stx) (let ([expected-type #`(#%type:wobbly-var #,(generate-temporary))])
+                #`(deferred-expected-type-transformer #,expected-type #,proc #,stx))))))

hackett-lib/hackett/private/kernel.rkt

@@ -20,7 +20,7 @@
                      [λ lambda])
          #%require/only-types combine-in except-in only-in prefix-in rename-in
          provide combine-out except-out prefix-out rename-out for-type module+
-         : def λ let letrec todo!
+         : def λ let letrec
          (for-type #:no-introduce ∀ -> => Integer Double String Bytes
                    (rename-out [@%top #%top]
                                [#%type:app #%app]

hackett-lib/hackett/private/type-language.rkt

@@ -195,9 +195,9 @@
                                  (syntax-track-origin #'t-.residual #'head)
                                  (syntax-track-origin #'expansion #'head))])
 
-  (define (expand-type stx [intdef-ctx #f])
+  (define (expand-type stx [intdef-ctx #f] #:context [context 'expand-type])
     (syntax-parse stx
-      #:context 'expand-type
+      #:context context
       [{~var t (type intdef-ctx)} #'t.expansion]))
 
 ;; ---------------------------------------------------------------------------------------------------

hackett-lib/hackett/todo.rkt

@@ -0,0 +1,23 @@
+#lang hackett/base
+
+(require (only-in racket/base define-syntax for-syntax)
+         (for-syntax racket/base
+                     syntax/srcloc
+                     hackett/private/typecheck)
+         syntax/parse/define
+
+         hackett/private/deferred-transformer
+         (only-in hackett/private/prim error!))
+
+(provide todo!)
+
+(define-syntax todo!
+  (make-expected-type-transformer
+   (syntax-parser
+     [(_ e ...)
+      (let* ([type-str (type->string (get-expected this-syntax))]
+             [message (string-append (source-location->prefix this-syntax)
+                                     "todo! with type "
+                                     type-str)])
+        (syntax-property (quasisyntax/loc this-syntax (error! #,message))
+                         'todo `#s(todo-item ,type-str ,type-str)))])))