├── README ├── aux.ss ├── core.ss ├── exceptT.ss ├── idM.ss ├── listM.ss ├── match.ss ├── maybeM.ss ├── readerM-multi.ss ├── readerM.ss ├── readerT.ss ├── stateM-multi.ss ├── stateM.ss └── writerM.ss /README: -------------------------------------------------------------------------------- 1 | scheme-monads: a(nother) monad and monad transformer library written in chez scheme 2 | 3 | Kyle Carter, Spring 2012 4 | 5 | TODO: migrate withM form to parameterize unit, bind, other forms as necessary. -------------------------------------------------------------------------------- /aux.ss: -------------------------------------------------------------------------------- 1 | (library (monad aux) 2 | (export mod-in-list 3 | letp 4 | extend 5 | extend* 6 | make-set) 7 | (import (chezscheme)) 8 | 9 | ; mod-in-list takes a tag, a function, and then a 10 | ; list of tagged values. 11 | ; It modifies the value associated with the tag using the function. 12 | (define mod-in-list 13 | (lambda (t f) 14 | (lambda (ls) 15 | (if (null? ls) '() 16 | (let ((a (car ls)) 17 | (d (cdr ls))) 18 | (if (eq? t (car a)) 19 | (cons (cons (car a) (f (cdr a))) d) 20 | (cons a ((mod-in-list t f) d)))))))) 21 | 22 | ; letp provides match-like pair deconstruction 23 | ; NB: letp has let* semantics between bindings. 24 | (define-syntax letp 25 | (syntax-rules () 26 | ((_ () body ...) (let () body ...)) 27 | ((_ ((b e) rest ...) body ...) 28 | (let-bind b e (letp (rest ...) body ...))))) 29 | 30 | (define-syntax let-bind 31 | (syntax-rules () 32 | ((_ (a . r) e . body) 33 | (let ((t e)) 34 | (letp ((a (car t))) 35 | (let-bind r (cdr t) . body)))) 36 | ((_ () e . body) (let () . body)) 37 | ((_ a e . body) (let ((a e)) . body)))) 38 | 39 | (define extend 40 | (lambda (x) 41 | (lambda (e) 42 | (cons x e)))) 43 | 44 | (define extend* 45 | (lambda (e^) 46 | (lambda (e) 47 | (append e^ e)))) 48 | 49 | (define make-set 50 | (lambda (l) 51 | (cond 52 | ((null? l) '()) 53 | (else 54 | (letp (((a . d) l)) 55 | (cons a (make-set (remq a d)))))))) 56 | 57 | ) -------------------------------------------------------------------------------- /core.ss: -------------------------------------------------------------------------------- 1 | (library (monad core) 2 | (export unit bind mzero mplus lift baseM 3 | current-monad 4 | doM <- == >< 5 | withM 6 | printM 7 | whenM 8 | nopM 9 | mapM 10 | foldM 11 | liftM 12 | define-monad 13 | define-transformer 14 | monad-error 15 | mzero-err 16 | mplus-err 17 | lift-err 18 | mzeroT-err 19 | mplusT-err) 20 | (import (chezscheme) 21 | (monad aux)) 22 | 23 | (define-syntax define-monad-op 24 | (syntax-rules () 25 | ((_ id f) 26 | (define-syntax id 27 | (identifier-syntax 28 | (let ((t (current-monad))) 29 | (if (monad? t) 30 | (f t) 31 | (errorf 'id "monad is undefined")))))))) 32 | 33 | (define-monad-op unit monad-unit) 34 | (define-monad-op bind monad-bind) 35 | (define-monad-op mzero monad-zero) 36 | (define-monad-op mplus monad-plus) 37 | (define-monad-op lift monad-lift) 38 | (define-monad-op baseM monad-base) 39 | 40 | ;(define-syntax unit (identifier-syntax (check-monad monad-unit))) 41 | ;(define-syntax bind (identifier-syntax (check-monad monad-bind))) 42 | ;(define-syntax mzero (identifier-syntax (check-monad monad-zero))) 43 | ;(define-syntax mplus (identifier-syntax (check-monad monad-plus))) 44 | ;(define-syntax lift (identifier-syntax (check-monad monad-lift))) 45 | ;(define-syntax baseM (identifier-syntax (check-monad monad-base))) 46 | 47 | (define-syntax withM 48 | (syntax-rules () 49 | ((_ m b b* ...) 50 | (parameterize ((current-monad m)) 51 | (begin 52 | b b* ...))))) 53 | 54 | (define monad-error 55 | (lambda (t) 56 | (lambda args 57 | (errorf t "undefined")))) 58 | 59 | (define current-monad (make-parameter 'dummy)) 60 | 61 | (define printM 62 | (lambda (fst . more) 63 | (if (null? more) 64 | (begin 65 | (pretty-print fst) 66 | (nopM)) 67 | (begin 68 | (printf "~a" fst) 69 | (let loop ((more more)) 70 | (cond 71 | ((null? more) (begin (newline) (nopM))) 72 | (else 73 | (begin 74 | (printf " ~a" (car more)) 75 | (loop (cdr more) ))))))))) 76 | 77 | (define-syntax whenM 78 | (syntax-rules () 79 | ((_ t e) 80 | (if t e (nopM))))) 81 | 82 | (define nopM 83 | (lambda () 84 | (unit '_))) 85 | 86 | ;; do macro, extended with: 87 | ;; >< operator for cata like binding 88 | ;; == operator for simple aliasing 89 | ;; monadic bind w/o result (>>) 90 | ;; list binding and aliasing 91 | (define-syntax doM 92 | (syntax-rules (<- == ><) 93 | ;; base case 94 | ((_ e) e) 95 | ;; bind (with pair/list deconstruction) 96 | ((_ (v <- e) e* e** ...) 97 | (bind e (lambda (x) (letp ((v x)) (doM e* e** ...))))) 98 | ;; alias (with pair/list deconstruction) 99 | ((_ (v == e) e* e** ...) 100 | (letp ((v e)) (doM e* e** ...))) 101 | ;; transform and rebind 102 | ((_ (v >< f) e* e** ...) 103 | (bind (f v) (lambda (v) (doM e* e** ...)))) 104 | ;; bind hukarz 105 | ((_ e e* e** ...) 106 | (bind e (lambda (_) (doM e* e** ...)))))) 107 | 108 | (define-syntax (<- x) 109 | (syntax-violation #f "misplaced aux keyword" x)) 110 | 111 | (define-syntax (== x) 112 | (syntax-violation #f "misplaced aux keyword" x)) 113 | 114 | (define-syntax (>< x) 115 | (syntax-violation #f "misplaced aux keyword" x)) 116 | 117 | ;; mapM maps a potentially effectual function over a list 118 | (define mapM 119 | (lambda (f) 120 | (lambda (first . rest) 121 | (if (null? rest) 122 | (let mapM1 ((a* first)) 123 | (cond 124 | ((null? a*) (unit '())) 125 | (else 126 | (doM (a <- (f (car a*))) 127 | (d <- (mapM1 (cdr a*))) 128 | (unit (cons a d)))))) 129 | (let mapM-more ((a* first) (more rest)) 130 | (cond 131 | ((and (null? a*) (for-all null? more)) 132 | (unit '())) 133 | ((find null? more) => 134 | (lambda (bad) 135 | (errorf 'mapM "lists ~a and ~a differ in length" first bad))) 136 | (else 137 | (doM (a <- (apply f (car a*) (map car more))) 138 | (d <- (mapM-more (cdr a*) (map cdr more))) 139 | (unit (cons a d)))))))))) 140 | 141 | (define foldM 142 | (lambda (f a) 143 | (lambda (first . rest) 144 | (if (null? rest) 145 | (let foldM1 ((a a) (a* first)) 146 | (cond 147 | ((null? a*) (unit a)) 148 | (else 149 | (doM (a <- (f a (car a*))) 150 | (foldM1 a (cdr a*)))))) 151 | (let foldM-more ((a a) (a* first) (more rest)) 152 | (cond 153 | ((and (null? a*) (for-all null? more)) 154 | (unit a)) 155 | ((find null? more) => 156 | (lambda (bad) 157 | (error 'foldM "lists ~a and ~a differ in length" first bad))) 158 | (else 159 | (doM (a <- (apply f a (car a*) (map car more))) 160 | (foldM-more a (cdr a*) (map cdr more)))))))))) 161 | 162 | (define liftM 163 | (lambda (f) 164 | (lambda args 165 | (doM (args >< (lambda (x) x)) 166 | (unit (apply f args)))))) 167 | 168 | (define-record monad (unit bind zero plus lift base)) 169 | 170 | (define-syntax define-monad 171 | (syntax-rules () 172 | ((_ id u b z p l) 173 | (define id 174 | (make-monad u b z p l base-err))))) 175 | 176 | (define-syntax define-transformer 177 | (syntax-rules () 178 | ((_ id u b z p l) 179 | (define id 180 | (lambda (m) 181 | (withM m 182 | (make-monad 183 | (u unit bind) 184 | (b unit bind) 185 | (z unit bind) 186 | (p unit bind) 187 | (l unit bind) 188 | (lambda () m)))))))) 189 | 190 | (define mzero-err (monad-error 'mzero)) 191 | (define mplus-err (monad-error 'mplus)) 192 | (define lift-err (monad-error 'lift)) 193 | (define base-err (monad-error 'baseM)) 194 | 195 | (define mzeroT-err (lambda (u b) mzero-err)) 196 | (define mplusT-err (lambda (u b) mplus-err)) 197 | 198 | ) -------------------------------------------------------------------------------- /exceptT.ss: -------------------------------------------------------------------------------- 1 | (library (monad exceptT) 2 | (export exceptT 3 | unit-exceptT 4 | bind-exceptT 5 | bind-except 6 | lift-exceptT 7 | zero-exceptT 8 | try/catch) 9 | (import (chezscheme) 10 | (monad core) 11 | (monad aux)) 12 | 13 | ;; Maybe monad transformer with failure message 14 | ;; Also equivalent to Either monad 15 | 16 | (define unit-exceptT 17 | (lambda (unit bind) 18 | (lambda (a) 19 | (unit `(Success . ,a))))) 20 | 21 | (define bind-exceptT 22 | (lambda (unit bind) 23 | (lambda (m f) 24 | (bind m (lambda (x) 25 | (letp (((t . a) x)) 26 | (case t 27 | ((Success) (f a)) 28 | ((Exception) (unit `(Exception . ,a)))))))))) 29 | 30 | (define bind-except 31 | (lambda (m f) 32 | (letp (((t . a) m)) 33 | (case t 34 | ((Success) (f a)) 35 | ((Exception) `(Exception . ,a)))))) 36 | 37 | (define zero-exceptT 38 | (lambda (unit bind) 39 | (lambda (mes) 40 | (unit `(Exception . ,mes))))) 41 | 42 | (define lift-exceptT 43 | (lambda (unit bind) 44 | (lambda (m) 45 | (bind m (lambda (a) 46 | (unit `(Success . ,a))))))) 47 | 48 | (define try/catch 49 | (lambda (m f) 50 | (letp (((t . a) m)) 51 | (case t 52 | ((Success) a) 53 | ((Exception) (f a)))))) 54 | 55 | (define-transformer exceptT 56 | unit-exceptT 57 | bind-exceptT 58 | zero-exceptT 59 | mplusT-err 60 | lift-exceptT) 61 | 62 | ) -------------------------------------------------------------------------------- /idM.ss: -------------------------------------------------------------------------------- 1 | (library (monad idM) 2 | (export idM 3 | unit-id 4 | bind-id) 5 | (import (chezscheme) 6 | (monad core)) 7 | 8 | (define unit-id 9 | (lambda (a) a)) 10 | 11 | (define bind-id 12 | (lambda (m f) (f m))) 13 | 14 | (define-monad idM 15 | unit-id 16 | bind-id 17 | mzero-err 18 | mplus-err 19 | lift-err) 20 | 21 | ) -------------------------------------------------------------------------------- /listM.ss: -------------------------------------------------------------------------------- 1 | (library (monad listM) 2 | (export listM 3 | unit-list 4 | bind-list 5 | mzero-list 6 | mplus-list 7 | guard-list) 8 | (import (chezscheme) 9 | (monad core) 10 | (monad aux)) 11 | 12 | (define unit-list 13 | (lambda (a) 14 | `(,a))) 15 | 16 | (define bind-list 17 | (lambda (m f) 18 | (mapcan f m))) 19 | 20 | (define mapcan 21 | (lambda (f ls) 22 | (if (null? ls) '() 23 | (letp (((a . d) ls)) 24 | (mplus-list (f a) (mapcan f d)))))) 25 | 26 | (define mzero-list 27 | (lambda () 28 | '())) 29 | 30 | (define mplus-list 31 | (lambda (m1 m2) 32 | (append m1 m2))) 33 | 34 | (define guard-list 35 | (lambda (t) 36 | (if t (unit-list '_) (mzero-list)))) 37 | 38 | (define-monad listM 39 | unit-list 40 | bind-list 41 | mzero-list 42 | mplus-list 43 | lift-err) 44 | 45 | ) -------------------------------------------------------------------------------- /match.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2000-2008 Dan Friedman, Erik Hilsdale, and Kent Dybvig 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation files 5 | ;;; (the "Software"), to deal in the Software without restriction, 6 | ;;; including without limitation the rights to use, copy, modify, merge, 7 | ;;; publish, distribute, sublicense, and/or sell copies of the Software, 8 | ;;; and to permit persons to whom the Software is furnished to do so, 9 | ;;; subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 18 | ;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 19 | ;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | ;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;;; SOFTWARE. 22 | 23 | ;;; This program was originally designed and implemented by Dan Friedman. 24 | ;;; It was redesigned and reimplemented by Erik Hilsdale. Additional 25 | ;;; modifications were made by Kent Dybvig, Steve Ganz, and Aziz Ghuloum. 26 | ;;; Parts of the implementation were adapted from the portable syntax-case 27 | ;;; implementation written by Kent Dybvig, Oscar Waddell, Bob Hieb, and 28 | ;;; Carl Bruggeman and is used by permission of Cadence Research Systems. 29 | 30 | ;;; A change log appears at end of this file. 31 | 32 | ;;; A brief description of match is given at: 33 | 34 | ;;; http://www.cs.indiana.edu/chezscheme/match/ 35 | 36 | ;;; ============================================================ 37 | 38 | ;; Exp ::= (match Exp Clause) 39 | ;; || (trace-match Exp Clause) 40 | ;; || (match+ (Id*) Exp Clause*) 41 | ;; || (trace-match+ (Id*) Exp Clause*) 42 | ;; || OtherSchemeExp 43 | 44 | ;; Clause ::= (Pat Exp+) || (Pat (guard Exp*) Exp+) 45 | 46 | ;; Pat ::= (Pat ... . Pat) 47 | ;; || (Pat . Pat) 48 | ;; || () 49 | ;; || #(Pat* Pat ... Pat*) 50 | ;; || #(Pat*) 51 | ;; || ,Id 52 | ;; || ,[Id*] 53 | ;; || ,[Cata -> Id*] 54 | ;; || Id 55 | 56 | ;; Cata ::= Exp 57 | 58 | ;; YOU'RE NOT ALLOWED TO REFER TO CATA VARS IN GUARDS. (reasonable!) 59 | 60 | #!chezscheme 61 | (library (monad match) 62 | (export 63 | match match+ trace-match trace-match+ match-equality-test 64 | with-ellipsis-aware-quasiquote 65 | guard unquote ->) 66 | (import (chezscheme)) 67 | 68 | (define-syntax (-> x) 69 | (syntax-violation #f "misplaced aux keyword" x)) 70 | 71 | (define match-equality-test 72 | (make-parameter 73 | equal? 74 | (lambda (x) 75 | (unless (procedure? x) 76 | (errorf 'match-equality-test "~s is not a procedure" x)) 77 | x))) 78 | 79 | (define-syntax match+ 80 | (lambda (x) 81 | (syntax-case x () 82 | [(k (ThreadedId ...) Exp Clause ...) 83 | #'(let f ((ThreadedId ThreadedId) ... (x Exp)) 84 | (match-help k f x (ThreadedId ...) Clause ...))]))) 85 | 86 | (define-syntax match 87 | (lambda (x) 88 | (syntax-case x () 89 | [(k Exp Clause ...) 90 | #'(let f ((x Exp)) 91 | (match-help k f x () Clause ...))]))) 92 | 93 | (define-syntax trace-match+ 94 | (lambda (x) 95 | (syntax-case x () 96 | [(k (ThreadedId ...) Name Exp Clause ...) 97 | #'(letrec ((f (trace-lambda Name (ThreadedId ... x) 98 | (match-help k f x (ThreadedId ...) Clause ...)))) 99 | (f ThreadedId ... x))]))) 100 | 101 | (define-syntax trace-match 102 | (lambda (x) 103 | (syntax-case x () 104 | [(k Name Exp Clause ...) 105 | #'(letrec ((f (trace-lambda Name (x) 106 | (match-help k f x () Clause ...)))) 107 | (f Exp))]))) 108 | 109 | ;;; ------------------------------ 110 | 111 | (define-syntax let-values** 112 | (syntax-rules () 113 | ((_ () B0 B ...) (begin B0 B ...)) 114 | ((_ ((Formals Exp) Rest ...) B0 B ...) 115 | (let-values** (Rest ...) 116 | (call-with-values (lambda () Exp) 117 | (lambda Formals B0 B ...)))))) 118 | 119 | (define-syntax match-help 120 | (lambda (x) 121 | (syntax-case x () 122 | ((_ Template Cata Obj ThreadedIds) 123 | #'(errorf 'match "Unmatched datum: ~s" Obj)) 124 | ((_ Template Cata Obj ThreadedIds (Pat B0 B ...) Rest ...) 125 | #'(convert-pat Pat 126 | (match-help1 Template Cata Obj ThreadedIds 127 | (B0 B ...) 128 | Rest ...))) 129 | ((_ Template Cata Obj ThreadedIds cls Rest ...) 130 | (syntax-error #'cls "invalid match clause"))))) 131 | 132 | 133 | (define-syntax match-help1 134 | (lambda (x) 135 | (syntax-case x (guard) 136 | [(_ PatLit Vars () Cdecls Template Cata Obj ThreadedIds 137 | ((guard) B0 B ...) Rest ...) 138 | #'(let ((ls/false (sexp-dispatch Obj PatLit))) 139 | (if ls/false 140 | (apply (lambda Vars 141 | (clause-body Cata Cdecls ThreadedIds 142 | (extend-backquote Template B0 B ...))) 143 | ls/false) 144 | (match-help Template Cata Obj ThreadedIds Rest ...)))] 145 | [(_ PatLit Vars (PG ...) Cdecls Template Cata Obj ThreadedIds 146 | ((guard G ...) B0 B ...) Rest ...) 147 | #'(let ((ls/false (sexp-dispatch Obj PatLit))) 148 | (if (and ls/false (apply (lambda Vars 149 | (guard-body Cdecls 150 | (extend-backquote Template 151 | (and PG ... G ...)))) 152 | ls/false)) 153 | (apply (lambda Vars 154 | (clause-body Cata Cdecls ThreadedIds 155 | (extend-backquote Template B0 B ...))) 156 | ls/false) 157 | (match-help Template Cata Obj ThreadedIds Rest ...)))] 158 | [(_ PatLit Vars (PG ...) Cdecls Template Cata Obj ThreadedIds 159 | (B0 B ...) Rest ...) 160 | #'(match-help1 PatLit Vars (PG ...) Cdecls Template Cata Obj ThreadedIds 161 | ((guard) B0 B ...) Rest ...)]))) 162 | 163 | (define-syntax clause-body 164 | (lambda (x) 165 | (define build-mapper 166 | (lambda (vars depth cata tIds) 167 | (if (zero? depth) 168 | cata 169 | (with-syntax ((rest (build-mapper vars (- depth 1) cata tIds)) 170 | (vars vars) 171 | (tIds tIds)) 172 | #'(mapper rest vars tIds))))) 173 | (syntax-case x () 174 | ((_ Cata ((CVar CDepth CMyCata CFormal ...) ...) (ThreadedId ...) B) 175 | (with-syntax (((Mapper ...) 176 | (map (lambda (mycata formals depth) 177 | (build-mapper formals 178 | (syntax->datum depth) 179 | (syntax-case mycata () 180 | [#f #'Cata] 181 | [exp #'exp]) 182 | #'(ThreadedId ...))) 183 | #'(CMyCata ...) 184 | #'((CFormal ...) ...) 185 | #'(CDepth ...)))) 186 | #'(let-values** (([ThreadedId ... CFormal ...] 187 | (Mapper ThreadedId ... CVar)) 188 | ...) 189 | B)))))) 190 | 191 | (define-syntax guard-body 192 | (lambda (x) 193 | (syntax-case x () 194 | ((_ ((Cvar Cdepth MyCata Cformal ...) ...) B) 195 | (with-syntax (((CF ...) (apply append #'((Cformal ...) ...)))) 196 | #'(let-syntax 197 | ((CF 198 | (lambda (x) 199 | (syntax-case x () 200 | (Name 201 | (syntax-error #'Name 202 | "guard cannot refer to return-value variable"))))) 203 | ...) 204 | B)))))) 205 | 206 | (define-syntax convert-pat 207 | ;; returns sexp-pat x vars x guards x cdecls 208 | (let () 209 | (define ellipsis? 210 | (lambda (x) 211 | (and (identifier? x) (free-identifier=? x #'(... ...))))) 212 | (define Var? 213 | (lambda (x) 214 | (syntax-case x (->) 215 | [-> #f] 216 | [id (identifier? #'id)]))) 217 | (define fVar 218 | (lambda (var vars guards) 219 | (let loop ([ls vars]) 220 | (if (null? ls) 221 | (values (cons var vars) guards) 222 | (if (bound-identifier=? var (car ls)) 223 | (with-syntax ([(tmp) (generate-temporaries (list var))] 224 | [var (car ls)]) 225 | (values (cons #'tmp vars) 226 | (cons #'((match-equality-test) tmp var) guards))) 227 | (loop (cdr ls))))))) 228 | (define (f syn vars guards cdecls depth) 229 | (syntax-case syn (unquote) 230 | ((unquote . stuff) ; separate for better error detection 231 | (syntax-case syn (unquote ->) 232 | ((unquote [MyCata -> Var ...]) 233 | (andmap Var? #'(Var ...)) 234 | (with-syntax (((Temp) (generate-temporaries '(x))) 235 | (Depth depth)) 236 | (values #'any 237 | (cons #'Temp vars) 238 | guards 239 | (cons #'[Temp Depth MyCata Var ...] cdecls)))) 240 | ((unquote [Var ...]) 241 | (andmap Var? #'(Var ...)) 242 | (with-syntax (((Temp) (generate-temporaries '(x))) 243 | (Depth depth)) 244 | (values #'any 245 | (cons #'Temp vars) 246 | guards 247 | (cons #'[Temp Depth #f Var ...] cdecls)))) 248 | ((unquote Var) 249 | (Var? #'Var) 250 | (let-synvalues* ([(vars guards) (fVar #'Var vars guards)]) 251 | (values #'any #'vars #'guards cdecls))))) 252 | (((unquote . stuff) Dots) 253 | (ellipsis? #'Dots) 254 | (syntax-case syn (unquote ->) 255 | (((unquote [MyCata -> Var ...]) Dots) 256 | (andmap Var? #'(Var ...)) 257 | (with-syntax (((Temp) (generate-temporaries '(x))) 258 | (Depth+1 (add1 depth))) 259 | (values #'each-any 260 | (cons #'Temp vars) 261 | guards 262 | (cons #'[Temp Depth+1 MyCata Var ...] cdecls)))) 263 | (((unquote [Var ...]) Dots) 264 | (andmap Var? #'(Var ...)) 265 | (with-syntax (((Temp) (generate-temporaries '(x))) 266 | (Depth+1 (add1 depth))) 267 | (values #'each-any 268 | (cons #'Temp vars) 269 | guards 270 | (cons #'[Temp Depth+1 #f Var ...] cdecls)))) 271 | (((unquote Var) Dots) 272 | (Var? #'Var) 273 | (let-synvalues* ([(vars guards) (fVar #'Var vars guards)]) 274 | (values #'each-any #'vars #'guards cdecls))) 275 | ((expr Dots) (syntax-error #'expr "match-pattern unquote syntax")))) 276 | ((Pat Dots) 277 | (ellipsis? #'Dots) 278 | (let-synvalues* (((Dpat Dvars Dguards Dcdecls) 279 | (f #'Pat vars guards cdecls (add1 depth)))) 280 | (with-syntax ((Size (- (length #'Dvars) (length vars)))) 281 | (values #'#(each Dpat Size) #'Dvars #'Dguards #'Dcdecls)))) 282 | ((Pat Dots . Rest) 283 | (ellipsis? #'Dots) 284 | (let-synvalues* (((Rpat Rvars Rguards Rcdecls) 285 | (f #'Rest vars guards cdecls depth)) 286 | ((Dpat Dvars Dguards Dcdecls) 287 | (f #'(Pat (... ...)) #'Rvars #'Rguards #'Rcdecls 288 | depth))) 289 | (with-syntax ((Size (- (length #'Dvars) (length #'Rvars))) 290 | ((RevRestTl . RevRest) (reverseX #'Rpat '()))) 291 | (values #'#(tail-each Dpat Size RevRest RevRestTl) 292 | #'Dvars #'Dguards #'Dcdecls)))) 293 | ((X . Y) 294 | (let-synvalues* (((Ypat Yvars Yguards Ycdecls) 295 | (f #'Y vars guards cdecls depth)) 296 | ((Xpat Xvars Xguards Xcdecls) 297 | (f #'X #'Yvars #'Yguards #'Ycdecls depth))) 298 | (values #'(Xpat . Ypat) #'Xvars #'Xguards #'Xcdecls))) 299 | (() (values #'() vars guards cdecls)) 300 | (#(X ...) 301 | (let-synvalues* (((Pat Vars Eqvars Cdecls) 302 | (f #'(X ...) vars guards cdecls depth))) 303 | (values #'#(vector Pat) #'Vars #'Eqvars #'Cdecls))) 304 | (Thing (values #'#(atom Thing) vars guards cdecls)))) 305 | (define reverseX 306 | (lambda (ls acc) 307 | (if (pair? ls) 308 | (reverseX (cdr ls) (cons (car ls) acc)) 309 | (cons ls acc)))) 310 | (define-syntax let-synvalues* 311 | (syntax-rules () 312 | ((_ () B0 B ...) (begin B0 B ...)) 313 | ((_ (((Formal ...) Exp) Decl ...) B0 B ...) 314 | (call-with-values (lambda () Exp) 315 | (lambda (Formal ...) 316 | (with-syntax ((Formal Formal) ...) 317 | (let-synvalues* (Decl ...) B0 B ...))))))) 318 | (lambda (syn) 319 | (syntax-case syn () 320 | ((_ syn (kh . kt)) 321 | (let-synvalues* (((Pat Vars Guards Cdecls) (f #'syn '() '() '() 0))) 322 | #'(kh 'Pat Vars Guards Cdecls . kt))))))) 323 | 324 | (define-syntax mapper 325 | (lambda (x) 326 | (syntax-case x () 327 | ((_ F (RetId ...) (ThreadId ...)) 328 | (with-syntax (((t ...) (generate-temporaries #'(RetId ...))) 329 | ((ts ...) (generate-temporaries #'(RetId ...))) 330 | ((null ...) (map (lambda (x) #''()) #'(RetId ...)))) 331 | #'(let ((fun F)) 332 | (rec g 333 | (lambda (ThreadId ... ls) 334 | (if (null? ls) 335 | (values ThreadId ... null ...) 336 | (call-with-values 337 | (lambda () (g ThreadId ... (cdr ls))) 338 | (lambda (ThreadId ... ts ...) 339 | (call-with-values 340 | (lambda () (fun ThreadId ... (car ls))) 341 | (lambda (ThreadId ... t ...) 342 | (values ThreadId ... (cons t ts) ...)))))))))))))) 343 | 344 | ;;; ------------------------------ 345 | 346 | (define-syntax my-backquote 347 | (lambda (x) 348 | (define ellipsis? 349 | (lambda (x) 350 | (and (identifier? x) (free-identifier=? x #'(... ...))))) 351 | (define-syntax with-values 352 | (syntax-rules () 353 | ((_ P C) (call-with-values (lambda () P) C)))) 354 | (define-syntax syntax-lambda 355 | (lambda (x) 356 | (syntax-case x () 357 | ((_ (Pat ...) Body0 Body ...) 358 | (with-syntax (((X ...) (generate-temporaries #'(Pat ...)))) 359 | #'(lambda (X ...) 360 | (with-syntax ((Pat X) ...) 361 | Body0 Body ...))))))) 362 | (define-syntax with-temp 363 | (syntax-rules () 364 | ((_ V Body0 Body ...) 365 | (with-syntax (((V) (generate-temporaries '(x)))) 366 | Body0 Body ...)))) 367 | (define-syntax with-temps 368 | (syntax-rules () 369 | ((_ (V ...) (Exp ...) Body0 Body ...) 370 | (with-syntax (((V ...) (generate-temporaries #'(Exp ...)))) 371 | Body0 Body ...)))) 372 | (define destruct 373 | (lambda (Orig x depth) 374 | (syntax-case x (quasiquote unquote unquote-splicing) 375 | ;; inner quasiquote 376 | ((Exp dots1 dots2 . Rest) 377 | (and (zero? depth) (ellipsis? #'dots1) (ellipsis? #'dots2)) 378 | (let f ([Exp #'(... ((Exp ...) ...))] [Rest #'Rest] [ndots 2]) 379 | (syntax-case Rest () 380 | [(dots . Rest) 381 | (ellipsis? #'dots) 382 | (with-syntax ([Exp Exp]) 383 | (f #'(... (Exp ...)) #'Rest (+ ndots 1)))] 384 | [Rest 385 | (with-values (destruct Orig Exp depth) 386 | (syntax-lambda (ExpBuilder (ExpVar ...) (ExpExp ...)) 387 | (if (null? #'(ExpVar ...)) 388 | (syntax-error Orig "Bad ellipsis") 389 | (with-values (destruct Orig #'Rest depth) 390 | (syntax-lambda (RestBuilder RestVars RestExps) 391 | (values 392 | #`(append 393 | #,(let f ([ndots ndots]) 394 | (if (= ndots 1) 395 | #'ExpBuilder 396 | #`(apply append #,(f (- ndots 1))))) 397 | RestBuilder) 398 | (append #'(ExpVar ...) #'RestVars) 399 | (append #'(ExpExp ...) #'RestExps)))))))]))) 400 | ((quasiquote Exp) 401 | (with-values (destruct Orig #'Exp (add1 depth)) 402 | (syntax-lambda (Builder Vars Exps) 403 | (if (null? #'Vars) 404 | (values #''(quasiquote Exp) '() '()) 405 | (values #'(list 'quasiquote Builder) #'Vars #'Exps))))) 406 | ;; unquote 407 | ((unquote Exp) 408 | (zero? depth) 409 | (with-temp X 410 | (values #'X (list #'X) (list #'Exp)))) 411 | ((unquote Exp) 412 | (with-values (destruct Orig #'Exp (sub1 depth)) 413 | (syntax-lambda (Builder Vars Exps) 414 | (if (null? #'Vars) 415 | (values #''(unquote Exp) '() '()) 416 | (values #'(list 'unquote Builder) #'Vars #'Exps))))) 417 | ;; splicing 418 | (((unquote-splicing Exp)) 419 | (zero? depth) 420 | (with-temp X 421 | (values #'X (list #'X) (list #'Exp)))) 422 | (((unquote-splicing Exp ...)) 423 | (zero? depth) 424 | (with-temps (X ...) (Exp ...) 425 | (values #'(append X ...) #'(X ...) #'(Exp ...)))) 426 | (((unquote-splicing Exp ...) . Rest) 427 | (zero? depth) 428 | (with-values (destruct Orig #'Rest depth) 429 | (syntax-lambda (Builder Vars Exps) 430 | (with-temps (X ...) (Exp ...) 431 | (if (null? #'Vars) 432 | (values #'(append X ... 'Rest) 433 | #'(X ...) #'(Exp ...)) 434 | (values #'(append X ... Builder) 435 | #'(X ... . Vars) #'(Exp ... . Exps))))))) 436 | ((unquote-splicing Exp ...) 437 | (with-values (destruct Orig #'(Exp ...) (sub1 depth)) 438 | (syntax-lambda (Builder Vars Exps) 439 | (if (null? #'Vars) 440 | (values #''(unquote-splicing Exp ...) '() '()) 441 | (values #'(cons 'unquote-splicing Builder) 442 | #'Vars #'Exps))))) 443 | ;; dots 444 | (((unquote Exp) Dots) 445 | (and (zero? depth) (ellipsis? #'Dots)) 446 | (with-temp X 447 | (values #'X (list #'X) (list #'Exp)))) 448 | (((unquote Exp) Dots . Rest) 449 | (and (zero? depth) (ellipsis? #'Dots)) 450 | (with-values (destruct Orig #'Rest depth) 451 | (syntax-lambda (RestBuilder RestVars RestExps) 452 | (with-syntax ((TailExp 453 | (if (null? #'RestVars) 454 | #''Rest 455 | #'RestBuilder))) 456 | (with-temp X 457 | (values #'(append X TailExp) 458 | (cons #'X #'RestVars) 459 | (cons #'Exp #'RestExps))))))) 460 | ((Exp Dots . Rest) 461 | (and (zero? depth) (ellipsis? #'Dots)) 462 | (with-values (destruct Orig #'Exp depth) 463 | (syntax-lambda (ExpBuilder (ExpVar ...) (ExpExp ...)) 464 | (if (null? #'(ExpVar ...)) 465 | (syntax-error Orig "Bad ellipsis") 466 | (with-values (destruct Orig #'Rest depth) 467 | (syntax-lambda (RestBuilder RestVars RestExps) 468 | (with-syntax ((TailExp 469 | (if (null? #'RestVars) 470 | #''Rest 471 | #'RestBuilder)) 472 | (Orig Orig)) 473 | (values #'(let f ((ExpVar ExpVar) ...) 474 | (if (and (pair? ExpVar) ...) 475 | (cons 476 | (let ((ExpVar (car ExpVar)) ...) 477 | ExpBuilder) 478 | (f (cdr ExpVar) ...)) 479 | (if (and (null? ExpVar) ...) 480 | TailExp 481 | (errorf 'unquote 482 | "Mismatched lists in ~s" 483 | Orig)))) 484 | (append #'(ExpVar ...) #'RestVars) 485 | (append #'(ExpExp ...) #'RestExps))))))))) 486 | ;; Vectors 487 | (#(X ...) 488 | (with-values (destruct Orig #'(X ...) depth) 489 | (syntax-lambda (LsBuilder LsVars LsExps) 490 | (values #'(list->vector LsBuilder) #'LsVars #'LsExps)))) 491 | ;; random stuff 492 | ((Hd . Tl) 493 | (with-values (destruct Orig #'Hd depth) 494 | (syntax-lambda (HdBuilder HdVars HdExps) 495 | (with-values (destruct Orig #'Tl depth) 496 | (syntax-lambda (TlBuilder TlVars TlExps) 497 | (with-syntax ((Hd (if (null? #'HdVars) 498 | #''Hd 499 | #'HdBuilder)) 500 | (Tl (if (null? #'TlVars) 501 | #''Tl 502 | #'TlBuilder))) 503 | (values #'(cons Hd Tl) 504 | (append #'HdVars #'TlVars) 505 | (append #'HdExps #'TlExps)))))))) 506 | (OtherThing 507 | (values #''OtherThing '() '()))))) 508 | ;; macro begins 509 | (syntax-case x () 510 | ((_ Datum) 511 | (with-values (destruct #'(quasiquote Datum) #'Datum 0) 512 | (syntax-lambda (Builder (Var ...) (Exp ...)) 513 | (if (null? #'(Var ...)) 514 | #''Datum 515 | #'(let ((Var Exp) ...) 516 | Builder)))))))) 517 | 518 | (define-syntax extend-backquote 519 | (lambda (x) 520 | (syntax-case x () 521 | [(_ Template Exp ...) 522 | (with-syntax ([quasiquote (datum->syntax #'Template 'quasiquote)]) 523 | #'(let-syntax ([quasiquote 524 | (lambda (x) 525 | (syntax-case x () 526 | ((_ Foo) #'(my-backquote Foo))))]) 527 | Exp ...))]))) 528 | 529 | (define-syntax with-ellipsis-aware-quasiquote 530 | (lambda (x) 531 | (syntax-case x () 532 | [(k b1 b2 ...) 533 | (with-implicit (k quasiquote) 534 | #'(let-syntax ([quasiquote 535 | (lambda (x) 536 | (syntax-case x () 537 | ((_ e) #'(my-backquote e))))]) 538 | (let () b1 b2 ...)))]))) 539 | 540 | ;;; ------------------------------ 541 | 542 | (define-syntax with-values 543 | (syntax-rules () 544 | ((_ P C) (call-with-values (lambda () P) C)))) 545 | 546 | (define-syntax letcc 547 | (syntax-rules () 548 | ((_ V B0 B ...) (call/cc (lambda (V) B0 B ...))))) 549 | 550 | (define classify-list 551 | (lambda (ls) 552 | (cond 553 | ((null? ls) 'proper) 554 | ((not (pair? ls)) 'improper) 555 | (else 556 | (let f ((tortoise ls) (hare (cdr ls))) 557 | (cond 558 | ((eq? tortoise hare) 'infinite) 559 | ((null? hare) 'proper) 560 | ((not (pair? hare)) 'improper) 561 | (else 562 | (let ((hare (cdr hare))) 563 | (cond 564 | ((null? hare) 'proper) 565 | ((not (pair? hare)) 'improper) 566 | (else (f (cdr ls) (cdr hare)))))))))))) 567 | 568 | (define ilist-copy-flat 569 | (lambda (ils) 570 | (let f ((tortoise ils) (hare (cdr ils))) 571 | (if (eq? tortoise hare) 572 | (list (car tortoise)) 573 | (cons (car tortoise) (f (cdr tortoise) (cddr hare))))))) 574 | 575 | (define sexp-dispatch 576 | (lambda (obj pat);; #f or list of vars 577 | (letcc escape 578 | (let ((fail (lambda () (escape #f)))) 579 | (let f ((pat pat) (obj obj) (vals '())) 580 | (cond 581 | ((eq? pat 'any) 582 | (cons obj vals)) 583 | ((eq? pat 'each-any) 584 | ;; handle infinities 585 | (case (classify-list obj) 586 | ((proper infinite) (cons obj vals)) 587 | ((improper) (fail)))) 588 | ((pair? pat) 589 | (if (pair? obj) 590 | (f (car pat) (car obj) (f (cdr pat) (cdr obj) vals)) 591 | (fail))) 592 | ((vector? pat) 593 | (case (vector-ref pat 0) 594 | ((atom) 595 | (let ((a (vector-ref pat 1))) 596 | (if (eqv? obj a) 597 | vals 598 | (fail)))) 599 | ((vector) 600 | (if (vector? obj) 601 | (let ((vec-pat (vector-ref pat 1))) 602 | (f vec-pat (vector->list obj) vals)) 603 | (fail))) 604 | ((each) 605 | ;; if infinite, copy the list as flat, then do the matching, 606 | ;; then do some set-cdrs. 607 | (let ((each-pat (vector-ref pat 1)) 608 | (each-size (vector-ref pat 2))) 609 | (case (classify-list obj) 610 | ((improper) (fail)) 611 | ((infinite) 612 | (let ((each-vals (f pat (ilist-copy-flat obj) '()))) 613 | (for-each (lambda (x) (set-cdr! (last-pair x) x)) 614 | each-vals) 615 | (append each-vals vals))) 616 | ((proper) 617 | (append 618 | (let g ((obj obj)) 619 | (if (null? obj) 620 | (make-list each-size '()) 621 | (let ((hd-vals (f each-pat (car obj) '())) 622 | (tl-vals (g (cdr obj)))) 623 | (map cons hd-vals tl-vals)))) 624 | vals))))) 625 | ((tail-each) 626 | (let ((each-pat (vector-ref pat 1)) 627 | (each-size (vector-ref pat 2)) 628 | (revtail-pat (vector-ref pat 3)) 629 | (revtail-tail-pat (vector-ref pat 4))) 630 | (when (eq? (classify-list obj) 'infinite) (fail)) 631 | (with-values 632 | (let g ((obj obj)) 633 | ;; in-tail?, vals, revtail-left/ls 634 | (cond 635 | ((pair? obj) 636 | (with-values (g (cdr obj)) 637 | (lambda (in-tail? vals tail-left/ls) 638 | (if in-tail? 639 | (if (null? tail-left/ls) 640 | (values #f vals (list (car obj))) 641 | (values #t (f (car tail-left/ls) 642 | (car obj) 643 | vals) 644 | (cdr tail-left/ls))) 645 | (values #f vals 646 | (cons (car obj) tail-left/ls)))))) 647 | (else 648 | (values #t 649 | (f revtail-tail-pat obj vals) 650 | revtail-pat)))) 651 | (lambda (in-tail? vals tail-left/ls) 652 | (if in-tail? 653 | (if (null? tail-left/ls) 654 | (append (make-list each-size '()) 655 | vals) 656 | (fail)) 657 | (f each-pat tail-left/ls vals)))))))) 658 | (else 659 | (if (eqv? obj pat) 660 | vals 661 | (fail))))))))) 662 | ) 663 | 664 | #!eof 665 | 666 | ;;; examples of passing along threaded information. 667 | 668 | ;;; Try (collect-symbols '(if (x y 'a 'c zz) 'b 'c)) 669 | ;;; Note that it commonizes the reference to c. 670 | 671 | (define-syntax with-values 672 | (syntax-rules () 673 | ((_ P C) (call-with-values (lambda () P) C)))) 674 | (define collect-symbols 675 | (lambda (exp) 676 | (with-values (collect-symbols-help exp) 677 | (lambda (symbol-decls exp) 678 | (match symbol-decls 679 | (((,symbol-name . ,symbol-var) ...) 680 | `(let ((,symbol-var (quote ,symbol-name)) ...) ,exp))))))) 681 | (define collect-symbols-help 682 | (lambda (exp) 683 | (let ((symbol-env '())) 684 | (match+ (symbol-env) exp 685 | (,x 686 | (guard (symbol? x)) 687 | (values symbol-env x)) 688 | ((quote ,x) 689 | (guard (symbol? x)) 690 | (let ((pair/false (assq x symbol-env))) 691 | (if pair/false 692 | (values symbol-env (cdr pair/false)) 693 | (let ((v (gensym))) 694 | (values (cons (cons x v) symbol-env) 695 | v))))) 696 | ((quote ,x) 697 | (values symbol-env `(quote ,x))) 698 | ((if ,[t] ,[c] ,[a]) 699 | (values symbol-env `(if ,t ,c ,a))) 700 | ((,[op] ,[arg] ...) 701 | (values symbol-env `(,op ,arg ...))))))) 702 | 703 | ;;; the grammar for this one is just if-exprs and everything else 704 | 705 | (define collect-leaves 706 | (lambda (exp acc) 707 | (match+ (acc) exp 708 | ((if ,[] ,[] ,[]) 709 | acc) 710 | ((,[] ,[] ...) 711 | acc) 712 | (,x 713 | (cons x acc))))) 714 | 715 | ;; here's something that takes apart quoted stuff. 716 | 717 | (define destruct 718 | (lambda (datum) 719 | (match datum 720 | (() `'()) 721 | ((,[X] . ,[Y])`(cons ,X ,Y)) 722 | (#(,[X] ...) `(vector ,X ...)) 723 | (,thing 724 | (guard (symbol? thing)) 725 | `',thing) 726 | (,thing 727 | thing)))) 728 | 729 | ;; examples using explicit Catas 730 | 731 | (define sumsquares 732 | (lambda (ls) 733 | (define square 734 | (lambda (x) 735 | (* x x))) 736 | (match ls 737 | [(,[a*] ...) (apply + a*)] 738 | [,[square -> n] n]))) 739 | 740 | (define sumsquares 741 | (lambda (ls) 742 | (define square 743 | (lambda (x) 744 | (* x x))) 745 | (let ([acc 0]) 746 | (match+ (acc) ls 747 | [(,[] ...) acc] 748 | [,[(lambda (acc x) (+ acc (square x))) ->] acc])))) 749 | 750 | ;;; The following uses explicit Catas to parse programs in the 751 | ;;; simple language defined by the grammar below 752 | 753 | ;;; -> (program * ) 754 | ;;; -> (if ) 755 | ;;; | (set! ) 756 | ;;; -> 757 | ;;; | 758 | ;;; | (if ) 759 | ;;; | ( ) 760 | 761 | (define parse 762 | (lambda (x) 763 | (define Prog 764 | (lambda (x) 765 | (match x 766 | [(program ,[Stmt -> s*] ... ,[Expr -> e]) 767 | `(begin ,s* ... ,e)] 768 | [,other (errorf 'parse "invalid program ~s" other)]))) 769 | (define Stmt 770 | (lambda (x) 771 | (match x 772 | [(if ,[Expr -> e] ,[Stmt -> s1] ,[Stmt -> s2]) 773 | `(if ,e ,s1 ,s2)] 774 | [(set! ,v ,[Expr -> e]) 775 | (guard (symbol? v)) 776 | `(set! ,v ,e)] 777 | [,other (errorf 'parse "invalid statement ~s" other)]))) 778 | (define Expr 779 | (lambda (x) 780 | (match x 781 | [,v (guard (symbol? v)) v] 782 | [,n (guard (integer? n)) n] 783 | [(if ,[e1] ,[e2] ,[e3]) 784 | `(if ,e1 ,e2 ,e3)] 785 | [(,[rator] ,[rand*] ...) `(,rator ,rand* ...)] 786 | [,other (errorf 'parse "invalid expression ~s" other)]))) 787 | (Prog x))) 788 | ;;; (parse '(program (set! x 3) (+ x 4)))) => (begin (set! x 3) (+ x 4)) 789 | 790 | ;; CHANGELOG 791 | 792 | ;; [31 January 2010] 793 | ;; rkd replaced _ with k in the syntax-case patterns for match, match+, 794 | ;; etc., since in R6RS, _ is not a pattern variable. 795 | 796 | ;; [31 January 2010] 797 | ;; rkd renamed syntax-object->datum and datum->syntax-object to their 798 | ;; R6RS names syntax->datum and datum->syntax. also replaced the 799 | ;; literal-identifier=? calls with free-identifier=? calls. 800 | 801 | ;; [3 February 2008] 802 | ;; rkd modified overloaded quasiquote to handle expressions followed 803 | ;; by more than one ellipsis. 804 | 805 | ;; [3 February 2008] 806 | ;; aziz modified mapper to quote the inserted empty lists 807 | 808 | ;; [3 March 2007] 809 | ;; aziz minor change to eagerly catch malformed clauses (e.g. a clause 810 | ;; that's not a list of 2 or more subforms). 811 | 812 | ;; [13 March 2002] 813 | ;; rkd added following change by Friedman and Ganz to the main source 814 | ;; code thread and fixed a couple of minor problems. 815 | 816 | ;; [9 March 2002] 817 | ;; Dan Friedman and Steve Ganz added the ability to use identical pattern 818 | ;; variables. The patterns represented by the variables are compared 819 | ;; using the value of the parameter match-equality-test, which defaults 820 | ;; to equal?. 821 | ;; 822 | ;; > (match '(1 2 1 2 1) 823 | ;; [(,a ,b ,a ,b ,a) (guard (number? a) (number? b)) (+ a b)]) 824 | ;; 3 825 | ;; ;; 826 | ;; > (match '((1 2 3) 5 (1 2 3)) 827 | ;; [((,a ...) ,b (,a ...)) `(,a ... ,b)]) 828 | ;; (1 2 3 5) 829 | ;; ;; 830 | ;; > (parameterize ([match-equality-test (lambda (x y) (equal? x (reverse y)))]) 831 | ;; (match '((1 2 3) (3 2 1)) 832 | ;; [(,a ,a) 'yes] 833 | ;; [,oops 'no])) 834 | ;; yes 835 | 836 | ;; [10 Jan 2002] 837 | ;; eh fixed bug that caused (match '((1 2 3 4)) (((,a ... ,d) . ,x) a)) to 838 | ;; blow up. The bug was caused by a bug in the sexp-dispatch procedure 839 | ;; where a base value empty list was passed to an accumulator from inside 840 | ;; the recursion, instead of passing the old value of the accumulator. 841 | 842 | ;; [14 Jan 2001] 843 | ;; rkd added syntax checks to unquote pattern parsing to weed out invalid 844 | ;; patterns like ,#(a) and ,[(vector-ref d 1)]. 845 | 846 | ;; [14 Jan 2001] 847 | ;; rkd added ,[Cata -> Id* ...] to allow specification of recursion 848 | ;; function. ,[Id* ...] recurs to match; ,[Cata -> Id* ...] recurs 849 | ;; to Cata. 850 | 851 | ;; [14 Jan 2001] 852 | ;; rkd tightened up checks for ellipses and nested quasiquote; was comparing 853 | ;; symbolic names, which, as had been noted in the source, is a possible 854 | ;; hygiene bug. Replaced error call in guard-body with syntax-error to 855 | ;; allow error to include source line/character information. 856 | 857 | ;; [13 Jan 2001] 858 | ;; rkd fixed match patterns of the form (stuff* ,[x] ... stuff+), which 859 | ;; had been recurring on subforms of each item rather than on the items 860 | ;; themselves. 861 | 862 | ;; [29 Feb 2000] 863 | ;; Fixed a case sensitivity bug. 864 | 865 | ;; [24 Feb 2000] 866 | ;; Matcher now handles vector patterns. Quasiquote also handles 867 | ;; vector patterns, but does NOT do the csv6.2 optimization of 868 | ;; `#(a 1 ,(+ 3 4) x y) ==> (vector 'a 1 (+ 3 4) 'x 'y). 869 | ;; Also fixed bug in (P ... . P) matching code. 870 | 871 | ;; [23 Feb 2000] 872 | ;; KSM fixed bug in unquote-splicing inside quasiquote. 873 | 874 | ;; [10 Feb 2000] 875 | ;; New forms match+ and trace-match+ thread arguments right-to-left. 876 | ;; The pattern (P ... . P) now works the way you might expect. 877 | ;; Infinite lists are now properly matched (and not matched). 878 | ;; Removed the @ pattern. 879 | ;; Internal: No longer converting into syntax-case. 880 | 881 | ;; [6 Feb 2000] 882 | ;; Added expansion-time error message for referring to cata variable 883 | ;; in a guard. 884 | 885 | ;; [4 Feb 2000] 886 | ;; Fixed backquote so it can handle nested backquote (oops). 887 | ;; Double-backquoted elipses are neutralized just as double-backquoted 888 | ;; unquotes are. So: 889 | ;; `(a ,'(1 2 3) ... b) =eval=> (a 1 2 3 b) 890 | ;; ``(a ,'(1 2 3) ... b) =eval=> `(a ,'(1 2 3) ... b) 891 | ;; ``(a ,(,(1 2 3) ...) b) =eval=> `(a ,(1 2 3) b) 892 | ;; Added support for 893 | ;; `((unquote-splicing x y z) b) =expand==> (append x y z (list 'b)) 894 | 895 | ;; [1 Feb 2000] 896 | ;; Fixed a bug involving forgetting to quote stuff in the revised backquote. 897 | ;; Recognized unquote-splicing and signalled errors in the appropriate places. 898 | ;; Added support for deep elipses in backquote. 899 | ;; Rewrote backquote so it does the rebuilding directly instead of 900 | ;; expanding into Chez's backquote. 901 | 902 | ;; [31 Jan 2000] 903 | ;; Kent Dybvig fixed template bug. 904 | 905 | ;; [31 Jan 2000] 906 | ;; Added the trace-match form, and made guards contain 907 | ;; an explicit and expression: 908 | ;; (guard E ...) ==> (guard (and E ...)) 909 | 910 | ;; [26 Jan 2000] 911 | ;; Inside the clauses of match expressions, the following 912 | ;; transformation is performed inside backquote expressions: 913 | ;; ,v ... ==> ,@v 914 | ;; (,v ,w) ... ==> ,@(map list v w) 915 | ;; etc. 916 | 917 | -------------------------------------------------------------------------------- /maybeM.ss: -------------------------------------------------------------------------------- 1 | (library (monad maybeM) 2 | (export maybeM 3 | unit-maybe 4 | bind-maybe 5 | mzero-maybe) 6 | (import (chezscheme) 7 | (monad core) 8 | (monad aux)) 9 | 10 | (define unit-maybe 11 | (lambda (a) 12 | `(Just . ,a))) 13 | 14 | (define bind-maybe 15 | (lambda (m f) 16 | (letp (((t . a) m)) 17 | (case t 18 | ((Just) (f a)) 19 | ((Nothing) '(Nothing)))))) 20 | 21 | (define mzero-maybe 22 | (lambda () 23 | '(Nothing))) 24 | 25 | (define-monad maybeM 26 | unit-maybe 27 | bind-maybe 28 | mzero-maybe 29 | mplus-err 30 | lift-err) 31 | 32 | ) 33 | -------------------------------------------------------------------------------- /readerM-multi.ss: -------------------------------------------------------------------------------- 1 | (library (monad readerM-multi) 2 | (export ask-for 3 | local-for 4 | with-new-env) 5 | (import (chezscheme) 6 | (monad core) 7 | (monad readerM) 8 | (monad aux)) 9 | 10 | ; env has form ((t0 . env0) (t1 . env1) ...) 11 | ; where t0, t1, ... are tags for their environments 12 | ; and t0, t, ... are all unique 13 | ; and env0, env1, ... are alists 14 | 15 | ; accessor for tagged environment 16 | (define ask-for 17 | (lambda (t) 18 | (lambda () 19 | (lambda (e) 20 | (cond 21 | ((assq t e) => cdr) 22 | (else #f)))))) 23 | 24 | ; local modification of tagged environment 25 | (define local-for 26 | (lambda (t) 27 | (lambda (f m) 28 | (local-reader 29 | (mod-in-list t f) 30 | m)))) 31 | 32 | ; introduce new tagged environment in inner computation 33 | (define with-new-env 34 | (lambda (t/e m) 35 | (local-reader 36 | (lambda (e) `(,t/e . ,e)) 37 | m))) 38 | 39 | ) -------------------------------------------------------------------------------- /readerM.ss: -------------------------------------------------------------------------------- 1 | (library (monad readerM) 2 | (export readerM 3 | unit-reader 4 | bind-reader 5 | run-reader 6 | ask-reader 7 | local-reader 8 | lookup-reader 9 | walk-reader) 10 | (import (chezscheme) 11 | (monad core)) 12 | 13 | (define unit-reader 14 | (lambda (a) 15 | (lambda (e) a))) 16 | 17 | (define bind-reader 18 | (lambda (m f) 19 | (lambda (e) 20 | (let ((a (m e))) 21 | (let ((m^ (f a))) 22 | (m^ e)))))) 23 | 24 | (define run-reader 25 | (lambda (m e) 26 | (m e))) 27 | 28 | (define ask-reader 29 | (lambda () 30 | (lambda (e) e))) 31 | 32 | (define local-reader 33 | (lambda (f m) 34 | (lambda (e) 35 | (m (f e))))) 36 | 37 | (define lookup-reader 38 | (lambda (x) 39 | (lambda (e) 40 | (cond 41 | ((assq x e) => cdr) 42 | (else #f))))) 43 | 44 | (define walk-reader 45 | (lambda (x) 46 | (lambda (e) 47 | (cond 48 | ((assq x e) => cdr) 49 | (else x))))) 50 | 51 | (define-monad readerM 52 | unit-reader 53 | bind-reader 54 | mzero-err 55 | mplus-err 56 | lift-err) 57 | 58 | ) -------------------------------------------------------------------------------- /readerT.ss: -------------------------------------------------------------------------------- 1 | (library (monad readerT) 2 | (export readerT 3 | unit-readerT 4 | bind-readerT 5 | bind-reader 6 | lift-readerT 7 | run-reader 8 | ask-readerT 9 | local-reader) 10 | (import (chezscheme) 11 | (monad core)) 12 | 13 | (define unit-readerT 14 | (lambda (unit bind) 15 | (lambda (a) 16 | (lambda (e) 17 | (unit a))))) 18 | 19 | (define bind-readerT 20 | (lambda (unit bind) 21 | (lambda (m f) 22 | (lambda (e) 23 | (bind (m e) 24 | (lambda (a) 25 | ((f a) e))))))) 26 | 27 | (define bind-reader 28 | (lambda (m f) 29 | (lambda (e) 30 | ((f (m e)) e)))) 31 | 32 | (define lift-readerT 33 | (lambda (unit bind) 34 | (lambda (m) 35 | (lambda (e) 36 | m)))) 37 | 38 | (define run-reader 39 | (lambda (m e) 40 | (m e))) 41 | 42 | (define ask-readerT 43 | (withM (baseM) 44 | (lambda (e) 45 | (unit e)))) 46 | 47 | (define local-reader 48 | (lambda (f m) 49 | (lambda (e) 50 | (m (f e))))) 51 | 52 | (define-transformer readerT 53 | unit-readerT 54 | bind-readerT 55 | mzeroT-err 56 | mplusT-err 57 | lift-readerT) 58 | 59 | ) -------------------------------------------------------------------------------- /stateM-multi.ss: -------------------------------------------------------------------------------- 1 | (library (monad stateM-multi) 2 | (export get-state-n 3 | put-state-n 4 | mod-state-n 5 | push-state-n 6 | pop-state-n 7 | lookup-state-n 8 | empty-env-n) 9 | (import (chezscheme) 10 | (monad core) 11 | (monad stateM) 12 | (monad aux)) 13 | 14 | ;; states referenced by index 15 | 16 | (define get-state-n 17 | (withM stateM 18 | (lambda (n) 19 | (lambda () 20 | (doM (e <- (get-state)) 21 | (unit (list-ref e n))))))) 22 | 23 | (define put-state-n 24 | (lambda (n) 25 | (lambda (s^) 26 | ((mod-state-n n) 27 | (lambda (s) s^))))) 28 | 29 | (define mod-state-n 30 | (lambda (n) 31 | (lambda (f) 32 | (mod-state (mod-list-n n f))))) 33 | 34 | (define push-state-n 35 | (lambda (n) 36 | (lambda (s^) 37 | ((mod-state-n n) 38 | (extend s^))))) 39 | 40 | (define pop-state-n 41 | (withM stateM 42 | (lambda (n) 43 | (lambda () 44 | (doM (s <- ((get-state-n n))) 45 | ((mod-state-n n) cdr) 46 | (unit (car s))))))) 47 | 48 | (define lookup-state-n 49 | (lambda (n) 50 | (lambda (x) 51 | (lookup-state (get-state-n n))))) 52 | 53 | ;; modify list-ref n of ls with function f 54 | (define mod-list-n 55 | (lambda (n f) 56 | (lambda (ls) 57 | (cond 58 | ((null? ls) '()) 59 | ((zero? n) (cons (f (car ls)) (cdr ls))) 60 | (else (cons (car ls) 61 | ((mod-list-n (sub1 n) f) 62 | (cdr ls)))))))) 63 | 64 | ;; constructs a list of n empty lists 65 | (define empty-env-n 66 | (lambda (n) 67 | (lambda () 68 | (let loop ((n n)) 69 | (cond 70 | ((zero? n) '()) 71 | (else (cons '() (loop (sub1 n))))))))) 72 | 73 | ) -------------------------------------------------------------------------------- /stateM.ss: -------------------------------------------------------------------------------- 1 | (library (monad stateM) 2 | (export stateM 3 | unit-state 4 | bind-state 5 | lookup-state 6 | run-state 7 | eval-state 8 | exec-state 9 | get-state 10 | put-state 11 | mod-state 12 | push-state 13 | pop-state) 14 | (import (chezscheme) 15 | (monad core)) 16 | 17 | (define unit-state 18 | (lambda (a) 19 | (lambda (s) 20 | `(,a . ,s)))) 21 | 22 | (define bind-state 23 | (lambda (m f) 24 | (lambda (s) 25 | (let ((p (m s))) 26 | (let ((a^ (car p)) 27 | (s^ (cdr p))) 28 | (let ((m^ (f a^))) 29 | (m^ s^))))))) 30 | 31 | (define lookup-state 32 | (lambda (get) 33 | (lambda (x) 34 | (doM (env <- (get)) 35 | (unit-state 36 | (cond 37 | ((assq x env) => cdr) 38 | (else x))))))) 39 | 40 | (define run-state 41 | (lambda (m s) 42 | (m s))) 43 | 44 | (define eval-state 45 | (lambda (m s) 46 | (car (run-state m s)))) 47 | 48 | (define exec-state 49 | (lambda (m s) 50 | (cdr (run-state m s)))) 51 | 52 | (define get-state 53 | (lambda () 54 | (lambda (s) 55 | `(,s . ,s)))) 56 | 57 | (define put-state 58 | (lambda (s^) 59 | (mod-state (lambda (s) s^)))) 60 | 61 | (define mod-state 62 | (lambda (f) 63 | (lambda (s) 64 | (let ((s^ (f s))) 65 | `(_ . ,s^))))) 66 | 67 | (define push-state 68 | (lambda (s^) 69 | (mod-state 70 | (lambda (s) 71 | (cons s^ s))))) 72 | 73 | (define pop-state 74 | (lambda () 75 | (doM (s <- (get-state)) 76 | (mod-state cdr) 77 | (unit-state (car s))))) 78 | 79 | (define-monad stateM 80 | unit-state 81 | bind-state 82 | mzero-err 83 | mplus-err 84 | lift-err) 85 | 86 | ) -------------------------------------------------------------------------------- /writerM.ss: -------------------------------------------------------------------------------- 1 | (library (monad writerM) 2 | (export writerM 3 | eval-writer 4 | exec-writer 5 | unit-writer 6 | bind-writer 7 | init-writer 8 | pass-writer 9 | listen-writer 10 | tell-writer 11 | listens-writer 12 | censor-writer 13 | empty-writer 14 | diff-writer 15 | union-writer 16 | inters-writer 17 | set-writer) 18 | (import (chezscheme) 19 | (monad core) 20 | (monad aux)) 21 | 22 | (define eval-writer car) 23 | 24 | (define exec-writer cdr) 25 | 26 | (define unit-writer 27 | (lambda (a) 28 | `(,a . ()))) 29 | 30 | (define bind-writer 31 | (lambda (m f) 32 | (letp (((a . w) m)) 33 | (let ((m^ (f a))) 34 | (letp (((a^ . w^) m^)) 35 | (let ((ww (append w w^))) 36 | `(,a^ . ,ww))))))) 37 | 38 | (define init-writer 39 | (withM writerM 40 | (lambda (a w) 41 | (doM (tell-writer w) 42 | (unit a))))) 43 | 44 | (define pass-writer 45 | (lambda (m) 46 | (letp ((((a . f) . w) m)) 47 | (let ((w^ (f w))) 48 | `(,a . ,w^))))) 49 | 50 | (define listen-writer 51 | (lambda (m) 52 | (letp (((a . w) m)) 53 | `((,a . ,w) . ,w)))) 54 | 55 | (define tell-writer 56 | (lambda (w) 57 | `(_ . ,w))) 58 | 59 | (define listens-writer 60 | (withM writerM 61 | (lambda (f m) 62 | (doM ((a . w) <- m) 63 | (w^ == (f w)) 64 | (unit `(,a . ,w^)))))) 65 | 66 | (define censor-writer 67 | (lambda (f) 68 | (lambda (m) 69 | (pass-writer 70 | (doM (a <- m) 71 | (unit `(,a . ,f))))))) 72 | 73 | (define empty-writer (censor-writer (lambda (w) '()))) 74 | 75 | (define diff-writer 76 | (lambda (w^ m) 77 | ((censor-writer 78 | (lambda (w) 79 | (difference w w^))) 80 | m))) 81 | 82 | (define union-writer 83 | (lambda (w^ m) 84 | ((censor-writer 85 | (lambda (w) 86 | (union w w^))) 87 | m))) 88 | 89 | (define inters-writer 90 | (lambda (w^ m) 91 | ((censor-writer 92 | (lambda (w) 93 | (union w w^))) 94 | m))) 95 | 96 | (define set-writer (censor-writer make-set)) 97 | 98 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 99 | 100 | (define union 101 | (lambda (s1 s2) 102 | (cond 103 | ((null? s1) s2) 104 | ((memq (car s1) s2) 105 | (union (cdr s1) s2)) 106 | (else (cons (car s1) 107 | (union (cdr s1) s2)))))) 108 | 109 | (define intersect 110 | (lambda (s1 s2) 111 | (cond 112 | ((or (null? s1) 113 | (null? s2)) 114 | '()) 115 | (else 116 | (let ((a (car s1))) 117 | (if (memq a s2) 118 | (cons a (intersect (cdr s1) (remq a s2))) 119 | (intersect (cdr s1) (remq a s2)))))))) 120 | 121 | (define difference 122 | (lambda (s1 s2) 123 | (cond 124 | ((null? s2) s1) 125 | (else (difference (remq (car s2) s1) (cdr s2)))))) 126 | 127 | (define-monad writerM 128 | unit-writer 129 | bind-writer 130 | mzero-err 131 | mplus-err 132 | lift-err) 133 | 134 | ) --------------------------------------------------------------------------------