intdef.rkt

#lang racket/base

;; ---------------------------------------------------------------------------------------------------
;; high-level definition context API

(module intdef racket/base
  (require (prefix-in racket: racket/base)
           racket/contract
           racket/syntax
           syntax/apply-transformer
           syntax/kerncase
           syntax/id-set
           syntax/parse
           (for-template racket/base))

  (provide (contract-out
            [internal-definition-context?
             (-> any/c boolean?)]
            [internal-definition-context-sealed?
             (-> internal-definition-context? boolean?)]
            [syntax-local-make-definition-context
             (->* [] #:pre (syntax-transforming?) internal-definition-context?)]
            [internal-definition-context-introduce
             (->* [internal-definition-context? syntax?] [(or/c 'flip 'add 'remove)] syntax?)]
            [syntax-local-value
             (->* [identifier?]
                  [(or/c (-> any) #f)
                   (listof internal-definition-context?)
                   #:immediate? any/c]
                  #:pre (syntax-transforming?)
                  any)]
            [internal-definition-context-add-parent!
             (-> (and/c internal-definition-context? (not/c internal-definition-context-sealed?))
                 internal-definition-context?
                 void?)]
            [syntax-local-expand-in-definition-context
             (->* [syntax?
                   internal-definition-context?
                   (listof identifier?)]
                  [#:extra-intdefs (listof internal-definition-context?)]
                  #:pre (syntax-transforming?)
                  syntax?)]
            [syntax-local-definition-context-extend!
             (->* [(and/c internal-definition-context? (not/c internal-definition-context-sealed?))
                   syntax?]
                  [#:stop-ids (listof identifier?)
                   #:interpret (-> syntax? (or/c syntax? #f))
                   #:extra-intdefs (listof internal-definition-context?)]
                  #:pre (syntax-transforming?)
                  void?)]
            [syntax-local-definition-context-finish!
             (->* [(and/c internal-definition-context? (not/c internal-definition-context-sealed?))]
                  #:pre (syntax-transforming?)
                  syntax?)]))

  ;; -------------------------------------------------------------------------------------------------
  ;; helper functions

  (define make-liberal-define-context
    (let ()
      (struct liberal-define-context ()
        #:property prop:liberal-define-context #t)
      (lambda () (liberal-define-context))))

  (struct opaque-box (value))

  (define (local-apply-transformer/any-result proc stx context intdefs)
    (define expanded-stx (local-apply-transformer
                          (lambda (stx)
                            (define result (proc stx))
                            (if (syntax? result)
                                result
                                (datum->syntax #f (opaque-box result))))
                          stx
                          context
                          intdefs))
    (define expanded-value (syntax-e expanded-stx))
    (if (opaque-box? expanded-value)
        (opaque-box-value expanded-value)
        expanded-stx))

  (define keep-for-track
    (syntax-parser
      #:context 'keep-for-track
      [(x:id . _)
       (cons (syntax-local-introduce #'x)
             (datum->syntax #f #f this-syntax this-syntax))]))

  ;; -------------------------------------------------------------------------------------------------
  ;; core definitions

  (struct internal-definition-context (intdef
                                       [prune-scopes-proc #:mutable]
                                       expand-ctx
                                       bound-ids
                                       [val-bindings #:mutable]
                                       [final-exprs #:mutable]
                                       [origin-stxs #:mutable]))

  (define (internal-definition-context-prune-scopes intdef stx)
    ((internal-definition-context-prune-scopes-proc intdef) stx))

  (define (internal-definition-context-register-binding! intdef ids)
    (define bound-ids (internal-definition-context-bound-ids intdef))
    (for ([id (in-list ids)])
      (define pre-id (syntax-local-identifier-as-binding (syntax-local-introduce id)))
      (define intdef-id (internal-definition-context-introduce intdef pre-id 'add))
      (when (bound-id-set-member? bound-ids intdef-id)
        (raise-syntax-error #f "duplicate binding name" id))
      (bound-id-set-add! bound-ids intdef-id)))

  (define (internal-definition-context-cons-val-binding! intdef ids rhs)
    (set-internal-definition-context-val-bindings!
     intdef (cons (cons ids rhs) (internal-definition-context-val-bindings intdef))))

  (define (internal-definition-context-register-val-binding! intdef ids rhs)
    (internal-definition-context-register-binding! intdef ids)
    (define old-val-bindings (internal-definition-context-val-bindings intdef))
    (define new-val-binding (cons (map syntax-local-introduce ids) (syntax-local-introduce rhs)))
    (define exprs (internal-definition-context-final-exprs intdef))
    (define all-val-bindings
      (cond
        [(null? exprs)
         (cons new-val-binding old-val-bindings)]
        [else
         (set-internal-definition-context-final-exprs! intdef '())
         (define intermediate-exprs-binding (cons '() #`(begin #,@exprs (values))))
         (cons new-val-binding (cons intermediate-exprs-binding old-val-bindings))]))
    (set-internal-definition-context-val-bindings! intdef all-val-bindings))

  (define (internal-definition-context-register-expr! intdef stx)
    (define prev-exprs (internal-definition-context-final-exprs intdef))
    (define flipped-stx (syntax-local-introduce stx))
    (set-internal-definition-context-final-exprs! intdef (cons flipped-stx prev-exprs)))

  (define (internal-definition-context-register-origin-stx! intdef stx)
    (set-internal-definition-context-origin-stxs!
     intdef
     (cons (keep-for-track stx) (internal-definition-context-origin-stxs intdef))))

  ;; -------------------------------------------------------------------------------------------------
  ;; public API

  (define (syntax-local-make-definition-context)
    (internal-definition-context (racket:syntax-local-make-definition-context)
                                 (lambda (stx) stx)
                                 (list (make-liberal-define-context))
                                 (mutable-bound-id-set)
                                 '() '() '()))

  (define (internal-definition-context-sealed? intdef)
    (racket:internal-definition-context-sealed? (internal-definition-context-intdef intdef)))

  (define (internal-definition-context-introduce intdef id [mode 'flip])
    (racket:internal-definition-context-introduce
     (internal-definition-context-intdef intdef) id mode))

  (define (syntax-local-value id-stx [failure-thunk #f] [intdefs '()] #:immediate? [immediate? #f])
    (define r:intdefs (map internal-definition-context-intdef intdefs))
    (cond
      [immediate?
       (define-values [value target]
         (racket:syntax-local-value/immediate id-stx failure-thunk r:intdefs))
       value]
      [else
       (racket:syntax-local-value id-stx failure-thunk r:intdefs)]))

  (define (internal-definition-context-add-parent! intdef parent-intdef)
    (define old-prune-scopes-proc (internal-definition-context-prune-scopes-proc intdef))
    (set-internal-definition-context-prune-scopes-proc!
     intdef
     (lambda (stx)
       (old-prune-scopes-proc (internal-definition-context-introduce parent-intdef stx 'remove)))))

  (define (syntax-local-expand-in-definition-context stx intdef stop-ids
                                                     #:extra-intdefs [extra-intdefs '()])
    (local-expand stx
                  (internal-definition-context-expand-ctx intdef)
                  stop-ids
                  (cons (internal-definition-context-intdef intdef)
                        (map internal-definition-context-intdef extra-intdefs))))

  (define (syntax-local-definition-context-extend! intdef stx
                                                   #:stop-ids [stop-ids '()]
                                                   #:interpret [interpret-proc (lambda (stx) #f)]
                                                   #:extra-intdefs [extra-intdefs '()])
    (define r:intdef (internal-definition-context-intdef intdef))
    (define r:extra-intdefs (map internal-definition-context-intdef extra-intdefs))
    (define expand-ctx (internal-definition-context-expand-ctx intdef))
    (define all-stop-ids (append stop-ids (kernel-form-identifier-list)))
    (define (prune-scopes stx) (internal-definition-context-prune-scopes intdef stx))
    (let loop ([stxs (list stx)])
      (unless (null? stxs)
        (define expanded-stx
          (syntax-local-expand-in-definition-context (car stxs) intdef all-stop-ids
                                                     #:extra-intdefs extra-intdefs))
        (syntax-parse (syntax-disarm expanded-stx #f)
          #:literal-sets [kernel-literals]
          [_
           #:do [(define maybe-interpreted-stx
                   (local-apply-transformer/any-result interpret-proc
                                                       expanded-stx
                                                       expand-ctx
                                                       (cons r:intdef r:extra-intdefs)))]
           #:when maybe-interpreted-stx #:post ~!
           #:with {~or* (head:id . _) head:id _} this-syntax
           (define maybe-tracked (if (attribute head)
                                     (syntax-track-origin maybe-interpreted-stx this-syntax
                                                          (syntax-local-introduce #'head))
                                     maybe-interpreted-stx))
           (loop (cons (syntax-rearm maybe-tracked expanded-stx #t) (cdr stxs)))]
          [(head:begin ~! form ...)
           (loop (append (for/list ([form (in-list (attribute form))])
                           (syntax-track-origin form this-syntax (syntax-local-introduce #'head)))
                         (cdr stxs)))]
          [(define-values ~! [x:id ...] rhs:expr)
           (define pruned-xs (map prune-scopes (attribute x)))
           (syntax-local-bind-syntaxes pruned-xs #f r:intdef r:extra-intdefs)
           (internal-definition-context-register-val-binding! intdef pruned-xs #'rhs)
           (internal-definition-context-register-origin-stx! intdef this-syntax)
           (loop (cdr stxs))]
          [(define-syntaxes ~! [x:id ...] rhs:expr)
           (define pruned-xs (map prune-scopes (attribute x)))
           (syntax-local-bind-syntaxes pruned-xs #'rhs r:intdef r:extra-intdefs)
           (internal-definition-context-register-binding! intdef pruned-xs)
           (internal-definition-context-register-origin-stx! intdef this-syntax)
           (loop (cdr stxs))]
          [_
           (internal-definition-context-register-expr! intdef expanded-stx)
           (loop (cdr stxs))]))))

  (define (syntax-local-definition-context-finish! intdef)
    (define body-exprs (internal-definition-context-final-exprs intdef))
    (when (null? body-exprs)
      (raise-syntax-error '|begin (possibly implicit)|
                          "no expression after a sequence of internal definitions"
                          (current-syntax-context)
                          #f
                          (map cdr (internal-definition-context-origin-stxs intdef))))
    (define body-expr #`(begin #,@(map syntax-local-introduce (reverse body-exprs))))
    (define val-bindings (reverse (internal-definition-context-val-bindings intdef)))
    (define introduced-val-bindings (for/list ([val-binding (in-list val-bindings)])
                                      (cons (map syntax-local-introduce (car val-binding))
                                            (syntax-local-introduce (cdr val-binding)))))
    (define-values [ignored opaque-stx]
      (syntax-local-expand-expression body-expr #t
                                      #:intdefs (list (internal-definition-context-intdef intdef))
                                      #:value-bindings introduced-val-bindings))
    (for/fold ([result-stx opaque-stx])
              ([origin-stx (in-list (internal-definition-context-origin-stxs intdef))])
      (syntax-track-origin result-stx (cdr origin-stx) (car origin-stx)))))

;; ---------------------------------------------------------------------------------------------------
;; helpers for trampolining

(module intdef-trampoline racket/base
  (require racket/require
           (for-syntax (subtract-in racket/base (submod ".." intdef))
                       (submod ".." intdef))
           syntax/parse/define)

  (provide (for-syntax make-expression-transformer)
           #%expression/intdef local/intdef)

  (begin-for-syntax
    (define ((make-expression-transformer proc) stx)
      (if (eq? (syntax-local-context) 'expression)
          (proc stx)
          #`(#%expression #,stx)))

    (define-syntax-class literal-intdef
      #:description "literal internal definition context"
      #:attributes [value]
      [pattern intdef #:attr value (syntax-e #'intdef)
               #:when (internal-definition-context? (attribute value))]))

  (define-syntax #%expression/intdef
    (make-expression-transformer
     (syntax-parser
       [(_ intdef:literal-intdef)
        (syntax-local-definition-context-finish! (attribute intdef.value))])))

  (define-syntax local/intdef
    (make-expression-transformer
     (syntax-parser
       [(_ intdef:literal-intdef [local-defn-or-expr ...] defn-or-expr ...+)
        (define local-intdef (syntax-local-make-definition-context))
        (internal-definition-context-add-parent! (attribute intdef.value) local-intdef)
        (define bind-redirect
          (syntax-parser
            #:literal-sets [kernel-literals]
            [({~or* define-values define-syntaxes} ~! [x:id ...] _)
             (unless (null? (attribute x))
               (syntax-local-definition-context-extend!
                (attribute intdef.value)
                #'(define-syntaxes [x ...] (values (make-rename-transformer (quote-syntax x)) ...))))
             #f]
            [_
             #f]))
        (for ([local-defn-or-expr (in-list (attribute local-defn-or-expr))])
          (syntax-local-definition-context-extend! local-intdef local-defn-or-expr
                                                   #:interpret bind-redirect
                                                   #:extra-intdefs (list (attribute intdef.value))))
        (syntax-local-definition-context-extend! local-intdef #'(let-values () defn-or-expr ...)
                                                 #:extra-intdefs (list (attribute intdef.value)))
        (syntax-local-definition-context-finish! local-intdef)]))))

;; ---------------------------------------------------------------------------------------------------
;; example uses

(require racket/require
         (for-syntax (subtract-in racket/base 'intdef)
                     racket/list
                     racket/set
                     syntax/transformer
                     'intdef)
         racket/format
         racket/set
         racket/stxparam
         racket/unsafe/undefined
         syntax/parse/define
         'intdef-trampoline)

(module+ test
  (require rackunit))

;; local
(define-syntax local
  (make-expression-transformer
   (syntax-parser
     [(_ [local-defn-or-expr ...] defn-or-expr ...+)
      #:do [(define intdef (syntax-local-make-definition-context))
            (for ([local-defn-or-expr (in-list (attribute local-defn-or-expr))])
              (syntax-local-definition-context-extend! intdef local-defn-or-expr))
            (syntax-local-definition-context-extend! intdef #'(let () defn-or-expr ...))]
      (syntax-local-definition-context-finish! intdef)])))

(module+ test
  (check-equal? (local [(define x 2)
                        (define y (* x 3))]
                  (define x (+ y 4))
                  (/ x 2))
                5))

;; mini-class
(define-for-syntax (mini-class-keyword stx)
  (raise-syntax-error #f "cannot be used as an expression" stx))
(define-syntaxes [init field define/public]
  (values mini-class-keyword mini-class-keyword mini-class-keyword))
(define-for-syntax mini-class-keywords (list #'init #'field #'define/public))

(define-syntax (this-out-of-context stx)
  (raise-syntax-error #f "cannot be used outside class body" stx))
(define-rename-transformer-parameter this-param (make-rename-transformer #'this-out-of-context))
(define-syntax this (make-variable-like-transformer #'this-param))

(define-syntax (init-out-of-context stx)
  (raise-syntax-error #f "init arg out of context" stx))
(define-syntax (init-in-method stx)
  (raise-syntax-error #f "cannot reference init arg inside method body" stx))

(struct class (methods field-names initializer))
(struct object (class fields))

(define new
  (make-keyword-procedure
   (lambda (kws kw-args cls)
     (define obj (object cls (make-hasheq (for/list ([kw (in-set (class-field-names cls))])
                                            (cons kw unsafe-undefined)))))
     (keyword-apply (class-initializer cls) kws kw-args (list obj))
     obj)))

(define (check-field-not-unsafe-undefined name v #:assign? [assign? #f])
  (if (eq? v unsafe-undefined)
      (raise (exn:fail:contract:variable (~a name ": undefined; "
                                             (if assign? "assignment" "use")
                                             " before initialization")
                                         (current-continuation-marks)
                                         (string->symbol (keyword->string name))))
      v))

(define (dynamic-get-field this name)
  (check-field-not-unsafe-undefined name (hash-ref (object-fields this) name)))
(define (dynamic-set-field!/no-check this name value)
  (hash-set! (object-fields this) name value))
(define (dynamic-set-field! this name value)
  (check-field-not-unsafe-undefined name (hash-ref (object-fields this) name) #:assign? #t)
  (dynamic-set-field!/no-check this name value))
(define dynamic-send
  (make-keyword-procedure
   (lambda (kws kw-args this name . args)
     (keyword-apply (hash-ref (class-methods (object-class this)) name) kws kw-args this args))))

(define-syntax-parser get-field
  [(_ e:expr kw:keyword)
   (syntax/loc this-syntax
     (dynamic-get-field e 'kw))])
(define-syntax-parser set-field!
  [(_ e:expr kw:keyword val-e:expr)
   (syntax/loc this-syntax
     (dynamic-set-field! e 'kw val-e))])
(define-syntax-parser send
  [(_ e:expr kw:keyword . formals)
   (syntax/loc this-syntax
     (dynamic-send e 'kw . formals))])

(define-syntax mini-class
  (make-expression-transformer
   (syntax-parser
     [(_ class-decl ...)
      #:do [(define intdef (syntax-local-make-definition-context))

            (define inits (make-hasheq))
            (define fields (mutable-seteq))
            (define methods (make-hasheq))

            (define interpret
              (syntax-parser
                #:literals [init field define/public]

                [(init ~! {~seq kw:keyword x:id} ...+)
                 #:fail-when (or (check-duplicates (attribute kw) eq? #:key syntax-e)
                                 (for/or ([kw (in-list (attribute kw))])
                                   (and (hash-has-key? inits (syntax-e kw))
                                        kw)))
                 "duplicate init arg name"
                 #:with [x-param ...] (generate-temporaries (attribute x))
                 (for ([kw (in-list (attribute kw))]
                       [x-param (in-list (attribute x-param))])
                   (hash-set! inits (syntax-e kw) (syntax-local-introduce x-param)))
                 #'(begin
                     (define-syntax x (make-variable-like-transformer
                                       (quote-syntax (#%expression x-param))))
                     ...)]

                [(field ~! {~seq kw:keyword e:expr} ...)
                 #:fail-when (or (check-duplicates (attribute kw) eq? #:key syntax-e)
                                 (for/or ([kw (in-list (attribute kw))])
                                   (and (set-member? fields (syntax-e kw))
                                        kw)))
                 "duplicate field name"
                 (for ([kw (in-list (attribute kw))])
                   (set-add! fields (syntax-e kw)))
                 #'(begin (dynamic-set-field!/no-check this 'kw e) ...)]

                [(define/public ~! (kw:keyword . formals) body-defn-or-expr ...+)
                 #:fail-when (and (hash-has-key? methods (syntax-e #'kw)) #'kw)
                 "duplicate method name"
                 (hash-set! methods
                            (syntax-e #'kw)
                            (syntax-local-introduce
                             (syntax/loc this-syntax
                               (lambda (this-val . formals)
                                 (syntax-parameterize ([this-param (make-rename-transformer
                                                                    #'this-val)])
                                   body-defn-or-expr ...)))))
                 #'(begin)]

                [_
                 #f]))

            (for ([class-decl (in-list (attribute class-decl))])
              (syntax-local-definition-context-extend! intdef class-decl
                                                       #:stop-ids mini-class-keywords
                                                       #:interpret interpret))
            (syntax-local-definition-context-extend! intdef #'(void))]

      #:with [(init-kw . init-id) ...] (for/list ([(kw id) (in-hash inits)])
                                         (cons kw (syntax-local-introduce id)))
      #:with [init-tmp ...] (generate-temporaries (attribute init-id))
      #:with [field-kw ...] (set->list fields)
      #:with [(method-kw . method-e) ...] (for/list ([(kw e) (in-hash methods)])
                                            (cons kw (syntax-local-introduce e)))
      #`(local/intdef #,intdef [(define-rename-transformer-parameter init-id
                                  (make-rename-transformer #'init-out-of-context))
                                ...]
         (class (syntax-parameterize ([init-id (make-rename-transformer #'init-in-method)] ...)
                  (hasheq {~@ 'method-kw method-e} ...))
                (seteq 'field-kw ...)
                (lambda (this-val {~@ init-kw init-tmp} ...)
                  (syntax-parameterize ([this-param (make-rename-transformer #'this-val)]
                                        [init-id (make-rename-transformer (quote-syntax init-tmp))]
                                        ...)
                    (#%expression/intdef #,intdef)))))])))

(module+ test
  (define-simple-macro (attr-accessor kw:keyword e:expr)
    #:do [(define kw-str (keyword->string (syntax-e #'kw)))]
    #:with get-kw (datum->syntax #f (string->keyword (string-append "get-" kw-str)) #'kw)
    #:with set!-kw (datum->syntax #f (string->keyword (string-append "set-" kw-str "!")) #'kw)
    (begin
      (field kw e)
      (define/public (get-kw)
        (get-field this kw))
      (define/public (set!-kw val)
        (set-field! this kw val))))

  (define box%
    (mini-class
     (init #:value value)
     (attr-accessor #:value value)))

  (define b (new box% #:value #f))
  (check-equal? (send b #:get-value) #f)
  (send b #:set-value! #t)
  (check-equal? (send b #:get-value) #t))