Initial parsing tests

2 files changed, 131 insertions, 29 deletions

diff --git a/compiler/passes/read-and-parse.scm b/compiler/passes/read-and-parse.scm
index 2f2c8c2..e25a7f5 100644
--- a/compiler/passes/read-and-parse.scm
+++ b/compiler/passes/read-and-parse.scm
@@ -20,7 +20,8 @@
   #:use-module (json)
   #:use-module (rnrs base)
   #:use-module (rnrs io ports)
-  #:export (read-and-parse))
+  #:export (read-and-parse
+            read-and-parse-string))
 
 (define (call-command-with-output-error-to-string cmd)
   "Invoke CMD, recording what it writes to `stdout' and `stderr'
@@ -51,3 +52,14 @@ containing the content of `stdout', and the second value is a string or
   (assert (eof-object? stderr))
 
   (json-string->scm stdout))
+
+(define (read-and-parse-string code)
+  "Pass to read the contents of FILE-NAME and output a syntax tree"
+  (define quoted (with-output-to-string (lambda () (write code))))
+  (define-values (stdout stderr)
+    (call-command-with-output-error-to-string
+     (string-concatenate (list "echo -ne " quoted " | opa parse -f json /dev/stdin"))))
+  (unless (eof-object? stderr)
+    (display stderr))
+  (assert (eof-object? stderr))
+  (json-string->scm stdout))
diff --git a/compiler/test.scm b/compiler/test.scm
index 84a340e..88ca0a1 100644
--- a/compiler/test.scm
+++ b/compiler/test.scm
@@ -15,16 +15,75 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (compiler test)
+  #:use-module (compiler passes bool-to-prop)
   #:use-module (compiler passes compile-constraints)
   #: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-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 (srfi srfi-64)
-  #:export (run-parsing-tests))
+  #:use-module (compiler types)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-64))
+
+
+
+(define (my-simple-runner)
+  (let ((runner (test-runner-null))
+        (num-passed 0)
+        (num-failed 0))
+    (test-runner-on-test-end! runner
+      (lambda (runner)
+        (case (test-result-kind runner)
+          ((pass xpass) (set! num-passed (+ num-passed 1)))
+          ((fail xfail) (set! num-failed (+ num-failed 1)))
+          (else #t))))
+    (test-runner-on-final! runner
+      (lambda (runner)
+        (format #t "Passing tests: ~d.~%Failing tests: ~d.~%"
+                num-passed num-failed)))
+    runner))
+
+(test-runner-factory (lambda () (my-simple-runner)))
+
+
+
+(test-begin "parsing-tests")
+
+(define (template-rego-code code)
+  "Return CODE with necessary boilerplate to be run"
+  (format #f "package test
+
+import future.keywords.contains
+import future.keywords.if
+
+~a\n" code))
+
+(define (template-and-parse code)
+  "Template CODE and run it through the parsing-adjacent passes
+
+Returns a `<policy>'"
+  (let* ((code (template-rego-code code))
+         (ast (read-and-parse-string code))
+         (policy (preprocess-policy ast))
+         (policy (parse-policy policy)))
+    policy))
+
+(define (select-rule policy)
+  "Strip all of POLICY but the rule it defines
+
+Error if POLICY has more than one rule."
+  (match policy
+    (($ <policy> _package _imports _scope rules _comments)
+     (cadr (first rules)))))
 
 ;; Open Policy Agent provides a specification [1] of Rego's grammar. The
 ;; compiler makes two passes (`preprocess-policy' and `parse-policy') to
@@ -47,17 +106,33 @@
 ;;   where
 ;;   (string? package)
 ;;   (and (list? imports) (every string? imports))
-;;   (and (list? rules)   (every rule?   rules))
+;;   (and (list? rules))
+
+(let ((parse-result (template-and-parse "pi := 3.14159")))
+  (match parse-result
+    (($ <policy> package imports scope rules comments)
+     (test-assert (string? package))
+     (test-assert (and (list? imports) (every string? imports)))
+     (test-assert (string? package))
+     (test-assert (and (list? imports) (every string? imports))))))
 
 ;; rule            = [ "default" ] rule-head { rule-body }
 ;;
 ;; ↔
 ;;
-;; #<<rule> head: ... body: ..>
+;; #<<rule> default: ... head: ... body: ..>
 ;;   where
+;;   (boolean? default)
 ;;   (head? head)
 ;;   (body? body)
 
+(let ((parse-result (template-and-parse "pi := 3.14159")))
+  (match (select-rule parse-result)
+    (($ <rule> default head body)
+     (test-assert (boolean? default))
+     (test-assert (is-a? head <head>))
+     (test-assert (is-a? body <body>)))))
+
 ;; rule-head       = ( ref | var ) ( rule-head-set | rule-head-obj | rule-head-func | rule-head-comp )
 ;; rule-head-comp  = [ assign-operator term ] [ "if" ]
 ;; rule-head-obj   = "[" term "]" [ assign-operator term ] [ "if" ]
@@ -67,10 +142,34 @@
 ;;
 ;; ↔
 ;;
-;; #<<head> kind: ... lhs: ... rhs: ...>
+;; #<<head> name: ... kind: ... lhs: ... rhs: ...>
 ;;   where
 ;;   (member kind '(value-eqv field-eqv set-memq))
 
+(let ((parse-result (template-and-parse "pi := 3.14159")))
+  (match (select-rule parse-result)
+    (($ <rule>
+        _default
+        ($ <head> name kind lhs rhs)
+        _body)
+     (test-assert (eqv? kind 'value-eqv)))))
+
+(let ((parse-result (template-and-parse "pi contains 3.14159")))
+  (match (select-rule parse-result)
+    (($ <rule>
+        _default
+        ($ <head> name kind lhs rhs)
+        _body)
+     (test-assert (eqv? kind 'set-memq)))))
+
+(let ((parse-result (template-and-parse "pi[\"value\"] := 3.14159")))
+  (match (select-rule parse-result)
+    (($ <rule>
+        _default
+        ($ <head> name kind lhs rhs)
+        _body)
+     (test-assert (eqv? kind 'field-eqv)))))
+
 ;; *N.B. `rule-head-func' is not yet implemented!*
 
 ;; rule-body       = [ "else" [ assign-operator term ] [ "if" ] ] ( "{" query "}" ) | literal
@@ -128,7 +227,7 @@
 ;;
 ;; ↔
 ;;
-;; #<<invoke-membership> elem: ... set: ...>
+;; (#<<reference> parts: (#<<variable-ref> name: "internal">, #<<variable-ref> name: "member2">) term ...)
 
 ;; # Terms
 ;;
@@ -205,37 +304,28 @@
 ;; string          = STRING | raw-string
 ;; raw-string      = "`" { CHAR-"`" } "`"
 
-(define (my-simple-runner filename)
-  (let ((runner (test-runner-null))
-    (port (open-output-file filename))
-        (num-passed 0)
-        (num-failed 0))
-    (test-runner-on-test-end! runner
-      (lambda (runner)
-        (case (test-result-kind runner)
-          ((pass xpass) (set! num-passed (+ num-passed 1)))
-          ((fail xfail) (set! num-failed (+ num-failed 1)))
-          (else #t))))
-    (test-runner-on-final! runner
-       (lambda (runner)
-          (format port "Passing tests: ~d.~%Failing tests: ~d.~%"
-                  num-passed num-failed)
-      (close-output-port port)))
-    runner))
-
-(test-runner-factory
- (lambda () (my-simple-runner "/dev/stdout")))
+(test-end "parsing-tests")
 
 (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))
          (policy (parse-policy policy))
-         (policy (compile-constraints policy))
+         (policy (compile-comprehensions policy))
          (policy (compile-exists-some policy))
+         (policy (compile-for-all policy))
          (policy (extract-identifiers policy))
-         (policy (compile-funcall policy)))
+         (policy (compile-constraints policy))
+         (policy (compile-funcall policy))
+         (policy (compile-reference policy))
+         (policy (compile-bool-to-prop policy)))
     (with-output-to-string
       (lambda ()
         (emit-specification policy)))))