Merge branch 'emacs' of http://git.hacks-galore.org/jao/factor into new_ui

db4
Slava Pestov 2009-01-08 13:10:51 -06:00
commit 51232b4451
23 changed files with 310 additions and 127 deletions

View File

@ -3,7 +3,7 @@
USING: combinators.short-circuit unicode.categories kernel math USING: combinators.short-circuit unicode.categories kernel math
combinators splitting sequences math.parser io.files io assocs combinators splitting sequences math.parser io.files io assocs
arrays namespaces make math.ranges unicode.normalize.private values arrays namespaces make math.ranges unicode.normalize.private values
io.encodings.ascii unicode.syntax unicode.data compiler.units io.encodings.ascii unicode.syntax unicode.data compiler.units fry
alien.syntax sets accessors interval-maps memoize locals words ; alien.syntax sets accessors interval-maps memoize locals words ;
IN: unicode.breaks IN: unicode.breaks
@ -111,14 +111,9 @@ PRIVATE>
<PRIVATE <PRIVATE
:: (>pieces) ( str quot -- ) : >pieces ( str quot: ( str -- i ) -- graphemes )
str [ [ dup empty? not ] swap '[ dup @ cut-slice swap ]
dup quot call cut-slice [ ] produce nip ; inline
swap , quot (>pieces)
] unless-empty ; inline recursive
: >pieces ( str quot -- graphemes )
[ (>pieces) ] { } make ; inline
PRIVATE> PRIVATE>

View File

@ -4,7 +4,7 @@ USING: unicode.case tools.test namespaces ;
\ >lower must-infer \ >lower must-infer
\ >title must-infer \ >title must-infer
[ "Hello How Are You? I'M Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test [ "Hello How Are You? I'm Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test
[ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test [ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test
[ "\u0003C3\u0003C2" ] [ "\u0003A3\u0003A3" >lower ] unit-test [ "\u0003C3\u0003C2" ] [ "\u0003A3\u0003A3" >lower ] unit-test
[ t ] [ "hello how are you?" lower? ] unit-test [ t ] [ "hello how are you?" lower? ] unit-test

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: unicode.data sequences sequences.next namespaces make USING: unicode.data sequences sequences.next namespaces make
unicode.normalize math unicode.categories combinators unicode.normalize math unicode.categories combinators
assocs strings splitting kernel accessors ; assocs strings splitting kernel accessors unicode.breaks ;
IN: unicode.case IN: unicode.case
<PRIVATE <PRIVATE
@ -82,23 +82,30 @@ SYMBOL: locale ! Just casing locale, or overall?
[ [ % ] compose ] [ [ , ] compose ] bi* ?if [ [ % ] compose ] [ [ , ] compose ] bi* ?if
] 2curry each ] 2curry each
] "" make ; inline ] "" make ; inline
PRIVATE>
: >lower ( string -- lower )
i-dot? [ turk>lower ] when
final-sigma [ lower>> ] [ ch>lower ] map-case ;
: >upper ( string -- upper ) : (>lower) ( string -- lower )
i-dot? [ turk>upper ] when [ lower>> ] [ ch>lower ] map-case ;
: (>title) ( string -- title )
[ title>> ] [ ch>title ] map-case ;
: (>upper) ( string -- upper )
[ upper>> ] [ ch>upper ] map-case ; [ upper>> ] [ ch>upper ] map-case ;
: title-word ( string -- title )
unclip 1string [ (>lower) ] [ (>title) ] bi* prepend ;
PRIVATE>
: >lower ( string -- lower )
i-dot? [ turk>lower ] when
final-sigma (>lower) ;
: >upper ( string -- upper )
i-dot? [ turk>upper ] when (>upper) ;
: >title ( string -- title ) : >title ( string -- title )
final-sigma final-sigma >words [ title-word ] map concat ;
CHAR: \s swap
[ tuck word-boundary swapd
[ title>> ] [ lower>> ] if ]
[ tuck word-boundary swapd
[ ch>title ] [ ch>lower ] if ]
map-case nip ;
: >case-fold ( string -- fold ) : >case-fold ( string -- fold )
>upper >lower ; >upper >lower ;

View File

@ -1,6 +1,6 @@
USING: io io.files splitting grouping unicode.collation USING: io io.files splitting grouping unicode.collation
sequences kernel io.encodings.utf8 math.parser math.order sequences kernel io.encodings.utf8 math.parser math.order
tools.test assocs io.streams.null words ; tools.test assocs words ;
IN: unicode.collation.tests IN: unicode.collation.tests
: parse-test ( -- strings ) : parse-test ( -- strings )
@ -25,4 +25,4 @@ IN: unicode.collation.tests
unit-test unit-test
parse-test 2 <clumps> parse-test 2 <clumps>
[ [ test-two ] assoc-each ] with-null-writer [ test-two ] assoc-each

View File

@ -28,10 +28,6 @@ VALUE: properties
: char>name ( char -- string ) name-map value-at ; : char>name ( char -- string ) name-map value-at ;
: property? ( char property -- ? ) properties at interval-key? ; : property? ( char property -- ? ) properties at interval-key? ;
! Convenience functions
: ?between? ( n/f from to -- ? )
pick [ between? ] [ 3drop f ] if ;
! Loading data from UnicodeData.txt ! Loading data from UnicodeData.txt
: split-; ( line -- array ) : split-; ( line -- array )
@ -206,9 +202,9 @@ SYMBOL: interned
: expand-ranges ( assoc -- interval-map ) : expand-ranges ( assoc -- interval-map )
[ [
[ [
CHAR: . pick member? [ swap CHAR: . over member? [
swap ".." split1 [ hex> ] bi@ 2array ".." split1 [ hex> ] bi@ 2array
] [ swap hex> ] if range, ] [ hex> ] if range,
] assoc-each ] assoc-each
] { } make <interval-map> ; ] { } make <interval-map> ;

View File

@ -8,9 +8,7 @@ ARTICLE: "unicode.normalize" "Unicode normalization"
{ $subsection nfc } { $subsection nfc }
{ $subsection nfd } { $subsection nfd }
{ $subsection nfkc } { $subsection nfkc }
{ $subsection nfkd } { $subsection nfkd } ;
"If two strings in a normalization form are appended, the result may not be in that normalization form still. To append two strings in NFD and make sure the result is in NFD, the following procedure is supplied:"
{ $subsection string-append } ;
HELP: nfc HELP: nfc
{ $values { "string" string } { "nfc" "a string in NFC" } } { $values { "string" string } { "nfc" "a string in NFC" } }
@ -27,7 +25,3 @@ HELP: nfkc
HELP: nfkd HELP: nfkd
{ $values { "string" string } { "nfc" "a string in NFKD" } } { $values { "string" string } { "nfc" "a string in NFKD" } }
{ $description "Converts a string to Normalization Form KD" } ; { $description "Converts a string to Normalization Form KD" } ;
HELP: string-append
{ $values { "s1" "a string in NFD" } { "s2" "a string in NFD" } { "string" "a string in NFD" } }
{ $description "Appends two strings, putting the result in NFD." } ;

View File

