Initial work for compiling 08-object-comprehension.rego

3 files changed, 20 insertions, 17 deletions

diff --git a/compiler/passes/bool-to-prop.scm b/compiler/passes/bool-to-prop.scm
index 6f82761..c5acacb 100644
--- a/compiler/passes/bool-to-prop.scm
+++ b/compiler/passes/bool-to-prop.scm
@@ -17,6 +17,7 @@
 (define-module (compiler passes bool-to-prop)
   #:use-module (compiler lean)
   #:use-module (compiler types)
+  #:use-module (compiler utilities)
   #:use-module (ice-9 match)
   #:use-module (oop goops)
   #:export (compile-bool-to-prop))
@@ -44,4 +45,9 @@
        (($ <body> conjunction)
         (make <body>
           #:conjunction (map rewrite-top-level conjunction)))
+       (($ <for-all> _domain _key _value conjunction)
+        (with-modified-slot form 'body
+          (map rewrite-top-level conjunction))
+        (make <for-all>
+          #:conjunction (map rewrite-top-level conjunction)))
        (_ form)))))
diff --git a/compiler/passes/compile-reference.scm b/compiler/passes/compile-reference.scm
index 101f33b..72ed777 100644
--- a/compiler/passes/compile-reference.scm
+++ b/compiler/passes/compile-reference.scm
@@ -25,10 +25,11 @@
   #:export (compile-reference))
 
 (define (compile-reference policy)
+
   (define (specialize breadcrumb scope)
     (define (recur input-identifier form new-identifiers)
       (match form
-        ((($ <constant> value) rest ...)
+        ((target rest ...)
          (let* ((target-cast-id (fresh-identifier new-identifiers))
                 (new-identifiers (cons target-cast-id new-identifiers))
                 (target-cast-id (make <variable-ref> #:name target-cast-id))
@@ -43,7 +44,7 @@
                                         #:args `(,input-identifier)))
                     (,deref-id       ,(make <lean-funcall>
                                         #:name "Array.get?"
-                                        #:args `(,target-cast-id ,(make <constant> #:value value))))
+                                        #:args `(,target-cast-id ,target)))
                     ,@(recur deref-id rest new-identifiers)))
                  ((and (infer-is-a? input-identifier 'set breadcrumb scope)
                        (infer-is-a? input-identifier 'number breadcrumb scope))
@@ -54,7 +55,7 @@
                                         #:name "Array.get?"
                                         ;; Yes, you're reading this right. Set indices start at `1',
                                         ;; despite array indices starting at `0'.
-                                        #:args `(,target-cast-id ,(make <constant> #:value (+ 1 value)))))
+                                        #:args `(,target-cast-id ,target)))
                     ,@(recur deref-id rest new-identifiers)))
                  (else
                   `((,target-cast-id ,(make <lean-funcall>
@@ -62,7 +63,7 @@
                                         #:args `(,input-identifier)))
                     (,deref-id       ,(make <lean-funcall>
                                         #:name "Rego.Object.ref"
-                                        #:args `(,target-cast-id ,(make <constant> #:value value))))
+                                        #:args `(,target-cast-id ,target)))
                     ,@(recur deref-id rest new-identifiers))))))
         (() '())))
     recur)
diff --git a/compiler/passes/parse-policy.scm b/compiler/passes/parse-policy.scm
index 30949ff..5afb6d8 100644
--- a/compiler/passes/parse-policy.scm
+++ b/compiler/passes/parse-policy.scm
@@ -49,20 +49,16 @@
   (make <rule>
     #:default default
     #:head head
-    #:body (extract-body body)))
+    #:body (make <body> #:conjunction (extract-conjunction (inner body)))))
 
-(define (extract-body body-obj)
+(define (extract-conjunction conjunction)
   "Extract the body of a parsed rule"
-  (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>
-      #:conjunction
-      (map (lambda (part)
-             (maybe-extract-for-all (assoc-ref part "terms")))
-           conjunction))))
+  ;; Every part of the conjunction is an alist with a `terms' field.
+  (assert (every alist? conjunction))
+  (assert (every (lambda (part) (assoc "terms" part)) 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))
@@ -70,7 +66,7 @@
         #: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"))))
+        #:body (extract-conjunction (assoc-ref term-obj "body")))
       (maybe-extract-exists-some term-obj)))
 
 (define (maybe-extract-exists-some term-obj)