;;;; Code from
;;;;   "Abstraction and Performance from Explicit Monadic Reflection"
;;;;    by Jonathan Sobel, Erik Hilsdale, Kent Dybvig, and Dan Friedman

;;;; There is some additional code and reorganization here, to make it
;;;; easier to try out the examples.


;;;----------------------------------------------------------------------
;;; Preliminaries:
;;; Products:
(define same-and-doubled
  (lambda (n)
    (values n (* n 2))))

(define times3
  (lambda (n)
    (call-with-values (lambda () 
                        (same-and-doubled n))
      (lambda (same doubled)
        (+ same doubled)))))

(define-syntax let-values
  (syntax-rules ()
    ((let-values (?params ?exp) ?body)
     (call-with-values (lambda () ?exp)
       (lambda ?params ?body)))))

(define times3
  (lambda (n)
    (let-values ((same doubled) (same-and-doubled n))
      (+ same doubled))))

;;; Sums:
(define inl
  (lambda (x)
    (list x)))

(define inr
  (lambda ()
    #f))

(define-syntax sum-case
  (syntax-rules ()
    ((sum-case ?exp
       ((?var) ?left-result)
       (() ?right-result))
     (let ((temp ?exp))
       (if temp
           (let ((?var (car temp)))
             ?left-result)
           ?right-result)))))

(define add1-or-zero
  (lambda (x)
    (sum-case x
      ((n) (+ n 1))
      (() 0))))

(list (add1-or-zero (inl 42)) (add1-or-zero (inr)))

;;;----------------------------------------------------------------------
;;; Parsing natural numbers:

(define natural
  (lambda ()
    (lambda (ts1)
      (let-values ((x ts2) ((digit) ts1))
        (sum-case x
          ((d) ((lambda (ts1)
                  (let-values ((x ts2) ((more-digits) ts1))
                    (sum-case x
                      ((ds) ((lambda (ts)
                               (values (inl (string->number
                                              (list->string (cons d ds))))
                                       ts))
                             ts2))
                      (() (values (inr) ts2)))))
                ts2))
          (() (values (inr) ts2)))))))

(define more-digits
  (lambda ()
    (lambda (ts1)
      (let-values ((x ts2) ((lambda (ts1)
                              (let-values ((x ts2) ((digit) ts1))
                                (sum-case x
                                  ((d) ((lambda (ts1)
                                          (let-values ((x ts2) ((more-digits) ts1))
                                            (sum-case x
                                              ((ds) ((lambda (ts)
                                                       (values (inl (cons d ds)) ts))
                                                     ts2))
                                              (() (values (inr) ts2)))))
                                        ts2))
                                  (() (values (inr) ts2)))))
                            ts1))
        (sum-case x
          ((ds) (values (inl ds) ts2))
          (() ((lambda (ts)
                 (values (inl '()) ts))
               ts1)))))))

;;; Now use return and bind to clean things up:

(define-syntax return
  (syntax-rules ()
    ((return ?answer)
     (lambda (ts)
       (values (inl ?answer) ts)))))

(define-syntax bind
  (syntax-rules ()
    ((bind (?var ?producer1)
       ?producer2)
     (lambda (ts1)
       (let-values ((x ts2) (?producer1 ts1))
         (sum-case x
           ((?var) (?producer2 ts2))
           (() (values (inr) ts2))))))))

(define natural
  (lambda ()
    (bind (d (digit))
      (bind (ds (more-digits))
        (return (string->number
                  (list->string (cons d ds))))))))

;;; When we try to clean up more-digits, it doesn't get very clean,
;;; so we come up with orelse, which cleans up more-digits:

(define more-digits
  (lambda ()
    (lambda (ts1)
      (let-values ((x ts2) ((bind (d (digit))
                              (bind (ds (more-digits))
                                (return (cons d ds))))
                            ts1))
        (sum-case x
          ((ds) (values (inl ds) ts2))
          (() ((return '()) ts1)))))))

(define-syntax orelse
  (syntax-rules ()
    ((orelse ?producer1 ?producer2)
     (lambda (ts1)
       (let-values ((x ts2) (?producer1 ts1))
         (sum-case x
           ((ds) (values (inl ds) ts2))
           (() (?producer2 ts1))))))))

(define more-digits
  (lambda ()
    (orelse (bind (d (digit))
              (bind (ds (more-digits))
                (return (cons d ds))))
            (return '()))))

;;; We can write digit, but there's nothing we can do (yet) to clean
;;; it up:

(define digit
  (lambda ()
    (lambda (ts)
      (if (or (null? ts)
              (not (char-numeric? (car ts))))
          (values (inr) ts)
          (values (inl (car ts)) (cdr ts))))))

;;;----------------------------------------------------------------------
;;; Monads:

(define map
  (lambda (f)
    (lambda (alpha-producer)
      (lambda (ts1)
        (let-values ((x ts2) (alpha-producer ts1))
          (sum-case x
            ((a) (values (inl (f a)) ts2))
            (() (values (inr) ts2))))))))

(define map
  (lambda (f)
    (lambda (alpha-producer)
      (bind (a alpha-producer)
        (return (f a))))))

(define unit
  (lambda (a)
    (lambda (ts)
      (values (inl a) ts))))

(define unit
  (lambda (a)
    (return a)))

(define mult
  (lambda (alpha-producer-producer)
    (lambda (ts1)
      (let-values ((x ts2) (alpha-producer-producer ts1))
        (sum-case x
          ((alpha-producer) (alpha-producer ts2))
          (() (values (inr) ts2)))))))

(define mult
  (lambda (alpha-producer-producer)
    (bind (alpha-producer alpha-producer-producer)
      alpha-producer)))

;;; Now that we have unit and mult, go back and redo digit and orelse:

(define digit
  (lambda ()
    (mult (return (lambda (ts)
                    (if (or (null? ts)
                            (not (char-numeric? (car ts))))
                        (values (inr) ts)
                        (values (inl (car ts)) (cdr ts))))))))

(define-syntax orelse
  (syntax-rules ()
    ((orelse ?producer1 ?producer2)
     (bind (p1 (unit ?producer1))
       (bind (p2 (unit ?producer2))
         (mult (return (lambda (ts1)
                         (let-values ((x ts2) (p1 ts1))
                           (sum-case x
                             ((ds) (values (inl ds) ts2))
                             (() (p2 ts1))))))))))))

;;; But we can do better, using reify and reflect:

(define-syntax reify
  (syntax-rules ()
    ((reify (?var ?producer1)
       ?producer2)
     (bind (?var (unit ?producer1))
       ?producer2))))

(define-syntax reflect
  (syntax-rules ()
    ((reflect (?var) ?expression)
     (mult (return (lambda (?var) ?expression))))))

(define digit
  (lambda ()
    (reflect (ts)
      (if (or (null? ts)
              (not (char-numeric? (car ts))))
          (values (inr) ts)
          (values (inl (car ts)) (cdr ts))))))

(define-syntax orelse
  (syntax-rules ()
    ((orelse ?producer1 ?producer2)
     (reify (p1 ?producer1)
       (reify (p2 ?producer2)
         (reflect (ts1)
           (let-values ((x ts2) (p1 ts1))
             (sum-case x
               ((ds) (values (inl ds) ts2))
               (() (p2 ts1))))))))))

;;;----------------------------------------------------------------------
;;; Grammar section:

(define-syntax lambda+
  (syntax-rules ()
    ((lambda+ (?var ...) ?producer)
     (lambda (?var ...) ?producer))))

(define-syntax run
  (syntax-rules ()
    ((run ?producer ?exp)
     (?producer ?exp))))


;;;----------------------------------------------------------------------
;;;----------------------------------------------------------------------
;;; Complete example so far, unoptimized, with lambda+ added:

(define-syntax return
  (syntax-rules ()
    ((return ?answer)
     (lambda (ts)
       (values (inl ?answer) ts)))))

(define-syntax bind
  (syntax-rules ()
    ((bind (?var ?producer1)
       ?producer2)
     (lambda (ts1)
       (let-values ((x ts2) (?producer1 ts1))
         (sum-case x
           ((?var) (?producer2 ts2))
           (() (values (inr) ts2))))))))

(define-syntax reify
  (syntax-rules ()
    ((reify (?var ?producer1)
       ?producer2)
     (bind (?var (unit ?producer1))
       ?producer2))))

(define-syntax reflect
  (syntax-rules ()
    ((reflect (?var) ?expression)
     (mult (return (lambda (?var) ?expression))))))

(define-syntax orelse
  (syntax-rules ()
    ((orelse ?producer1 ?producer2)
     (reify (p1 ?producer1)
       (reify (p2 ?producer2)
         (reflect (ts1)
           (let-values ((x ts2) (p1 ts1))
             (sum-case x
               ((ds) (values (inl ds) ts2))
               (() (p2 ts1))))))))))

(define natural
  (lambda+ ()
    (bind (d (digit))
      (bind (ds (more-digits))
        (return (string->number
                  (list->string (cons d ds))))))))

(define more-digits
  (lambda+ ()
    (orelse (bind (d (digit))
              (bind (ds (more-digits))
                (return (cons d ds))))
            (return '()))))

(define digit
  (lambda+ ()
    (reflect (ts)
      (if (or (null? ts)
              (not (char-numeric? (car ts))))
          (values (inr) ts)
          (values (inl (car ts)) (cdr ts))))))


;;;----------------------------------------------------------------------
;;;----------------------------------------------------------------------
;;; Now for the fun part!  Optimize!

(define-syntax with-args
  (syntax-rules ()
    ((with-args (?extra-arg ...) (?operator ?arg ...))
     (?operator ?arg ... ?extra-arg ...))))

(define-syntax lambda+
  (syntax-rules ()
    ((lambda+ (?formal ...) ?body)
     (lambda (?formal ... ts)
       (with-args (ts) ?body)))))

(define-syntax bind
  (syntax-rules ()
    ((bind (?var ?rhs) ?body ?ts ...)
     (let-values ((x ?ts ...)
                  (with-args (?ts ...) ?rhs))
       (sum-case x
         ((?var) (with-args (?ts ...) ?body))
         (() (values (inr) ?ts ...)))))))

(define-syntax return
  (syntax-rules ()
    ((return ?answer ?ts ...)
     (values (inl ?answer) ?ts ...))))

(define-syntax run
  (syntax-rules ()
    ((run ?producer ?exp ...)
     (with-args (?exp ...) ?producer))))

(define-syntax reflect
  (syntax-rules ()
    ((reflect (?var ...) ?expression ?ts ...)
     (let ((?var ?ts) ...)
       ?expression))))

(define-syntax reify
  (syntax-rules ()
    ((reify (?var ?rhs) ?body ?ts ...)
     (let ((?var (lambda (?ts ...)
                   (with-args (?ts ...) ?rhs))))
       (with-args (?ts ...) ?body)))))

(define-syntax reify
  (syntax-rules ()
    ((reify (?var ?rhs) ?body ?ts ...)
     (let-syntax ((?var (syntax-rules ()
                          ((?var ?ts ...)
                           (with-args (?ts ...) ?rhs)))))
       (with-args (?ts ...) ?body)))))

;;;----------------------------------------------------------------------
;;; And the example, one last time.  Same code (except for orelse),
;;; but it needs to be expanded again, with the new macro definitions,
;;; do we include it all here for ease of testing.  You can run it all
;;; by using just the preceding section and this one.

(define-syntax orelse
  (syntax-rules ()
    ((orelse ?producer1 ?producer2 ?ts ...)
     (with-args (?ts ...)
       (reify (p1 ?producer1)
         (reify (p2 ?producer2)
           (reflect (ts1)
             (let-values ((x ts2) (p1 ts1))
               (sum-case x
                 ((ds) (values (inl ds) ts2))
                 (() (p2 ts1)))))))))))

(define natural
  (lambda+ ()
    (bind (d (digit))
      (bind (ds (more-digits))
        (return (string->number
                  (list->string (cons d ds))))))))

(define more-digits
  (lambda+ ()
    (orelse (bind (d (digit))
              (bind (ds (more-digits))
                (return (cons d ds))))
            (return '()))))

(define digit
  (lambda+ ()
    (reflect (ts)
      (if (or (null? ts)
              (not (char-numeric? (car ts))))
          (values (inr) ts)
          (values (inl (car ts)) (cdr ts))))))