aboutsummaryrefslogtreecommitdiff
path: root/control
diff options
context:
space:
mode:
Diffstat (limited to 'control')
-rw-r--r--control/monad.scm69
-rw-r--r--control/monad/procedures.scm33
-rw-r--r--control/monad/state.scm83
3 files changed, 0 insertions, 185 deletions
diff --git a/control/monad.scm b/control/monad.scm
deleted file mode 100644
index 4b756c7..0000000
--- a/control/monad.scm
+++ /dev/null
@@ -1,69 +0,0 @@
-(define-module (control monad)
- #:use-module (control monad procedures)
- #:use-module (srfi srfi-1)
- #:use-module (ice-9 match)
- #:use-module (ice-9 curried-definitions)
- #:replace (do)
- #:export (sequence mapM
- fmap <$> cmap <*>)
- #:re-export (>> >>= return))
-
-(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)))
diff --git a/control/monad/procedures.scm b/control/monad/procedures.scm
deleted file mode 100644
index 707dc0b..0000000
--- a/control/monad/procedures.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-(define-module (control monad procedures)
- #:use-module (oop goops)
- #:use-module (srfi srfi-1) ; concatenate!
- #:export (>> >>= 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
diff --git a/control/monad/state.scm b/control/monad/state.scm
deleted file mode 100644
index b5fefe3..0000000
--- a/control/monad/state.scm
+++ /dev/null
@@ -1,83 +0,0 @@
-(define-module (control monad state)
- #:use-module (oop goops)
- #:use-module (ice-9 match)
- #:use-module (control monad)
- #:export (return-state run-state get put modify)
- #:re-export (>>= >> fmap return))
-
-
-;; Alternative implementation of get.
-;; See https://hackage.haskell.org/package/mtl-2.2.1/docs/src/Control.Monad.State.Class.html#get
-
-;;; newtype State = st-list -> st-list
-
-;;; state procedure <=> st-list -> st-list
-;;; state list <=> (list ret st)
-
-;;; Wrapper around a procedure with signature:
-;;; (st-list -> st-list). Wrapped to allow goops
-;;; multiple dispatch to do its thing.
-(define-class <state> ()
- (proc #:init-keyword #:proc
- #:getter proc))
-
-;; (st-list -> st-list) -> State
-(define (make-state proc)
- "Creates a state object from a State procedure"
- (make <state> #:proc proc))
-
-;;; Define a procedure which is in the state monad. This means that it takes a
-;;; state list as a curried argument, and it's return is wrappen in a <state>
-;;; object.
-;;; It's fully possible to create stateful objects without these macros, but it's
-;;; ill adviced since that would just be boilerplate.
-
-(define-syntax-rule (define-stateful ((proc args ...) st) body ...)
- (define (proc args ...)
- (make-state
- (lambda (st) body ...))))
-
-(define-syntax-rule (define-stateful-method ((proc args ...) st) body ...)
- (define-method (proc args ...)
- (make-state
- (lambda (st) body ...))))
-
-(define-stateful-method ((>>= (st <state>) (f <procedure>)) st-list)
- (let ((new-st-list ((proc st) st-list)))
- (match new-st-list
- ((v _)
- ((proc (f v)) new-st-list)))))
-
-;; (define-stateful-method ((>> (a <state>) (b <state>)) st-list-a)
-;; (let ((st-list-b ((proc a) st-list-a)))
-;; ((proc b) st-list-b)))
-
-(define-stateful ((return-state v) st-list)
- "Sets the return value to v"
- (cons v (cdr st-list)))
-
-(define-method (return (a <state>)) return-state)
-
-(define-stateful ((get) st-list)
- "Sets the return value of state to st."
- (match st-list
- ((_ st)
- (list st st))))
-
-(define-stateful ((put v) st-list)
- "Sets st to v."
- (list '() v))
-
-(define-stateful ((modify proc) st-list)
- (match st-list
- ((r s)
- (list '() (proc s)))))
-
-;; (define-stateful-method ((fmap (f <procedure>) (s <state>)) st-list)
-;; (match ((proc s) st-list)
-;; ((r st)
-;; (list (f r) st))))
-
-(define-method (run-state (st <state>) init)
- "Exec state with init as starting state value and st."
- ((proc st) (list init init)))