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 assocs classes.algebra combinators
   4 combinators.short-circuit continuations io.directories
   5 io.encodings.utf8 io.files io.pathnames kernel make math.parser
   6 memoize namespaces sequences splitting 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 : vocab-file-path ( vocab name -- path/f )
  14     [ dup vocab-dir ] [ append-path ] bi* vocab-append-path ;
  15
  16 MEMO: vocab-file-lines ( vocab name -- lines/f )
  17     vocab-file-path dup [
  18         dup file-exists? [
  19             utf8 file-lines harvest
  20         ] [
  21             drop f
  22         ] if
  23     ] when ;
  24
  25 : set-vocab-file-lines ( lines vocab name -- )
  26     dupd vocab-file-path [
  27         swap [ ?delete-file ] [ swap utf8 set-file-lines ] if-empty
  28         \ vocab-file-lines reset-memoized
  29     ] [ vocab-name no-vocab ] ?if ;
  30
  31 : vocab-resources-path ( vocab -- path/f )
  32     "resources.txt" vocab-file-path ;
  33
  34 : vocab-resources ( vocab -- patterns )
  35     "resources.txt" vocab-file-lines ;
  36
  37 : vocab-summary-path ( vocab -- path/f )
  38     "summary.txt" vocab-file-path ;
  39
  40 : vocab-summary ( vocab -- summary )
  41     "summary.txt" vocab-file-lines [ first ] [ f ] if* ;
  42
  43 : vocab-in-root-summary ( vocab -- string )
  44     [ vocab-summary ] [
  45         vocab-name dup
  46         ".private" ?tail drop find-vocab-root
  47         [ "`" "'" surround " in " glue ] when*
  48     ] bi over [ ", " glue ] [ nip ] if ;
  49
  50 M: vocab summary
  51     [
  52         dup vocab-in-root-summary %
  53         " (" %
  54         words>> assoc-size #
  55         " words)" %
  56     ] "" make ;
  57
  58 M: vocab-link summary vocab-in-root-summary ;
  59
  60 : vocab-tags-path ( vocab -- path/f )
  61     "tags.txt" vocab-file-path ;
  62
  63 : vocab-tags ( vocab -- tags )
  64     "tags.txt" vocab-file-lines ;
  65
  66 : vocab-authors-path ( vocab -- path/f )
  67     "authors.txt" vocab-file-path ;
  68
  69 : vocab-authors ( vocab -- authors )
  70     "authors.txt" vocab-file-lines ;
  71
  72 : vocab-platforms-path ( vocab -- path/f )
  73     "platforms.txt" vocab-file-path ;
  74
  75 ERROR: bad-platform name ;
  76
  77 : vocab-platforms ( vocab -- platforms )
  78     "platforms.txt" vocab-file-lines
  79     [ dup "system" lookup-word [ ] [ bad-platform ] ?if ] map ;
  80
  81 : supported-platform? ( platforms -- ? )
  82     [ t ] [ [ os swap class<= ] any? ] if-empty ;
  83
  84 : don't-load? ( vocab -- ? )
  85     {
  86         [ vocab-tags "not loaded" swap member? ]
  87         [ vocab-platforms supported-platform? not ]
  88     } 1|| ;
  89
  90 : don't-test? ( vocab -- ? )
  91     vocab-tags "not tested" swap member? ;
  92
  93 TUPLE: unsupported-platform vocab requires ;
  94
  95 : throw-unsupported-platform ( vocab requires -- )
  96     unsupported-platform boa throw-continue ;
  97
  98 M: unsupported-platform summary
  99     drop "Current operating system not supported by this vocabulary" ;
 100
 101 : file-exists?, ( path -- )
 102     [ dup file-exists? [ , ] [ drop ] if ] when* ;
 103
 104 : vocab-metadata-files ( vocab -- paths )
 105     [
 106         {
 107             [ vocab-summary-path file-exists?, ]
 108             [ vocab-authors-path file-exists?, ]
 109             [ vocab-tags-path file-exists?, ]
 110             [ vocab-platforms-path file-exists?, ]
 111             [ vocab-resources-path file-exists?, ]
 112         } cleave
 113     ] { } make ;
 114
 115 [
 116     dup vocab-platforms dup supported-platform?
 117     [ 2drop ] [ [ vocab-name ] dip throw-unsupported-platform ] if
 118 ] check-vocab-hook set-global