diff options
| -rw-r--r-- | compiler/passes/parse-policy.scm | 19 | ||||
| -rw-r--r-- | compiler/test.scm | 47 | ||||
| -rw-r--r-- | examples/13-else-keyword.rego | 5 |
3 files changed, 37 insertions, 34 deletions
diff --git a/compiler/passes/parse-policy.scm b/compiler/passes/parse-policy.scm index 840460b..28a7925 100644 --- a/compiler/passes/parse-policy.scm +++ b/compiler/passes/parse-policy.scm @@ -106,7 +106,6 @@ ;; 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) @@ -126,17 +125,17 @@ 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 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")))) - (assert (= 1 (length lhs))) (let ((kind (determine-head-kind head-obj))) (make <head> #:name (assoc-ref head-obj "name") #:kind kind - #:lhs (first lhs) + #:lhs lhs #:rhs rhs))) (define (preprocess-body body-obj) @@ -183,27 +182,27 @@ field-eqv: assignment to a reference (varname[field] IS value IF condition) (string? value)) value) ((string= "array" type) (if (null? value) #() - (list->vector (map parse-literal (array->list value))))) + (list->vector value))) ((string= "set" type) (make <set-literal> - #:elems (map parse-literal (array->list value)))) + #:elems value)) ((string= "object" type) (pairs->object-literal value)) ((string= "arraycomprehension" type) (make <comprehension> #:kind 'array - #:key (parse-literal (assoc-ref value "term")) + #:key (assoc-ref value "term") #:value #f #:body (extract-conjunction (preprocess-body (assoc-ref value "body"))))) ((string= "setcomprehension" type) (make <comprehension> #:kind 'set - #:key (parse-literal (assoc-ref value "term")) + #:key (assoc-ref value "term") #:value #f #:body (extract-conjunction (preprocess-body (assoc-ref value "body"))))) ((string= "objectcomprehension" type) (make <comprehension> #:kind 'object - #:key (parse-literal (assoc-ref value "key")) - #:value (parse-literal (assoc-ref value "value")) + #:key (assoc-ref value "key") + #:value (assoc-ref value "value") #:body (extract-conjunction (preprocess-body (assoc-ref value "body"))))) (else (error "unidentified type" type)))))) diff --git a/compiler/test.scm b/compiler/test.scm index 53b51b7..23b6898 100644 --- a/compiler/test.scm +++ b/compiler/test.scm @@ -30,7 +30,6 @@ #:use-module (compiler types) #:use-module (compiler utilities) #:use-module (ice-9 match) - #:use-module (ice-9 pretty-print) #:use-module (oop goops) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -416,31 +415,31 @@ Error if POLICY has more than one rule." ;; ;; ↔ ;; -;; #<<object-literal> pairs: ...> +;; #<<constant> value: #<<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 }"))) + (match (select-rule parse-result) + (($ <rule> + _default + ($ <head> _name _kind _lhs + ($ <constant> + ($ <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)))) +(let ((parse-result (template-and-parse "naturals := { first: 1, second: 2 }"))) + (match (select-rule parse-result) + (($ <rule> + _default + ($ <head> _name _kind _lhs + ($ <constant> + ($ <object-literal> + ((($ <variable-ref> "first") ($ <constant> 1)) + (($ <variable-ref> "second") ($ <constant> 2)))))) + _body) + (test-assert #t)))) ;; set = empty-set | non-empty-set ;; non-empty-set = "{" term { "," term } "}" diff --git a/examples/13-else-keyword.rego b/examples/13-else-keyword.rego new file mode 100644 index 0000000..f04887a --- /dev/null +++ b/examples/13-else-keyword.rego @@ -0,0 +1,5 @@ +package examples.set_defined_by_predicate + +import future.keywords.if + +phi := 3.14159 if False else := 1.61803 |