core/modules.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: modules
   4 USING: hashtables io kernel namespaces parser sequences
   5 words strings arrays math help errors ;
   6
   7 SYMBOL: modules
   8
   9 TUPLE: module name loc directory files tests help main ;
  10
  11 : module-def ( name -- path )
  12     "resource:" over "/load.factor" 3append
  13     dup ?resource-path exists? [
  14         nip
  15     ] [
  16         drop "resource:" swap ".factor" 3append
  17     ] if ;
  18
  19 : module modules get [ module-name = ] find-with nip ;
  20
  21 : process-files ( name seq -- newseq )
  22     [ dup string? [ [ t ] 2array ] when ] map
  23     [ second call ] subset
  24     0 <column> >array
  25     [ path+ "resource:" swap append ] map-with ;
  26
  27 : module-files* ( module -- seq )
  28     dup module-directory swap module-files process-files ;
  29
  30 : loading-module ( name -- )
  31     "quiet" get [
  32         drop
  33     ] [
  34         "Loading module " write print flush
  35     ] if ;
  36
  37 : load-module ( name -- )
  38     [
  39         dup loading-module
  40         [ dup module-def run-file ] assert-depth drop
  41     ] no-parse-hook ;
  42
  43 : reload-module ( module -- )
  44     dup module-name module-def source-modified? [
  45         module-name load-module
  46     ] [
  47         module-files* [ source-modified? ] subset run-files
  48     ] if ;
  49
  50 : reload-modules ( -- )
  51     modules get [ reload-module ] each do-parse-hook ;
  52
  53 : require ( name -- )
  54     dup module [ drop ] [ load-module ] if do-parse-hook ;
  55
  56 : remove-module ( name -- )
  57     module [ modules get delete ] when* ;
  58
  59 : alist>module ( name loc hash -- module )
  60     alist>hash [
  61         +directory+ get [ over ] unless*
  62         +files+ get
  63         +tests+ get
  64         +help+ get
  65     ] bind f <module> ;
  66
  67 : module>alist ( module -- hash )
  68     [
  69         +directory+ over module-directory 2array ,
  70         +files+ over module-files 2array ,
  71         +tests+ over module-tests 2array ,
  72         +help+ swap module-help 2array ,
  73     ] { } make ;
  74
  75 : provide ( name loc hash -- )
  76     pick remove-module
  77     alist>module
  78     [ module-files* run-files ] keep
  79     modules get push ;