diff options
Diffstat (limited to 'data')
-rw-r--r-- | data/either.scm | 28 | ||||
-rw-r--r-- | data/monoid.scm | 25 | ||||
-rw-r--r-- | data/optional.scm | 81 | ||||
-rw-r--r-- | data/writer.scm | 28 |
4 files changed, 162 insertions, 0 deletions
diff --git a/data/either.scm b/data/either.scm new file mode 100644 index 0000000..d6e0f73 --- /dev/null +++ b/data/either.scm @@ -0,0 +1,28 @@ +(define-module (data either) + #:use-module (oop goops) + #:use-module (ice-9 match)) + +(define-class <either> () + (slot #:init-keyword #:slot) + (dir #:init-keyword #:dir #:init-value 'left)) + +(define (left val) + "Error values" + (make <either> #:slot val #:dir 'left)) + +(define (right val) + "Good values" + (make <either> #:slot val #:dir 'right)) + +(define-method (write (this <either>) port) + (format port "[~a ~s]" + (slot-ref this 'dir) + (slot-ref this 'slot))) + +(define-method (>>= (this <either>) + (proc <procedure>)) + (case (slot-ref this 'dir) + ((left) this) + ((right) (match this (($ <either> slot) (proc slot)))))) + +(define return-either right) diff --git a/data/monoid.scm b/data/monoid.scm new file mode 100644 index 0000000..45d30cd --- /dev/null +++ b/data/monoid.scm @@ -0,0 +1,25 @@ +(define-module (data monoid) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:export (null mappend <>)) + +(define-generic null) +(define-generic mappend) + +(define (<> . args) + (fold mappend (null (car args)) (reverse args))) + +;;; Lists + +(define-method (mappend (a <pair>) (b <pair>)) + (append a b)) +(define-method (mappend (a <pair>) (b <null>)) a) +(define-method (mappend (a <null>) (b <pair>)) b) +(define-method (mappend (a <null>) (b <null>)) '()) +(define-method (null (a <pair>)) '()) +(define-method (null (a <null>)) '()) + +;;; Strings +(define-method (mappend (a <string>) (b <string>)) + (string-append a b)) +(define-method (null (a <string>)) "") diff --git a/data/optional.scm b/data/optional.scm new file mode 100644 index 0000000..462c01b --- /dev/null +++ b/data/optional.scm @@ -0,0 +1,81 @@ +(define-module (data optional) + #:use-module (oop goops) + #:use-module (ice-9 match) + #:use-module (control monad) + #:export (nothing just + nothing? just? + return-optional + do <-) + ;; #:re-export (>>=) + ) + +(define-class <optional> () + (slot #:init-value #f + #:init-keyword #:slot) + (just #:init-value #t + #:init-keyword #:just)) + +(define (nothing) (make <optional> #:just #f)) + +(define (just obj) (make <optional> + #:just #t + #:slot obj)) + +(define (nothing? this) + (not (slot-ref this 'just))) + +(define (just? this) + (not (nothing? this))) + + +(define-method (write (this <optional>) port) + (if (just? this) + (format port "[Just ~s]" (slot-ref this 'slot)) + (format port "[Nothing]"))) + +(define return-optional just) + +(define-method (>>= (this <optional>) + (proc <procedure>)) + (cond ((nothing? this) (nothing)) + ((just? this) + (match this + (($ <optional> slot) (proc slot)))))) + +#; +(define-method (mappend (a <optional>) (b <optional>)) + (match a + (($ )))) + + +(define-syntax do + (syntax-rules (<- let =) + ((_ let var = val rest ...) + (let ((var val)) (do rest ...))) + ((_ ptrn <- val rest ...) + (<- ptrn val rest ...)) + ((_ a) a) + ((_ token rest ...) + (begin token (do rest ...))))) + +(define-syntax <- + (syntax-rules (just writer) + ((_ (just var) val rest ...) + (>>= val (lambda (var) rest ...))) + ((_ (writer var) val rest ...) + (>>= val (lambda (var) rest ...)))) + + + #; + (lambda (x) + (syntax-case x (just writer) + ((_ (just var) val rest ...) + #'(>>= val (lambda (var) rest ...))) + ((_ (writer var) val rest ...) + #'(>>= val (lambda (var) rest ...))) + #; + ((_ (left var) val rest ...) ; + #'(>>= val (lambda (var) rest ...))) + #; + ((_ (right var) val rest ...) ; + #'(>>= val (lambda (var) rest ...)))))) diff --git a/data/writer.scm b/data/writer.scm new file mode 100644 index 0000000..b79c670 --- /dev/null +++ b/data/writer.scm @@ -0,0 +1,28 @@ +(define-module (data writer) + #:use-module (oop goops) + #:use-module (ice-9 match) + #:use-module (data monoid) + #:use-module (control monad) + #:export (writer)) + +(read-enable 'curly-infix) + +(define-class <writer> () + (value #:init-keyword #:value) + (monoid #:init-keyword #:monoid)) + +(define (writer value context) + (make <writer> + #:value value + #:monoid context)) + +(define-method (>>= (this <writer>) + (proc <procedure>)) + (match this (($ <writer> value monoid) + (match (proc value) + (($ <writer> nval ncontext) + (writer nval { monoid <> ", " <> ncontext })))))) + +(define-method (write (this <writer>) port) + (match this (($ <writer> value monoid) + (format port "[Writer ~s, ~s]" value monoid)))) |