From af5e5611dceb9c625ba085ab2f2238e56da3f6ef Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 18:59:30 -0600
Subject: [PATCH] Better invalid callable check
---
basis/prettyprint/backend/backend.factor | 16 +++++++++++++---
basis/prettyprint/prettyprint-tests.factor | 5 +++++
2 files changed, 18 insertions(+), 3 deletions(-)
diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor
index 31b6ba3f26..2af0224e32 100644
--- a/basis/prettyprint/backend/backend.factor
+++ b/basis/prettyprint/backend/backend.factor
@@ -217,14 +217,24 @@ M: vector pprint* pprint-object ;
M: byte-vector pprint* pprint-object ;
M: hashtable pprint* pprint-object ;
+GENERIC: valid-callable? ( obj -- ? )
+
+M: object valid-callable? drop f ;
+
+M: quotation valid-callable? drop t ;
+
+M: curry valid-callable? quot>> valid-callable? ;
+
+M: compose valid-callable?
+ [ first>> ] [ second>> ] bi [ valid-callable? ] both? ;
+
M: curry pprint*
- dup quot>> callable? [ pprint-object ] [
+ dup valid-callable? [ pprint-object ] [
"( invalid curry )" swap present-text
] if ;
M: compose pprint*
- dup [ first>> callable? ] [ second>> callable? ] bi and
- [ pprint-object ] [
+ dup valid-callable? [ pprint-object ] [
"( invalid compose )" swap present-text
] if ;
diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor
index 8eaaab3c1d..7fa3c5a1a3 100644
--- a/basis/prettyprint/prettyprint-tests.factor
+++ b/basis/prettyprint/prettyprint-tests.factor
@@ -365,3 +365,8 @@ M: started-out-hustlin' ended-up-ballin' ; inline
[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
[ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer
] unit-test
+
+[ "( invalid curry )" ] [ 1 2 curry unparse ] unit-test
+[ "( invalid curry )" ] [ 1 2 3 curry curry unparse ] unit-test
+[ "( invalid compose )" ] [ 1 2 compose unparse ] unit-test
+[ "( invalid compose )" ] [ [ 1 ] 2 3 curry compose unparse ] unit-test