simplify dip/call/curry/compose in callable objects before prettyprinting

basis/prettyprint/backend/backend.factor

@@ -3,8 +3,9 @@
 USING: accessors arrays byte-arrays byte-vectors generic hashtables
 assocs kernel math namespaces make sequences strings sbufs vectors
 words prettyprint.config prettyprint.custom prettyprint.sections
-quotations io io.pathnames io.styles math.parser effects classes.tuple
+prettyprint.backend.callables quotations io io.pathnames io.styles
-math.order classes.tuple.private classes combinators colors ;
+math.parser effects classes.tuple math.order classes.tuple.private
+classes combinators colors ;
 IN: prettyprint.backend
 
 M: effect pprint* effect>string "(" ")" surround text ;
@@ -177,8 +178,7 @@ M: callstack pprint-delims drop \ CS{ \ } ;
 M: object >pprint-sequence ;
 M: vector >pprint-sequence ;
 M: byte-vector >pprint-sequence ;
-M: curry >pprint-sequence ;
+M: callable >pprint-sequence simplify-callable ;
-M: compose >pprint-sequence ;
 M: hashtable >pprint-sequence >alist ;
 M: wrapper >pprint-sequence wrapped>> 1array ;
 M: callstack >pprint-sequence callstack>array ;

basis/prettyprint/backend/callables/authors.txt

@@ -0,0 +1 @@
+Joe Groff

basis/prettyprint/backend/callables/callables-tests.factor

@@ -0,0 +1,15 @@
+! (c) 2009 Joe Groff bsd license
+USING: kernel math prettyprint prettyprint.backend.callables
+tools.test ;
+IN: prettyprint.backend.callables
+
+[ [ dip ] ] [ [ dip ] simplify-callable ] unit-test
+[ [ [ + ] dip ] ] [ [ [ + ] dip ] simplify-callable ] unit-test
+[ [ + 5 ] ] [ [ 5 [ + ] dip ] simplify-callable ] unit-test
+[ [ + ] ] [ [ [ + ] call ] simplify-callable ] unit-test
+[ [ call ] ] [ [ call ] simplify-callable ] unit-test
+[ [ 5 + ] ] [ [ 5 [ + ] curry call ] simplify-callable ] unit-test
+[ [ 4 5 + ] ] [ [ 4 5 [ + ] 2curry call ] simplify-callable ] unit-test
+[ [ 4 5 6 + ] ] [ [ 4 5 6 [ + ] 3curry call ] simplify-callable ] unit-test
+[ [ + . ] ] [ [ [ + ] [ . ] compose call ] simplify-callable ] unit-test
+[ [ . + ] ] [ [ [ + ] [ . ] prepose call ] simplify-callable ] unit-test

basis/prettyprint/backend/callables/callables.factor

@@ -0,0 +1,72 @@
+! (c) 2009 Joe Groff bsd license
+USING: combinators combinators.short-circuit generalizations
+kernel macros math math.ranges quotations sequences words ;
+IN: prettyprint.backend.callables
+
+<PRIVATE
+
+CONSTANT: simple-combinators { dip call curry 2curry 3curry compose prepose }
+
+: literal? ( obj -- ? ) word? not ;
+
+MACRO: slice-match? ( quots -- quot: ( seq end -- ? ) )
+    dup length
+    [ 0 [a,b) [ [ - swap nth ] swap prefix prepend ] 2map ]
+    [ nip \ nip swap \ >= [ ] 3sequence ] 2bi
+    prefix \ 2&& [ ] 2sequence ;
+
+: end-len>from-to ( seq end len -- from to seq )
+    [ - ] [ drop 1 + ] 2bi rot ;
+
+: slice-change ( seq end len quot -- seq' )
+    [ end-len>from-to ] dip
+    [ [ subseq ] dip call ] curry
+    [ replace-slice ] 3bi ; inline
+
+: when-slice-match ( seq i criteria quot -- seq' )
+    [ [ 2dup ] dip slice-match? ] dip [ drop ] if ; inline
+    
+: simplify-dip ( quot i -- quot' )
+    { [ literal? ] [ callable? ] }
+    [ 2 [ first2 swap suffix ] slice-change ] when-slice-match ;
+
+: simplify-call ( quot i -- quot' )
+    { [ callable? ] }
+    [ 1 [ first ] slice-change ] when-slice-match ;
+
+: simplify-curry ( quot i -- quot' )
+    { [ literal? ] [ callable? ] }
+    [ 2 [ first2 swap prefix 1quotation ] slice-change ] when-slice-match ;
+
+: simplify-2curry ( quot i -- quot' )
+    { [ literal? ] [ literal? ] [ callable? ] }
+    [ 3 [ [ 2 head ] [ third ] bi append 1quotation ] slice-change ] when-slice-match ;
+
+: simplify-3curry ( quot i -- quot' )
+    { [ literal? ] [ literal? ] [ literal? ] [ callable? ] }
+    [ 4 [ [ 3 head ] [ fourth ] bi append 1quotation ] slice-change ] when-slice-match ;
+
+: simplify-compose ( quot i -- quot' )
+    { [ callable? ] [ callable? ] }
+    [ 2 [ first2 append 1quotation ] slice-change ] when-slice-match ;
+
+: simplify-prepose ( quot i -- quot' )
+    { [ callable? ] [ callable? ] }
+    [ 2 [ first2 swap append 1quotation ] slice-change ] when-slice-match ;
+
+: (simplify-callable) ( quot -- quot' )
+    dup [ simple-combinators member? ] find {
+        { \ dip     [ simplify-dip     ] }
+        { \ call    [ simplify-call    ] }
+        { \ curry   [ simplify-curry   ] }
+        { \ 2curry  [ simplify-2curry  ] }
+        { \ 3curry  [ simplify-3curry  ] }
+        { \ compose [ simplify-compose ] }
+        { \ prepose [ simplify-prepose ] }
+        [ 2drop ]
+    } case ;
+
+PRIVATE>
+
+: simplify-callable ( quot -- quot' )
+    [ (simplify-callable) ] to-fixed-point ;

basis/prettyprint/backend/callables/summary.txt

@@ -0,0 +1 @@
+Quotation simplification for prettyprinting automatically-constructed callable objects