diff options
Diffstat (limited to '')
-rw-r--r-- | monad/writer.scm | 65 |
1 files changed, 33 insertions, 32 deletions
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))) |