Finish parsing tests of interest; some issues discovered

4 files changed, 212 insertions, 48 deletions

diff --git a/compiler/passes/parse-policy.scm b/compiler/passes/parse-policy.scm
index 5afb6d8..e85a613 100644
--- a/compiler/passes/parse-policy.scm
+++ b/compiler/passes/parse-policy.scm
@@ -48,9 +48,24 @@
   "Extract an individual parsed rule"
   (make <rule>
     #:default default
-    #:head head
+    #:head (extract-head head)
     #:body (make <body> #:conjunction (extract-conjunction (inner body)))))
 
+(define (extract-head head)
+  "Process any nested conjunctions in HEAD"
+  ;; Every part of the conjunction is an alist with a `terms' field.
+  (match head
+    (($ <head> _name _kind _lhs
+        ($ <constant> ($ <comprehension> kind key value body)))
+     (with-modified-slot head 'rhs
+       (make <constant>
+         #:value (make <comprehension>
+                   #:kind kind
+                   #:key key
+                   #:value value
+                   #:body (extract-conjunction body)))))
+    (_ head)))
+
 (define (extract-conjunction conjunction)
   "Extract the body of a parsed rule"
   ;; Every part of the conjunction is an alist with a `terms' field.
@@ -74,27 +89,6 @@
       (make <exists-some> #:identifiers (assoc-ref term-obj "symbols"))
       term-obj))
 
-(define (extract-term term-obj)
-  "Extract a term of a parsed body"
-  (cond ((assoc "type" term-obj) (extract-constant term-obj))
-        (else (error "unimplemented"))))
-
-(define (extract-literal term-obj)
-  (match (assoc-ref term-obj "type")
-    ("var" (extract-variable-ref term-obj))
-    (_     (extract-constant     term-obj))))
-
-(define (extract-constant term-obj)
-  (make <constant> #:value (assoc-ref term-obj "value")))
-
-(define (extract-variable-ref term-obj)
-  (make <variable-ref> #:name (assoc-ref term-obj "value")))
-
-(define (extract-reference reference-obj)
-  (make <reference>
-    #:parts
-    (map extract-literal (array->list reference-obj))))
-
 (define (parse-policy policy)
   "Parse `ast', an abstract syntax tree from OPA, into a `<policy>'"
   (over (ι-policy-rules) extract-rules policy))
diff --git a/compiler/passes/preprocess-policy.scm b/compiler/passes/preprocess-policy.scm
index 054edca..395916f 100644
--- a/compiler/passes/preprocess-policy.scm
+++ b/compiler/passes/preprocess-policy.scm
@@ -152,28 +152,28 @@ field-eqv: assignment to a reference   (varname[field] IS value IF condition)
       (cond ((or (boolean? value)
                  (number? value)
                  (string? value)) value)
-            ((string= "array" type)  (map parse-literal (array->list value)))
+            ((string= "array" type)  (list->array 1 (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-reference (assoc-ref (assoc-ref value "term") "value"))
+               #:key (parse-variable-ref (assoc-ref value "term"))
                #:value #f
-               #:body (parse-constant (assoc-ref value "body"))))
+               #:body (preprocess-body (assoc-ref value "body"))))
             ((string= "setcomprehension" type)
              (make <comprehension>
                #:kind 'set
-               #:key (parse-reference (assoc-ref (assoc-ref value "term") "value"))
+               #:key (parse-variable-ref (assoc-ref value "term"))
                #:value #f
-               #:body (parse-constant (assoc-ref value "body"))))
+               #:body (preprocess-body (assoc-ref value "body"))))
             ((string= "objectcomprehension" type)
              (make <comprehension>
               #:kind 'object
-              #:key (parse-reference (assoc-ref (assoc-ref value "key") "value"))
-              #:value (parse-constant (assoc-ref value "value"))
-              #:body (parse-constant (assoc-ref value "body"))))
+              #: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)
             ))))
diff --git a/compiler/test.scm b/compiler/test.scm
index 88ca0a1..c22fd13 100644
--- a/compiler/test.scm
+++ b/compiler/test.scm
@@ -28,6 +28,7 @@
   #: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 (oop goops)
   #:use-module (srfi srfi-1)
@@ -36,7 +37,7 @@
 
 
 
-(define (my-simple-runner)
+(define (test-harness)
   (let ((runner (test-runner-null))
         (num-passed 0)
         (num-failed 0))
@@ -52,7 +53,7 @@
                 num-passed num-failed)))
     runner))
 
-(test-runner-factory (lambda () (my-simple-runner)))
+(test-runner-factory (lambda () (test-harness)))
 
 
 
@@ -63,7 +64,9 @@
   (format #f "package test
 
 import future.keywords.contains
+import future.keywords.every
 import future.keywords.if
+import future.keywords.in
 
 ~a\n" code))
 
@@ -78,13 +81,19 @@ Returns a `<policy>'"
     policy))
 
 (define (select-rule policy)
-  "Strip all of POLICY but the rule it defines
+  "Strip all of POLICY but the single rule it defines
 
 Error if POLICY has more than one rule."
   (match policy
     (($ <policy> _package _imports _scope rules _comments)
      (cadr (first rules)))))
 
+(define (select-rules policy)
+  "Strip all of POLICY but the rules it defines"
+  (match policy
+    (($ <policy> _package _imports _scope rules _comments)
+     (flat-map cdr rules))))
+
 ;; Open Policy Agent provides a specification [1] of Rego's grammar. The
 ;; compiler makes two passes (`preprocess-policy' and `parse-policy') to
 ;; transform the AST into something that's more usable from Scheme.
@@ -170,7 +179,7 @@ Error if POLICY has more than one rule."
         _body)
      (test-assert (eqv? kind 'field-eqv)))))
 
-;; *N.B. `rule-head-func' is not yet implemented!*
+;; TODO: When implemented, write a parse test for `rule-head-func'
 
 ;; rule-body       = [ "else" [ assign-operator term ] [ "if" ] ] ( "{" query "}" ) | literal
 ;;
@@ -179,13 +188,34 @@ Error if POLICY has more than one rule."
 ;; #<<body> conjunction: ...>
 ;;   where
 ;;   (list? conjunction)
-
+;;
 ;; query           = literal { ( ";" | ( [CR] LF ) ) literal }
 ;;
 ;; ↔
 ;;
 ;; (list ...)
 
+(let ((parse-result (template-and-parse "pi := 3.14159")))
+  (match (select-rule parse-result)
+    (($ <rule>
+        _default
+        _head
+        ($ <body> conjunction))
+     (test-assert (list? conjunction)))))
+
+;; (let ((parse-result (template-and-parse "phi := 3.14159 if False else := 1.61803")))
+;;   (pretty-print (to-pretty-sexp parse-result))
+;;   (match (select-rules parse-result)
+;;     ((($ <rule>
+;;          _default
+;;          _head
+;;          ($ <body> conjunction1))
+;;       ($ <rule>
+;;          _default
+;;          _head
+;;          ($ <body> conjunction2)))
+;;      (test-assert (list? conjunction)))))
+
 ;; # Literals
 ;;
 ;; literal         = ( some-decl | expr | "not" expr ) { with-modifier }
@@ -196,11 +226,22 @@ Error if POLICY has more than one rule."
 ;;
 ;; #<<with-modifier> with: ... as: ...>
 
+;; TODO: When implemented, write a parse test for `with-modifier'.
+
 ;; some-decl       = "some" term { "," term } { "in" expr }
 ;;
 ;; ↔
 ;;
-;; #<<some-decl> terms: ...>
+;; #<<exists-some> terms: ...>
+
+(let ((parse-result (template-and-parse "q1 contains name if { some site; name := site.name }")))
+  (match (select-rule parse-result)
+    (($ <rule>
+        _default
+        _head
+        ($ <body> (($ <exists-some> (($ <variable-ref> "site")))
+                   terms ...)))
+     (test-assert (list? terms)))))
 
 ;; expr            = term | expr-call | expr-infix | expr-every | expr-parens | unary-expr
 ;; expr-call       = var [ "." var ] "(" [ expr { "," expr } ] ")"
@@ -221,13 +262,43 @@ Error if POLICY has more than one rule."
 ;;
 ;; ↔
 ;;
-;; #<<forall> vars: ... from: ... body: ...>
+;; #<<for-all> domain: ... key: ... value: ... body: ...>
+
+(let ((parse-result (template-and-parse "q1 contains name if { every site in sites { name := site.name } }")))
+  (match (select-rule parse-result)
+    (($ <rule>
+        _default
+        _head
+        ($ <body>
+           (($ <for-all>
+               ($ <variable-ref> "sites")
+               'null
+               ($ <variable-ref> "site")
+               body)
+            terms ...)))
+     (test-assert (list? body))
+     (test-assert (list? terms)))))
 
 ;; membership      = term [ "," term ] "in" term
 ;;
 ;; ↔
 ;;
-;; (#<<reference> parts: (#<<variable-ref> name: "internal">, #<<variable-ref> name: "member2">) term ...)
+;; (#<<reference> parts: (#<<variable-ref> name: "internal">, #<<variable-ref> name: "member_2">) term ...)
+
+(let ((parse-result (template-and-parse "q1 contains name if { some site in sites; name := site.name }")))
+  (match (select-rule parse-result)
+    (($ <rule>
+        _default
+        _head
+        ($ <body>
+           (($ <exists-some>
+               (($ <funcall>
+                   ($ <reference> (($ <variable-ref> "internal")
+                                   ($ <constant> "member_2")))
+                   (($ <variable-ref> "site")
+                    ($ <variable-ref> "sites")))))
+            terms ...)))
+     (test-assert (list? terms)))))
 
 ;; # Terms
 ;;
@@ -237,9 +308,24 @@ Error if POLICY has more than one rule."
 ;;
 ;; ↔
 ;;
-;; #<<array-compr> from: ... where: ...>
+;; #<<comprehension> kind: ... key ... value ... body: ...>
 ;;   where
-;;   (list? where)
+;;   (member? kind '(array set object))
+;;   (list? body)
+
+(let ((parse-result (template-and-parse "namelist := [ x | some site in sites; name := site.name ]")))
+  (match (select-rule parse-result)
+    (($ <rule>
+        _default
+        ($ <head> _name _kind _lhs
+           ($ <constant>
+              ($ <comprehension>
+                 'array
+                 ($ <variable-ref> "x")
+                 #f
+                 body)))
+        _body)
+     (test-assert (list? body)))))
 
 ;; set-compr       = "{" term "|" query "}"
 ;;
@@ -249,6 +335,20 @@ Error if POLICY has more than one rule."
 ;;   where
 ;;   (list? where)
 
+(let ((parse-result (template-and-parse "namelist := { x | some site in sites; name := site.name }")))
+  (match (select-rule parse-result)
+    (($ <rule>
+        _default
+        ($ <head> _name _kind _lhs
+           ($ <constant>
+              ($ <comprehension>
+                 'set
+                 ($ <variable-ref> "x")
+                 #f
+                 body)))
+        _body)
+     (test-assert (list? body)))))
+
 ;; object-compr    = "{" object-item "|" query "}"
 ;;
 ;; ↔
@@ -257,6 +357,20 @@ Error if POLICY has more than one rule."
 ;;   where
 ;;   (list? where)
 
+(let ((parse-result (template-and-parse "namelist := { name: site | some site in sites; name := site.name }")))
+  (match (select-rule parse-result)
+    (($ <rule>
+        _default
+        ($ <head> _name _kind _lhs
+           ($ <constant>
+              ($ <comprehension>
+                 'object
+                 ($ <variable-ref> "name")
+                 ($ <variable-ref> "site")
+                 body)))
+        _body)
+     (test-assert (list? body)))))
+
 ;; ref             = ( var | array | object | set | array-compr | object-compr | set-compr | expr-call ) { ref-arg }
 ;; ref-arg         = ref-arg-dot | ref-arg-brack
 ;; ref-arg-brack   = "[" ( scalar | var | array | object | set | "_" ) "]"
@@ -267,7 +381,7 @@ Error if POLICY has more than one rule."
 ;; #<<reference> parts: ...>
 ;;   where
 ;;   (list? parts)
-
+;;
 ;; var             = ( ALPHA | "_" ) { ALPHA | DIGIT | "_" }
 ;;
 ;; ↔
@@ -276,12 +390,38 @@ Error if POLICY has more than one rule."
 ;;   where
 ;;   (string? name)
 
+;; (let ((parse-result (template-and-parse "newlist := site.names")))
+;;   (pretty-print (to-pretty-sexp parse-result))
+;;   (match (select-rule parse-result)
+;;     (($ <rule>
+;;         _default
+;;         ($ <head> _name _kind _lhs
+;;            ($ <reference>
+;;               (($ <variable-ref> "site")
+;;                ($ <constant> "names"))))
+;;         _body)
+;;      (test-assert #t))))
+
 ;; array           = "[" term { "," term } "]"
 ;;
 ;; ↔
 ;;
 ;; #(...)
 
+(let ((parse-result (template-and-parse "naturals := [1, 2, 3, 4, 5]")))
+  (match (select-rule parse-result)
+    (($ <rule>
+        _default
+        ($ <head> _name _kind _lhs
+           ($ <constant>
+              #(($ <constant> 1)
+                ($ <constant> 2)
+                ($ <constant> 3)
+                ($ <constant> 4)
+                ($ <constant> 5))))
+        _body)
+     (test-assert #t))))
+
 ;; object          = "{" object-item { "," object-item } "}"
 ;; object-item     = ( scalar | ref | var ) ":" term
 ;;
@@ -289,6 +429,30 @@ Error if POLICY has more than one rule."
 ;;
 ;; #<<object-literal> pairs: ...>
 
+;; (let ((parse-result (template-and-parse "naturals := { \"first\": 1, \"second\": 2 }")))
+;;   (pretty-print (to-pretty-sexp parse-result))
+;;   (match (select-rule parse-result)
+;;     (($ <rule>
+;;         _default
+;;         ($ <head> _name _kind _lhs
+;;            ($ <object-literal>
+;;               ((($ <constant> "first") ($ <constant> 1))
+;;                (($ <constant> "second") ($ <constant> 2)))))
+;;         _body)
+;;      (test-assert #t))))
+
+;; (let ((parse-result (template-and-parse "naturals := { first: 1, second: 2 }")))
+;;   (pretty-print (to-pretty-sexp parse-result))
+;;   (match (select-rule parse-result)
+;;     (($ <rule>
+;;         _default
+;;         ($ <head> _name _kind _lhs
+;;            ($ <object-literal>
+;;               ((($ <constant> "first") ($ <constant> 1))
+;;                (($ <constant> "second") ($ <constant> 2)))))
+;;         _body)
+;;      (test-assert #t))))
+
 ;; set             = empty-set | non-empty-set
 ;; non-empty-set   = "{" term { "," term } "}"
 ;; empty-set       = "set(" ")"
@@ -298,6 +462,17 @@ Error if POLICY has more than one rule."
 ;; #<<set-literal> elts: ...>
 ;; #<<set-literal> elts: '()>
 
+(let ((parse-result (template-and-parse "naturals := { 1, 2, 3 }")))
+  (match (select-rule parse-result)
+    (($ <rule>
+        _default
+        ($ <head> _name _kind _lhs
+           ($ <constant>
+              ($ <set-literal>
+                 (($ <constant> 1) ($ <constant> 2) ($ <constant> 3)))))
+        _body)
+     (test-assert #t))))
+
 ;; ## The following are mapped to Scheme objects
 
 ;; scalar          = string | NUMBER | TRUE | FALSE | NULL
@@ -308,12 +483,6 @@ Error if POLICY has more than one rule."
 
 (test-begin "integration-tests")
 
-;; (define (parse-file file-name)
-;;   (let* ((ast (read-and-parse file-name))
-;;          (policy (preprocess-policy ast))
-;;          (policy (parse-policy policy)))
-;;     policy))
-
 (define (compile-policy policy-file-name)
   (let* ((ast (read-and-parse policy-file-name))
          (policy (preprocess-policy ast))
@@ -330,7 +499,6 @@ Error if POLICY has more than one rule."
       (lambda ()
         (emit-specification policy)))))
 
-
 (test-equal (compile-policy "examples/01-computable-assign-scalar.rego")
   "-- package data.examples.computable_assign_scalar\n\n\ninductive pi_eqv (v : Rego.Any) : Prop\n| rule₀ : (v = (Rego.Any.num 3.14159)) → pi_eqv v\n\n\n")
 
diff --git a/compiler/utilities.scm b/compiler/utilities.scm
index 8970bd0..783d153 100644
--- a/compiler/utilities.scm
+++ b/compiler/utilities.scm
@@ -146,6 +146,8 @@
                            (cut slot-definition-name <>))
                   (class-slots (class-of form)))))
         ((list? form) (map to-pretty-sexp form))
+        ((and (array? form) (not (string? form)))
+         (list->array 1 (map to-pretty-sexp (array->list form))))
         ((pair? form) (cons (to-pretty-sexp (car form))
                             (to-pretty-sexp (cdr form))))
         (else form)))