From e650a80856edc1d1df1f163c3f84082455717fa0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 18 Mar 2019 18:43:51 +0100
Subject: Compleately redid file structure.

---
 monad.scm | 100 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 100 insertions(+)
 create mode 100644 monad.scm

(limited to 'monad.scm')

diff --git a/monad.scm b/monad.scm
new file mode 100644
index 0000000..97f4af6
--- /dev/null
+++ b/monad.scm
@@ -0,0 +1,100 @@
+(define-module (monad)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 curried-definitions)
+  #:use-module (oop goops)
+  #:replace (do)
+  #:export (sequence mapM
+                     fmap <$> cmap <*>
+                     >> >>= return))
+
+(define-generic return)
+(define-method (return (a <top>)) identity)
+(define-method (return (a <pair>)) list)
+
+(define-generic >>=)
+
+(define-method (>>= (a <top>) (proc <procedure>))
+  (proc a))
+
+(define-method (>>= (this <null>) proc) '())
+(define-method (>>= (this <pair>)
+                    (proc <procedure>))
+  (concatenate! (map proc this)))
+
+(define-generic >>)
+
+(define-method (>> (a <top>) (b <top>))
+  (>>= a (lambda args b)))
+
+(define-method (>> (a <null>) (b <null>)) '())
+(define-method (>> (a <pair>) (b <null>)) '())
+(define-method (>> (a <null>) (b <pair>)) '())
+(define-method (>> (a <pair>) (b <pair>))
+  (concatenate! (map (const b) a)))
+
+;; 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-syntax do
+  (syntax-rules (<- let =)
+    ((_ let ptrn = val rest ...)
+     (match val
+       (ptrn (do rest ...))))
+    ((_ ptrn <- val rest ...)
+     (>>= val (match-lambda (ptrn (do rest ...)))))
+    ((_ a) a) ; Base case
+    ((_ token rest ...)
+     (>> token (do rest ...)))))
+
+;;; ----------------------------------------
+
+(define (fmap f m)
+  (>>= m (lambda (x) ((return m) (f x)))))
+
+(define <$> fmap)
+
+;; Curried map
+(define (cmap f)
+  (lambda (m) (fmap f m)))
+
+(define (<*> f_ i_)
+  (do f <- f_
+      i <- i_
+      ((return f_) (f i))))
+
+;;; ----------------------------------------
+
+;; This makes all curly infix operators be left associative,
+;; discarding regular order of operations.
+;; It does however work in my below example where I do
+;; > f <$> a <*> b
+;; Which is all that really matters.
+(define-syntax $nfx$
+  (syntax-rules ()
+    ((_ single) single)
+    ((_ a * b rest ...)
+     ($nfx$ (* a b) rest ...))))
+
+;; sequence :: (list (M a)) → M (list a)
+(define (sequence in-list)
+  "Evaluate each monadic action in the structure from left to right, and collect
+the results. For a version that ignores the results see sequence_.
+https://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Monad.html#g:4"
+  (define ((f done) item) (append done (list item)))
+  (fold (lambda (m-item m-done)
+          #!curly-infix { f <$> m-done <*> m-item })
+        ;; TODO this fails on a list of length 0
+        ((return (car in-list)) '())
+        in-list))
+
+;; mapM :: (a -> M b) x (list a) → M (list b)
+(define (mapM proc items)
+  "Map each element of a structure to a monadic action, evaluate these actions from
+left to right, and collect the results. For a version that ignores the results
+see mapM_.
+https://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Monad.html#g:4"
+  (sequence (map (lambda (x) (>>= x proc)) items)))
-- 
cgit v1.2.3