aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorHugo Hörnquist <hugo@hornquist.se>2018-11-10 17:09:57 +0100
committerHugo Hörnquist <hugo@hornquist.se>2018-11-10 17:09:57 +0100
commitd6377ddd8f4a88cd07fdd927f78d7e5a90c13f5d (patch)
treee271c3c9e07c75eac76da0e8ae9767407d967a5b
parentFurther work. (diff)
downloadscheme-monad-d6377ddd8f4a88cd07fdd927f78d7e5a90c13f5d.tar.gz
scheme-monad-d6377ddd8f4a88cd07fdd927f78d7e5a90c13f5d.tar.xz
Move stuff into modules.
-rw-r--r--control/monad.scm39
-rw-r--r--control/monad/procedures.scm17
-rw-r--r--data/either.scm28
-rw-r--r--data/monoid.scm25
-rw-r--r--data/optional.scm81
-rw-r--r--data/writer.scm28
-rw-r--r--examples.scm61
-rw-r--r--state-monad.scm197
8 files changed, 279 insertions, 197 deletions
diff --git a/control/monad.scm b/control/monad.scm
new file mode 100644
index 0000000..e5dc89d
--- /dev/null
+++ b/control/monad.scm
@@ -0,0 +1,39 @@
+(define-module (control monad)
+ #:use-module (control monad procedures)
+ ;; #:use-module (control monad syntax)
+ #:export (do <-)
+ ;; #:re-export (>>= do <-)
+ )
+
+(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/control/monad/procedures.scm b/control/monad/procedures.scm
new file mode 100644
index 0000000..701f871
--- /dev/null
+++ b/control/monad/procedures.scm
@@ -0,0 +1,17 @@
+(define-module (control monad procedures)
+ #:use-module (oop goops)
+ #:use-module (srfi srfi-1) ; concatenate!
+ #:export (>>=))
+
+(define-generic >>=)
+
+(define-method (>>= (this <null>)
+ proc)
+ '())
+(define-method (>>= (this <pair>)
+ (proc <procedure>))
+ (concatenate! (map proc this)))
+
+;; bind :: Monad m => m a -> (a -> m b) -> m b
+;; return :: Monad m => a -> m a
+;; map :: Functor f => (a -> b) -> f a -> f b
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))))
diff --git a/examples.scm b/examples.scm
new file mode 100644
index 0000000..a2f2319
--- /dev/null
+++ b/examples.scm
@@ -0,0 +1,61 @@
+;; (read-enable 'curly-infix)
+
+;;; Examples:
+;;; These are do in the conext of the optional monad.
+
+(add-to-load-path (dirname (current-filename)))
+
+(use-modules (control monad)
+ (data monoid)
+ (data optional)
+ (data writer))
+
+(do (just x) <- (just 10)
+ x) ; => 10
+
+(do let y = (just 10)
+ (just x) <- y
+ (+ x 5)) ; => 15
+
+(do (just x) <- (nothing)
+ (+ x 5)) ; => [Nothing]
+
+;;;
+
+(do let either = left 10
+ (left x) <- either
+ x) ; EVALUATION ERROR
+
+;; Int -> Writer Int String
+(define (log-number n)
+ (writer n (format #f "Got nuber: ~a" n)))
+
+(define (mult-with-log)
+ (do (writer a) <- (log-number 3)
+ (writer b) <- (log-number 5)
+ (* a b)))
+
+(do (writer a) <- (log-number 1)
+ a) ; EVALUATION ERROR
+
+(begin { (log-number 1) >>= log-number })
+;; => [Writer 1, "Got nuber: 1, Got nuber: 1"]
+
+(do (writer a) <- (log-number 3)
+ (writer b) <- (log-number 5)
+ (writer (* a b) ""))
+;; EVALUATION ERROR
+;; => [Writer 3, "Got nuber: 3, base"]
+
+(log-number 3) ; => [Writer 3, "Got nuber: 3"]
+(just 1) ; => [Just 1]
+
+(do let y = 5
+ (just x) <- (just 10)
+ (just (* x y)))
+;; => [Just 50]
+
+;;; TODO
+;;; '<- and 'let can't be used after '<-
+
+
diff --git a/state-monad.scm b/state-monad.scm
index eaafe30..e69de29 100644
--- a/state-monad.scm
+++ b/state-monad.scm
@@ -1,197 +0,0 @@
-(read-enable 'curly-infix)
-
-(use-modules (oop goops)
- (oop goops describe)
- (ice-9 match)
- (srfi srfi-1))
-
-(define-class <monoid> ())
-
-(define-generic null)
-(define-generic mappend)
-
-(define (<> . args)
- (fold mappend (null (car args)) (reverse args)))
-
-(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>)) '())
-
-(define-macro (null type)
- (symbol-append type '-null))
-
-(define-class <applicative> ())
-(define-generic map)
-
-(define-class <monad> (<applicative> <monoid>))
-(define-generic bind)
-#; (define-generic 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-method (write (this <optional>) port)
- (if (just? this)
- (format port "[Just ~s]" (slot-ref this 'slot))
- (format port "[Nothing]")))
-
-(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)
-(define return-optional just)
-
-;; bind :: Monad m => m a -> (a -> m b) -> m b
-;; return :: Monad m => a -> m a
-;; map :: Functor f => (a -> b) -> f a -> f b
-
-(define-method (>>= (this <optional>)
- (proc <procedure>))
- (cond ((nothing? this) (nothing))
- ((just? this)
- (match this
- (($ <optional> slot) (proc slot))))))
-
-(define-method (>>= (this <null>)
- proc)
- '())
-
-(define-method (>>= (this <pair>)
- (proc <procedure>))
- (concatenate! (map proc this)))
-
-(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))))
-
-(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 <-
- (lambda (x)
- (syntax-case x (just left right 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 ...))))))
-
-;;; Examples:
-;;; These are do in the conext of the optional monad.
-
-(do (just x) <- (just 10)
- x) ; => 10
-
-(do let y = (just 10)
- (just x) <- y
- (+ x 5)) ; => 15
-
-(do (just x) <- (nothing)
- (+ x 5)) ; => [Nothing]
-
-;;;
-
-(do let either = left 10
- (left x) <- either
- x) ; EVALUATION ERROR
-
-;; Int -> Writer Int String
-(define (log-number n)
- (writer n (format #f "Got nuber: ~a" n)))
-
-(define (mult-with-log)
- (do (writer a) <- (log-number 3)
- (writer b) <- (log-number 5)
- (* a b)))
-
-(do (writer a) <- (log-number 1)
- a) ; EVALUATION ERROR
-
-(begin { (log-number 1) >>= log-number })
-;; => [Writer 1, "Got nuber: 1, Got nuber: 1"]
-
-(do (writer a) <- (log-number 3)
- (writer b) <- (log-number 5)
- (writer (* a b) ""))
-;; EVALUATION ERROR
-;; => [Writer 3, "Got nuber: 3, base"]
-
-(log-number 3) ; => [Writer 3, "Got nuber: 3"]
-(just 1) ; => [Just 1]
-
-(do let y = 5
- (just x) <- (just 10)
- (just (* x y)))
-;; => [Just 50]
-
-;;; TODO
-;;; '<- and 'let can't be used after '<-