Replace explicit lenses with a macro based on slot interface

2 files changed, 16 insertions, 16 deletions

diff --git a/compiler/types.scm b/compiler/types.scm
index 07e9550..9b8447f 100644
--- a/compiler/types.scm
+++ b/compiler/types.scm
@@ -145,15 +145,11 @@
   "Names of all rules defined in POLICY"
   (map car (rules policy)))
 
-(define (ι-policy-rules)
-  "Lens for focusing the rules of a <policy>"
-  (lens (lambda (s)   (slot-ref s 'rules))
-        (lambda (s f) (map-slot s 'rules f))))
+;; Lens for focusing the rules of a <policy>
+(define-slot-lens ι-policy-rules 'rules)
 
-(define (ι-policy-scope)
-  "Lens for focusing the global of a <policy>"
-  (lens (lambda (s)   (slot-ref s 'scope))
-        (lambda (s f) (map-slot s 'scope f))))
+;; Lens for focusing the global of a <policy>
+(define-slot-lens ι-policy-scope 'scope)
 
 
 
@@ -253,10 +249,8 @@ and `identifier' is a <reference>"
   (body    #:init-keyword #:body
            #:accessor     body))
 
-(define (ι-rule-body)
-  "Lens for focusing the body of a <rule>"
-  (lens (lambda (s)   (slot-ref s 'body))
-        (lambda (s f) (map-slot s 'body f))))
+;; Lens for focusing the body of a <rule>
+(define-slot-lens ι-rule-body 'body)
 
 (define-method (tree-map (form <rule>) f scope breadcrumb)
   (match form
@@ -307,10 +301,8 @@ and `identifier' is a <reference>"
                     (tree-map conjunction f scope breadcrumb))))
          (f scope breadcrumb inner)))))
 
-(define (ι-body-conjunction)
-  "Lens for focusing the contents of a <body>"
-  (lens (lambda (s)   (slot-ref s 'conjunction))
-        (lambda (s f) (map-slot s 'conjunction f))))
+;; Lens for focusing the contents of a <body>
+(define-slot-lens ι-body-conjunction 'conjunction)
 
 
 
diff --git a/compiler/utilities.scm b/compiler/utilities.scm
index 352bc28..8970bd0 100644
--- a/compiler/utilities.scm
+++ b/compiler/utilities.scm
@@ -34,6 +34,7 @@
             number->subscript
 
             map-slot
+            define-slot-lens
             with-modified-slot
             derive-display
             to-pretty-sexp
@@ -108,6 +109,13 @@
        (slot-set! clone slot (f (slot-ref clone slot)))
        clone))))
 
+(define-syntax define-slot-lens
+  (syntax-rules ()
+    ((define-slot-lens name slot)
+     (define (name)
+       (lens (lambda (s)   (slot-ref s slot))
+             (lambda (s f) (map-slot s slot f)))))))
+
 (define-syntax with-modified-slot
   (syntax-rules ()
     ((with-modified-slot instance slot new-value)