Merge branch 'master' of git://factorcode.org/git/factor into jwmerrill
Daniel Ehrenberg
commit
d598963e0a
basis/http/client
extra
fuel
git-tool
|
|
@ -34,6 +34,8 @@ IN: http.client
|
|||
|
||||
GENERIC: >post-data ( object -- post-data )
|
||||
|
||||
M: f >post-data ;
|
||||
|
||||
M: post-data >post-data ;
|
||||
|
||||
M: string >post-data
|
||||
|
|
@ -41,15 +43,13 @@ M: string >post-data
|
|||
"application/octet-stream" <post-data>
|
||||
swap >>data ;
|
||||
|
||||
M: byte-array >post-data
|
||||
"application/octet-stream" <post-data>
|
||||
swap >>data ;
|
||||
|
||||
M: assoc >post-data
|
||||
"application/x-www-form-urlencoded" <post-data>
|
||||
swap >>params ;
|
||||
|
||||
M: f >post-data ;
|
||||
M: object >post-data
|
||||
"application/octet-stream" <post-data>
|
||||
swap >>data ;
|
||||
|
||||
: normalize-post-data ( request -- request )
|
||||
dup post-data>> [
|
||||
|
|
@ -63,8 +63,10 @@ M: f >post-data ;
|
|||
normalize-post-data ;
|
||||
|
||||
: write-post-data ( request -- request )
|
||||
dup method>> [ "POST" = ] [ "PUT" = ] bi or
|
||||
[ dup post-data>> data>> write ] when ;
|
||||
dup method>> { "POST" "PUT" } member? [
|
||||
dup post-data>> data>> dup sequence?
|
||||
[ write ] [ output-stream get stream-copy ] if
|
||||
] when ;
|
||||
|
||||
: write-request ( request -- )
|
||||
unparse-post-data
|
||||
|
|
|
|||
|
|
@ -1,10 +1,9 @@
|
|||
! Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors arrays assocs compiler.units definitions fuel.eval
|
||||
fuel.help help.markup help.topics io.pathnames kernel math math.order
|
||||
memoize namespaces parser sequences sets sorting tools.crossref
|
||||
tools.scaffold tools.vocabs vocabs vocabs.loader vocabs.parser words ;
|
||||
USING: assocs compiler.units fuel.eval fuel.help fuel.remote fuel.xref
|
||||
help.topics io.pathnames kernel namespaces parser sequences
|
||||
tools.scaffold vocabs.loader ;
|
||||
|
||||
IN: fuel
|
||||
|
||||
|
|
@ -50,92 +49,40 @@ PRIVATE>
|
|||
|
||||
! Edit locations
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: fuel-normalize-loc ( seq -- path line )
|
||||
[ dup length 0 > [ first (normalize-path) ] [ drop f ] if ]
|
||||
[ dup length 1 > [ second ] [ drop 1 ] if ] bi ;
|
||||
|
||||
: fuel-get-loc ( object -- )
|
||||
fuel-normalize-loc 2array fuel-eval-set-result ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: fuel-get-edit-location ( word -- ) where fuel-get-loc ; inline
|
||||
: fuel-get-word-location ( word -- )
|
||||
word-location fuel-eval-set-result ;
|
||||
|
||||
: fuel-get-vocab-location ( vocab -- )
|
||||
>vocab-link fuel-get-edit-location ; inline
|
||||
vocab-location fuel-eval-set-result ;
|
||||
|
||||
: fuel-get-doc-location ( word -- ) props>> "help-loc" swap at fuel-get-loc ;
|
||||
: fuel-get-doc-location ( word -- )
|
||||
doc-location fuel-eval-set-result ;
|
||||
|
||||
: fuel-get-article-location ( name -- ) article loc>> fuel-get-loc ;
|
||||
: fuel-get-article-location ( name -- )
|
||||
article-location fuel-eval-set-result ;
|
||||
|
||||
: fuel-get-vocabs ( -- )
|
||||
get-vocabs fuel-eval-set-result ;
|
||||
|
||||
: fuel-get-vocabs/prefix ( prefix -- )
|
||||
get-vocabs/prefix fuel-eval-set-result ;
|
||||
|
||||
: fuel-get-words ( prefix names -- )
|
||||
get-vocabs-words/prefix fuel-eval-set-result ;
|
||||
|
||||
! Cross-references
|
||||
|
||||
<PRIVATE
|
||||
: fuel-callers-xref ( word -- ) callers-xref fuel-eval-set-result ;
|
||||
|
||||
: fuel-word>xref ( word -- xref )
|
||||
[ name>> ] [ vocabulary>> ] [ where fuel-normalize-loc ] tri 4array ;
|
||||
: fuel-callees-xref ( word -- ) callees-xref fuel-eval-set-result ;
|
||||
|
||||
: fuel-sort-xrefs ( seq -- seq' )
|
||||
[ [ first ] dip first <=> ] sort ; inline
|
||||
: fuel-apropos-xref ( str -- ) apropos-xref fuel-eval-set-result ;
|
||||
|
||||
: fuel-format-xrefs ( seq -- seq' )
|
||||
[ word? ] filter [ fuel-word>xref ] map ; inline
|
||||
: fuel-vocab-xref ( vocab -- ) vocab-xref fuel-eval-set-result ;
|
||||
|
||||
: (fuel-index) ( seq -- seq )
|
||||
[ [ >link name>> ] [ article-title ] bi 2array \ $subsection prefix ] map ;
|
||||
: fuel-vocab-uses-xref ( vocab -- ) vocab-uses-xref fuel-eval-set-result ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: fuel-callers-xref ( word -- )
|
||||
usage fuel-format-xrefs fuel-sort-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
: fuel-callees-xref ( word -- )
|
||||
uses fuel-format-xrefs fuel-sort-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
: fuel-apropos-xref ( str -- )
|
||||
words-matching fuel-format-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
: fuel-vocab-xref ( vocab -- )
|
||||
words fuel-format-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
: fuel-index ( quot: ( -- seq ) -- )
|
||||
call (fuel-index) fuel-eval-set-result ; inline
|
||||
|
||||
! Completion support
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: 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
|
||||
|
||||
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 ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: fuel-get-vocabs ( -- )
|
||||
(fuel-get-vocabs) fuel-eval-set-result ;
|
||||
|
||||
: fuel-get-vocabs/prefix ( prefix -- )
|
||||
(fuel-get-vocabs) swap fuel-filter-prefix fuel-eval-set-result ;
|
||||
|
||||
: fuel-get-words ( prefix names -- )
|
||||
(fuel-get-words) fuel-eval-set-result ;
|
||||
: fuel-vocab-usage-xref ( vocab -- ) vocab-usage-xref fuel-eval-set-result ;
|
||||
|
||||
! Help support
|
||||
|
||||
|
|
@ -155,6 +102,8 @@ PRIVATE>
|
|||
: fuel-vocab-summary ( name -- )
|
||||
(fuel-vocab-summary) fuel-eval-set-result ;
|
||||
|
||||
: fuel-index ( quot -- ) call format-index fuel-eval-set-result ;
|
||||
|
||||
: fuel-get-vocabs/tag ( tag -- )
|
||||
(fuel-get-vocabs/tag) fuel-eval-set-result ;
|
||||
|
||||
|
|
@ -174,3 +123,6 @@ PRIVATE>
|
|||
|
||||
: fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;
|
||||
|
||||
! Remote connection
|
||||
|
||||
MAIN: fuel-start-remote-listener*
|
||||
|
|
|
|||
|
|
@ -109,3 +109,6 @@ MEMO: (fuel-get-vocabs/author) ( author -- element )
|
|||
MEMO: (fuel-get-vocabs/tag) ( tag -- element )
|
||||
[ "Vocabularies tagged " prepend \ $heading swap 2array ]
|
||||
[ tagged fuel-vocab-list ] bi 2array ;
|
||||
|
||||
: format-index ( seq -- seq )
|
||||
[ [ >link name>> ] [ article-title ] bi 2array \ $subsection prefix ] map ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Jose Antonio Ortega Ruiz
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
! Copyright (C) 2009 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors io io.encodings.utf8 io.servers.connection kernel
|
||||
listener math ;
|
||||
|
||||
IN: fuel.remote
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: server ( port -- server )
|
||||
<threaded-server>
|
||||
"tty-server" >>name
|
||||
utf8 >>encoding
|
||||
swap local-server >>insecure
|
||||
[ listener ] >>handler
|
||||
f >>timeout ;
|
||||
|
||||
: print-banner ( -- )
|
||||
"Starting server. Connect with 'M-x connect-to-factor' in Emacs"
|
||||
write nl flush ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: fuel-start-remote-listener ( port/f -- )
|
||||
print-banner integer? [ 9000 ] unless* server start-server ;
|
||||
|
||||
: fuel-start-remote-listener* ( -- ) f fuel-start-remote-listener ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jose Antonio Ortega Ruiz
|
||||
|
|
@ -0,0 +1,69 @@
|
|||
! Copyright (C) 2009 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors arrays assocs definitions help.topics io.pathnames
|
||||
kernel math math.order memoize namespaces sequences sets sorting
|
||||
tools.crossref tools.vocabs vocabs vocabs.parser words ;
|
||||
|
||||
IN: fuel.xref
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: normalize-loc ( seq -- path line )
|
||||
[ dup length 0 > [ first (normalize-path) ] [ drop f ] if ]
|
||||
[ dup length 1 > [ second ] [ drop 1 ] if ] bi ;
|
||||
|
||||
: get-loc ( object -- loc ) normalize-loc 2array ;
|
||||
|
||||
: word>xref ( word -- xref )
|
||||
[ name>> ] [ vocabulary>> ] [ where normalize-loc ] tri 4array ;
|
||||
|
||||
: vocab>xref ( vocab -- xref )
|
||||
dup dup >vocab-link where normalize-loc 4array ;
|
||||
|
||||
: sort-xrefs ( seq -- seq' )
|
||||
[ [ first ] dip first <=> ] sort ; inline
|
||||
|
||||
: format-xrefs ( seq -- seq' )
|
||||
[ word? ] filter [ word>xref ] map ; inline
|
||||
|
||||
: filter-prefix ( seq prefix -- seq )
|
||||
[ drop-prefix nip length 0 = ] curry filter prune ; inline
|
||||
|
||||
MEMO: (vocab-words) ( name -- seq )
|
||||
>vocab-link words [ name>> ] map ;
|
||||
|
||||
: current-words ( -- seq )
|
||||
use get [ keys ] map concat ; inline
|
||||
|
||||
: vocabs-words ( names -- seq )
|
||||
prune [ (vocab-words) ] map concat ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: callers-xref ( word -- seq ) usage format-xrefs sort-xrefs ;
|
||||
|
||||
: callees-xref ( word -- seq ) uses format-xrefs sort-xrefs ;
|
||||
|
||||
: apropos-xref ( str -- seq ) words-matching format-xrefs ;
|
||||
|
||||
: vocab-xref ( vocab -- seq ) words format-xrefs ;
|
||||
|
||||
: word-location ( word -- loc ) where get-loc ;
|
||||
|
||||
: vocab-location ( vocab -- loc ) >vocab-link where get-loc ;
|
||||
|
||||
: vocab-uses-xref ( vocab -- seq ) vocab-uses [ vocab>xref ] map ;
|
||||
|
||||
: vocab-usage-xref ( vocab -- seq ) vocab-usage [ vocab>xref ] map ;
|
||||
|
||||
: doc-location ( word -- loc ) props>> "help-loc" swap at get-loc ;
|
||||
|
||||
: article-location ( name -- loc ) article loc>> get-loc ;
|
||||
|
||||
: get-vocabs ( -- seq ) all-vocabs-seq [ vocab-name ] map ;
|
||||
|
||||
: get-vocabs/prefix ( prefix -- seq ) get-vocabs swap filter-prefix ;
|
||||
|
||||
: get-vocabs-words/prefix ( prefix names/f -- seq )
|
||||
[ vocabs-words ] [ current-words ] if* natural-sort swap filter-prefix ;
|
||||
|
|
@ -1,470 +0,0 @@
|
|||
|
||||
USING: accessors combinators.cleave combinators.short-circuit
|
||||
concurrency.combinators destructors fry io io.directories
|
||||
io.encodings io.encodings.utf8 io.launcher io.monitors
|
||||
io.pathnames io.pipes io.ports kernel locals math namespaces
|
||||
sequences splitting strings threads ui ui.gadgets
|
||||
ui.gadgets.buttons ui.gadgets.editors ui.gadgets.labels
|
||||
ui.gadgets.packs ui.gadgets.tracks ;
|
||||
|
||||
IN: git-tool
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: head** ( seq obj -- seq/f ) dup number? [ head ] [ dupd find drop head ] if ;
|
||||
|
||||
: tail** ( seq obj -- seq/f )
|
||||
dup number?
|
||||
[ tail ]
|
||||
[ dupd find drop [ tail ] [ drop f ] if* ]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: <process-stdout-stderr-reader> ( DESC -- process stream stream )
|
||||
[
|
||||
[let | STDOUT-PIPE [ (pipe) |dispose ]
|
||||
STDERR-PIPE [ (pipe) |dispose ] |
|
||||
|
||||
[let | PROCESS [ DESC >process ] |
|
||||
|
||||
PROCESS
|
||||
[ STDOUT-PIPE out>> or ] change-stdout
|
||||
[ STDERR-PIPE out>> or ] change-stderr
|
||||
run-detached
|
||||
|
||||
STDOUT-PIPE out>> dispose
|
||||
STDERR-PIPE out>> dispose
|
||||
|
||||
STDOUT-PIPE in>> <input-port> utf8 <decoder>
|
||||
STDERR-PIPE in>> <input-port> utf8 <decoder> ] ]
|
||||
]
|
||||
with-destructors ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: run-process/result ( desc -- process )
|
||||
<process-stdout-stderr-reader>
|
||||
{
|
||||
[ contents [ string-lines ] [ f ] if* ]
|
||||
[ contents [ string-lines ] [ f ] if* ]
|
||||
}
|
||||
parallel-spread
|
||||
[ >>stdout ] [ >>stderr ] bi*
|
||||
dup wait-for-process >>status ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! process popup windows
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: popup-window ( title contents -- )
|
||||
dup string? [ ] [ "\n" join ] if
|
||||
<editor> tuck set-editor-string swap open-window ;
|
||||
|
||||
: popup-process-window ( process -- )
|
||||
[ stdout>> [ "output" swap popup-window ] when* ]
|
||||
[ stderr>> [ "error" swap popup-window ] when* ]
|
||||
[
|
||||
[ stdout>> ] [ stderr>> ] bi or not
|
||||
[ "Process" "NO OUTPUT" popup-window ]
|
||||
when
|
||||
]
|
||||
tri ;
|
||||
|
||||
: popup-if-error ( process -- )
|
||||
{ [ status>> 0 = not ] [ popup-process-window t ] } 1&& drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: git-process ( REPO DESC -- process )
|
||||
REPO [ DESC run-process/result ] with-directory ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: git-status-section ( lines section -- lines/f )
|
||||
'[ _ = ] tail**
|
||||
[
|
||||
[ "#\t" head? ] tail**
|
||||
[ "#\t" head? not ] head**
|
||||
[ 2 tail ] map
|
||||
]
|
||||
[ f ]
|
||||
if* ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: colon ( -- ch ) CHAR: : ;
|
||||
: space ( -- ch ) 32 ;
|
||||
|
||||
: git-status-line-file ( line -- file )
|
||||
{ [ colon = ] 1 [ space = not ] } [ tail** ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <git-status>
|
||||
repository
|
||||
to-commit-new
|
||||
to-commit-modified
|
||||
to-commit-deleted
|
||||
modified
|
||||
deleted
|
||||
untracked ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: check-empty ( seq -- seq/f ) dup empty? [ drop f ] when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: refresh-git-status ( STATUS -- STATUS )
|
||||
|
||||
[let | LINES [ STATUS repository>> { "git" "status" } git-process stdout>> ] |
|
||||
|
||||
STATUS
|
||||
|
||||
LINES "# Changes to be committed:" git-status-section
|
||||
[ "new file:" head? ] filter
|
||||
[ git-status-line-file ] map
|
||||
check-empty
|
||||
>>to-commit-new
|
||||
|
||||
LINES "# Changes to be committed:" git-status-section
|
||||
[ "modified:" head? ] filter
|
||||
[ git-status-line-file ] map
|
||||
check-empty
|
||||
>>to-commit-modified
|
||||
|
||||
LINES "# Changes to be committed:" git-status-section
|
||||
[ "deleted:" head? ] filter
|
||||
[ git-status-line-file ] map
|
||||
check-empty
|
||||
>>to-commit-deleted
|
||||
|
||||
LINES "# Changed but not updated:" git-status-section
|
||||
[ "modified:" head? ] filter
|
||||
[ git-status-line-file ] map
|
||||
check-empty
|
||||
>>modified
|
||||
|
||||
LINES "# Changed but not updated:" git-status-section
|
||||
[ "deleted:" head? ] filter
|
||||
[ git-status-line-file ] map
|
||||
check-empty
|
||||
>>deleted
|
||||
|
||||
LINES "# Untracked files:" git-status-section >>untracked ] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: git-status ( REPO -- <git-status> )
|
||||
|
||||
<git-status> new REPO >>repository refresh-git-status ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: factor-git-status ( -- <git-status> ) "resource:" git-status ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! git-tool
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: to-commit ( <git-status> -- seq )
|
||||
{ to-commit-new>> to-commit-modified>> to-commit-deleted>> } 1arr concat ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: refresh-status-pile ( STATUS PILE -- )
|
||||
|
||||
STATUS refresh-git-status drop
|
||||
|
||||
PILE clear-gadget
|
||||
|
||||
PILE
|
||||
|
||||
! Commit section
|
||||
|
||||
[wlet | add-commit-path-button [| TEXT PATH |
|
||||
|
||||
{ 1 0 } <track>
|
||||
|
||||
TEXT <label> 2/8 track-add
|
||||
PATH <label> 6/8 track-add
|
||||
|
||||
"Reset"
|
||||
[
|
||||
drop
|
||||
|
||||
STATUS repository>>
|
||||
{ "git" "reset" "HEAD" PATH }
|
||||
git-process
|
||||
drop
|
||||
|
||||
STATUS PILE refresh-status-pile
|
||||
]
|
||||
<bevel-button> f track-add
|
||||
|
||||
add-gadget ] |
|
||||
|
||||
STATUS to-commit
|
||||
[
|
||||
"Changes to be committed" <label> reverse-video-theme add-gadget
|
||||
|
||||
STATUS to-commit-new>>
|
||||
[| PATH | "new file: " PATH add-commit-path-button ]
|
||||
each
|
||||
|
||||
STATUS to-commit-modified>>
|
||||
[| PATH | "modified: " PATH add-commit-path-button ]
|
||||
each
|
||||
|
||||
STATUS to-commit-deleted>>
|
||||
[| PATH | "deleted: " PATH add-commit-path-button ]
|
||||
each
|
||||
|
||||
<pile> 1 >>fill
|
||||
|
||||
[let | EDITOR [ <editor> "COMMIT MESSAGE" over set-editor-string ] |
|
||||
|
||||
EDITOR add-gadget
|
||||
|
||||
"Commit"
|
||||
[
|
||||
drop
|
||||
[let | MSG [ EDITOR editor-string ] |
|
||||
|
||||
STATUS repository>>
|
||||
{ "git" "commit" "-m" MSG } git-process
|
||||
popup-if-error ]
|
||||
STATUS PILE refresh-status-pile
|
||||
]
|
||||
<bevel-button>
|
||||
add-gadget ]
|
||||
|
||||
add-gadget
|
||||
|
||||
]
|
||||
when ]
|
||||
|
||||
! Modified section
|
||||
|
||||
STATUS modified>>
|
||||
[
|
||||
"Modified but not updated" <label> reverse-video-theme add-gadget
|
||||
|
||||
STATUS modified>>
|
||||
[| PATH |
|
||||
|
||||
<shelf>
|
||||
|
||||
PATH <label> add-gadget
|
||||
|
||||
"Add"
|
||||
[
|
||||
drop
|
||||
STATUS repository>> { "git" "add" PATH } git-process popup-if-error
|
||||
STATUS PILE refresh-status-pile
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
|
||||
"Diff"
|
||||
[
|
||||
drop
|
||||
STATUS repository>> { "git" "diff" PATH } git-process
|
||||
popup-process-window
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
|
||||
add-gadget
|
||||
|
||||
]
|
||||
each
|
||||
|
||||
]
|
||||
when
|
||||
|
||||
! Untracked section
|
||||
|
||||
STATUS untracked>>
|
||||
[
|
||||
"Untracked files" <label> reverse-video-theme add-gadget
|
||||
|
||||
STATUS untracked>>
|
||||
[| PATH |
|
||||
|
||||
{ 1 0 } <track>
|
||||
|
||||
PATH <label> f track-add
|
||||
|
||||
"Add"
|
||||
[
|
||||
drop
|
||||
STATUS repository>> { "git" "add" PATH } git-process popup-if-error
|
||||
STATUS PILE refresh-status-pile
|
||||
]
|
||||
<bevel-button> f track-add
|
||||
|
||||
add-gadget
|
||||
|
||||
]
|
||||
each
|
||||
|
||||
]
|
||||
when
|
||||
|
||||
! Refresh button
|
||||
|
||||
"Refresh" [ drop STATUS PILE refresh-status-pile ] <bevel-button> add-gadget
|
||||
|
||||
drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: git-remote-branches ( REPO NAME -- seq )
|
||||
REPO { "git" "remote" "show" NAME } git-process stdout>>
|
||||
" Tracked remote branches" over index 1 + tail first " " split
|
||||
[ empty? not ] filter ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: refresh-remotes-pile ( REPO PILE -- )
|
||||
|
||||
PILE clear-gadget
|
||||
|
||||
PILE
|
||||
|
||||
"Remotes" <label> reverse-video-theme add-gadget
|
||||
|
||||
REPO { "git" "remote" } git-process stdout>> [ empty? not ] filter
|
||||
|
||||
[| NAME |
|
||||
|
||||
[let | BRANCH! [ "master" ] |
|
||||
|
||||
{ 1 0 } <track>
|
||||
|
||||
NAME <label> 1 track-add
|
||||
|
||||
[let | BRANCH-BUTTON [ "master" [ drop ] <bevel-button> ] |
|
||||
|
||||
BRANCH-BUTTON
|
||||
[
|
||||
drop
|
||||
|
||||
<pile>
|
||||
|
||||
1 >>fill
|
||||
|
||||
REPO NAME git-remote-branches
|
||||
[| OTHER-BRANCH |
|
||||
OTHER-BRANCH
|
||||
[
|
||||
drop
|
||||
|
||||
OTHER-BRANCH BRANCH!
|
||||
|
||||
OTHER-BRANCH BRANCH-BUTTON gadget-child set-label-string
|
||||
|
||||
]
|
||||
<bevel-button>
|
||||
add-gadget
|
||||
]
|
||||
each
|
||||
|
||||
"Select a branch" open-window
|
||||
]
|
||||
>>quot
|
||||
|
||||
1 track-add ]
|
||||
|
||||
"Fetch"
|
||||
[ drop REPO { "git" "fetch" NAME } git-process popup-process-window ]
|
||||
<bevel-button>
|
||||
1 track-add
|
||||
|
||||
"..remote/branch"
|
||||
[
|
||||
drop
|
||||
[let | ARG [ { ".." NAME "/" BRANCH } concat ] |
|
||||
REPO { "git" "log" ARG } git-process popup-process-window ]
|
||||
]
|
||||
<bevel-button>
|
||||
1 track-add
|
||||
|
||||
"Merge"
|
||||
[
|
||||
drop
|
||||
[let | ARG [ { NAME "/" BRANCH } concat ] |
|
||||
REPO { "git" "merge" ARG } git-process popup-process-window ]
|
||||
]
|
||||
<bevel-button>
|
||||
1 track-add
|
||||
|
||||
"remote/branch.."
|
||||
[
|
||||
drop
|
||||
[let | ARG [ { NAME "/" BRANCH ".." } concat ] |
|
||||
REPO { "git" "log" ARG } git-process popup-process-window ]
|
||||
]
|
||||
<bevel-button>
|
||||
1 track-add
|
||||
|
||||
"Push"
|
||||
[
|
||||
drop
|
||||
REPO { "git" "push" NAME "master" } git-process popup-process-window
|
||||
]
|
||||
<bevel-button>
|
||||
1 track-add
|
||||
|
||||
add-gadget ]
|
||||
|
||||
]
|
||||
each
|
||||
|
||||
drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: git-tool ( REPO -- )
|
||||
|
||||
<pile> 1 >>fill
|
||||
|
||||
"Repository: " REPO [ current-directory get ] with-directory append
|
||||
<label>
|
||||
add-gadget
|
||||
|
||||
[let | STATUS [ REPO git-status ]
|
||||
PILE [ <pile> 1 >>fill ] |
|
||||
|
||||
[
|
||||
[
|
||||
[let | MONITOR [ REPO t <monitor> ] |
|
||||
[
|
||||
[let | PATH [ MONITOR next-change drop ] |
|
||||
".git" PATH subseq? ! Ignore git internal operations
|
||||
[ ]
|
||||
[ STATUS PILE refresh-status-pile ]
|
||||
if
|
||||
t ]
|
||||
]
|
||||
loop
|
||||
]
|
||||
]
|
||||
with-monitors
|
||||
]
|
||||
in-thread
|
||||
|
||||
STATUS PILE refresh-status-pile
|
||||
|
||||
PILE add-gadget ]
|
||||
|
||||
REPO <pile> 1 >>fill tuck refresh-remotes-pile add-gadget
|
||||
|
||||
"Git" open-window ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: factor-git-tool ( -- ) "resource:" git-tool ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -1,392 +0,0 @@
|
|||
|
||||
USING: accessors calendar git-tool git-tool io.directories
|
||||
io.monitors io.pathnames kernel locals math namespaces
|
||||
sequences splitting system threads ui ui.gadgets
|
||||
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.packs ;
|
||||
|
||||
USING: git-tool ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
IN: git-tool.remote
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <git-remote-gadget> < pack
|
||||
repository
|
||||
branch
|
||||
remote
|
||||
remote-branch
|
||||
fetch-period
|
||||
push
|
||||
closed
|
||||
last-refresh ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: current-branch ( REPO -- branch )
|
||||
{ "git" "branch" } git-process stdout>> [ "* " head? ] find nip 2 tail ;
|
||||
|
||||
: list-branches ( REPO -- branches )
|
||||
{ "git" "branch" } git-process stdout>>
|
||||
[ empty? not ] filter
|
||||
[ 2 tail ] map ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: list-remotes ( REPO -- remotes )
|
||||
{ "git" "remote" } git-process stdout>> [ empty? not ] filter ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: list-remote-branches ( REPO REMOTE -- branches )
|
||||
[let | OUT [ REPO { "git" "remote" "show" REMOTE } git-process stdout>> ] |
|
||||
|
||||
" Tracked remote branches" OUT member?
|
||||
[
|
||||
OUT
|
||||
" Tracked remote branches" OUT index 1 + tail first " " split
|
||||
[ empty? not ] filter
|
||||
]
|
||||
[
|
||||
OUT
|
||||
OUT [ " New remote branches" head? ] find drop
|
||||
1 + tail first " " split
|
||||
[ empty? not ] filter
|
||||
]
|
||||
if ] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: refresh-git-remote-gadget ( GADGET -- )
|
||||
|
||||
[let | REPO [ GADGET repository>> ] |
|
||||
|
||||
GADGET clear-gadget
|
||||
|
||||
GADGET
|
||||
|
||||
! Repository label
|
||||
|
||||
"Repository: " REPO [ current-directory get ] with-directory append
|
||||
<label>
|
||||
add-gadget
|
||||
|
||||
! Branch button
|
||||
|
||||
<shelf>
|
||||
|
||||
"Branch: " <label> add-gadget
|
||||
|
||||
REPO current-branch
|
||||
[
|
||||
drop
|
||||
|
||||
<pile>
|
||||
REPO list-branches
|
||||
|
||||
[| BRANCH |
|
||||
|
||||
BRANCH
|
||||
[
|
||||
drop
|
||||
REPO { "git" "checkout" BRANCH } git-process popup-if-error
|
||||
GADGET refresh-git-remote-gadget
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
|
||||
]
|
||||
each
|
||||
|
||||
"Select a branch" open-window
|
||||
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
|
||||
add-gadget
|
||||
|
||||
! Remote button
|
||||
|
||||
<shelf>
|
||||
|
||||
"Remote: " <label> add-gadget
|
||||
|
||||
GADGET remote>>
|
||||
[
|
||||
drop
|
||||
|
||||
<pile>
|
||||
|
||||
REPO list-remotes
|
||||
|
||||
[| REMOTE |
|
||||
|
||||
REMOTE
|
||||
[
|
||||
drop
|
||||
GADGET REMOTE >>remote drop
|
||||
GADGET "master" >>remote-branch drop
|
||||
GADGET refresh-git-remote-gadget
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
|
||||
]
|
||||
each
|
||||
|
||||
"Select a remote" open-window
|
||||
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
|
||||
add-gadget
|
||||
|
||||
! Remote branch button
|
||||
|
||||
<shelf>
|
||||
|
||||
"Remote branch: " <label> add-gadget
|
||||
|
||||
GADGET remote-branch>>
|
||||
[
|
||||
drop
|
||||
|
||||
<pile>
|
||||
|
||||
REPO GADGET remote>> list-remote-branches
|
||||
|
||||
[| REMOTE-BRANCH |
|
||||
|
||||
REMOTE-BRANCH
|
||||
[
|
||||
drop
|
||||
GADGET REMOTE-BRANCH >>remote-branch drop
|
||||
GADGET refresh-git-remote-gadget
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
]
|
||||
|
||||
each
|
||||
|
||||
"Select a remote branch" open-window
|
||||
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
|
||||
add-gadget
|
||||
|
||||
! Fetch button
|
||||
|
||||
"Fetch"
|
||||
[
|
||||
drop
|
||||
[let | REMOTE [ GADGET remote>> ] |
|
||||
REPO { "git" "fetch" REMOTE } git-process popup-if-error ]
|
||||
|
||||
GADGET refresh-git-remote-gadget
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
|
||||
! Available changes
|
||||
|
||||
[let | REMOTE [ GADGET remote>> ]
|
||||
REMOTE-BRANCH [ GADGET remote-branch>> ] |
|
||||
|
||||
[let | ARG [ { ".." REMOTE "/" REMOTE-BRANCH } concat ] |
|
||||
|
||||
[let | PROCESS [ REPO { "git" "log" ARG } git-process ] |
|
||||
|
||||
PROCESS stdout>>
|
||||
[
|
||||
<shelf>
|
||||
|
||||
"Changes available:" <label> add-gadget
|
||||
|
||||
"View"
|
||||
[
|
||||
drop
|
||||
PROCESS popup-process-window
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
|
||||
"Merge"
|
||||
[
|
||||
drop
|
||||
|
||||
[let | ARG [ { REMOTE "/" REMOTE-BRANCH } concat ] |
|
||||
|
||||
REPO { "git" "merge" ARG } git-process popup-process-window
|
||||
|
||||
]
|
||||
|
||||
GADGET refresh-git-remote-gadget
|
||||
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
|
||||
add-gadget
|
||||
|
||||
]
|
||||
when
|
||||
|
||||
] ] ]
|
||||
|
||||
|
||||
! Pushable changes
|
||||
|
||||
[let | REMOTE [ GADGET remote>> ]
|
||||
REMOTE-BRANCH [ GADGET remote-branch>> ] |
|
||||
|
||||
[let | ARG [ { REMOTE "/" REMOTE-BRANCH ".." } concat ] |
|
||||
|
||||
[let | PROCESS [ REPO { "git" "log" ARG } git-process ] |
|
||||
|
||||
PROCESS stdout>>
|
||||
[
|
||||
<shelf>
|
||||
|
||||
"Pushable changes: " <label> add-gadget
|
||||
|
||||
"View"
|
||||
[
|
||||
drop
|
||||
PROCESS popup-process-window
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
|
||||
"Push"
|
||||
[
|
||||
drop
|
||||
|
||||
REPO { "git" "push" REMOTE REMOTE-BRANCH }
|
||||
git-process
|
||||
popup-process-window
|
||||
|
||||
GADGET refresh-git-remote-gadget
|
||||
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
|
||||
add-gadget
|
||||
|
||||
]
|
||||
when
|
||||
|
||||
] ] ]
|
||||
|
||||
drop
|
||||
|
||||
] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: start-fetch-thread ( GADGET -- )
|
||||
|
||||
GADGET f >>closed drop
|
||||
|
||||
[
|
||||
|
||||
[
|
||||
|
||||
GADGET closed>>
|
||||
[ f ]
|
||||
[
|
||||
[let | REPO [ GADGET repository>> ]
|
||||
REMOTE-BRANCH [ GADGET remote-branch>> ] |
|
||||
|
||||
REPO { "git" "fetch" REMOTE-BRANCH } git-process drop ]
|
||||
|
||||
GADGET fetch-period>> sleep
|
||||
|
||||
t
|
||||
]
|
||||
if
|
||||
|
||||
|
||||
]
|
||||
loop
|
||||
|
||||
]
|
||||
|
||||
in-thread ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: start-monitor-thread ( GADGET -- )
|
||||
|
||||
GADGET f >>closed drop
|
||||
|
||||
[
|
||||
[
|
||||
[let | MONITOR [ GADGET repository>> t <monitor> ] |
|
||||
|
||||
[
|
||||
GADGET closed>>
|
||||
[ f ]
|
||||
[
|
||||
|
||||
[let | PATH [ MONITOR next-change drop ] |
|
||||
|
||||
".git" PATH subseq?
|
||||
[ ]
|
||||
[
|
||||
micros
|
||||
GADGET last-refresh>> 0 or -
|
||||
1000000 >
|
||||
[
|
||||
GADGET micros >>last-refresh drop
|
||||
GADGET refresh-git-remote-gadget
|
||||
]
|
||||
when
|
||||
]
|
||||
if ]
|
||||
|
||||
t
|
||||
|
||||
]
|
||||
if
|
||||
]
|
||||
loop
|
||||
]
|
||||
]
|
||||
with-monitors
|
||||
]
|
||||
in-thread ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M: <git-remote-gadget> pref-dim* ( gadget -- dim ) drop { 500 500 } ;
|
||||
|
||||
M:: <git-remote-gadget> graft* ( GADGET -- )
|
||||
GADGET start-fetch-thread
|
||||
GADGET start-monitor-thread ;
|
||||
|
||||
M:: <git-remote-gadget> ungraft* ( GADGET -- ) GADGET t >>closed drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: git-remote-tool ( REPO -- )
|
||||
|
||||
<git-remote-gadget> new-gadget
|
||||
|
||||
{ 0 1 } >>orientation
|
||||
1 >>fill
|
||||
|
||||
REPO >>repository
|
||||
|
||||
"origin" >>remote
|
||||
|
||||
"master" >>remote-branch
|
||||
|
||||
5 minutes >>fetch-period
|
||||
|
||||
dup refresh-git-remote-gadget
|
||||
|
||||
"git-remote-tool" open-window ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: factor-git-remote-tool ( -- ) "resource:" git-remote-tool ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
MAIN: factor-git-remote-tool
|
||||
|
|
@ -53,6 +53,20 @@ beast.
|
|||
factor image (overwriting the current one) with all the needed
|
||||
vocabs.
|
||||
|
||||
*** Connecting to a running Factor
|
||||
|
||||
'run-factor' starts a new factor listener process managed by Emacs.
|
||||
If you prefer to start Factor externally, you can also connect
|
||||
remotely from Emacs. Here's how to proceed:
|
||||
|
||||
- In the factor listener, run FUEL:
|
||||
"fuel" run
|
||||
This will start a server listener in port 9000.
|
||||
- Switch to Emacs and issue the command 'M-x connect-to-factor'.
|
||||
|
||||
That's it; you should be up and running. See the help for
|
||||
'connect-to-factor' for how to use a different port.
|
||||
|
||||
*** Vocabulary creation
|
||||
|
||||
FUEL offers a basic interface with Factor's scaffolding utilities.
|
||||
|
|
@ -99,8 +113,10 @@ beast.
|
|||
- C-cC-dp : find words containing given substring (M-x fuel-apropos)
|
||||
- C-cC-dv : show words in current file (with prefix, ask for vocab)
|
||||
|
||||
- C-cM-<, C-cC-d< : show callers of word at point
|
||||
- C-cM->, C-cC-d> : show callees of word at point
|
||||
- C-cM-<, C-cC-d< : show callers of word or vocabulary at point
|
||||
(M-x fuel-show-callers, M-x fuel-vocab-usage)
|
||||
- C-cM->, C-cC-d> : show callees of word or vocabulary at point
|
||||
(M-x fuel-show-callees, M-x fuel-vocab-uses)
|
||||
|
||||
- C-cC-xs : extract innermost sexp (up to point) as a separate word
|
||||
- C-cC-xr : extract region as a separate word
|
||||
|
|
|
|||
|
|
@ -24,6 +24,9 @@
|
|||
(autoload 'switch-to-factor "fuel-listener.el"
|
||||
"Start a Factor listener, or switch to a running one." t)
|
||||
|
||||
(autoload 'connect-to-factor "fuel-listener.el"
|
||||
"Connect to an external Factor listener." t)
|
||||
|
||||
(autoload 'fuel-autodoc-mode "fuel-help.el"
|
||||
"Minor mode showing in the minibuffer a synopsis of Factor word at point."
|
||||
t)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; fuel-completion.el -- completion utilities
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
|
|
@ -32,6 +32,10 @@
|
|||
(fuel-eval--send/wait '(:fuel* (fuel-get-vocabs) "fuel" (:array)))))))
|
||||
fuel-completion--vocabs)
|
||||
|
||||
(defun fuel-completion--read-vocab (&optional reload init-input history)
|
||||
(let ((vocabs (fuel-completion--vocabs reload)))
|
||||
(completing-read "Vocab name: " vocabs nil nil init-input history)))
|
||||
|
||||
(defsubst fuel-completion--vocab-list (prefix)
|
||||
(fuel-eval--retort-result
|
||||
(fuel-eval--send/wait `(:fuel* (,prefix fuel-get-vocabs/prefix) t t))))
|
||||
|
|
|
|||
|
|
@ -213,7 +213,7 @@ the debugger."
|
|||
(goto-char (point-min))
|
||||
(when (search-forward (car ci) nil t)
|
||||
(setq str (format "%c %s, %s" (cdr ci) (car ci) str))))))
|
||||
(if (and (not err) fuel-debug--uses) "u to update USING:, " "")))
|
||||
(if fuel-debug--uses "u to update USING:, " "")))
|
||||
|
||||
(defun fuel-debug--buffer-file ()
|
||||
(with-current-buffer (fuel-debug--buffer)
|
||||
|
|
|
|||
|
|
@ -22,21 +22,30 @@
|
|||
|
||||
;;; Customization
|
||||
|
||||
(defcustom fuel-edit-word-method nil
|
||||
"How the new buffer is opened when invoking
|
||||
\\[fuel-edit-word-at-point]."
|
||||
:group 'fuel
|
||||
:type '(choice (const :tag "Other window" window)
|
||||
(const :tag "Other frame" frame)
|
||||
(const :tag "Current window" nil)))
|
||||
(defmacro fuel-edit--define-custom-visit (var group doc)
|
||||
`(defcustom ,var nil
|
||||
,doc
|
||||
:group ',group
|
||||
:type '(choice (const :tag "Other window" window)
|
||||
(const :tag "Other frame" frame)
|
||||
(const :tag "Current window" nil))))
|
||||
|
||||
(fuel-edit--define-custom-visit
|
||||
fuel-edit-word-method fuel
|
||||
"How the new buffer is opened when invoking \\[fuel-edit-word-at-point]")
|
||||
|
||||
|
||||
;;; Auxiliar functions:
|
||||
|
||||
(defun fuel-edit--visit-file (file method)
|
||||
(cond ((eq method 'window) (find-file-other-window file))
|
||||
((eq method 'frame) (find-file-other-frame file))
|
||||
(t (find-file file))))
|
||||
|
||||
(defun fuel-edit--looking-at-vocab ()
|
||||
(save-excursion
|
||||
(fuel-syntax--beginning-of-defun)
|
||||
(looking-at "USING:\\|USE:")))
|
||||
(looking-at "USING:\\|USE:\\|IN:")))
|
||||
|
||||
(defun fuel-edit--try-edit (ret)
|
||||
(let* ((err (fuel-eval--retort-error ret))
|
||||
|
|
@ -45,9 +54,7 @@
|
|||
(error "Couldn't find edit location"))
|
||||
(unless (file-readable-p (car loc))
|
||||
(error "Couldn't open '%s' for read" (car loc)))
|
||||
(cond ((eq fuel-edit-word-method 'window) (find-file-other-window (car loc)))
|
||||
((eq fuel-edit-word-method 'frame) (find-file-other-frame (car loc)))
|
||||
(t (find-file (car loc))))
|
||||
(fuel-edit--visit-file (car loc) fuel-edit-word-method)
|
||||
(goto-line (if (numberp (cadr loc)) (cadr loc) 1))))
|
||||
|
||||
(defun fuel-edit--read-vocabulary-name (refresh)
|
||||
|
|
@ -86,7 +93,7 @@ offered."
|
|||
nil
|
||||
fuel-edit--word-history
|
||||
arg))
|
||||
(cmd `(:fuel* ((:quote ,word) fuel-get-edit-location))))
|
||||
(cmd `(:fuel* ((:quote ,word) fuel-get-word-location))))
|
||||
(fuel-edit--try-edit (fuel-eval--send/wait cmd))))
|
||||
|
||||
(defun fuel-edit-word-at-point (&optional arg)
|
||||
|
|
@ -95,7 +102,7 @@ With prefix, asks for the word to edit."
|
|||
(interactive "P")
|
||||
(let* ((word (or (and (not arg) (fuel-syntax-symbol-at-point))
|
||||
(fuel-completion--read-word "Edit word: ")))
|
||||
(cmd `(:fuel* ((:quote ,word) fuel-get-edit-location)))
|
||||
(cmd `(:fuel* ((:quote ,word) fuel-get-word-location)))
|
||||
(marker (and (not arg) (point-marker))))
|
||||
(if (and (not arg) (fuel-edit--looking-at-vocab))
|
||||
(fuel-edit-vocabulary nil word)
|
||||
|
|
|
|||
|
|
@ -92,9 +92,9 @@
|
|||
`((,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
|
||||
(,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word)
|
||||
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
|
||||
(,fuel-syntax--constructor-regex (1 'factor-font-lock-word)
|
||||
(2 'factor-font-lock-type-name)
|
||||
(3 'factor-font-lock-invalid-syntax nil t))
|
||||
(,fuel-syntax--constructor-decl-regex (1 'factor-font-lock-word)
|
||||
(2 'factor-font-lock-type-name)
|
||||
(3 'factor-font-lock-invalid-syntax nil t))
|
||||
(,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name)
|
||||
(2 'factor-font-lock-type-name)
|
||||
(3 'factor-font-lock-invalid-syntax nil t))
|
||||
|
|
|
|||
|
|
@ -87,6 +87,17 @@ buffer."
|
|||
(fuel-listener--wait-for-prompt 10000)
|
||||
(fuel-con--setup-connection (current-buffer))))
|
||||
|
||||
(defun fuel-listener--connect-process (port)
|
||||
(message "Connecting to remote listener ...")
|
||||
(pop-to-buffer (fuel-listener--buffer))
|
||||
(let ((process (get-buffer-process (current-buffer))))
|
||||
(when (or (not process)
|
||||
(y-or-n-p "Kill current listener? "))
|
||||
(make-comint-in-buffer "fuel listener" (current-buffer)
|
||||
(cons "localhost" port))
|
||||
(fuel-listener--wait-for-prompt 10000)
|
||||
(fuel-con--setup-connection (current-buffer)))))
|
||||
|
||||
(defun fuel-listener--process (&optional start)
|
||||
(or (and (buffer-live-p (fuel-listener--buffer))
|
||||
(get-buffer-process (fuel-listener--buffer)))
|
||||
|
|
@ -123,6 +134,17 @@ buffer."
|
|||
(pop-to-buffer buf)
|
||||
(switch-to-buffer buf))))
|
||||
|
||||
(defun connect-to-factor (&optional arg)
|
||||
"Connects to a remote listener running in the same host.
|
||||
Without prefix argument, the default port, 9000, is used.
|
||||
Otherwise, you'll be prompted for it. To make this work, in the
|
||||
remote listener you need to issue the words
|
||||
'fuel-start-remote-listener*' or 'port
|
||||
fuel-start-remote-listener', from the fuel vocabulary."
|
||||
(interactive "P")
|
||||
(let ((port (if (not arg) 9000 (read-number "Port: "))))
|
||||
(fuel-listener--connect-process port)))
|
||||
|
||||
(defun fuel-listener-nuke ()
|
||||
"Try this command if the listener becomes unresponsive."
|
||||
(interactive)
|
||||
|
|
|
|||
|
|
@ -103,10 +103,10 @@
|
|||
(let* ((code (buffer-substring begin end))
|
||||
(existing (fuel-refactor--reuse-existing code))
|
||||
(code-str (or existing (fuel--region-to-string begin end)))
|
||||
(word (or (car existing) (read-string "New word name: ")))
|
||||
(stack-effect (or existing
|
||||
(fuel-stack--infer-effect code-str)
|
||||
(read-string "Stack effect: ")))
|
||||
(word (or (car existing) (read-string "New word name: "))))
|
||||
(read-string "Stack effect: "))))
|
||||
(goto-char begin)
|
||||
(delete-region begin end)
|
||||
(insert word)
|
||||
|
|
@ -164,6 +164,11 @@ word."
|
|||
(save-excursion (font-lock-fontify-region start (point)))
|
||||
(indent-region start (point))))))
|
||||
|
||||
|
||||
;;; Rename word:
|
||||
|
||||
|
||||
|
||||
|
||||
;;; Extract vocab:
|
||||
|
||||
|
|
|
|||
|
|
@ -209,7 +209,7 @@
|
|||
(format ":[^ ]* [^ ]+\\(%s\\)*" fuel-syntax--stack-effect-regex)
|
||||
"M[^:]*: [^ ]+ [^ ]+"))
|
||||
|
||||
(defconst fuel-syntax--constructor-regex
|
||||
(defconst fuel-syntax--constructor-decl-regex
|
||||
"\\_<C: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")
|
||||
|
||||
(defconst fuel-syntax--typedef-regex
|
||||
|
|
@ -246,7 +246,7 @@
|
|||
("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">"))
|
||||
("\\_<\\((\\) \\([^)\n]*?\\) \\()\\)\\_>" (1 "<b") (2 "w") (3 ">b"))
|
||||
;; Strings
|
||||
("\\_<\\(\"\\)\\([^\n\r\f\"]\\|\\\\\"\\)*\\(\"\\)\\_>" (1 "\"") (3 "\""))
|
||||
("\\( \\|^\\)\\(\"\\)[^\n\r\f]*\\(\"\\)\\( \\|\n\\)" (2 "\"") (3 "\""))
|
||||
("\\_<<\\(\"\\)\\_>" (1 "<b"))
|
||||
("\\_<\\(\"\\)>\\_>" (1 ">b"))
|
||||
;; Multiline constructs
|
||||
|
|
|
|||
|
|
@ -37,6 +37,11 @@ cursor at the first ocurrence of the used word."
|
|||
:group 'fuel-xref
|
||||
:type 'boolean)
|
||||
|
||||
(fuel-edit--define-custom-visit
|
||||
fuel-xref-follow-link-method
|
||||
fuel-xref
|
||||
"How new buffers are opened when following a crossref link.")
|
||||
|
||||
(fuel-font-lock--defface fuel-font-lock-xref-link
|
||||
'link fuel-xref "highlighting links in cross-reference buffers")
|
||||
|
||||
|
|
@ -59,12 +64,12 @@ cursor at the first ocurrence of the used word."
|
|||
(when (not (file-readable-p file))
|
||||
(error "File '%s' is not readable" file))
|
||||
(let ((word fuel-xref--word))
|
||||
(find-file-other-window file)
|
||||
(fuel-edit--visit-file file fuel-xref-follow-link-method)
|
||||
(when (numberp line) (goto-line line))
|
||||
(when (and word fuel-xref-follow-link-to-word-p)
|
||||
(and (search-forward word
|
||||
(fuel-syntax--end-of-defun-pos)
|
||||
t)
|
||||
(and (re-search-forward (format "\\_<%s\\_>" word)
|
||||
(fuel-syntax--end-of-defun-pos)
|
||||
t)
|
||||
(goto-char (match-beginning 0)))))))
|
||||
|
||||
|
||||
|
|
@ -78,11 +83,11 @@ cursor at the first ocurrence of the used word."
|
|||
(defvar fuel-xref--help-string
|
||||
"(Press RET or click to follow crossrefs, or h for help on word at point)")
|
||||
|
||||
(defun fuel-xref--title (word cc count)
|
||||
(defun fuel-xref--title (word cc count thing)
|
||||
(put-text-property 0 (length word) 'font-lock-face 'bold word)
|
||||
(cond ((zerop count) (format "No known words %s %s" cc word))
|
||||
((= 1 count) (format "1 word %s %s:" cc word))
|
||||
(t (format "%s words %s %s:" count cc word))))
|
||||
(cond ((zerop count) (format "No known %s %s %s" thing cc word))
|
||||
((= 1 count) (format "1 %s %s %s:" thing cc word))
|
||||
(t (format "%s %ss %s %s:" count thing cc word))))
|
||||
|
||||
(defun fuel-xref--insert-ref (ref &optional no-vocab)
|
||||
(when (and (stringp (first ref))
|
||||
|
|
@ -101,7 +106,7 @@ cursor at the first ocurrence of the used word."
|
|||
(newline)
|
||||
t))
|
||||
|
||||
(defun fuel-xref--fill-buffer (word cc refs &optional no-vocab app)
|
||||
(defun fuel-xref--fill-buffer (word cc refs &optional no-vocab app thing)
|
||||
(let ((inhibit-read-only t)
|
||||
(count 0))
|
||||
(with-current-buffer (fuel-xref--buffer)
|
||||
|
|
@ -113,34 +118,38 @@ cursor at the first ocurrence of the used word."
|
|||
(newline)
|
||||
(goto-char start)
|
||||
(save-excursion
|
||||
(insert (fuel-xref--title word cc count) "\n\n"))
|
||||
(insert (fuel-xref--title word cc count (or thing "word")) "\n\n"))
|
||||
count))))
|
||||
|
||||
(defun fuel-xref--fill-and-display (word cc refs &optional no-vocab)
|
||||
(let ((count (fuel-xref--fill-buffer word cc refs no-vocab)))
|
||||
(defun fuel-xref--fill-and-display (word cc refs &optional no-vocab thing)
|
||||
(let ((count (fuel-xref--fill-buffer word cc refs no-vocab nil (or thing "word"))))
|
||||
(if (zerop count)
|
||||
(error (fuel-xref--title word cc 0))
|
||||
(error (fuel-xref--title word cc 0 (or thing "word")))
|
||||
(message "")
|
||||
(fuel-popup--display (fuel-xref--buffer)))))
|
||||
|
||||
(defun fuel-xref--show-callers (word)
|
||||
(let* ((cmd `(:fuel* (((:quote ,word) fuel-callers-xref))))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(with-current-buffer (fuel-xref--buffer) (setq fuel-xref--word word))
|
||||
(fuel-xref--fill-and-display word "using" res)))
|
||||
|
||||
(defun fuel-xref--show-callees (word)
|
||||
(let* ((cmd `(:fuel* (((:quote ,word) fuel-callees-xref))))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(with-current-buffer (fuel-xref--buffer) (setq fuel-xref--word nil))
|
||||
(fuel-xref--fill-and-display word "used by" res)))
|
||||
|
||||
(defun fuel-xref--apropos (str)
|
||||
(let* ((cmd `(:fuel* ((,str fuel-apropos-xref))))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(with-current-buffer (fuel-xref--buffer) (setq fuel-xref--word nil))
|
||||
(fuel-xref--fill-and-display str "containing" res)))
|
||||
|
||||
(defun fuel-xref--show-vocab (vocab &optional app)
|
||||
(let* ((cmd `(:fuel* ((,vocab fuel-vocab-xref)) ,vocab))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(with-current-buffer (fuel-xref--buffer) (setq fuel-xref--word nil))
|
||||
(fuel-xref--fill-buffer vocab "in vocabulary" res t app)))
|
||||
|
||||
(defun fuel-xref--show-vocab-words (vocab &optional private)
|
||||
|
|
@ -151,13 +160,25 @@ cursor at the first ocurrence of the used word."
|
|||
(fuel-popup--display (fuel-xref--buffer))
|
||||
(goto-char (point-min)))
|
||||
|
||||
(defun fuel-xref--show-vocab-usage (vocab)
|
||||
(let* ((cmd `(:fuel* ((,vocab fuel-vocab-usage-xref))))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(with-current-buffer (fuel-xref--buffer) (setq fuel-xref--word nil))
|
||||
(fuel-xref--fill-and-display vocab "using" res t "vocab")))
|
||||
|
||||
(defun fuel-xref--show-vocab-uses (vocab)
|
||||
(let* ((cmd `(:fuel* ((,vocab fuel-vocab-uses-xref))))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(with-current-buffer (fuel-xref--buffer) (setq fuel-xref--word nil))
|
||||
(fuel-xref--fill-and-display vocab "used by" res t "vocab")))
|
||||
|
||||
|
||||
;;; User commands:
|
||||
|
||||
(defvar fuel-xref--word-history nil)
|
||||
|
||||
(defun fuel-show-callers (&optional arg)
|
||||
"Show a list of callers of word at point.
|
||||
"Show a list of callers of word or vocabulary at point.
|
||||
With prefix argument, ask for word."
|
||||
(interactive "P")
|
||||
(let ((word (if arg (fuel-completion--read-word "Find callers for: "
|
||||
|
|
@ -165,11 +186,14 @@ With prefix argument, ask for word."
|
|||
fuel-xref--word-history)
|
||||
(fuel-syntax-symbol-at-point))))
|
||||
(when word
|
||||
(message "Looking up %s's callers ..." word)
|
||||
(fuel-xref--show-callers word))))
|
||||
(message "Looking up %s's users ..." word)
|
||||
(if (and (not arg)
|
||||
(fuel-edit--looking-at-vocab))
|
||||
(fuel-xref--show-vocab-usage word)
|
||||
(fuel-xref--show-callers word)))))
|
||||
|
||||
(defun fuel-show-callees (&optional arg)
|
||||
"Show a list of callers of word at point.
|
||||
"Show a list of callers of word or vocabulary at point.
|
||||
With prefix argument, ask for word."
|
||||
(interactive "P")
|
||||
(let ((word (if arg (fuel-completion--read-word "Find callees for: "
|
||||
|
|
@ -178,7 +202,30 @@ With prefix argument, ask for word."
|
|||
(fuel-syntax-symbol-at-point))))
|
||||
(when word
|
||||
(message "Looking up %s's callees ..." word)
|
||||
(fuel-xref--show-callees word))))
|
||||
(if (and (not arg)
|
||||
(fuel-edit--looking-at-vocab))
|
||||
(fuel-xref--show-vocab-uses word)
|
||||
(fuel-xref--show-callees word)))))
|
||||
|
||||
(defvar fuel-xref--vocab-history nil)
|
||||
|
||||
(defun fuel-vocab-uses (&optional arg)
|
||||
"Show a list of vocabularies used by a given one.
|
||||
With prefix argument, force reload of vocabulary list."
|
||||
(interactive "P")
|
||||
(let ((vocab (fuel-completion--read-vocab arg
|
||||
(fuel-syntax-symbol-at-point)
|
||||
fuel-xref--vocab-history)))
|
||||
(fuel-xref--show-vocab-uses vocab)))
|
||||
|
||||
(defun fuel-vocab-usage (&optional arg)
|
||||
"Show a list of vocabularies that use a given one.
|
||||
With prefix argument, force reload of vocabulary list."
|
||||
(interactive "P")
|
||||
(let ((vocab (fuel-completion--read-vocab arg
|
||||
(fuel-syntax-symbol-at-point)
|
||||
fuel-xref--vocab-history)))
|
||||
(fuel-xref--show-vocab-usage vocab)))
|
||||
|
||||
(defun fuel-apropos (str)
|
||||
"Show a list of words containing the given substring."
|
||||
|
|
|
|||
13
vm/image.c
13
vm/image.c
|
|
@ -112,10 +112,7 @@ bool save_image(const F_CHAR *filename)
|
|||
FILE* file;
|
||||
F_HEADER h;
|
||||
|
||||
F_CHAR temporary_filename[] = STRING_LITERAL("##saving-factor-image##");
|
||||
|
||||
file = OPEN_WRITE(filename);
|
||||
//file = OPEN_WRITE(temporary_filename);
|
||||
if(file == NULL)
|
||||
{
|
||||
print_string("Cannot open image file: "); print_native_string(filename); nl();
|
||||
|
|
@ -167,16 +164,6 @@ bool save_image(const F_CHAR *filename)
|
|||
}
|
||||
|
||||
return true;
|
||||
|
||||
if(MOVE_FILE_FAILS(temporary_filename, filename))
|
||||
{
|
||||
print_string("Failed to rename tempoarary image file: "); print_string(strerror(errno)); nl();
|
||||
//if(DELETE_FILE_FAILS(temporary_filename))
|
||||
//print_string("Failed to clean up temporary image file: "); print_string(strerror(errno)); nl();
|
||||
return false;
|
||||
}
|
||||
|
||||
return true;
|
||||
}
|
||||
|
||||
void primitive_save_image(void)
|
||||
|
|
|
|||
|
|
@ -22,8 +22,6 @@ typedef char F_SYMBOL;
|
|||
#define STRCMP strcmp
|
||||
#define STRNCMP strncmp
|
||||
#define STRDUP strdup
|
||||
#define MOVE_FILE_FAILS(old,new) (rename((old),(new)) < 0)
|
||||
#define DELETE_FILE_FAILS(old) (unlink((old)) < 0)
|
||||
|
||||
#define FIXNUM_FORMAT "%ld"
|
||||
#define CELL_FORMAT "%lu"
|
||||
|
|
|
|||
|
|
@ -19,8 +19,6 @@ typedef wchar_t F_CHAR;
|
|||
#define STRCMP wcscmp
|
||||
#define STRNCMP wcsncmp
|
||||
#define STRDUP _wcsdup
|
||||
#define MOVE_FILE_FAILS(old,new) (MoveFile((old),(new)) == 0)
|
||||
#define DELETE_FILE_FAILS(old) (DeleteFile((old)) == 0)
|
||||
|
||||
#ifdef WIN64
|
||||
#define CELL_FORMAT "%Iu"
|
||||
|
|
|
|||
Loading…
Reference in New Issue