Clean up types.scm

1 files changed, 159 insertions, 145 deletions

diff --git a/compiler/types.scm b/compiler/types.scm
index 94c1e1b..c093981 100644
--- a/compiler/types.scm
+++ b/compiler/types.scm
@@ -24,14 +24,23 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-69)
   #:export (policy-map
-            tree-map ;; TODO: Clean up these exports
+            tree-map
 
             <policy>
             scope
             rules
-            policy-top-level-names
             ι-policy-scope
             ι-policy-rules
+            policy-top-level-names
+
+            <scope>
+            identifiers
+            add-to-scope
+            originating-breadcrumb
+            canonicalize
+            collapse-constraints
+            all-valid-identifiers
+            scope-contains?
 
             <rule>
             head
@@ -48,9 +57,15 @@
             inner
             ι-body-conjunction
 
-            <reference>
+            <funcall>
+            args
+
+            <for-all>
+
+            <exists-some>
 
             <constant>
+            scheme-value->type
 
             <set-literal>
 
@@ -60,24 +75,10 @@
 
             <variable-ref>
 
-            <scope>
-            identifiers
-            canonicalize
-            scope-contains?
-            collapse-constraints
-            all-valid-identifiers
-            scheme-value->type
-            update-scope
-            add-to-scope
-
-            <funcall>
-            args
-
-            <for-all>
-
-            <exists-some>))
+            <reference>))
 
 (define (policy-map policy f)
+  "Return POLICY where F has been applied to every form in the rules"
   (over (ι-policy-rules)
         (lambda (rule-groups)
           (map (match-lambda
@@ -129,126 +130,7 @@
   (lens (lambda (s)   (slot-ref s 'scope))
         (lambda (s f) (map-slot s 'scope f))))
 
-;; The intensional database of a Rego program is defined by its rules.
-(define-class <rule> ()
-  (default #:init-form #f
-           #:init-keyword #:default)
-  (head    #:init-keyword #:head
-           #:accessor     head)
-  (body    #:init-keyword #:body
-           #:accessor     body))
-
-(define (ι-rule-body)
-  "Lens for focusing the body of a <rule>"
-  (lens (lambda (s)   (slot-ref s 'body))
-        (lambda (s f) (map-slot s 'body f))))
-
-(define-method (tree-map (form <rule>) f scope breadcrumb)
-  (match form
-    (($ <rule> default head body)
-     ;; A rule body introduces a new scope.
-     (let* ((breadcrumb (add-to-end breadcrumb (name head)))
-            (inner (with-modified-slot form 'head
-                     (tree-map head f scope breadcrumb)))
-            (inner (with-modified-slot inner 'body
-                     (tree-map body f scope breadcrumb))))
-       (f scope breadcrumb inner)))))
-
-;; A (named) relation (equality or inclusion) that holds if the body of the rule is true.
-(define-class <head> ()
-  (name #:init-keyword #:name
-        #:accessor     name)
-  (kind #:init-keyword #:kind ; memq '(value-eqv field-eqv set-memq array-memq)
-        #:accessor     kind)
-  (lhs  #:init-keyword #:lhs
-        #:accessor     left)
-  (rhs  #:init-keyword #:rhs
-        #:accessor     right))
-
-(define-method (tree-map (form <head>) f scope breadcrumb)
-  (match form
-    (($ <head> name kind lhs rhs)
-     ;; A rule body introduces a new scope.
-     (let* ((inner (with-modified-slot form 'kind
-                     (tree-map kind f scope breadcrumb)))
-            ;; (inner (with-modified-slot inner 'lhs
-            ;;          (tree-map lhs f scope breadcrumb)))
-            (inner (with-modified-slot inner 'rhs
-                     (tree-map rhs f scope breadcrumb))))
-       (f scope breadcrumb inner)))))
-
-;; A conjunction that defines whether a rule should apply.
-(define-class <body> ()
-  (conjunction #:init-keyword #:conjunction
-               #:accessor     inner))
-
-(define-method (tree-map (form <body>) f scope breadcrumb)
-  (match form
-    (($ <body> conjunction)
-     (let ((inner (with-modified-slot form 'conjunction
-                    (tree-map conjunction f scope breadcrumb))))
-         (f scope breadcrumb inner)))))
-
-(define (ι-body-conjunction)
-  "Lens for focusing the contents of a <body>"
-  (lens (lambda (s)   (slot-ref s 'conjunction))
-        (lambda (s f) (map-slot s 'conjunction f))))
-
-;; FIXME: Not inclusive of all literals.
-;; Any literal occurrence in a Rego program.
-(define-class <constant> ()
-  (value #:init-keyword #:value)) ; scheme value
-
-(define-method (tree-map (form <constant>) f scope breadcrumb)
-  (f scope breadcrumb form))
-
-(define-class <set-literal> ()
-  (elems #:init-keyword #:elems)) ; list of [scheme value | <set-literal> | <object-literal>]
-
-(define-class <object-literal> ()
-  (pairs #:init-keyword #:pairs)) ; list of [(string, scheme value | <set-literal> | <object-literal>)]
-
-(define-class <comprehension> ()
-  (kind  #:init-keyword #:kind)  ; one of '(array set object)
-  (key   #:init-keyword #:key)
-  (value #:init-keyword #:value)
-  (body  #:init-keyword #:body))
-
-;; A name within a lexical environment.
-;;
-;; Semantically, we don't treat a bare `<variable-ref>' as evaluating to the
-;; value it refers to. For such an operation, we wrap the `<variable-ref>' in a
-;; `<reference>'.
-(define-class <variable-ref> ()
-  (name #:init-keyword #:name ; <string>
-        #:accessor     inner))
-
-(define-method (equal? (x <variable-ref>) (y <variable-ref>))
-  (equal? (inner x) (inner y)))
-
-(define-class <invoke-membership> ()
-  (elem #:init-keyword #:elem) ; <term>
-  (set #:init-keyword #:set))  ; <term>
-
-;; A place within a (possibly nested) data structure.
-;;
-;; As described in the documentation for `<variable-ref>', this is our semantic
-;; encoding for variable dereferencing. Referring to a variable in scope would
-;; be encoded as a `<reference>' containing a single `<variable-ref>'.
-(define-class <reference> ()
-  (parts #:init-keyword #:parts
-         #:accessor inner))
-
-(define-method (equal? (x <reference>) (y <reference>))
-  (equal? (inner x) (inner y)))
-
-(define-method (tree-map (form <reference>) f scope breadcrumb)
-  (match form
-    (($ <reference> parts)
-     (let ((inner (with-modified-slot form 'parts
-                    (map (cut tree-map <> f scope breadcrumb)
-                         parts))))
-       (f scope breadcrumb inner)))))
+
 
 (define-class <scope> ()
   (identifiers #:init-keyword #:identifiers
@@ -334,16 +216,87 @@ and `identifier' is a <reference>"
     (($ <variable-ref> _)  (member identifier (all-valid-identifiers scope breadcrumb)))
     (_ (error "type unsupp"))))
 
-(define (scheme-value->type x)
-  (cond ((boolean? x) 'bool)
-        ((number? x) 'number)
-        (else 'any)))
+
+
+;; The intensional database of a Rego program is defined by its rules.
+(define-class <rule> ()
+  (default #:init-form #f
+           #:init-keyword #:default)
+  (head    #:init-keyword #:head
+           #:accessor     head)
+  (body    #:init-keyword #:body
+           #:accessor     body))
+
+(define (ι-rule-body)
+  "Lens for focusing the body of a <rule>"
+  (lens (lambda (s)   (slot-ref s 'body))
+        (lambda (s f) (map-slot s 'body f))))
+
+(define-method (tree-map (form <rule>) f scope breadcrumb)
+  (match form
+    (($ <rule> default head body)
+     ;; A rule body introduces a new scope.
+     (let* ((breadcrumb (add-to-end breadcrumb (name head)))
+            (inner (with-modified-slot form 'head
+                     (tree-map head f scope breadcrumb)))
+            (inner (with-modified-slot inner 'body
+                     (tree-map body f scope breadcrumb))))
+       (f scope breadcrumb inner)))))
+
+
+
+;; A (named) relation (equality or inclusion) that holds if the body of the rule is true.
+(define-class <head> ()
+  (name #:init-keyword #:name
+        #:accessor     name)
+  (kind #:init-keyword #:kind ; memq '(value-eqv field-eqv set-memq array-memq)
+        #:accessor     kind)
+  (lhs  #:init-keyword #:lhs
+        #:accessor     left)
+  (rhs  #:init-keyword #:rhs
+        #:accessor     right))
+
+(define-method (tree-map (form <head>) f scope breadcrumb)
+  (match form
+    (($ <head> name kind lhs rhs)
+     ;; A rule body introduces a new scope.
+     (let* ((inner (with-modified-slot form 'kind
+                     (tree-map kind f scope breadcrumb)))
+            ;; (inner (with-modified-slot inner 'lhs
+            ;;          (tree-map lhs f scope breadcrumb)))
+            (inner (with-modified-slot inner 'rhs
+                     (tree-map rhs f scope breadcrumb))))
+       (f scope breadcrumb inner)))))
+
+
+
+;; A conjunction that defines whether a rule should apply.
+(define-class <body> ()
+  (conjunction #:init-keyword #:conjunction
+               #:accessor     inner))
+
+(define-method (tree-map (form <body>) f scope breadcrumb)
+  (match form
+    (($ <body> conjunction)
+     (let ((inner (with-modified-slot form 'conjunction
+                    (tree-map conjunction f scope breadcrumb))))
+         (f scope breadcrumb inner)))))
+
+(define (ι-body-conjunction)
+  "Lens for focusing the contents of a <body>"
+  (lens (lambda (s)   (slot-ref s 'conjunction))
+        (lambda (s f) (map-slot s 'conjunction f))))
 
+
+
+;; Call to a Rego function
 (define-class <funcall> ()
-  (ref  #:init-keyword #:name) ; <reference> (to the function being called)
+  (ref  #:init-keyword #:name  ; <reference> (to the function being called)
+        #:accessor name)
   (args #:init-keyword #:args  ; list of <term>
-        #:accessor     args))
+        #:accessor args))
 
+;; Universal quantification over some domain of Rego values
 (define-class <for-all> ()
   (domain #:init-keyword #:domain)
   (key    #:init-keyword #:key)
@@ -357,6 +310,7 @@ and `identifier' is a <reference>"
                     (tree-map body f scope breadcrumb))))
        (f scope breadcrumb inner)))))
 
+;; Existential quantification over some domain of Rego values
 (define-class <exists-some> ()
   (identifiers #:init-keyword #:identifiers
                #:accessor     identifiers))
@@ -368,3 +322,63 @@ and `identifier' is a <reference>"
                     (map (cut tree-map <> f scope breadcrumb)
                          identifiers))))
        (f scope breadcrumb inner)))))
+
+
+
+;; Any literal that evaluates to itself, inclusive of comprehensions.
+(define-class <constant> ()
+  (value #:init-keyword #:value)) ; scheme value
+
+(define-method (tree-map (form <constant>) f scope breadcrumb)
+  (f scope breadcrumb form))
+
+(define-class <set-literal> ()
+  (elems #:init-keyword #:elems)) ; list of [scheme value | <set-literal> | <object-literal>]
+
+(define-class <object-literal> ()
+  (pairs #:init-keyword #:pairs)) ; list of [(string, scheme value | <set-literal> | <object-literal>)]
+
+(define-class <comprehension> ()
+  (kind  #:init-keyword #:kind)  ; one of '(array set object)
+  (key   #:init-keyword #:key)
+  (value #:init-keyword #:value)
+  (body  #:init-keyword #:body))
+
+(define (scheme-value->type x)
+  (cond ((boolean? x) 'bool)
+        ((number? x) 'number)
+        (else 'any)))
+
+
+
+;; A place within a (possibly nested) data structure.
+;;
+;; As described in the documentation for `<variable-ref>', this is our semantic
+;; encoding for variable dereferencing. Referring to a variable in scope would
+;; be encoded as a `<reference>' containing a single `<variable-ref>'.
+(define-class <reference> ()
+  (parts #:init-keyword #:parts
+         #:accessor inner))
+
+(define-method (equal? (x <reference>) (y <reference>))
+  (equal? (inner x) (inner y)))
+
+(define-method (tree-map (form <reference>) f scope breadcrumb)
+  (match form
+    (($ <reference> parts)
+     (let ((inner (with-modified-slot form 'parts
+                    (map (cut tree-map <> f scope breadcrumb)
+                         parts))))
+       (f scope breadcrumb inner)))))
+
+;; A name within a lexical environment.
+;;
+;; Semantically, we don't treat a bare `<variable-ref>' as evaluating to the
+;; value it refers to. For such an operation, we wrap the `<variable-ref>' in a
+;; `<reference>'.
+(define-class <variable-ref> ()
+  (name #:init-keyword #:name ; <string>
+        #:accessor     inner))
+
+(define-method (equal? (x <variable-ref>) (y <variable-ref>))
+  (equal? (inner x) (inner y)))