Cleanup singletons

remix/stx0.rkt

@@ -4,7 +4,9 @@
                      racket/match
                      racket/generic
                      racket/syntax
-                     syntax/parse))
+                     syntax/parse)
+         syntax/parse/define
+         racket/stxparam)
 
 ;; xxx add extensibility
 (define-syntax (def stx)
@@ -49,20 +51,26 @@
      (syntax/loc stx
        (remix-block . body))]))
 
-(define-syntax-rule
+(module singleton racket/base
-  (define-define-singleton-struct define-singleton-struct define inner-begin)
+  (require (for-syntax racket/base
-  (define-syntax (define-singleton-struct stx)
+                       syntax/parse
+                       racket/syntax))
+  (define-syntax (singleton-struct stx)
     (syntax-parse stx
-      [(define-singleton-struct singleton:id . struct-args)
+      [(singleton-struct . struct-args)
-       (with-syntax ([the-singleton (generate-temporary #'singleton)])
+       (with-syntax ([the-singleton (generate-temporary (syntax-local-name))])
          (syntax/loc stx
-           (begin (inner-begin (struct the-singleton () . struct-args))
+           (let ()
-                  (define singleton (the-singleton)))))])))
+             (struct the-singleton () . struct-args)
+             (the-singleton))))]))
+  (provide singleton-struct))
+(require (submod "." singleton)
+         (for-syntax (submod "." singleton)))
 
-(define-define-singleton-struct define/singleton-struct
+(define-simple-macro (define/singleton-struct singleton:id . struct-args)
-  define begin)
+  (define singleton (singleton-struct . struct-args)))
-(define-define-singleton-struct define-syntax/singleton-struct
+(define-simple-macro (define-syntax/singleton-struct singleton:id . struct-args)
-  define-syntax begin-for-syntax)
+  (define-syntax singleton (singleton-struct . struct-args)))
 
 (begin-for-syntax
   (define-generics binary-operator
@@ -156,6 +164,7 @@
   (λ (_ stx)
     (syntax-parse stx
       ;; xxx transform args into bind plus what racket λ needs
+      ;; xxx no rest args?
       [(_ (arg:id ...) . body:expr)
        (syntax/loc stx
          (λ (arg ...) (remix-block . body)))]))
@@ -171,11 +180,30 @@
           (remix-cut (#%dot bodies ...)))]))])
 
 ;; xxx actually implement cut with _ or $ as the var accessor
+(define-syntax-parameter remix-cut-$
+  (λ (stx)
+    (raise-syntax-error '$ "illegal outside of cut" stx)))
 (define-syntax (remix-cut stx)
   (syntax-parse stx
     [(_ body:expr)
+     (let ()
+       (define cut-body-stx
+         (with-syntax ([this-$ (generate-temporary '$)])
            (syntax/loc stx
-       (remix-λ () body))]))
+             (let-syntax ([this-$
+                           (λ (stx)
+                             (syntax-parse stx
+                               [$:id
+                                (syntax/loc stx
+                                  0)]))])
+               (syntax-parameterize ([remix-cut-$ (make-rename-transformer #'this-$)])
+                 body)))))
+       (define cut-body-estx
+         (local-expand cut-body-stx 'expression '()))
+       (define this-cut-args
+         '())
+       (quasisyntax/loc stx
+         (remix-λ #,this-cut-args #,cut-body-estx)))]))
 
 (define-syntax (remix-cond stx)
   (syntax-parse stx
@@ -197,7 +225,8 @@
          (rename-out [def ≙]
                      [def* ≙*])
          (rename-out [remix-λ λ]
-                     [remix-cond cond])
+                     [remix-cond cond]
+                     [remix-cut-$ $])
          #%brackets
          #%braces
          (for-syntax gen:binary-operator

remix/tests/simple.rkt

@@ -116,11 +116,24 @@
   v9)
 
 ;; λ is a dot-transformer for cut
+(def f11
+  λ.(+ 10 1))
 (def v11
-  (λ.(+ 10 1)))
+  (f11))
 (module+ test
   v11)
 
+(def v11b
+  (λ.(+ 10 1)))
+(module+ test
+  v11b)
+
+#;#;
+(def v11c
+  (λ.(+ $ 1) 10))
+(module+ test
+  v11c)
+
 ;; ≙ is a synonym for def, and because of the {} rules, is a binary
 ;; operator.
 {v33 ≙ 33}