extra/xmode/utilities/utilities.factor

   1 USING: sequences assocs kernel quotations namespaces xml.data
   2 xml.utilities combinators macros parser words ;
   3 IN: xmode.utilities
   4
   5 : implies >r not r> or ; inline
   6
   7 : child-tags ( tag -- seq ) tag-children [ tag? ] filter ;
   8
   9 : map-find ( seq quot -- result elt )
  10     f -rot
  11     [ nip ] swap [ dup ] 3compose find
  12     >r [ drop f ] unless r> ; inline
  13
  14 : tag-init-form ( spec -- quot )
  15     {
  16         { [ dup quotation? ] [ [ object get tag get ] prepose ] }
  17         { [ dup length 2 = ] [
  18             first2 [
  19                 >r >r tag get children>string
  20                 r> [ execute ] when* object get r> execute
  21             ] 2curry
  22         ] }
  23         { [ dup length 3 = ] [
  24             first3 [
  25                 >r >r tag get at
  26                 r> [ execute ] when* object get r> execute
  27             ] 3curry
  28         ] }
  29     } cond ;
  30
  31 : with-tag-initializer ( tag obj quot -- )
  32     [ object set tag set ] prepose with-scope ; inline
  33
  34 MACRO: (init-from-tag) ( specs -- )
  35     [ tag-init-form ] map concat [ ] like
  36     [ with-tag-initializer ] curry ;
  37
  38 : init-from-tag ( tag tuple specs -- tuple )
  39     over >r (init-from-tag) r> ; inline
  40
  41 SYMBOL: tag-handlers
  42 SYMBOL: tag-handler-word
  43
  44 : <TAGS:
  45     CREATE tag-handler-word set
  46     H{ } clone tag-handlers set ; parsing
  47
  48 : (TAG:) ( name quot -- ) swap tag-handlers get set-at ;
  49
  50 : TAG:
  51     f set-word
  52     scan parse-definition
  53     (TAG:) ; parsing
  54
  55 : TAGS>
  56     tag-handler-word get
  57     tag-handlers get >alist [ >r dup name-tag r> case ] curry
  58     (( tag -- )) define-declared ; parsing