使用宏给racket加类型

使用宏给racket加类型

御坂黒子御坂黒子

前言:

首先,感谢@qww6 解答了我许多问题,如果有任何问题,可以在下面的评论区提出。

一直以来,racket语言因为没有静态类型系统而为人诟病,不少人认为这门语言辣鸡。但是,racket中远比scheme强大的宏系统带给我们了一线希望,我们可以通过宏给racket加类型,而且不需要等待官方更新typed racket,就可以给我们的type system加上各种各样的功能。

目前已知的给racket加类型的方法至少有两种:1.Typed Racket所采用的将程序展开为core form后进行类型检查的方法。

2.Type System as Macros 中所提到的一边展开一边检查的方法(type tailoring)。

我们这篇文章的采用的方法是第二种。

前置知识:

我们的读者至少应该已经了解并会使用scheme中的syntax-case宏(不会的点这里:Syntactic Extension

由于我们要对类型进行检查,所以我们必须拦截所有的app,racket中提供了一个#%app的形式,所有的函数应用都会被转化为(#%app func . args)的形式。

类似的,我们可以用重写lambda宏,#%datum的形式来进行类型检查。

(provide (rename-out [app #%app]))
(define-syntax (app stx)
  (syntax-case stx ()
    [(_ func . args) #'(#%app func . args)]))

相关链接:17.1 Module Languages

我们的简易类型系统:

我们将会在下面实现一个简单的类型系统,它将支持以下类型:

type=int|string|bool|(-> type type ...)

看起来确实很简陋啊, 但是这是一个从没有静态类型系统到有静态类型系统的质变。

另外,我们的类型系统不支持自动的currying(scheme传统)。

除此之外,我们还将支持对我们程序的一些优化。

常量的类型:

给程序中出现的数字,字符串和布尔值加上类型是极为简单的,我们只需要插进#%datum就行了,最后,我们用syntax-property(12.7 Syntax Object Properties)给typing terms加上类型信息。

(require (for-syntax syntax/parse))
(provide (rename-out [app #%app][datum #%datum]))
 (define-syntax (datum stx)
  (syntax-parse stx
    [(d . c:integer) (syntax-property #'(#%datum . c)
                                  'type
                                  #'int)]
    [(d . c:boolean) (syntax-property #'(#%datum . c)
                                   'type
                                   #'bool)]
    [(d . c:str) (syntax-property #'(#%datum . c)
                                  'type
                                  #'string)]
    [(d . any) (raise-syntax-error 'type-system-error "Don't Support this type." #'any)]
     ))

相关链接(syntax-parse):1.3 Parsing Syntax

一些primitive operator的类型:

我们这个类型系统还支持一些primop,它们是+,-,*,/,string-append,and,or,not(注意了,这里and和or是宏,不是函数,我们必须要对它们做额外的检查)。

我们将会用到identifier macro的知识:16.1 Pattern-Based Macros,为了方便,我们写一个macro-transformer实现相同的功能。

(define-for-syntax (make-val-transformer val)
  (lambda (stx)
    (syntax-case stx ()
      [_ (identifier? stx) val]
      [(_ . args) #`(app #,val . args)])))

对于简单的函数+,-,*,/,string-append,not,我们可以直接写:


 (provide (rename-out [app #%app][datum #%datum]
                     [add +][sub -][div /][mul *]
                     [strapd string-append]
                     [tnot not]))
 (define-syntax add (make-val-transformer (syntax-property #'(lambda (x y) (+ x y)) 'type #'(-> int int int))))
(define-syntax sub (make-val-transformer (syntax-property #'(lambda (x y) (- x y)) 'type #'(-> int int int))))
(define-syntax mul (make-val-transformer (syntax-property #'(lambda (x y) (* x y)) 'type #'(-> int int int))))
(define-syntax div (make-val-transformer (syntax-property #'(lambda (x y) (/ x y)) 'type #'(-> int int int))))
(define-syntax strapd (make-val-transformer (syntax-property #'(lambda (x y) (string-append x y)) 'type #'(-> string string string))))
(define-syntax tnot (make-val-transformer (syntax-property #'not 'type #'(-> bool bool))))

对于上面这段冗余的代码,你也可以写一个宏来简化它们,不过,这不是本篇文章的目的。

接下来我们将会对app做一个检查。

Type Check for app:

我们首先为app加上type check,检查参数类型,并返回正确的类型。

 (define-syntax (app stx)
  (syntax-case stx ()
    [(_ func . args) (let ([types (map
                                   (lambda (x)
                                     (let ([t (syntax-property x 'type)])
                                       (if t t (raise-syntax-error 'type-system-error
                                                                   "missing type:"
                                                                   x))))
                                      (syntax->list #'(func . args)))])
                       (syntax-property #'(#%app func . args) 'type
                                        (type-app types)))]))
接下来定义type-app,它的行为遵循以下的规则。

type-app (-> a b) a=b

type-app (-> a b c ...) a rest ...=type-app (-> b c ...) rest ...

type-app other=error

补充:实际上这个type-app还写的不够好,但是我懒,你们饶了我把。

(define-for-syntax (type-app stx errorinf)
  (syntax-case stx ()
    [((-> a b) c) (free-identifier=? a c) #'b]
    [((-> a b c ...) d e ...) (free-identifier=? a d)
                              (type-app #'((-> b c ...) e ...) errorinf)]
    [others (raise-syntax-error 'type-system-error
                                "error when apply the arguements to function"
                                errofinf)]))

测试我们的程序, 发现一个问题,它会提示我们已经支持的int,string,bool没有类型,所以我们必须要对app进行修改,让app的参数先展开(12.4 Syntax Transformers),才能获取到参数的type。

(define-syntax (app stx)
  (syntax-case stx ()
    [(_ func . args) (let ([types #`(#,@(map
                                   (lambda (x)
                                     (let ([t (syntax-property (local-expand x
                                                                (syntax-local-context)
                                                                (list #'#%datum))
 'type)])
                                       (if t t (raise-syntax-error 'type-system-error
                                                                   "missing type:"
                                                                   x))))
                                      (syntax->list #'(func . args))))])
                       (syntax-property #'(#%app func . args) 'type
                                        (type-app types #'(#%app func . args))))]))

这时,我们测试一下,发现各种运算都表现的很好,报错也是正常的。

Type check for lambda:

下面我们要正式支持lambda了,先把lambda的form写一下:

(lambda ([x : type] ...) expr)

大致思路是,将x的type代入expr中(make-val-transformer) ,然后根据获得的type生成整个lambda term的type,好累。

 (define-for-syntax (gen-type pa f)
  (syntax-case pa ()
    [(a ...) #`(-> a ... #,f)]
    ))
 (define-syntax (lam stx)
  (syntax-case stx ()
    [(_ ([var : types] ...) body)
      (let* ([body (local-expand #'(lambda (var ...)
                        (let-syntax ([var (make-val-transformer (syntax-property #'var 'type #'types))] ...)
                          body))
                    (syntax-local-context) '())]
            [bodyt (syntax-case body ()
                     [(_ args (letvalues () (letvalues2 () e)))
                      (syntax-property #'e 'type)]
                     [(_ (lam args (letvalues () (letvalues2 () e))))
                      (syntax-property #'e 'type)]
                     )]
            )
        (if bodyt
            (syntax-property body 'type (gen-type #'(types ...) bodyt))
            (raise-syntax-error 'type-system-error
                          "the body of lambda doesn;t have a type"
                          #'(lambda ([var : types] ...) body)))
        )]))

我们可以添加一个方便的语法形式print-type:来打印表达式的type:

(define-syntax (print-type: stx)
  (syntax-case stx ()
    [(_ e) #`(begin
               (display '#,(syntax-property (local-expand #'e (syntax-local-context) '()) 'type))
               (newline))]))

一些测试:


 (require "type.rkt")
((lambda ([x : int][y : int]) (* 1 (+ 4 x))) 2 3)
((lambda ([x : string][y : string]) (string-append x y)) "dfd" "dfdf")
(+ 1 2)
(print-type: 3)
(print-type: (not #t))
(print-type: (lambda ([x : int] [y : string]) y))
(print-type: (lambda ([x : int]) (lambda ([y : int]) x)))
(print-type: (lambda ([x : int][y : int]) x))
(print-type: +)

result:
6
"dfddfdf"
3
int
bool
(-> int string string)
(-> int (-> int int))
(-> int int int)
(-> int int int)

一点改进:

上面我们在判断两个类型是否相等时直接使用了非常naive的free-identifier=?,我们必须要改进它,采用把type全部展开后再逐个比较的方法。

(define-for-syntax (type=? x y)
  (or (and (identifier? x) (identifier? y) (free-identifier=? x y))
      (and (stx-null? x) (stx-null? y))
      (and (type=? (stx-car x) (stx-car y))
           (type=? (stx-cdr x) (stx-cdr y)))))

最后,我们需要type-alias,比如

(define-type another-int int)

(define-type op (-> int int int))

甚至

(define-type (f3 t) (-> t t t))

看起来很复杂,其实我们根本不需要自己动手,只要借刀(宏)杀人 就可以了。

为了防止type展开的时候出错,我们需要先定义:

(define int 'type-int)
(define string 'type-string)
(define bool 'type-bool)
(define -> (lambda l (error "ooh,you can't call me at runtime")))
然后把type=?中的参数用local-expand展开。

展开时我们会发现type-check无法通过,原因是->没有type,我们可以把->单独弄出来,而不是让app进行check。

(define ->internal (lambda l (error "ooh")))
(define-syntax ->
  (syntax-rules ()
    [(_ a ...) (#%app ->internal a ...)])) 

我们写出不带参数的define-type:

 (define-syntax (define-type stx)
  (syntax-case stx ()
    [(_ tname tvar) #'(define-syntax tname (make-val-transformer #'tvar))])

(print-type: (lambda ([x : another-int] [y : another-int]) (+ x y)))的结果是(-> another-int another-int int),但是其实和(-> int int int)是一样的。

如何实现(define-type (tc xx yy) e)这种形式,留给读者自己动手实现。

由于我们的类型都是已经经过检查的,所以根本不需要运行时检查,可以把+的内部实现替换成unsafe-fx+,以此类推。

最后我们的type system还是不完善的,最好给speical form比如define(一般是core form)加上支持,不过这就留作读者朋友的作业了。

另外,对于这种方法感兴趣的同学,可以学习racket平台上的turnstile语言,只要写出对应的typing rule,就可以轻易实现自己的类型系统啦。

附录:全部源码


 #lang racket
(require (for-syntax syntax/parse syntax/stx))
 (require racket/unsafe/ops)
(provide (rename-out [app #%app][datum #%datum]
                     [add +][sub -][div /][mul *]
                     [strapd string-append]
                     [tnot not][lam lambda]))
(provide print-type: int string bool -> define-type)
(define int 'type-int)
(define string 'type-string)
(define bool 'type-bool)
(define ->internal (lambda l (error "ooh,you can't call me at runtime")))
(define-syntax ->
  (syntax-rules ()
    [(_ a ...) (#%app ->internal a ...)]))
(define-syntax (define-type stx)
  (syntax-case stx ()
    [(_ tname tvar) #'(define-syntax tname (make-val-transformer #'tvar))]
    ))
(define-for-syntax (type-app stx errorinf)
  (syntax-case stx ()
    [((-> a b) c) (type=e? #'a #'c) #'b]
    [((-> a b c ...) d e ...) (type=e? #'a #'d)
                              (type-app #'((-> b c ...) e ...) errorinf)]
    [others (raise-syntax-error 'type-system-error
                                "error when apply the arguements to function"
                                errorinf)]))
(define-for-syntax (type=e? x y) (type=? (local-expand x (syntax-local-context) '())
                                         (local-expand y (syntax-local-context) '())))
(define-for-syntax (type=? x y)
  (or (and (identifier? x) (identifier? y) (free-identifier=? x y))
      (and (stx-null? x) (stx-null? y))
      (and (type=? (stx-car x) (stx-car y))
           (type=? (stx-cdr x) (stx-cdr y)))))
(define-syntax (app stx)
  (syntax-case stx ()
    [(_ func . args) (let ([types #`(#,@(map
                                   (lambda (x)
                                     (let ([t (syntax-property (local-expand x
                                                                (syntax-local-context)
                                                                '())
 'type)])
                                       (if t t (raise-syntax-error 'type-system-error
                                                                   "missing type:"
                                                                   x))))
                                      (syntax->list #'(func . args))))])
                       
                       (syntax-property #'(#%app func . args) 'type
                                        (type-app types #'(#%app func . args))))]))
(define-syntax (datum stx)
  (syntax-parse stx
    [(d . c:integer) (syntax-property #'(#%datum . c)
                                  'type
                                  #'int)]
    [(d . c:boolean) (syntax-property #'(#%datum . c)
                                   'type
                                   #'bool)]
    [(d . c:str) (syntax-property #'(#%datum . c)
                                  'type
                                  #'string)]
    [(d . any) (raise-syntax-error 'type-system-error "Don't Support this type." #'any)]
     ))
(define-syntax (lam stx)
  (syntax-case stx ()
    [(_ ([var : types] ...) body)
      (let* ([body (local-expand #'(lambda (var ...)
                        (let-syntax ([var (make-val-transformer (syntax-property #'var 'type #'types))] ...)
                          body))
                    (syntax-local-context) '())]
            [bodyt (syntax-case body ()
                     [(_ args (letvalues () (letvalues2 () e)))
                      (syntax-property #'e 'type)]
                     [(_ (lam args (letvalues () (letvalues2 () e))))
                      (syntax-property #'e 'type)]
                     )]
            )
        (if bodyt
            (syntax-property body 'type (gen-type #'(types ...) bodyt))
            (raise-syntax-error 'type-system-error
                          "the body of lambda doesn;t have a type"
                          #'(lambda ([var : types] ...) body)))
        )]))
(define-syntax (print-type: stx)
  (syntax-case stx ()
    [(_ e) #`(begin
               (display '#,(syntax-property (local-expand #'e (syntax-local-context) '()) 'type))
               (newline))]))
(define-for-syntax (gen-type pa f)
  (syntax-case pa ()
    [(a ...) #`(-> a ... #,f)]
    ))
              
(define-for-syntax (make-val-transformer val)
  (lambda (stx)
    (syntax-case stx ()
      [_ (identifier? stx) val]
      [(_ . args) #`(app #,val . args)])))
(define-syntax add (make-val-transformer (syntax-property #'(lambda (x y) (unsafe-fx+ x y)) 'type #'(-> int int int))))
(define-syntax sub (make-val-transformer (syntax-property #'(lambda (x y) (unsafe-fx- x y)) 'type #'(-> int int int))))
(define-syntax mul (make-val-transformer (syntax-property #'(lambda (x y) (unsafe-fx* x y)) 'type #'(-> int int int))))
(define-syntax div (make-val-transformer (syntax-property #'(lambda (x y) (unsafe-fx/ x y)) 'type #'(-> int int int))))
(define-syntax strapd (make-val-transformer (syntax-property #'(lambda (x y) (string-append x y)) 'type #'(-> string string string))))
(define-syntax tnot (make-val-transformer (syntax-property #'not 'type #'(-> bool bool))))
文章被以下专栏收录
2 条评论
推荐阅读