Implement `bool-to-prop'.

2 files changed, 48 insertions, 1 deletions

diff --git a/compiler/main.scm b/compiler/main.scm
index 94423da..6246d08 100644
--- a/compiler/main.scm
+++ b/compiler/main.scm
@@ -47,5 +47,6 @@ of `(program-arguments)'."
            (policy (extract-identifiers policy))
            (policy (compile-constraints policy))
            (policy (compile-funcall policy))
-           (policy (compile-reference policy)))
+           (policy (compile-reference policy))
+           (policy (compile-bool-to-prop policy)))
       (emit-specification policy))))
diff --git a/compiler/passes/bool-to-prop.scm b/compiler/passes/bool-to-prop.scm
new file mode 100644
index 0000000..0dd81d5
--- /dev/null
+++ b/compiler/passes/bool-to-prop.scm
@@ -0,0 +1,46 @@
+;;; 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 bool-to-prop)
+  #:use-module (compiler lean)
+  #:use-module (compiler types)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:export (compile-bool-to-prop))
+
+(define (compile-bool-to-prop policy)
+  (define (rewrite-top-level form)
+    (match form
+      (($ <constant> value)
+       (if (boolean? value)
+           (make <lean-compare>
+             #:kind 'eq
+             #:left form
+             #:right (make <constant> #:value #t))
+           form))
+      (($ <lean-assignment-chain> value)
+       (make <lean-compare>
+         #:kind 'eq
+         #:left form
+         #:right (make <constant> #:value #t)))))
+  (policy-map
+   policy
+   (lambda (scope breadcrumb form)
+     (match form
+       (($ <body> conjunction)
+        (make <body>
+          #:conjunction (map rewrite-top-level conjunction)))
+       (_ form)))))