smalltalk-tng

annotate experiments/monad/general-monad.scm @ 323:454c18798969

find changesets by author, revision, files, or words in the commit message
merger
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
date Tue Feb 07 11:34:20 2012 -0500 (3 months ago)
parents 9e14ff21779b
children
rev   line source
tonyg@68 1 (require (lib "match.ss")
tonyg@84 2 (lib "etc.ss")
tonyg@84 3 (lib "errortrace.ss" "errortrace")
tonyg@88 4 (lib "1.ss" "srfi")
tonyg@68 5 (lib "9.ss" "srfi"))
tonyg@68 6
tonyg@84 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
tonyg@84 8
tonyg@84 9 (print-struct #t)
tonyg@84 10 (define previous-inspector (current-inspector))
tonyg@84 11 (current-inspector (make-inspector))
tonyg@84 12
tonyg@84 13 (define-record-type <monad-class>
tonyg@84 14 (make-monad-class name binder returner failer)
tonyg@84 15 monad-class?
tonyg@84 16 (name monad-class-name)
tonyg@84 17 (binder monad-class-binder)
tonyg@84 18 (returner monad-class-returner)
tonyg@84 19 (failer monad-class-failer))
tonyg@84 20
tonyg@68 21 (define-record-type <monad>
tonyg@68 22 (make-monad kind value)
tonyg@68 23 monad?
tonyg@68 24 (kind monad-kind)
tonyg@68 25 (value monad-value))
tonyg@68 26
tonyg@84 27 (current-inspector previous-inspector)
tonyg@84 28
tonyg@84 29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
tonyg@84 30
tonyg@84 31 (define (determined? m)
tonyg@84 32 (monad-class? (monad-kind m)))
tonyg@84 33
tonyg@84 34 (define (monadize m)
tonyg@84 35 (cond
tonyg@84 36 ((pair? m) (make-monad *list* m))
tonyg@84 37 ((null? m) (make-monad *list* m))
tonyg@94 38 ((monad? m) m)
tonyg@84 39 (else (error "not a monad" m))))
tonyg@84 40
tonyg@68 41 (define (>>= ma a->mb)
tonyg@84 42 (let ((ma (monadize ma)))
tonyg@84 43 (if (determined? ma)
tonyg@84 44 ((monad-class-binder (monad-kind ma)) ma a->mb)
tonyg@84 45 (make-monad '_bind (list ma a->mb)))))
tonyg@68 46
tonyg@68 47 (define (return a)
tonyg@68 48 (make-monad '_return a))
tonyg@68 49
tonyg@84 50 (define (fail s)
tonyg@84 51 (make-monad '_fail s))
tonyg@84 52
tonyg@68 53 (define-syntax mlet*
tonyg@68 54 (syntax-rules ()
tonyg@68 55 ((_ () mexpN) mexpN)
tonyg@68 56 ((_ ((var mexp) rest ...) mexpN)
tonyg@68 57 (>>= mexp (lambda (var) (mlet* (rest ...) mexpN))))))
tonyg@68 58
tonyg@84 59 (define (wrong-mclass mclass m)
tonyg@84 60 (error "wrong monad-class" `((mclass ,mclass) (m ,m))))
tonyg@84 61
tonyg@84 62 (define (determine mclass m)
tonyg@68 63 (let continue ((m m))
tonyg@84 64 (let* ((m (monadize m))
tonyg@84 65 (kind (monad-kind m)))
tonyg@87 66 (if (determined? m)
tonyg@87 67 (if (eq? kind mclass)
tonyg@87 68 m
tonyg@87 69 (wrong-mclass mclass m))
tonyg@87 70 (continue
tonyg@87 71 (case kind
tonyg@87 72 ((_bind) ((monad-class-binder mclass)
tonyg@87 73 (continue (car (monad-value m)))
tonyg@87 74 (cadr (monad-value m))))
tonyg@87 75 ((_return) ((monad-class-returner mclass) (monad-value m)))
tonyg@87 76 ((_fail) ((monad-class-failer mclass) (monad-value m)))
tonyg@87 77 (else
tonyg@87 78 (error "invalid monad-kind" m))))))))
tonyg@68 79
tonyg@84 80 (define (monad-arg mclass)
tonyg@87 81 (lambda (m) (monad-value (determine mclass m))))
tonyg@68 82
tonyg@84 83 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
tonyg@84 84
tonyg@84 85 (define *list* (make-monad-class 'list
tonyg@84 86 (lambda (L f) (append-map (compose run-list f) (run-list L)))
tonyg@84 87 (lambda (x) (list x))
tonyg@84 88 (lambda (s) '())))
tonyg@84 89
tonyg@87 90 (define run-list (monad-arg *list*))
tonyg@84 91
tonyg@84 92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
tonyg@84 93
tonyg@84 94 (define *io* (make-monad-class 'io
tonyg@94 95 (lambda (io1 f) (make-monad *io* (cons (io-action io1) f)))
tonyg@84 96 (lambda (v) (make-monad *io* (lambda () v)))
tonyg@84 97 error))
tonyg@84 98
tonyg@84 99 (define io-action (monad-arg *io*))
tonyg@84 100
tonyg@84 101 (define (run-io m)
tonyg@94 102 (let run-action ((action (io-action m)))
tonyg@94 103 (if (pair? action)
tonyg@94 104 (let ((previous-action (car action))
tonyg@94 105 (continuation (cdr action)))
tonyg@94 106 (run-io (continuation (run-action previous-action))))
tonyg@94 107 (action))))
tonyg@68 108
tonyg@68 109 (define (mdisplay x)
tonyg@84 110 (make-monad *io* (lambda () (display x) 'done)))
tonyg@68 111
tonyg@69 112 (define mread
tonyg@84 113 (make-monad *io* (lambda () (read))))
tonyg@69 114
tonyg@84 115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
tonyg@68 116
tonyg@84 117 (define *state* (make-monad-class 'state
tonyg@84 118 (lambda (st1 f)
tonyg@84 119 (make-monad *state*
tonyg@84 120 (lambda (s0)
tonyg@87 121 (let* ((inp (run-st st1 s0))
tonyg@84 122 (v (car inp))
tonyg@84 123 (s1 (cdr inp)))
tonyg@84 124 (run-st (f v) s1)))))
tonyg@84 125 (lambda (a)
tonyg@84 126 (make-monad *state*
tonyg@84 127 (lambda (s0) (cons a s0))))
tonyg@84 128 error))
tonyg@84 129
tonyg@84 130 (define state-xformer (monad-arg *state*))
tonyg@84 131
tonyg@84 132 (define (run-st m initial)
tonyg@87 133 ((state-xformer m) initial))
tonyg@68 134
tonyg@68 135 (define sget
tonyg@84 136 (make-monad *state* (lambda (s0) (cons s0 s0))))
tonyg@68 137
tonyg@68 138 (define (sput a)
tonyg@84 139 (make-monad *state* (lambda (s0) (cons 'unit a))))
tonyg@69 140
tonyg@69 141 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
tonyg@69 142
tonyg@69 143 (define (mixed-monad-demo)
tonyg@69 144 (run-io (mlet* ((_ (mdisplay "Enter a number\n"))
tonyg@69 145 (n mread)
tonyg@69 146 (all-n (return (iota n)))
tonyg@69 147 (_ (mdisplay "Numbers: "))
tonyg@69 148 (_ (mdisplay all-n))
tonyg@69 149 (_ (mdisplay "\n")))
tonyg@69 150 (return 'nothing))))
tonyg@84 151
tonyg@84 152 (define oleg-example-mixed-monad
tonyg@84 153 (mlet* ((_ (mdisplay "Enter a number: "))
tonyg@84 154 (n mread)
tonyg@84 155 (all-n (return (iota n)))
tonyg@84 156 (evens (return (run-list (mlet* ((i all-n))
tonyg@84 157 (if (even? i)
tonyg@84 158 (return i)
tonyg@84 159 (fail "odd"))))))
tonyg@84 160 (_ (mdisplay "Computed "))
tonyg@84 161 (_ (mdisplay (length evens)))
tonyg@84 162 (_ (mdisplay " evens\n")))
tonyg@84 163 (return evens)))