Simplify construction/matching on Name types

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-structs.rkt

@@ -35,11 +35,10 @@
          ...)
        ...)]))
 
-(define -Srcloc (make-Name #'srcloc null #f #t))
-(define -Date (make-Name #'date null #f #t))
-(define -Arity-At-Least
-  (make-Name #'arity-at-least null #f #t))
-(define -Exn (make-Name #'exn null #f #t))
+(define -Srcloc (-struct-name #'srcloc))
+(define -Date (-struct-name #'date))
+(define -Arity-At-Least (-struct-name #'arity-at-least))
+(define -Exn (-struct-name #'exn))
 
 
 (define (initialize-structs)

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-alias-helper.rkt

@@ -60,7 +60,7 @@
 (define (check-type-alias-contractive id type)
   (define/match (check type)
     [((Union: elems)) (andmap check elems)]
-    [((Name: name-id _ _ _))
+    [((Name/simple: name-id))
      (and (not (free-identifier=? name-id id))
           (check (resolve-once type)))]
     [((App: rator rands stx))

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt

@@ -543,7 +543,7 @@
           [args (parse-types #'(arg args ...))])
          (resolve-app-check-error rator args stx)
          (match rator
-           [(Name: _ _ _ _) (make-App rator args stx)]
+           [(? Name?) (make-App rator args stx)]
            [(Poly: _ _) (instantiate-poly rator args)]
            [(Mu: _ _) (loop (unfold rator) args)]
            [(Error:) Err]

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt

@@ -277,7 +277,7 @@
                                   (λ () (loop resolved-name 'both rv)))
                 (lookup-name-sc name-id typed-side)])]
         ;; Ordinary type applications or struct type names, just resolve
-        [(or (App: _ _ _) (Name: _ _ _ #t)) (t->sc (resolve-once type))]
+        [(or (App: _ _ _) (Name/struct:)) (t->sc (resolve-once type))]
         [(Univ:) (if (from-typed? typed-side) any-wrap/sc any/sc)]
         [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var)))))
          (listof/sc (t->sc elem-ty))]

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt

@@ -32,6 +32,7 @@
          type-equal?
          remove-dups
          sub-t sub-f sub-o sub-pe
+         Name/simple: Name/struct:
          (rename-out [Class:* Class:]
                      [Class* make-Class]
                      [Row* make-Row]
@@ -1031,3 +1032,15 @@
                  (list row-pat inits-pat fields-pat
                        methods-pat augments-pat init-rest-pat)))])))
 
+;; alternative to Name: that only matches the name part
+(define-match-expander Name/simple:
+  (λ (stx)
+    (syntax-parse stx
+      [(_ name-pat) #'(Name: name-pat _ _ _)])))
+
+;; alternative to Name: that only matches struct names
+(define-match-expander Name/struct:
+  (λ (stx)
+    (syntax-parse stx
+      [(_) #'(Name: _ _ _ #t)]
+      [(_ name-pat) #'(Name: name-pat _ _ #t)])))

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt

@@ -239,6 +239,10 @@
 (define/decl -syntax-e (make-SyntaxPE))
 (define/decl -force (make-ForcePE))
 
+;; Type alias names
+(define (-struct-name name)
+  (make-Name name null #f #t))
+
 ;; Structs
 (define (-struct name parent flds [proc #f] [poly #f] [pred #'dummy])
   (make-Struct name parent flds proc poly pred))

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt

@@ -376,7 +376,7 @@
     [(? Rep-stx a) (syntax->datum (Rep-stx a))]
     [(Univ:) 'Any]
     ;; struct names are just printed as the original syntax
-    [(Name: id _ _ #t) (syntax-e id)]
+    [(Name/struct: id) (syntax-e id)]
     ;; If a type has a name, then print it with that name.
     ;; However, we expand the alias in some cases
     ;; (i.e., the fuel is > 0) for the :type form.

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/remove-intersect.rkt

@@ -38,7 +38,7 @@
          [(list _ (F: _)) #t]
          [(list (Opaque: _) _) #t]
          [(list _ (Opaque: _)) #t]
-         [(list (Name: n _ _ _) (Name: n* _ _ _))
+         [(list (Name/simple: n) (Name/simple: n*))
           (or (free-identifier=? n n*)
               (overlap (resolve-once t1) (resolve-once t2)))]
          [(list _ (Name: _ _ _ _))

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/resolve.rkt

@@ -29,8 +29,8 @@
 
 (define (resolve-name t)
   (match t
-    [(Name: n _ _ _) (let ([t (lookup-type-name n)])
-                         (if (Type/c? t) t #f))]
+    [(Name/simple: n) (let ([t (lookup-type-name n)])
+                        (if (Type/c? t) t #f))]
     [_ (int-err "resolve-name: not a name ~a" t)]))
 
 (define already-resolving? (make-parameter #f))
@@ -43,7 +43,7 @@
        (unless (= n (length rands))
          (tc-error "wrong number of arguments to polymorphic type: expected ~a and got ~a"
                    n (length rands)))]
-      [(Name: n _ _ #t)
+      [(Name/struct: n)
        (when (and (current-poly-struct)
                   (free-identifier=? n (poly-name (current-poly-struct))))
         (define num-rands (length rands))
@@ -115,7 +115,7 @@
                  [already-resolving? #t])
     (resolve-app-check-error rator rands stx)
     (match rator
-      [(Name: _ _ _ _)
+      [(? Name?)
        (let ([r (resolve-name rator)])
          (and r (resolve-app r rands stx)))]
       [(Poly: _ _) (instantiate-poly rator rands)]
@@ -137,7 +137,7 @@
                   [(Mu: _ _) (unfold t)]
                   [(App: r r* s)
                    (resolve-app r r* s)]
-                  [(Name: _ _ _ _) (resolve-name t)])])
+                  [(? Name?) (resolve-name t)])])
         (when (and r*
                    (not (currently-subtyping?)))
           (hash-set! resolver-cache seq r*))

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt

@@ -178,9 +178,9 @@
   (lambda (stx)
     (syntax-case stx ()
       [(_ i)
-       #'(or (and (Name: _ _ _ #t)
+       #'(or (and (Name/struct:)
                   (app resolve-once (? Struct? i)))
-             (App: (and (Name: _ _ _ #t)
+             (App: (and (Name/struct:)
                         (app resolve-once (Poly: _ (? Struct? i))))
                    _ _))])))
 
@@ -210,7 +210,7 @@
     (or (free-identifier=? s-name p-name)
         (match s
           [(Poly: _ (? Struct? s*)) (in-hierarchy? s* par)]
-          [(Struct: _ (and (Name: _ _ _ #t) p) _ _ _ _)
+          [(Struct: _ (and (Name/struct:) p) _ _ _ _)
            (in-hierarchy? (resolve-once p) par)]
           [(Struct: _ (? Struct? p) _ _ _ _) (in-hierarchy? p par)]
           [(Struct: _ (Poly: _ p) _ _ _ _) (in-hierarchy? p par)]

pkgs/typed-racket-pkgs/typed-racket-more/typed/pict.rkt

@@ -8,10 +8,10 @@
                               make-Union)))
 
 (begin-for-syntax
- (define -pict (make-Name #'pict null #f #t))
+ (define -pict (-struct-name #'pict))
  (define -pict-path
    (make-Union (list (-val #f) -pict (-lst -pict))))
- (define -child (make-Name #'child null #f #t))
+ (define -child (-struct-name #'child))
  (define -linestyle
    (one-of/c 'transparent 'solid 'xor 'hilite
              'dot 'long-dash 'short-dash 'dot-dash

pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt

@@ -1907,7 +1907,7 @@
               -Void)
         [tc-e (raise (exn:fail:contract "1" (current-continuation-marks))) (t:Un)]
         [tc-err (exn:fail:contract)
-          #:ret (ret (resolve (make-Name #'exn:fail:contract null #f #t)))]
+          #:ret (ret (resolve (-struct-name #'exn:fail:contract)))]
         [tc-e (#%variable-reference) -Variable-Reference]
         [tc-e (#%variable-reference x) -Variable-Reference]
         [tc-e (#%variable-reference +) -Variable-Reference]