Parse rules with `else' branches

3 files changed, 32 insertions, 33 deletions

diff --git a/compiler/passes/preprocess-policy.scm b/compiler/passes/preprocess-policy.scm
index 85a75c0..51eded7 100644
--- a/compiler/passes/preprocess-policy.scm
+++ b/compiler/passes/preprocess-policy.scm
@@ -66,12 +66,18 @@
 
 (define (preprocess-rules ast)
   (define rules (array->list (assoc-ref ast "rules")))
-  (map (lambda (rule)
-         (list (assoc-ref rule "default")
-               (preprocess-head (assoc-ref rule "head"))
-               (make <body>
-                 #:conjunction (preprocess-body (assoc-ref rule "body")))))
-       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
diff --git a/compiler/test.scm b/compiler/test.scm
index c22fd13..6a122fd 100644
--- a/compiler/test.scm
+++ b/compiler/test.scm
@@ -88,12 +88,6 @@ Error if POLICY has more than one rule."
     (($ <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.
@@ -129,11 +123,12 @@ Error if POLICY has more than one rule."
 ;;
 ;; ↔
 ;;
-;; #<<rule> default: ... head: ... body: ..>
+;; #<<rule> default: ... head: ... body: ... else-arm: ...>
 ;;   where
 ;;   (boolean? default)
 ;;   (head? head)
 ;;   (body? body)
+;;   (rule? else-arm)
 
 (let ((parse-result (template-and-parse "pi := 3.14159")))
   (match (select-rule parse-result)
@@ -142,6 +137,14 @@ Error if POLICY has more than one rule."
      (test-assert (is-a? head <head>))
      (test-assert (is-a? body <body>)))))
 
+(let ((parse-result (template-and-parse "phi := 3.14159 if False else := 1.61803")))
+  (match (select-rule parse-result)
+    (($ <rule> default head body else-arm)
+     (test-assert (boolean? default))
+     (test-assert (is-a? head <head>))
+     (test-assert (is-a? body <body>))
+     (test-assert (is-a? else-arm <rule>)))))
+
 ;; 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" ]
@@ -203,19 +206,6 @@ Error if POLICY has more than one rule."
         ($ <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 }
diff --git a/compiler/types.scm b/compiler/types.scm
index b5e2862..ec5de53 100644
--- a/compiler/types.scm
+++ b/compiler/types.scm
@@ -256,13 +256,16 @@ and `identifier' is a <reference>"
 
 ;; The intensional database of a Rego program is defined by its rules.
 (define-class <rule> ()
-  (default #:init-form #f
-           #:init-keyword #:default
-           #:accessor     default-rule?)
-  (head    #:init-keyword #:head
-           #:accessor     head)
-  (body    #:init-keyword #:body
-           #:accessor     body))
+  (default  #:init-form #f
+            #:init-keyword #:default
+            #:accessor     default-rule?)
+  (head     #:init-keyword #:head
+            #:accessor     head)
+  (body     #:init-keyword #:body
+            #:accessor     body)
+  (else-arm #:init-form #f
+            #:init-keyword #:else-arm
+            #:accessor     else-arm))
 
 ;; Lens for focusing the body of a <rule>
 (define-slot-lens ι-rule-body 'body)