/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt

http://github.com/gmarceau/PLT · Racket · 141 lines · 113 code · 14 blank · 14 comment · 3 complexity · becd978259a4655dd262348c7acb3367 MD5 · raw file 

    

  1. #lang scheme/base
    2. 

  2. 

  3. (require "test-utils.rkt"
    4. 

  4.          (types subtype convenience union)
    5. 

  5.          (rep type-rep)
    6. 

  6.          (env init-envs type-env-structs)
    7. 

  7.          (r:infer infer infer-dummy)
    8. 

  8.          rackunit
    9. 

  9.          (for-syntax scheme/base))
    10. 

  10. 

  11. (provide subtype-tests)
    12. 

  12. 

  13. (define-syntax (subtyping-tests stx)
    14. 

  14.   (define (single-test stx)
    15. 

  15.     (syntax-case stx (FAIL)
    16. 

  16.       [(FAIL t s) (syntax/loc stx (test-check (format "FAIL ~a" '(t s)) (lambda (a b) (not (subtype a b))) t s))]
    17. 

  17.       [(t s) (syntax/loc stx (test-check (format "~a" '(t s)) subtype t s))]))
    18. 

  18.   (syntax-case stx ()
    19. 

  19.     [(_ cl ...)
    20. 

  20.      (with-syntax ([(new-cl ...) (map single-test (syntax->list #'(cl ...)))])
    21. 

  21. 		  (syntax/loc stx
    22. 

  22. 			      (begin (test-suite "Tests for subtyping"
    23. 

  23. 						 new-cl ...))))]))
    24. 

  24. 

  25. (infer-param infer)
    26. 

  26. 

  27. (define (subtype-tests)
    28. 

  28.   (subtyping-tests
    29. 

  29.    ;; trivial examples
    30. 

  30.    (Univ Univ)
    31. 

  31.    (-Number Univ)
    32. 

  32.    (-Boolean Univ)
    33. 

  33.    (-Symbol Univ)
    34. 

  34.    (-Void Univ)
    35. 

  35.    [-Number -Number]
    36. 

  36.    [(Un (-pair Univ (-lst Univ)) (-val '())) (-lst Univ)]
    37. 

  37.    [(-pair -Number (-pair -Number (-pair (-val 'foo) (-val '())))) (-lst Univ)]
    38. 

  38.    [(-pair -Number (-pair -Number (-pair (-val 'foo) (-val '())))) (-lst (Un -Number -Symbol))]
    39. 

  39.    [(-pair (-val 6) (-val 6)) (-pair -Number -Number)]
    40. 

  40.    [(-val 6) (-val 6)]
    41. 

  41.    ;; unions
    42. 

  42.    [(Un -Number) -Number]
    43. 

  43.    [(Un -Number -Number) -Number]
    44. 

  44.    [(Un -Number -Symbol) (Un -Symbol -Number)]
    45. 

  45.    [(Un (-val 6) (-val 7)) -Number]
    46. 

  46.    [(Un (-val #f) (Un (-val 6) (-val 7))) (Un -Number (Un -Boolean -Symbol))]
    47. 

  47.    [(Un (-val #f) (Un (-val 6) (-val 7))) (-mu x (Un -Number (Un -Boolean -Symbol)))]
    48. 

  48.    [(Un -Number (-val #f) (-mu x (Un -Number -Symbol (make-Listof x))))
    49. 

  49.     (-mu x (Un -Number -Symbol -Boolean (make-Listof x)))]
    50. 

  50.    ;; sexps vs list*s of nums
    51. 

  51.    [(-mu x (Un -Number -Symbol (make-Listof x))) (-mu x (Un -Number -Symbol -Boolean (make-Listof x)))]
    52. 

  52.    [(-mu x (Un -Number (make-Listof x))) (-mu x (Un -Number -Symbol (make-Listof x)))]
    53. 

  53.    [(-mu x (Un -Number (make-Listof x))) (-mu y (Un -Number -Symbol (make-Listof y)))]
    54. 

  54.    ;; a hard one
    55. 

  55.    [(-mu x (*Un -Number (-pair x (-pair -Symbol (-pair x (-val null)))))) -Sexp]
    56. 

  56.    ;; simple function types
    57. 

  57.    ((Univ . -> . -Number) (-Number . -> . Univ))
    58. 

  58.    [(Univ Univ Univ . -> . -Number) (Univ Univ -Number . -> . -Number)]
    59. 

  59.    ;; simple list types
    60. 

  60.    [(make-Listof -Number) (make-Listof Univ)]
    61. 

  61.    [(make-Listof -Number) (make-Listof -Number)]
    62. 

  62.    [FAIL (make-Listof -Number) (make-Listof -Symbol)]
    63. 

  63.    [(-mu x (make-Listof x)) (-mu x* (make-Listof x*))]
    64. 

  64.    [(-pair -Number -Number) (-pair Univ -Number)]
    65. 

  65.    [(-pair -Number -Number) (-pair -Number -Number)]
    66. 

  66.    ;; from page 7
    67. 

  67.    [(-mu t (-> t t)) (-mu s (-> s s))]
    68. 

  68.    [(-mu s (-> -Number s)) (-mu t (-> -Number (-> -Number t)))]
    69. 

  69.    ;; polymorphic types
    70. 

  70.    [(-poly (t) (-> t t)) (-poly (s) (-> s s))]
    71. 

  71.    [FAIL (make-Listof -Number) (-poly (t) (make-Listof t))]
    72. 

  72.    [(-poly (a) (make-Listof (-v a))) (make-Listof -Number)]     ;;
    73. 

  73.    [(-poly (a) -Number) -Number]
    74. 

  74. 

  75.    [(-val 6) -Number]
    76. 

  76.    [(-val 'hello) -Symbol]
    77. 

  77.    [((Un -Symbol -Number) . -> . -Number) (-> -Number -Number)]
    78. 

  78.    [(-poly (t) (-> -Number t)) (-mu t (-> -Number t))]
    79. 

  79.    ;; not subtypes
    80. 

  80.    [FAIL (-val 'hello) -Number]
    81. 

  81.    [FAIL (-val #f) -Symbol]
    82. 

  82.    [FAIL (Univ Univ -Number -Number . -> . -Number) (Univ Univ Univ . -> . -Number)]
    83. 

  83.    [FAIL (-Number . -> . -Number) (-> Univ Univ)]
    84. 

  84.    [FAIL (Un -Number -Symbol) -Number]
    85. 

  85.    [FAIL -Number (Un (-val 6) (-val 11))]
    86. 

  86.    [FAIL -Symbol (-val 'Sym)]
    87. 

  87.    [FAIL (Un -Symbol -Number) (-poly (a) -Number)]
    88. 

  88.    ;; bugs found
    89. 

  89.    [(Un (-val 'foo) (-val 6)) (Un (-val 'foo) (-val 6))]
    90. 

  90.    [(-poly (a) (make-Listof (-v a))) (make-Listof (-mu x (Un (make-Listof x) -Number)))]
    91. 

  91.    [FAIL (make-Listof (-mu x (Un (make-Listof x) -Number))) (-poly (a) (make-Listof a))]
    92. 

  92.    ;; case-lambda
    93. 

  93.    [(cl-> [(-Number) -Number] [(-Boolean) -Boolean]) (-Number . -> . -Number)]
    94. 

  94.    ;; special case for unused variables
    95. 

  95.    [-Number (-poly (a) -Number)]
    96. 

  96.    [FAIL (cl-> [(-Number) -Boolean] [(-Boolean) -Number]) (-Number . -> . -Number)]
    97. 

  97.    ;; varargs
    98. 

  98.    [(->* (list -Number) Univ -Boolean) (->* (list -Number) -Number -Boolean)]
    99. 

  99.    [(->* (list Univ) -Number -Boolean) (->* (list -Number) -Number -Boolean)]
    100. 

  100.    [(->* (list -Number) -Number -Boolean) (->* (list -Number) -Number -Boolean)]
    101. 

  101.    [(->* (list -Number) -Number -Boolean) (->* (list -Number) -Number Univ)]
    102. 

  102.    [(->* (list -Number) -Number -Number) (->* (list -Number -Number) -Number)]
    103. 

  103.    [(->* (list -Number) -Number -Number) (->* (list -Number -Number -Number) -Number)]
    104. 

  104.    [(->* (list -Number -Number) -Boolean -Number) (->* (list -Number -Number) -Number)]
    105. 

  105.    [FAIL (->* (list -Number) -Number -Boolean) (->* (list -Number -Number -Number) -Number)]
    106. 

  106.    [(->* (list -Number -Number) -Boolean -Number) (->* (list -Number -Number -Boolean -Boolean) -Number)]
    107. 

  107. 

  108.    [(-poly (a) (cl-> [() a]
    109. 

  109. 		     [(-Number) a]))
    110. 

  110.     (cl-> [() (-pair -Number (-v b))]
    111. 

  111. 	  [(-Number) (-pair -Number (-v b))])]
    112. 

  112. 

  113.    [(-values (list -Number)) (-values (list Univ))]
    114. 

  114. 

  115.    [(-poly (b) ((Un (make-Base 'foo #'dummy values #'values)
    116. 

  116.                     (-struct 'bar #f
    117. 

  117.                              (list (make-fld -Number #'values #f) (make-fld b #'values #f))
    118. 

  118.                              #'values))
    119. 

  119.                 . -> . (-lst b)))
    120. 

  120.     ((Un (make-Base 'foo #'dummy values #'values) (-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values))
    121. 

  121.      . -> . (-lst (-pair -Number (-v a))))]
    122. 

  122.    [(-poly (b) ((-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld b #'values #f)) #'values) . -> . (-lst b)))
    123. 

  123.     ((-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values) . -> . (-lst (-pair -Number (-v a))))]
    124. 

  124. 

  125.    [(-poly (a) (a . -> . (make-Listof a))) ((-v b) . -> . (make-Listof (-v b)))]
    126. 

  126.    [(-poly (a) (a . -> . (make-Listof a))) ((-pair -Number (-v b)) . -> . (make-Listof (-pair -Number (-v b))))]
    127. 

  127. 

  128.    (FAIL (-poly (a b) (-> a a)) (-poly (a b) (-> a b)))
    129. 

  129. 

  130.    ;; polymorphic function types should be subtypes of the function top
    131. 

  131.    [(-poly (a) (a . -> . a)) top-func]
    132. 

  132.    (FAIL (-> Univ) (null Univ . ->* . Univ))
    133. 

  133. 

  134.    [(cl->* (-Number . -> . -String) (-Boolean . -> . -String)) ((Un -Boolean -Number) . -> . -String)]
    135. 

  135.    [(-struct 'a #f null #'values) (-struct 'a #f null #'values)]
    136. 

  136.    [(-struct 'a #f (list (make-fld -String #'values #f)) #'values) (-struct 'a #f (list (make-fld -String #'values #f)) #'values)]
    137. 

  137.    [(-struct 'a #f (list (make-fld -String #'values #f)) #'values) (-struct 'a #f (list (make-fld Univ #'values #f)) #'values)]
    138. 

  138.    ))
    139. 

  139. 

  140. (define-go
    141. 

  141.   subtype-tests)
    142.