Paste: Rework Lists vocab

! Copyright (C) 2022 Keldan Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel promises typed parser accessors compiler.units ;
QUALIFIED: sequences
IN: lists.better

! Definition of List

MIXIN: list

SINGLETON: nil
INSTANCE: nil list

TUPLE: cons
    head
    { tail-thunk maybe{ promise } }
    { tail maybe{ list } }
    ;
INSTANCE: cons list

GENERIC: head ( list -- head )
GENERIC: tail ( list -- tail )

! Construction

<PRIVATE

: (cons-list) ( head tail -- list ) f swap \ cons boa ;
: (cons-promise) ( head tail-promise -- list ) f \ cons boa ;

: force-tail ( list -- )
    [ [ tail-thunk>> force ] keep tail<< ]
    [ f swap tail-thunk<< ]
    bi ;

PRIVATE>

TYPED: cons ( head tail: union{ list promise }  -- list )
    dup list? [ (cons-list) ] [ (cons-promise) ] if ;

TYPED: sequence>list ( seq: sequences:sequence -- list )
    sequences:reverse nil [ swap cons ] sequences:reduce ;

SYNTAX: L{ \ } [ sequence>list ] parse-literal ;

M: cons clone
  [ head>> ] [ tail-thunk>> ] [ tail>> ] tri [ clone ] bi@ \ cons boa ;

! Predicates and control
: lazy? ( xs -- ? )
    dup cons? [ tail>> not ] [ drop f ] if ;

: if-nil ( ..a list quot1: ( ..a -- ..b ) quot2: ( ..a list -- ..b ) -- ..b )
    [ dup nil? ] [ [ drop ] prepose ] [ ] tri* if ; inline

: when-nil ( ..a list quot: ( ..a -- ..b ) -- ..b )
    [ ] if-nil ; inline

: unless-nil ( ..a list quot: ( ..a list -- ..b ) -- ..b )
    [ ] swap if-nil ; inline

! Deconstruction

M: cons head head>> ;
M: cons tail dup lazy? [ dup force-tail ] when tail>> ;
TYPED: uncons ( xs: list -- head tail ) [ head ] [ tail ] bi ;

! Operations
! For each we have an eager version, and a lazy version denoted with ~

: append ( list1 list2 -- newlist )
    swap [ clone ] [ swap [ uncons ] dip append cons ] if-nil ;

LAZY: ~append ( list1 list2 -- joined )
    swap [ clone ] [
        [ [ tail swap ~append ] 2curry <promise> ]
        [ head ]
        bi swap cons
    ] if-nil ;

: map ( ... list quot: ( ... elt -- ... newelt ) -- ... newlist )
    swap [ drop nil ] [
        uncons swapd over map [ call( ... elt -- ... newelt ) ] dip cons
    ] if-nil ;

LAZY: ~map ( list quot: ( elt -- newelt ) -- newlist )
    swap [ drop nil ] [
        [ head ] keep swapd over [ [ tail ] dip ~map ] 2curry
        [ call( elt -- newelt ) ] dip cons
    ] if-nil ;
    
: filter ( ... list quot: ( ... elt -- ... ? ) -- ... sublist )
    swap [ drop nil ] [
        swap 2dup [ head ] dip call( ... elt -- ... ? )
        [ [ uncons ] dip filter cons ]
        [ [ tail ] dip filter ]
        if
    ] if-nil ;
    
LAZY: ~filter ( list quot: ( elt -- ? ) -- sublist )
    swap [ drop nil ] [
        swap 2dup [ head ] dip call( elt -- ? )
        [ [ uncons ] dip ~filter cons ]
        [ [ tail ] dip ~filter force ]
        if
    ] if-nil ;