1 files changed, 0 insertions, 257 deletions
diff --git a/rego-proofs/compiler/passes/parse-policy.scm b/rego-proofs/compiler/passes/parse-policy.scm
deleted file mode 100644
index fca48f5..0000000
--- a/rego-proofs/compiler/passes/parse-policy.scm
+++ /dev/null
@@ -1,257 +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 parse-policy)
-  #:use-module ((rnrs base) #:select (assert))
-  #:use-module (compiler types)
-  #: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-2)
-  #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-69)
-  #:export (parse-policy))
-
-(define (parse-policy ast)
-  "Parse `ast', an abstract syntax tree from OPA, into a `<policy>'"
-  (assert (list? ast))
-  (make <policy>
-    #:package (extract-package ast)
-    #:imports (extract-imports ast)
-    #:rules   (extract-rules ast)
-    #:scope   (make <scope>
-                #:identifiers (make-hash-table))))
-
-(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 (extract-rules ast)
-  "Group rules in `ast' by name, parsing each into a <rule> record"
-  (define (recur rule)
-    (make <rule>
-      #:default  (assoc-ref rule "default")
-      #:head     (preprocess-head (assoc-ref rule "head"))
-      #:body     (make <body>
-                   #:conjunction (extract-conjunction (preprocess-body (assoc-ref rule "body"))))
-      #:else-arm (if (assoc-ref rule "else")
-                     (recur (assoc-ref rule "else"))
-                     #f)))
-  (define rules
-    (let ((rules (array->list (assoc-ref ast "rules"))))
-      (map recur rules)))
-  (define targets
-    (map (match-lambda
-           (($ <rule> _default head _body _else)
-            (left head)))
-         rules))
-  (define result
-    (map (lambda (target)
-           (cons target
-                 (filter (match-lambda
-                           (($ <rule> _default head _body _else)
-                            (equal? target (left head))))
-                         rules)))
-         targets))
-  (delete-duplicates! targets)
-
-  ;; No individual rule should have failed to extract.
-  (assert (every identity result))
-
-  result)
-
-(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.
-  (define lhs (make <reference>
-                #:parts (preprocess-body (array->list (assoc-ref head-obj "ref")))))
-  (define rhs (preprocess-body
-               (if (eqv? 'set-memq (determine-head-kind head-obj))
-                   (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 lhs
-      #:rhs rhs)))
-
-(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"  (parse-reference (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)
-  (make <object-literal>
-    #:pairs 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 value)))
-            ((string= "set" type)    (make <set-literal>
-                                       #:elems value))
-            ((string= "object" type) (pairs->object-literal value))
-            ((string= "arraycomprehension" type)
-             (make <comprehension>
-               #:kind 'array
-               #:key (assoc-ref value "term")
-               #:value #f
-               #:body (extract-conjunction (preprocess-body (assoc-ref value "body")))))
-            ((string= "setcomprehension" type)
-             (make <comprehension>
-               #:kind 'set
-               #:key (assoc-ref value "term")
-               #:value #f
-               #:body (extract-conjunction (preprocess-body (assoc-ref value "body")))))
-            ((string= "objectcomprehension" type)
-             (make <comprehension>
-              #:kind 'object
-              #:key (assoc-ref value "key")
-              #:value (assoc-ref value "value")
-              #:body (extract-conjunction (preprocess-body (assoc-ref value "body")))))
-            (else (error "unidentified type" type))))))
-
-(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 (list? ref-obj))
-  (make <reference> #:parts ref-obj))
-
-
-
-
-
-(define* (extract-rule default head body #:optional else-arm)
-  "Extract an individual parsed rule"
-  (if else-arm
-      (make <rule>
-        #:default default
-        #:head head
-        #:body (make <body> #:conjunction (extract-conjunction (inner body)))
-        #:else-arm (apply extract-rule else-arm))
-      (make <rule>
-        #:default default
-        #:head head
-        #:body (make <body> #:conjunction (extract-conjunction (inner body))))))
-
-(define (extract-conjunction conjunction)
-  "Extract the body of a parsed rule"
-  ;; 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))
-      (make <for-all>
-        #:domain (assoc-ref term-obj "domain")
-        #:key (assoc-ref term-obj "key")
-        #:value (assoc-ref term-obj "value")
-        #:body (extract-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> #:identifiers (assoc-ref term-obj "symbols"))
-      term-obj))