diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 27416e0f89..a3e5ba810f 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/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 -math.order classes.tuple.private classes combinators colors ; +prettyprint.backend.callables quotations io io.pathnames io.styles +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: compose >pprint-sequence ; +M: callable >pprint-sequence simplify-callable ; M: hashtable >pprint-sequence >alist ; M: wrapper >pprint-sequence wrapped>> 1array ; M: callstack >pprint-sequence callstack>array ; diff --git a/basis/prettyprint/backend/callables/authors.txt b/basis/prettyprint/backend/callables/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/prettyprint/backend/callables/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/prettyprint/backend/callables/callables-tests.factor b/basis/prettyprint/backend/callables/callables-tests.factor new file mode 100644 index 0000000000..de5b8a073a --- /dev/null +++ b/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 diff --git a/basis/prettyprint/backend/callables/callables.factor b/basis/prettyprint/backend/callables/callables.factor new file mode 100644 index 0000000000..19350b6b51 --- /dev/null +++ b/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 + += [ ] 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 ; diff --git a/basis/prettyprint/backend/callables/summary.txt b/basis/prettyprint/backend/callables/summary.txt new file mode 100644 index 0000000000..870a5fa64d --- /dev/null +++ b/basis/prettyprint/backend/callables/summary.txt @@ -0,0 +1 @@ +Quotation simplification for prettyprinting automatically-constructed callable objects