;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; The full text of the GNU General Public License can be read at:
;; <https://www.gnu.org/licenses/>.
;;----------------------------------------------------------------------

(import (scheme base))

(cond-expand
  (guile-3
   )
  (else
   (import
     (only (srfi 130) string-split))
   ))

;; Here is a simple example of a monadic evaluator in Scheme that
;; behaves like any ordinary, non-concurrent, procedural program. It
;; steps through a list of lambdas composing them all together by
;; executing a lambda, and applying the values returned the lambda as
;; the arguments to the next computation:


(define (monad-eval monad . args)
  ;; Lets say the "monad" arument here is a list of procedures.
  (let loop ((procs monad) (args args))
    (cond
      ((null? procs) (apply values args))
      (else
        (call-with-values
          ;; first execute the first procedure
          (lambda () (apply (car procs) args))
          ;; then execute the next procedure
          (lambda args (loop (cdr procs) args))
          )))))


(define monadic-average
  (list
    (lambda args      ;; 1. sum all arguments, return sum and list length
      (values (apply + args) (length args)))
    (lambda (sum len) ;; 2. display sum, compute and return average
      (display "sum = ")(write sum)(newline)
      (inexact (/ sum len)))
    (lambda (avg)     ;; 3. display and return 
      (display "avg = ")(write avg)(newline)
      avg)))


(write
 (monad-eval monadic-average -3 -1 4 8 15 16 23 42 66 104))

(newline)

;;--------------------------------------------------------------------------------------------------

;; Our pretty printer may want to parameterize values like
;; indentation, or which output ports to use. Of course, we can use
;; Scheme's built-in parameter objects for this, but lets see how we
;; might construct a monad similar to Haskell's "reader" monad to
;; accomplish this same goal. To construct a "reader" monad, our
;; thunks must always take exactly one argument, the environment
;; argument. The environment will contain the parameters we want to
;; always be available to every thunk in the monad. So lets define two
;; record type: one for our thunks, one for our environment.
;;
;; Also, our monad will have properties of a "writer" monad. This is
;; accomplished by storing a data structure in the monad environment
;; that can collect output. In the case of the pretty printer, this
;; data structure is an output port.


(define-record-type <pretty-monad-type>
  (%pp thunk) ;; wraps our thunks in a record type
  pretty-monad-type?
  (thunk pretty-monad-thunk)
  )

(define-record-type <pretty-env-type>
  (make<pretty-env> port indent line)
  pretty-env-type?
  (port    pretty-env-port)                            ;; port to which we print
  (indent  pretty-env-indent   set!pretty-env-indent)  ;; indentation level
  (line    pretty-env-newline? set!pretty-env-newline) ;; after a line break?
  )

(define-record-type <quoted-string-type>
  (qstr str)
  quoted-string-type?
  (str unquote-string)
  )


