Skip to content

Instantly share code, notes, and snippets.

@frenchy64
Created May 17, 2012 11:10
Show Gist options
  • Save frenchy64/2718201 to your computer and use it in GitHub Desktop.
Save frenchy64/2718201 to your computer and use it in GitHub Desktop.
clojure.core/isa? port to Typed Racket
;(defn isa?
; "Returns true if (= child parent), or child is directly or indirectly derived from
; parent, either via a Java type inheritance relationship or a
; relationship established via derive. h must be a hierarchy obtained
; from make-hierarchy, if not supplied defaults to the global
; hierarchy"
; {:added "1.0"}
; ([child parent] (isa? global-hierarchy child parent))
; ([h child parent]
; (or (= child parent)
; (and (class? parent) (class? child)
; (. ^Class parent isAssignableFrom child))
; (contains? ((:ancestors h) child) parent)
; (and (class? child) (some #(contains? ((:ancestors h) %) parent) (supers child)))
; (and (vector? parent) (vector? child)
; (= (count parent) (count child))
; (loop [ret true i 0]
; (if (or (not ret) (= i (count parent)))
; ret
; (recur (isa? h (child i) (parent i)) (inc i))))))))
(require racket/set)
(struct: class ([name : Symbol]))
(struct: hierarchy ([ancestors : (HashTable class (Setof class))]))
(define int-class (class 'int))
(define num-class (class 'num))
(define float-class (class 'float))
(define object-class (class 'object))
(define global-hierarchy (hierarchy
(make-hash (list (cons object-class ((inst set class)))
(cons int-class (set object-class num-class))
(cons num-class (set object-class))
(cons float-class (set num-class object-class))))))
(: class-assignable-from-class? (class class -> Boolean))
(define (class-assignable-from-class? child parent)
#f)
(: some-super (hierarchy Any class -> Boolean))
(define (some-super h p c)
#f)
(define-predicate vector-of? (Vectorof Any))
(: isa? (case-lambda
(Any Any -> Boolean)
(hierarchy Any Any -> Boolean)))
(define isa?
(case-lambda
((child parent) (isa? global-hierarchy child parent))
((h child parent)
(or (equal? child parent)
(and (class? parent) (class? child)
(class-assignable-from-class? child parent))
(and (class? child)
(let* ([hs (hierarchy-ancestors h)])
(and (hash-has-key? hs child)
(let ([as (hash-ref hs child)])
(set-member? as parent)))))
(and (class? child) (some-super h parent child))
(and (vector-of? child) (vector-of? parent)
(= (vector-length child) (vector-length parent))
(let: loop : Boolean
([ret : Boolean #t]
[i : Integer 0])
(if (or (not ret) (= i (vector-length parent)))
ret
(loop (isa? h (vector-ref child i) (vector-ref parent i)) (+ 1 i)))
))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment