From f509c70b6064c631c0de1c26ca4272d143188383 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 18 Mar 2019 23:18:12 +0100
Subject: Rewrote writer monad.

---
 gendoc.scm       |  3 ++-
 monad/writer.scm | 65 ++++++++++++++++++++++++++++----------------------------
 tests/test.scm   | 26 +++++++++++++++++++++++
 3 files changed, 61 insertions(+), 33 deletions(-)

diff --git a/gendoc.scm b/gendoc.scm
index f493b42..133ccdf 100755
--- a/gendoc.scm
+++ b/gendoc.scm
@@ -22,6 +22,7 @@
     ((monad optional) "Optional (Maybe) type")
     ((monad state) "State monad")
     ((monad stack) "Stacks implemented on top of the state monad")
+    ((monad writer) "Your classical writer monad")
     ))
 
 (define prolog
@@ -54,4 +55,4 @@
 
 (define (main args)
   (with-output-to-file infile
-    (lambda () (display (stexi->texi stexi-doc-real)))))
+    (lambda () (display (stexi->texi stexi-doc)))))
diff --git a/monad/writer.scm b/monad/writer.scm
index 8be72c2..7036cb9 100644
--- a/monad/writer.scm
+++ b/monad/writer.scm
@@ -1,39 +1,40 @@
+;;; Commentary:
+;; The writer monad creates a context where strings are automatically collected.
+;; This is useful both for logging and output construction.
+;;
+;; The writer monad uses the state monad internally, but it's considered a leak
+;; in the abstraction to access it directly (even though there is nothing
+;; stoping you).
+;;; Code:
+
 (define-module (monad writer)
-  #:use-module (oop goops)
-  #:use-module (ice-9 match)
-  #:use-module (monad monoid) ; ?
   #:use-module (monad)
-  #:export (writer return-writer))
-
-(read-enable 'curly-infix)
-
-(define-class <writer> ()
-  (value #:init-keyword #:value)
-  (monoid #:init-keyword #:monoid))
+  #:use-module (monad state)
+  #:use-module (oop goops)
+  #:re-export (>>)
+  #:export (w return-writer
+              run-writer
+              with-writer))
 
-(define (writer value context)
-  (make <writer>
-    #:value value
-    #:monoid context))
+(define (w str)
+  "writes str to the current writer monad"
+  (modify (lambda (st) (string-append st str))))
 
-(define-method (>>= (this <writer>)
-                    (proc <procedure>))
-  (match this (($ <writer> value monoid)
-               (match (proc value)
-                 (($ <writer> nval ncontext)
-                  (writer nval { monoid <> ncontext }))))))
+(define return-writer return-state)
 
-(define-method (>> (a <writer>)
-                   (b <writer>))
-  (match a (($ <writer> _ monoid-a)
-            (match b (($ <writer> val monoid-b)
-                      (writer val (<> monoid-a monoid-b))
-                      )))))
+(define (run-writer w)
+  "Wrapper around run-state, but inserts an empty string as starting state."
+  (run-state w ""))
 
-;;; TODO replace this
-(define (return-writer val)
-  (writer val ""))
+(define-method (>> (s <string>) other)
+  "A bit of a hack, but this allows strings to be placed directly inside a
+@code{do} block, and have them written to the current writer context."
+  (>> (w s) other))
 
-(define-method (write (this <writer>) port)
-  (match this (($ <writer> value monoid)
-               (format port "[Writer ~s, ~s]" value monoid))))
+(define (with-writer proc . values)
+  "Runs a regular procedure on values, but also logs the call"
+  (do let return = (apply proc values)
+      (format #f "Applied ~s to ~s ⇒ ~s\n"
+              (procedure-name proc)
+              values return)
+      (return-writer return)))
diff --git a/tests/test.scm b/tests/test.scm
index 6ce798e..562c736 100755
--- a/tests/test.scm
+++ b/tests/test.scm
@@ -51,3 +51,29 @@
 
 
 (test-end "state-test")
+
+(test-begin "writer-test")
+
+(use-modules (monad writer))
+
+(test-equal '(10 "HelloWorld")
+  (run-writer
+   (do (w "Hello")
+       (w "World")
+     (return-writer 10))))
+
+(test-equal '(10 "HelloWorld")
+  (run-writer
+   (do "Hello" "World"
+     (return-writer 10))))
+
+(test-equal '(3 "Applied + to (1 2) ⇒ 3\n")
+  (run-writer (with-writer + 1 2)))
+
+(test-equal '(10 "Hello, World")
+  (run-writer
+   (do (string-append "Hello" ", ")
+       "World"
+     (return-writer 10))))
+
+(test-end "writer-test")
-- 
cgit v1.2.3