<commit_before>#lang racket/base
; algebraic effects and handlers as found in:
; http://www.eff-lang.org/
(provide
  effect
  handler
  handler-compose
  eff-handle
  @!
  @!!
  )

(require
  racket/control
  racket/function
  )

(module+ test
  (require
    "sugar.rkt"
    rackunit
    ))

(define-syntax effect
  (syntax-rules ()
    ((_ op-name ...)
     (make-immutable-hash (list (cons 'op-name (make-parameter
      (lambda _ (error (format "unhandled effect: ~a" 'op-name))))) ...)))))

(define-syntax handler-full
  (syntax-rules ()
    ((_ ((effect-expr (op-name op-param ... cont) op-body ...) ...)
        (return v return-body ...)
        (finally r finally-body ...))
     (lambda (body-thunk)
       (define (return v) return-body ...)
       (define (finally r) finally-body ...)
       (define tag (make-continuation-prompt-tag))
       (parameterize
         (((hash-ref effect-expr 'op-name)
           (lambda (op-param ...) (shift-at tag cont op-body ...))) ...)
         (finally (reset-at tag (return (body-thunk)))))))))

(define-syntax handler-finally
  (syntax-rules (finally)
    ((_ ops ret (finally r finally-body ...))
     (handler-full ops ret (finally r finally-body ...)))
     ;(let ((finally (lambda (r) finally-body ...))) main-expr))
    ((_ ops ret)
     (handler-finally ops ret (finally r r)))))

(define-syntax handler-return+finally
  (syntax-rules (return)
    ((_ ops (return v return-body ...) finally ...)
     (handler-finally ops (return v return-body ...) finally ...))
      ;(let ((return (lambda (v) return-body ...)))
        ;main-expr)
      ;finally ...))
    ((_ ops finally ...)
     (handler-return+finally ops (return v v) finally ...))))

(define-syntax handler-ops
  (syntax-rules ()
    ((_ (acc ...) (ee (on op ... k) ob ...) rest ...)
     (handler-ops (acc ... (ee (on op ... k) ob ...)) rest ...))
    ((_ ops rest ...)
     (handler-return+finally ops rest ...))))
(define-syntax handler
  (syntax-rules ()
    ((_ body ...) (handler-ops () body ...))))

(define-syntax @!!
  (syntax-rules ()
    ((_ effect-expr op-name-expr arg ...)
     (((hash-ref effect-expr op-name-expr)) arg ...))))
(define-syntax @!
  (syntax-rules ()
    ((_ effect-expr op-name arg ...) (@!! effect-expr 'op-name arg ...))))

(define-syntax eff-handle
  (syntax-rules ()
    ((_ handler-expr body ...) (handler-expr (thunk body ...)))))<commit_msg>Remove stray commented code<commit_after>#lang racket/base
; algebraic effects and handlers as found in:
; http://www.eff-lang.org/
(provide
  effect
  handler
  handler-compose
  eff-handle
  @!
  @!!
  )

(require
  racket/control
  racket/function
  )

(module+ test
  (require
    "sugar.rkt"
    rackunit
    ))

(define-syntax effect
  (syntax-rules ()
    ((_ op-name ...)
     (make-immutable-hash (list (cons 'op-name (make-parameter
      (lambda _ (error (format "unhandled effect: ~a" 'op-name))))) ...)))))

(define-syntax handler-full
  (syntax-rules ()
    ((_ ((effect-expr (op-name op-param ... cont) op-body ...) ...)
        (return v return-body ...)
        (finally r finally-body ...))
     (lambda (body-thunk)
       (define (return v) return-body ...)
       (define (finally r) finally-body ...)
       (define tag (make-continuation-prompt-tag))
       (parameterize
         (((hash-ref effect-expr 'op-name)
           (lambda (op-param ...) (shift-at tag cont op-body ...))) ...)
         (finally (reset-at tag (return (body-thunk)))))))))

(define-syntax handler-finally
  (syntax-rules (finally)
    ((_ ops ret (finally r finally-body ...))
     (handler-full ops ret (finally r finally-body ...)))
    ((_ ops ret)
     (handler-finally ops ret (finally r r)))))

(define-syntax handler-return+finally
  (syntax-rules (return)
    ((_ ops (return v return-body ...) finally ...)
     (handler-finally ops (return v return-body ...) finally ...))
    ((_ ops finally ...)
     (handler-return+finally ops (return v v) finally ...))))

(define-syntax handler-ops
  (syntax-rules ()
    ((_ (acc ...) (ee (on op ... k) ob ...) rest ...)
     (handler-ops (acc ... (ee (on op ... k) ob ...)) rest ...))
    ((_ ops rest ...)
     (handler-return+finally ops rest ...))))
(define-syntax handler
  (syntax-rules ()
    ((_ body ...) (handler-ops () body ...))))

(define-syntax @!!
  (syntax-rules ()
    ((_ effect-expr op-name-expr arg ...)
     (((hash-ref effect-expr op-name-expr)) arg ...))))
(define-syntax @!
  (syntax-rules ()
    ((_ effect-expr op-name arg ...) (@!! effect-expr 'op-name arg ...))))

(define-syntax eff-handle
  (syntax-rules ()
    ((_ handler-expr body ...) (handler-expr (thunk body ...)))))
{'fraction_non_alphanumeric': 0.20567986230636834, 'fraction_numerical': 0.0, 'mean_word_length': 2.273943661971831, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 3, 'https://': 0, 'lorem ipsum': 0, 'www.': 2, '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': '5018947', 'n_tokens_mistral': 1602, 'n_tokens_neox': 1516, 'n_words': 378}