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.

---
 state-monad.scm | 197 --------------------------------------------------------
 1 file changed, 197 deletions(-)

(limited to 'state-monad.scm')

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