From f70c50082b4e5e43da05d2101013ee9b07732cfc Mon Sep 17 00:00:00 2001
From: Jakob L. Kreuze
Date: Sat, 13 May 2023 09:05:00 -0400
Subject: Separate pass for compiling object literals

---
 compiler/main.scm                          |  6 ++---
 compiler/passes/compile-object-literal.scm | 35 ++++++++++++++++++++++++++++++
 compiler/passes/emit-specification.scm     | 22 ++++---------------
 compiler/test.scm                          | 10 ++++-----
 4 files changed, 47 insertions(+), 26 deletions(-)
 create mode 100644 compiler/passes/compile-object-literal.scm

diff --git a/compiler/main.scm b/compiler/main.scm
index d395711..04809c8 100644
--- a/compiler/main.scm
+++ b/compiler/main.scm
@@ -20,12 +20,12 @@
   #:use-module (compiler passes compile-exists-some)
   #:use-module (compiler passes compile-for-all)
   #:use-module (compiler passes compile-funcall)
+  #:use-module (compiler passes compile-object-literal)
   #:use-module (compiler passes compile-reference)
   #:use-module (compiler passes emit-specification)
   #:use-module (compiler passes extract-identifiers)
   #:use-module (compiler passes lift-comprehensions)
   #: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 (srfi srfi-1)
@@ -44,11 +44,11 @@ of `(program-arguments)'."
       (format (current-error-port) "file does not exist: ~a~%" policy-file-name)
       (quit 1))
     (let* ((ast (read-and-parse policy-file-name))
-           (policy (preprocess-policy ast))
-           (policy (parse-policy policy))
+           (policy (parse-policy ast))
            (policy (compile-comprehensions policy))
            (policy (compile-exists-some policy))
            (policy (compile-for-all policy))
+           (policy (compile-object-literal policy))
            (policy (extract-identifiers policy))
            (policy (compile-constraints policy))
            (policy (compile-funcall policy))
diff --git a/compiler/passes/compile-object-literal.scm b/compiler/passes/compile-object-literal.scm
new file mode 100644
index 0000000..02c1986
--- /dev/null
+++ b/compiler/passes/compile-object-literal.scm
@@ -0,0 +1,35 @@
+;;; Copyright © 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org>
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (compiler passes compile-object-literal)
+  #:use-module ((rnrs base) #:select (assert))
+  #:use-module (compiler lean)
+  #:use-module (compiler types)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:export (compile-object-literal))
+
+(define (compile-object-literal policy)
+  (policy-map
+   policy
+   (lambda (scope breadcrumb form)
+     (match form
+       (($ <constant>
+           ($ <object-literal> pairs))
+        (make <lean-funcall>
+          #:name "List.toAssocList'"
+          #:args (list (map (lambda (x) (make <lean-tuple> #:items x)) pairs))))
+       (_ form)))))
diff --git a/compiler/passes/emit-specification.scm b/compiler/passes/emit-specification.scm
index 7aae195..b29c1ce 100644
--- a/compiler/passes/emit-specification.scm
+++ b/compiler/passes/emit-specification.scm
@@ -31,29 +31,15 @@
                       (($ <variable-ref> name) name))
                     (inner reference)) "."))
 
-(define (compile-expr expr)
-  (match expr
-    (($ <constant> value) (compile-expr value))
-    (($ <object-literal> pairs)
-     (make <lean-funcall>
-       #:name "List.toAssocList'"
-       #:args (list
-               (map (lambda (x)
-                      (make <lean-tuple>
-                        #:items `(,(compile-expr (car x))
-                                  ,(compile-expr (cdr x)))))
-                    pairs))))
-    (_ expr)))
-
 (define (compile-rule rule)
   (assert (is-a? rule <rule>))
   (match rule
     (($ <rule> default head ($ <body> conjunction))
      (make <lean-fact>
-       #:conclusion (compile-expr (right head))
+       #:conclusion (right head)
        #:body (if (> (length conjunction) 1)
                   (make <lean-conjunction> #:clauses (map compile-expr conjunction))
-                  (compile-expr (first conjunction)))))))
+                  (first conjunction))))))
 
 (define (find-default rules)
   (find default-rule? rules))
@@ -68,11 +54,11 @@
 (define (compile-rule-group group)
   (match group
     ((left rules ...)
-     (assert (is-a? left <variable-ref>))
+     (assert (is-a? left <reference>))
      (make <lean-predicate>
        ;; TODO: Not really correct now, is it?
        #:kind (kind (head (first rules)))
-       #:name (inner left)
+       #:name (reference->string left)
        ;; TODO: Find unique name
        #:subject "v"
        #:default (if (find-default rules)
diff --git a/compiler/test.scm b/compiler/test.scm
index 8c810b5..53b51b7 100644
--- a/compiler/test.scm
+++ b/compiler/test.scm
@@ -20,16 +20,17 @@
   #:use-module (compiler passes compile-exists-some)
   #:use-module (compiler passes compile-for-all)
   #:use-module (compiler passes compile-funcall)
+  #:use-module (compiler passes compile-object-literal)
   #:use-module (compiler passes compile-reference)
   #:use-module (compiler passes emit-specification)
   #:use-module (compiler passes extract-identifiers)
   #:use-module (compiler passes lift-comprehensions)
   #:use-module (compiler passes parse-policy)
-  #:use-module (compiler passes preprocess-policy)
   #:use-module (compiler passes read-and-parse)
   #:use-module (compiler types)
   #:use-module (compiler utilities)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
   #:use-module (oop goops)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
@@ -76,8 +77,7 @@ import future.keywords.in
 Returns a `<policy>'"
   (let* ((code (template-rego-code code))
          (ast (read-and-parse-string code))
-         (policy (preprocess-policy ast))
-         (policy (parse-policy policy)))
+         (policy (parse-policy ast)))
     policy))
 
 (define (select-rule policy)
@@ -474,11 +474,11 @@ Error if POLICY has more than one rule."
 
 (define (compile-policy policy-file-name)
   (let* ((ast (read-and-parse policy-file-name))
-         (policy (preprocess-policy ast))
-         (policy (parse-policy policy))
+         (policy (parse-policy ast))
          (policy (compile-comprehensions policy))
          (policy (compile-exists-some policy))
          (policy (compile-for-all policy))
+         (policy (compile-object-literal policy))
          (policy (extract-identifiers policy))
          (policy (compile-constraints policy))
          (policy (compile-funcall policy))
-- 
cgit v1.3