120 lines
3 KiB
Scheme
120 lines
3 KiB
Scheme
;; functional error handling with Either type
|
|
;; initially written by claude 3.7!
|
|
(library (meh either)
|
|
(export
|
|
either either?
|
|
left? right?
|
|
left-value right-value
|
|
left right
|
|
either-value
|
|
either-map
|
|
either-bind
|
|
either-fold
|
|
either->list
|
|
|
|
;; syntax helpers
|
|
try-either
|
|
with-either
|
|
either-let)
|
|
(import (chezscheme)
|
|
(meh match)
|
|
(meh std))
|
|
|
|
;; Core implementation using tagged records
|
|
(define-record-type either
|
|
(fields tag value)
|
|
(protocol
|
|
(lambda (new)
|
|
(lambda (tag value)
|
|
(unless (memq tag '(left right))
|
|
(assertion-violation 'make-either
|
|
"Invalid tag, must be 'left or 'right"
|
|
tag))
|
|
(new tag value)))))
|
|
|
|
;; Constructors and predicates
|
|
(define (left value)
|
|
(make-either 'left value))
|
|
|
|
(define (right value)
|
|
(make-either 'right value))
|
|
|
|
(define (left? e)
|
|
(and (either? e) (eq? (either-tag e) 'left)))
|
|
|
|
(define (right? e)
|
|
(and (either? e) (eq? (either-tag e) 'right)))
|
|
|
|
;; Accessors with safety checks
|
|
(define (left-value e)
|
|
(if (left? e)
|
|
(either-value e)
|
|
(assertion-violation 'left-value "Expected a Left value" e)))
|
|
|
|
(define (right-value e)
|
|
(if (right? e)
|
|
(either-value e)
|
|
(assertion-violation 'right-value "Expected a Right value" e)))
|
|
|
|
;; Functional operations
|
|
(define (either-map f e)
|
|
(if (right? e)
|
|
(right (f (right-value e)))
|
|
e))
|
|
|
|
(define (either-bind e f)
|
|
(if (right? e)
|
|
(f (right-value e))
|
|
e))
|
|
|
|
(define (either-fold left-f right-f e)
|
|
(if (left? e)
|
|
(left-f (left-value e))
|
|
(right-f (right-value e))))
|
|
|
|
(define (either->list e)
|
|
(either-fold
|
|
(lambda (v) '())
|
|
(lambda (v) (list v))
|
|
e))
|
|
|
|
;; Add pattern matching support
|
|
(define-record-equality! either)
|
|
(define-record-pattern! either)
|
|
|
|
;; Define pattern expanders for left and right
|
|
(define-pattern (left pat) (either 'left pat))
|
|
|
|
(define-pattern (right pat) (either 'right pat))
|
|
|
|
;; Exception handling helper - now with explicit condition handling
|
|
(define-syntax try-either
|
|
(syntax-rules ()
|
|
[(_ expr)
|
|
(guard (exn
|
|
[(condition? exn) (left exn)])
|
|
(right expr))]))
|
|
|
|
;; Syntax for monadic composition
|
|
(define-syntax either-let
|
|
(syntax-rules ()
|
|
[(_ () expr) (right expr)]
|
|
[(_ ([var val]) expr)
|
|
(either-bind val (lambda (var) (right expr)))]
|
|
[(_ ([var val] [var2 val2] ...) expr)
|
|
(either-bind val
|
|
(lambda (var)
|
|
(either-let ([var2 val2] ...) expr)))]))
|
|
|
|
;; Syntax for unwrapping either values with early return on error
|
|
(define-syntax with-either
|
|
(syntax-rules ()
|
|
[(_ default [pat expr])
|
|
(match expr
|
|
[(right pat) pat]
|
|
[_ default])]
|
|
[(_ default [pat expr] [pat2 expr2] ...)
|
|
(match expr
|
|
[(right pat) (with-either default [pat2 expr2] ...)]
|
|
[_ default])])))
|