Add `lift-comprehensions.scm'

1 files changed, 83 insertions, 0 deletions

diff --git a/compiler/passes/lift-comprehensions.scm b/compiler/passes/lift-comprehensions.scm
new file mode 100644
index 0000000..35fdb49
--- /dev/null
+++ b/compiler/passes/lift-comprehensions.scm
@@ -0,0 +1,83 @@
+;;; 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 lift-comprehensions)
+  #:use-module (compiler lean)
+  #:use-module (compiler types)
+  #:use-module (compiler utilities)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print) ;; Temporary
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-11)
+  #:export (compile-comprehensions))
+
+(define (compile-comprehensions policy)
+  (define new-rules (list))
+
+  ;; For generating anonymous rule names.
+  (define top-level-names (map inner (policy-top-level-names policy)))
+
+  (define (new-comprehension-rule comprehension)
+    (match comprehension
+      ;; (($ <comprehension> 'array key value body)
+      ;;  (let ((identifier (fresh-identifier top-level-names "arraycomp")))
+      ;;    (make <rule>
+      ;;      #:default #f
+      ;;      #:head (make <head>
+      ;;               #:name identifier
+      ;;               #:kind 'array-memq
+      ;;               #:lhs
+      ;;               #:rhs)
+      ;;      #:body body))
+      ;;  )
+      ;; (($ <comprehension> 'set key value body)
+      ;;  ;; TODO
+      ;;  )
+      (($ <constant> ($ <comprehension> 'object key value body))
+       (let ((identifier (fresh-identifier top-level-names "objectcomp")))
+         (values identifier
+                 (make <rule>
+                   #:default #f
+                   #:head (make <head>
+                            #:name identifier
+                            #:kind 'field-eqv
+                            #:lhs key
+                            #:rhs value)
+                   #:body (make <body>
+                            #:conjunction
+                            (if (not (list? body))
+                                `(,body)
+                                body))))))))
+
+  (let ((policy
+         (policy-map
+          policy
+          (lambda (scope breadcrumb form)
+            (match form
+              (($ <constant> ($ <comprehension> 'object key value body))
+               (let-values (((identifier rule) (new-comprehension-rule form)))
+                 (set! new-rules
+                   `((,(make <reference> #:parts `(,(make <variable-ref> #:name identifier)))
+                      ,rule)
+                     ,@new-rules))
+                 ;; Make like Indiana Jones and swap this out with a reference to the
+                 ;; new lifted object.
+                 (make <reference> #:parts `(,(make <variable-ref> #:name identifier)))))
+              (_ form))))))
+    (match policy
+      (($ <policy> _package _imports _scope rules _comments)
+       (with-modified-slot policy 'rules
+                           (append rules new-rules))))))