reorganize to remove subtype inheritance

8 files changed, 252 insertions, 167 deletions

diff --git a/README.md b/README.md
index bb413fd..b7e62fd 100644
--- a/README.md
+++ b/README.md
@@ -24,17 +24,6 @@ Multiple dispatch is difficult in the presence of inheritance (in R6RS,
 for instance). It would require either disambiguation or a method
 resolution order, which are complicated.
 
-SAHPs do handle single inheritance[^1], because it is an inherent part
-of the numerical tower and R6RS records, and because method dispatch
-can be implemented unambiguously. Multiple inheritance has many of
-the same issues that multiple dispatch has and is also not included.
-Single dispatch and single inheritance work for most other programming
-languages, so why not use it in Scheme?
-
-[^1]: SAHPs are based off of Rust traits, which do not allow for
-      inheritance at all. A more radical design would do away with single
-      inheritance and subtyping entirely.
-
 If one wanted multiple dispatch or multiple inheritance, it would be better
 to use a CLOS style system, which has much more fine-grained control over
 method dispatch. Dynamic and local scoping could be added to a CLOS style
@@ -62,30 +51,109 @@ can override global but not local scope. Dynamic scope allows for the
 program to override default behavior for programs not in lexical scope
 without mutating global state and without overriding local scope.
 
