factor/extra/fuel/fuel.factor

! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
! See http://factorcode.org/license.txt for BSD license.

USING: accessors arrays assocs classes classes.tuple
combinators compiler.units continuations debugger definitions
eval help io io.files io.pathnames io.streams.string kernel
lexer listener listener.private make math math.order memoize
namespaces parser prettyprint prettyprint.config quotations
sequences sets sorting source-files strings summary tools.vocabs
vectors vocabs vocabs.loader vocabs.parser words ;

IN: fuel

! Evaluation status:

TUPLE: fuel-status in use restarts ;

SYMBOL: fuel-status-stack
V{ } clone fuel-status-stack set-global

SYMBOL: fuel-eval-result
f clone fuel-eval-result set-global

SYMBOL: fuel-eval-output
f clone fuel-eval-result set-global

SYMBOL: fuel-eval-res-flag
t clone fuel-eval-res-flag set-global

: fuel-eval-restartable? ( -- ? )
    fuel-eval-res-flag get-global ; inline

: fuel-eval-restartable ( -- )
    t fuel-eval-res-flag set-global ; inline

: fuel-eval-non-restartable ( -- )
    f fuel-eval-res-flag set-global ; inline

: fuel-push-status ( -- )
    in get use get clone restarts get-global clone
    fuel-status boa
    fuel-status-stack get push ;

: fuel-pop-restarts ( restarts -- )
    fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; inline

: fuel-pop-status ( -- )
    fuel-status-stack get empty? [
        fuel-status-stack get pop
        [ in>> in set ]
        [ use>> clone use set ]
        [ restarts>> fuel-pop-restarts ] tri
    ] unless ;

! Lispy pretty printing

GENERIC: fuel-pprint ( obj -- )

M: object fuel-pprint pprint ; inline

M: f fuel-pprint drop "nil" write ; inline

M: integer fuel-pprint pprint ; inline

M: string fuel-pprint pprint ; inline

M: sequence fuel-pprint
    "(" write [ " " write ] [ fuel-pprint ] interleave ")" write ; inline

M: tuple fuel-pprint tuple>array fuel-pprint ; inline

M: continuation fuel-pprint drop ":continuation" write ; inline

M: restart fuel-pprint name>> fuel-pprint ; inline

SYMBOL: :restarts

: fuel-restarts ( obj -- seq )
    compute-restarts :restarts prefix ; inline

M: condition fuel-pprint
    [ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ;

M: lexer-error fuel-pprint
    {
        [ line>> ]
        [ column>> ]
        [ line-text>> ]
        [ fuel-restarts ]
    } cleave 4array lexer-error prefix fuel-pprint ;

M: source-file-error fuel-pprint
    [ file>> ] [ error>> ] bi 2array source-file-error prefix
    fuel-pprint ;

M: source-file fuel-pprint path>> fuel-pprint ;

! Evaluation vocabulary

: fuel-eval-set-result ( obj -- )
    clone fuel-eval-result set-global ; inline

: fuel-retort ( -- )
    error get
    fuel-eval-result get-global
    fuel-eval-output get-global
    3array fuel-pprint flush nl "<~FUEL~>" write nl flush ;

: fuel-forget-error ( -- ) f error set-global ; inline
: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline

: (fuel-begin-eval) ( -- )
    fuel-push-status
    fuel-forget-error
    fuel-forget-result
    fuel-forget-output ;

: (fuel-end-eval) ( output -- )
    fuel-eval-output set-global fuel-retort fuel-pop-status ; inline

: (fuel-eval) ( lines -- )
    [ [ parse-lines ] with-compilation-unit call ] curry
    [ print-error ] recover ; inline

: (fuel-eval-each) ( lines -- )
    [ 1vector (fuel-eval) ] each ; inline

: (fuel-eval-usings) ( usings -- )
    [ "USING: " prepend " ;" append ] map
    (fuel-eval-each) fuel-forget-error fuel-forget-output ;

: (fuel-eval-in) ( in -- )
    [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline

: fuel-eval-in-context ( lines in usings -- )
    (fuel-begin-eval)
    [ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer
    (fuel-end-eval) ;

: fuel-run-file ( path -- ) run-file ; inline

! Edit locations

: fuel-normalize-loc ( seq -- path line )
    dup length 1 > [ first2 [ (normalize-path) ] dip ] [ f ] if ; inline

: fuel-get-edit-location ( defspec -- )
    where fuel-normalize-loc 2array fuel-eval-set-result ; inline

: fuel-get-vocab-location ( vocab -- )
    >vocab-link fuel-get-edit-location ; inline

: fuel-get-doc-location ( defspec -- )
    props>> "help-loc" swap at
    fuel-normalize-loc 2array fuel-eval-set-result ;

! Cross-references

: fuel-word>xref ( word -- xref )
    [ name>> ] [ vocabulary>> ] [ where fuel-normalize-loc ] tri 4array ;

: fuel-sort-xrefs ( seq -- seq' )
    [ [ first ] dip first <=> ] sort ; inline

: fuel-format-xrefs ( seq -- seq' )
    [ word? ] filter [ fuel-word>xref ] map fuel-sort-xrefs ;

: fuel-callers-xref ( word -- )
    usage fuel-format-xrefs fuel-eval-set-result ; inline

: fuel-callees-xref ( word -- )
    uses fuel-format-xrefs fuel-eval-set-result ; inline

! Completion support

: fuel-filter-prefix ( seq prefix -- seq )
    [ drop-prefix nip length 0 = ] curry filter prune ; inline

: (fuel-get-vocabs) ( -- seq )
    all-vocabs-seq [ vocab-name ] map ; inline

: fuel-get-vocabs ( -- )
    (fuel-get-vocabs) fuel-eval-set-result ; inline

: fuel-get-vocabs/prefix ( prefix -- )
    (fuel-get-vocabs) swap fuel-filter-prefix fuel-eval-set-result ; inline

: fuel-vocab-summary ( name -- )
    >vocab-link summary fuel-eval-set-result ; inline

MEMO: (fuel-vocab-words) ( name -- seq )
    >vocab-link words [ name>> ] map ;

: fuel-current-words ( -- seq )
    use get [ keys ] map concat ; inline

: fuel-vocabs-words ( names -- seq )
    prune [ (fuel-vocab-words) ] map concat ; inline

: (fuel-get-words) ( prefix names/f -- seq )
    [ fuel-vocabs-words ] [ fuel-current-words ] if* natural-sort
    swap fuel-filter-prefix ;

: fuel-get-words ( prefix names -- )
    (fuel-get-words) fuel-eval-set-result ; inline


! -run=fuel support

: fuel-startup ( -- ) "listener" run-file ; inline

MAIN: fuel-startup