<commit_before>(module lazy mzscheme

  (require-for-syntax stepper/private/shared)

  ;; ~ = lazy (or delayed)
  ;; ! = strict (or forced)
  ;; (See below for app-related names)

  ;; --------------------------------------------------------------------------
  ;; Syntax utilities

  ;; taken & modified from swindle/misc.ss
  (provide defsubst) ; useful utility
  (define-syntax (defsubst-process stx)
    (syntax-case stx ()
      [(_ name (acc ...))
       #'(define-syntax (name stx)
           (syntax-case stx () acc ...))]
      [(_ name (acc ...) id subst . more) (identifier? #'id)
       #'(defsubst-process
           name (acc ...
                 (id (identifier? #'id) #'subst)
                 ((id x (... ...)) #'(subst x (... ...))))
           . more)]
      [(_ name (acc ...) n+a subst . more)
       #'(defsubst-process name (acc ... (n+a #'subst)) . more)]))
  (define-syntax defsubst
    (syntax-rules ()
      [(_ (name . args) subst . more)
       (defsubst-process name () (name . args) subst . more)]
      [(_ name subst . more)
       (defsubst-process name () name subst . more)]))

  ;; utility for defining ~foo but make it look like #<procedure:foo>
  (define-syntax (define* stx)
    (syntax-case stx ()
      [(_ ~name val) (identifier? #'~name)
       (let* ([~str (symbol->string (syntax-e #'~name))]
              [str  (string->symbol (regexp-replace #rx"^[~*]" ~str ""))])
         (with-syntax ([name (datum->syntax-object #'~name str #'~name)])
           #'(define ~name (let ([name val]) (mark-lazy name)))))]
      [(_ (~name . xs) body ...) (identifier? #'~name)
       #'(define* ~name (lambda xs body ...))]))

  ;; --------------------------------------------------------------------------
  ;; Delay/force etc

  (require "force.ss")

  (provide ~)

  ;; the exposed `!' (and other similar !s) must be a special form in the lazy
  ;; language -- but this is achieved through the lazy #%app (~!%app below)
  ;; that treats it (and the others) specially: uses mzscheme's application
  (define-for-syntax strict-names
    (syntax->list #'(! !! !list !!list !values !!values)))

  ;; --------------------------------------------------------------------------
  ;; Determine laziness

  (define-values (lazy-proc lazy-proc?)
    (let-values ([(type make pred ref set)
                  (make-struct-type
                   'lazy-proc #f 1 0 #f null (current-inspector) 0)])
      (values make pred)))
  (defsubst (lazy? x) (if (lazy-proc? x) #t (struct-constructor-procedure? x)))
  ;; a version that works on any value
  (defsubst (mark-lazy x) (if (procedure? x) (lazy-proc x) x))

  ;; a few primitive constructors
  (define ~cons   (lazy-proc cons))
  (define ~list   (lazy-proc list))
  (define ~list*  (lazy-proc list*))
  (define ~vector (lazy-proc vector))
  (define ~box    (lazy-proc box))
  ;; values is special, see below

  ;; --------------------------------------------------------------------------
  ;; Implicit begin & multiple values

  ;; This is used for implicit body begins.  It is slightly complex since it
  ;; should still be possible to use it for splicing up macro contents, so
  ;; definitions are used with a normal begin.  The actual body turns into one
  ;; promise that, when forced, forces each of its expressions and returns the
  ;; last value.  This effectively ties evaluation of all expressions in one
  ;; package, so (~begin foo bar) will always evaluate `foo' when the value of
  ;; `bar' is forced.
  (define-syntax ~begin
    (let ([ids (syntax->list
                #'(~define ~define-values define-syntax define-syntaxes
                   define-struct require provide))])
      (define (definition? stx)
        (ormap (lambda (id) (module-identifier=? id stx)) ids))
      (lambda (stx)
        (syntax-case stx ()
          ;; optimize simple cases
          [(_) #'(begin)]
          [(_ expr) #'expr]
          [(_ expr ...)
           (let loop ([exprs #'(expr ...)] [defs '()])
             (syntax-case exprs ()
               [((head . rest) expr ...)
                (definition? #'head)
                (loop #'(expr ...) (cons #'(head . rest) defs))]
               ;; only definitions
               [() #`(begin #,@(reverse defs))]
               ;; single expr
               [(expr) #`(begin #,@(reverse defs) expr)]
               [(expr ...)
                #`(begin #,@(reverse defs) (~ (begin (! expr) ...)))]))]))))

  ;; redefined to use lazy-proc and ~begin
  (define-syntax (~lambda stx)
    (syntax-case stx ()
      [(_ args body0 body ...)
       (let ([n (syntax-local-name)])
         (with-syntax ([lam (syntax-property
                             (syntax/loc stx
                               (lambda args (~begin body0 body ...)))
                             'inferred-name n)])
           (syntax/loc stx (lazy-proc lam))))]))
  (provide (rename ~lambda λ))
  (defsubst
    (~define (f . xs) body0 body ...) (define f (~lambda xs body0 body ...))
    (~define v x) (define v x))
  (defsubst
    (~let [(x v) ...] body0 body ...)
      (let ([x v] ...) (~begin body0 body ...))
    (~let name [(x v) ...] body0 body ...)
      (let name [(x v) ...] (~begin body0 body ...)))
  (defsubst (~let* [(x v) ...] body0 body ...)
    (let* ([x v] ...) (~begin body0 body ...)))
  (defsubst (~letrec [(x v) ...] body0 body ...)
    (letrec ([x v] ...) (~begin body0 body ...)))

  ;; parameterize should force its arguments
  (defsubst (~parameterize ([param val] ...) body ...)
    ;; like ~begin, delaying the whole thing is necessary to tie the evaluation
    ;; to whenever the value is actually forced
    (~ (parameterize ([param (! val)] ...) (~begin body ...))))

  ;; Multiple values are problematic: MzScheme promises can use multiple
  ;; values, but to carry that out `call-with-values' should be used in all
  ;; places that deal with multiple values, which will make the whole thing
  ;; much slower (about twice in tight loops) -- but multiple values are rarely
  ;; used (spceifically, students never use them).  So `values' is redefined to
  ;; produce a first-class tuple-holding struct, and `split-values' turns that
  ;; into multiple values.
  (define-struct multiple-values (values))
  (define (split-values x)
    (let ([x (! x)])
      (if (multiple-values? x) (apply values (multiple-values-values x)) x)))
  ;; Force and split resulting values.
  (define (!values x)
    (split-values (! x)))
  ;; Similar, but forces the actual values too.
  (define (!!values x)
    (let ([x (! x)])
      (if (multiple-values? x)
        (apply values (map ! (multiple-values-values x)))
        x)))

  (define* (~values . xs) (make-multiple-values xs))

  ;; Redefine multiple-value constructs so they split the results
  (defsubst (~define-values (v ...) body)
    (define-values (v ...) (split-values body)))
  (defsubst (~let-values ([(x ...) v] ...) body ...)
    (let-values ([(x ...) (split-values v)] ...) (~begin body ...)))
  (defsubst (~let*-values ([(x ...) v] ...) body ...)
    (let*-values ([(x ...) (split-values v)] ...) (~begin body ...)))
  (defsubst (~letrec-values ([(x ...) v] ...) body ...)
    (letrec-values ([(x ...) (split-values v)] ...) (~begin body ...)))

  ;; Redefine things that return multiple values.
  ;; (todo: only stuff necessary for the datatypes are done, more needed)
  (define* (~make-struct-type . args)
    (let ([args (!!list args)])
      (call-with-values (lambda () (apply make-struct-type args)) ~values)))

  ;; --------------------------------------------------------------------------
  ;; Applications

  ;; Basic names:
  ;; `app':    syntax, calls a function over given arguments
  ;; `apply':  function, last argument is a list of arguments to the function
  ;; Conventions:
  ;; `!*---':  forces args when needed (depending on the function)
  ;;           doesn't force the function (internal use only)
  ;; `!---':   forces function, and forces args when needed
  ;; `~!---':  adds a delay wrapper to the application (uses the above)
  ;;           (this is a macro in the `apply' case too)<commit_msg>make (values x) return just x<commit_after>(module lazy mzscheme

  (require-for-syntax stepper/private/shared)

  ;; ~ = lazy (or delayed)
  ;; ! = strict (or forced)
  ;; (See below for app-related names)

  ;; --------------------------------------------------------------------------
  ;; Syntax utilities

  ;; taken & modified from swindle/misc.ss
  (provide defsubst) ; useful utility
  (define-syntax (defsubst-process stx)
    (syntax-case stx ()
      [(_ name (acc ...))
       #'(define-syntax (name stx)
           (syntax-case stx () acc ...))]
      [(_ name (acc ...) id subst . more) (identifier? #'id)
       #'(defsubst-process
           name (acc ...
                 (id (identifier? #'id) #'subst)
                 ((id x (... ...)) #'(subst x (... ...))))
           . more)]
      [(_ name (acc ...) n+a subst . more)
       #'(defsubst-process name (acc ... (n+a #'subst)) . more)]))
  (define-syntax defsubst
    (syntax-rules ()
      [(_ (name . args) subst . more)
       (defsubst-process name () (name . args) subst . more)]
      [(_ name subst . more)
       (defsubst-process name () name subst . more)]))

  ;; utility for defining ~foo but make it look like #<procedure:foo>
  (define-syntax (define* stx)
    (syntax-case stx ()
      [(_ ~name val) (identifier? #'~name)
       (let* ([~str (symbol->string (syntax-e #'~name))]
              [str  (string->symbol (regexp-replace #rx"^[~*]" ~str ""))])
         (with-syntax ([name (datum->syntax-object #'~name str #'~name)])
           #'(define ~name (let ([name val]) (mark-lazy name)))))]
      [(_ (~name . xs) body ...) (identifier? #'~name)
       #'(define* ~name (lambda xs body ...))]))

  ;; --------------------------------------------------------------------------
  ;; Delay/force etc

  (require "force.ss")

  (provide ~)

  ;; the exposed `!' (and other similar !s) must be a special form in the lazy
  ;; language -- but this is achieved through the lazy #%app (~!%app below)
  ;; that treats it (and the others) specially: uses mzscheme's application
  (define-for-syntax strict-names
    (syntax->list #'(! !! !list !!list !values !!values)))

  ;; --------------------------------------------------------------------------
  ;; Determine laziness

  (define-values (lazy-proc lazy-proc?)
    (let-values ([(type make pred ref set)
                  (make-struct-type
                   'lazy-proc #f 1 0 #f null (current-inspector) 0)])
      (values make pred)))
  (defsubst (lazy? x) (if (lazy-proc? x) #t (struct-constructor-procedure? x)))
  ;; a version that works on any value
  (defsubst (mark-lazy x) (if (procedure? x) (lazy-proc x) x))

  ;; a few primitive constructors
  (define ~cons   (lazy-proc cons))
  (define ~list   (lazy-proc list))
  (define ~list*  (lazy-proc list*))
  (define ~vector (lazy-proc vector))
  (define ~box    (lazy-proc box))
  ;; values is special, see below

  ;; --------------------------------------------------------------------------
  ;; Implicit begin & multiple values

  ;; This is used for implicit body begins.  It is slightly complex since it
  ;; should still be possible to use it for splicing up macro contents, so
  ;; definitions are used with a normal begin.  The actual body turns into one
  ;; promise that, when forced, forces each of its expressions and returns the
  ;; last value.  This effectively ties evaluation of all expressions in one
  ;; package, so (~begin foo bar) will always evaluate `foo' when the value of
  ;; `bar' is forced.
  (define-syntax ~begin
    (let ([ids (syntax->list
                #'(~define ~define-values define-syntax define-syntaxes
                   define-struct require provide))])
      (define (definition? stx)
        (ormap (lambda (id) (module-identifier=? id stx)) ids))
      (lambda (stx)
        (syntax-case stx ()
          ;; optimize simple cases
          [(_) #'(begin)]
          [(_ expr) #'expr]
          [(_ expr ...)
           (let loop ([exprs #'(expr ...)] [defs '()])
             (syntax-case exprs ()
               [((head . rest) expr ...)
                (definition? #'head)
                (loop #'(expr ...) (cons #'(head . rest) defs))]
               ;; only definitions
               [() #`(begin #,@(reverse defs))]
               ;; single expr
               [(expr) #`(begin #,@(reverse defs) expr)]
               [(expr ...)
                #`(begin #,@(reverse defs) (~ (begin (! expr) ...)))]))]))))

  ;; redefined to use lazy-proc and ~begin
  (define-syntax (~lambda stx)
    (syntax-case stx ()
      [(_ args body0 body ...)
       (let ([n (syntax-local-name)])
         (with-syntax ([lam (syntax-property
                             (syntax/loc stx
                               (lambda args (~begin body0 body ...)))
                             'inferred-name n)])
           (syntax/loc stx (lazy-proc lam))))]))
  (provide (rename ~lambda λ))
  (defsubst
    (~define (f . xs) body0 body ...) (define f (~lambda xs body0 body ...))
    (~define v x) (define v x))
  (defsubst
    (~let [(x v) ...] body0 body ...)
      (let ([x v] ...) (~begin body0 body ...))
    (~let name [(x v) ...] body0 body ...)
      (let name [(x v) ...] (~begin body0 body ...)))
  (defsubst (~let* [(x v) ...] body0 body ...)
    (let* ([x v] ...) (~begin body0 body ...)))
  (defsubst (~letrec [(x v) ...] body0 body ...)
    (letrec ([x v] ...) (~begin body0 body ...)))

  ;; parameterize should force its arguments
  (defsubst (~parameterize ([param val] ...) body ...)
    ;; like ~begin, delaying the whole thing is necessary to tie the evaluation
    ;; to whenever the value is actually forced
    (~ (parameterize ([param (! val)] ...) (~begin body ...))))

  ;; Multiple values are problematic: MzScheme promises can use multiple
  ;; values, but to carry that out `call-with-values' should be used in all
  ;; places that deal with multiple values, which will make the whole thing
  ;; much slower (about twice in tight loops) -- but multiple values are rarely
  ;; used (spceifically, students never use them).  So `values' is redefined to
  ;; produce a first-class tuple-holding struct, and `split-values' turns that
  ;; into multiple values.
  (define-struct multiple-values (values))
  (define (split-values x)
    (let ([x (! x)])
      (if (multiple-values? x) (apply values (multiple-values-values x)) x)))
  ;; Force and split resulting values.
  (define (!values x)
    (split-values (! x)))
  ;; Similar, but forces the actual values too.
  (define (!!values x)
    (let ([x (! x)])
      (if (multiple-values? x)
        (apply values (map ! (multiple-values-values x)))
        x)))

  (define* ~values
    (case-lambda [(x) x] [xs (make-multiple-values xs)]))

  ;; Redefine multiple-value constructs so they split the results
  (defsubst (~define-values (v ...) body)
    (define-values (v ...) (split-values body)))
  (defsubst (~let-values ([(x ...) v] ...) body ...)
    (let-values ([(x ...) (split-values v)] ...) (~begin body ...)))
  (defsubst (~let*-values ([(x ...) v] ...) body ...)
    (let*-values ([(x ...) (split-values v)] ...) (~begin body ...)))
  (defsubst (~letrec-values ([(x ...) v] ...) body ...)
    (letrec-values ([(x ...) (split-values v)] ...) (~begin body ...)))

  ;; Redefine things that return multiple values.
  ;; (todo: only stuff necessary for the datatypes are done, more needed)
  (define* (~make-struct-type . args)
    (let ([args (!!list args)])
      (call-with-values (lambda () (apply make-struct-type args)) ~values)))

  ;; --------------------------------------------------------------------------
  ;; Applications

  ;; Basic names:
  ;; `app':    syntax, calls a function over given arguments
  ;; `apply':  function, last argument is a list of arguments to the function
  ;; Conventions:
  ;; `!*---':  forces args when needed (depending on the function)
  ;;           doesn't force the function (internal use only)
  ;; `!---':   forces function, and forces args when needed
  ;; `~!---':  adds a delay wrapper to the application (uses the above)
  ;;           (this is a macro in the `apply' case too)
{'fraction_non_alphanumeric': 0.21321173280749323, 'fraction_numerical': 0.0018486566428395365, 'mean_word_length': 1.9920722713864307, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 15, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6113343', 'n_tokens_mistral': 5160, 'n_tokens_neox': 4762, 'n_words': 1649}