+### On Inheritance
+
+I am very conflicted on inheritance for subtypes of a type. The issue
+is that combining it with scoping introduces a form of the diamond
+problem. For example: imagine if type `T` has an implementation in global
+scope, and its supertype `T'` has an implementation in local scope. Which
+one should be used?
+
+                     SAHP 
+                    /    \
+           T (global)    |
+                   \     T' (local)
+                    \   /
+                     \ /
+                      T
+
+There are two reasonable choices: most specific and closest scope. Closest
+scope is probably the best option, but in some instances it may not
+be enough. One might want to specify a default implementation without
+desiring to override all specific implementations of subtypes. This could
+be done by giving one the ability to specify how each implementation
+should be inherited.
+
+SAHPs currently do not automatically inherit implementations. Records
+designed with SAHPs in mind should use composition, not inheritance.
+
+### The Numeric Tower
+
+The numeric tower has two conflicts with SAHP:
+
+1. The machine representation of types is what SAHPs dispatch against,
+   and the numeric tower hides this.
+2. Exactness is "orthogonal to the dimension of type" (R7RS).
+
+The exact number types that SAHPs will dispatch against are implementation
+defined. They will usually consist of
+
+* [fixnums](https://srfi.schemers.org/srfi-143/),
+* bignums,
+* [flonums](https://srfi.schemers.org/srfi-144/),
+* proper rationals,
+* irrationals,
+* proper complex numbers.
+
+An implementation could also have unitful numbers, quarternions, etc.
+
+In order to support the numeric tower, SAHPs define portable sets of
+types arranged in a hierarchy of subsets. They are
+
+    all-exact-integers
+    ⊆ all-exact-rational
+      ⊆ all-real
+        ⊆ all-complex
+          ⊆ all-number
+
+Type sets are lists that contain other type sets or concrete
+types. Defining an implementation against a type set explicitly
+defines the type set against all implementations, overriding previous
+implementations: hence the prefix `all`. These sets are static.
+
+### What Types are dispatched against?
+
+All fundamental types (pairs, fixnums, vectors, defined record types).
+Predicates are not dispatched against because that would make the type
+system inefficient. One could force this by putting predicates into the
+default implementation of a SAHP.
+
 ## API
 
 A SAHP is a procedure object. There is no portable way to differentiate
-between a SAHP and a regular procedure. A SAHP has a
+between a SAHP and a regular procedure. A SAHP has multiple tables (some
+conceptual) where an implementation is looked up. In order, the SAHP will
+dispatch on (in order of precedence):
 
-* local scope,
-* dynamic scope, and
+* local scope
+* dynamic scope
 * global scope
+* the default implementation.
 
-Multiple SAHPs can share global scope tables. The procedures stored in a
-SAHP must take at least one argument, which is the argument whose type
-is dispatched against.
+The SAHP will raise an error object that satisfies the predicate
+`SAHP-implementation-not-found-error?` if no implementation is found.
+
+Multiple SAHPs can share global scope tables, dynamic scope, and default
+implementations.
+
+The procedures stored in a SAHP must take at least one argument, which
+is the argument whose type is dispatched against.
 
 The phrase "the SAHP resolves to `procedure` given `T`" means that
 if the SAHP is called with a value as its first argument of type `T`,
 it will call `procedure` with all of the arguments passed to it.
 
-When an implement for a type `T` is added to an SAHP, the implementation
-will also be added to every supertype of `T` that does not have an
-implementation already. This currently applies to the numerical tower
-and can be easily extended to systems with single inheritance like R6RS.
+### Type Expressions
+
+A type expression is defined as:
 
-SAHPs do not dispatch against procedures, because that would make dispatch
-non-terminating and possibly non-deterministic.
+* The symbols `boolean`, `char`, `null`, `pair`, `procedure`, `symbol`,
+  `bytevector`, `eof-object`, `port`, `string`, or `vector`, or
+* The values of `all-exact-integers`, `all-exact-rationals`,
+  `all-real`, `all-complex`, and `all-number`, or
+* Lists of type expressions, or
+* the value bound to a name of a record type, or
+* any other implementation defined value.
 
 ### The Object
 
@@ -97,36 +165,49 @@ with any other SAHP.
     (SAHP=? sahp1 sahp2) => boolean?
 
 Returns `#t` if the two SAHPs share the same global SAHP table and
-dynamic state. These SAHPs are not necessarily `eqv?`.
+dynamic state. SAHPs that are `SAHP=?` are not necessarily `eqv?`.
 
 ### Global Scope
 
-    (set-global-SAHP! SAHP type procedure)
+    (set-global-SAHP! SAHP type-expr procedure procedure)
+
+Set `SAHP` to resolve to `procedure` given `type-expr` in global scope.
+
+    (define-global-SAHP (name (type-expr argument) . arg-rest) body ...)
+
+Creates a procedure with the given arguments and body. The SAHP will
+resolve to this procedure given `type-expr` in global scope.
+
+### The Default Implementation
+
+    (set-default-SAHP! SAHP procedure)
 
-Set `SAHP` to resolve to `procedure` given `type` in global scope.
+Set `SAHP` to call `procedure`, if called with a type `T` that the SAHP
+does not resolve to any procedure in any scope.
 
-    (define-global-SAHP (name (type argument) arg-rest ...) body ...)
+    (define-default-SAHP (name arguments . arg-rest) body ...)
 
 Creates a procedure with the given arguments and body. The SAHP will
-resolve to this procedure given `type` in global scope.
+use it as the default implementation.
 
 ### Dynamic Scope
 
-    (parameterize-SAHP ((SAHP (type value) ...) ...) body ...)
+    (parameterize-SAHP ((SAHP (type-expr value) ...) ...) body ...)
 
 Each `SAHP` must resolve to an SAHP.
 
-Each SAHP will have each `type` under it resolve to `value` in dynamic
-scope. These procedures take precedence over global scope procedures.
-The SAHPs are the same SAHP in the block in the sense of `eq?`.
+Each SAHP will have each `type-expr` under it resolve to `value`
+in dynamic scope. These procedures take precedence over global scope
+procedures.  The SAHPs are the same SAHP in the block in the sense of
+`eq?`.
 
 ### Local Scope
 
-    (letrec-SAHP ((SAHP (type value) ...) ...) body ...)
+    (letrec-SAHP ((SAHP (type-expr value) ...) ...) body ...)
 
 Each `SAHP` must be an identifier that resolves to a SAHP.
 
-Each SAHP will have each `type` under it resolve to the corresponding
+Each SAHP will have each `type-expr` under it resolve to the corresponding
 `value` in lexical scope. Each procedure will have the new SAHPs in
 scope.  These procedures will take precedence over dynamic and global
 scope procedures.
@@ -142,6 +223,4 @@ the previous SAHP object.
 
 ## TODO
 
-* Should there be a way to erase local/dynamic bindings? There would need
-  to be a way to mark default supertype bindings.
 * Standard SAHP library.
diff --git a/SAHP.egg b/SAHP.egg
index e006ada..08557a7 100644
--- a/SAHP.egg
+++ b/SAHP.egg
@@ -14,4 +14,4 @@
                (source "lib/SAHP/internal.sld")
                (source-dependencies "lib/SAHP/internal-common.scm"
                                     "lib/SAHP/internal-chicken.scm")
-               (csc-options "-O2" "-R" "r7rs" "-X" "r7rs"))))
+               (csc-options "-include-path" "lib/SAHP/" "-O2" "-R" "r7rs" "-X" "r7rs"))))
diff --git a/lib/SAHP.scm b/lib/SAHP.scm
index 3e60956..0e50b0a 100644
--- a/lib/SAHP.scm
+++ b/lib/SAHP.scm
@@ -19,9 +19,9 @@
 ;;; ;;;;;;;;;;;;
 
 (define (set-global-SAHP! SAHP type procedure)
-  (%SAHP-add-to-global/subtypes (extract-SAHP-descriptor SAHP)
-                                type
-                                procedure))
+  (%SAHP-add-to-global (extract-SAHP-descriptor SAHP)
+                       type
+                       procedure))
 
 (define-syntax define-global-SAHP
   (syntax-rules ()
diff --git a/lib/SAHP.sld b/lib/SAHP.sld
index 49d5cb2..5ab78a4 100644
--- a/lib/SAHP.sld
+++ b/lib/SAHP.sld
@@ -21,6 +21,8 @@
           set-global-SAHP! define-global-SAHP
           SAHP-implementation-not-found-error?
           parameterize-SAHP letrec-SAHP
+          all-exact-integers all-exact-rationals
+          all-reals all-complex all-numbers
           ;; Internal API exposed only for macro use
           SAHP-dynamic-scope-parameter
           SAHP-local-scope
diff --git a/lib/SAHP/internal-chicken.scm b/lib/SAHP/internal-chicken.scm
index 992d98f..e5392a2 100644
--- a/lib/SAHP/internal-chicken.scm
+++ b/lib/SAHP/internal-chicken.scm
@@ -17,12 +17,11 @@
 
 (define (type-of x)
   (cond
-    ((exact-integer? x) 'exact-integer)
-    ((integer? x) 'integer)
-    ((rational? x) 'rational)
-    ((real? x) 'real)
-    ((complex? x) 'complex)
-    ((number? x) 'number)
+    ((fixnum? x) 'fixnum)
+    ((bignum? x) 'bignum)
+    ((flonum? x) 'flonum)
+    ((cplxnum? x) 'cplxnum)
+    ((ratnum? x) 'ratnum)
     ((boolean? x) 'boolean)
     ((char? x) 'char)
     ((null? x) 'null)
@@ -37,11 +36,17 @@
     ((record-instance? x) (record-instance-type x))
     (else (error "cannot derive type of" x))))
 
-(define (subtypes type)
-  (case type
-    ((number) '(complex))
-    ((complex) '(real))
-    ((real) '(rational))
-    ((rational) '(integer))
-    ((integer) '(exact-integer))
-    (else '())))
+(define all-exact-integers
+  '(fixnum bignum))
+
+(define all-exact-rationals
+  `(,all-exact-integers ratnum))
+
+(define all-reals
+  `(,all-exact-rationals flonum))
+
+(define all-complex
+  `(,all-reals cplxnum))
+
+(define all-numbers all-complex)
+
diff --git a/lib/SAHP/internal-common.scm b/lib/SAHP/internal-common.scm
index 9030c7c..5854c51 100644
--- a/lib/SAHP/internal-common.scm
+++ b/lib/SAHP/internal-common.scm
@@ -1,4 +1,4 @@
-#| Copyright 2024 Peter McGoron
+#| Copyright 2025 Peter McGoron
  |
  | Licensed under the Apache License, Version 2.0 (the "License");
  |
@@ -14,7 +14,6 @@
  | limitations under the License.
  |#
 
-
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Utilities
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -42,12 +41,6 @@
   (dynamic-scope SAHP-dynamic-scope-parameter)
   (global-scope SAHP-global-scope))
 
-(define-record-type <SAHP-entry>
-  (make-SAHP-entry procedure inherited?)
-  SAHP-entry?
-  (procedure SAHP-entry-procedure)
-  (inherited? SAHP-entry-inherited?))
-
 (define (SAHP=? sahp1 sahp2)
   (eq? (SAHP-global-scope (extract-SAHP-descriptor sahp1))
        (SAHP-global-scope (extract-SAHP-descriptor sahp2))))
@@ -56,44 +49,28 @@
 ;;; Handling scope
 ;;; ;;;;;;;;;;;;;;;;;;;;;;
 
-(define (add-to-scope/subtypes scope type value)
-  (define (entry-is-empty-or-inherited? scope type)
-    (mapping-ref scope type (lambda () #t) SAHP-entry-inherited?))
-  (define (recurse-on-subtype subtype scope)
-    (if (entry-is-empty-or-inherited? scope subtype)
-        (fold recurse-on-subtype
-              (mapping-set scope
-                           subtype
-                           (make-SAHP-entry value #t))
-              (subtypes subtype))
-        scope))
-  (fold recurse-on-subtype
-        (mapping-set scope
-                     type
-                     (make-SAHP-entry value #f))
-        (subtypes type)))
-
-(define (%SAHP-add-to-global/subtypes SAHP-desc type value)
-  (define table (SAHP-global-scope SAHP-desc))
-  (define (empty-or-inherited? type)
-    (let ((entry (hash-table-ref/default table type #f)))
-      (if (SAHP-entry? entry)
-          (SAHP-entry-inherited? entry)
-          #t)))
-  (define (recurse-on-subtype type)
-    (when (empty-or-inherited? type)
-      (hash-table-set! table type (make-SAHP-entry value #t))
-      (for-each recurse-on-subtype (subtypes type))))
-  (hash-table-set! table type (make-SAHP-entry value #f))
-  (for-each recurse-on-subtype (subtypes type)))
+(define (add-to-scope scope type-expr value)
+  (cond
+    ((pair? type-expr)
+     (fold (lambda (type-expr scope)
+             (add-to-scope scope type-expr value))
+           scope
+           type-expr))
+    (else (mapping-set scope type-expr value))))
+
+(define (%SAHP-add-to-global SAHP-desc type-expr value)
+  (cond
+    ((pair? type-expr)
+     (for-each (cut %SAHP-add-to-global SAHP-desc <> value)
+               type-expr))
+    (else (hash-table-set! (SAHP-global-scope SAHP-desc)
+                           type-expr
+                           value))))
 
 (define (%SAHP-set/subtypes scope types values)
   (cond
     ((null? types) scope)
-    (else (%SAHP-set/subtypes (add-to-scope/subtypes
-                               scope
-                               (car types)
-                               (car values))
+    (else (%SAHP-set/subtypes (add-to-scope scope (car types) (car values))
                               (cdr types)
                               (cdr values)))))
 
@@ -118,8 +95,11 @@
   (or (mapping-ref/default (SAHP-local-scope desc) type #f)
       (mapping-ref/default ((SAHP-dynamic-scope-parameter desc)) type #f)
       (hash-table-ref/default (SAHP-global-scope desc) type #f)
+      (mapping-ref/default (SAHP-local-scope desc) '* #f)
+      (mapping-ref/default ((SAHP-dynamic-scope-parameter desc)) '* #f)
+      (hash-table-ref/default (SAHP-global-scope desc) '* #f)
       (error cannot-find-implementation-str desc type)))
 
 (define (call-SAHP desc type arguments)
-  (apply (SAHP-entry-procedure (lookup-SAHP-implementation desc type))
-         arguments))
+  (apply (lookup-SAHP-implementation desc type) arguments))
+
diff --git a/lib/SAHP/internal.sld b/lib/SAHP/internal.sld
index e4a5ac0..4a40096 100644
--- a/lib/SAHP/internal.sld
+++ b/lib/SAHP/internal.sld
@@ -16,15 +16,18 @@
 
 (define-library (SAHP internal)
   (import (scheme base)
-          (srfi 1) (srfi 69) (srfi 128) (srfi 146))
+          (chicken base)
+          (srfi 1) (srfi 69) (srfi 111) (srfi 128) (srfi 146))
   (export make-new-SAHP extract-SAHP-descriptor
           SAHP-dynamic-scope-parameter
           SAHP-local-scope
           SAHP=?
           SAHP-implementation-not-found-error?
           %SAHP-set/subtypes
-          %SAHP-add-to-global/subtypes
-          %SAHP/local-scope)
+          %SAHP-add-to-global
+          %SAHP/local-scope
+          all-exact-integers all-exact-rationals
+          all-reals all-complex all-numbers)
   (cond-expand
     (chicken (import (chicken memory representation))
              (include "internal-chicken.scm"))
diff --git a/tests/run.scm b/tests/run.scm
index f6ace47..cbc19f4 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -17,7 +17,7 @@
 (import (scheme base)
         (mcgoron srfi 64)
         (SAHP)
-        (srfi 64) (srfi 252))
+        (srfi 64) (srfi 194) (srfi 252))
 
 (test-runner-factory factory)
 (test-runner-current (test-runner-create))
@@ -135,80 +135,96 @@
               (else #f)))))
       (test-property override (list (bytevector-generator))))))
 
-(test-group "subtyping"
-  ;; TODO: property testing
+(test-group "numeric tower type expressions"
   (define sub (make-new-SAHP))
-  (define (test-for-all)
-    (test-assert "exact integer" (sub 0))
-    (test-assert "integer" (sub 1.0))
-    (test-assert "rational" (sub 1/2))
-    (test-assert "real" (sub +inf.0))
-    (test-assert "complex" (sub 1+2i))
-    (test-assert "not implemented"
-                 (guard (c
-                         (else
-                          (SAHP-implementation-not-found-error? c)))
-                   (sub "not a number")
-                   #f)))
-  (define (test-for-some)
-    (test-assert "exact integer" (sub 0))
-    (test-assert "integer" (sub 1.0))
-    (test-assert "rational" (sub 1/2))
-    (test-assert "not for complex"
-                 (guard (c
-                         (else
-                          (SAHP-implementation-not-found-error? c)))
-                   (sub +inf.0))))
+  (define test-all-numbers
+    (case-lambda
+      (() (test-all-numbers sub))
+      ((sub)
+       (test-group "implemented"
+         (test-property sub (list (gsampling (number-generator)))))
+       (test-assert "not implemented"
+                    (guard (c
+                            (else
+                             (SAHP-implementation-not-found-error? c)))
+                      (sub "not a number")
+                      #f)))))
+  (define test-some-numbers
+    (case-lambda
+      (() (test-some-numbers sub))
+      ((sub)
+       (test-group "exact rationals and integers"
+         (test-property sub
+                        (list (gsampling
+                               (exact-rational-generator)
+                               (exact-integer-generator)))))
+       (test-assert "not for complex"
+                    (guard (c
+                            (else
+                             (SAHP-implementation-not-found-error? c)))
+                      (sub +inf.0))))))
   (test-group "local scope"
-    (test-group "subtypes flow downwards"
-      (letrec-SAHP ((sub ('number (lambda (x) #t))))
-        (test-assert "exact integer" (sub 0))
-        (test-assert "integer" (sub 1.0))
-        (test-assert "rational" (sub 1/2))
-        (test-assert "real" (sub +inf.0))
-        (test-assert "complex" (sub 1+2i))
-        (test-assert "not implemented"
-                     (guard (c
-                             (else
-                              (SAHP-implementation-not-found-error? c)))
-                       (sub "not a number")
-                       #f))))
+    (test-group "type expression flow downwards"
+      (letrec-SAHP ((sub (all-numbers (lambda (x) #t))))
+        (test-all-numbers sub)))
     (test-group "subtypes do not flow upwards"
-      (letrec-SAHP ((sub ('rational (lambda (x) #t))))
-        (test-assert "exact integer" (sub 0))
-        (test-assert "integer" (sub 1.0))
-        (test-assert "rational" (sub 1/2))
-        (test-assert "not for complex"
-                     (guard (c
-                             (else
-                              (SAHP-implementation-not-found-error? c)))
-                       (sub +inf.0))))))
+      (letrec-SAHP ((sub (all-exact-rationals (lambda (x) #t))))
+        (test-some-numbers sub))))
   (test-group "dynamic scope"
     (test-group "subtypes flow downwards"
-      (parameterize-SAHP ((sub ('number (lambda (x) #t))))
-        (test-for-all)))
+      (parameterize-SAHP ((sub (all-numbers (lambda (x) #t))))
+        (test-all-numbers sub)))
     (test-group "subtypes do not flow upwards"
-      (parameterize-SAHP ((sub ('rational (lambda (x) #t))))
-        (test-for-some)))
+      (parameterize-SAHP ((sub (all-exact-rationals (lambda (x) #t))))
+        (test-some-numbers sub)))
     (test-group "local scope overrides dynamic scope subtyping"
-      (parameterize-SAHP ((sub ('number (lambda (x) 1))))
-        (letrec-SAHP ((sub ('rational (lambda (x) 2))))
-          (test-equal 2 (sub 0))
-          (test-equal 2 (sub 1/2))
-          (test-equal 1 (sub 1+2i))))))
+      (parameterize-SAHP ((sub (all-numbers (lambda (x) 1))))
+        (letrec-SAHP ((sub (all-exact-rationals (lambda (x) 2))))
+          (define (test-local n)
+            (= 2 (sub n)))
+          (define (test-dynamic n)
+            (= 1 (sub n)))
+          (test-group "local"
+            (test-property test-local
+                           (list
+                            (gsampling (exact-rational-generator)))))
+          (test-group "dynamic"
+            (test-property test-dynamic
+                           (list
+                            (gsampling (inexact-complex-generator)))))))))
   (test-group "global scope"
-    (define-global-SAHP (sub ('number x))
+    (define-global-SAHP (sub (all-numbers x))
       1)
+    (define (test-global n)
+      (= 1 (sub n)))
+    (define (test-dynamic n)
+      (= 2 (sub n)))
     (test-group "subtypes flow downwards"
-      (test-for-all))
+      (test-all-numbers))
     (test-group "dynamic scope overrides global scope"
-      (parameterize-SAHP ((sub ('rational (lambda (x) 2))))
-        (test-equal 2 (sub 0))
-        (test-equal 2 (sub 1/2))
-        (test-equal 1 (sub 1+2i))))
+      (parameterize-SAHP ((sub (all-exact-rationals (lambda (x) 2))))
+        (test-group "dynamic"
+          (test-property test-dynamic
+                         (list
+                          (gsampling (exact-rational-generator)))))
+        (test-group "global"
+          (test-property test-global
+                         (list
+                          (gsampling (inexact-complex-generator)))))))
     (test-group "local scope overrides dynamic scope overrides global scope"
-      (parameterize-SAHP ((sub ('rational (lambda (x) 2))))
-        (letrec-SAHP ((sub ('integer (lambda (x) 3))))
-          (test-equal 3 (sub 0))
-          (test-equal 2 (sub 1/2))
-          (test-equal 1 (sub 1+2i)))))))
+      (parameterize-SAHP ((sub (all-exact-rationals (lambda (x) 2))))
+        (letrec-SAHP ((sub (all-exact-integers (lambda (x) 3))))
+          (define (test-local n)
+            (= 3 (sub n)))
+          (test-group "dynamic"
+            (test-property test-dynamic
+                           (list
+                            (gsampling (exact-rational-generator)))))
+          (test-group "global"
+            (test-property test-global
+                           (list
+                            (gsampling (inexact-complex-generator)))))
+          (test-group "local"
+            (test-property test-local
+                           (list
+                            (gsampling (exact-integer-generator))))))))))