basis/xmode/catalog/catalog.factor

   1 USING: xmode.loader xmode.utilities xmode.rules namespaces
   2 strings splitting assocs sequences kernel io.files xml memoize
   3 words globs combinators io.encodings.utf8 io.pathnames sorting
   4 accessors regexp unicode.case xml.data xml.traversal
   5 xml.syntax ;
   6 IN: xmode.catalog
   7
   8 TUPLE: mode file file-name-glob first-line-glob ;
   9
  10 TAGS: parse-mode-tag ( modes tag -- )
  11
  12 TAG: MODE parse-mode-tag
  13     dup "NAME" attr [
  14         mode new {
  15             { "FILE" f file<< }
  16             { "FILE_NAME_GLOB" f file-name-glob<< }
  17             { "FIRST_LINE_GLOB" f first-line-glob<< }
  18         } init-from-tag
  19         [ [ >case-fold <glob> ] [ f ] if* ] change-file-name-glob
  20         [ [ >case-fold <glob> ] [ f ] if* ] change-first-line-glob
  21     ] dip
  22     rot set-at ;
  23
  24 : parse-modes-tag ( tag -- modes )
  25     H{ } clone [
  26         swap children-tags [ parse-mode-tag ] with each
  27     ] keep ;
  28
  29 MEMO: modes ( -- modes )
  30     "vocab:xmode/modes/catalog"
  31     file>xml parse-modes-tag ;
  32
  33 MEMO: mode-names ( -- modes )
  34     modes keys natural-sort ;
  35
  36 : reset-catalog ( -- )
  37     \ modes reset-memoized ;
  38
  39 MEMO: (load-mode) ( name -- rule-sets )
  40     modes at [
  41         file>>
  42         "vocab:xmode/modes/" prepend parse-mode
  43     ] [
  44         "text" (load-mode)
  45     ] if* ;
  46
  47 SYMBOL: rule-sets
  48
  49 : no-such-rule-set ( name -- * )
  50     "No such rule set: " prepend throw ;
  51
  52 : get-rule-set ( name -- rule-sets rules )
  53     dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*
  54     [ at* [ nip ] [ drop no-such-rule-set ] if ] keep swap ;
  55
  56 DEFER: finalize-rule-set
  57
  58 : resolve-delegate ( rule -- )
  59     dup delegate>> dup string? [
  60         get-rule-set
  61         dup rule-set? [ "not a rule set" throw ] unless
  62         swap rule-sets [ dup finalize-rule-set ] with-variable
  63         >>delegate drop
  64     ] [ 2drop ] if ;
  65
  66 : each-rule ( rule-set quot -- )
  67     [ rules>> values concat ] dip each ; inline
  68
  69 : resolve-delegates ( ruleset -- )
  70     [ resolve-delegate ] each-rule ;
  71
  72 : ?update ( keyword-map/f keyword-map -- keyword-map )
  73     over [ assoc-union! ] [ nip clone ] if ;
  74
  75 : import-keywords ( parent child -- )
  76     over [ [ keywords>> ] bi@ ?update ] dip keywords<< ;
  77
  78 : import-rules ( parent child -- )
  79     swap [ add-rule ] curry each-rule ;
  80
  81 : resolve-imports ( ruleset -- )
  82     dup imports>> [
  83         get-rule-set swap rule-sets [
  84             [ nip resolve-delegates ]
  85             [ import-keywords ]
  86             [ import-rules ]
  87             2tri
  88         ] with-variable
  89     ] with each ;
  90
  91 ERROR: mutually-recursive-rulesets ruleset ;
  92
  93 : finalize-rule-set ( ruleset -- )
  94     dup finalized?>> [ drop ] [
  95         t >>finalized?
  96         [ resolve-imports ]
  97         [ resolve-delegates ]
  98         bi
  99     ] if ;
 100
 101 : finalize-mode ( rulesets -- )
 102     dup rule-sets [
 103         [ nip finalize-rule-set ] assoc-each
 104     ] with-variable ;
 105
 106 : load-mode ( name -- rule-sets )
 107     (load-mode) dup finalize-mode ;
 108
 109 : reset-modes ( -- )
 110     \ (load-mode) reset-memoized ;
 111
 112 : ?matches ( string glob/f -- ? )
 113     [ >case-fold ] dip dup [ matches? ] [ 2drop f ] if ;
 114
 115 : suitable-mode? ( file-name first-line mode -- ? )
 116     [ nip ] 2keep first-line-glob>> ?matches
 117     [ 2drop t ] [ file-name-glob>> ?matches ] if ;
 118
 119 : ?find-mode ( file-name first-line -- mode/f )
 120     [ file-name ] dip
 121     modes
 122     [ nip [ 2dup ] dip suitable-mode? ] assoc-find
 123     2drop [ 2drop ] dip ;
 124
 125 : find-mode ( file-name first-line -- mode )
 126     ?find-mode "text" or ; inline