diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index b2ea32504a..4b157084e4 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -25,7 +25,7 @@ ERROR: bad-vocab-name name ; : check-vocab-name ( name -- name ) dup string? [ bad-vocab-name ] unless - dup [ ":/\\ " member? ] any? [ bad-vocab-name ] when ; + dup [ "/\\ " member? ] any? [ bad-vocab-name ] when ; TUPLE: vocab-link name ; diff --git a/extra/namespaces/extras/authors.txt b/extra/namespaces/extras/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/namespaces/extras/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/namespaces/extras/extras.factor b/extra/namespaces/extras/extras.factor new file mode 100644 index 0000000000..89599ee8ff --- /dev/null +++ b/extra/namespaces/extras/extras.factor @@ -0,0 +1,121 @@ +! Copyright (C) 2017 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs assocs.extras combinators +combinators.extras continuations effects.parser formatting fry +generalizations interpolate io.streams.string kernel make +math.parser namespaces parser quotations sequences +sequences.generalizations unicode vocabs.parser words ; +QUALIFIED: sets +IN: namespaces.extras + +<< +ERROR: not-all-unique seq ; + +: ensure-unique ( seq -- seq ) + dup sets:all-unique? [ not-all-unique ] unless ; inline + +: effect-in>drop-variables ( effect -- quot ) + in>> ensure-unique + [ '[ name>> _ set ] ] map + '[ _ spread ] ; inline + +: make-in-drop-variables ( def effect -- def effect ) + [ + effect-in>drop-variables swap + '[ [ @ @ ] with-scope ] + ] keep ; +>> + +: functor-definer-word-name ( word -- string ) + name>> >lower "define-" prepend ; + +: functor-syntax-word-name ( word -- string ) + name>> >upper ":" append ; + +: functor-instantiated-vocab-name ( functor-word parameters -- string ) + dupd + '[ + ! box-functor:functors:box:float:1827917291 + _ vocabulary>> % + ":functors:" % + _ name>> % ! functor name, e.g. box + ":" % + _ hashcode number>string % ! narray for all the template parameters + ] "" make ; + +: prepend-input-vocabs ( word def effect -- word def effect ) + [ 2drop ] + [ + ! make FROM: vocab => word ; for each input argument + nip in>> length + [ + dup '[ [ _ _ narray functor-instantiated-vocab-name "IN: " prepend ] _ nkeep ] + ] [ + [ + [ + [ vocabulary>> ] [ name>> ] bi + "FROM: %s => %s ;" sprintf + ] + ] replicate + ] [ ] tri dup + ! Make the FROM: list and keep the input arguments + '[ [ @ _ spread _ narray "\n" join "\n" glue ] _ nkeep ] + ] [ + [ drop ] 2dip + ! append the IN: and the FROM: quot generator and the functor code + [ + append + '[ @ "functor" parse-stream drop ] + ] dip + ] 3tri ; + +: interpolate-assoc ( assoc -- quot ) + assoc-invert + [ '[ _ interpolate>string _ set ] ] { } assoc>map [ ] concat-as ; inline + +: create-new-word-in ( string -- word ) + create-word-in dup reset-generic ; + +: lookup-word-in ( string -- word ) + current-vocab lookup-word ; + +: (make-functor) ( word effect quot -- ) + swap + make-in-drop-variables + prepend-input-vocabs + [ + [ functor-definer-word-name create-new-word-in ] 2dip + define-declared + ] [ + nip + [ + [ functor-syntax-word-name create-new-word-in ] + [ functor-definer-word-name lookup-word-in ] bi + ] dip + in>> length [ [ scan-object ] ] replicate [ ] concat-as + swap + 1quotation + '[ @ @ ] define-syntax + ] 3bi ; inline + +: make-functor-word ( word effect string -- ) + nip 1quotation ( -- string ) define-declared ; + +: make-variable-functor ( word effect bindings string -- ) + [ + nip make-functor-word + ] [ + [ interpolate-assoc ] dip ! do bindings in series + '[ @ _ interpolate>string append ] ! append the interpolated string to the FROM: + (make-functor) + ] 4bi ; inline + +: make-functor ( word effect string -- ) + { } swap make-variable-functor ; + +! FUNCTOR: foo, define-foo, and FOO: go into the vocabulary where the FUNCTOR: appears +SYNTAX: \FUNCTOR: + scan-new-word scan-effect scan-object make-functor ; + +SYNTAX: \VARIABLE-FUNCTOR: + scan-new-word scan-effect scan-object scan-object make-variable-functor ;