extra/fuel/fuel.factor

   1 ! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors arrays assocs classes classes.tuple
   5 combinators compiler.units continuations debugger definitions
   6 eval help io io.files io.pathnames io.streams.string kernel
   7 lexer listener listener.private make math memoize namespaces
   8 parser prettyprint prettyprint.config quotations sequences sets
   9 sorting source-files strings tools.vocabs vectors vocabs
  10 vocabs.loader vocabs.parser summary ;
  11
  12 IN: fuel
  13
  14 ! Evaluation status:
  15
  16 TUPLE: fuel-status in use ds? restarts ;
  17
  18 SYMBOL: fuel-status-stack
  19 V{ } clone fuel-status-stack set-global
  20
  21 SYMBOL: fuel-eval-result
  22 f clone fuel-eval-result set-global
  23
  24 SYMBOL: fuel-eval-output
  25 f clone fuel-eval-result set-global
  26
  27 SYMBOL: fuel-eval-res-flag
  28 t clone fuel-eval-res-flag set-global
  29
  30 : fuel-eval-restartable? ( -- ? )
  31     fuel-eval-res-flag get-global ; inline
  32
  33 : fuel-eval-restartable ( -- )
  34     t fuel-eval-res-flag set-global ; inline
  35
  36 : fuel-eval-non-restartable ( -- )
  37     f fuel-eval-res-flag set-global ; inline
  38
  39 : push-fuel-status ( -- )
  40     in get use get clone display-stacks? get restarts get-global clone
  41     fuel-status boa
  42     fuel-status-stack get push ;
  43
  44 : pop-fuel-status ( -- )
  45     fuel-status-stack get empty? [
  46         fuel-status-stack get pop {
  47             [ in>> in set ]
  48             [ use>> clone use set ]
  49             [ ds?>> display-stacks? swap [ on ] [ off ] if ]
  50             [
  51                 restarts>> fuel-eval-restartable? [ drop ] [
  52                     clone restarts set-global
  53                 ] if
  54             ]
  55         } cleave
  56     ] unless ;
  57
  58
  59 ! Lispy pretty printing
  60
  61 GENERIC: fuel-pprint ( obj -- )
  62
  63 M: object fuel-pprint pprint ; inline
  64
  65 M: f fuel-pprint drop "nil" write ; inline
  66
  67 M: integer fuel-pprint pprint ; inline
  68
  69 M: string fuel-pprint pprint ; inline
  70
  71 M: sequence fuel-pprint
  72     dup empty? [ drop f fuel-pprint ] [
  73         "(" write
  74         [ " " write ] [ fuel-pprint ] interleave
  75         ")" write
  76     ] if ;
  77
  78 M: tuple fuel-pprint tuple>array fuel-pprint ; inline
  79
  80 M: continuation fuel-pprint drop ":continuation" write ; inline
  81
  82 M: restart fuel-pprint name>> fuel-pprint ; inline
  83
  84 SYMBOL: :restarts
  85
  86 : fuel-restarts ( obj -- seq )
  87     compute-restarts :restarts prefix ; inline
  88
  89 M: condition fuel-pprint
  90     [ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ;
  91
  92 M: lexer-error fuel-pprint
  93     {
  94         [ line>> ]
  95         [ column>> ]
  96         [ line-text>> ]
  97         [ fuel-restarts ]
  98     } cleave 4array lexer-error prefix fuel-pprint ;
  99
 100 M: source-file-error fuel-pprint
 101     [ file>> ] [ error>> ] bi 2array source-file-error prefix
 102     fuel-pprint ;
 103
 104 M: source-file fuel-pprint path>> fuel-pprint ;
 105
 106 ! Evaluation vocabulary
 107
 108 : fuel-eval-set-result ( obj -- )
 109     clone fuel-eval-result set-global ; inline
 110
 111 : fuel-retort ( -- )
 112     error get
 113     fuel-eval-result get-global
 114     fuel-eval-output get-global
 115     3array fuel-pprint flush nl "EOT:" write ;
 116
 117 : fuel-forget-error ( -- ) f error set-global ; inline
 118 : fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
 119 : fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline
 120
 121 : (fuel-begin-eval) ( -- )
 122     push-fuel-status
 123     display-stacks? off
 124     fuel-forget-error
 125     fuel-forget-result
 126     fuel-forget-output ;
 127
 128 : (fuel-end-eval) ( quot -- )
 129     with-string-writer fuel-eval-output set-global
 130     fuel-retort pop-fuel-status ; inline
 131
 132 : (fuel-eval) ( lines -- )
 133     [ [ parse-lines ] with-compilation-unit call ] curry
 134     [ print-error ] recover ; inline
 135
 136 : (fuel-eval-each) ( lines -- )
 137     [ 1vector (fuel-eval) ] each ; inline
 138
 139 : (fuel-eval-usings) ( usings -- )
 140     [ "USING: " prepend " ;" append ] map
 141     (fuel-eval-each) fuel-forget-error fuel-forget-output ;
 142
 143 : (fuel-eval-in) ( in -- )
 144     [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline
 145
 146 : fuel-eval-in-context ( lines in usings -- )
 147     (fuel-begin-eval) [
 148         (fuel-eval-usings)
 149         (fuel-eval-in)
 150         (fuel-eval)
 151     ] (fuel-end-eval) ;
 152
 153 : fuel-begin-eval ( in -- )
 154     (fuel-begin-eval)
 155     (fuel-eval-in)
 156     fuel-retort ;
 157
 158 : fuel-eval ( lines -- )
 159     (fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ; inline
 160
 161 : fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline
 162
 163 : fuel-run-file ( path -- ) run-file ; inline
 164
 165 ! Edit locations
 166
 167 : fuel-get-edit-location ( defspec -- )
 168     where [
 169        first2 [ (normalize-path) ] dip 2array fuel-eval-set-result
 170     ] when* ; inline
 171
 172 : fuel-get-vocab-location ( vocab -- )
 173     >vocab-link fuel-get-edit-location ; inline
 174
 175 ! Completion support
 176
 177 : fuel-filter-prefix ( seq prefix -- seq )
 178     [ drop-prefix nip length 0 = ] curry filter prune ; inline
 179
 180 : (fuel-get-vocabs) ( -- seq )
 181     all-vocabs-seq [ vocab-name ] map ; inline
 182
 183 : fuel-get-vocabs ( -- )
 184     (fuel-get-vocabs) fuel-eval-set-result ; inline
 185
 186 : fuel-get-vocabs/prefix ( prefix -- )
 187     (fuel-get-vocabs) swap fuel-filter-prefix fuel-eval-set-result ; inline
 188
 189 : fuel-vocab-summary ( name -- )
 190     >vocab-link summary fuel-eval-set-result ; inline
 191
 192 MEMO: (fuel-vocab-words) ( name -- seq )
 193     >vocab-link words [ name>> ] map ;
 194
 195 : fuel-current-words ( -- seq )
 196     use get [ keys ] map concat ; inline
 197
 198 : fuel-vocabs-words ( names -- seq )
 199     prune [ (fuel-vocab-words) ] map concat ; inline
 200
 201 : (fuel-get-words) ( prefix names/f -- seq )
 202     [ fuel-vocabs-words ] [ fuel-current-words ] if* natural-sort
 203     swap fuel-filter-prefix ;
 204
 205 : fuel-get-words ( prefix names -- )
 206     (fuel-get-words) fuel-eval-set-result ; inline
 207
 208
 209 ! -run=fuel support
 210
 211 : fuel-startup ( -- ) "listener" run-file ; inline
 212
 213 MAIN: fuel-startup