From e650a80856edc1d1df1f163c3f84082455717fa0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 18 Mar 2019 18:43:51 +0100 Subject: Compleately redid file structure. --- monad/either.scm | 30 ++++++++++++++++++++ monad/monoid.scm | 26 +++++++++++++++++ monad/optional.scm | 53 ++++++++++++++++++++++++++++++++++ monad/stack.scm | 24 ++++++++++++++++ monad/state.scm | 83 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ monad/writer.scm | 39 +++++++++++++++++++++++++ 6 files changed, 255 insertions(+) create mode 100644 monad/either.scm create mode 100644 monad/monoid.scm create mode 100644 monad/optional.scm create mode 100644 monad/stack.scm create mode 100644 monad/state.scm create mode 100644 monad/writer.scm (limited to 'monad') diff --git a/monad/either.scm b/monad/either.scm new file mode 100644 index 0000000..c597a60 --- /dev/null +++ b/monad/either.scm @@ -0,0 +1,30 @@ +;;; TODO UNFINISHED + +(define-module (data either) + #:use-module (oop goops) + #:use-module (ice-9 match)) + +(define-class () + (slot #:init-keyword #:slot) + (dir #:init-keyword #:dir #:init-value 'left)) + +(define (left val) + "Error values" + (make #:slot val #:dir 'left)) + +(define (right val) + "Good values" + (make #:slot val #:dir 'right)) + +(define-method (write (this ) port) + (format port "[~a ~s]" + (slot-ref this 'dir) + (slot-ref this 'slot))) + +(define-method (>>= (this ) + (proc )) + (case (slot-ref this 'dir) + ((left) this) + ((right) (match this (($ slot) (proc slot)))))) + +(define return-either right) diff --git a/monad/monoid.scm b/monad/monoid.scm new file mode 100644 index 0000000..4b10a72 --- /dev/null +++ b/monad/monoid.scm @@ -0,0 +1,26 @@ +;;; ??? +(define-module (monad monoid) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:export (null mappend <>)) + +(define-generic null) +(define-generic mappend) + +(define (<> . args) + (fold mappend (null (car args)) (reverse args))) + +;;; Lists + +(define-method (mappend (a ) (b )) + (append a b)) +(define-method (mappend (a ) (b )) a) +(define-method (mappend (a ) (b )) b) +(define-method (mappend (a ) (b )) '()) +(define-method (null (a )) '()) +(define-method (null (a )) '()) + +;;; Strings +(define-method (mappend (a ) (b )) + (string-append a b)) +(define-method (null (a )) "") diff --git a/monad/optional.scm b/monad/optional.scm new file mode 100644 index 0000000..1aa1e92 --- /dev/null +++ b/monad/optional.scm @@ -0,0 +1,53 @@ +(define-module (monad optional) + #:use-module (oop goops) + #:use-module (ice-9 match) + #:use-module (monad) + #:use-module (ice-9 curried-definitions) + #:export (from-just wrap-maybe + nothing just + nothing? just?) + #:re-export (>>= >> return)) + +(define-class () + (slot #:init-value #f + #:init-keyword #:slot) + (just #:init-value #t + #:init-keyword #:just)) + +(define (nothing) (make #:just #f)) + +(define (just obj) (make + #:just #t + #:slot obj)) + +(define (nothing? this) + (not (slot-ref this 'just))) + +(define (just? this) + (not (nothing? this))) + +(define (from-just default maybe-val) + "Returns default if maybe-val is nothing, otherwise +the value embedded in maybe-val" + (if (just? maybe-val) + (slot-ref maybe-val 'slot) + default)) + +(define ((wrap-maybe proc) . values) + "Wraps a function in an optional monad, where #f returns are translated to nothing." + (let ((v (apply proc values))) + (if v (just v) (nothing)))) + +(define-method (write (this ) port) + (if (just? this) + (format port "[Just ~s]" (slot-ref this 'slot)) + (format port "[Nothing]"))) + +(define-method (>>= (this ) + (proc )) + (cond ((nothing? this) (nothing)) + ((just? this) + (match this + (($ slot) (proc slot)))))) + +(define-method (return (a )) just) diff --git a/monad/stack.scm b/monad/stack.scm new file mode 100644 index 0000000..8d25303 --- /dev/null +++ b/monad/stack.scm @@ -0,0 +1,24 @@ +(define-module (monad stack) + #:export (pop peek push) + #:use-module (monad) + #:use-module (monad state)) + +;;; Simple stateful stack module for showing the state monad +;;; in action. These functions assume that they are in a +;;; (state list) monad. But dynamic types! + +;;; TODO test these for empty stack + +(define (pop) + (do st <- (get) + let top = (car st) + (put (cdr st)) + (return-state top))) + +(define (peek) + (do st <- (get) + (return-state (car st)))) + +(define (push v) + (do st <- (get) + (put (cons v st)))) diff --git a/monad/state.scm b/monad/state.scm new file mode 100644 index 0000000..471e756 --- /dev/null +++ b/monad/state.scm @@ -0,0 +1,83 @@ +(define-module (monad state) + #:use-module (oop goops) + #:use-module (ice-9 match) + #:use-module (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 () + (proc #:init-keyword #:proc + #:getter proc)) + +;; (st-list -> st-list) -> State +(define (make-state proc) + "Creates a state object from a State procedure" + (make #: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 +;;; 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 ) (f )) 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 ) (b )) 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 )) 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 ) (s )) st-list) +;; (match ((proc s) st-list) +;; ((r st) +;; (list (f r) st)))) + +(define-method (run-state (st ) init) + "Exec state with init as starting state value and st." + ((proc st) (list init init))) diff --git a/monad/writer.scm b/monad/writer.scm new file mode 100644 index 0000000..8be72c2 --- /dev/null +++ b/monad/writer.scm @@ -0,0 +1,39 @@ +(define-module (monad writer) + #:use-module (oop goops) + #:use-module (ice-9 match) + #:use-module (monad monoid) ; ? + #:use-module (monad) + #:export (writer return-writer)) + +(read-enable 'curly-infix) + +(define-class () + (value #:init-keyword #:value) + (monoid #:init-keyword #:monoid)) + +(define (writer value context) + (make + #:value value + #:monoid context)) + +(define-method (>>= (this ) + (proc )) + (match this (($ value monoid) + (match (proc value) + (($ nval ncontext) + (writer nval { monoid <> ncontext })))))) + +(define-method (>> (a ) + (b )) + (match a (($ _ monoid-a) + (match b (($ val monoid-b) + (writer val (<> monoid-a monoid-b)) + ))))) + +;;; TODO replace this +(define (return-writer val) + (writer val "")) + +(define-method (write (this ) port) + (match this (($ value monoid) + (format port "[Writer ~s, ~s]" value monoid)))) -- cgit v1.2.3