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.

---
 monad/writer.scm | 65 ++++++++++++++++++++++++++++----------------------------
 1 file changed, 33 insertions(+), 32 deletions(-)

(limited to 'monad')

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)))
-- 
cgit v1.2.3