basis/vocabs/metadata/metadata.factor

   1 ! Copyright (C) 2009, 2010 Slava Pestov, Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes.algebra
   4 combinators.short-circuit continuations io.directories
   5 io.encodings.utf8 io.files io.pathnames kernel make math.parser
   6 memoize namespaces sequences sets summary system vocabs
   7 vocabs.loader words ;
   8 IN: vocabs.metadata
   9
  10 : check-vocab ( vocab -- vocab )
  11     dup find-vocab-root [ no-vocab ] unless ;
  12
  13 MEMO: vocab-file-contents ( vocab name -- seq )
  14     vocab-append-path dup
  15     [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ;
  16
  17 : set-vocab-file-contents ( seq vocab name -- )
  18     dupd vocab-append-path [
  19         swap [ ?delete-file ] [ swap utf8 set-file-lines ] if-empty
  20         \ vocab-file-contents reset-memoized
  21     ] [ vocab-name no-vocab ] ?if ;
  22
  23 : vocab-windows-icon-path ( vocab -- string )
  24     vocab-dir "icon.ico" append-path ;
  25
  26 : vocab-mac-icon-path ( vocab -- string )
  27     vocab-dir "icon.icns" append-path ;
  28
  29 : vocab-resources-path ( vocab -- string )
  30     vocab-dir "resources.txt" append-path ;
  31
  32 : vocab-resources ( vocab -- patterns )
  33     dup vocab-resources-path vocab-file-contents harvest ;
  34
  35 : set-vocab-resources ( patterns vocab -- )
  36     dup vocab-resources-path set-vocab-file-contents ;
  37
  38 : vocab-summary-path ( vocab -- string )
  39     vocab-dir "summary.txt" append-path ;
  40
  41 : vocab-summary ( vocab -- summary )
  42     dup dup vocab-summary-path vocab-file-contents
  43     [
  44         vocab-name " vocabulary" append
  45     ] [
  46         nip first
  47     ] if-empty ;
  48
  49 M: vocab summary
  50     [
  51         dup vocab-summary %
  52         " (" %
  53         words>> assoc-size #
  54         " words)" %
  55     ] "" make ;
  56
  57 M: vocab-link summary vocab-summary ;
  58
  59 : set-vocab-summary ( string vocab -- )
  60     [ 1array ] dip
  61     dup vocab-summary-path
  62     set-vocab-file-contents ;
  63
  64 : vocab-tags-path ( vocab -- string )
  65     vocab-dir "tags.txt" append-path ;
  66
  67 : vocab-tags ( vocab -- tags )
  68     dup vocab-tags-path vocab-file-contents harvest ;
  69
  70 : set-vocab-tags ( tags vocab -- )
  71     dup vocab-tags-path set-vocab-file-contents ;
  72
  73 : add-vocab-tags ( tags vocab -- )
  74     [ vocab-tags append members ] keep set-vocab-tags ;
  75
  76 : remove-vocab-tags ( tags vocab -- )
  77     [ vocab-tags swap diff ] keep set-vocab-tags ;
  78
  79 : vocab-authors-path ( vocab -- string )
  80     vocab-dir "authors.txt" append-path ;
  81
  82 : vocab-authors ( vocab -- authors )
  83     dup vocab-authors-path vocab-file-contents harvest ;
  84
  85 : set-vocab-authors ( authors vocab -- )
  86     dup vocab-authors-path set-vocab-file-contents ;
  87
  88 : vocab-platforms-path ( vocab -- string )
  89     vocab-dir "platforms.txt" append-path ;
  90
  91 ERROR: bad-platform name ;
  92
  93 : vocab-platforms ( vocab -- platforms )
  94     dup vocab-platforms-path vocab-file-contents
  95     [ dup "system" lookup-word [ ] [ bad-platform ] ?if ] map ;
  96
  97 : set-vocab-platforms ( platforms vocab -- )
  98     [ [ name>> ] map ] dip
  99     dup vocab-platforms-path set-vocab-file-contents ;
 100
 101 : supported-platform? ( platforms -- ? )
 102     [ t ] [ [ os swap class<= ] any? ] if-empty ;
 103
 104 : don't-load? ( vocab -- ? )
 105     {
 106         [ vocab-tags "not loaded" swap member? ]
 107         [ vocab-platforms supported-platform? not ]
 108     } 1|| ;
 109
 110 : filter-don't-load ( vocabs -- vocabs' )
 111     [ vocab-name don't-load? ] reject ;
 112
 113 : don't-test? ( vocab -- ? )
 114     vocab-tags "not tested" swap member? ;
 115
 116 : filter-don't-test ( vocabs -- vocabs' )
 117     [ don't-test? ] reject ;
 118
 119 TUPLE: unsupported-platform vocab requires ;
 120
 121 : throw-unsupported-platform ( vocab requires -- )
 122     \ unsupported-platform boa throw-continue ;
 123
 124 M: unsupported-platform summary
 125     drop "Current operating system not supported by this vocabulary" ;
 126
 127 [
 128     dup vocab-platforms dup supported-platform?
 129     [ 2drop ] [ [ vocab-name ] dip throw-unsupported-platform ] if
 130 ] check-vocab-hook set-global