(define (print . args)
  ;; This is a monad combinator, but it also happens to be the monad's
  ;; evaluator as well. It can take monads as arguments, and it will
  ;; recursively calls the evaluator on these arguments, thus defining
  ;; procedural evaluation semantics. The "pretty" evaluator is just
  ;; an entry point into this monad.

  (%pp  ;; Wrap this thunk in a "<pretty-monad-type>".
   (lambda (env)  ;; The thunk takes exactly one argument: a <pretty-env-type>.
     (let ((port (pretty-env-port env)))  ;; Port is used often, give it a short name
       (let loop ((args args))  ;; Loop over the arguments.
         (cond
          ((null? args) (values))  ;; Stop looping here.
          ((pair? args)

            ;; First thing: if we are right after a line break, out
            ;; indentation. This needs to happen inside of this loop
            ;; since arguments can be other monads which could
            ;; evaluate the "line-break" monad.

            (when (pretty-env-newline? env)
              (let loop ((n (pretty-env-indent env)))
                (when (> n 0)
                  (display #\space port)
                  (loop (- n 1)))
                (set!pretty-env-newline env #f)
                ))

            ;; Now, inspect the next argument and "display" or "write" it.

            (let ((obj (car args)))  ;; Get the current argument.
              (cond
               ((string? obj) (display obj port))
               ((char?   obj) (display obj port))
               ((quoted-string-type? obj)
                (write (unquote-string obj) port))
               ((pretty-monad-type? obj) ;; Recursively evaluate monad arguments
                ((pretty-monad-thunk obj) env))
               (else   ;; Use Scheme's built-in writer by default.
                (write obj))
                ))

            (loop (cdr args))
            )))))))


;; Next, lets define a combinator that outputs a line break only if a
;; line break has not already been output. Our combinator can
;; optionally take a boolean to force the line break regardless. If a
;; line break is written, the "pretty-env-newline?" field of the
;; environment is updated to #t.


(define line-break
  (case-lambda
    (() (line-break #f))
    ((forced?)
     (%pp  ;; wrap this thunk in a "<pretty-monad-type>"
       (lambda (env)  ;; the thunk takes an environment
         (unless (and (not forced?) (pretty-env-newline? env))
           (newline (pretty-env-port env))
           (set!pretty-env-newline env #t))
       )))))


;; Finally, let's define a combinator that can recursively evaluate
;; another monad, but with increased indentation. This is an example
;; of how we can simulate the Scheme "parameterize" keyword in our
;; monad.


(define (indent +n monad)
  (%pp ;; wrap this thunk
   (lambda (env)
     (set!pretty-env-indent env (+ (pretty-env-indent env) +n))
     ((pretty-monad-thunk monad) env)
     (set!pretty-env-indent env (- (pretty-env-indent env) +n))
     )))


;; Finally, we need our evaluator function, which I will call the
;; "pretty" procedure. The "print" monad is really the evaluator of
;; this monad, so the pretty evaluator is really just an entrypoint
;; into print, we could call "pretty" the top-level evaluator. This
;; top-level evaluator takes any pretty printer monad and applies an
;; environment to the lazy thunk within it to force computation. So we
;; should provide arguments to the evaluator for setting-up the
;; environment.


(define pretty
  (case-lambda
    ((monad) (pretty #t 0 monad))
    ((init-indent monad) (pretty #t init-indent monad))
    ((port init-indent monad)
     ;; We can do some simple runtime type checking
     ;; when setting up the environment
     (cond
      ((not (integer? init-indent))
       (error "non-integer indentation value" init-indent))
      ((not (pretty-monad-type? monad))
       (error "not a pretty-printer monad" monad))
      (else (values)))
     (let ((port
            (cond
             ((eq? port #f) (open-output-string))
             ((eq? port #t) (current-output-port))
             ((output-port? port) port)
             (else (error "wrong type for port argument" port)))))
       ((pretty-monad-thunk monad)
        (make<pretty-env> port init-indent #t))))
    ))


;; Now we can declare our monadic computation and evaluate it.
;;
;; Here is a function that produces a list of items
;; that we want to pretty print:


(define (iota+ init n end)
  ;; Iterate n numbers starting at zero and
  ;; delimieted by init and end lists.
  (define (iota i)
   (cond
    ((< i n) (cons i (iota (+ 1 i))))
    ((or (pair? end) (null? end)) end)
    (else (list end))))
  (let loop ((init init))
    (cond
     ((pair? init) (cons (car init) (loop (cdr init))))
     ((null? init) (iota 0))
     (else (cons init (iota 0))
     ))))


;; This function calls the above "iota+" and
;; pretty prints the result.


(define (print-seq n)
  (apply print
   (map (lambda (val) (print #\space val)) (iota+ #\( 10 #\)))))


;; Here we pretty print a hello world message with
;; the above list of items in between.


(pretty
 (print #\( "hello" (print-seq 10) (line-break)
        (indent 4 (print (qstr "world!") #\) ))
        (line-break)))


;; Prints:
;; (hello ( 0 1 2 3 4 5 6 7 8 9 )
;:     "world!")

;;--------------------------------------------------------------------------------------------------

;; The basic idea of a "list" monad is that you compose a pipeline of
;; procedures, the output of each procedure being applied to the input
;; of each next procedure in the pipieline. However, each procedure
;; has the option of returning more than one result, and when there is
;; more than one result, each result is applied to the next procedure
;; in the chain concurrently.


(define-record-type <list-monad-type>
  ;; The wrapper for thunks.
  (%list thunk)
  list-monad-type?
  (thunk list-thunk)
  )


;; The combinators


(define (do-list . monads)
  ;; Each argument to this monad must be a procedure, a lambda, or
  ;; a list monad that takes one value and returns a list, each value
  ;; returned is applied concurrently to the procedure that comes
  ;; after it. All arguments returned are collected into a list.
  (%list
   (lambda (arg)
     (let step-monads ((monads monads) (arg arg))
       (cond
        ((null? monads) arg)
        (else
         (let*((monad (car monads))
               (monad
                (cond
                 ((procedure? monad) monad)
                 ((list-monad-type? monad) (list-thunk monad))
                 (else (error "not a list monad or procedure" monad)))
                )
               (args (monad arg)) ;; apply the argument to the next monad
               )
           (apply append
            (map (lambda (arg) (step-monads (cdr monads) arg)) args))
           )))))))


(define (constants . items)
  ;; A list monad that simply wraps all of it's arguments, ignoring
  ;; any input it may receive.
  (%list (lambda _ items)))


(define (eval-list-monad init-args . monads)
  (let ((monad (list-thunk (apply do-list monads))))
    (if (or (pair? init-args) (null? init-args))
        (apply append (map monad init-args))
        (monad init-args))))


(write
 (let ((line-number 0))
   (eval-list-monad
    (string-append
     "As you liberate yourself in metaphor, think of others,\n"
     "those who have lost the right to speak.\n"
     "As you think of others, think of yourself,\n"
     "say: \"if only I were a candle in the dark.\"\n"
     )
    (lambda (str) (string-split str #\newline))
    (lambda (line) (list (string-split line #\space))
       ;; As an exercise, what happens when we do not wrap
       ;; the tokenized line in a list?
       )
    (lambda (line)
      (set! line-number (+ 1 line-number))
      (list (list (cons line-number line)))
      )
    )))

(newline)

(define (list-apply elems monad)
  (eval-list-monad elems (lambda (elem) (list (monad elem)))))


(write 
 (list-apply
  '(1 2 3)
  (lambda (a)
    (list-apply
     '(1 2 3)
     (lambda (b)
       (list-apply
        '(1 2 3)
        (lambda (c) (list (list a b c)))
        ))))))

(newline)