diff options
Diffstat (limited to 'data')
-rw-r--r-- | data/either.scm | 30 | ||||
-rw-r--r-- | data/monoid.scm | 26 | ||||
-rw-r--r-- | data/optional.scm | 53 | ||||
-rw-r--r-- | data/stack.scm | 24 | ||||
-rw-r--r-- | data/writer.scm | 39 |
5 files changed, 0 insertions, 172 deletions
diff --git a/data/either.scm b/data/either.scm deleted file mode 100644 index c597a60..0000000 --- a/data/either.scm +++ /dev/null @@ -1,30 +0,0 @@ -;;; TODO UNFINISHED - -(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 deleted file mode 100644 index d33557e..0000000 --- a/data/monoid.scm +++ /dev/null @@ -1,26 +0,0 @@ -;;; ??? -(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 deleted file mode 100644 index 61543d2..0000000 --- a/data/optional.scm +++ /dev/null @@ -1,53 +0,0 @@ -(define-module (data optional) - #:use-module (oop goops) - #:use-module (ice-9 match) - #:use-module (control monad) - #:use-module (ice-9 curried-definitions) - #:export (from-just wrap-maybe - nothing just - nothing? just?) - #:re-export (>>= >> return)) - -(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 (from-just default maybe-val) - "Returns default if maybe-val is nothing, otherwise -the value embedded in maybe-val" - (if (just? maybe-val) - (slot-ref maybe-val 'slot) - default)) - -(define ((wrap-maybe proc) . values) - "Wraps a function in an optional monad, where #f returns are translated to nothing." - (let ((v (apply proc values))) - (if v (just v) (nothing)))) - -(define-method (write (this <optional>) port) - (if (just? this) - (format port "[Just ~s]" (slot-ref this 'slot)) - (format port "[Nothing]"))) - -(define-method (>>= (this <optional>) - (proc <procedure>)) - (cond ((nothing? this) (nothing)) - ((just? this) - (match this - (($ <optional> slot) (proc slot)))))) - -(define-method (return (a <optional>)) just) diff --git a/data/stack.scm b/data/stack.scm deleted file mode 100644 index d470394..0000000 --- a/data/stack.scm +++ /dev/null @@ -1,24 +0,0 @@ -(define-module (data stack) - #:export (pop peek push) - #:use-module (control monad) - #:use-module (control monad state)) - -;;; Simple stateful stack module for showing the state monad -;;; in action. These functions assume that they are in a -;;; (state list) monad. But dynamic types! - -;;; TODO test these for empty stack - -(define (pop) - (do st <- (get) - let top = (car st) - (put (cdr st)) - (return-state top))) - -(define (peek) - (do st <- (get) - (return-state (car st)))) - -(define (push v) - (do st <- (get) - (put (cons v st)))) diff --git a/data/writer.scm b/data/writer.scm deleted file mode 100644 index bf391c2..0000000 --- a/data/writer.scm +++ /dev/null @@ -1,39 +0,0 @@ -(define-module (data writer) - #:use-module (oop goops) - #:use-module (ice-9 match) - #:use-module (data monoid) - #:use-module (control monad) - #:export (writer return-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 (>> (a <writer>) - (b <writer>)) - (match a (($ <writer> _ monoid-a) - (match b (($ <writer> val monoid-b) - (writer val (<> monoid-a monoid-b)) - ))))) - -;;; TODO replace this -(define (return-writer val) - (writer val "")) - -(define-method (write (this <writer>) port) - (match this (($ <writer> value monoid) - (format port "[Writer ~s, ~s]" value monoid)))) |