reformat

Assignments/04.rkt

@@ -20,8 +20,7 @@
   [let1E (var : Symbol) (te : TypeExp) (value : Exp) (body : Exp)]
   [recE (var : Symbol) (te : TypeExp) (value : Exp) (body : Exp)]
   [objE (fields : (Listof (Symbol * Exp)))]
-  [msgE (obj : Exp) (selector : Symbol)]
-  )
+  [msgE (obj : Exp) (selector : Symbol)])
 
 (define-type Type
   [numT]
@@ -62,7 +61,35 @@
         (objT (hash (list (pair 'add1 (arrowT (numT) (numT)))
                           (pair 'compare (arrowT (numT) (boolT))))))))
 
-(define (subtype? X Y) ....)
+(define (subtype? X Y)
+  (type-case Type X
+    [(numT) (type-case Type Y
+              [(numT) #t]
+              [else #f])]
+    [(boolT) (type-case Type Y
+               [(boolT) #t]
+               [else #f])]
+    [(arrowT X-arg X-result)
+     (type-case Type Y
+       [(arrowT Y-arg Y-result)
+        (and (subtype? Y-arg X-arg)  ;; Contravariance of arguments
+             (subtype? X-result Y-result))]  ;; Covariance of results
+       [else #f])]
+    [(objT X-fields)
+     (type-case Type Y
+       [(objT Y-fields)
+        (local [(define (loop keys)
+                  (if (empty? keys)
+                      #t
+                      (let ([key (first keys)])
+                        (let ([Y-type (some-v (hash-ref Y-fields key))])
+                          (type-case (Optionof Type) (hash-ref X-fields key)
+                            [(none) #f]  ;; Key not found in X-fields
+                            [(some X-type)
+                             (and (subtype? X-type Y-type)  ;; Check subtyping of field types
+                                  (loop (rest keys)))])))))]  ;; Recurse on remaining keys
+          (loop (hash-keys Y-fields)))]
+       [else #f])]))
 
 (module+ test
   (define hello-t (objT (hash (list (pair 'hello (numT))))))
@@ -85,7 +112,6 @@
              type
              (error 'typecheck "expected 2 num"))))]
     (type-case Exp exp
-
       [(numE n) (numT)]
       [(boolE b) (boolT)]
       [(plusE l r) (num2 l r (numT))]
@@ -101,7 +127,7 @@
        (type-case Type (typecheck fn env)
          [(arrowT arg-type result-type)
           (let ([actual-type (typecheck arg env)])
-            (if (equal? arg-type actual-type)
+            (if (subtype? actual-type arg-type)  ;; Use subtype? to check compatibility
                 result-type
                 (error 'typecheck "argument type")))]
          [else (error 'typecheck "not function")])]
@@ -127,31 +153,29 @@
          (if (equal? var-t val-t)
              body-t
              (error 'typecheck "type does not match annotation")))]
-      [(objE fields) (let* ([extract-exp (lambda (obj) (pair (fst obj) (typecheck (snd obj) env)))]
+      [(objE fields)
+       (let*
+           ([extract-exp (lambda (obj) (pair (fst obj) (typecheck (snd obj) env)))]
             [field-list (map extract-exp fields)])
-                       (objT (make-hash field-list)))]
-      [(msgE obj selector) (type-case Exp obj
-                             [(objE fields) (type-case (Optionof Exp) (hash-ref (make-hash fields) selector)
+         (objT (hash field-list)))]
+      [(msgE obj selector)
+       (type-case Exp obj
+         [(objE fields)
+          (type-case (Optionof Exp) (hash-ref (make-hash fields) selector)
             [(none) (error 'typecheck "unknown field")]
             [(some v) (typecheck v env)])]
-                             [(varE name) (type-case Type (type-lookup name env)
-                                            [(objT fields) (type-case (Optionof Type) (hash-ref fields selector)
-                                                             [(none) (error 'typecheck "dasdas")]
-                                                             [(some v) (type-case Type v
-                                                                         [(arrowT a b) b]
-                                                                         [else (error 'dasdas "dasdas")])])]
+         [(varE name) 
+          (type-case Type (type-lookup name env)
+            [(objT fields) (type-lookup selector fields)]
             [else (error 'typecheck "bound variable is not an object")])]
-
-                             [else (error 'typecheck "passing message to non-object")])]
-      )))
+         [else (error 'typecheck "passing message to non-object")])])))
 
 (define (parse-error sx)
   (error 'parse (string-append "parse error: " (to-string sx))))
 
 (module+ test
   (test/exn (parse `"strings are not in our language") "parse")
-  (test/exn (parse `{& 1 2}) "parse")
-)
+  (test/exn (parse `{& 1 2}) "parse"))
 
 (define (sx-ref sx n) (list-ref (s-exp->list sx) n))
 
@@ -228,9 +252,7 @@
                     (pair 'goodbye (numE 42)))))
   (test (parse `{lam {x : (obj (n-func (num -> num)))} x})
         (lamE 'x (objTE (list (pair 'n-func (arrowTE (numTE) (numTE)))))
-              (varE 'x)))
-
-  )
+              (varE 'x))))
 
 
 (tc : (S-Exp -> Type))
@@ -274,9 +296,7 @@
                {obj {run {lam {n : num}
                               {if {<= n 0} 1 {* n {{msg fact run} {- n 1}}}}}}}
                {{msg fact run} 10}})
-        (numT))
-
-  )
+        (numT)))
 
 (module+ test
   (test (tc `{,obj-fun {obj {n-func {lam {x : num} x}}
@@ -286,3 +306,24 @@
                    ,obj-fun
                    {f ,sampler}})
         (numT)))
+
+(module+ test
+  (test (subtype? (arrowT hello-t hello-t)
+                  (arrowT hello-t hello-t)) #t)
+  (test (subtype? (arrowT hello-t hello-t)
+                  (arrowT hello-t hello-goodbye-t)) #f)
+  (test (subtype? (arrowT hello-t hello-goodbye-t)
+                  (arrowT hello-t hello-t)) #t)
+  (test (subtype? (arrowT hello-t hello-goodbye-t)
+                  (arrowT hello-goodbye-t hello-t)) #t)
+  (test (subtype? (arrowT hello-goodbye-t hello-goodbye-t)
+                  (arrowT hello-t hello-t)) #f)
+  ;; for coverage
+  (define non-object-fun `{lam {x : num} {msg x hello}})
+  ;; `x` is bound to `numT`, which is not an object type
+  (test/exn (tc non-object-fun) "bound variable is not an object")
+  (test (subtype? hello-t (boolT)) #f)
+  (test (subtype? (boolT) (boolT)) #t)
+  (test (subtype? (boolT) (numT)) #f)
+  (test (subtype? (arrowT (numT) (numT)) (numT)) #f)
+  (test (subtype? (numT) (arrowT (numT) (numT))) #f))