expand-type-prefab.rkt

#lang racket

(require (for-syntax syntax/kerncase
                     syntax/transformer)
         syntax/parse/define)

(begin-for-syntax
  (struct type:con (id) #:prefab)
  (struct type:app (a b) #:prefab)
  (struct type:forall (x t) #:prefab)
  (struct type:qual (constr t) #:prefab)
  (struct type:bound-var (id) #:prefab)
  (struct type:wobbly-var (id) #:prefab)
  (struct type:rigid-var (id) #:prefab)

  (define-syntax-class type
    #:description "type"
    #:attributes [expansion]
    [pattern _ #:with :expanded-type (local-expand this-syntax 'expression
                                                   (kernel-form-identifier-list))])

  (define-syntax-class expanded-type
    #:description #f
    #:attributes [expansion]
    #:commit
    #:literal-sets [kernel-literals]
    [pattern (#%expression ~! a:type)
             #:attr expansion (attribute a.expansion)]
    [pattern #s(type:con ~! x:id)
             #:attr expansion (type:con #'x)]
    [pattern #s(type:app ~! a:type b:type)
             #:attr expansion (type:app (attribute a.expansion) (attribute b.expansion))]
    [pattern #s(type:forall ~! x:id t:type)
             #:attr expansion (type:forall #'x (attribute t.expansion))]
    [pattern #s(type:qual ~! a:type b:type)
             #:attr expansion (type:qual (attribute a.expansion) (attribute b.expansion))]
    [pattern #s(type:bound-var ~! x:id)
             #:attr expansion (type:bound-var #'x)]
    [pattern #s(type:wobbly-var ~! x:id)
             #:attr expansion (type:wobbly-var #'x)]
    [pattern #s(type:rigid-var ~! x:id)
             #:attr expansion (type:rigid-var #'x)]))

(define-syntax-parser #%app
  [{~and (_ _ _) ~! (_ a:type b:type)}
   #`#s(type:app #,(attribute a.expansion) #,(attribute b.expansion))]
  [(_ a b c ...+)
   (syntax/loc this-syntax
     (#%app (#%app a b) c ...))])

(define-syntax -> (make-variable-like-transformer #'#s(type:con ->)))
(define-syntax Integer (make-variable-like-transformer #'#s(type:con Integer)))

(define-simple-macro (expand-type t:type)
  #:do [(println (attribute t.expansion))]
  (#%plain-app void))

(expand-type (-> Integer Integer))

expand-type-syntax.rkt

#lang racket

(require (for-syntax racket
                     syntax/parse/define
                     syntax/transformer)
         syntax/parse/define)

(begin-for-syntax
  (define-syntaxes [syntax/loc/props quasisyntax/loc/props]
    (let ()
      (define (make-syntax/loc/props syntax-id)
        (syntax-parser
          [(_ from-stx-expr:expr template)
           #`(let ([from-stx from-stx-expr])
               (datum->syntax from-stx (syntax-e (#,syntax-id template)) from-stx from-stx))]))
      (values (make-syntax/loc/props #'syntax)
              (make-syntax/loc/props #'quasisyntax)))))

(define-syntaxes [#%type:con #%type:app #%type:forall #%type:qual
                  #%type:bound-var #%type:wobbly-var #%type:rigid-var]
  (let ([type-literal (λ (stx) (raise-syntax-error #f "can only be used in a type" stx))])
    (values type-literal type-literal type-literal type-literal
            type-literal type-literal type-literal)))

(begin-for-syntax
  (define type-stop-list (list #'#%type:con #'#%type:app #'#%type:forall #'#%type:qual
                               #'#%type:bound-var #'#%type:wobbly-var #'#%type:rigid-var))
  (define-literal-set type-literals [#%type:con #%type:app #%type:forall #%type:qual
                                     #%type:bound-var #%type:wobbly-var #%type:rigid-var])

  (define-syntax-class type
    #:description "type"
    #:attributes [expansion]
    [pattern _ #:with :expanded-type (local-expand this-syntax 'expression type-stop-list)])

  (define-syntax-class expanded-type
    #:description #f
    #:attributes [expansion]
    #:commit
    #:literal-sets [kernel-literals type-literals]
    [pattern (head:#%expression ~! a:type)
             #:attr expansion (syntax-track-origin #'a.expansion this-syntax #'head)]
    [pattern (#%type:con ~! _:id)
             #:attr expansion this-syntax]
    [pattern (head:#%type:app ~! a:type b:type)
             #:attr expansion (syntax/loc/props this-syntax
                                (head a.expansion b.expansion))]
    [pattern (head:#%type:forall ~! x:id t:type)
             #:attr expansion (syntax/loc/props this-syntax
                                (head x t.expansion))]
    [pattern (head:#%type:qual ~! a:type b:type)
             #:attr expansion (syntax/loc/props this-syntax
                                (head a.expansion b.expansion))]
    [pattern (#%type:bound-var ~! x:id)
             #:attr expansion this-syntax]
    [pattern (#%type:wobbly-var ~! x:id)
             #:attr expansion this-syntax]
    [pattern (#%type:rigid-var ~! x:id)
             #:attr expansion this-syntax]))

(define-syntax-parser #%app
  [{~and (_ _ _) ~! (_ a:type b:type)}
   (syntax/loc this-syntax
     (#%type:app a.expansion b.expansion))]
  [(_ a b c ...+)
   (syntax/loc this-syntax
     (#%app (#%app a b) c ...))])

(define-syntax -> (make-variable-like-transformer #'(#%type:con ->)))
(define-syntax Integer (make-variable-like-transformer #'(#%type:con Integer)))

(define-simple-macro (expand-type t:type)
  (quote-syntax t.expansion))

(expand-type (-> Integer Integer))