reformat

Assignments/04.rkt

@@ -20,14 +20,13 @@
   [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]
   [boolT]
   [arrowT (arg : Type)
-           (result : Type)]
+          (result : Type)]
   [objT (fields : (Hashof Symbol Type))])
 
 (define-type-alias TypeEnv (Hashof Symbol Type))
@@ -51,10 +50,10 @@
     [(arrowTE a b) (arrowT (interp-te a)
                            (interp-te b))]
     [(objTE fields) (objT (hash
-                            (map (lambda (key-val)
+                           (map (lambda (key-val)
-                                   (values (fst key-val)
+                                  (values (fst key-val)
-                                           (interp-te (snd key-val))))
+                                          (interp-te (snd key-val))))
-                                 fields)))]))
+                                fields)))]))
 (module+ test
   (test (interp-te (objTE
                     (list (pair 'add1 (arrowTE (numTE) (numTE)))
@@ -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))))))
@@ -78,14 +105,13 @@
 
 (define (typecheck [exp : Exp] [env : TypeEnv]) : Type
   (local
-      [(define (num2 l r type)
+    [(define (num2 l r type)
-         (let ([left-t (typecheck l env)]
+       (let ([left-t (typecheck l env)]
-               [right-t (typecheck r env)])
+             [right-t (typecheck r env)])
-           (if (and (equal? (numT) left-t) (equal? (numT) right-t))
+         (if (and (equal? (numT) left-t) (equal? (numT) right-t))
-               type
+             type
-               (error 'typecheck "expected 2 num"))))]
+             (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)
-                            [field-list (map extract-exp fields)])
+       (let*
-                       (objT (make-hash field-list)))]
+           ([extract-exp (lambda (obj) (pair (fst obj) (typecheck (snd obj) env)))]
-      [(msgE obj selector) (type-case Exp obj
+            [field-list (map extract-exp fields)])
-                             [(objE fields) (type-case (Optionof Exp) (hash-ref (make-hash fields) selector)
+         (objT (hash field-list)))]
-                                              [(none) (error 'typecheck "unknown field")]
+      [(msgE obj selector)
-                                              [(some v) (typecheck v env)])]
+       (type-case Exp obj
-                             [(varE name) (type-case Type (type-lookup name env)
+         [(objE fields)
-                                            [(objT fields) (type-case (Optionof Type) (hash-ref fields selector)
+          (type-case (Optionof Exp) (hash-ref (make-hash fields) selector)
-                                                             [(none) (error 'typecheck "dasdas")]
+            [(none) (error 'typecheck "unknown field")]
-                                                             [(some v) (type-case Type v
+            [(some v) (typecheck v env)])]
-                                                                         [(arrowT a b) b]
+         [(varE name) 
-                                                                         [else (error 'dasdas "dasdas")])])]
+          (type-case Type (type-lookup name env)
-                                            [else (error 'typecheck "bound variable is not an object")])]
+            [(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))
 
@@ -172,7 +196,7 @@
 
 (define (parse sx)
   (local
-      [(define (px i) (parse (sx-ref sx i)))]
+    [(define (px i) (parse (sx-ref sx i)))]
     (cond
       [(s-exp-number? sx) (numE (s-exp->number sx))]
       [(s-exp-symbol? sx)
@@ -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))
@@ -271,18 +293,37 @@
   (test/exn (tc `{,obj-fun 2}) "argument type")
   (test/exn (tc `{if true ,obj-fun 2}) "branches")
   (test (tc `{rec {fact : (obj (run (num -> num)))}
-                  {obj {run {lam {n : num}
+               {obj {run {lam {n : num}
-                                 {if {<= n 0} 1 {* n {{msg fact run} {- n 1}}}}}}}
+                              {if {<= n 0} 1 {* n {{msg fact run} {- n 1}}}}}}}
-                  {{msg fact run} 10}})
+               {{msg fact run} 10}})
-        (numT))
+        (numT)))
-
-  )
 
 (module+ test
-    (test (tc `{,obj-fun {obj {n-func {lam {x : num} x}}
+  (test (tc `{,obj-fun {obj {n-func {lam {x : num} x}}
-                              {b-func {lam {x : bool} x}}}}) (numT))
+                            {b-func {lam {x : bool} x}}}}) (numT))
 
-    (test (tc `{let1 {f : {(obj (n-func (num -> num))) -> num}}
+  (test (tc `{let1 {f : {(obj (n-func (num -> num))) -> num}}
-                     ,obj-fun
+                   ,obj-fun
-                     {f ,sampler}})
+                   {f ,sampler}})
-          (numT)))
+        (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))