diff options
Diffstat (limited to 'control')
-rw-r--r-- | control/monad.scm | 69 | ||||
-rw-r--r-- | control/monad/procedures.scm | 33 | ||||
-rw-r--r-- | control/monad/state.scm | 83 |
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))) |