compile-reference proof-of-concept

5 files changed, 91 insertions, 28 deletions

diff --git a/compiler/main.scm b/compiler/main.scm
index c208872..94423da 100644
--- a/compiler/main.scm
+++ b/compiler/main.scm
@@ -18,6 +18,7 @@
   #:use-module (compiler passes compile-constraints)
   #:use-module (compiler passes compile-exists-some)
   #: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 parse-policy)
@@ -45,5 +46,6 @@ of `(program-arguments)'."
            (policy (compile-exists-some policy))
            (policy (extract-identifiers policy))
            (policy (compile-constraints policy))
-           (policy (compile-funcall policy)))
+           (policy (compile-funcall policy))
+           (policy (compile-reference policy)))
       (emit-specification policy))))
diff --git a/compiler/passes/compile-reference.scm b/compiler/passes/compile-reference.scm
new file mode 100644
index 0000000..790a7b3
--- /dev/null
+++ b/compiler/passes/compile-reference.scm
@@ -0,0 +1,53 @@
+;;; Copyright © 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org>
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (compiler passes compile-reference)
+  #:use-module ((rnrs base) #:select (assert))
+  #:use-module (compiler lean)
+  #:use-module (compiler types)
+  #:use-module (compiler utilities)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:export (compile-reference))
+
+(define (compile-reference policy)
+  (define (recur input-identifier form new-identifiers)
+    (match form
+      ((($ <constant> value) rest ...)
+       (let* ((target-cast-id (fresh-identifier new-identifiers))
+              (new-identifiers (cons target-cast-id new-identifiers))
+              (target-cast-id (make <variable-ref> #:name target-cast-id))
+
+              (deref-id (fresh-identifier new-identifiers))
+              (new-identifiers (cons deref-id new-identifiers))
+              (deref-id (make <variable-ref> #:name deref-id)))
+         ;; TODO: If we can infer that the target is an array, we don't want to do the object deref...
+         `((,target-cast-id ,(make <lean-funcall>
+                               #:name "Rego.expectObject"
+                               #:args `(,input-identifier)))
+           (,deref-id       ,(make <lean-funcall>
+                               #:name "Rego.Object.ref"
+                               #:args `(,target-cast-id ,(make <constant> #:value value))))
+           ,@(recur deref-id rest new-identifiers))))
+      (() '())))
+
+  (policy-map
+   policy
+   (lambda (scope breadcrumb form)
+     (match form
+       (($ <reference> (first rest ...))
+        (make <lean-assignment-chain> #:identifiers (recur first rest '())))
+       (_ form)))))
diff --git a/compiler/passes/extract-identifiers.scm b/compiler/passes/extract-identifiers.scm
index 703b226..377fe6a 100644
--- a/compiler/passes/extract-identifiers.scm
+++ b/compiler/passes/extract-identifiers.scm
@@ -67,13 +67,21 @@
    (lambda (rule-group)
      (for-each
       (lambda (rule i)
-        (assert (is-a? (right (head rule)) <variable-ref>))
         (let* ((breadcrumb `(,(name (head rule)) ,i))
-               (right      (right (head rule))))
-          (match right
-            (($ <variable-ref> identifier)
-             (add-to-scope new-scope breadcrumb right
-                           `(membero ,(canonicalize identifier breadcrumb) ,any-type))))))
+               (lhs        (left (head rule)))
+               (rhs        (right (head rule))))
+          (match `(,lhs ,rhs)
+            ((($ <reference> (($ <variable-ref> identifier-left))) ($ <variable-ref> identifier))
+             (add-to-scope new-scope breadcrumb rhs
+                           `(membero ,(canonicalize identifier breadcrumb)
+                                     ,any-type))
+             (add-to-scope new-scope breadcrumb (make <variable-ref> #:name identifier)
+                           `(== ,(canonicalize identifier-left breadcrumb)
+                                ,(canonicalize identifier breadcrumb))))
+            ((($ <reference> (($ <variable-ref> identifier))) ($ <constant> value))
+             (add-to-scope new-scope breadcrumb (make <variable-ref> #:name identifier)
+                           `(== ,(canonicalize identifier breadcrumb)
+                                ,(scheme-value->type value)))))))
       (cdr rule-group)
       (iota (length (cdr rule-group)))))
    (rules policy))
diff --git a/compiler/types.scm b/compiler/types.scm
index 0f7a4f6..83ae370 100644
--- a/compiler/types.scm
+++ b/compiler/types.scm
@@ -277,27 +277,18 @@ identifier."
                  (* 1024 1024)))))
 
 (define (collapse-constraints scope)
+  "Return all constraints in SCOPE
 
-  (define (rewrite form old-term new-term)
-    (cond ((null? form) form)
-          ((list? form) (map (cut rewrite <> old-term new-term) form))
-          ((equal? form old-term) new-term)
-          (else form)))
-  (map (lambda (grouping)
-         (let ((breadcrumb (first grouping))
-               (identifiers (drop grouping 1)))
-           (map (lambda (identifier-and-constraints)
-                  (let ((just-identifier (first identifier-and-constraints))
-                        (constraints     (drop identifier-and-constraints 1)))
-                    (match just-identifier
-                      (($ <variable-ref> name)
-                       `((,(canonicalize name breadcrumb))
-                         ;; n.b. when we create constraints we embed the
-                         ;; <variable-ref> form, not a symbol.
-                         ,(map (cut rewrite <> just-identifier (canonicalize name breadcrumb))
-                               constraints))))))
-                identifiers)))
-       (hash-table->alist (inner scope))))
+This is independent of context, which is okay, because the identifiers in the
+resulting list of constraints are canonicalized such that they are unique and
+can be associated with identifiers as they appear in the AST programmatically."
+  (flat-map (lambda (grouping)
+              (let ((_breadcrumb (first grouping))
+                    (identifiers (drop grouping 1)))
+                (flat-map (lambda (identifier-and-constraints)
+                            (drop identifier-and-constraints 1))
+                          identifiers)))
+            (hash-table->alist (inner scope))))
 
 (define (all-valid-identifiers scope breadcrumb)
   "Return all identifiers that can be referenced in the scope specified by BREADCRUMB"
@@ -320,6 +311,11 @@ and `identifier' is a <reference>"
     (($ <variable-ref> _)  (member identifier (all-valid-identifiers scope breadcrumb)))
     (_ (error "type unsupp"))))
 
+(define (scheme-value->type x)
+  (cond ((boolean? x) 'bool)
+        ((number? x) 'number)
+        (else 'any)))
+
 (define-class <funcall> ()
   (ref  #:init-keyword #:name) ; <reference> (to the function being called)
   (args #:init-keyword #:args  ; list of <term>
diff --git a/compiler/utilities.scm b/compiler/utilities.scm
index be87d94..352bc28 100644
--- a/compiler/utilities.scm
+++ b/compiler/utilities.scm
@@ -38,7 +38,8 @@
             derive-display
             to-pretty-sexp
 
-            partition-on))
+            partition-on
+            flat-map))
 
 (define (alist? xs)
   "Return #t when XS is an alist"
@@ -151,3 +152,6 @@
           (else
            (recur result (cons (car cur) running) (cdr cur)))))
   (reverse! (filter (negate null?) (recur '() '() xs))))
+
+(define* (flat-map proc #:rest args)
+  (fold append '() (apply map proc args)))