remix/remix/stx0.rkt

#lang racket/base
(require (for-syntax racket/base
                     racket/list
                     racket/match
                     racket/generic
                     racket/syntax
                     syntax/parse)
         syntax/parse/define
         racket/stxparam)

;; xxx add extensibility
(define-syntax (def stx)
  (syntax-parse stx
    [(_ x:id . body:expr)
     (syntax/loc stx
       (define x (remix-block . body)))]
    [(_ (x . args:expr) . body:expr)
     (syntax/loc stx
       (def x (remix-λ args . body)))]))

(define-syntax (def* stx)
  (raise-syntax-error 'def* "illegal outside of block" stx))

;; xxx add extensibility
(define-syntax (def*-internal stx)
  (syntax-parse stx
    [(_ (x:id . def-body:expr) bind-body:expr)
     (syntax/loc stx
       (let ([x (remix-block . def-body)])
         (remix-block . bind-body)))]
    [(_ ((x . args:expr) . def-body:expr) bind-body:expr)
     (syntax/loc stx
       (def*-internal (x (remix-λ args . def-body)) bind-body))]))

(define-syntax (remix-block stx)
  (syntax-parse stx
    #:literals (def*)
    [(_ (~and (~not (def* . _)) before:expr) ...
        (def* . def*-body:expr) . after:expr)
     (syntax/loc stx
       (let ()
         before ...
         (def*-internal def*-body after)))]
    [(_ . body:expr)
     (syntax/loc stx
       (let () . body))]))

(define-syntax (#%brackets stx)
  (syntax-parse stx
    [(_ . body:expr)
     (syntax/loc stx
       (remix-block . body))]))

(module singleton racket/base
  (require (for-syntax racket/base
                       syntax/parse
                       racket/syntax))
  (define-syntax (singleton-struct stx)
    (syntax-parse stx
      [(singleton-struct . struct-args)
       (with-syntax ([the-singleton (generate-temporary (syntax-local-name))])
         (syntax/loc stx
           (let ()
             (struct the-singleton () . struct-args)
             (the-singleton))))]))
  (provide singleton-struct))
(require (submod "." singleton)
         (for-syntax (submod "." singleton)))

(define-simple-macro (define/singleton-struct singleton:id . struct-args)
  (define singleton (singleton-struct . struct-args)))
(define-simple-macro (define-syntax/singleton-struct singleton:id . struct-args)
  (define-syntax singleton (singleton-struct . struct-args)))

(begin-for-syntax
  (define-generics binary-operator
    (binary-operator-precedence binary-operator))
  (define (operator-chars? s)
    (not
     (ormap (λ (c) (or (char-alphabetic? c)
                       (char-numeric? c)))
            (string->list s))))
  (define-syntax-class operator-sym
    (pattern op:identifier
             #:when (operator-chars? (symbol->string (syntax->datum #'op)))))
  (define PRECEDENCE-TABLE
    (hasheq '* 30 '/ 30
            '+ 40 '- 40
            '< 60 '<= 60
            '> 60 '>= 60
            '= 70 '≙ 70 '≙* 70))
  (define (shunting-yard:precendence op)
    (define v (syntax-local-value op (λ () #f)))
    (or (and v (binary-operator? v) (binary-operator-precedence v))
        (hash-ref PRECEDENCE-TABLE (syntax->datum op) 150)))
  
  (define (shunting-yard:consume-input input output operators)
    (match input
      ['()
       (shunting-yard:pop-operators output operators)]
      [(cons token input)
       (syntax-parse token
         #:literals (unquote)
         [(~or (unquote (~and op1:expr (~not _:operator-sym))) op1:operator-sym)
          (define-values (output-p operators-p)
            (shunting-yard:push-operator output operators #'op1))
          (shunting-yard:consume-input input output-p operators-p)]
         [(~or (unquote arg:operator-sym) arg:expr)
          (shunting-yard:consume-input input (cons #'arg output) operators)])]))
  (define (shunting-yard:push-operator output operators op1)
    (match operators
      ['()
       (values output (cons op1 operators))]
      [(cons op2 operators-p)
       (cond
         [(<= (shunting-yard:precendence op2) (shunting-yard:precendence op1))
          (shunting-yard:push-operator
           (shunting-yard:push-operator-to-output op2 output)
           operators-p op1)]
         [else
          (values output (cons op1 operators))])]))
  (define (shunting-yard:pop-operators output operators)
    (match operators
      ['()
       (match output
         [(list result)
          result]
         [_
          (error 'shunting-yard:pop-operators "Too much output: ~v" output)])]
      [(cons op operators)
       (shunting-yard:pop-operators
        (shunting-yard:push-operator-to-output op output)
        operators)]))
  (define (shunting-yard:push-operator-to-output op output)
    (syntax-parse output
      [(arg2:expr arg1:expr output:expr ...)
       (cons (quasisyntax/loc op
               (#,op arg1 arg2))
             (syntax->list
              #'(output ...)))])))
(define-syntax (#%braces stx)
  (syntax-parse stx
    [(_ input-tokens:expr ...)
     (shunting-yard:consume-input
      (syntax->list #'(input-tokens ...))
      empty
      empty)]))

(begin-for-syntax
  (define-generics dot-transformer
    (dot-transform dot-transformer stx)))
(define-syntax (#%dot stx)
  (syntax-parse stx
    #:literals (#%dot)
    [(_ x:expr ... (#%dot y:expr ...))
     (syntax/loc stx
       (#%dot x ... y ...))]
    [(_ dt . more:expr)
     #:declare dt (static dot-transformer? "dot transformer")
     (dot-transform (attribute dt.value) stx)]))

(define-syntax/singleton-struct remix-λ
  #:property prop:procedure
  (λ (_ 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)))]))
  #:methods gen:dot-transformer
  [(define (dot-transform _ stx)
     (syntax-parse stx
       [(_#%dot _λ body:expr)
        (syntax/loc stx
          (remix-cut body))]
       ;; xxx test this
       [(_#%dot _λ bodies:expr ...)
        (syntax/loc stx
          (remix-cut (#%dot bodies ...)))]))])

;; xxx actually implement cut with _ or $ as the var accessor
(define-syntax-parameter remix-cut-box
  #f)

(begin-for-syntax
  (struct remix-cut-box-st ([round-two? #:mutable] arg-n->id))
  (define (argmax* f l)
    (if (empty? l)
        #f
        (argmax f l)))
  (define (remix-cut-box-st->args this-box the-stx-base)
    (match-define (remix-cut-box-st _ arg-n->id) this-box)
    (define max-arg-n
      (argmax* (λ (x) x) (hash-keys arg-n->id)))
    (printf "cut box -> args ~v\n" arg-n->id)
    (cond
      [max-arg-n
       (for/list ([i (in-range (add1 max-arg-n))])
         (printf "arg ~v is...\n" i)
         (define nr (format-id the-stx-base "cut-arg~a" i))
         (hash-set! arg-n->id i nr)
         nr)]
      [else
       #'()]))
       
  (define (remix-cut-index->stx index-stx)
    (match-define (remix-cut-box-st round-two? arg-n->id)
      (syntax-parameter-value #'remix-cut-box))
    (syntax-parse index-stx
      ;; xxx support keywords, rest, etc
      [n:nat
       (let ()
         (define nv (syntax->datum #'n))
         (define nr
           (hash-ref! arg-n->id nv
                      (λ ()
                        (printf "cut arg needed for index ~v\n" nv)
                        #t)))
         (cond
           [round-two?
            (printf "really using it ~v\n" nr)
            nr]
           [else
            (printf "not using it ~v\n" nr)
            #'(error 'cut)]))])))

(define-syntax remix-cut-$
  (singleton-struct
   #:property prop:procedure
   (λ (_ stx)
     (syntax-parse stx
       [$:id
        (syntax/loc stx
          (#%dot $ 0))]))
   #:methods gen:dot-transformer
   [(define (dot-transform _ stx)
      (syntax-parse stx
        [(#%dot $:id index:expr)
         (quasisyntax/loc stx
           #,(remix-cut-index->stx #'index))]
        ;; xxx test this
        [(#%dot $:id index:expr more:expr ...)
         (quasisyntax/loc stx
           (#%dot #,(remix-cut-index->stx #'index) more ...))]))]))

(require (for-syntax (for-syntax racket/base)))
(define-syntax (remix-cut stx)
  (syntax-parse stx
    [(_ body:expr)
     (let ()
       (define this-box (remix-cut-box-st #f (make-hasheq)))
       (define cut-body-stx
         (quasisyntax/loc stx
           (syntax-parameterize ([remix-cut-box #,this-box])
             body)))
       (local-expand cut-body-stx 'expression '())
       (set-remix-cut-box-st-round-two?! this-box #t)
       (define the-stx-base #'body)
       (define cut-args (remix-cut-box-st->args this-box the-stx-base))
       (printf "args are ~v\n" cut-args)
       (quasisyntax/loc stx
         (remix-λ #,cut-args #,cut-body-stx)))]))

(define-syntax (remix-cond stx)
  (syntax-parse stx
    #:literals (#%brackets)
    [(_ (~and before:expr (~not (#%brackets . any:expr))) ...
        (#%brackets #:else . answer-body:expr))
     (syntax/loc stx
       (remix-block before ... . answer-body))]
    [(_ (~and before:expr (~not (#%brackets . any:expr))) ...
        (#%brackets question:expr . answer-body:expr)
        . more:expr)
     (syntax/loc stx
       (remix-block before ...
                    (if question
                        (remix-block . answer-body)
                        (remix-cond . more))))]))

(provide def def*
         (rename-out [def ≙]
                     [def* ≙*])
         (rename-out [remix-λ λ]
                     [remix-cond cond]
                     [remix-cut-$ $])
         #%brackets
         #%braces
         (for-syntax gen:binary-operator
                     binary-operator?
                     binary-operator-precedence)
         #%dot
         #%app
         #%datum
         unquote
         module
         module*
         module+
         provide)