1;;; 2;;; srfi-189 - Maybe and Either 3;;; 4;;; Copyright (c) 2020 Shiro Kawai <shiro@acm.org> 5;;; 6;;; Redistribution and use in source and binary forms, with or without 7;;; modification, are permitted provided that the following conditions 8;;; are met: 9;;; 10;;; 1. Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12;;; 13;;; 2. Redistributions in binary form must reproduce the above copyright 14;;; notice, this list of conditions and the following disclaimer in the 15;;; documentation and/or other materials provided with the distribution. 16;;; 17;;; 3. Neither the name of the authors nor the names of its contributors 18;;; may be used to endorse or promote products derived from this 19;;; software without specific prior written permission. 20;;; 21;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 27;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32;;; 33 34(define-module srfi-189 35 (use srfi-1) 36 (use util.match) 37 (export just nothing right left either-swap 38 maybe? either? just? nothing? right? left? maybe-ref-error? 39 maybe= either= 40 maybe-ref either-ref maybe-ref/default either-ref/default 41 maybe-join either-join 42 maybe-compose either-compose 43 maybe-bind either-bind 44 maybe-length either-length 45 maybe-filter maybe-remove either-filter either-remove 46 maybe-sequence either-sequence 47 maybe->either either->maybe list->just list->right list->left 48 maybe->list either->list list->maybe list->either 49 maybe->truth either->truth truth->maybe truth->either 50 maybe->list-truth either->list-truth 51 list-truth->maybe list-truth->either 52 maybe->generation generation->maybe 53 either->generation generation->either 54 maybe->values either->values 55 values->maybe values->either 56 maybe->two-values two-values->maybe 57 exception->either 58 maybe-map either-map maybe-for-each either-for-each 59 maybe-fold either-fold maybe-unfold either-unfold 60 maybe-if 61 maybe-and maybe-or maybe-let* maybe-let*-values 62 either-and either-or either-let* either-let*-values 63 either-guard 64 65 tri-not tri=? tri-and tri-or tri-merge 66 ) 67 ;; The followings are Gauche-specific. 68 (export <maybe> <just> <nothing> 69 <either> <left> <right>) 70 ) 71(select-module srfi-189) 72 73(define-class <maybe> () ()) 74(define-method initialize ((obj <maybe>) initargs) 75 (when (eq? (class-of obj) <maybe>) 76 (error "You can't instantiate <maybe> directly.")) 77 (next-method)) 78 79(define-class <just> (<maybe>) 80 ((objs :init-keyword :objs))) 81(define-class <nothing> (<maybe>) ()) 82 83(define-class <either> () ()) 84(define-method initialize ((obj <either>) initargs) 85 (when (eq? (class-of obj) <either>) 86 (error "You can't instantiate <either> directly.")) 87 (next-method)) 88 89(define-class <right> (<either>) 90 ((objs :init-keyword :objs))) 91(define-class <left> (<either>) 92 ((objs :init-keyword :objs))) 93 94(define-condition-type <maybe-ref-error> <error> 95 maybe-ref-error?) 96 97(define-method write-object ((obj <just>) port) 98 (format port "#<Just ~a>" 99 (string-join (map write-to-string (~ obj'objs)) " "))) 100(define-method write-object ((obj <nothing>) port) 101 (display "#<Nothing>" port)) 102(define-method write-object ((obj <right>) port) 103 (format port "#<Right ~a>" 104 (string-join (map write-to-string (~ obj'objs)) " "))) 105(define-method write-object ((obj <left>) port) 106 (format port "#<Left ~a>" 107 (string-join (map write-to-string (~ obj'objs)) " "))) 108 109 110(define *nothing* (make <nothing>)) 111 112;;; Constructors 113(define (just . objs) (make <just> :objs objs)) 114(define (nothing) *nothing*) 115(define (right . objs) (make <right> :objs objs)) 116(define (left . objs) (make <left> :objs objs)) 117 118(define (list->just lis) (make <just> :objs lis)) 119(define (list->right lis) (make <right> :objs lis)) 120(define (list->left lis) (make <left> :objs lis)) 121 122(define (maybe->either maybe . objs) 123 (assume-type maybe <maybe>) 124 (if (just? maybe) 125 (list->right (~ maybe'objs)) 126 (list->left objs))) 127 128(define (either->maybe either) 129 (assume-type either <either>) 130 (if (right? either) 131 (list->just (~ either'objs)) 132 (nothing))) 133 134(define (either-swap either) 135 (assume-type either <either>) 136 (make (if (left? either) <right> <left>) :objs (~ either'objs))) 137 138;;; Predicates 139 140(define (maybe? x) (is-a? x <maybe>)) 141(define (just? x) (is-a? x <just>)) 142(define (nothing? x) (is-a? x <nothing>)) 143(define (either? x) (is-a? x <either>)) 144(define (right? x) (is-a? x <right>)) 145(define (left? x) (is-a? x <left>)) 146 147(define (maybe= eqproc x . xs) 148 (or (null? xs) 149 (let1 y (car xs) 150 (and (or (and (nothing? x) (nothing? y)) 151 (and (just? x) (just? y) 152 (list= eqproc (~ x'objs) (~ y'objs)))) 153 (or (null? (cdr xs)) 154 (apply maybe= eqproc xs)))))) 155 156(define (either= eqproc x . xs) 157 (or (null? xs) 158 (let1 y (car xs) 159 (and (or (and (right? x) (right? y) 160 (list= eqproc (~ x'objs) (~ y'objs))) 161 (and (left? x) (left? y) 162 (list= eqproc (~ x'objs) (~ y'objs)))) 163 (or (null? (cdr xs)) 164 (apply either= eqproc xs)))))) 165 166;;; Accessors 167 168;; returns one value in container; raises an error if container doesn't have 169;; exactly one value. 170(define (%ref1 container) 171 (match (~ container'objs) 172 [(x) x] 173 [_ (error "~a with exactly one value expected, but got: ~s" 174 (class-of container) container)])) 175 176(define (maybe-ref maybe failure :optional (success values)) 177 (assume-type maybe <maybe>) 178 (if (nothing? maybe) 179 (failure) 180 (apply success (~ maybe'objs)))) 181 182(define (either-ref either failure :optional (success values)) 183 (assume-type either <either>) 184 (if (left? either) 185 (apply failure (~ either'objs)) 186 (apply success (~ either'objs)))) 187 188(define (maybe-ref/default maybe . defaults) 189 (assume-type maybe <maybe>) 190 (apply values (if (just? maybe) (~ maybe'objs) defaults))) 191 192(define (either-ref/default either . defaults) 193 (assume-type either <either>) 194 (apply values (if (right? either) (~ either'objs) defaults))) 195 196;;; Join and bind 197 198(define (maybe-join maybe) 199 (assume-type maybe <maybe>) 200 (if (nothing? maybe) 201 maybe 202 (match (~ maybe'objs) 203 [((? maybe? val)) val] 204 [x (error "invalid payload" x)]))) 205 206(define (either-join either) 207 (assume-type either <either>) 208 (if (left? either) 209 either 210 (match (~ either'objs) 211 [((? either? val)) val] 212 [x (error "invalid payload" x)]))) 213 214(define (maybe-bind maybe proc . procs) 215 (assume-type maybe <maybe>) 216 (if (nothing? maybe) 217 maybe 218 (if (null? procs) 219 (apply proc (~ maybe'objs)) ;tail call 220 (apply maybe-bind (apply proc (~ maybe'objs)) procs)))) 221 222(define (maybe-compose proc . procs) 223 (if (null? procs) 224 proc 225 (let1 p (apply maybe-compose procs) 226 (^ args 227 (let1 m (apply proc args) 228 (if (nothing? m) 229 m 230 (apply p (~ m'objs)))))))) 231 232(define (either-bind either proc . procs) 233 (assume-type either <either>) 234 (if (left? either) 235 either 236 (if (null? procs) 237 (apply proc (~ either'objs)) ;tail call 238 (apply either-bind (apply proc (~ either'objs)) procs)))) 239 240(define (either-compose proc . procs) 241 (if (null? procs) 242 proc 243 (let1 p (apply either-compose procs) 244 (^ args 245 (let1 e (apply proc args) 246 (unless (either? e) 247 (error "mproc returned non-either object:" e)) 248 (if (left? e) 249 e 250 (apply p (~ e'objs)))))))) 251 252;;; Sequence operations 253 254(define (maybe-length maybe) 255 (assume-type maybe <maybe>) 256 (if (nothing? maybe) 0 1)) 257 258(define (either-length either) 259 (assume-type either <either>) 260 (if (left? either) 0 1)) 261 262(define (maybe-filter pred maybe) 263 (assume-type maybe <maybe>) 264 (if (and (just? maybe) (apply pred (~ maybe'objs))) 265 maybe 266 (nothing))) 267 268(define (maybe-remove pred maybe) 269 (assume-type maybe <maybe>) 270 (if (and (just? maybe) (not (apply pred (~ maybe'objs)))) 271 maybe 272 (nothing))) 273 274(define (either-filter pred either . objs) 275 (assume-type either <either>) 276 (if (and (right? either) (apply pred (~ either'objs))) 277 either 278 (list->left objs))) 279 280(define (either-remove pred either . objs) 281 (assume-type either <either>) 282 (if (and (right? either) (not (apply pred (~ either'objs)))) 283 either 284 (list->left objs))) 285 286;; input :: Container Maybe a* 287;; cmap :: Container Maybe a* -> (Maybe a* -> b) -> Container b 288;; aggregator :: a* -> b 289;; Returns Maybe Container b 290(define (maybe-sequence input cmap :optional (aggregator list)) 291 (let/cc return 292 (just (cmap (^[me] (maybe-ref me (^[] (return (nothing))) aggregator)) 293 input)))) 294 295;; input :: Container Either a* 296;; cmap :: Container Either a* -> (Either a -> b) -> Container b 297;; aggregator :: a* -> b 298;; returns Either Container b 299(define (either-sequence input cmap :optional (aggregator list)) 300 (let/cc return 301 (right (cmap (^[ee] (either-ref ee (^ _ (return ee)) aggregator)) 302 input)))) 303 304;;; Protocol conversion 305 306(define (maybe->list maybe) 307 (assume-type maybe <maybe>) 308 (if (nothing? maybe) '() (~ maybe'objs))) 309(define (list->maybe lis) 310 (if (null? lis) 311 (nothing) 312 (apply just lis))) 313(define (either->list either) 314 (assume-type either <either>) 315 (~ either'objs)) 316(define (list->either lis . objs) 317 (if (null? lis) 318 (apply left objs) 319 (apply right lis))) 320 321(define (maybe->truth maybe) 322 (assume-type maybe <maybe>) 323 (and (just? maybe) (%ref1 maybe))) 324(define (truth->maybe obj) 325 (if obj (just obj) (nothing))) 326(define (either->truth either) 327 (assume-type either <either>) 328 (and (right? either) (%ref1 either))) 329(define (truth->either obj . fail-objs) 330 (if obj (right obj) (apply left fail-objs))) 331 332(define (maybe->list-truth maybe) 333 (assume-type maybe <maybe>) 334 (and (just? maybe) (~ maybe'objs))) 335(define (list-truth->maybe lis-or-false) 336 (if lis-or-false (apply just lis-or-false) (nothing))) 337(define (either->list-truth either) 338 (assume-type either <either>) 339 (and (right? either) (~ either'objs))) 340(define (list-truth->either lis-or-false . fail-objs) 341 (if lis-or-false (apply right lis-or-false) (apply left fail-objs))) 342 343(define (maybe->generation maybe) 344 (assume-type maybe <maybe>) 345 (if (just? maybe) 346 (%ref1 maybe) 347 (eof-object))) 348(define (generation->maybe obj) 349 (if (eof-object? obj) 350 (nothing) 351 (just obj))) 352(define (either->generation either) 353 (assume-type either <either>) 354 (if (right? either) 355 (%ref1 either) 356 (eof-object))) 357(define (generation->either obj . objs) 358 (if (eof-object? obj) 359 (apply left objs) 360 (right obj))) 361 362(define (maybe->values maybe) 363 (assume-type maybe <maybe>) 364 (if (nothing? maybe) (values) (apply values (~ maybe'objs)))) 365(define (either->values either) 366 (assume-type either <either>) 367 (if (left? either) (values) (apply values (~ either'objs)))) 368 369(define (values->maybe producer) 370 (call-with-values producer 371 (^ xs (if (null? xs) (nothing) (apply just xs))))) 372(define (values->either producer . objs) 373 (call-with-values producer 374 (^ xs (if (null? xs) (apply left objs) (apply right xs))))) 375 376(define (maybe->two-values maybe) 377 (assume-type maybe <maybe>) 378 (if (nothing? maybe) 379 (values #f #f) 380 (values (%ref1 maybe) #t))) 381 382(define (two-values->maybe producer) 383 (receive (val has-val?) (producer) 384 (if has-val? (just val) (nothing)))) 385 386(define (exception->either pred thunk) 387 (guard (e [(pred e) (left e)]) 388 (call-with-values thunk right))) 389 390;;; Map, fold and unfold 391 392(define (maybe-map proc maybe) 393 (assume-type maybe <maybe>) 394 (if (nothing? maybe) 395 maybe 396 (list->just (values->list (apply proc (~ maybe'objs)))))) 397(define (either-map proc either) 398 (assume-type either <either>) 399 (if (left? either) 400 either 401 (list->right (values->list (apply proc (~ either'objs)))))) 402 403(define (maybe-for-each proc maybe) 404 (assume-type maybe <maybe>) 405 (when (just? maybe) 406 (apply proc (~ maybe'objs))) 407 (undefined)) 408(define (either-for-each proc either) 409 (assume-type either <either>) 410 (when (right? either) 411 (apply proc (~ either'objs))) 412 (undefined)) 413 414(define (maybe-fold kons knil maybe) 415 (assume-type maybe <maybe>) 416 (if (nothing? maybe) 417 knil 418 (apply kons (append (~ maybe'objs) (list knil))))) 419(define (either-fold kons knil either) 420 (assume-type either <either>) 421 (if (right? either) 422 (apply kons (append (~ either'objs) (list knil))) 423 knil)) 424 425(define (maybe-unfold stop? mapper successor . seeds) 426 (if (apply stop? seeds) 427 (nothing) 428 (if (call-with-values (cut apply successor seeds) stop?) 429 (list->just (values->list (apply mapper seeds))) 430 (error "unstoppable unfold")))) 431 432(define (either-unfold stop? mapper successor . seeds) 433 (if (apply stop? seeds) 434 (list->left seeds) 435 (if (call-with-values (cut apply successor seeds) stop?) 436 (list->right (values->list (apply mapper seeds))) 437 (error "unstoppable unfold")))) 438 439;;; Conditional syntax 440 441(define-syntax maybe-if 442 (syntax-rules () 443 [(_ expr justx nothingx) 444 (if (just? (assume-type expr <maybe>)) justx nothingx)])) 445 446(define-syntax maybe-and 447 (syntax-rules () 448 [(_) (just "empty maybe-and")] 449 [(_ x) (assume-type x <maybe>)] 450 [(_ x . xs) (let1 t (assume-type x <maybe>) 451 (if (nothing? t) t (maybe-and . xs)))])) 452 453(define-syntax either-and 454 (syntax-rules () 455 [(_) (right "empty either-and")] 456 [(_ x) (assume-type x <either>)] 457 [(_ x . xs) (let1 t (assume-type x <either>) 458 (if (left? t) t (either-and . xs)))])) 459 460(define-syntax maybe-or 461 (syntax-rules () 462 [(_) (nothing)] 463 [(_ x) (assume-type x <maybe>)] 464 [(_ x . xs) (let1 t (assume-type x <maybe>) 465 (if (just? t) t (maybe-or . xs)))])) 466 467(define-syntax either-or 468 (syntax-rules () 469 [(_) (left "empty either-or")] 470 [(_ x) (assume-type x <either>)] 471 [(_ x . xs) (let1 t (assume-type x <either>) 472 (if (right? t) t (either-or . xs)))])) 473 474(define-syntax maybe-let* 475 (syntax-rules () 476 ;; empty body case 477 [(_ ()) (just #t)] 478 [(_ ((var expr))) (assume-type expr <maybe>)] 479 [(_ ((expr))) (assume-type expr <maybe>)] 480 [(_ (var)) (assume-type var <maybe>)] 481 ;; normal case 482 [(_ () . body) (receive xs (let () . body) (list->just xs))] 483 [(_ ((var expr) . claws) . body) 484 (let1 t (assume-type expr <maybe>) 485 (if (nothing? t) 486 t 487 (let ((var (%ref1 t))) 488 (maybe-let* claws . body))))] 489 [(_ ((expr) . claws) . body) 490 (if (nothing? (assume-type expr <maybe>)) 491 (nothing) 492 (maybe-let* claws . body))] 493 [(_ (var . claws) . body) 494 (if (nothing? (assume-type var <maybe>)) 495 (nothing) 496 (maybe-let* claws . body))])) 497 498(define-syntax maybe-let*-values 499 (syntax-rules () 500 ;; empty body case 501 [(_ ()) (just #t)] 502 [(_ ((formals expr))) (rlet1 t expr 503 ;; Just make sure formals match the contained values 504 (maybe-ref t nothing (^ formals #f)))] 505 [(_ ((expr))) (assume-type expr <maybe>)] 506 [(_ (var)) (assume-type var <maybe>)] 507 ;; normal case 508 [(_ () . body) (receive xs (let () . body) (list->just xs))] 509 [(_ ((formals expr) . claws) . body) 510 (maybe-ref expr nothing 511 (^ formals (maybe-let*-values claws . body)))] 512 [(_ ((expr) . claws) . body) 513 (if (nothing? (assume-type expr <maybe>)) 514 (nothing) 515 (maybe-let*-values claws . body))] 516 [(_ (var . claws) . body) 517 (if (nothing? (assume-type var <maybe>)) 518 (nothing) 519 (maybe-let*-values claws . body))])) 520 521(define-syntax either-let* 522 (syntax-rules () 523 ;; empty body case 524 [(_ ()) (right #t)] 525 [(_ ((var expr))) (assume-type expr <either>)] 526 [(_ ((expr))) (assume-type expr <either>)] 527 [(_ (var)) (assume-type var <either>)] 528 ;; normal case 529 [(_ () . body) (receive xs (let () . body) (list->right xs))] 530 [(_ ((var expr) . claws) . body) 531 (let1 t (assume-type expr <either>) 532 (if (left? t) t (let ((var (%ref1 t))) 533 (either-let* claws . body))))] 534 [(_ ((expr) . claws) . body) 535 (let1 t (assume-type expr <either>) 536 (if (left? t) t (either-let* claws . body)))] 537 [(_ (var . claws) . body) 538 (let1 t (assume-type var <either>) 539 (if (left? t) t (either-let* claws . body)))])) 540 541(define-syntax either-let*-values 542 (syntax-rules () 543 ;; empty body case 544 [(_ ()) (right #t)] 545 [(_ ((formal expr))) (rlet1 t expr 546 ;; just to check the values match formals 547 (either-ref t (^ _ #f) (^ formals #f)))] 548 [(_ ((expr))) (rlet1 t expr 549 (assume-type t <either>))] 550 [(_ (var)) (assume-type var <either>)] 551 ;; normal case 552 [(_ () . body) (receive xs (let () . body) (list->right xs))] 553 [(_ ((formals expr) . claws) . body) 554 (either-ref expr left 555 (^ formals (either-let*-values claws . body)))] 556 [(_ ((expr) . claws) . body) 557 (let1 t (assume-type expr <either>) 558 (if (left? t) t (either-let*-values claws . body)))] 559 [(_ (var . claws) . body) 560 (if (left? (assume-type var <either>)) 561 var 562 (either-let*-values claws . body))])) 563 564(define-syntax either-guard 565 (syntax-rules () 566 [(_ (pred-expr) . body) 567 (guard (e [(pred-expr e) (left e)]) 568 (receive xs (begin . body) 569 (list->right xs)))])) 570 571;;; Trivalent logic 572 573(define (tri-not maybe) 574 (assume-type maybe <maybe>) 575 (if (nothing? maybe) 576 maybe 577 (just (not (%ref1 maybe))))) 578 579(define (tri=? maybe . maybes) 580 (define (rec val maybe maybes) 581 (if (nothing? (assume-type maybe <maybe>)) 582 (just #f) 583 (if (boolean=? val (boolean (%ref1 maybe))) 584 (if (null? maybes) 585 (just #t) 586 (rec val (car maybes) (cdr maybes))) 587 (just #f)))) 588 589 (if (nothing? (assume-type maybe <maybe>)) 590 (just #f) 591 (let1 v (%ref1 maybe) 592 (if (null? maybes) 593 (just #t) 594 (rec v (car maybes) (cdr maybes)))))) 595 596(define (tri-and . maybes) 597 (define (rec maybes) 598 (if (null? maybes) 599 (just #t) 600 (let ([maybe (car maybes)] 601 [maybes (cdr maybes)]) 602 (if (nothing? (assume-type maybe <maybe>)) 603 maybe 604 (if-let1 v (%ref1 maybe) 605 (rec maybes) 606 maybe))))) ; this must be #<just #f> 607 (rec maybes)) 608 609(define (tri-or . maybes) 610 (define (rec maybes) 611 (if (null? maybes) 612 (just #f) 613 (let ([maybe (car maybes)] 614 [maybes (cdr maybes)]) 615 (if (nothing? (assume-type maybe <maybe>)) 616 maybe 617 (if-let1 v (%ref1 maybe) 618 maybe 619 (rec maybes)))))) 620 (rec maybes)) 621 622(define (tri-merge . maybes) 623 (define (rec maybes) 624 (if (null? maybes) 625 (nothing) 626 (let ([maybe (car maybes)] 627 [maybes (cdr maybes)]) 628 (if (nothing? (assume-type maybe <maybe>)) 629 (rec maybes) 630 maybe)))) 631 (rec maybes)) 632