Join files

2 files changed, 189 insertions, 210 deletions

diff --git a/compiler/passes/parse-policy.scm b/compiler/passes/parse-policy.scm
index e85a613..b4e2075 100644
--- a/compiler/passes/parse-policy.scm
+++ b/compiler/passes/parse-policy.scm
@@ -26,6 +26,182 @@
   #:use-module (srfi srfi-26)
   #:export (parse-policy))
 
+(define (extract-package ast)
+  "Return, as a string, the name of the package specified by `ast'"
+  (define package-spec (assoc-ref ast          "package"))
+  (define path-spec    (assoc-ref package-spec "path"))
+  (define components
+    (map (lambda (component)
+           (assoc-ref component "value"))
+         (array->list path-spec)))
+
+  ;; Ensure no component is #f
+  (assert (every identity components))
+
+  (string-join components "."))
+
+(define (extract-imports ast)
+  "Return, as a list of strings, the package imports in `ast'"
+  (define import-spec (assoc-ref ast "imports"))
+  (define import-paths
+    (map (lambda (package-spec)
+           (assoc-ref package-spec "path"))
+         (if import-spec
+             (array->list import-spec)
+             '())))
+
+  ;; Ensure no path is #f
+  (assert (every identity import-paths))
+  ;; Ensure every path is a `ref'
+  (assert (every (lambda (import-path)
+                   (string= "ref" (assoc-ref import-path "type")))
+                 import-paths))
+
+  (let* ((values (map (cut assoc-ref <> "value") import-paths))
+         (values (map array->list                values)))
+    (map (lambda (value-list)
+           (string-join (map (cut assoc-ref <> "value")
+                             value-list)
+                        "."))
+         values)))
+
+(define (preprocess-rules ast)
+  (define rules (array->list (assoc-ref ast "rules")))
+  (define (recur rule)
+    (if (assoc-ref rule "else")
+        (list (assoc-ref rule "default")
+              (preprocess-head (assoc-ref rule "head"))
+              (make <body>
+                #:conjunction (preprocess-body (assoc-ref rule "body")))
+              (recur (assoc-ref rule "else")))
+        (list (assoc-ref rule "default")
+              (preprocess-head (assoc-ref rule "head"))
+              (make <body>
+                #:conjunction (preprocess-body (assoc-ref rule "body"))))))
+  (map recur rules))
+
+(define (determine-head-kind head-obj)
+  "Return the appropriate symbol describing the kind of rule that `head-obj' represents
+
+value-eqv: assignment to a variable    (varname IS value IF condition)
+field-eqv: assignment to a reference   (varname[field] IS value IF condition)
+ set-memq: assertion of set membership (varname CONTAINS value IF condition)"
+  (cond ((and (assoc "key" head-obj) (assoc "value" head-obj))
+         'field-eqv)
+        ((and (assoc "ref" head-obj) (assoc "value" head-obj))
+         'value-eqv)
+        ((and (assoc "key" head-obj) (assoc "ref" head-obj))
+         'set-memq)
+        (else (error "unidentified rule kind" head-obj))))
+
+(define (preprocess-head head-obj)
+  ;; Head rules will sometimes have an "assign" key, but this is only when the
+  ;; right-hand side is a scalar 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.
+        ((and (array? body-obj) (not (string? body-obj)))
+         (preprocess-body (array->list body-obj)))
+        ;; Objects with a `type' field represent constants in Rego, so parse
+        ;; them into a Scheme type.
+        ((and (alist? body-obj) (assoc "type" body-obj))
+         (parse-literal (map-key preprocess-body "value" body-obj)))
+        ;; Otherwise, map over all values in the object.
+        ((alist? body-obj)
+         (map (lambda (kv)
+                (cons (car kv) (preprocess-body (cdr kv))))
+              body-obj))
+        ;; Recurse on list.
+        ((list? body-obj) (map preprocess-body body-obj))
+        ;; Look inside the `identifiers' of an `<exists-some>'
+        ((is-a? body-obj <exists-some>) (preprocess-body (identifiers body-obj)))
+        ;; Anything else is the identity.
+        (else body-obj)))
+
+(define (parse-literal term-obj)
+  "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> #:parts (assoc-ref term-obj "value")))
+    ("call" (let ((parts (assoc-ref term-obj "value")))
+              (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>
+      #: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>
+      #:value
+      (cond ((or (boolean? value)
+                 (number? value)
+                 (string? value)) value)
+            ((string= "array" type)  (if (null? value)
+                                         #()
+                                         (list->vector (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-variable-ref (assoc-ref value "term"))
+               #:value #f
+               #:body (preprocess-body (assoc-ref value "body"))))
+            ((string= "setcomprehension" type)
+             (make <comprehension>
+               #:kind 'set
+               #:key (parse-variable-ref (assoc-ref value "term"))
+               #:value #f
+               #:body (preprocess-body (assoc-ref value "body"))))
+            ((string= "objectcomprehension" type)
+             (make <comprehension>
+              #:kind 'object
+              #:key (parse-variable-ref (assoc-ref value "key"))
+              #:value (parse-variable-ref (assoc-ref value "value"))
+              #:body (preprocess-body (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> #:name (assoc-ref term-obj "value")))
+
+(define (parse-reference ref-obj)
+  (assert (array? 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'"
+  (assert (list? ast))
+  (make <policy>
+    #:package (extract-package ast)
+    #:imports (extract-imports ast)
+    #:rules   (preprocess-rules ast)))
 
 (define (extract-rules rules)
   "Group rules in `ast' by name, parsing each into a <rule> record"
@@ -44,12 +220,18 @@
 
   result)
 
-(define (extract-rule default head body)
+(define* (extract-rule default head body #:optional else-arm)
   "Extract an individual parsed rule"
-  (make <rule>
-    #:default default
-    #:head (extract-head head)
-    #:body (make <body> #:conjunction (extract-conjunction (inner body)))))
+  (if else-arm
+      (make <rule>
+        #:default default
+        #:head (extract-head head)
+        #:body (make <body> #:conjunction (extract-conjunction (inner body)))
+        #:else-arm (apply extract-rule else-arm))
+      (make <rule>
+        #:default default
+        #:head (extract-head head)
+        #:body (make <body> #:conjunction (extract-conjunction (inner body))))))
 
 (define (extract-head head)
   "Process any nested conjunctions in HEAD"
@@ -89,6 +271,6 @@
       (make <exists-some> #:identifiers (assoc-ref term-obj "symbols"))
       term-obj))
 
-(define (parse-policy policy)
+(define (parse-policy ast)
   "Parse `ast', an abstract syntax tree from OPA, into a `<policy>'"
-  (over (ι-policy-rules) extract-rules policy))
+  (over (ι-policy-rules) extract-rules (preprocess-policy ast)))
diff --git a/compiler/passes/preprocess-policy.scm b/compiler/passes/preprocess-policy.scm
deleted file mode 100644
index 51eded7..0000000
--- a/compiler/passes/preprocess-policy.scm
+++ /dev/null
@@ -1,203 +0,0 @@
-;;; 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 preprocess-policy)
-  #:use-module ((rnrs base) #:select (assert))
-  #:use-module (compiler types)
-  #:use-module (compiler utilities)
-  #:use-module (ice-9 match)
-  #:use-module (oop goops)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-26)
-  #:export (preprocess-policy
-            %test-preprocess-policy))
-
-(define (extract-package ast)
-  "Return, as a string, the name of the package specified by `ast'"
-  (define package-spec (assoc-ref ast          "package"))
-  (define path-spec    (assoc-ref package-spec "path"))
-  (define components
-    (map (lambda (component)
-           (assoc-ref component "value"))
-         (array->list path-spec)))
-
-  ;; Ensure no component is #f
-  (assert (every identity components))
-
-  (string-join components "."))
-
-(define (extract-imports ast)
-  "Return, as a list of strings, the package imports in `ast'"
-  (define import-spec (assoc-ref ast "imports"))
-  (define import-paths
-    (map (lambda (package-spec)
-           (assoc-ref package-spec "path"))
-         (if import-spec
-             (array->list import-spec)
-             '())))
-
-  ;; Ensure no path is #f
-  (assert (every identity import-paths))
-  ;; Ensure every path is a `ref'
-  (assert (every (lambda (import-path)
-                   (string= "ref" (assoc-ref import-path "type")))
-                 import-paths))
-
-  (let* ((values (map (cut assoc-ref <> "value") import-paths))
-         (values (map array->list                values)))
-    (map (lambda (value-list)
-           (string-join (map (cut assoc-ref <> "value")
-                             value-list)
-                        "."))
-         values)))
-
-(define (preprocess-rules ast)
-  (define rules (array->list (assoc-ref ast "rules")))
-  (define (recur rule)
-    (if (assoc-ref rule "else")
-        (list (assoc-ref rule "default")
-              (preprocess-head (assoc-ref rule "head"))
-              (make <body>
-                #:conjunction (preprocess-body (assoc-ref rule "body")))
-              (recur (assoc-ref rule "else")))
-        (list (assoc-ref rule "default")
-              (preprocess-head (assoc-ref rule "head"))
-              (make <body>
-                #:conjunction (preprocess-body (assoc-ref rule "body"))))))
-  (map recur rules))
-
-(define (determine-head-kind head-obj)
-  "Return the appropriate symbol describing the kind of rule that `head-obj' represents
-
-value-eqv: assignment to a variable    (varname IS value IF condition)
-field-eqv: assignment to a reference   (varname[field] IS value IF condition)
- set-memq: assertion of set membership (varname CONTAINS value IF condition)"
-  (cond ((and (assoc "key" head-obj) (assoc "value" head-obj))
-         'field-eqv)
-        ((and (assoc "ref" head-obj) (assoc "value" head-obj))
-         'value-eqv)
-        ((and (assoc "key" head-obj) (assoc "ref" head-obj))
-         'set-memq)
-        (else (error "unidentified rule kind" head-obj))))
-
-(define (preprocess-head head-obj)
-  ;; Head rules will sometimes have an "assign" key, but this is only when the
-  ;; right-hand side is a scalar 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.
-        ((and (array? body-obj) (not (string? body-obj)))
-         (preprocess-body (array->list body-obj)))
-        ;; Objects with a `type' field represent constants in Rego, so parse
-        ;; them into a Scheme type.
-        ((and (alist? body-obj) (assoc "type" body-obj))
-         (parse-literal (map-key preprocess-body "value" body-obj)))
-        ;; Otherwise, map over all values in the object.
-        ((alist? body-obj)
-         (map (lambda (kv)
-                (cons (car kv) (preprocess-body (cdr kv))))
-              body-obj))
-        ;; Recurse on list.
-        ((list? body-obj) (map preprocess-body body-obj))
-        ;; Look inside the `identifiers' of an `<exists-some>'
-        ((is-a? body-obj <exists-some>) (preprocess-body (identifiers body-obj)))
-        ;; Anything else is the identity.
-        (else body-obj)))
-
-(define (parse-literal term-obj)
-  "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> #:parts (assoc-ref term-obj "value")))
-    ("call" (let ((parts (assoc-ref term-obj "value")))
-              (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>
-      #: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>
-      #:value
-      (cond ((or (boolean? value)
-                 (number? value)
-                 (string? value)) value)
-            ((string= "array" type)  (if (null? value)
-                                         #()
-                                         (list->vector (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-variable-ref (assoc-ref value "term"))
-               #:value #f
-               #:body (preprocess-body (assoc-ref value "body"))))
-            ((string= "setcomprehension" type)
-             (make <comprehension>
-               #:kind 'set
-               #:key (parse-variable-ref (assoc-ref value "term"))
-               #:value #f
-               #:body (preprocess-body (assoc-ref value "body"))))
-            ((string= "objectcomprehension" type)
-             (make <comprehension>
-              #:kind 'object
-              #:key (parse-variable-ref (assoc-ref value "key"))
-              #:value (parse-variable-ref (assoc-ref value "value"))
-              #:body (preprocess-body (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> #:name (assoc-ref term-obj "value")))
-
-(define (parse-reference ref-obj)
-  (assert (array? 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'"
-  (assert (list? ast))
-  (make <policy>
-    #:package (extract-package ast)
-    #:imports (extract-imports ast)
-    #:rules   (preprocess-rules ast)))