[racket] Eval / Lazy Macros followup

On 07/05/2013 07:33 PM, Eli Barzilay wrote:
> I'm not sure that I followed things correctly, but the problem with 
> `mappend' is that it's yet another piece of fuunctionality that needs 
> to be defined in the lazy language to ensure that it's not too strict. 
> If you're just requiring it from `racket/list' ... 

I believe you mean append-map? I mean the monoidal dot/multiply/times, 
called mappend by Haskell. It does though require lazy arguments and 
I've switched everything to #lazy but I seem to be running into problems 
with macros generating proper code, despite them working just fine in 
strict Racket, except for the improper strictness. The main problem is 
I'm left with a promise instead of a value when e.g. using REPL to call 
one of the generated functions. It's possibly related to the expansion 
code using strict begin instead of lazy begin, but lazy begin gave 
errors preventing the macros from even being generated at all, claiming 
define-syntax cannot be used within it (expression not allowed in 
context or something like that).

I don't have github or anything like that, so I apologize in advance for 
pasting here (80 lines total) but I suppose one can just paste it into 
DrRacket. It's not so complex aside from the define-type-class syntax 
portion, but reading anything at all is not required. I like to work on 
many projects in parallel to keep from getting bored, so... But, if 
interested, the *only* changes from the working code (aside from being 
buggy with respect to and/or) is switching to #lazy and the required 
racket/base import to have phase1 stuff.

#lang lazy
(require (for-syntax racket/syntax
(rename-in racket/base (begin !begin)))
(rename-in racket/base (begin !begin)))

(provide
define-type-class
instance-type-class
instance-type-class/sub
using
use-sub
!begin)

(define methods (make-hash))

(define (put! name instance f)
(hash-set! methods (cons name instance) f))

(define (put-default! name f)
(hash-set! methods name f))

(define (get name instance)
(hash-ref methods (cons name instance) (λ () (get-default name))))

(define (get-default name)
(hash-ref methods name (λ () (error "method not defined" name))))

(define (apply-generic name instance . args)
(apply (get name instance) args))

(define-syntax-rule (define-generic (name type-class arg ...))
(define (name arg ...)
(apply-generic 'name (car (type-class)) arg ...)))

(define-syntax-rule (define-default-method (name arg ...) body ...)
(put-default! 'name (λ (arg ...) body ...)))

(define-syntax-rule (define-method (name instance arg ...) body ...)
(put! 'name 'instance (λ (arg ...) body ...)))

(define-syntax (define-type-class stx)
(define (parse-def name d)
(syntax-case d ()
[(generic (arg ...) body ...)
#`(!begin
#,(parse-def name #`(generic arg ...))
(define-default-method (generic arg ...) body ...))]
[(generic arg ...)
#`(define-generic (generic #,name arg ...))]))
(syntax-case stx ()
[(_ name generic-def ...)
(with-syntax ([def-name (format-id stx "define/~a" #'name)])
#`(!begin
(define name (make-parameter #f))
(define-syntax-rule (def-name instance (f a (... ...)) body (... ...))
(define (f a (... ...))
(using ([name instance])
body (... ...))))
#,@(map (λ (d) (parse-def #'name d))
(syntax->list #'(generic-def ...)))))]))

(define-syntax-rule (instance-type-class class-name instance (method 
(arg ...) body ...) ...)
(!begin
(define-method (method instance arg ...)
body ...)
...))

(define-syntax-rule (using ([type-class instance ...] ...) body ...)
(parameterize ([type-class '(instance ...)] ...)
body ...))

(define-syntax-rule (use-sub type-class body ...)
(parameterize ([type-class (cdr (type-class))])
body ...))

(define-syntax-rule (instance-type-class/sub class-name instance (method 
(arg ...) body ...) ...)
(!begin
(define-method (method instance arg ...)
(use-sub class-name body ...))
...))

If any one is still here, here is the monoid module that doesn't work so 
hot with #lazy:

#lang lazy
(require "core.rkt")

(provide (all-defined-out))

(define-type-class monoid
(mempty)
(mappend a b))

(define (mappend* . ms) (foldr mappend (mempty) ms))

(instance-type-class monoid list
(mempty () '())
(mappend (a b) (append a b)))

(instance-type-class/sub monoid result
(mempty () (mempty))
(mappend (a b) (λ (x) (mappend (a x) (b x)))))

(instance-type-class monoid void
(mempty () (void))
(mappend (a b) (void)))

(instance-type-class/sub monoid cons
(mempty () (cons (mempty) (mempty)))
(mappend (a b) (cons (mappend (car a) (car b))
(mappend (cdr a) (cdr b)))))

(instance-type-class/sub monoid dual
(mempty () (mempty))
(mappend (a b) (mappend b a)))

(instance-type-class monoid endo
(mempty () identity)
(mappend (a b) (compose a b)))

(instance-type-class monoid all
(mempty () #t)
(mappend (a b) (and a b)))

(instance-type-class monoid any
(mempty () #f)
(mappend (a b) (or a b)))

(instance-type-class monoid sum
(mempty () 0)
(mappend (a b) (+ a b)))

(instance-type-class monoid product
(mempty () 1)
(mappend (a b) (* a b)))

(instance-type-class/sub monoid maybe
(mempty () #f)
(mappend (a b) (cond [(not a) b]
[(not b) a]
[else (mappend a b)])))

A vigintillion dollars to anyone that can solve this. Payment will be 
provided through Racket:

(define (pay routing acct)
(wire routing acct (promise (dollars (expt 10 63)))))







(define promise (const 'jk))