Monadism comes to Heresy

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

@@ -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)

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 ...)
+      ...))

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"))

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)