factor/extra/constructors/constructors.factor

! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.tuple
effects.parser fry generalizations sequences.generalizations
generic.standard kernel lexer locals macros parser sequences
sets slots vocabs words ;
IN: constructors

! An experiment

: initializer-name ( class -- word )
    name>> "initialize-" prepend ;

: lookup-initializer ( class -- word/f )
    initializer-name "initializers" lookup ;

: initializer-word ( class -- word )
    initializer-name
    "initializers" create-vocab create
    [ t "initializer" set-word-prop ] [ ] bi ;

: define-initializer-generic ( name -- )
    initializer-word (( object -- object )) define-simple-generic ;

: define-initializer ( class def -- )
    [ drop define-initializer-generic ]
    [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;

: all-slots-assoc ( class -- slots )
    superclasses [ [ "slots" word-prop ] keep '[ _ ] { } map>assoc ] map concat ;

MACRO:: slots>constructor ( class slots -- quot )
    class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
    class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
    slots length
    default-params length
    '[
        _ narray slot-assoc swap zip 
        default-params swap assoc-union values _ firstn class boa
    ] ;

ERROR: repeated-constructor-parameters class effect ;

ERROR: unknown-constructor-parameters class effect unknown ;

: ensure-constructor-parameters ( class effect -- class effect )
    dup in>> all-unique? [ repeated-constructor-parameters ] unless
    2dup [ all-slots [ name>> ] map ] [ in>> ] bi* swap diff
    [ unknown-constructor-parameters ] unless-empty ;

:: (define-constructor) ( constructor-word class effect def -- word quot )
    constructor-word
    class def define-initializer
    class effect in>> '[ _ _ slots>constructor ] ;

:: define-constructor ( constructor-word class effect def reverse? -- )
    constructor-word class effect def (define-constructor)
    class superclasses [ lookup-initializer ] map sift
    reverse? [ reverse ] when
    '[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ;

: scan-constructor ( -- word class )
    scan-word [ name>> "<" ">" surround create-in dup reset-generic ] keep ;

: parse-constructor ( -- class word effect def )
    scan-constructor complete-effect ensure-constructor-parameters
    parse-definition ;

SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ;

"initializers" create-vocab drop