(define-module (data writer)
  #:use-module (oop goops)
  #:use-module (ice-9 match)
  #:use-module (data monoid)
  #:use-module (control monad)
  #:export (writer return-writer))

(read-enable 'curly-infix)

(define-class <writer> ()
  (value #:init-keyword #:value)
  (monoid #:init-keyword #:monoid))

(define (writer value context)
  (make <writer>
    #:value value
    #:monoid context))

(define-method (>>= (this <writer>)
                    (proc <procedure>))
  (match this (($ <writer> value monoid)
               (match (proc value)
                 (($ <writer> nval ncontext)
                  (writer nval { monoid <> ncontext }))))))

(define-method (>> (a <writer>)
                   (b <writer>))
  (match a (($ <writer> _ monoid-a)
            (match b (($ <writer> val monoid-b)
                      (writer val (<> monoid-a monoid-b))
                      )))))

(define (return-writer val)
  (writer val ""))

(define-method (write (this <writer>) port)
  (match this (($ <writer> value monoid)
               (format port "[Writer ~s, ~s]" value monoid))))