Paste: fusion experiment

! Copyright (C) 2016 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes combinators.short-circuit
constructors fry io kernel macros multiline parser
prettyprint.custom quotations sequences sequences.private
vectors words ;
QUALIFIED: multi-methods
IN: fusion

TUPLE: super-sequence sequences ;
CONSTRUCTOR: <super-sequence> super-sequence ( sequences -- obj ) ;

TUPLE: super-callable < super-sequence ;
: <super-callable> ( sequences -- obj )
    super-callable new
        swap >vector >>sequences ; inline

! INSTANCE: super-callable callable

: nth-sequence ( n super-sequence -- obj ) sequences>> nth ; inline
: each-sequence ( super-sequence quot -- obj ) [ sequences>> ] dip each ; inline
: map-sequence ( super-sequence quot -- obj ) [ sequences>> ] dip map ; inline
! : call-each ( super-sequence -- ... ) [ sequences>> ] dip [ call ] each ; inline

<<
TUPLE: combinator quotation ;

TUPLE: map < combinator ;
CONSTRUCTOR: <map> map ( quotation -- obj ) ;

TUPLE: map! < combinator ;
CONSTRUCTOR: <map!> map! ( quotation -- obj ) ;

TUPLE: 2map < combinator ;
CONSTRUCTOR: <2map> 2map ( quotation -- obj ) ;

TUPLE: filter < combinator ;
CONSTRUCTOR: <filter> filter ( quotation -- obj ) ;

TUPLE: filter! < combinator ;
CONSTRUCTOR: <filter!> filter! ( quotation -- obj ) ;

TUPLE: each < combinator ;
CONSTRUCTOR: <each> each ( quotation -- obj ) ;
>>

! M: combinator call quotation>> call ; inline

<<
M: combinator length quotation>> length ;
M: combinator nth-unsafe quotation>> nth-unsafe ;
M: combinator pprint-delims class-of name>> "[" append "fusion" lookup-word \ ] ;
>>
<<
! INSTANCE: super-sequence callable  ! this breaks prettyprinting unless more than pprint-delims is defined

INSTANCE: map callable
INSTANCE: map! callable
INSTANCE: 2map callable
INSTANCE: filter callable
INSTANCE: filter! callable
INSTANCE: each callable
>>

<<
SYNTAX: map[ parse-quotation <map> suffix! ;
SYNTAX: map![ parse-quotation <map!> suffix! ;
SYNTAX: 2map[ parse-quotation <2map> suffix! ;
SYNTAX: filter[ parse-quotation <filter> suffix! ;
SYNTAX: filter![ parse-quotation <filter!> suffix! ;
SYNTAX: each[ parse-quotation <each> suffix! ;
>>

! GENERIC: callable>quotation ( obj -- quot )
! M: callable callable>quotation ;
! M: combinator callable>quotation quotation>> ;

M: map call quotation>> sequences:map ;
M: map! call quotation>> sequences:map! ;
M: 2map call quotation>> sequences:2map ;
M: filter call quotation>> sequences:filter ;
M: filter! call quotation>> sequences:filter! ;
M: each call quotation>> sequences:each ;

GENERIC: combinator>quotation ( obj -- quot )
M: map combinator>quotation quotation>> [ sequences:map ] curry ;
M: map! combinator>quotation quotation>> [ sequences:map! ] curry ;
M: 2map combinator>quotation quotation>> [ sequences:2map ] curry ;
M: filter combinator>quotation quotation>> [ sequences:filter ] curry ;
M: filter! combinator>quotation quotation>> [ sequences:filter! ] curry ;
M: each combinator>quotation quotation>> [ sequences:each ] curry ;


! can't do this because of stack-checker
! M: super-callable call sequences>> [ call ] each ;

! BUG: multi-methods don't forget enough methods
multi-methods:GENERIC: 2fuse ( obj1 obj2 -- quot )

multi-methods:METHOD: 2fuse { quotation combinator } [ compose ] change-quotation ;
multi-methods:METHOD: 2fuse { curry combinator } [ compose ] change-quotation ;
multi-methods:METHOD: 2fuse { compose combinator } [ compose ] change-quotation ;

multi-methods:METHOD: 2fuse { super-callable map } '[ [ pop _ 2fuse ] keep [ push ] keep ] change-sequences ;
multi-methods:METHOD: 2fuse { super-callable filter } '[ [ pop _ 2fuse ] keep [ push ] keep ] change-sequences ;

multi-methods:METHOD: 2fuse { map map } [ quotation>> ] bi@ compose <map> ;
multi-methods:METHOD: 2fuse { map filter } 2array <super-callable> ;
multi-methods:METHOD: 2fuse { filter filter } [ quotation>> ] bi@ 2array '[ _ 1&& ] <filter> ;
! multi-methods:METHOD: 2fuse { map each } [ callable>quotation ] bi@ compose <each> ;


MACRO: fuse-call ( seq -- quot' )
    [ ] [ 2fuse ] reduce
    [ combinator>quotation ] map-sequence
    [ ] [ compose ] reduce ;