@ -1,6 +1,6 @@
USING: unicode.normalize kernel tools.test sequences USING: unicode.normalize kernel tools.test sequences
unicode.data io.encodings.utf8 io.files splitting math.parser unicode.data io.encodings.utf8 io.files splitting math.parser
locals math quotations assocs combinators ; locals math quotations assocs combinators unicode.normalize.private ;
IN: unicode.normalize.tests IN: unicode.normalize.tests
[ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test [ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test

View File

@ -1,21 +1,24 @@
! Copyright (C) 2008 Daniel Ehrenberg. ! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: sequences namespaces make unicode.data kernel math arrays USING: sequences namespaces make unicode.data kernel math arrays
locals sorting.insertion accessors assocs ; locals sorting.insertion accessors assocs math.order ;
IN: unicode.normalize IN: unicode.normalize
<PRIVATE <PRIVATE
! Conjoining Jamo behavior ! Conjoining Jamo behavior
: hangul-base HEX: ac00 ; inline CONSTANT: hangul-base HEX: ac00
: hangul-end HEX: D7AF ; inline CONSTANT: hangul-end HEX: D7AF
: initial-base HEX: 1100 ; inline CONSTANT: initial-base HEX: 1100
: medial-base HEX: 1161 ; inline CONSTANT: medial-base HEX: 1161
: final-base HEX: 11a7 ; inline CONSTANT: final-base HEX: 11a7
: initial-count 19 ; inline CONSTANT: initial-count 19
: medial-count 21 ; inline CONSTANT: medial-count 21
: final-count 28 ; inline CONSTANT: final-count 28
: ?between? ( n/f from to -- ? )
pick [ between? ] [ 3drop f ] if ;
: hangul? ( ch -- ? ) hangul-base hangul-end ?between? ; : hangul? ( ch -- ? ) hangul-base hangul-end ?between? ;
: jamo? ( ch -- ? ) HEX: 1100 HEX: 11FF ?between? ; : jamo? ( ch -- ? ) HEX: 1100 HEX: 11FF ?between? ;
@ -84,8 +87,6 @@ PRIVATE>
[ compatibility-entry ] decompose ; [ compatibility-entry ] decompose ;
: string-append ( s1 s2 -- string ) : string-append ( s1 s2 -- string )
! This could be more optimized,
! but in practice, it'll almost always just be append
[ append ] keep [ append ] keep
0 over ?nth non-starter? 0 over ?nth non-starter?
[ length dupd reorder-back ] [ drop ] if ; [ length dupd reorder-back ] [ drop ] if ;
@ -154,7 +155,7 @@ DEFER: compose-iter
] if (compose) ] if (compose)
] when* ; ] when* ;
: compose ( str -- comp ) : combine ( str -- comp )
[ [
main-str set main-str set
0 ind set 0 ind set
@ -165,7 +166,7 @@ DEFER: compose-iter
PRIVATE> PRIVATE>
: nfc ( string -- nfc ) : nfc ( string -- nfc )
nfd compose ; nfd combine ;
: nfkc ( string -- nfkc ) : nfkc ( string -- nfkc )
nfkd compose ; nfkd combine ;

View File

@ -256,7 +256,9 @@ DEFER: default-L-parser-values
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: <L-system> < gadget TUPLE: <L-system> < gadget
camera display-list pedestal paused commands axiom rules string ; camera display-list pedestal paused
turtle-values
commands axiom rules string ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -376,6 +378,7 @@ TUPLE: <L-system> < gadget
L-SYSTEM display-list>> GL_COMPILE glNewList L-SYSTEM display-list>> GL_COMPILE glNewList
turtle turtle
L-SYSTEM turtle-values>> [ ] or call
L-SYSTEM string>> L-SYSTEM axiom>> or L-SYSTEM string>> L-SYSTEM axiom>> or
L-SYSTEM commands>> L-SYSTEM commands>>
interpret-string interpret-string
@ -445,6 +448,11 @@ H{
{ T{ key-down f f "q" } [ [ 5 roll-left ] with-camera ] } { T{ key-down f f "q" } [ [ 5 roll-left ] with-camera ] }
{ T{ key-down f f "w" } [ [ 5 roll-right ] with-camera ] } { T{ key-down f f "w" } [ [ 5 roll-right ] with-camera ] }
{ T{ key-down f { A+ } "LEFT" } [ [ 1 strafe-left ] with-camera ] }
{ T{ key-down f { A+ } "RIGHT" } [ [ 1 strafe-right ] with-camera ] }
{ T{ key-down f { A+ } "UP" } [ [ 1 strafe-up ] with-camera ] }
{ T{ key-down f { A+ } "DOWN" } [ [ 1 strafe-down ] with-camera ] }
{ T{ key-down f f "r" } [ start-rotation-thread ] } { T{ key-down f f "r" } [ start-rotation-thread ] }
{ {

View File

@ -9,20 +9,23 @@ IN: L-system.models.abop-2
L-parser-dialect >>commands L-parser-dialect >>commands
[ 30 >>angle ] >>turtle-values
"c(12)FAL" >>axiom "c(12)FAL" >>axiom
{ {
{ "A" "F[&'(.7)!BL]>(137)[&'(.6)!BL]>(137)'(.9)!(.9)A" } { "A" "F [&'(.7)!BL] >(137) [&'(.6)!BL] >(137) '(.9) !(.9) A" }
{ "B" "F[-'(.7)!(.9)$CL]'(.9)!(.9)C" }
{ "C" "F[+'(.7)!(.9)$BL]'(.9)!(.9)B" } { "B" "F [- '(.7) !(.9) $ C L] '(.9) !(.9) C" }
{ "C" "F [+ '(.7) !(.9) $ B L] '(.9) !(.9) B" }
{ "L" "~c(8){+f(.1)-f(.1)-f(.1)+|+f(.1)-f(.1)-f(.1)}" } { "L" "~c(8){+f(.1)-f(.1)-f(.1)+|+f(.1)-f(.1)-f(.1)}" }
} >>rules ; } >>rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: main ( -- ) [ L-system abop-2 "L-system" open-window ] with-ui ; : main ( -- ) [ L-system abop-2 "L-system" open-window ] with-ui ;
MAIN: main MAIN: main

View File

@ -9,6 +9,8 @@ IN: L-system.models.abop-3
L-parser-dialect >>commands L-parser-dialect >>commands
[ 30 >>angle ] >>turtle-values
"c(12)FA" >>axiom "c(12)FA" >>axiom
{ {

View File

@ -9,6 +9,8 @@ IN: L-system.models.abop-4
L-parser-dialect >>commands L-parser-dialect >>commands
[ 18 >>angle ] >>turtle-values
"c(12)&(20)N" >>axiom "c(12)&(20)N" >>axiom
{ {

View File

@ -0,0 +1,33 @@
USING: accessors ui L-system ;
IN: L-system.models.abop-5-angular
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: abop-5-angular ( <L-system> -- <L-system> )
L-parser-dialect >>commands
"&(90)+(90)a" >>axiom
{
{ "a" "F[+(45)l][-(45)l]^;ca" }
{ "l" "j" }
{ "j" "h" }
{ "h" "s" }
{ "s" "d" }
{ "d" "x" }
{ "x" "a" }
{ "F" "'(1.17)F'(.855)" }
}
>>rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: main ( -- ) [ L-system abop-5-angular "L-system" open-window ] with-ui ;
MAIN: main

View File

@ -9,7 +9,9 @@ IN: L-system.models.abop-5
L-parser-dialect >>commands L-parser-dialect >>commands
"&(90)+(90)a" >>axiom [ 5 >>angle ] >>turtle-values
"a" >>axiom
{ {
{ "a" "F[+(45)l][-(45)l]^;ca" } { "a" "F[+(45)l][-(45)l]^;ca" }

View File

@ -0,0 +1,34 @@
USING: accessors ui L-system ;
IN: L-system.models.abop-6
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: abop-6 ( <L-system> -- <L-system> )
L-parser-dialect >>commands
[ 5 >>angle ] >>turtle-values
! "&(90)+(90)FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x"
"FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x"
>>axiom
{
{ "a" "F[cdx][cex]F!(.9)a" }
{ "x" "a" }
{ "d" "+d" }
{ "e" "-e" }
{ "F" "'(1.25)F'(.8)" }
}
>>rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: main ( -- ) [ L-system abop-6 "L-system" open-window ] with-ui ;
MAIN: main

View File

@ -0,0 +1,53 @@
USING: accessors ui L-system ;
IN: L-system.models.airhorse
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: airhorse ( <L-system> -- <L-system> )
L-parser-dialect >>commands
[ 10 >>angle ] >>turtle-values
"C" >>axiom
{
{ "C" "LBW" }
{ "B" "[[''aH]|[g]]" }
{ "a" "Fs+;'a" }
{ "g" "Ft+;'g" }
{ "s" "[::cc!!!!&&[FFcccZ]^^^^FFcccZ]" }
{ "t" "[c!!!!&[FF]^^FF]" }
{ "L" "O" }
{ "O" "P" }
{ "P" "Q" }
{ "Q" "R" }
{ "R" "U" }
{ "U" "X" }
{ "X" "Y" }
{ "Y" "V" }
{ "V" "[cc!!!&(90)[Zp]|[Zp]]" }
{ "p" "h>(120)h>(120)h" }
{ "h" "[+(40)!F'''p]" }
{ "H" "[cccci[>(50)dcFFF][<(50)ecFFF]]" }
{ "d" "Z!&Z!&:'d" }
{ "e" "Z!^Z!^:'e" }
{ "i" "-:/i" }
{ "W" "[%[!!cb][<<<!!cb][>>>!!cb]]" }
{ "b" "Fl!+Fl+;'b" }
{ "l" "[-cc{--z++z++z--|--z++z++z}]" }
}
>>rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: main ( -- ) [ L-system airhorse "L-system" open-window ] with-ui ;
MAIN: main

View File

@ -201,6 +201,9 @@ SYMBOL: :uses
: fuel-apropos-xref ( str -- ) : fuel-apropos-xref ( str -- )
words-matching fuel-format-xrefs fuel-eval-set-result ; inline words-matching fuel-format-xrefs fuel-eval-set-result ; inline
: fuel-vocab-xref ( vocab -- )
words fuel-format-xrefs fuel-eval-set-result ; inline
! Completion support ! Completion support
: fuel-filter-prefix ( seq prefix -- seq ) : fuel-filter-prefix ( seq prefix -- seq )

View File

@ -7,7 +7,7 @@ IN: update.latest
: git-pull-master ( -- ) : git-pull-master ( -- )
image parent-directory image parent-directory
[ [
{ "git" "pull" "http://factorcode.org/git/factor.git" "master" } { "git" "pull" "git://factorcode.org/git/factor.git" "master" }
run-command run-command
] ]
with-directory ; with-directory ;

View File

@ -70,11 +70,13 @@ beast.
- C-cC-ds : short help word at point - C-cC-ds : short help word at point
- C-cC-de : show stack effect of current sexp (with prefix, region) - C-cC-de : show stack effect of current sexp (with prefix, region)
- C-cC-dp : find words containing given substring (M-x fuel-apropos) - 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 callers of word at point
- C-cM->, C-cC-d> : show callees of word at point - C-cM->, C-cC-d> : show callees of word at point
- C-cC-xw : extract region as a separate word - C-cC-xs : extract innermost sexp (up to point) as a separate word
- C-cC-xr : extract region as a separate word
*** In the listener: *** In the listener:

View File

@ -132,37 +132,6 @@ With prefix argument, ask for the file name."
(let ((file (car (fuel-mode--read-file arg)))) (let ((file (car (fuel-mode--read-file arg))))
(when file (fuel-debug--uses-for-file file)))) (when file (fuel-debug--uses-for-file file))))
(defvar fuel-mode--word-history nil)
(defun fuel-show-callers (&optional arg)
"Show a list of callers of word at point.
With prefix argument, ask for word."
(interactive "P")
(let ((word (if arg (fuel-completion--read-word "Find callers for: "
(fuel-syntax-symbol-at-point)
fuel-mode--word-history)
(fuel-syntax-symbol-at-point))))
(when word
(message "Looking up %s's callers ..." word)
(fuel-xref--show-callers word))))
(defun fuel-show-callees (&optional arg)
"Show a list of callers of word at point.
With prefix argument, ask for word."
(interactive "P")
(let ((word (if arg (fuel-completion--read-word "Find callees for: "
(fuel-syntax-symbol-at-point)
fuel-mode--word-history)
(fuel-syntax-symbol-at-point))))
(when word
(message "Looking up %s's callees ..." word)
(fuel-xref--show-callees word))))
(defun fuel-apropos (str)
"Show a list of words containing the given substring."
(interactive "MFind words containing: ")
(message "Looking up %s's references ..." str)
(fuel-xref--apropos str))
;;; Minor mode definition: ;;; Minor mode definition:
@ -225,10 +194,12 @@ interacting with a factor listener is at your disposal.
(fuel-mode--key ?e ?w 'fuel-edit-word) (fuel-mode--key ?e ?w 'fuel-edit-word)
(fuel-mode--key ?e ?x 'fuel-eval-definition) (fuel-mode--key ?e ?x 'fuel-eval-definition)
(fuel-mode--key ?x ?w 'fuel-refactor-extract-word) (fuel-mode--key ?x ?s 'fuel-refactor-extract-sexp)
(fuel-mode--key ?x ?r 'fuel-refactor-extract-region)
(fuel-mode--key ?d ?> 'fuel-show-callees) (fuel-mode--key ?d ?> 'fuel-show-callees)
(fuel-mode--key ?d ?< 'fuel-show-callers) (fuel-mode--key ?d ?< 'fuel-show-callers)
(fuel-mode--key ?d ?v 'fuel-show-file-words)
(fuel-mode--key ?d ?a 'fuel-autodoc-mode) (fuel-mode--key ?d ?a 'fuel-autodoc-mode)
(fuel-mode--key ?d ?p 'fuel-apropos) (fuel-mode--key ?d ?p 'fuel-apropos)
(fuel-mode--key ?d ?d 'fuel-help) (fuel-mode--key ?d ?d 'fuel-help)

View File

@ -20,23 +20,13 @@
;;; Extract word: ;;; Extract word:
(defun fuel-refactor-extract-word (begin end) (defun fuel-refactor--extract (begin end)
"Extracts current region as a separate word."
(interactive "r")
(let* ((word (read-string "New word name: ")) (let* ((word (read-string "New word name: "))
(begin (save-excursion
(goto-char begin)
(when (zerop (skip-syntax-backward "w"))
(skip-syntax-forward "-"))
(point)))
(end (save-excursion
(goto-char end)
(skip-syntax-forward "w")
(point)))
(code (buffer-substring begin end)) (code (buffer-substring begin end))
(code-str (fuel--region-to-string begin end)) (code-str (fuel--region-to-string begin end))
(stack-effect (or (fuel-stack--infer-effect code-str) (stack-effect (or (fuel-stack--infer-effect code-str)
(read-string "Stack effect: ")))) (read-string "Stack effect: "))))
(unless (< begin end) (error "No proper region to extract"))
(goto-char begin) (goto-char begin)
(delete-region begin end) (delete-region begin end)
(insert word) (insert word)
@ -52,6 +42,29 @@
(sit-for fuel-stack-highlight-period) (sit-for fuel-stack-highlight-period)
(delete-overlay fuel-stack--overlay)))) (delete-overlay fuel-stack--overlay))))
(defun fuel-refactor-extract-region (begin end)
"Extracts current region as a separate word."
(interactive "r")
(let ((begin (save-excursion
(goto-char begin)
(when (zerop (skip-syntax-backward "w"))
(skip-syntax-forward "-"))
(point)))
(end (save-excursion
(goto-char end)
(skip-syntax-forward "w")
(point))))
(fuel-refactor--extract begin end)))
(defun fuel-refactor-extract-sexp ()
"Extracts current innermost sexp (up to point) as a separate
word."
(interactive)
(fuel-refactor-extract-region (1+ (fuel-syntax--beginning-of-sexp-pos))
(if (looking-at-p ";") (point)
(fuel-syntax--end-of-symbol-pos))))
(provide 'fuel-refactor) (provide 'fuel-refactor)
;;; fuel-refactor.el ends here ;;; fuel-refactor.el ends here

View File

@ -312,6 +312,12 @@
(defsubst fuel-syntax--usings () (defsubst fuel-syntax--usings ()
(funcall fuel-syntax--usings-function)) (funcall fuel-syntax--usings-function))
(defun fuel-syntax--file-has-private ()
(save-excursion
(goto-char (point-min))
(and (re-search-forward "\\_<<PRIVATE\\_>" nil t)
(re-search-forward "\\_<PRIVATE>\\_>" nil t))))
(defun fuel-syntax--find-usings (&optional no-private) (defun fuel-syntax--find-usings (&optional no-private)
(save-excursion (save-excursion
(let ((usings)) (let ((usings))
@ -319,10 +325,7 @@
(while (re-search-backward fuel-syntax--using-lines-regex nil t) (while (re-search-backward fuel-syntax--using-lines-regex nil t)
(dolist (u (split-string (match-string-no-properties 1) nil t)) (dolist (u (split-string (match-string-no-properties 1) nil t))
(push u usings))) (push u usings)))
(goto-char (point-min)) (when (and (not no-private) (fuel-syntax--file-has-private))
(when (and (not no-private)
(re-search-forward "\\_<<PRIVATE\\_>" nil t)
(re-search-forward "\\_<PRIVATE>\\_>" nil t))
(goto-char (point-max)) (goto-char (point-max))
(push (concat (fuel-syntax--find-in) ".private") usings)) (push (concat (fuel-syntax--find-in) ".private") usings))
usings))) usings)))

View File

@ -13,6 +13,8 @@
;;; Code: ;;; Code:
(require 'fuel-edit)
(require 'fuel-completion)
(require 'fuel-help) (require 'fuel-help)
(require 'fuel-eval) (require 'fuel-eval)
(require 'fuel-syntax) (require 'fuel-syntax)
@ -82,7 +84,7 @@ cursor at the first ocurrence of the used word."
((= 1 count) (format "1 word %s %s:" cc word)) ((= 1 count) (format "1 word %s %s:" cc word))
(t (format "%s words %s %s:" count cc word)))) (t (format "%s words %s %s:" count cc word))))
(defun fuel-xref--insert-ref (ref) (defun fuel-xref--insert-ref (ref &optional no-vocab)
(when (and (stringp (first ref)) (when (and (stringp (first ref))
(stringp (third ref)) (stringp (third ref))
(numberp (fourth ref))) (numberp (fourth ref)))
@ -94,29 +96,28 @@ cursor at the first ocurrence of the used word."
(fourth ref)) (fourth ref))
'file (third ref) 'file (third ref)
'line (fourth ref)) 'line (fourth ref))
(when (stringp (second ref)) (when (and (not no-vocab) (stringp (second ref)))
(insert (format " (in %s)" (second ref)))) (insert (format " (in %s)" (second ref))))
(newline) (newline)
t)) t))
(defun fuel-xref--fill-buffer (word cc refs) (defun fuel-xref--fill-buffer (word cc refs &optional no-vocab app)
(let ((inhibit-read-only t) (let ((inhibit-read-only t)
(count 0)) (count 0))
(with-current-buffer (fuel-xref--buffer) (with-current-buffer (fuel-xref--buffer)
(erase-buffer) (let ((start (if app (goto-char (point-max))
(dolist (ref refs) (erase-buffer)
(when (fuel-xref--insert-ref ref) (setq count (1+ count)))) (point-min))))
(goto-char (point-min)) (dolist (ref refs)
(insert (fuel-xref--title word cc count) "\n\n") (when (fuel-xref--insert-ref ref no-vocab) (setq count (1+ count))))
(when (> count 0) (newline)
(setq fuel-xref--word (and cc word)) (goto-char start)
(goto-char (point-max)) (save-excursion
(insert "\n" fuel-xref--help-string "\n")) (insert (fuel-xref--title word cc count) "\n\n"))
(goto-char (point-min)) count))))
count)))
(defun fuel-xref--fill-and-display (word cc refs) (defun fuel-xref--fill-and-display (word cc refs &optional no-vocab)
(let ((count (fuel-xref--fill-buffer word cc refs))) (let ((count (fuel-xref--fill-buffer word cc refs no-vocab)))
(if (zerop count) (if (zerop count)
(error (fuel-xref--title word cc 0)) (error (fuel-xref--title word cc 0))
(message "") (message "")
@ -137,6 +138,65 @@ cursor at the first ocurrence of the used word."
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd)))) (res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
(fuel-xref--fill-and-display str "containing" res))) (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))))
(fuel-xref--fill-buffer vocab "in vocabulary" res t app)))
(defun fuel-xref--show-vocab-words (vocab &optional private)
(fuel-xref--show-vocab vocab)
(when private
(fuel-xref--show-vocab (format "%s.private" (substring-no-properties vocab))
t))
(fuel-popup--display (fuel-xref--buffer))
(goto-char (point-min)))
;;; User commands:
(defvar fuel-xref--word-history nil)
(defun fuel-show-callers (&optional arg)
"Show a list of callers of word at point.
With prefix argument, ask for word."
(interactive "P")
(let ((word (if arg (fuel-completion--read-word "Find callers for: "
(fuel-syntax-symbol-at-point)
fuel-xref--word-history)
(fuel-syntax-symbol-at-point))))
(when word
(message "Looking up %s's callers ..." word)
(fuel-xref--show-callers word))))
(defun fuel-show-callees (&optional arg)
"Show a list of callers of word at point.
With prefix argument, ask for word."
(interactive "P")
(let ((word (if arg (fuel-completion--read-word "Find callees for: "
(fuel-syntax-symbol-at-point)
fuel-xref--word-history)
(fuel-syntax-symbol-at-point))))
(when word
(message "Looking up %s's callees ..." word)
(fuel-xref--show-callees word))))
(defun fuel-apropos (str)
"Show a list of words containing the given substring."
(interactive "MFind words containing: ")
(message "Looking up %s's references ..." str)
(fuel-xref--apropos str))
(defun fuel-show-file-words (&optional arg)
"Show a list of words in current file.
With prefix argument, ask for the vocab."
(interactive "P")
(let ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
(fuel-edit--read-vocabulary-name))))
(when vocab
(fuel-xref--show-vocab-words vocab
(fuel-syntax--file-has-private)))))
;;; Xref mode: ;;; Xref mode:
@ -159,6 +219,7 @@ cursor at the first ocurrence of the used word."
(kill-all-local-variables) (kill-all-local-variables)
(buffer-disable-undo) (buffer-disable-undo)
(use-local-map fuel-xref-mode-map) (use-local-map fuel-xref-mode-map)
(set-syntax-table fuel-syntax--syntax-table)
(setq mode-name "FUEL Xref") (setq mode-name "FUEL Xref")
(setq major-mode 'fuel-xref-mode) (setq major-mode 'fuel-xref-mode)
(font-lock-add-keywords nil '(("(in \\(.+\\))" 1 'fuel-font-lock-xref-vocab))) (font-lock-add-keywords nil '(("(in \\(.+\\))" 1 'fuel-font-lock-xref-vocab)))