From e9509ca1261e34fde9652dba185d66cbc56e5597 Mon Sep 17 00:00:00 2001
From: Jakob L. Kreuze
Date: Sun, 16 Apr 2023 19:14:17 -0400
Subject: GOOPS rewrite

---
 compiler/lean.scm                       |  18 +-
 compiler/main.scm                       |  19 +-
 compiler/passes/compile-exists-some.scm |  22 +-
 compiler/passes/compile-funcall.scm     |   2 +-
 compiler/passes/emit-specification.scm  |  49 +++--
 compiler/passes/extract-identifiers.scm |  21 +-
 compiler/passes/parse-policy.scm        |  47 +++--
 compiler/passes/preprocess-policy.scm   | 106 +++++-----
 compiler/types.scm                      | 348 +++++++++++++++-----------------
 compiler/utilities.scm                  |  48 ++++-
 10 files changed, 370 insertions(+), 310 deletions(-)

diff --git a/compiler/lean.scm b/compiler/lean.scm
index 41d4c92..7c1e226 100644
--- a/compiler/lean.scm
+++ b/compiler/lean.scm
@@ -73,10 +73,24 @@
   (body      #:init-keyword #:body
              #:getter       body))
 
+(define-method (tree-map (form <lean-exists>) f scope breadcrumb)
+  (match form
+    (($ <lean-exists> variables body)
+     (let ((inner (with-modified-slot form 'body
+                    (tree-map body f scope breadcrumb))))
+       (f scope breadcrumb inner)))))
+
 (define-class <lean-conjunction> (<lean-expression>)
   (clauses #:init-keyword #:clauses
            #:getter       clauses))
 
+(define-method (tree-map (form <lean-conjunction>) f scope breadcrumb)
+  (match form
+    (($ <lean-conjunction> clauses)
+     (let ((inner (with-modified-slot form 'clauses
+                    (tree-map clauses f scope breadcrumb))))
+         (f scope breadcrumb inner)))))
+
 (define-class <lean-compare> (<lean-expression>)
   (kind  #:init-keyword #:kind
          #:getter       kind)
@@ -226,7 +240,7 @@
   (match reference
     (($ <reference> (x)) (sanitize x))
     (($ <reference> (x xs ...))
-     (if (and (equal? x (make-variable-ref "internal"))
-              (equal? xs (list (make-constant "member_2"))))
+     (if (and (equal? (to-pretty-sexp x) `(<variable-ref> "internal"))
+              (equal? (to-pretty-sexp xs) (list `(<constant> "member_2"))))
          "Array.contains"
          (error "Unimplemented")))))
diff --git a/compiler/main.scm b/compiler/main.scm
index 387aed7..91fc611 100644
--- a/compiler/main.scm
+++ b/compiler/main.scm
@@ -23,6 +23,7 @@
   #:use-module (compiler passes parse-policy)
   #:use-module (compiler passes preprocess-policy)
   #:use-module (compiler passes read-and-parse)
+  #:use-module (compiler utilities)
   #:use-module (ice-9 pretty-print)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
@@ -45,18 +46,6 @@ of `(program-arguments)'."
                   ((policy) (parse-policy package imports rules))
                   ((policy) (extract-identifiers policy))
                   ((policy) (compile-exists-some policy))
-                  ((policy) (compile-funcall policy))
-                  ;; ((policy) (compile-ref policy))
-                  )
-      (pretty-print policy)
-      ;; (emit-specification policy)
-      )))
-
-(let*-values (((ast) (read-and-parse "/home/jakob/Research/rego-proofs/examples/03-set-defined-by-predicate.rego"))
-              ((package imports rules) (preprocess-policy ast))
-              ((policy) (parse-policy package imports rules))
-              ((policy) (extract-identifiers policy))
-              ((policy) (compile-constraints policy))
-              ((policy) (compile-exists-some policy))
-              ((policy) (compile-funcall policy)))
-  (emit-specification policy))
+                  ((policy) (compile-funcall policy)))
+      ;; (pretty-print (to-pretty-sexp policy))
+      (emit-specification policy))))
diff --git a/compiler/passes/compile-exists-some.scm b/compiler/passes/compile-exists-some.scm
index 6bdd643..5af0245 100644
--- a/compiler/passes/compile-exists-some.scm
+++ b/compiler/passes/compile-exists-some.scm
@@ -24,6 +24,9 @@
   #:use-module (srfi srfi-1)
   #:export (compile-exists-some))
 
+(define (exists-some? form)
+  (is-a? form <exists-some>))
+
 (define (partition-on-quantification xs)
   (define (recur result running cur)
     (cond ((null? cur)
@@ -36,29 +39,30 @@
 
 (define (exists-some->variables identifiers)
   (map (lambda (x)
-         (cond ((variable-ref? x) x)
+         (cond ((is-a? x <variable-ref>) x)
                ;; TODO: Assert that this is internal.member2
-               ((funcall? x) (first (funcall-args x)))
+               ((is-a? x <funcall>) (first (args x)))
                (else (error "unimplement"))))
-       (exists-some-identifiers identifiers)))
+       identifiers))
 
 (define (exists-some->constraints identifiers)
   (fold append '()
         (map (lambda (x)
-               (cond ((variable-ref? x) '())
-                     ((funcall? x) (list x))
+               (cond ((is-a? x <variable-ref>) '())
+                     ((is-a? x <funcall>) (list x))
                      (else (error "unimplement"))))
-             (exists-some-identifiers identifiers))))
+             identifiers)))
 
 (define (process-quantified-extent xs)
   (assert (list? xs))
   (if (and (positive? (length xs))
            (exists-some? (first xs)))
       (make <lean-exists>
-        #:variables (exists-some->variables (first xs))
+        #:variables (exists-some->variables (identifiers (first xs)))
         #:body
         (make <lean-conjunction>
-          #:clauses (append (exists-some->constraints (first xs)) (drop xs 1))))
+          #:clauses (append (exists-some->constraints (identifiers (first xs)))
+                            (drop xs 1))))
       xs))
 
 (define (process-all form)
@@ -66,7 +70,7 @@
   (map process-quantified-extent (partition-on-quantification form)))
 
 (define (compile-exists-some policy)
-  (mutate-tree
+  (policy-map
    policy
    (lambda (scope breadcrumb form)
      (if (and (list? form) (any exists-some? form))
diff --git a/compiler/passes/compile-funcall.scm b/compiler/passes/compile-funcall.scm
index 2e170c0..04444ad 100644
--- a/compiler/passes/compile-funcall.scm
+++ b/compiler/passes/compile-funcall.scm
@@ -24,7 +24,7 @@
   #:export (compile-funcall))
 
 (define (compile-funcall policy)
-  (mutate-tree
+  (policy-map
    policy
    (lambda (scope breadcrumb form)
      (match form
diff --git a/compiler/passes/emit-specification.scm b/compiler/passes/emit-specification.scm
index f2290e4..6af8776 100644
--- a/compiler/passes/emit-specification.scm
+++ b/compiler/passes/emit-specification.scm
@@ -27,10 +27,9 @@
   #:export (emit-specification))
 
 (define (reference->string reference)
-  (string-join (map (lambda (term)
-                      (cond ((variable-ref? term) (variable-ref-name term))
-                            (else (error "unimplemented"))))
-                    (reference-parts reference)) "."))
+  (string-join (map (match-lambda
+                      (($ <variable-ref> name) name))
+                    (inner reference)) "."))
 
 (define (compile-expr expr)
   (match expr
@@ -47,23 +46,22 @@
     (_ expr)))
 
 (define (compile-rule rule)
-  (assert (rule? rule))
+  (assert (is-a? rule <rule>))
   (match rule
-    (($ <rule> default head body)
-     (let ((conjunction (body-conjunction body)))
-       (make <lean-fact>
-         #:conclusion (compile-expr (head-rhs head))
-         #:body (if (> (length conjunction) 1)
-                    (make <lean-conjunction> #:clauses (map compile-expr conjunction))
-                    (compile-expr (first conjunction))))))))
+    (($ <rule> default head ($ <body> conjunction))
+     (make <lean-fact>
+       #:conclusion (compile-expr (right head))
+       #:body (if (> (length conjunction) 1)
+                  (make <lean-conjunction> #:clauses (map compile-expr conjunction))
+                  (compile-expr (first conjunction)))))))
 
 (define (compile-rule-group group)
   (match group
     ((left rules ...)
-     (assert (reference? left))
+     (assert (is-a? left <reference>))
      (make <lean-predicate>
        ;; TODO: Not really correct now, is it?
-       #:kind (head-kind (rule-head (first rules)))
+       #:kind (kind (head (first rules)))
        #:name (reference->string left)
        ;; TODO: Find unique name
        #:subject "v"
@@ -71,14 +69,15 @@
 
 (define (emit-specification policy)
   "Emit a Lean file specifying the semantics of `policy'."
-  (assert (policy? policy))
-  (format #t "-- package ~a~%" (policy-package policy))
-  (newline)
-  (for-each (cut format #t "-- imports ~a~%" <>)
-            (policy-imports policy))
-  (newline)
-  (for-each (lambda (x)
-              (display (compile x))
-              (newline))
-            (map compile-rule-group (policy-rules policy)))
-  (newline))
+  (assert (is-a? policy <policy>))
+  (match policy
+    (($ <policy> package imports _ rules _)
+     (format #t "-- package ~a~%" package)
+     (newline)
+     (for-each (cut format #t "-- imports ~a~%" <>) imports)
+     (newline)
+     (for-each (lambda (x)
+                 (display (compile x))
+                 (newline))
+               (map compile-rule-group rules))
+     (newline))))
diff --git a/compiler/passes/extract-identifiers.scm b/compiler/passes/extract-identifiers.scm
index 1420176..7a6cb10 100644
--- a/compiler/passes/extract-identifiers.scm
+++ b/compiler/passes/extract-identifiers.scm
@@ -20,6 +20,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (lens)
+  #:use-module (oop goops)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-69)
   #:export (extract-identifiers))
@@ -74,7 +75,7 @@
 
       ;; TODO: In what cases do we error out, instead of treating this as a free variable?
        (($ <variable-ref> name)
-       `((,(make-reference (list (make-variable-ref name))) any)))
+       `((,(make <reference> #:parts (list (make <variable-ref> #:name name))) any)))
       (($ <funcall> _ args)
        (recur breadcrumb args))
 
@@ -87,11 +88,11 @@
       ;; `recur' won't encounter heads. Similarly, policy documents can't be nested.
       (_ '())))
   (for-each (lambda (rule)
-              (hash-table-append-item! scopes '() `(,(head-lhs (rule-head rule)) any))
-              (recur (list (head-lhs (rule-head rule)))
-                     (rule-body rule)))
-            (map cadr (policy-rules policy)))
-  (make-scope scopes))
+              (hash-table-append-item! scopes '() `(,(left (head rule)) any))
+              (recur (list (left (head rule)))
+                     (body rule)))
+            (map cadr (rules policy)))
+  (make <scope> #:identifiers scopes))
 
 (define (extract-identifiers policy)
   "Annotate `policy' with any variable occurrences
@@ -105,9 +106,9 @@ aren't. This is updated in later passes."
 (define (my-rewrite-anonymous form)
   (match form
     (($ <variable-ref> name)
-     (make-variable-ref
-      (if (string= name "$0")
-          "anony_0"
-          name)))
+     (make <variable-ref>
+       #:name (if (string= name "$0")
+                  "anony_0"
+                  name)))
     (anything-else
      anything-else)))
diff --git a/compiler/passes/parse-policy.scm b/compiler/passes/parse-policy.scm
index 280d366..ac5e3d8 100644
--- a/compiler/passes/parse-policy.scm
+++ b/compiler/passes/parse-policy.scm
@@ -15,10 +15,11 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (compiler passes parse-policy)
+  #:use-module ((rnrs base) #:select (assert))
   #:use-module (compiler types)
   #:use-module (compiler utilities)
   #:use-module (ice-9 match)
-  #:use-module ((rnrs base) #:select (assert))
+  #:use-module (oop goops)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-26)
@@ -27,13 +28,13 @@
 
 (define (extract-rules rules)
   "Group rules in `ast' by name, parsing each into a <rule> record"
-  (define targets (map (lambda (rule) (head-lhs (second rule))) rules))
+  (define targets (map (lambda (rule) (left (second rule))) rules))
   (define result
     (map (lambda (target)
            (cons target
                  (map (lambda (x) (apply extract-rule x))
                       (filter (lambda (rule)
-                                (equal? target (head-lhs (second rule))))
+                                (equal? target (left (second rule))))
                               rules))))
          (delete-duplicates! targets)))
 
@@ -44,28 +45,36 @@
 
 (define (extract-rule default head body)
   "Extract an individual parsed rule"
-  (make-rule default head (extract-body body)))
+  (make <rule>
+    #:default default
+    #:head head
+    #:body (extract-body body)))
 
 (define (extract-body body-obj)
   "Extract the body of a parsed rule"
-  (assert (body? body-obj))
-  (let ((conjunction (body-conjunction body-obj)))
+  (assert (is-a? body-obj <body>))
+  (let ((conjunction (inner body-obj)))
     ;; Every part of the conjunction is an alist with a `terms' field.
     (assert (every alist? conjunction))
     (assert (every (lambda (part) (assoc "terms" part)) conjunction))
-    (make-body (map (lambda (part) (maybe-extract-for-all (assoc-ref part "terms"))) conjunction))))
+    (make <body>
+      #:conjunction
+      (map (lambda (part)
+             (maybe-extract-for-all (assoc-ref part "terms")))
+           conjunction))))
 
 (define (maybe-extract-for-all term-obj)
   (if (and (alist? term-obj) (assoc "domain" term-obj))
-      (make-for-all (assoc-ref term-obj "domain")
-                    (assoc-ref term-obj "key")
-                    (assoc-ref term-obj "value")
-                    (extract-body (make-body (assoc-ref term-obj "body"))))
+      (make <for-all>
+        #:domain (assoc-ref term-obj "domain")
+        #:key (assoc-ref term-obj "key")
+        #:value (assoc-ref term-obj "value")
+        #:body (extract-body (make <body> #:conjunction (assoc-ref term-obj "body"))))
       (maybe-extract-exists-some term-obj)))
 
 (define (maybe-extract-exists-some term-obj)
   (if (and (alist? term-obj) (assoc "symbols" term-obj))
-      (make-exists-some (assoc-ref term-obj "symbols"))
+      (make <exists-some> #:identifiers (assoc-ref term-obj "symbols"))
       term-obj))
 
 (define (extract-term term-obj)
@@ -79,18 +88,22 @@
     (_     (extract-constant     term-obj))))
 
 (define (extract-constant term-obj)
-  (make-constant (assoc-ref term-obj "value")))
+  (make <constant> #:value (assoc-ref term-obj "value")))
 
 (define (extract-variable-ref term-obj)
-  (make-variable-ref (assoc-ref term-obj "value")))
+  (make <variable-ref> #:name (assoc-ref term-obj "value")))
 
 (define (extract-reference reference-obj)
-  (make-reference
-   (map extract-literal (array->list reference-obj))))
+  (make <reference>
+    #:parts
+    (map extract-literal (array->list reference-obj))))
 
 (define (parse-policy package imports rules)
   "Parse `ast', an abstract syntax tree from OPA, into a `<policy>'"
   (assert (string? package))
   (assert (and (list? imports) (every string? imports)))
   (assert (list? rules))
-  (make-policy package imports #f (extract-rules rules) #f))
+  (make <policy>
+    #:package package
+    #:imports imports
+    #:rules (extract-rules rules)))
diff --git a/compiler/passes/preprocess-policy.scm b/compiler/passes/preprocess-policy.scm
index 17a7318..a743766 100644
--- a/compiler/passes/preprocess-policy.scm
+++ b/compiler/passes/preprocess-policy.scm
@@ -15,10 +15,11 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (compiler passes preprocess-policy)
+  #:use-module ((rnrs base) #:select (assert))
   #:use-module (compiler types)
   #:use-module (compiler utilities)
   #:use-module (ice-9 match)
-  #:use-module ((rnrs base) #:select (assert))
+  #:use-module (oop goops)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (preprocess-policy
@@ -68,7 +69,8 @@
   (map (lambda (rule)
          (list (assoc-ref rule "default")
                (preprocess-head (assoc-ref rule "head"))
-               (make-body (preprocess-body (assoc-ref rule "body")))))
+               (make <body>
+                 #:conjunction (preprocess-body (assoc-ref rule "body")))))
        rules))
 
 (define (determine-head-kind head-obj)
@@ -86,16 +88,17 @@ field-eqv: assignment to a reference   (varname[field] IS value IF condition)
         (else (error "unidentified rule kind" head-obj))))
 
 (define (preprocess-head head-obj)
-  (define kind (determine-head-kind head-obj))
   ;; Head rules will sometimes have an "assign" key, but this is only when the
   ;; right-hand side is a scalar value.
-  (make-head (assoc-ref head-obj "name")
-             kind
-             (parse-reference (assoc-ref head-obj "ref"))
-             (parse-literal
-              (if (eqv? kind 'set-memq)
-                  (assoc-ref head-obj "key")
-                  (assoc-ref head-obj "value")))))
+  (let ((kind (determine-head-kind head-obj)))
+    (make <head>
+      #:name (assoc-ref head-obj "name")
+      #:kind kind
+      #:lhs (parse-reference (assoc-ref head-obj "ref"))
+      #:rhs (parse-literal
+             (if (eqv? kind 'set-memq)
+                 (assoc-ref head-obj "key")
+                 (assoc-ref head-obj "value"))))))
 
 (define (preprocess-body body-obj)
   (cond ;; Non-array strings should be turned into lists.
@@ -113,7 +116,7 @@ field-eqv: assignment to a reference   (varname[field] IS value IF condition)
         ;; Recurse on list.
         ((list? body-obj) (map preprocess-body body-obj))
         ;; Look inside the `identifiers' of an `<exists-some>'
-        ((exists-some? body-obj) (preprocess-body (exists-some-identifiers body-obj)))
+        ((is-a? body-obj <exists-some>) (preprocess-body (identifiers body-obj)))
         ;; Anything else is the identity.
         (else body-obj)))
 
@@ -121,60 +124,67 @@ field-eqv: assignment to a reference   (varname[field] IS value IF condition)
   "Parse into a Scheme record `term-obj' containing `type,' `value' keys"
   (match (assoc-ref term-obj "type")
     ("var"  (parse-variable-ref term-obj))
-    ("ref"  (make-reference (assoc-ref term-obj "value")))
+    ("ref"  (make <reference> #:parts (assoc-ref term-obj "value")))
     ("call" (let ((parts (assoc-ref term-obj "value")))
-              (make-funcall (first parts) (drop parts 1))))
+              (make <funcall> #:name (first parts) #:args (drop parts 1))))
     (_      (parse-constant term-obj))))
 
 (define (pairs->object-literal pairs)
   (let* ((pairs (array->list pairs))
          (pairs (map array->list pairs)))
-    (make-object-literal
-     (map (lambda (pair)
-            ;; Assumption that the object is represented as pairs of constant
-            ;; objects where the first is the key name and the second is the
-            ;; value.
-            (assert (string= "string" (assoc-ref (first pair) "type")))
-            (let ((key (assoc-ref (first pair) "value")))
-              (cons key (parse-literal (second pair)))))
-          pairs))))
+    (make <object-literal>
+      #:pairs
+      (map (lambda (pair)
+             ;; Assumption that the object is represented as pairs of constant
+             ;; objects where the first is the key name and the second is the
+             ;; value.
+             (assert (string= "string" (assoc-ref (first pair) "type")))
+             (let ((key (assoc-ref (first pair) "value")))
+               (cons key (parse-literal (second pair)))))
+           pairs))))
 
 (define (parse-constant term-obj)
   "Parse a constant literal (boolean, number, string, array, set, or object)"
   (let ((type (assoc-ref term-obj "type"))
         (value (assoc-ref term-obj "value")))
-    (make-constant (cond ((or (boolean? value)
-                              (number? value)
-                              (string? value)) value)
-                         ((string= "array" type)  (map parse-literal (array->list value)))
-                         ((string= "set" type)    (make-set-literal (map parse-literal (array->list value))))
-                         ((string= "object" type) (pairs->object-literal value))
-                         ((string= "arraycomprehension" type)
-                          (make-comprehension 'array
-                                              (parse-constant (assoc-ref value "term"))
-                                              #f
-                                              (parse-constant (assoc-ref value "body"))))
-                         ((string= "setcomprehension" type)
-                          (make-comprehension 'set
-                                              (parse-constant (assoc-ref value "term"))
-                                              #f
-                                              (parse-constant (assoc-ref value "body"))))
-                         ((string= "objectcomprehension" type)
-                          (make-comprehension 'object
-                                              (parse-constant (assoc-ref value "key"))
-                                              (parse-constant (assoc-ref value "value"))
-                                              (parse-constant (assoc-ref value "body"))))
-                         ;; (else (error "unidentified type" type))
-                         (else value)
-                         ))))
+    (make <constant>
+      #:value
+      (cond ((or (boolean? value)
+                 (number? value)
+                 (string? value)) value)
+            ((string= "array" type)  (map parse-literal (array->list value)))
+            ((string= "set" type)    (make <set-literal>
+                                       #:elems (map parse-literal (array->list value))))
+            ((string= "object" type) (pairs->object-literal value))
+            ((string= "arraycomprehension" type)
+             (make <comprehension>
+               #:kind 'array
+               #:key (parse-constant (assoc-ref value "term"))
+               #:value #f
+               #:body (parse-constant (assoc-ref value "body"))))
+            ((string= "setcomprehension" type)
+             (make <comprehension>
+               #:kind 'set
+               #:key (parse-constant (assoc-ref value "term"))
+               #:value #f
+               #:body (parse-constant (assoc-ref value "body"))))
+            ((string= "objectcomprehension" type)
+             (make <comprehension>
+              #:kind 'object
+              #:key (parse-constant (assoc-ref value "key"))
+              #:value (parse-constant (assoc-ref value "value"))
+              #:body (parse-constant (assoc-ref value "body"))))
+            ;; (else (error "unidentified type" type))
+            (else value)
+            ))))
 
 (define (parse-variable-ref term-obj)
   "Parse a reference to a named variable"
-  (make-variable-ref (assoc-ref term-obj "value")))
+  (make <variable-ref> #:name (assoc-ref term-obj "value")))
 
 (define (parse-reference ref-obj)
   (assert (array? ref-obj))
-  (make-reference (map parse-literal (array->list ref-obj))))
+  (make <reference> #:parts (map parse-literal (array->list ref-obj))))
 
 (define (preprocess-policy ast)
   "Lift metadata and pre-process rules of `ast' to be more easily worked with in `parse-policy'"
diff --git a/compiler/types.scm b/compiler/types.scm
index eae55d7..2349082 100644
--- a/compiler/types.scm
+++ b/compiler/types.scm
@@ -16,219 +16,193 @@
 
 (define-module (compiler types)
   #:use-module ((rnrs base) #:select (assert))
+  #:use-module (compiler utilities)
+  #:use-module (ice-9 match)
   #:use-module (lens)
+  #:use-module (oop goops)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
-  #:export (make-policy
-            policy?
-            policy-package
-            policy-imports
-            policy-scope
-            policy-rules
-            policy-comments
+  #:use-module (srfi srfi-26)
+  #:export (policy-map
+            tree-map ;; TODO: Clean up these exports
+
+            <policy>
+            rules
             ι-policy-scope
             ι-policy-rules
 
-            make-rule
             <rule>
-            rule?
-            rule-default
-            rule-head
-            rule-body
+            head
+            body
             ι-rule-body
 
-            make-head
-            head?
-            head-name
-            head-kind
-            head-lhs
-            head-rhs
+            <head>
+            kind
+            left
+            right
 
-            make-body
             <body>
-            body?
-            body-conjunction
+            inner
             ι-body-conjunction
 
-            make-reference
             <reference>
-            reference?
-            reference-parts
 
-            make-constant
             <constant>
-            constant?
-            constant-value
 
-            make-set-literal
-            set-literal?
-            set-literal-elems
+            <set-literal>
 
-            make-object-literal
             <object-literal>
-            object-literal?
-            object-literal-pairs
 
-            make-comprehension
             <comprehension>
-            comprehension?
-            comprehension-kind
-            comprehension-key
-            comprehension-value
-            comprehension-body
             
-            make-variable-ref
             <variable-ref>
-            variable-ref?
-            variable-ref-name
 
-            make-scope
-            scope?
-            scope-identifiers
+            <scope>
+            identifiers
             scope-contains?
 
-            make-funcall
             <funcall>
-            funcall?
-            funcall-ref
-            funcall-args
+            args
 
-            make-for-all
             <for-all>
-            for-all?
-            for-all-domain
-            for-all-key
-            for-all-value
-            for-all-body
 
-            make-exists-some
-            <exists-some>
-            exists-some?
-            exists-some-identifiers))
+            <exists-some>))
+
+(define (policy-map policy f)
+  (over (ι-policy-rules)
+        (lambda (rules)
+          (zip (map car rules)
+               ;; n.b. discards `scope', `breadcrumb'
+               (map (compose (cut tree-map <> f (scope policy) '()) cadr) rules)))
+        policy))
+
+(define-method (tree-map form f scope breadcrumb)
+  form)
+
+(define-method (tree-map (form <list>) f scope breadcrumb)
+  (f scope breadcrumb
+     (map (lambda (x i)
+            (let ((breadcrumb (add-to-end breadcrumb i)))
+              (f scope breadcrumb (tree-map x f scope breadcrumb))))
+          form
+          (iota (length form)))))
+
+
 
 ;; Type representing an individual `.rego' file
-(define-record-type <policy>
-  (make-policy package imports scope rules comments)
-  policy?
-  (package  policy-package)
-  (imports  policy-imports)
-  (scope    policy-scope)
-  (rules    policy-rules)
-  (comments policy-comments))
+(define-class <policy> ()
+  (package  #:init-value #f
+            #:init-keyword #:package)
+  (imports  #:init-value #f
+            #:init-keyword #:imports)
+  (scope    #:init-value #f
+            #:init-keyword #:scope
+            #:accessor scope)
+  (rules    #:init-value #f
+            #:init-keyword #:rules
+            #:accessor rules)
+  (comments #:init-value #f
+            #:init-keyword #:comments))
 
 (define (ι-policy-rules)
   "Lens for focusing the rules of a <policy>"
-  (lens policy-rules
-        (lambda (s f)
-          (make-policy
-           (policy-package s)
-           (policy-imports s)
-           (policy-scope s)
-           (f (policy-rules s))
-           (policy-comments s)))))
+  (lens (lambda (s)   (slot-ref s 'rules))
+        (lambda (s f) (map-slot s 'rules f))))
 
 (define (ι-policy-scope)
   "Lens for focusing the global of a <policy>"
-  (lens policy-rules
-        (lambda (s f)
-          (make-policy
-           (policy-package s)
-           (policy-imports s)
-           (f (policy-scope s))
-           (policy-rules s)
-           (policy-comments s)))))
+  (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-record-type <rule>
-  (make-rule default head body)
-  rule?
-  (default rule-default)
-  (head    rule-head)
-  (body    rule-body))
+(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 rule-body
-        (lambda (s f)
-          (make-rule
-           (rule-default s)
-           (rule-head s)
-           (f (rule-body s))))))
+  (lens (lambda (s)   (slot-ref s 'body))
+        (lambda (s f) (map-slot s 'body f))))
+
+(define-method (tree-map (form <rule>) f scope breadcrumb)
+  ;; TODO: Should this include the `head' of a rule too?
+  (match form
+    (($ <rule> default head body)
+     (let* ((breadcrumb (add-to-end breadcrumb (left head)))
+            (inner (with-modified-slot form '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-record-type <head>
-  (make-head name kind lhs rhs)
-  head?
-  (name head-name)
-  (kind head-kind) ; memq '(value-eqv field-eqv set-memq)
-  (lhs  head-lhs)
-  (rhs  head-rhs))
+(define-class <head> ()
+  (name #:init-keyword #:name)
+  (kind #:init-keyword #:kind ; memq '(value-eqv field-eqv set-memq)
+        #:accessor     kind)
+  (lhs  #:init-keyword #:lhs
+        #:accessor     left)
+  (rhs  #:init-keyword #:rhs
+        #:accessor     right))
 
 ;; A conjunction that defines whether a rule should apply.
-(define-record-type <body>
-  (make-body conjunction)
-  body?
-  (conjunction body-conjunction))
+(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 body-conjunction
-        (lambda (s f)
-          (make-body
-           (f (body-conjunction s))))))
+  (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-record-type <constant>
-  (make-constant value)
-  constant?
-  (value constant-value) ; scheme value
-  )
-
-(define-record-type <set-literal>
-  (make-set-literal elems)
-  set-literal?
-  (elems set-literal-elems) ; list of [scheme value | <set-literal> | <object-literal>]
-  )
-
-(define-record-type <object-literal>
-  (make-object-literal pairs)
-  object-literal?
-  (pairs object-literal-pairs) ; list of [(string, scheme value | <set-literal> | <object-literal>)]
-  )
-
-(define-record-type <comprehension>
-  (make-comprehension kind key value body)
-  comprehension?
-  (kind  comprehension-kind)  ; one of '(array set object)
-  (key   comprehension-key)
-  (value comprehension-value)
-  (body  comprehension-body)
-  )
-
-(define-record-type <variable-ref>
-  (make-variable-ref name)
-  variable-ref?
-  (name variable-ref-name) ; <string>
-  )
-
-(define-record-type <invoke-membership>
-  (make-invoke-membership elem set)
-  invoke-membership?
-  (elem invoke-membership-elem) ; <term>
-  (set  invoke-membership-set)  ; <term>
-  )
+(define-class <constant> ()
+  (value #:init-keyword #:value)) ; scheme value
 
-;; A place within a nested data structure.
-(define-record-type <reference>
-  (make-reference parts)
-  reference?
-  (parts reference-parts))
+(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-record-type <scope>
-  (make-scope identifiers)
-  scope?
-  (identifiers scope-identifiers))
+(define-class <variable-ref> ()
+  (name #:init-keyword #:name)) ; <string>
+
+(define-class <invoke-membership> ()
+  (elem #:init-keyword #:elem) ; <term>
+  (set #:init-keyword #:set))  ; <term>
+
+;; A place within a nested data structure.
+(define-class <reference> ()
+  (parts #:init-keyword #:parts
+         #:accessor inner))
+
+(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
+               #:accessor     inner))
 
 (define (scope-contains? scope breadcrumb identifier)
   "Whether SCOPE contains IDENTIFIER at the point indicated by BREADCRUMB
@@ -236,33 +210,43 @@
 `scope' is a <scope>, `breadcrumb' is a list given to the `f' of `mutate-tree',
 and `identifier' is a <reference>"
   (define (recur breadcrumb)
-    (or (member identifier (or (assoc-ref (scope-identifiers scope) breadcrumb) '()))
+    (or (member identifier (or (assoc-ref (inner scope) breadcrumb) '()))
         (if (null? breadcrumb)
             #t
             ;; (lean-builtin-function? (reference->lean-name identifier))
             (recur (drop-right breadcrumb 1)))))
-  (assert (scope? scope))
-  (assert (reference? identifier))
+  (assert (is-a? scope <scope>))
+  (assert (is-a? identifier <reference>))
   (assert (list? breadcrumb))
   (recur breadcrumb))
 
-(define-record-type <funcall>
-  (make-funcall ref args)
-  funcall?
-  (ref  funcall-name) ; <reference> (to the function being called)
-  (args funcall-args) ; list of <term>
-  )
-
-(define-record-type <for-all>
-  (make-for-all domain key value body)
-  for-all?
-  (domain for-all-domain)
-  (key for-all-key)
-  (value for-all-value)
-  (body for-all-body)
-  )
-
-(define-record-type <exists-some>
-  (make-exists-some identifiers)
-  exists-some?
-  (identifiers exists-some-identifiers))
+(define-class <funcall> ()
+  (ref  #:init-keyword #:name) ; <reference> (to the function being called)
+  (args #:init-keyword #:args  ; list of <term>
+        #:accessor     args))
+
+(define-class <for-all> ()
+  (domain #:init-keyword #:domain)
+  (key    #:init-keyword #:key)
+  (value  #:init-keyword #:value)
+  (body   #:init-keyword #:body))
+
+(define-method (tree-map (form <for-all>) f scope breadcrumb)
+  (match form
+    (($ <for-all> domain key value body)
+     (let ((inner (with-modified-slot form 'body
+                    (map (cut tree-map <> f scope breadcrumb)
+                         body))))
+       (f scope breadcrumb inner)))))
+
+(define-class <exists-some> ()
+  (identifiers #:init-keyword #:identifiers
+               #:accessor     identifiers))
+
+(define-method (tree-map (form <exists-some>) f scope breadcrumb)
+  (match form
+    (($ <exists-some> identifiers)
+     (let ((inner (with-modified-slot form 'identifiers
+                    (map (cut tree-map <> f scope breadcrumb)
+                         identifiers))))
+       (f scope breadcrumb inner)))))
diff --git a/compiler/utilities.scm b/compiler/utilities.scm
index 7591536..598d014 100644
--- a/compiler/utilities.scm
+++ b/compiler/utilities.scm
@@ -16,7 +16,9 @@
 
 (define-module (compiler utilities)
   #:use-module (ice-9 match)
+  #:use-module (oop goops)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-31)
   #:use-module (srfi srfi-69)
   #:export (alist?
@@ -29,7 +31,12 @@
             hash-table-append-item!
 
             fresh-identifier
-            number->subscript))
+            number->subscript
+
+            map-slot
+            with-modified-slot
+            derive-display
+            to-pretty-sexp))
 
 (define (alist? xs)
   "Return #t when XS is an alist"
@@ -90,3 +97,42 @@
                 (#\8 #\₈)
                 (#\9 #\₉))
               (number->string n)))
+
+(define-syntax map-slot
+  (syntax-rules ()
+    ((map-slot instance slot f)
+     (let ((clone (shallow-clone instance)))
+       (slot-set! clone slot (f (slot-ref clone slot)))
+       clone))))
+
+(define-syntax with-modified-slot
+  (syntax-rules ()
+    ((with-modified-slot instance slot new-value)
+     (let ((clone (shallow-clone instance)))
+       (slot-set! clone slot new-value)
+       clone))))
+
+(define-syntax derive-display
+  (syntax-rules ()
+    ((derive-display class)
+     (define-method (display (x class) port)
+       (format port "#<~a " (class-name class))
+       (for-each (compose (lambda (y)
+                            (display y port)
+                            (display " "))
+                          (cut slot-ref x <>)
+                          (cut slot-definition-name <>))
+                 (class-slots class))
+       (display ">" port)))))
+
+(define (to-pretty-sexp form)
+  (cond ((hash-table? form)
+         (to-pretty-sexp (hash-table->alist form)))
+        ((instance? form)
+         `(,(class-name (class-of form))
+           ,@(map (compose to-pretty-sexp
+                           (cut slot-ref form <>)
+                           (cut slot-definition-name <>))
+                  (class-slots (class-of form)))))
+        ((list? form) (map to-pretty-sexp form))
+        (else form)))
-- 
cgit v1.3