diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2019-03-18 18:43:51 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2019-03-18 18:43:51 +0100 |
commit | e650a80856edc1d1df1f163c3f84082455717fa0 (patch) | |
tree | 4848ad975d95f5765980980d0e10ed0752e553f9 /monad.scm | |
parent | Assorted comments and cleanup. (diff) | |
download | scheme-monad-e650a80856edc1d1df1f163c3f84082455717fa0.tar.gz scheme-monad-e650a80856edc1d1df1f163c3f84082455717fa0.tar.xz |
Compleately redid file structure.
Diffstat (limited to 'monad.scm')
-rw-r--r-- | monad.scm | 100 |
1 files changed, 100 insertions, 0 deletions
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))) |