From d6377ddd8f4a88cd07fdd927f78d7e5a90c13f5d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@hornquist.se>
Date: Sat, 10 Nov 2018 17:09:57 +0100
Subject: Move stuff into modules.

---
 control/monad.scm            |  39 +++++++++
 control/monad/procedures.scm |  17 ++++
 data/either.scm              |  28 ++++++
 data/monoid.scm              |  25 ++++++
 data/optional.scm            |  81 ++++++++++++++++++
 data/writer.scm              |  28 ++++++
 examples.scm                 |  61 ++++++++++++++
 state-monad.scm              | 197 -------------------------------------------
 8 files changed, 279 insertions(+), 197 deletions(-)
 create mode 100644 control/monad.scm
 create mode 100644 control/monad/procedures.scm
 create mode 100644 data/either.scm
 create mode 100644 data/monoid.scm
 create mode 100644 data/optional.scm
 create mode 100644 data/writer.scm
 create mode 100644 examples.scm

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 '<-
-- 
cgit v1.2.3