From 57b5d417dad8d6e74b19879805d24e82dc13bd01 Mon Sep 17 00:00:00 2001 From: AlexKnauth Date: Thu, 24 Sep 2015 15:17:51 -0400 Subject: [PATCH] fix possible loops with fallback methods These would come up if someone defined a struct that declared only lens-view or only lens-set, or no methods at all. --- lens/private/base/gen-lens.rkt | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/lens/private/base/gen-lens.rkt b/lens/private/base/gen-lens.rkt index cfbd51a..d29d074 100644 --- a/lens/private/base/gen-lens.rkt +++ b/lens/private/base/gen-lens.rkt @@ -19,15 +19,24 @@ (lens-view lens target) (lens-set lens target x) (focus-lens lens target) + #:defined-predicate lens-implements? #:fallbacks [(define/generic gen-lens-view lens-view) (define/generic gen-lens-set lens-set) + (define/generic gen-focus-lens focus-lens) (define (lens-view lens target) - (let-lens (view _) lens target view)) + (unless (lens-implements? lens 'focus-lens) + (error 'lens-view "not implemented for ~v" lens)) + (let-values ([(view _) (gen-focus-lens lens target)]) + view)) (define (lens-set lens target x) - (let-lens (_ setter) lens target + (unless (lens-implements? lens 'focus-lens) + (error 'lens-set "not implemented for ~v" lens)) + (let-values ([(_ setter) (gen-focus-lens lens target)]) (setter x))) (define (focus-lens lens target) + (unless (lens-implements? lens 'lens-view 'lens-set) + (error 'focus-lens "not implemented for ~v" lens)) (values (gen-lens-view lens target) (gen-lens-set lens target _)))] #:derive-property prop:procedure