! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays byte-vectors classes
combinators definitions effects fry generic generic.single
generic.standard hashtables io.binary io.streams.string kernel
kernel.private math math.parser namespaces parser sbufs
sequences splitting splitting.private strings vectors words ;
IN: hints

GENERIC: specializer-predicate ( spec -- quot )

M: class specializer-predicate "predicate" word-prop ;

M: object specializer-predicate '[ _ eq? ] ;

GENERIC: specializer-declaration ( spec -- class )

M: class specializer-declaration ;

M: object specializer-declaration class ;

: specializer ( word -- specializer )
    "specializer" word-prop ;

: make-specializer ( specs -- quot )
    dup length <reversed>
    [ (picker) 2array ] 2map
    [ drop object eq? not ] assoc-filter
    [ [ t ] ] [
        [ swap specializer-predicate append ] { } assoc>map
        [ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce
    ] if-empty ;

: specializer-cases ( quot specializer -- alist )
    dup [ array? ] all? [ 1array ] unless [
        [ nip make-specializer ]
        [ [ specializer-declaration ] map swap '[ _ declare @ ] ] 2bi
    ] with { } map>assoc ;

: specialize-quot ( quot word specializer -- quot' )
    [ drop nip def>> ] [ nip specializer-cases ] 3bi alist>quot ;

! compiler.tree.propagation.inlining sets this to f
SYMBOL: specialize-method?

t specialize-method? set-global

: method-declaration ( method -- quot )
    [ "method-generic" word-prop dispatch# object <array> ]
    [ "method-class" word-prop ]
    bi prefix [ declare ] curry [ ] like ;

: specialize-method ( quot method -- quot' )
    [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
    [ dup "method-generic" word-prop specializer ] bi
    [ specialize-quot ] [ drop ] if* ;

: standard-method? ( method -- ? )
    dup method-body? [
        "method-generic" word-prop standard-generic?
    ] [ drop f ] if ;

: (specialized-def) ( word -- quot )
    [ def>> ] keep
    dup generic? [ drop ] [
        [ dup standard-method? [ specialize-method ] [ drop ] if ]
        [ dup specializer [ specialize-quot ] [ drop ] if* ]
        bi
    ] if ;

ERROR: type-mismatch-error word expected-types ;

: typed-stack-effect? ( effect -- ? )
    [ object = ] all? not ;

: type-mismatch-quot ( word types -- quot )
    [ type-mismatch-error ] 2curry ;

: make-coercer ( types -- quot )
    [ "coercer" word-prop [ ] or ]
    [ swap \ dip [ ] 2sequence prepend ]
    map-reduce ;

: typed-inputs ( quot word -- quot' )
    dup stack-effect effect-in-types {
        [ 2nip make-coercer ]
        [ 2nip make-specializer ]
        [ nip swap '[ _ declare @ ] ]
        [ [ drop ] 2dip type-mismatch-quot ]
    } 3cleave '[ @ @ _ _ if ] ;

: specialized-def ( word -- quot )
    [ (specialized-def) ] keep
    dup stack-effect effect-in-types typed-stack-effect?
    [ typed-inputs ] [ drop ] if ;

: specialized-length ( specializer -- n )
    dup [ array? ] all? [ first ] when length ;

SYNTAX: HINTS:
    scan-object dup wrapper? [ wrapped>> ] when
    [ changed-definition ]
    [ subwords [ changed-definition ] each ]
    [ parse-definition { } like "specializer" set-word-prop ] tri ;

! Default specializers
{ first first2 first3 first4 }
[ { array } "specializer" set-word-prop ] each

{ last pop* pop } [
    { vector } "specializer" set-word-prop
] each

\ push { { vector } { sbuf } } "specializer" set-word-prop

\ last { { vector } } "specializer" set-word-prop

\ set-last { { object vector } } "specializer" set-word-prop

\ push-all
{ { string sbuf } { array vector } { byte-array byte-vector } }
"specializer" set-word-prop

\ append
{ { string string } { array array } }
"specializer" set-word-prop

\ subseq
{ { fixnum fixnum string } { fixnum fixnum array } }
"specializer" set-word-prop

\ reverse-here
{ { string } { array } }
"specializer" set-word-prop

\ mismatch
{ string string }
"specializer" set-word-prop

\ >string { sbuf } "specializer" set-word-prop

\ >array { { vector } } "specializer" set-word-prop

\ >vector { { array } { vector } } "specializer" set-word-prop

\ >sbuf { string } "specializer" set-word-prop

\ split, { string string } "specializer" set-word-prop

\ memq? { array } "specializer" set-word-prop

\ member? { array } "specializer" set-word-prop

\ assoc-stack { vector } "specializer" set-word-prop

\ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop

\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop

\ base> { string fixnum } "specializer" set-word-prop

M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop

M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop