From 4125ecaf950e2aabaddbd6f7a06181908af507d3 Mon Sep 17 00:00:00 2001 From: John Berry Date: Mon, 30 Nov 2015 13:36:04 +0200 Subject: [PATCH] Monadism comes to Heresy MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The first proper additions to the Heresy standard library in some time, Heresy now has a forward-pipe operator `:>`, and a monad-like mini-DSL inspired by the Haskell State monad and do notation. This update also brings `def macroset`, which allows for variadic macro definitions equivalent to Racket’s `syntax-rules`. --- examples/monadish.hsy | 14 ++++---- lib/monadish.rkt | 79 +++++++++++++++++++++++++++++++++++++++++++ main.rkt | 6 ++-- private/base.rkt | 11 ++++-- 4 files changed, 99 insertions(+), 11 deletions(-) create mode 100644 lib/monadish.rkt diff --git a/examples/monadish.hsy b/examples/monadish.hsy index 9d5bcc5..b49f62b 100644 --- a/examples/monadish.hsy +++ b/examples/monadish.hsy @@ -17,19 +17,19 @@ (def macro pass (f . args) (fn (s) - (f . args) - s)) + (f . args) + s)) (def macro use ((name ...) body ...) (fn (s) - (let ([name (s (quote name))] ...) - body ... - s))) + (let ([name (s (quote name))] ...) + body ... + s))) (def macro ->from ((name ...) var val) (fn (s) - (let ([name (s (quote name))] ...) - (thing extends s (var val))))) + (let ([name (s (quote name))] ...) + (thing extends s (var val))))) (do> (-> x 5) (-> y 4) diff --git a/lib/monadish.rkt b/lib/monadish.rkt new file mode 100644 index 0000000..4cfc050 --- /dev/null +++ b/lib/monadish.rkt @@ -0,0 +1,79 @@ +#lang s-exp "../private/base.rkt" + +(import "./things.rkt") +(provide (all-defined-out)) + +; (:> *initial-value* *fn1* ...) +; The forward pipe operator. Given an initial value and a list of one-argument functions +; applys functions in order from left to right and returns the result +(def fn :> (initial-value . fns) + (for (f in fns with initial-value) + (carry (f cry)))) + +; State +; A handy empty object for use as a State store +(describe State (new (fn () State))) + +; (:= [(*names* ...)] *var* *value*) +; State -> State +; Binds a new value to var in State. Can overwrite previous values +; If *names* are provided, they are bound in the scope for use in value clause +(def macroset := + [(:= (name ...) var value) + (fn (s) + (let ([name (s (quote name))] ...) + (thing extends s (var value))))] + [(:= var value) + (fn (s) (thing extends s (var value)))]) + +; (:_ [(*names* ...)] *fn* *args* ...) +; State -> State +; Executes fn with args, optionally binding names to the local scope for use in by fn, then ignores their return value and returns State +(def macroset :_ + [(:_ (name ...) body ...) + (fn (s) + (let ([name (s (quote name))] ...) + body ... + s))] + [(:_ f args ...) + (fn (s) + (f args ...) + s)]) + +; (return *value*) +; State -> value +; Returns the given value from State +; Always use last +(def macro return (name) + (fn (s) (s (quote name)))) + +; (do> *actions* ...) +; A useful shortcut for using State with :> +(def fn do> fns + (apply :> (join State fns))) + +; (f> *fn* *args* ...) +; For currying fns for :>. Returns a function that takes initial-value and applies it as the first argument of fn +(def macro f> (f args ...) + (fn (x) + (f x args ...))) + +; (l> *fn* *args* ...) +; The inverse of f>, returns a function that takes a value and applies it as the last argument of fn +(def macro l> (f args ...) + (fn (x) + (f args ... x))) + +; (-> *value* *fns* ...) +; The first-argument threading macro. Takes value, and threads it in turn as the first argument of the following functions +(def macro -> (iv (f args ...) ...) + (:> iv + (f> f args ...) + ...)) + +; (->> *value* *fns* ...) +; The last-argument version of ->. Takes a value, and threads it in turn as the last argument of successive functions +(def macro ->> (iv (f args ...) ...) + (:> iv + (l> f args ...) + ...)) \ No newline at end of file diff --git a/main.rkt b/main.rkt index 45b4492..5371ea7 100644 --- a/main.rkt +++ b/main.rkt @@ -11,7 +11,8 @@ "./lib/math.rkt" "./lib/theory.rkt" "./lib/things.rkt" - "./lib/infix-math.rkt") + "./lib/infix-math.rkt" + "./lib/monadish.rkt") ;; Provides (provide (all-from-out "./private/base.rkt" @@ -20,4 +21,5 @@ "./lib/math.rkt" "./lib/theory.rkt" "./lib/things.rkt" - "./lib/infix-math.rkt")) + "./lib/infix-math.rkt" + "./lib/monadish.rkt")) diff --git a/private/base.rkt b/private/base.rkt index 7679278..2b14239 100644 --- a/private/base.rkt +++ b/private/base.rkt @@ -43,7 +43,7 @@ join head tail run one? - (for-syntax ...) + (for-syntax ... _) (rename-out [app #%app])) ;; Declarations @@ -66,9 +66,13 @@ ; (DEF MACRO name (pattern-vars) pattern) ; Defines new variables and functions (with help from FN) (define-syntax def - (syntax-rules (macro fn) + (syntax-rules (macro macroset fn) [(_ macro name (args ... . rest) body0 bodyn ...) (define-syntax-rule (name args ... . rest) body0 bodyn ...)] + [(_ macroset name [(pname ptr0 ptrn ...) (body0 bodyn ...)] ...) + (define-syntax name + (syntax-rules () + [(pname ptr0 ptrn ...) (body0 bodyn ...)] ...))] [(_ fn name (args ... . rest) body0 bodyn ...) (define (name args ... . rest) body0 bodyn ...)] [(_ name contents) (define name contents)])) @@ -77,6 +81,9 @@ (define-syntax-parameter macro (lambda (stx) (raise-syntax-error (syntax-e stx) "macro must be used with def"))) +(define-syntax-parameter macroset + (lambda (stx) + (raise-syntax-error (syntax-e stx) "syntax must be used with def"))) ;(define-syntax-parameter fn ; (lambda (stx) ; (raise-syntax-error (syntax-e stx)