Some processing order issues resolved

2 files changed, 68 insertions, 88 deletions

diff --git a/compiler/passes/emit-specification.scm b/compiler/passes/emit-specification.scm
index 37d0aa8..7aae195 100644
--- a/compiler/passes/emit-specification.scm
+++ b/compiler/passes/emit-specification.scm
@@ -68,11 +68,11 @@
 (define (compile-rule-group group)
   (match group
     ((left rules ...)
-     (assert (is-a? left <reference>))
+     (assert (is-a? left <variable-ref>))
      (make <lean-predicate>
        ;; TODO: Not really correct now, is it?
        #:kind (kind (head (first rules)))
-       #:name (reference->string left)
+       #:name (inner left)
        ;; TODO: Find unique name
        #:subject "v"
        #:default (if (find-default rules)
diff --git a/compiler/passes/parse-policy.scm b/compiler/passes/parse-policy.scm
index b4e2075..840460b 100644
--- a/compiler/passes/parse-policy.scm
+++ b/compiler/passes/parse-policy.scm
@@ -24,8 +24,17 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-26)
+  #:use-module (ice-9 pretty-print) ;; Temporary
   #: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)))
+
 (define (extract-package ast)
   "Return, as a string, the name of the package specified by `ast'"
   (define package-spec (assoc-ref ast          "package"))
@@ -65,20 +74,40 @@
                         "."))
          values)))
 
-(define (preprocess-rules ast)
-  (define rules (array->list (assoc-ref ast "rules")))
+(define (extract-rules ast)
+  "Group rules in `ast' by name, parsing each into a <rule> record"
   (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))
+    (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))
+
+  (pretty-print (to-pretty-sexp result))
+  result)
 
 (define (determine-head-kind head-obj)
   "Return the appropriate symbol describing the kind of rule that `head-obj' represents
@@ -97,15 +126,18 @@ field-eqv: assignment to a reference   (varname[field] IS value IF condition)
 (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 (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"))))
+  (assert (= 1 (length lhs)))
   (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"))))))
+      #:lhs (first lhs)
+      #:rhs rhs)))
 
 (define (preprocess-body body-obj)
   (cond ;; Non-array strings should be turned into lists.
@@ -131,24 +163,14 @@ field-eqv: assignment to a reference   (varname[field] IS value IF condition)
   "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")))
+    ("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)
-  (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))))
+  (make <object-literal>
+    #:pairs pairs))
 
 (define (parse-constant term-obj)
   "Parse a constant literal (boolean, number, string, array, set, or object)"
@@ -168,86 +190,48 @@ field-eqv: assignment to a reference   (varname[field] IS value IF condition)
             ((string= "arraycomprehension" type)
              (make <comprehension>
                #:kind 'array
-               #:key (parse-variable-ref (assoc-ref value "term"))
+               #:key (parse-literal (assoc-ref value "term"))
                #:value #f
-               #:body (preprocess-body (assoc-ref value "body"))))
+               #:body (extract-conjunction (preprocess-body (assoc-ref value "body")))))
             ((string= "setcomprehension" type)
              (make <comprehension>
                #:kind 'set
-               #:key (parse-variable-ref (assoc-ref value "term"))
+               #:key (parse-literal (assoc-ref value "term"))
                #:value #f
-               #:body (preprocess-body (assoc-ref value "body"))))
+               #:body (extract-conjunction (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)
-            ))))
+              #:key (parse-literal (assoc-ref value "key"))
+              #:value (parse-literal (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 (array? ref-obj))
-  (make <reference> #:parts (map parse-literal (array->list ref-obj))))
+  (assert (list? ref-obj))
+  (make <reference> #:parts 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"
-  (define targets (map (lambda (rule) (left (second rule))) rules))
-  (define result
-    (map (lambda (target)
-           (cons target
-                 (map (lambda (x) (apply extract-rule x))
-                      (filter (lambda (rule)
-                                (equal? target (left (second rule))))
-                              rules))))
-         (delete-duplicates! targets)))
+
 
-  ;; No individual rule should have failed to extract.
-  (assert (every identity result))
 
-  result)
 
 (define* (extract-rule default head body #:optional else-arm)
   "Extract an individual parsed rule"
   (if else-arm
       (make <rule>
         #:default default
-        #:head (extract-head head)
+        #: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)
+        #: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.
@@ -270,7 +254,3 @@ field-eqv: assignment to a reference   (varname[field] IS value IF condition)
   (if (and (alist? term-obj) (assoc "symbols" term-obj))
       (make <exists-some> #:identifiers (assoc-ref term-obj "symbols"))
       term-obj))
-
-(define (parse-policy ast)
-  "Parse `ast', an abstract syntax tree from OPA, into a `<policy>'"
-  (over (ι-policy-rules) extract-rules (preprocess-policy ast)))