Support infix notation in more places, including type aliases

Author: lexi-lambda

hackett-doc/scribblings/hackett/reference.scrbl

@@ -315,7 +315,10 @@ specified controls the fixity used by the associated @racket[type-constructor-id
          (type type-clause type-expr)
          #:grammar
          ([type-clause name-id
-                       (code:line (name-id param-id ...+))])]{
+                       (code:line (name-id param-id ...+))]
+          [maybe-fixity-ann (code:line #:fixity fixity)
+                            (code:line)]
+          [fixity left right])]{
 
 Defines a @deftech{type alias} named @racket[name-id]. Uses of @racket[name-id] are equivalent to
 uses of the type specified in @racket[type-expr]. If @racket[type-clause] is a bare @racket[name-id],
@@ -327,11 +330,6 @@ then @racket[name-id] is bound directly to the type alias.
   (def n : Num 1.5)
   (#:type n))
 
-@margin-note{
-  Type aliases with @racket[param-id]s can only be used with prefix notation, using
-  @racket[(name-id type-argument ...)] rather than
-  @racket[{type-argument name-id type-argument}].}
-
 If @racket[param-id]s are specified, then uses of the type alias must supply as many arguments as
 there are @racket[param-id]s. The arguments are supplied like those to a type constructor—i.e. 
 @racket[(name-id type-argument ...)]—and the resulting type is @racket[type-expr] with each

hackett-lib/hackett/private/base.rkt

@@ -187,18 +187,36 @@
                                              syntax-local-introduce)
                                        xs)])
         (for/lists [es- ts_es]
-                 ([k (in-list ks)]
-                  [e (in-list (map car es+ts))]
-                  [e/elab (in-list es/elab)]
-                  [scoped-intdef-ctx (in-list scoped-intdef-ctxs)])
-        (let* ([e- (local-expand e/elab 'expression stop-ids (if scoped-intdef-ctx
-                                                                 (list intdef-ctx scoped-intdef-ctx)
-                                                                 intdef-ctx))]
-               [t_e (get-type e-)])
-          (unless t_e (raise-syntax-error #f "no inferred type" e))
-          (k (syntax-property e- 'disappeared-binding
-                              (cons (syntax-property e 'disappeared-binding) disappeared-bindings))
-             t_e)))))
+                   ([k (in-list ks)]
+                    [e (in-list (map car es+ts))]
+                    [e/elab (in-list es/elab)]
+                    [scoped-intdef-ctx (in-list scoped-intdef-ctxs)])
+          (let* ([e- (let ([intdef-ctxs (if scoped-intdef-ctx
+                                            (list intdef-ctx scoped-intdef-ctx)
+                                            intdef-ctx)])
+                       (let loop ([e e/elab])
+                         (syntax-parse (local-expand e 'expression stop-ids intdef-ctxs)
+                           #:literals [#%expression]
+                           ; Expand through #%expression forms if we don’t find an inferred type
+                           ; immediately and hope that the nested expression will have a type.
+                           [(head:#%expression e*)
+                            #:when (not (get-type this-syntax))
+                            (syntax-track-origin (loop #'e*) this-syntax #'head)]
+                           ; If we find a bare identifier, it’s either a variable, an out-of-context
+                           ; identifier, or an unbound identifier that stopped expanding just before
+                           ; introducing racket/base’s #%top (since that #%top is implicitly added to
+                           ; the stop list). The former two cases are okay, but the latter is not, so
+                           ; keep going to trigger the unbound identifier error if the identifier is
+                           ; actually unbound.
+                           [_:id
+                            #:when (not (identifier-binding this-syntax))
+                            (local-expand this-syntax 'expression '() intdef-ctxs)]
+                           [_ this-syntax])))]
+                 [t_e (get-type e-)])
+            (unless t_e (raise-syntax-error #f "no inferred type" e-))
+            (k (syntax-property e- 'disappeared-binding
+                                (cons (syntax-property e 'disappeared-binding) disappeared-bindings))
+               t_e)))))
 
     ; With everything inferred and checked, all that’s left to do is return the results.
     (values xs-* es- ts_es))

hackett-lib/hackett/private/kernel.rkt

@@ -90,48 +90,45 @@
    (begin
      (define-syntax-parser @%app
        [(~parens _ . args)
-        (syntax/loc this-syntax
-          (@%app/prefix . args))]
+        (datum->syntax this-syntax (cons #'@%app/prefix #'args) this-syntax)]
        [{~braces _ . args}
-        (syntax/loc this-syntax
-          (@%app/infix . args))])
+        (datum->syntax this-syntax (cons #'@%app/infix #'args) this-syntax)])
 
      (define-syntax-parser @%app/prefix
        [(_ f:expr) #'f]
        [(_ f:expr x:expr)
-        (syntax/loc this-syntax
-          (@%app1 f x))]
+        (datum->syntax this-syntax (list #'@%app1 #'f #'x) this-syntax)]
        [(_ f:expr x:expr xs:expr ...)
-        (quasisyntax/loc this-syntax
-          (@%app/prefix #,(~> (syntax/loc this-syntax
-                                (@%app1 f x))
-                              (syntax-property 'omit-type-tooltip #t))
-                        xs ...))])
+        #:with inner-app (~> (datum->syntax this-syntax (list #'@%app1 #'f #'x) this-syntax)
+                             (syntax-property 'omit-type-tooltip #t))
+        (datum->syntax this-syntax (list* #'@%app/prefix #'inner-app #'(xs ...)) this-syntax)])
 
      (define-syntax-parser @%app/infix
        [(_ a:expr op:infix-operator b:expr {~seq ops:infix-operator bs:expr} ...+)
         #:when (eq? 'left (attribute op.fixity))
         #:and ~!
         #: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))
+        #:with inner-app (~> (datum->syntax this-syntax (list #'@%app/infix #'a #'op #'b) this-syntax)
                              (syntax-property 'omit-type-tooltip #t))
-                       {?@ ops bs} ...))]
+        (~> (list* #'@%app/infix #'inner-app (syntax->list #'({?@ ops bs} ...)))
+            (datum->syntax this-syntax _ this-syntax))]
        [(_ {~seq as:expr ops:infix-operator} ...+ a:expr op:infix-operator b:expr)
         #:when (eq? 'right (attribute op.fixity))
         #:and ~!
         #:fail-unless (andmap #{eq? % 'right} (attribute ops.fixity))
                       "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-property 'omit-type-tooltip #t))))]
+        #:with inner-app (~> (datum->syntax this-syntax (list #'@%app/infix #'a #'op #'b) this-syntax)
+                             (syntax-property 'omit-type-tooltip #t))
+        (~> (append (list #'@%app/infix) (syntax->list #'({?@ as ops} ...)) (list #'inner-app))
+            (datum->syntax this-syntax _ this-syntax))]
        [(_ a:expr op:expr b:expr)
-        (syntax/loc this-syntax
-          (@%app/prefix op a b))]
+        (quasisyntax/loc this-syntax
+          (#%expression
+           #,(~> (datum->syntax this-syntax (list #'op #'a #'b) this-syntax)
+                 ; Explicitly make 'paren-shape #f on the new application form to avoid the #\{ value
+                 ; being copied onto the prefix application when #%expression is expanded.
+                 (syntax-property 'paren-shape #f))))]
        [(_ a:expr)
         #'a]))))
 

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

@@ -15,10 +15,12 @@
 (begin-for-syntax
   ; Alias transformer bindings; use the make-alias-transformer constructor instead of creating
   ; instances of this struct directly.
-  (struct alias-transformer (procedure)
-    #:property prop:procedure (struct-field-index procedure))
+  (struct alias-transformer (procedure fixity)
+    #:property prop:procedure (struct-field-index procedure)
+    #:property prop:infix-operator
+    (λ (self) (alias-transformer-fixity self)))
 
-  (define (make-alias-transformer args type-template)
+  (define (make-alias-transformer args type-template fixity)
     (let ([arity (length args)])
       (alias-transformer
        (cond
@@ -33,13 +35,14 @@
              (insts type-template (map cons args (attribute t)))]
             [:id
              #:fail-when #t (~a "expected " arity " argument(s) to type alias")
-             (error "unreachable")])])))))
+             (error "unreachable")])])
+       fixity))))
 
 
 (define-syntax-parser type
   [(_ ctor-spec:type-constructor-spec {~type type-template:expr})
    #:with [ctor-spec*:type-constructor-spec] (type-namespace-introduce #'ctor-spec)
-   #:fail-when (attribute ctor-spec.fixity) "type aliases do not support infix notation"
+   #:with fixity (attribute ctor-spec.fixity)
 
    ; Create a dummy internal definition context with args.
    #:do [(define intdef-ctx (syntax-local-make-definition-context))
@@ -55,5 +58,6 @@
        (define-syntax ctor-spec*.tag
          (make-alias-transformer
           (list (quote-syntax arg*) ...)
-          (quote-syntax type-template-.expansion))))])
+          (quote-syntax type-template-.expansion)
+          'fixity)))])
 

hackett-test/tests/hackett/integration/type-alias.rkt

@@ -29,3 +29,10 @@
 
 (test {{4 int= 6} ==! False})
 (test {{4 int= 4} ==! True})
+
+(type {a ~> b} #:fixity right {a -> (Maybe b)})
+
+(def head* : (forall [a] {(List a) ~> a}) head)
+
+(test {(head* {1 :: Nil}) ==! (Just 1)})
+(test {(head* {Nil : (List Integer)}) ==! Nothing})