Paste: Rework Lists vocab UPDATE

! Copyright (C) 2022 Keldan Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel promises typed parser accessors compiler.units fry ;
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: swons ( tail: union{ list promise } head -- list ) swap cons ;

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 ;
TYPED: unswons ( xs: list -- head tail ) uncons swap ;

! Operations
! For each we have an eager version, and a lazy version denoted with ~
! Lazy versions will probably be moved to lists.lazy

: foldr ( ... list id quot: ( ... elt accum -- ... accum' ) -- ... result )
    rot [ drop ] [ unswons pick [ -rot foldr ] 2dip swapd call ] if-nil ; inline recursive

LAZY: ~foldr ( list id quot: ( elt promise<accum> -- accum' ) -- result )
    rot [ drop ] [ -rot [ uncons ] 2dip [ ~foldr ] keep call( e p<a> -- a' ) ] if-nil ;
    
: each ( ... list quot: ( ... elt -- ... ) -- ... )
    swap [ drop ] [ uncons swapd over [ call ] 2dip each ] if-nil ; inline recursive

: foldl ( ... list id quot: ( ... accum elt -- ... accum' ) -- ... result )
    swapd each ; inline

: reverse ( list -- reversed ) nil [ swons ] foldl ; 

LAZY: ~foldl ( list id quot: ( promise<accum> elt -- accum' ) -- result )
    [ reverse ] 2dip [ swap ] prepose ~foldr force ;

: append ( list1 list2 -- newlist ) clone [ cons ] foldr ;

: ~clone ( list -- copy ) nil [ cons ] ~foldr ;

LAZY: ~append ( list1 list2 -- joined ) ~clone [ cons ] ~foldr ;

: map ( ... list quot: ( ... elt -- ... newelt ) -- ... newlist )
    nil swap '[ swap _ dip cons ] foldl reverse ; inline

: ~map ( list quot: ( elt -- newelt ) -- newlist )
    nil swap [ dip cons ] curry ~foldr ;
    
: filter ( ... list quot: ( ... elt -- ... ? ) -- ... sublist )
    nil swap '[ over @ [ cons ] [ nip ] if ] foldr ; inline
    
LAZY: ~filter ( list quot: ( elt -- ? ) -- sublist )
    nil swap '[ over _ call( e -- ? ) [ cons ] [ nip force ] if ] ~foldr ;

! Not sure when this would be useful, but adding it for completeness
! ~each returns a new list, and is therefore like mapping with some side effect
LAZY: ~each ( list quot: ( elt -- ) -- newlist )
    [ dup ] prepose ~map ;