Merge pull request #72 from AlexKnauth/type-alias

Implement type aliases

Author: lexi-lambda

hackett-doc/scribblings/hackett/reference.scrbl

@@ -107,7 +107,7 @@ following combination of @racket[def], @racket[lambda], and @racket[case*]:
 The @racket[defn] form is generally preferred when defining top-level functions.
 
 @(hackett-examples
-  (defn square : (t:-> t:Integer t:Integer)
+  (defn square : {t:Integer t:-> t:Integer}
     [[x] {x * x}])
   (eval:check (square 5) 25))}
 
@@ -308,6 +308,47 @@ specified controls the fixity used by the associated @racket[type-constructor-id
   {(Leaf 1) :&: (Leaf 2) :&: (Leaf 3)})}
 @(close-eval data-examples-eval)
 
+@subsection[#:tag "reference-type-alias"]{Defining type aliases}
+
+@(define alias-examples-eval (make-hackett-eval))
+@defform[#:literals [left right]
+         (type type-clause type-expr)
+         #:grammar
+         ([type-clause name-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],
+then @racket[name-id] is bound directly to the type alias.
+
+@(hackett-examples
+  #:eval alias-examples-eval
+  (type Num Double)
+  (def n : Num 1.5)
+  (#:type n))
+
+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
+@racket[param-id] substituted with the corresponding @racket[type-argument].
+
+Though the application of a type alias is syntactically similar to the application of a type
+constructor, type aliases are effectively type-level macros, and they may not be partially applied.
+All uses of a type alias must be fully saturated.
+
+@(hackett-examples
+  #:eval alias-examples-eval
+  (type (Predicate a) {a t:-> t:Bool})
+  (def zero? : (Predicate t:Integer) (== 0))
+  (#:type zero?)
+  (eval:check (zero? 0) True)
+  (eval:check ((: zero? (Predicate t:Integer)) 0) True)
+  (eval:error (: zero? Predicate)))
+@(close-eval alias-examples-eval)}
+
 @subsection[#:tag "reference-numbers"]{Numbers}
 
 @deftype[t:Integer]{

hackett-lib/hackett/base.rkt

@@ -1,11 +1,13 @@
 #lang racket/base
 
 (require (only-in hackett/private/adt case* case λ λ* lambda lambda* defn _)
+         (only-in hackett/private/type-alias type)
          (only-in hackett/private/class instance derive-instance)
          (except-in hackett/private/kernel λ lambda)
          hackett/private/provide
          (only-in hackett/private/toplevel @%top-interaction))
 (provide (all-from-out hackett/private/adt)
+         (all-from-out hackett/private/type-alias)
          (all-from-out hackett/private/class)
          (all-from-out hackett/private/kernel)
          (all-from-out hackett/private/provide)

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/infix.rkt

@@ -35,7 +35,9 @@
 (define (infix-operator? x)
   (and (has-prop:infix-operator? x)
        (operator-fixity? (infix-operator-fixity x))))
-  
+
+; Infix transformer bindings; use the make-infix-variable-like-transformer constructor instead of
+; creating instances of this struct directly.
 (struct infix-variable-like-transformer (procedure fixity)
   #:property prop:procedure (struct-field-index procedure)
   #:property prop:infix-operator

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

@@ -0,0 +1,68 @@
+#lang curly-fn racket/base
+
+(require (for-syntax racket/base
+                     racket/format
+                     syntax/intdef
+                     threading
+
+                     hackett/private/infix
+                     hackett/private/typecheck
+                     hackett/private/util/stx)
+         syntax/parse/define
+
+         (only-in hackett/private/adt type-constructor-spec))
+
+(provide type)
+
+(begin-for-syntax
+  ; Alias transformer bindings; use the make-alias-transformer constructor instead of creating
+  ; instances of this struct directly.
+  (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 fixity)
+    (let ([arity (length args)])
+      (alias-transformer
+       (cond
+         [(zero? arity)
+          (make-variable-like-transformer type-template)]
+         [else
+          (syntax-parser
+            [(head:id t:type ...)
+             #:fail-unless (= (length (attribute t)) arity)
+                           (~a "expected " arity " argument(s) to type alias, got "
+                               (length (attribute t)))
+             (for/fold ([result (insts type-template (map cons args (attribute t)))])
+                       ([residual (in-list (attribute t.residual))])
+               (syntax-track-origin result residual #'head))]
+            [:id
+             #:fail-when #t (~a "expected " arity " argument(s) to type alias")
+             (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)
+   #:with fixity (attribute ctor-spec.fixity)
+
+   ; Create a dummy internal definition context with args.
+   #:do [(define intdef-ctx (syntax-local-make-definition-context))
+         (syntax-local-bind-syntaxes (attribute ctor-spec*.arg) #f intdef-ctx)]
+   #:with [arg* ...] (map #{internal-definition-context-introduce intdef-ctx %}
+                          (attribute ctor-spec*.arg))
+
+   ; Expanding the type in `ctx` checks immediately that it is a valid type,
+   ; rather than deferring that check to when the type alias is applied.
+   #:with {~var type-template- (type intdef-ctx)} #'type-template
+   (~>> #'(begin
+            (define-values [] type-template-.residual)
+            (define-syntax ctor-spec*.tag
+              (make-alias-transformer
+               (list (quote-syntax arg*) ...)
+               (quote-syntax type-template-.expansion)
+               'fixity)))
+        (internal-definition-context-track intdef-ctx))])
+

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

@@ -0,0 +1,38 @@
+#lang hackett
+
+(require hackett/private/test
+         (only-in racket/base submod)
+         (submod tests/hackett/typecheck assertions))
+
+(type X Integer)
+(def x : X 5)
+(typecheck-fail (: "" X))
+
+(type (Arr a b) {a -> b})
+(type (Pred a) (Arr a Bool))
+(type (BiRel a) {a -> a -> Bool})
+
+(type Y (forall [a b] (Monoid b) => (Either a b)))
+
+(typecheck-fail
+ (λ ([x : (Arr Bool)]) ; not enough args to alias
+   x))
+
+(defn never : (forall [a] (Pred a))
+  [[x] False])
+
+(test {(never 5) ==! False})
+(test {(never "asdasaf") ==! False})
+
+(def int= : (BiRel Integer)
+  ==)
+
+(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})