dispatch on types with multiple scopes

9 files changed, 493 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..0880f22
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,6 @@
+*.build.sh
+*.install.sh
+*.import.scm
+*.so
+*.link
+*.o
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..bb413fd
--- /dev/null
+++ b/README.md
@@ -0,0 +1,147 @@
+# Singly Ad-Hoc Polymorphic Procedures (SAHP) with Scope
+
+## Introduction
+
+This is an R7RS library that implements what the title says:
+
+* Ad-hoc: Polymorphism based on implementing specific procedures.
+* Singly polymorphic: The implementation is selected based off of a single
+  argument.
+* With scope: SAHP implementations can be overridden in dynamic scope,
+  and (somewhat) lexical scope. SAHPs can also be closed in lexical scope
+  and passed to other procedures outside of lexical scope while retaining
+  their bindings.
+
+These procedures are called "SAHPs" (pronounced "saps").
+
+This library is meant to be a system of polymorphic functions completely
+indepent of any object system. It is meant to be simple and have no
+surprises.
+
+### Why Singly Polymorphic (aka Single Dispatch)?
+
+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
+system, although the API would probably have to change.
+
+### Why Scope?
+
+SAHPs should behave like regular procedures wherever possible. This means
+allowing for redefinition in lexical scope. Normal procedures only have
+one body, while SAHPs have multiple, so local[^2] scope should only
+override the procedure bodys that are specified. Locally scoped SAHPs
+will also capture their lexical environment and can be passed around
+like closures, while still maintaining their global state.
+
+[^2]: I call it "local" instead of "lexical" scope because it might not
+      technically be "lexical scope".
+
+If SAHPs could only be modified with lexical scope, they would not be
+very useful. A library should be able to register a global change to a
+SAHP for any record type that it makes. Hence SAHPs also have a global
+scope which is always shadowed by a SAHP's local scope.
+
+AHSPs also have a dynamic scope (implemented using parameters) that
+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.
+
+## 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
+
+* local scope,
+* dynamic scope, and
+* global scope
+
+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 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.
+
+SAHPs do not dispatch against procedures, because that would make dispatch
+non-terminating and possibly non-deterministic.
+
+### The Object
+
+    (make-new-SAHP)
+
+Create a global SAHP with empty tables. This SAHP does not share memory
+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?`.
+
+### Global Scope
+
+    (set-global-SAHP! SAHP type procedure)
+
+Set `SAHP` to resolve to `procedure` given `type` in global scope.
+
+    (define-global-SAHP (name (type argument) arg-rest ...) body ...)
+
+Creates a procedure with the given arguments and body. The SAHP will
+resolve to this procedure given `type` in global scope.
+
+### Dynamic Scope
+
+    (parameterize-SAHP ((SAHP (type 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?`.
+
+### Local Scope
+
+    (letrec-SAHP ((SAHP (type 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
+`value` in lexical scope. Each procedure will have the new SAHPs in
+scope.  These procedures will take precedence over dynamic and global
+scope procedures.
+
+The SAHPs will be bound to new SAHP objects that share their global and
+dynamic scope with previous SAHP objects. If these SAHPs are passed
+to another procedure or stored somewhere, they will keep their local
+bindings.
+
+If the SAHPs passed to `letrec-SAHP` had local bindings, then
+`letrec-SAHP` will replace old bindings and add new ones without affecting
+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
new file mode 100644
index 0000000..c28a907
--- /dev/null
+++ b/SAHP.egg
@@ -0,0 +1,17 @@
+((author "Peter McGoron")
+ (version "0.1.0")
+ (synopsis "Singly Ad-Hoc Polymorphic Procedures with Scope")
+ (category oop)
+ (license "Apache-2.0")
+ (dependencies r7rs srfi-69 srfi-146)
+ (test-dependencies srfi-64 srfi-128 srfi-252)
+ (components (extension SAHP
+               (source "SAHP.sld")
+               (component-dependencies SAHP.internal)
+               (source-dependencies "SAHP.scm")
+               (csc-options "-O2" "-R" "r7rs" "-X" "r7rs"))
+             (extension SAHP.internal
+               (source "SAHP.internal.sld")
+               (source-dependencies "SAHP.internal-common.scm"
+                                    "SAHP.internal-chicken.scm")
+               (csc-options "-O2" "-R" "r7rs" "-X" "r7rs"))))
diff --git a/SAHP.internal-chicken.scm b/SAHP.internal-chicken.scm
new file mode 100644
index 0000000..992d98f
--- /dev/null
+++ b/SAHP.internal-chicken.scm
@@ -0,0 +1,47 @@
+(define (%make-derived-SAHP desc)
+  (let ((proc (lambda (arg1 . arg-rest)
+                (call-SAHP desc (type-of arg1) (cons arg1 arg-rest)))))
+    (extend-procedure proc desc)))
+
+(define (make-new-SAHP)
+  (%make-derived-SAHP
+   (make-SAHP-descriptor (make-symbol-mapping)
+                         (make-parameter (make-symbol-mapping))
+                         (make-hash-table))))
+
+(define (SAHP? x)
+  (and (extended-procedure? x)
+       (SAHP-descriptor? (extract-SAHP-descriptor x))))
+
+(define extract-SAHP-descriptor procedure-data)
+
+(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)
+    ((boolean? x) 'boolean)
+    ((char? x) 'char)
+    ((null? x) 'null)
+    ((pair? x) 'pair)
+    ((procedure? x) 'procedure)
+    ((symbol? x) 'symbol)
+    ((bytevector? x) 'bytevector)
+    ((eof-object? x) 'eof-object)
+    ((port? x) 'port)
+    ((string? x) 'string)
+    ((vector? x) 'vector)
+    ((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 '())))
diff --git a/SAHP.internal-common.scm b/SAHP.internal-common.scm
new file mode 100644
index 0000000..edb90bc
--- /dev/null
+++ b/SAHP.internal-common.scm
@@ -0,0 +1,125 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ |
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Utilities
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define symbol-comparator
+  (make-comparator symbol?
+                   symbol=?
+                   (lambda (s1 s2)
+                     (string<=? (symbol->string s1)
+                                (symbol->string s2)))
+                   (lambda (s)
+                     (string-hash (symbol->string s)))))
+
+(define (make-symbol-mapping)
+  (mapping symbol-comparator))
+
+;;; ;;;;;;;;;;;;;;;;;;;;
+;;; Defining the SAHP object
+;;; ;;;;;;;;;;;;;;;;;;;;
+
+(define-record-type <SAHP-descriptor>
+  (make-SAHP-descriptor local-scope dynamic-scope global-scope)
+  SAHP-descriptor?
+  (local-scope SAHP-local-scope)
+  (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))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;
+;;; Handling scope
+;;; ;;;;;;;;;;;;;;;;;;;;;;
+
+(define (add-to-scope/subtypes scope type value)
+  (define (entry-is-empty-or-inherited? scope type)
+    (mapping-ref scope type (lambda () #f) 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 entry
+          (SAHP-entry-inherited? entry)
+          #f)))
+  (define (recurse-on-subtype subtype)
+    (when (empty-or-inherited? type)
+      (hash-table-set! table type (make-SAHP-entry value #f))
+      (for-each recurse-on-subtype (subtypes subtype))))
+  (hash-table-set! table type (make-SAHP-entry value #t))
+  (for-each recurse-on-subtype (subtypes type)))
+
+(define (%SAHP-set/subtypes scope types values)
+  (cond
+    ((null? types) scope)
+    (else (%SAHP-set/subtypes (add-to-scope/subtypes
+                               scope
+                               (car types)
+                               (car values))
+                              (cdr types)
+                              (cdr values)))))
+
+(define (%SAHP/local-scope SAHP local-scope)
+  (%make-derived-SAHP
+   (make-SAHP-descriptor local-scope
+                         (SAHP-dynamic-scope-parameter SAHP)
+                         (SAHP-global-scope SAHP))))
+
+;;; ;;;;;;;;;;;;;;;;;;;;;;
+;;; Lookup
+;;; ;;;;;;;;;;;;;;;;;;;;;;
+
+(define cannot-find-implementation-str
+  "cannot find implementation")
+
+(define (SAHP-implementation-not-found-error? x)
+  (and (error-object? x)
+       (eq? (error-object-message x) cannot-find-implementation-str)))
+
+(define (lookup-SAHP-implementation desc type)
+  (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)
+      (error cannot-find-implementation-str desc type)))
+
+(define (call-SAHP desc type arguments)
+  (apply (SAHP-entry-procedure (lookup-SAHP-implementation desc type))
+         arguments))
diff --git a/SAHP.internal-portable.scm b/SAHP.internal-portable.scm
new file mode 100644
index 0000000..3174f4c
--- /dev/null
+++ b/SAHP.internal-portable.scm
@@ -0,0 +1,34 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ |
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+#| A portable implementation of `extract-SAHP-descriptor`, `make-new-SAHP`
+   using a unexported sentinel object.
+|#
+
+(define SAHP-sentinel-value
+  (vector #f))
+
+(define (extract-SAHP-descriptor SAHP)
+  (SAHP SAHP-sentinel-value))
+
+(define (make-new-SAHP)
+  (let ((SAHP (make-SAHP-descriptor (make-symbol-mapping)
+                                    (make-parameter (make-symbol-mapping))
+                                    (make-symbol-hash-table)))))
+  (lambda (arg1 . arg-rest)
+    (if (eq? arg1 SAHP-sentinel-value)
+        SAHP
+        (call-SAHP SAHP (type-of arg1) (cons arg1 arg-rest)))))
diff --git a/SAHP.internal.sld b/SAHP.internal.sld
new file mode 100644
index 0000000..199a66a
--- /dev/null
+++ b/SAHP.internal.sld
@@ -0,0 +1,32 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ |
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(define-library (SAHP internal)
+  (import (scheme base)
+          (srfi 1) (srfi 69) (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)
+  (cond-expand
+    (chicken (import (chicken memory representation))
+             (include "SAHP.internal-chicken.scm"))
+    (else (include "SAHP.internal-portable.scm")))
+  (include "SAHP.internal-common.scm"))
diff --git a/SAHP.scm b/SAHP.scm
new file mode 100644
index 0000000..3e60956
--- /dev/null
+++ b/SAHP.scm
@@ -0,0 +1,57 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ |
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+;;; ;;;;;;;;;;;;
+;;; API
+;;; ;;;;;;;;;;;;
+
+(define (set-global-SAHP! SAHP type procedure)
+  (%SAHP-add-to-global/subtypes (extract-SAHP-descriptor SAHP)
+                                type
+                                procedure))
+
+(define-syntax define-global-SAHP
+  (syntax-rules ()
+    ((_ (name (type arg1) . arg-rest) body ...)
+     (set-global-SAHP! name
+                       type
+                       (lambda (arg1 . arg-rest)
+                         body ...)))))
+
+(define-syntax parameterize-SAHP
+  (syntax-rules ()
+    ((_ ((SAHP (type value) ...) ...) body ...)
+     (let ((param (SAHP-dynamic-scope-parameter (extract-SAHP-descriptor
+                                                 SAHP)))
+           ...)
+       (parameterize ((param (%SAHP-set/subtypes (param)
+                                                 (list type ...)
+                                                 (list value ...)))
+                      ...)
+         body ...)))))
+
+(define-syntax letrec-SAHP
+  (syntax-rules ()
+    ((_ ((SAHP (type value) ...) ...) body ...)
+     (let ((%SAHP (extract-SAHP-descriptor SAHP)) ...)
+       (letrec ((SAHP (%SAHP/local-scope
+                       %SAHP
+                       (%SAHP-set/subtypes (SAHP-local-scope
+                                            %SAHP)
+                                           (list type ...)
+                                           (list value ...))))
+                ...)
+         body ...)))))
diff --git a/SAHP.sld b/SAHP.sld
new file mode 100644
index 0000000..49d5cb2
--- /dev/null
+++ b/SAHP.sld
@@ -0,0 +1,28 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ |
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(define-library (SAHP)
+  (import (scheme base)
+          (SAHP internal))
+  (export make-new-SAHP SAHP=?
+          set-global-SAHP! define-global-SAHP
+          SAHP-implementation-not-found-error?
+          parameterize-SAHP letrec-SAHP
+          ;; Internal API exposed only for macro use
+          SAHP-dynamic-scope-parameter
+          SAHP-local-scope
+          %SAHP-set/subtypes %SAHP/local-scope)
+  (include "SAHP.scm"))