Merge branch 'master' of git://factorcode.org/git/factor
Aaron Schaefer
commit
503e0a4e5f
|
|
@ -0,0 +1,448 @@
|
|||
|
||||
USING: accessors arrays assocs colors combinators.short-circuit
|
||||
kernel locals math math.functions math.matrices math.order
|
||||
math.parser math.trig math.vectors opengl opengl.demo-support
|
||||
opengl.gl sbufs sequences strings ui.gadgets ui.gadgets.worlds
|
||||
ui.gestures ui.render ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
IN: L-system
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <turtle> pos ori angle length thickness color vertices saved ;
|
||||
|
||||
DEFER: default-L-parser-values
|
||||
|
||||
: reset-turtle ( turtle -- turtle )
|
||||
{ 0 0 0 } clone >>pos
|
||||
3 identity-matrix >>ori
|
||||
V{ } clone >>vertices
|
||||
V{ } clone >>saved
|
||||
|
||||
default-L-parser-values ;
|
||||
|
||||
: turtle ( -- turtle ) <turtle> new reset-turtle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: step-turtle ( TURTLE LENGTH -- turtle )
|
||||
|
||||
TURTLE
|
||||
TURTLE pos>> TURTLE ori>> { 0 0 LENGTH } m.v v+
|
||||
>>pos ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: Rx ( ANGLE -- Rx )
|
||||
|
||||
[let | ANGLE [ ANGLE deg>rad ] |
|
||||
|
||||
[let | A [ ANGLE cos ]
|
||||
B [ ANGLE sin neg ]
|
||||
C [ ANGLE sin ]
|
||||
D [ ANGLE cos ] |
|
||||
|
||||
{ { 1 0 0 }
|
||||
{ 0 A B }
|
||||
{ 0 C D } }
|
||||
|
||||
] ] ;
|
||||
|
||||
:: Ry ( ANGLE -- Ry )
|
||||
|
||||
[let | ANGLE [ ANGLE deg>rad ] |
|
||||
|
||||
[let | A [ ANGLE cos ]
|
||||
B [ ANGLE sin ]
|
||||
C [ ANGLE sin neg ]
|
||||
D [ ANGLE cos ] |
|
||||
|
||||
{ { A 0 B }
|
||||
{ 0 1 0 }
|
||||
{ C 0 D } }
|
||||
|
||||
] ] ;
|
||||
|
||||
:: Rz ( ANGLE -- Rz )
|
||||
|
||||
[let | ANGLE [ ANGLE deg>rad ] |
|
||||
|
||||
[let | A [ ANGLE cos ]
|
||||
B [ ANGLE sin neg ]
|
||||
C [ ANGLE sin ]
|
||||
D [ ANGLE cos ] |
|
||||
|
||||
{ { A B 0 }
|
||||
{ C D 0 }
|
||||
{ 0 0 1 } }
|
||||
|
||||
] ] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: apply-rotation ( TURTLE ROTATION -- turtle )
|
||||
|
||||
TURTLE TURTLE ori>> ROTATION m. >>ori ;
|
||||
|
||||
: rotate-x ( turtle angle -- turtle ) Rx apply-rotation ;
|
||||
: rotate-y ( turtle angle -- turtle ) Ry apply-rotation ;
|
||||
: rotate-z ( turtle angle -- turtle ) Rz apply-rotation ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: pitch-up ( turtle angle -- turtle ) neg rotate-x ;
|
||||
: pitch-down ( turtle angle -- turtle ) rotate-x ;
|
||||
|
||||
: turn-left ( turtle angle -- turtle ) rotate-y ;
|
||||
: turn-right ( turtle angle -- turtle ) neg rotate-y ;
|
||||
|
||||
: roll-left ( turtle angle -- turtle ) neg rotate-z ;
|
||||
: roll-right ( turtle angle -- turtle ) rotate-z ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: V ( -- V ) { 0 1 0 } ;
|
||||
|
||||
: X ( turtle -- 3array ) ori>> [ first ] map ;
|
||||
: Y ( turtle -- 3array ) ori>> [ second ] map ;
|
||||
: Z ( turtle -- 3array ) ori>> [ third ] map ;
|
||||
|
||||
: set-X ( turtle seq -- turtle ) over ori>> [ set-first ] 2each ;
|
||||
: set-Y ( turtle seq -- turtle ) over ori>> [ set-second ] 2each ;
|
||||
: set-Z ( turtle seq -- turtle ) over ori>> [ set-third ] 2each ;
|
||||
|
||||
:: roll-until-horizontal ( TURTLE -- turtle )
|
||||
|
||||
TURTLE
|
||||
|
||||
V TURTLE Z cross normalize set-X
|
||||
|
||||
TURTLE Z TURTLE X cross normalize set-Y ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: strafe-up ( TURTLE LENGTH -- turtle )
|
||||
TURTLE 90 pitch-up LENGTH step-turtle 90 pitch-down ;
|
||||
|
||||
:: strafe-down ( TURTLE LENGTH -- turtle )
|
||||
TURTLE 90 pitch-down LENGTH step-turtle 90 pitch-up ;
|
||||
|
||||
:: strafe-left ( TURTLE LENGTH -- turtle )
|
||||
TURTLE 90 turn-left LENGTH step-turtle 90 turn-right ;
|
||||
|
||||
:: strafe-right ( TURTLE LENGTH -- turtle )
|
||||
TURTLE 90 turn-right LENGTH step-turtle 90 turn-left ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: polygon ( vertices -- ) GL_POLYGON glBegin [ first3 glVertex3d ] each glEnd ;
|
||||
|
||||
: start-polygon ( turtle -- turtle ) dup vertices>> delete-all ;
|
||||
|
||||
: finish-polygon ( turtle -- turtle ) dup vertices>> polygon ;
|
||||
|
||||
: polygon-vertex ( turtle -- turtle ) dup [ pos>> ] [ vertices>> ] bi push ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: record-vertex ( turtle -- turtle ) dup pos>> first3 glVertex3d ;
|
||||
|
||||
: draw-forward ( turtle length -- turtle )
|
||||
GL_LINES glBegin [ record-vertex ] dip step-turtle record-vertex glEnd ;
|
||||
|
||||
: move-forward ( turtle length -- turtle ) step-turtle polygon-vertex ;
|
||||
|
||||
: sneak-forward ( turtle length -- turtle ) step-turtle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: scale-length ( turtle m -- turtle ) over length>> * >>length ;
|
||||
: scale-angle ( turtle m -- turtle ) over angle>> * >>angle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: set-thickness ( turtle i -- turtle ) dup glLineWidth >>thickness ;
|
||||
|
||||
: scale-thickness ( turtle m -- turtle )
|
||||
over thickness>> * 0.5 max set-thickness ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: color-table ( -- colors )
|
||||
{
|
||||
T{ rgba f 0 0 0 1 } ! black
|
||||
T{ rgba f 0.5 0.5 0.5 1 } ! grey
|
||||
T{ rgba f 1 0 0 1 } ! red
|
||||
T{ rgba f 1 1 0 1 } ! yellow
|
||||
T{ rgba f 0 1 0 1 } ! green
|
||||
T{ rgba f 0.25 0.88 0.82 1 } ! turquoise
|
||||
T{ rgba f 0 0 1 1 } ! blue
|
||||
T{ rgba f 0.63 0.13 0.94 1 } ! purple
|
||||
T{ rgba f 0.00 0.50 0.00 1 } ! dark green
|
||||
T{ rgba f 0.00 0.82 0.82 1 } ! dark turquoise
|
||||
T{ rgba f 0.00 0.00 0.50 1 } ! dark blue
|
||||
T{ rgba f 0.58 0.00 0.82 1 } ! dark purple
|
||||
T{ rgba f 0.50 0.00 0.00 1 } ! dark red
|
||||
T{ rgba f 0.25 0.25 0.25 1 } ! dark grey
|
||||
T{ rgba f 0.75 0.75 0.75 1 } ! medium grey
|
||||
T{ rgba f 1 1 1 1 } ! white
|
||||
} ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! : material-color ( color -- )
|
||||
! GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
|
||||
|
||||
: material-color ( color -- )
|
||||
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot color>raw 4array gl-material ;
|
||||
|
||||
: set-color ( turtle i -- turtle )
|
||||
dup color-table nth dup gl-color material-color >>color ;
|
||||
|
||||
: inc-color ( turtle -- turtle ) dup color>> 1 + set-color ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: save-turtle ( turtle -- turtle ) dup clone over saved>> push ;
|
||||
: restore-turtle ( turtle -- turtle ) saved>> pop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: default-L-parser-values ( turtle -- turtle )
|
||||
1 >>length 45 >>angle 1 >>thickness 2 >>color ;
|
||||
|
||||
: L-parser-dialect ( -- commands )
|
||||
|
||||
{
|
||||
{ "+" [ dup angle>> turn-left ] }
|
||||
{ "-" [ dup angle>> turn-right ] }
|
||||
{ "&" [ dup angle>> pitch-down ] }
|
||||
{ "^" [ dup angle>> pitch-up ] }
|
||||
{ "<" [ dup angle>> roll-left ] }
|
||||
{ ">" [ dup angle>> roll-right ] }
|
||||
|
||||
{ "|" [ 180.0 rotate-y ] }
|
||||
{ "%" [ 180.0 rotate-z ] }
|
||||
{ "$" [ roll-until-horizontal ] }
|
||||
|
||||
{ "F" [ dup length>> draw-forward ] }
|
||||
{ "Z" [ dup length>> 2 / draw-forward ] }
|
||||
{ "f" [ dup length>> move-forward ] }
|
||||
{ "z" [ dup length>> 2 / move-forward ] }
|
||||
{ "g" [ dup length>> sneak-forward ] }
|
||||
{ "." [ polygon-vertex ] }
|
||||
|
||||
{ "[" [ save-turtle ] }
|
||||
{ "]" [ restore-turtle ] }
|
||||
|
||||
{ "{" [ start-polygon ] }
|
||||
{ "}" [ finish-polygon ] }
|
||||
|
||||
{ "/" [ 1.1 scale-length ] } ! double quote command in lparser
|
||||
{ "'" [ 0.9 scale-length ] }
|
||||
{ ";" [ 1.1 scale-angle ] }
|
||||
{ ":" [ 0.9 scale-angle ] }
|
||||
{ "?" [ 1.4 scale-thickness ] }
|
||||
{ "!" [ 0.7 scale-thickness ] }
|
||||
|
||||
{ "c" [ dup color>> 1 + color-table length mod set-color ] }
|
||||
|
||||
}
|
||||
;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <L-system> < gadget
|
||||
camera display-list
|
||||
commands axiom rules string ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: open-paren ( -- ch ) CHAR: ( ;
|
||||
: close-paren ( -- ch ) CHAR: ) ;
|
||||
|
||||
: open-paren? ( obj -- ? ) open-paren = ;
|
||||
: close-paren? ( obj -- ? ) close-paren = ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: read-instruction ( STRING -- next rest )
|
||||
|
||||
{ [ STRING length 1 > ] [ STRING second open-paren? ] } 0&&
|
||||
[ STRING close-paren STRING index 1 + cut ]
|
||||
[ STRING 1 cut ]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-string-loop ( STRING RULES ACCUM -- )
|
||||
STRING empty? not
|
||||
[
|
||||
STRING read-instruction
|
||||
|
||||
[let | REST [ ] NEXT [ ] |
|
||||
|
||||
NEXT 1 head RULES at NEXT or ACCUM push-all
|
||||
|
||||
REST RULES ACCUM iterate-string-loop ]
|
||||
]
|
||||
when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-string ( STRING RULES -- string )
|
||||
|
||||
[let | ACCUM [ STRING length 10 * <sbuf> ] |
|
||||
|
||||
STRING RULES ACCUM iterate-string-loop
|
||||
|
||||
ACCUM >string ] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: interpret-string ( STRING COMMANDS -- )
|
||||
|
||||
STRING empty? not
|
||||
[
|
||||
STRING read-instruction
|
||||
|
||||
[let | REST [ ] NEXT [ ] |
|
||||
|
||||
[let | COMMAND [ NEXT 1 head COMMANDS at ] |
|
||||
|
||||
COMMAND
|
||||
[
|
||||
NEXT length 1 =
|
||||
[ COMMAND call ]
|
||||
[
|
||||
NEXT 2 tail 1 head* string>number
|
||||
COMMAND 1 tail*
|
||||
call
|
||||
]
|
||||
if
|
||||
]
|
||||
when ]
|
||||
|
||||
REST COMMANDS interpret-string ]
|
||||
]
|
||||
when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-L-system-string ( L-SYSTEM -- )
|
||||
L-SYSTEM string>>
|
||||
L-SYSTEM rules>>
|
||||
iterate-string
|
||||
L-SYSTEM (>>string) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: do-camera-look-at ( CAMERA -- )
|
||||
|
||||
[let | EYE [ CAMERA pos>> ]
|
||||
FOCUS [ CAMERA clone 1 step-turtle pos>> ]
|
||||
UP [ CAMERA clone 90 pitch-up 1 step-turtle pos>> CAMERA pos>> v- ]
|
||||
|
|
||||
|
||||
EYE FOCUS UP gl-look-at ] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: generate-display-list ( L-SYSTEM -- )
|
||||
|
||||
L-SYSTEM find-gl-context
|
||||
|
||||
L-SYSTEM display-list>> GL_COMPILE glNewList
|
||||
|
||||
turtle
|
||||
L-SYSTEM string>>
|
||||
L-SYSTEM commands>>
|
||||
interpret-string
|
||||
drop
|
||||
|
||||
glEndList ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M:: <L-system> draw-gadget* ( L-SYSTEM -- )
|
||||
|
||||
black gl-clear
|
||||
|
||||
GL_FLAT glShadeModel
|
||||
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
-1 1 -1 1 1.5 200 glFrustum
|
||||
|
||||
GL_MODELVIEW glMatrixMode
|
||||
|
||||
glLoadIdentity
|
||||
|
||||
L-SYSTEM camera>> do-camera-look-at
|
||||
|
||||
GL_FRONT_AND_BACK GL_LINE glPolygonMode
|
||||
|
||||
! draw axis
|
||||
white gl-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
|
||||
|
||||
L-SYSTEM display-list>> glCallList ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M:: <L-system> graft* ( L-SYSTEM -- )
|
||||
|
||||
L-SYSTEM find-gl-context
|
||||
|
||||
1 glGenLists L-SYSTEM (>>display-list) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M:: <L-system> pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: camera-left ( L-SYSTEM -- )
|
||||
L-SYSTEM camera>> 5 turn-left drop
|
||||
L-SYSTEM relayout-1 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: with-camera ( L-SYSTEM QUOT -- )
|
||||
L-SYSTEM camera>> QUOT call drop
|
||||
L-SYSTEM relayout-1 ;
|
||||
|
||||
<L-system>
|
||||
H{
|
||||
{ T{ key-down f f "LEFT" } [ [ 5 turn-left ] with-camera ] }
|
||||
{ T{ key-down f f "RIGHT" } [ [ 5 turn-right ] with-camera ] }
|
||||
{ T{ key-down f f "UP" } [ [ 5 pitch-down ] with-camera ] }
|
||||
{ T{ key-down f f "DOWN" } [ [ 5 pitch-up ] with-camera ] }
|
||||
|
||||
{ T{ key-down f f "a" } [ [ 1 step-turtle ] with-camera ] }
|
||||
{ T{ key-down f f "z" } [ [ -1 step-turtle ] with-camera ] }
|
||||
|
||||
{
|
||||
T{ key-down f f "x" }
|
||||
[
|
||||
dup iterate-L-system-string
|
||||
dup generate-display-list
|
||||
dup relayout-1
|
||||
drop
|
||||
]
|
||||
}
|
||||
|
||||
}
|
||||
set-gestures
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: L-system ( -- L-system )
|
||||
|
||||
<L-system> new-gadget
|
||||
|
||||
turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
|
||||
USING: accessors kernel ui L-system ;
|
||||
|
||||
IN: L-system.models.abop-1
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-1 ( <L-system> -- <L-system> )
|
||||
|
||||
L-parser-dialect >>commands
|
||||
|
||||
"c(12)FFAL" >>axiom
|
||||
|
||||
{
|
||||
{ "A" "F[&'(.8)!BL]>(137)'!(.9)A" }
|
||||
{ "B" "F[-'(.8)!(.9)$CL]'!(.9)C" }
|
||||
{ "C" "F[+'(.8)!(.9)$BL]'!(.9)B" }
|
||||
|
||||
{ "L" "~c(8){+(30)f-(120)f-(120)f}" }
|
||||
}
|
||||
>>rules
|
||||
|
||||
dup axiom>> >>string ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: main ( -- ) [ L-system abop-1 "L-system" open-window ] with-ui ;
|
||||
|
||||
MAIN: main
|
||||
|
|
@ -1,11 +1,12 @@
|
|||
! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
|
||||
! Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors arrays assocs classes.tuple combinators
|
||||
compiler.units continuations debugger definitions io io.pathnames
|
||||
io.streams.string kernel lexer math math.order memoize namespaces
|
||||
parser prettyprint sequences sets sorting source-files strings summary
|
||||
tools.vocabs vectors vocabs vocabs.parser words ;
|
||||
compiler.units continuations debugger definitions help help.crossref
|
||||
help.markup help.topics io io.pathnames io.streams.string kernel lexer
|
||||
make math math.order memoize namespaces parser prettyprint sequences
|
||||
sets sorting source-files strings summary tools.crossref tools.vocabs
|
||||
vectors vocabs vocabs.parser words ;
|
||||
|
||||
IN: fuel
|
||||
|
||||
|
|
@ -17,13 +18,13 @@ SYMBOL: fuel-status-stack
|
|||
V{ } clone fuel-status-stack set-global
|
||||
|
||||
SYMBOL: fuel-eval-result
|
||||
f clone fuel-eval-result set-global
|
||||
f fuel-eval-result set-global
|
||||
|
||||
SYMBOL: fuel-eval-output
|
||||
f clone fuel-eval-result set-global
|
||||
f fuel-eval-result set-global
|
||||
|
||||
SYMBOL: fuel-eval-res-flag
|
||||
t clone fuel-eval-res-flag set-global
|
||||
t fuel-eval-res-flag set-global
|
||||
|
||||
: fuel-eval-restartable? ( -- ? )
|
||||
fuel-eval-res-flag get-global ; inline
|
||||
|
|
@ -56,6 +57,12 @@ GENERIC: fuel-pprint ( obj -- )
|
|||
|
||||
M: object fuel-pprint pprint ; inline
|
||||
|
||||
: fuel-maybe-scape ( ch -- seq )
|
||||
dup "\\\"?#()[]'`" member? [ CHAR: \ swap 2array ] [ 1array ] if ;
|
||||
|
||||
M: word fuel-pprint
|
||||
name>> V{ } clone [ fuel-maybe-scape append ] reduce >string write ;
|
||||
|
||||
M: f fuel-pprint drop "nil" write ; inline
|
||||
|
||||
M: integer fuel-pprint pprint ; inline
|
||||
|
|
@ -105,12 +112,11 @@ M: source-file fuel-pprint path>> fuel-pprint ;
|
|||
: 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-forget-status ( -- )
|
||||
fuel-forget-error fuel-forget-result fuel-forget-output ; inline
|
||||
|
||||
: (fuel-begin-eval) ( -- )
|
||||
fuel-push-status
|
||||
fuel-forget-error
|
||||
fuel-forget-result
|
||||
fuel-forget-output ;
|
||||
fuel-push-status fuel-forget-status ; inline
|
||||
|
||||
: (fuel-end-eval) ( output -- )
|
||||
fuel-eval-output set-global fuel-retort fuel-pop-status ; inline
|
||||
|
|
@ -136,14 +142,17 @@ M: source-file fuel-pprint path>> fuel-pprint ;
|
|||
|
||||
! Loading files
|
||||
|
||||
: fuel-run-file ( path -- ) run-file ; inline
|
||||
SYMBOL: :uses
|
||||
|
||||
: fuel-with-autouse ( quot -- )
|
||||
[
|
||||
auto-use? on
|
||||
[ amended-use get clone fuel-eval-set-result ] print-use-hook set
|
||||
call
|
||||
] curry with-scope ;
|
||||
: fuel-set-use-hook ( -- )
|
||||
[ amended-use get clone :uses prefix fuel-eval-set-result ]
|
||||
print-use-hook set ;
|
||||
|
||||
: fuel-run-file ( path -- )
|
||||
[ fuel-set-use-hook run-file ] curry with-scope ; inline
|
||||
|
||||
: fuel-with-autouse ( ... quot: ( ... -- ... ) -- ... )
|
||||
[ auto-use? on fuel-set-use-hook call ] curry with-scope ; inline
|
||||
|
||||
: (fuel-get-uses) ( lines -- )
|
||||
[ parse-fresh drop ] curry with-compilation-unit ; inline
|
||||
|
|
@ -175,13 +184,16 @@ M: source-file fuel-pprint path>> fuel-pprint ;
|
|||
[ [ first ] dip first <=> ] sort ; inline
|
||||
|
||||
: fuel-format-xrefs ( seq -- seq' )
|
||||
[ word? ] filter [ fuel-word>xref ] map fuel-sort-xrefs ;
|
||||
[ word? ] filter [ fuel-word>xref ] map ; inline
|
||||
|
||||
: fuel-callers-xref ( word -- )
|
||||
usage fuel-format-xrefs fuel-eval-set-result ; inline
|
||||
usage fuel-format-xrefs fuel-sort-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
: fuel-callees-xref ( word -- )
|
||||
uses fuel-format-xrefs fuel-eval-set-result ; inline
|
||||
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
|
||||
|
||||
! Completion support
|
||||
|
||||
|
|
@ -216,6 +228,86 @@ MEMO: (fuel-vocab-words) ( name -- seq )
|
|||
: fuel-get-words ( prefix names -- )
|
||||
(fuel-get-words) fuel-eval-set-result ; inline
|
||||
|
||||
! Help support
|
||||
|
||||
MEMO: fuel-articles-seq ( -- seq )
|
||||
articles get values ;
|
||||
|
||||
: fuel-find-articles ( title -- seq )
|
||||
[ [ article-title ] dip = ] curry fuel-articles-seq swap filter ;
|
||||
|
||||
MEMO: fuel-find-article ( title -- article/f )
|
||||
fuel-find-articles dup empty? [ drop f ] [ first ] if ;
|
||||
|
||||
MEMO: fuel-article-title ( name -- title/f )
|
||||
articles get at [ article-title ] [ f ] if* ;
|
||||
|
||||
: fuel-get-article ( name -- )
|
||||
article fuel-eval-set-result ;
|
||||
|
||||
: fuel-value-str ( word -- str )
|
||||
[ pprint-short ] with-string-writer ; inline
|
||||
|
||||
: fuel-definition-str ( word -- str )
|
||||
[ see ] with-string-writer ; inline
|
||||
|
||||
: fuel-methods-str ( word -- str )
|
||||
methods dup empty? not [
|
||||
[ [ see nl ] each ] with-string-writer
|
||||
] [ drop f ] if ; inline
|
||||
|
||||
: fuel-related-words ( word -- seq )
|
||||
dup "related" word-prop remove ; inline
|
||||
|
||||
: fuel-parent-topics ( word -- seq )
|
||||
help-path [ dup article-title swap 2array ] map ; inline
|
||||
|
||||
: (fuel-word-help) ( word -- element )
|
||||
dup \ article swap article-title rot
|
||||
[
|
||||
{
|
||||
[ fuel-parent-topics [ \ $doc-path prefix , ] unless-empty ]
|
||||
[ \ $vocabulary swap vocabulary>> 2array , ]
|
||||
[ word-help % ]
|
||||
[ fuel-related-words [ \ $related swap 2array , ] unless-empty ]
|
||||
[ get-global [ \ $value swap fuel-value-str 2array , ] when* ]
|
||||
[ \ $definition swap fuel-definition-str 2array , ]
|
||||
[ fuel-methods-str [ \ $methods swap 2array , ] when* ]
|
||||
} cleave
|
||||
] { } make 3array ;
|
||||
|
||||
MEMO: fuel-find-word ( name -- word/f )
|
||||
[ [ name>> ] dip = ] curry all-words swap filter
|
||||
dup empty? not [ first ] [ drop f ] if ;
|
||||
|
||||
: fuel-word-help ( name -- )
|
||||
fuel-find-word [ [ auto-use? on (fuel-word-help) ] with-scope ] [ f ] if*
|
||||
fuel-eval-set-result ; inline
|
||||
|
||||
: (fuel-word-see) ( word -- elem )
|
||||
[ name>> \ article swap ]
|
||||
[ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline
|
||||
|
||||
: fuel-word-see ( name -- )
|
||||
fuel-find-word [ [ auto-use? on (fuel-word-see) ] with-scope ] [ f ] if*
|
||||
fuel-eval-set-result ; inline
|
||||
|
||||
: (fuel-vocab-help) ( name -- element )
|
||||
\ article swap dup >vocab-link
|
||||
[
|
||||
[ summary [ , ] [ "No summary available" , ] if* ]
|
||||
[ drop \ $nl , ]
|
||||
[ vocab-help article [ content>> % ] when* ] tri
|
||||
] { } make 3array ;
|
||||
|
||||
: fuel-vocab-help ( name -- )
|
||||
(fuel-vocab-help) fuel-eval-set-result ; inline
|
||||
|
||||
: (fuel-index) ( seq -- seq )
|
||||
[ [ >link name>> ] [ article-title ] bi 2array \ $subsection prefix ] map ;
|
||||
|
||||
: fuel-index ( quot: ( -- seq ) -- )
|
||||
call (fuel-index) fuel-eval-set-result ; inline
|
||||
|
||||
! -run=fuel support
|
||||
|
||||
|
|
|
|||
|
|
@ -1,56 +1,54 @@
|
|||
FUEL, Factor's Ultimate Emacs Library
|
||||
FUEL, Factor's Ultimate Emacs Library -*- org -*-
|
||||
-------------------------------------
|
||||
|
||||
FUEL provides a complete environment for your Factor coding pleasure
|
||||
inside Emacs, including source code edition and interaction with a
|
||||
Factor listener instance running within Emacs.
|
||||
|
||||
FUEL was started by Jose A Ortega as an extension to Ed Cavazos'
|
||||
original factor.el code.
|
||||
FUEL was started by Jose A Ortega as an extension to Eduardo Cavazos'
|
||||
original factor.el code. Eduardo is also responsible of naming the
|
||||
beast.
|
||||
|
||||
Installation
|
||||
------------
|
||||
* Installation
|
||||
|
||||
FUEL comes bundled with Factor's distribution. The folder misc/fuel
|
||||
contains Elisp code, and there's a fuel vocabulary in extras/fuel.
|
||||
FUEL comes bundled with Factor's distribution. The folder misc/fuel
|
||||
contains Elisp code, and there's a fuel vocabulary in extras/fuel.
|
||||
|
||||
To install FUEL, either add this line to your Emacs initialisation:
|
||||
To install FUEL, either add this line to your Emacs initialisation:
|
||||
|
||||
(load-file "<path/to/factor/installation>/misc/fuel/fu.el")
|
||||
|
||||
or
|
||||
or
|
||||
|
||||
(add-to-list load-path "<path/to/factor/installation>/fuel")
|
||||
(require 'fuel)
|
||||
|
||||
If all you want is a major mode for editing Factor code with pretty
|
||||
font colors and indentation, without running the factor listener
|
||||
inside Emacs, you can use instead:
|
||||
If all you want is a major mode for editing Factor code with pretty
|
||||
font colors and indentation, without running the factor listener
|
||||
inside Emacs, you can use instead:
|
||||
|
||||
(add-to-list load-path "<path/to/factor/installation>/fuel")
|
||||
(setq factor-mode-use-fuel nil)
|
||||
(require 'factor-mode)
|
||||
|
||||
Basic usage
|
||||
-----------
|
||||
* Basic usage
|
||||
|
||||
If you're using the default factor binary and images locations inside
|
||||
the Factor's source tree, that should be enough to start using FUEL.
|
||||
Editing any file with the extension .factor will put you in
|
||||
factor-mode; try C-hm for a summary of available commands.
|
||||
If you're using the default factor binary and images locations inside
|
||||
the Factor's source tree, that should be enough to start using FUEL.
|
||||
Editing any file with the extension .factor will put you in
|
||||
factor-mode; try C-hm for a summary of available commands.
|
||||
|
||||
To start the listener, try M-x run-factor.
|
||||
To start the listener, try M-x run-factor.
|
||||
|
||||
Many aspects of the environment can be customized:
|
||||
M-x customize-group fuel will show you how many.
|
||||
Many aspects of the environment can be customized:
|
||||
M-x customize-group fuel will show you how many.
|
||||
|
||||
Quick key reference
|
||||
-------------------
|
||||
* Quick key reference
|
||||
|
||||
(Triple chords ending in a single letter <x> accept also C-<x> (e.g.
|
||||
C-cC-eC-r is the same as C-cC-er)).
|
||||
(Triple chords ending in a single letter <x> accept also C-<x> (e.g.
|
||||
C-cC-eC-r is the same as C-cC-er)).
|
||||
|
||||
* In factor source files:
|
||||
*** In factor source files:
|
||||
|
||||
- C-cz : switch to listener
|
||||
- C-co : cycle between code, tests and docs factor files
|
||||
|
|
@ -71,37 +69,46 @@ C-cC-eC-r is the same as C-cC-er)).
|
|||
- C-cC-dd : help for 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-dp : find words containing given substring (M-x fuel-apropos)
|
||||
|
||||
- C-cM-<, C-cC-d< : show callers of word at point
|
||||
- C-cM->, C-cC-d> : show callees of word at point
|
||||
|
||||
* In the listener:
|
||||
*** In the listener:
|
||||
|
||||
- TAB : complete word at point
|
||||
- M-. : edit word at point in Emacs
|
||||
- C-ca : toggle autodoc mode
|
||||
- C-cp : find words containing given substring (M-x fuel-apropos)
|
||||
- C-cs : toggle stack mode
|
||||
- C-cv : edit vocabulary
|
||||
- C-ch : help for word at point
|
||||
- C-ck : run file
|
||||
|
||||
* In the debugger (it pops up upon eval/compilation errors):
|
||||
*** In the debugger (it pops up upon eval/compilation errors):
|
||||
|
||||
- g : go to error
|
||||
- <digit> : invoke nth restart
|
||||
- w/e/l : invoke :warnings, :errors, :linkage
|
||||
- q : bury buffer
|
||||
|
||||
* In the Help browser:
|
||||
*** In the help browser:
|
||||
|
||||
- RET : help for word at point
|
||||
- f/b : next/previous page
|
||||
- h : help for word at point
|
||||
- a : find words containing given substring (M-x fuel-apropos)
|
||||
- ba : bookmark current page
|
||||
- bb : display bookmarks
|
||||
- bd : delete bookmark at point
|
||||
- n/p : next/previous page
|
||||
- SPC/S-SPC : scroll up/down
|
||||
- TAB/S-TAB : next/previous headline
|
||||
- TAB/S-TAB : next/previous link
|
||||
- r : refresh page
|
||||
- c : clean browsing history
|
||||
- M-. : edit word at point in Emacs
|
||||
- C-cz : switch to listener
|
||||
- q : bury buffer
|
||||
|
||||
* In crossref buffers
|
||||
*** In crossref buffers
|
||||
|
||||
- TAB/BACKTAB : navigate links
|
||||
- RET/mouse click : follow link
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; fuel-autodoc.el -- doc snippets in the echo area
|
||||
|
||||
;; 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>
|
||||
|
|
@ -31,22 +31,11 @@
|
|||
:group 'fuel-autodoc
|
||||
:type 'boolean)
|
||||
|
||||
|
||||
|
||||
;;; Autodoc mode:
|
||||
;;; Eldoc function:
|
||||
|
||||
(defvar fuel-autodoc--font-lock-buffer
|
||||
(let ((buffer (get-buffer-create " *fuel help minibuffer messages*")))
|
||||
(set-buffer buffer)
|
||||
(set-syntax-table fuel-syntax--syntax-table)
|
||||
(fuel-font-lock--font-lock-setup)
|
||||
buffer))
|
||||
|
||||
(defun fuel-autodoc--font-lock-str (str)
|
||||
(set-buffer fuel-autodoc--font-lock-buffer)
|
||||
(erase-buffer)
|
||||
(insert str)
|
||||
(let ((font-lock-verbose nil)) (font-lock-fontify-buffer))
|
||||
(buffer-string))
|
||||
(defvar fuel-autodoc--timeout 200)
|
||||
|
||||
(defun fuel-autodoc--word-synopsis (&optional word)
|
||||
(let ((word (or word (fuel-syntax-symbol-at-point)))
|
||||
|
|
@ -55,11 +44,11 @@
|
|||
(let* ((cmd (if (fuel-syntax--in-using)
|
||||
`(:fuel* (,word fuel-vocab-summary) :in t)
|
||||
`(:fuel* (((:quote ,word) synopsis :get)) :in)))
|
||||
(ret (fuel-eval--send/wait cmd 20))
|
||||
(ret (fuel-eval--send/wait cmd fuel-autodoc--timeout))
|
||||
(res (fuel-eval--retort-result ret)))
|
||||
(when (and ret (not (fuel-eval--retort-error ret)) (stringp res))
|
||||
(if fuel-autodoc-minibuffer-font-lock
|
||||
(fuel-autodoc--font-lock-str res)
|
||||
(fuel-font-lock--factor-str res)
|
||||
res))))))
|
||||
|
||||
(make-variable-buffer-local
|
||||
|
|
@ -70,6 +59,9 @@
|
|||
(funcall fuel-autodoc--fallback-function))
|
||||
(fuel-autodoc--word-synopsis)))
|
||||
|
||||
|
||||
;;; Autodoc mode:
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-autodoc-mode-string " A"
|
||||
"Modeline indicator for fuel-autodoc-mode"))
|
||||
|
|
|
|||
|
|
@ -23,12 +23,6 @@
|
|||
|
||||
;;; Customization:
|
||||
|
||||
(fuel-font-lock--defface fuel-font-lock-debug-missing-vocab
|
||||
'font-lock-warning-face fuel-debug "missing vocabulary names")
|
||||
|
||||
(fuel-font-lock--defface fuel-font-lock-debug-unneeded-vocab
|
||||
'font-lock-warning-face fuel-debug "unneeded vocabulary names")
|
||||
|
||||
(fuel-font-lock--defface fuel-font-lock-debug-uses-header
|
||||
'bold fuel-debug "headers in Uses buffers")
|
||||
|
||||
|
|
@ -53,26 +47,6 @@
|
|||
(forward-line))
|
||||
(reverse lines))))))
|
||||
|
||||
(defun fuel-debug--highlight-names (names ref face)
|
||||
(dolist (n names)
|
||||
(when (not (member n ref))
|
||||
(put-text-property 0 (length n) 'font-lock-face face n))))
|
||||
|
||||
(defun fuel-debug--uses-new-uses (file uses)
|
||||
(pop-to-buffer (find-file-noselect file))
|
||||
(goto-char (point-min))
|
||||
(if (re-search-forward "^USING: " nil t)
|
||||
(let ((begin (point))
|
||||
(end (or (and (re-search-forward "\\_<;\\_>") (point)) (point))))
|
||||
(kill-region begin end))
|
||||
(re-search-forward "^IN: " nil t)
|
||||
(beginning-of-line)
|
||||
(open-line 2)
|
||||
(insert "USING: "))
|
||||
(let ((start (point)))
|
||||
(insert (mapconcat 'substring-no-properties uses " ") " ;")
|
||||
(fill-region start (point) nil)))
|
||||
|
||||
(defun fuel-debug--uses-filter (restarts)
|
||||
(let ((result) (i 1) (rn 0))
|
||||
(dolist (r restarts (reverse result))
|
||||
|
|
@ -87,9 +61,6 @@
|
|||
(fuel-popup--define fuel-debug--uses-buffer
|
||||
"*fuel uses*" 'fuel-debug-uses-mode)
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-debug--uses nil))
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-debug--uses-file nil))
|
||||
|
||||
|
|
@ -122,27 +93,15 @@
|
|||
(fuel-popup--display (fuel-debug--uses-buffer))))
|
||||
|
||||
(defun fuel-debug--uses-cont (retort)
|
||||
(let ((uses (fuel-eval--retort-result retort))
|
||||
(let ((uses (fuel-debug--uses retort))
|
||||
(err (fuel-eval--retort-error retort)))
|
||||
(if uses (fuel-debug--uses-display uses)
|
||||
(fuel-debug--uses-display-err retort))))
|
||||
|
||||
(defun fuel-debug--insert-vlist (title vlist)
|
||||
(goto-char (point-max))
|
||||
(insert title "\n\n ")
|
||||
(let ((i 0) (step 5))
|
||||
(dolist (v vlist)
|
||||
(setq i (1+ i))
|
||||
(insert v)
|
||||
(insert (if (zerop (mod i step)) "\n " " ")))
|
||||
(unless (zerop (mod i step)) (newline))
|
||||
(newline)))
|
||||
|
||||
(defun fuel-debug--uses-display (uses)
|
||||
(let* ((inhibit-read-only t)
|
||||
(old (with-current-buffer (find-file-noselect fuel-debug--uses-file)
|
||||
(fuel-syntax--usings)))
|
||||
(old (sort old 'string<))
|
||||
(sort (fuel-syntax--find-usings t) 'string<)))
|
||||
(new (sort uses 'string<)))
|
||||
(erase-buffer)
|
||||
(fuel-debug--uses-insert-title)
|
||||
|
|
@ -177,14 +136,15 @@
|
|||
|
||||
(defun fuel-debug--uses-update-usings ()
|
||||
(interactive)
|
||||
(let ((inhibit-read-only t))
|
||||
(when (and fuel-debug--uses-file fuel-debug--uses)
|
||||
(fuel-debug--uses-new-uses fuel-debug--uses-file fuel-debug--uses)
|
||||
(message "USING: updated!")
|
||||
(with-current-buffer (fuel-debug--uses-buffer)
|
||||
(let ((inhibit-read-only t)
|
||||
(file fuel-debug--uses-file)
|
||||
(uses fuel-debug--uses))
|
||||
(when (and uses file)
|
||||
(insert "\nDone!")
|
||||
(fuel-debug--uses-clean)
|
||||
(bury-buffer)))))
|
||||
(fuel-popup--quit)
|
||||
(fuel-debug--replace-usings file uses)
|
||||
(message "USING: updated!"))))
|
||||
|
||||
(defun fuel-debug--uses-restart (n)
|
||||
(when (and (> n 0) (<= n (length fuel-debug--uses-restarts)))
|
||||
|
|
|
|||
|
|
@ -31,6 +31,12 @@
|
|||
:group 'fuel-debug
|
||||
:type 'hook)
|
||||
|
||||
(defcustom fuel-debug-confirm-restarts-p t
|
||||
"Whether to ask for confimation before executing a restart in
|
||||
the debugger."
|
||||
:group 'fuel-debug
|
||||
:type 'boolean)
|
||||
|
||||
(defcustom fuel-debug-show-short-help t
|
||||
"Whether to show short help on available keys in debugger."
|
||||
:group 'fuel-debug
|
||||
|
|
@ -43,7 +49,9 @@
|
|||
(column variable-name "column numbers in errors/warnings")
|
||||
(info comment "information headers")
|
||||
(restart-number warning "restart numbers")
|
||||
(restart-name function-name "restart names")))
|
||||
(restart-name function-name "restart names")
|
||||
(missing-vocab warning"missing vocabulary names")
|
||||
(unneeded-vocab warning "unneeded vocabulary names")))
|
||||
|
||||
|
||||
;;; Font lock and other pattern matching:
|
||||
|
|
@ -92,6 +100,9 @@
|
|||
(make-variable-buffer-local
|
||||
(defvar fuel-debug--file nil))
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-debug--uses nil))
|
||||
|
||||
(defun fuel-debug--prepare-compilation (file msg)
|
||||
(let ((inhibit-read-only t))
|
||||
(with-current-buffer (fuel-debug--buffer)
|
||||
|
|
@ -114,6 +125,7 @@
|
|||
(fuel-debug--display-restarts err)
|
||||
(delete-blank-lines)
|
||||
(newline))
|
||||
(fuel-debug--display-uses ret)
|
||||
(let ((hstr (fuel-debug--help-string err fuel-debug--file)))
|
||||
(if fuel-debug-show-short-help
|
||||
(insert "-----------\n" hstr "\n")
|
||||
|
|
@ -124,6 +136,46 @@
|
|||
(when (and err (not no-pop)) (fuel-popup--display))
|
||||
(not err))))
|
||||
|
||||
(defun fuel-debug--uses (ret)
|
||||
(let ((uses (fuel-eval--retort-result ret)))
|
||||
(and (eq :uses (car uses))
|
||||
(cdr uses))))
|
||||
|
||||
(defun fuel-debug--insert-vlist (title vlist)
|
||||
(goto-char (point-max))
|
||||
(insert title "\n\n ")
|
||||
(let ((i 0) (step 5))
|
||||
(dolist (v vlist)
|
||||
(setq i (1+ i))
|
||||
(insert v)
|
||||
(insert (if (zerop (mod i step)) "\n " " ")))
|
||||
(unless (zerop (mod i step)) (newline))
|
||||
(newline)))
|
||||
|
||||
(defun fuel-debug--highlight-names (names ref face)
|
||||
(dolist (n names)
|
||||
(when (not (member n ref))
|
||||
(put-text-property 0 (length n) 'font-lock-face face n))))
|
||||
|
||||
(defun fuel-debug--insert-uses (uses)
|
||||
(let* ((file (or file fuel-debug--file))
|
||||
(old (with-current-buffer (find-file-noselect file)
|
||||
(sort (fuel-syntax--find-usings t) 'string<)))
|
||||
(new (sort uses 'string<)))
|
||||
(when (not (equalp old new))
|
||||
(fuel-debug--highlight-names old new 'fuel-font-lock-debug-unneeded-vocab)
|
||||
(newline)
|
||||
(fuel-debug--insert-vlist "Correct vocabulary list:" new)
|
||||
new)))
|
||||
|
||||
(defun fuel-debug--display-uses (ret)
|
||||
(when (setq fuel-debug--uses (fuel-debug--uses ret))
|
||||
(newline)
|
||||
(fuel-debug--highlight-names fuel-debug--uses
|
||||
nil 'fuel-font-lock-debug-missing-vocab)
|
||||
(fuel-debug--insert-vlist "Missing vocabularies:" fuel-debug--uses)
|
||||
(newline)))
|
||||
|
||||
(defun fuel-debug--display-output (ret)
|
||||
(let* ((last (fuel-eval--retort-output fuel-debug--last-ret))
|
||||
(current (fuel-eval--retort-output ret))
|
||||
|
|
@ -149,7 +201,7 @@
|
|||
(newline))))
|
||||
|
||||
(defun fuel-debug--help-string (err &optional file)
|
||||
(format "Press %s%s%sq bury buffer"
|
||||
(format "Press %s%s%s%sq bury buffer"
|
||||
(if (or file (fuel-eval--error-file err)) "g go to file, " "")
|
||||
(let ((rsn (length (fuel-eval--error-restarts err))))
|
||||
(cond ((zerop rsn) "")
|
||||
|
|
@ -160,7 +212,8 @@
|
|||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(when (search-forward (car ci) nil t)
|
||||
(setq str (format "%c %s, %s" (cdr ci) (car ci) str))))))))
|
||||
(setq str (format "%c %s, %s" (cdr ci) (car ci) str))))))
|
||||
(if (and (not err) fuel-debug--uses) "u to update USING:, " "")))
|
||||
|
||||
(defun fuel-debug--buffer-file ()
|
||||
(with-current-buffer (fuel-debug--buffer)
|
||||
|
|
@ -229,6 +282,31 @@
|
|||
(fuel-eval--send/wait `(:fuel ((:factor ,info)))) "")
|
||||
(error "Sorry, no %s info available" info))))
|
||||
|
||||
(defun fuel-debug--replace-usings (file uses)
|
||||
(pop-to-buffer (find-file-noselect file))
|
||||
(goto-char (point-min))
|
||||
(if (re-search-forward "^USING: " nil t)
|
||||
(let ((begin (point))
|
||||
(end (or (and (re-search-forward "\\_<;\\_>") (point)) (point))))
|
||||
(kill-region begin end))
|
||||
(re-search-forward "^IN: " nil t)
|
||||
(beginning-of-line)
|
||||
(open-line 2)
|
||||
(insert "USING: "))
|
||||
(let ((start (point)))
|
||||
(insert (mapconcat 'substring-no-properties uses " ") " ;")
|
||||
(fill-region start (point) nil)))
|
||||
|
||||
(defun fuel-debug-update-usings ()
|
||||
(interactive)
|
||||
(when (and fuel-debug--file fuel-debug--uses)
|
||||
(let* ((file fuel-debug--file)
|
||||
(old (with-current-buffer (find-file-noselect file)
|
||||
(fuel-syntax--find-usings t)))
|
||||
(uses (sort (append fuel-debug--uses old) 'string<)))
|
||||
(fuel-popup--quit)
|
||||
(fuel-debug--replace-usings file uses))))
|
||||
|
||||
|
||||
;;; Fuel Debug mode:
|
||||
|
||||
|
|
@ -239,9 +317,11 @@
|
|||
(define-key map "\C-c\C-c" 'fuel-debug-goto-error)
|
||||
(define-key map "n" 'next-line)
|
||||
(define-key map "p" 'previous-line)
|
||||
(define-key map "u" 'fuel-debug-update-usings)
|
||||
(dotimes (n 9)
|
||||
(define-key map (vector (+ ?1 n))
|
||||
`(lambda () (interactive) (fuel-debug-exec-restart ,(1+ n) t))))
|
||||
`(lambda () (interactive)
|
||||
(fuel-debug-exec-restart ,(1+ n) fuel-debug-confirm-restarts-p))))
|
||||
(dolist (ci fuel-debug--compiler-info-alist)
|
||||
(define-key map (vector (cdr ci))
|
||||
`(lambda () (interactive) (fuel-debug-show--compiler-info ,(car ci)))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; fuel-font-lock.el -- font lock for factor code
|
||||
|
||||
;; 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>
|
||||
|
|
@ -99,5 +99,24 @@
|
|||
fuel-syntax--syntactic-keywords))))))
|
||||
|
||||
|
||||
|
||||
;;; Fontify strings as Factor code:
|
||||
|
||||
(defvar fuel-font-lock--font-lock-buffer
|
||||
(let ((buffer (get-buffer-create " *fuel font lock*")))
|
||||
(set-buffer buffer)
|
||||
(set-syntax-table fuel-syntax--syntax-table)
|
||||
(fuel-font-lock--font-lock-setup)
|
||||
buffer))
|
||||
|
||||
(defun fuel-font-lock--factor-str (str)
|
||||
(save-current-buffer
|
||||
(set-buffer fuel-font-lock--font-lock-buffer)
|
||||
(erase-buffer)
|
||||
(insert str)
|
||||
(let ((font-lock-verbose nil)) (font-lock-fontify-buffer))
|
||||
(buffer-string)))
|
||||
|
||||
|
||||
(provide 'fuel-font-lock)
|
||||
;;; fuel-font-lock.el ends here
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; fuel-help.el -- accessing Factor's help system
|
||||
|
||||
;; 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>
|
||||
|
|
@ -15,12 +15,16 @@
|
|||
;;; Code:
|
||||
|
||||
(require 'fuel-eval)
|
||||
(require 'fuel-markup)
|
||||
(require 'fuel-autodoc)
|
||||
(require 'fuel-xref)
|
||||
(require 'fuel-completion)
|
||||
(require 'fuel-font-lock)
|
||||
(require 'fuel-popup)
|
||||
(require 'fuel-base)
|
||||
|
||||
(require 'button)
|
||||
|
||||
|
||||
;;; Customization:
|
||||
|
||||
|
|
@ -33,37 +37,35 @@
|
|||
:type 'boolean
|
||||
:group 'fuel-help)
|
||||
|
||||
(defcustom fuel-help-use-minibuffer t
|
||||
"When enabled, use the minibuffer for short help messages."
|
||||
:type 'boolean
|
||||
:group 'fuel-help)
|
||||
|
||||
(defcustom fuel-help-mode-hook nil
|
||||
"Hook run by `factor-help-mode'."
|
||||
:type 'hook
|
||||
:group 'fuel-help)
|
||||
|
||||
(defcustom fuel-help-history-cache-size 50
|
||||
"Maximum number of pages to keep in the help browser cache."
|
||||
:type 'integer
|
||||
:group 'fuel-help)
|
||||
|
||||
(fuel-font-lock--defface fuel-font-lock-help-headlines
|
||||
'bold fuel-hep "headlines in help buffers")
|
||||
(defcustom fuel-help-bookmarks nil
|
||||
"Bookmars. Maintain this list using the help browser."
|
||||
:type 'list
|
||||
:group 'fuel-help)
|
||||
|
||||
|
||||
;;; Help browser history:
|
||||
|
||||
(defvar fuel-help--history
|
||||
(defun fuel-help--make-history ()
|
||||
(list nil ; current
|
||||
(make-ring fuel-help-history-cache-size) ; previous
|
||||
(make-ring fuel-help-history-cache-size))) ; next
|
||||
|
||||
(defun fuel-help--history-push (term)
|
||||
(when (and (car fuel-help--history)
|
||||
(not (string= (caar fuel-help--history) (car term))))
|
||||
(ring-insert (nth 1 fuel-help--history) (car fuel-help--history)))
|
||||
(setcar fuel-help--history term))
|
||||
(defsubst fuel-help--history-current ()
|
||||
(car fuel-help--history))
|
||||
|
||||
(defun fuel-help--history-push (link)
|
||||
(unless (equal link (car fuel-help--history))
|
||||
(let ((next (fuel-help--history-next)))
|
||||
(unless (equal link next)
|
||||
(when next (fuel-help--history-previous))
|
||||
(ring-insert (nth 1 fuel-help--history) (car fuel-help--history))
|
||||
(setcar fuel-help--history link))))
|
||||
link)
|
||||
|
||||
(defun fuel-help--history-next ()
|
||||
(when (not (ring-empty-p (nth 2 fuel-help--history)))
|
||||
|
|
@ -77,6 +79,25 @@
|
|||
(ring-insert (nth 2 fuel-help--history) (car fuel-help--history)))
|
||||
(setcar fuel-help--history (ring-remove (nth 1 fuel-help--history) 0))))
|
||||
|
||||
(defvar fuel-help--history (fuel-help--make-history))
|
||||
|
||||
|
||||
;;; Page cache:
|
||||
|
||||
(defun fuel-help--history-current-content ()
|
||||
(fuel-help--cache-get (car fuel-help--history)))
|
||||
|
||||
(defvar fuel-help--cache (make-hash-table :weakness 'key :test 'equal))
|
||||
|
||||
(defsubst fuel-help--cache-get (name)
|
||||
(gethash name fuel-help--cache))
|
||||
|
||||
(defsubst fuel-help--cache-insert (name str)
|
||||
(puthash name str fuel-help--cache))
|
||||
|
||||
(defsubst fuel-help--cache-clear ()
|
||||
(clrhash fuel-help--cache))
|
||||
|
||||
|
||||
;;; Fuel help buffer and internals:
|
||||
|
||||
|
|
@ -86,121 +107,158 @@
|
|||
|
||||
(defvar fuel-help--prompt-history nil)
|
||||
|
||||
(defun fuel-help--show-help (&optional see word)
|
||||
(let* ((def (or word (fuel-syntax-symbol-at-point)))
|
||||
(make-local-variable
|
||||
(defvar fuel-help--buffer-link nil))
|
||||
|
||||
(defun fuel-help--read-word (see)
|
||||
(let* ((def (fuel-syntax-symbol-at-point))
|
||||
(prompt (format "See%s help on%s: " (if see " short" "")
|
||||
(if def (format " (%s)" def) "")))
|
||||
(ask (or (not (memq major-mode '(factor-mode fuel-help-mode)))
|
||||
(not def)
|
||||
fuel-help-always-ask))
|
||||
(def (if ask (fuel-completion--read-word prompt
|
||||
fuel-help-always-ask)))
|
||||
(if ask (fuel-completion--read-word prompt
|
||||
def
|
||||
'fuel-help--prompt-history
|
||||
t)
|
||||
def))
|
||||
(cmd `(:fuel* ((:quote ,def) ,(if see 'see 'help)) t)))
|
||||
def)))
|
||||
|
||||
(defun fuel-help--word-help (&optional see word)
|
||||
(let ((def (or word (fuel-help--read-word see))))
|
||||
(when def
|
||||
(let ((cmd `(:fuel* (,def ,(if see 'fuel-word-see 'fuel-word-help))
|
||||
"fuel" t)))
|
||||
(message "Looking up '%s' ..." def)
|
||||
(fuel-eval--send cmd `(lambda (r) (fuel-help--show-help-cont ,def r)))))
|
||||
|
||||
(defun fuel-help--show-help-cont (def ret)
|
||||
(let ((out (fuel-eval--retort-output ret)))
|
||||
(if (or (fuel-eval--retort-error ret) (empty-string-p out))
|
||||
(let* ((ret (fuel-eval--send/wait cmd 2000))
|
||||
(res (fuel-eval--retort-result ret)))
|
||||
(if (not res)
|
||||
(message "No help for '%s'" def)
|
||||
(fuel-help--insert-contents def out))))
|
||||
(fuel-help--insert-contents (list def def 'word) res)))))))
|
||||
|
||||
(defun fuel-help--insert-contents (def str &optional nopush)
|
||||
(defun fuel-help--get-article (name label)
|
||||
(message "Retrieving article ...")
|
||||
(let* ((cmd `(:fuel* ((,name fuel-get-article)) "fuel" t))
|
||||
(ret (fuel-eval--send/wait cmd 2000))
|
||||
(res (fuel-eval--retort-result ret)))
|
||||
(if (not res)
|
||||
(message "Article '%s' not found" label)
|
||||
(fuel-help--insert-contents (list name label 'article) res)
|
||||
(message ""))))
|
||||
|
||||
(defun fuel-help--get-vocab (name)
|
||||
(message "Retrieving vocabulary help ...")
|
||||
(let* ((cmd `(:fuel* ((,name fuel-vocab-help)) "fuel" (,name)))
|
||||
(ret (fuel-eval--send/wait cmd 2000))
|
||||
(res (fuel-eval--retort-result ret)))
|
||||
(if (not res)
|
||||
(message "No help available for vocabulary '%s'" name)
|
||||
(fuel-help--insert-contents (list name name 'vocab) res)
|
||||
(message ""))))
|
||||
|
||||
(defun fuel-help--follow-link (link label type &optional no-cache)
|
||||
(let* ((llink (list link label type))
|
||||
(cached (and (not no-cache) (fuel-help--cache-get llink))))
|
||||
(if (not cached)
|
||||
(let ((fuel-help-always-ask nil))
|
||||
(cond ((eq type 'word) (fuel-help--word-help nil link))
|
||||
((eq type 'article) (fuel-help--get-article link label))
|
||||
((eq type 'vocab) (fuel-help--get-vocab link))
|
||||
((eq type 'bookmarks) (fuel-help-display-bookmarks))
|
||||
(t (error "Links of type %s not yet implemented" type))))
|
||||
(fuel-help--insert-contents llink cached))))
|
||||
|
||||
(defun fuel-help--insert-contents (key content)
|
||||
(let ((hb (fuel-help--buffer))
|
||||
(inhibit-read-only t)
|
||||
(font-lock-verbose nil))
|
||||
(set-buffer hb)
|
||||
(erase-buffer)
|
||||
(insert str)
|
||||
(unless nopush
|
||||
(goto-char (point-min))
|
||||
(when (re-search-forward (format "^%s" def) nil t)
|
||||
(beginning-of-line)
|
||||
(kill-region (point-min) (point))
|
||||
(fuel-help--history-push (cons def (buffer-string)))))
|
||||
(if (stringp content)
|
||||
(insert content)
|
||||
(fuel-markup--print content)
|
||||
(fuel-markup--insert-newline)
|
||||
(fuel-help--cache-insert key (buffer-string)))
|
||||
(fuel-help--history-push key)
|
||||
(setq fuel-help--buffer-link key)
|
||||
(set-buffer-modified-p nil)
|
||||
(fuel-popup--display)
|
||||
(goto-char (point-min))
|
||||
(message "%s" def)))
|
||||
(message "")))
|
||||
|
||||
|
||||
;;; Help mode font lock:
|
||||
;;; Bookmarks:
|
||||
|
||||
(defconst fuel-help--headlines
|
||||
(regexp-opt '("Class description"
|
||||
"Definition"
|
||||
"Errors"
|
||||
"Examples"
|
||||
"Generic word contract"
|
||||
"Inputs and outputs"
|
||||
"Methods"
|
||||
"Notes"
|
||||
"Parent topics:"
|
||||
"See also"
|
||||
"Syntax"
|
||||
"Variable description"
|
||||
"Variable value"
|
||||
"Vocabulary"
|
||||
"Warning"
|
||||
"Word description")
|
||||
t))
|
||||
(defun fuel-help-bookmark-page ()
|
||||
"Add current help page to bookmarks."
|
||||
(interactive)
|
||||
(let ((link fuel-help--buffer-link))
|
||||
(unless link (error "No link associated to this page"))
|
||||
(add-to-list 'fuel-help-bookmarks link)
|
||||
(customize-save-variable 'fuel-help-bookmarks fuel-help-bookmarks)
|
||||
(message "Bookmark '%s' saved" (cadr link))))
|
||||
|
||||
(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines))
|
||||
|
||||
(defconst fuel-help--font-lock-keywords
|
||||
`(,@fuel-font-lock--font-lock-keywords
|
||||
(,fuel-help--headlines-regexp . 'fuel-font-lock-help-headlines)))
|
||||
(defun fuel-help-delete-bookmark ()
|
||||
"Delete link at point from bookmarks."
|
||||
(interactive)
|
||||
(let ((link (fuel-markup--link-at-point)))
|
||||
(unless link (error "No link at point"))
|
||||
(unless (member link fuel-help-bookmarks)
|
||||
(error "'%s' is not bookmarked" (cadr link)))
|
||||
(customize-save-variable 'fuel-help-bookmarks
|
||||
(remove link fuel-help-bookmarks))
|
||||
(message "Bookmark '%s' delete" (cadr link))
|
||||
(fuel-help-display-bookmarks)))
|
||||
|
||||
(defun fuel-help-display-bookmarks ()
|
||||
"Display bookmarked pages."
|
||||
(interactive)
|
||||
(let ((links (mapcar (lambda (l) (cons '$subsection l)) fuel-help-bookmarks)))
|
||||
(unless links (error "No links to display"))
|
||||
(fuel-help--insert-contents '("bookmarks" "Bookmars" bookmarks)
|
||||
`(article "Bookmarks" ,links))))
|
||||
|
||||
|
||||
;;; Interactive help commands:
|
||||
|
||||
(defun fuel-help-short (&optional arg)
|
||||
"See a help summary of symbol at point.
|
||||
By default, the information is shown in the minibuffer. When
|
||||
called with a prefix argument, the information is displayed in a
|
||||
separate help buffer."
|
||||
(interactive "P")
|
||||
(if (if fuel-help-use-minibuffer (not arg) arg)
|
||||
(fuel-help--word-synopsis)
|
||||
(fuel-help--show-help t)))
|
||||
(defun fuel-help-short ()
|
||||
"See help summary of symbol at point."
|
||||
(interactive)
|
||||
(fuel-help--word-help t))
|
||||
|
||||
(defun fuel-help ()
|
||||
"Show extended help about the symbol at point, using a help
|
||||
buffer."
|
||||
(interactive)
|
||||
(fuel-help--show-help))
|
||||
(fuel-help--word-help))
|
||||
|
||||
(defun fuel-help-next ()
|
||||
"Go to next page in help browser."
|
||||
(interactive)
|
||||
(let ((item (fuel-help--history-next))
|
||||
(fuel-help-always-ask nil))
|
||||
(unless item
|
||||
(error "No next page"))
|
||||
(fuel-help--insert-contents (car item) (cdr item) t)))
|
||||
(let ((item (fuel-help--history-next)))
|
||||
(unless item (error "No next page"))
|
||||
(apply 'fuel-help--follow-link item)))
|
||||
|
||||
(defun fuel-help-previous ()
|
||||
"Go to next page in help browser."
|
||||
"Go to previous page in help browser."
|
||||
(interactive)
|
||||
(let ((item (fuel-help--history-previous))
|
||||
(fuel-help-always-ask nil))
|
||||
(unless item
|
||||
(error "No previous page"))
|
||||
(fuel-help--insert-contents (car item) (cdr item) t)))
|
||||
(let ((item (fuel-help--history-previous)))
|
||||
(unless item (error "No previous page"))
|
||||
(apply 'fuel-help--follow-link item)))
|
||||
|
||||
(defun fuel-help-next-headline (&optional count)
|
||||
(interactive "P")
|
||||
(end-of-line)
|
||||
(when (re-search-forward fuel-help--headlines-regexp nil t (or count 1))
|
||||
(beginning-of-line)))
|
||||
(defun fuel-help-refresh ()
|
||||
"Refresh the contents of current page."
|
||||
(interactive)
|
||||
(when fuel-help--buffer-link
|
||||
(apply 'fuel-help--follow-link (append fuel-help--buffer-link '(t)))))
|
||||
|
||||
(defun fuel-help-previous-headline (&optional count)
|
||||
(interactive "P")
|
||||
(re-search-backward fuel-help--headlines-regexp nil t count))
|
||||
(defun fuel-help-clean-history ()
|
||||
"Clean up the help browser cache of visited pages."
|
||||
(interactive)
|
||||
(when (y-or-n-p "Clean browsing history? ")
|
||||
(fuel-help--cache-clear)
|
||||
(setq fuel-help--history (fuel-help--make-history))
|
||||
(fuel-help-refresh))
|
||||
(message ""))
|
||||
|
||||
|
||||
;;;; Help mode map:
|
||||
|
|
@ -208,15 +266,16 @@ buffer."
|
|||
(defvar fuel-help-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(suppress-keymap map)
|
||||
(define-key map "\C-m" 'fuel-help)
|
||||
(define-key map "b" 'fuel-help-previous)
|
||||
(define-key map "f" 'fuel-help-next)
|
||||
(define-key map "l" 'fuel-help-previous)
|
||||
(define-key map "p" 'fuel-help-previous)
|
||||
(set-keymap-parent map button-buffer-map)
|
||||
(define-key map "a" 'fuel-apropos)
|
||||
(define-key map "ba" 'fuel-help-bookmark-page)
|
||||
(define-key map "bb" 'fuel-help-display-bookmarks)
|
||||
(define-key map "bd" 'fuel-help-delete-bookmark)
|
||||
(define-key map "c" 'fuel-help-clean-history)
|
||||
(define-key map "h" 'fuel-help)
|
||||
(define-key map "n" 'fuel-help-next)
|
||||
(define-key map (kbd "TAB") 'fuel-help-next-headline)
|
||||
(define-key map (kbd "S-TAB") 'fuel-help-previous-headline)
|
||||
(define-key map [(backtab)] 'fuel-help-previous-headline)
|
||||
(define-key map "p" 'fuel-help-previous)
|
||||
(define-key map "r" 'fuel-help-refresh)
|
||||
(define-key map (kbd "SPC") 'scroll-up)
|
||||
(define-key map (kbd "S-SPC") 'scroll-down)
|
||||
(define-key map "\M-." 'fuel-edit-word-at-point)
|
||||
|
|
@ -234,16 +293,10 @@ buffer."
|
|||
(kill-all-local-variables)
|
||||
(buffer-disable-undo)
|
||||
(use-local-map fuel-help-mode-map)
|
||||
(set-syntax-table fuel-syntax--syntax-table)
|
||||
(setq mode-name "FUEL Help")
|
||||
(setq major-mode 'fuel-help-mode)
|
||||
|
||||
(fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t)
|
||||
|
||||
(setq fuel-autodoc-mode-string "")
|
||||
(fuel-autodoc-mode)
|
||||
|
||||
(run-mode-hooks 'fuel-help-mode-hook)
|
||||
|
||||
(setq fuel-markup--follow-link-function 'fuel-help--follow-link)
|
||||
(setq buffer-read-only t))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; fuel-listener.el --- starting the fuel listener
|
||||
|
||||
;; 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>
|
||||
|
|
@ -15,6 +15,7 @@
|
|||
|
||||
(require 'fuel-stack)
|
||||
(require 'fuel-completion)
|
||||
(require 'fuel-xref)
|
||||
(require 'fuel-eval)
|
||||
(require 'fuel-connection)
|
||||
(require 'fuel-syntax)
|
||||
|
|
@ -169,6 +170,7 @@ buffer."
|
|||
(define-key fuel-listener-mode-map "\C-ca" 'fuel-autodoc-mode)
|
||||
(define-key fuel-listener-mode-map "\C-ch" 'fuel-help)
|
||||
(define-key fuel-listener-mode-map "\C-cs" 'fuel-stack-mode)
|
||||
(define-key fuel-listener-mode-map "\C-cp" 'fuel-apropos)
|
||||
(define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point)
|
||||
(define-key fuel-listener-mode-map "\C-cv" 'fuel-edit-vocabulary)
|
||||
(define-key fuel-listener-mode-map "\C-c\C-v" 'fuel-edit-vocabulary)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,479 @@
|
|||
;;; fuel-markup.el -- printing factor help markup
|
||||
|
||||
;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
;; Keywords: languages, fuel, factor
|
||||
;; Start date: Thu Jan 01, 2009 21:43
|
||||
|
||||
;;; Comentary:
|
||||
|
||||
;; Utilities for printing Factor's help markup.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'fuel-eval)
|
||||
(require 'fuel-font-lock)
|
||||
(require 'fuel-base)
|
||||
|
||||
(require 'button)
|
||||
(require 'table)
|
||||
|
||||
|
||||
;;; Customization:
|
||||
|
||||
(fuel-font-lock--defface fuel-font-lock-markup-title
|
||||
'bold fuel-help "article titles in help buffers")
|
||||
|
||||
(fuel-font-lock--defface fuel-font-lock-markup-heading
|
||||
'bold fuel-help "headlines in help buffers")
|
||||
|
||||
(fuel-font-lock--defface fuel-font-lock-markup-link
|
||||
'link fuel-help "links to topics in help buffers")
|
||||
|
||||
(fuel-font-lock--defface fuel-font-lock-markup-emphasis
|
||||
'italic fuel-help "emphasized words in help buffers")
|
||||
|
||||
(fuel-font-lock--defface fuel-font-lock-markup-strong
|
||||
'link fuel-help "bold words in help buffers")
|
||||
|
||||
|
||||
;;; Links:
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-markup--follow-link-function 'fuel-markup--echo-link))
|
||||
|
||||
(define-button-type 'fuel-markup--button
|
||||
'action 'fuel-markup--follow-link
|
||||
'face 'fuel-font-lock-markup-link
|
||||
'follow-link t)
|
||||
|
||||
(defun fuel-markup--follow-link (button)
|
||||
(when fuel-markup--follow-link-function
|
||||
(funcall fuel-markup--follow-link-function
|
||||
(button-get button 'markup-link)
|
||||
(button-get button 'markup-label)
|
||||
(button-get button 'markup-link-type))))
|
||||
|
||||
(defun fuel-markup--echo-link (link label type)
|
||||
(message "Link %s pointing to %s named %s" label type link))
|
||||
|
||||
(defun fuel-markup--insert-button (label link type)
|
||||
(let ((label (format "%s" label))
|
||||
(link (format "%s" link)))
|
||||
(insert-text-button label
|
||||
:type 'fuel-markup--button
|
||||
'markup-link link
|
||||
'markup-label label
|
||||
'markup-link-type type
|
||||
'help-echo (format "%s (%s)" label type))))
|
||||
|
||||
(defun fuel-markup--article-title (name)
|
||||
(fuel-eval--retort-result
|
||||
(fuel-eval--send/wait `(:fuel* ((,name fuel-article-title :get)) "fuel"))))
|
||||
|
||||
(defun fuel-markup--link-at-point ()
|
||||
(let ((button (condition-case nil (forward-button 0) (error nil))))
|
||||
(when button
|
||||
(list (button-get button 'markup-link)
|
||||
(button-get button 'markup-label)
|
||||
(button-get button 'markup-link-type)))))
|
||||
|
||||
|
||||
;;; Markup printers:
|
||||
|
||||
(defconst fuel-markup--printers
|
||||
'(($class-description . fuel-markup--class-description)
|
||||
($code . fuel-markup--code)
|
||||
($command . fuel-markup--command)
|
||||
($contract . fuel-markup--contract)
|
||||
($curious . fuel-markup--curious)
|
||||
($definition . fuel-markup--definition)
|
||||
($description . fuel-markup--description)
|
||||
($doc-path . fuel-markup--doc-path)
|
||||
($emphasis . fuel-markup--emphasis)
|
||||
($error-description . fuel-markup--error-description)
|
||||
($errors . fuel-markup--errors)
|
||||
($example . fuel-markup--example)
|
||||
($examples . fuel-markup--examples)
|
||||
($heading . fuel-markup--heading)
|
||||
($index . fuel-markup--index)
|
||||
($instance . fuel-markup--instance)
|
||||
($io-error . fuel-markup--io-error)
|
||||
($link . fuel-markup--link)
|
||||
($links . fuel-markup--links)
|
||||
($list . fuel-markup--list)
|
||||
($low-level-note . fuel-markup--low-level-note)
|
||||
($markup-example . fuel-markup--markup-example)
|
||||
($maybe . fuel-markup--maybe)
|
||||
($methods . fuel-markup--methods)
|
||||
($nl . fuel-markup--newline)
|
||||
($notes . fuel-markup--notes)
|
||||
($parsing-note . fuel-markup--parsing-note)
|
||||
($predicate . fuel-markup--predicate)
|
||||
($prettyprinting-note . fuel-markup--prettyprinting-note)
|
||||
($quotation . fuel-markup--quotation)
|
||||
($references . fuel-markup--references)
|
||||
($related . fuel-markup--related)
|
||||
($see . fuel-markup--see)
|
||||
($see-also . fuel-markup--see-also)
|
||||
($shuffle . fuel-markup--shuffle)
|
||||
($side-effects . fuel-markup--side-effects)
|
||||
($slot . fuel-markup--snippet)
|
||||
($snippet . fuel-markup--snippet)
|
||||
($strong . fuel-markup--strong)
|
||||
($subheading . fuel-markup--subheading)
|
||||
($subsection . fuel-markup--subsection)
|
||||
($synopsis . fuel-markup--synopsis)
|
||||
($syntax . fuel-markup--syntax)
|
||||
($table . fuel-markup--table)
|
||||
($unchecked-example . fuel-markup--example)
|
||||
($value . fuel-markup--value)
|
||||
($values . fuel-markup--values)
|
||||
($values-x/y . fuel-markup--values-x/y)
|
||||
($var-description . fuel-markup--var-description)
|
||||
($vocab-link . fuel-markup--vocab-link)
|
||||
($vocab-links . fuel-markup--vocab-links)
|
||||
($vocab-subsection . fuel-markup--vocab-subsection)
|
||||
($vocabulary . fuel-markup--vocabulary)
|
||||
($warning . fuel-markup--warning)
|
||||
(article . fuel-markup--article)))
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-markup--maybe-nl nil))
|
||||
|
||||
(defun fuel-markup--print (e)
|
||||
(cond ((null e))
|
||||
((stringp e) (fuel-markup--insert-string e))
|
||||
((and (listp e) (symbolp (car e))
|
||||
(assoc (car e) fuel-markup--printers))
|
||||
(funcall (cdr (assoc (car e) fuel-markup--printers)) e))
|
||||
((and (symbolp e)
|
||||
(assoc e fuel-markup--printers))
|
||||
(funcall (cdr (assoc e fuel-markup--printers)) e))
|
||||
((listp e) (mapc 'fuel-markup--print e))
|
||||
((symbolp e) (fuel-markup--print (list '$link e)))
|
||||
(t (insert (format "\n%S\n" e)))))
|
||||
|
||||
(defun fuel-markup--print-str (e)
|
||||
(with-temp-buffer
|
||||
(fuel-markup--print e)
|
||||
(buffer-string)))
|
||||
|
||||
(defun fuel-markup--maybe-nl ()
|
||||
(setq fuel-markup--maybe-nl (point)))
|
||||
|
||||
(defun fuel-markup--insert-newline (&optional justification)
|
||||
(fill-region (save-excursion (beginning-of-line) (point))
|
||||
(point)
|
||||
(or justification 'left))
|
||||
(newline))
|
||||
|
||||
(defsubst fuel-markup--insert-nl-if-nb (&optional no-fill)
|
||||
(unless (eq (save-excursion (beginning-of-line) (point)) (point))
|
||||
(if no-fill (newline) (fuel-markup--insert-newline))))
|
||||
|
||||
(defsubst fuel-markup--put-face (txt face)
|
||||
(put-text-property 0 (length txt) 'font-lock-face face txt)
|
||||
txt)
|
||||
|
||||
(defun fuel-markup--insert-heading (txt &optional no-nl)
|
||||
(fuel-markup--insert-nl-if-nb)
|
||||
(unless (bobp) (newline))
|
||||
(fuel-markup--put-face txt 'fuel-font-lock-markup-heading)
|
||||
(fuel-markup--insert-string txt)
|
||||
(unless no-nl (newline)))
|
||||
|
||||
(defun fuel-markup--insert-string (str)
|
||||
(when fuel-markup--maybe-nl
|
||||
(newline 2)
|
||||
(setq fuel-markup--maybe-nl nil))
|
||||
(insert str))
|
||||
|
||||
(defun fuel-markup--article (e)
|
||||
(setq fuel-markup--maybe-nl nil)
|
||||
(insert (fuel-markup--put-face (cadr e) 'fuel-font-lock-markup-title))
|
||||
(newline 2)
|
||||
(fuel-markup--print (car (cddr e))))
|
||||
|
||||
(defun fuel-markup--heading (e)
|
||||
(fuel-markup--insert-heading (cadr e)))
|
||||
|
||||
(defun fuel-markup--subheading (e)
|
||||
(fuel-markup--insert-heading (cadr e)))
|
||||
|
||||
(defun fuel-markup--subsection (e)
|
||||
(fuel-markup--insert-nl-if-nb)
|
||||
(insert " - ")
|
||||
(fuel-markup--link (cons '$link (cdr e)))
|
||||
(fuel-markup--maybe-nl))
|
||||
|
||||
(defun fuel-markup--vocab-subsection (e)
|
||||
(fuel-markup--insert-nl-if-nb)
|
||||
(insert " - ")
|
||||
(fuel-markup--vocab-link (cons '$vocab-link (cdr e)))
|
||||
(fuel-markup--maybe-nl))
|
||||
|
||||
(defun fuel-markup--newline (e)
|
||||
(fuel-markup--insert-newline)
|
||||
(newline))
|
||||
|
||||
(defun fuel-markup--doc-path (e)
|
||||
(fuel-markup--insert-heading "Related topics")
|
||||
(insert " ")
|
||||
(dolist (art (cdr e))
|
||||
(fuel-markup--insert-button (car art) (cadr art) 'article)
|
||||
(insert ", "))
|
||||
(delete-backward-char 2)
|
||||
(fuel-markup--insert-newline 'left))
|
||||
|
||||
(defun fuel-markup--emphasis (e)
|
||||
(when (stringp (cadr e))
|
||||
(fuel-markup--put-face (cadr e) 'fuel-font-lock-markup-emphasis)
|
||||
(insert (cadr e))))
|
||||
|
||||
(defun fuel-markup--strong (e)
|
||||
(when (stringp (cadr e))
|
||||
(fuel-markup--put-face (cadr e) 'fuel-font-lock-markup-strong)
|
||||
(insert (cadr e))))
|
||||
|
||||
(defun fuel-markup--snippet (e)
|
||||
(let ((snip (format "%s" (cdr e))))
|
||||
(insert (fuel-font-lock--factor-str snip))))
|
||||
|
||||
(defun fuel-markup--code (e)
|
||||
(fuel-markup--insert-nl-if-nb)
|
||||
(newline)
|
||||
(dolist (snip (cdr e))
|
||||
(if (stringp snip)
|
||||
(insert (fuel-font-lock--factor-str snip))
|
||||
(fuel-markup--print snip))
|
||||
(newline))
|
||||
(newline))
|
||||
|
||||
(defun fuel-markup--command (e)
|
||||
(fuel-markup--snippet (list '$snippet (nth 3 e))))
|
||||
|
||||
(defun fuel-markup--syntax (e)
|
||||
(fuel-markup--insert-heading "Syntax")
|
||||
(fuel-markup--print (cons '$code (cdr e)))
|
||||
(newline))
|
||||
|
||||
(defun fuel-markup--examples (e)
|
||||
(fuel-markup--insert-heading "Examples")
|
||||
(dolist (ex (cdr e))
|
||||
(fuel-markup--print ex)
|
||||
(newline)))
|
||||
|
||||
(defun fuel-markup--example (e)
|
||||
(fuel-markup--snippet (list '$snippet (cadr e))))
|
||||
|
||||
(defun fuel-markup--markup-example (e)
|
||||
(fuel-markup--snippet (cons '$snippet (cadr e))))
|
||||
|
||||
(defun fuel-markup--link (e)
|
||||
(let* ((link (nth 1 e))
|
||||
(type (or (nth 3 e) (if (symbolp link) 'word 'article)))
|
||||
(label (or (nth 2 e)
|
||||
(and (eq type 'article)
|
||||
(fuel-markup--article-title link))
|
||||
link)))
|
||||
(fuel-markup--insert-button label link type)))
|
||||
|
||||
(defun fuel-markup--links (e)
|
||||
(dolist (link (cdr e))
|
||||
(fuel-markup--link (list '$link link))
|
||||
(insert ", "))
|
||||
(delete-backward-char 2))
|
||||
|
||||
(defun fuel-markup--index-quotation (q)
|
||||
(cond ((null q) null)
|
||||
((listp q) (vconcat (mapcar 'fuel-markup--index-quotation q)))
|
||||
(t q)))
|
||||
|
||||
(defun fuel-markup--index (e)
|
||||
(let* ((q (fuel-markup--index-quotation (cadr e)))
|
||||
(cmd `(:fuel* ((,q fuel-index)) "fuel"
|
||||
("builtins" "help" "help.topics" "classes"
|
||||
"classes.builtin" "classes.tuple"
|
||||
"classes.singleton" "classes.union"
|
||||
"classes.intersection" "classes.predicate")))
|
||||
(subs (fuel-eval--retort-result (fuel-eval--send/wait cmd 200))))
|
||||
(when subs
|
||||
(fuel-markup--print subs))))
|
||||
|
||||
(defun fuel-markup--vocab-link (e)
|
||||
(fuel-markup--insert-button (cadr e) (cadr e) 'vocab))
|
||||
|
||||
(defun fuel-markup--vocab-links (e)
|
||||
(dolist (link (cdr e))
|
||||
(insert " ")
|
||||
(fuel-markup--vocab-link (list '$vocab-link link))
|
||||
(insert " ")))
|
||||
|
||||
(defun fuel-markup--vocabulary (e)
|
||||
(fuel-markup--insert-heading "Vocabulary: " t)
|
||||
(fuel-markup--vocab-link (cons '$vocab-link (cdr e)))
|
||||
(newline))
|
||||
|
||||
(defun fuel-markup--list (e)
|
||||
(fuel-markup--insert-nl-if-nb)
|
||||
(dolist (elt (cdr e))
|
||||
(insert " - ")
|
||||
(fuel-markup--print elt)
|
||||
(fuel-markup--insert-newline)))
|
||||
|
||||
(defun fuel-markup--table (e)
|
||||
(fuel-markup--insert-newline)
|
||||
(newline)
|
||||
(let ((start (point))
|
||||
(col-delim "<~end-of-col~>")
|
||||
(col-no (length (cadr e))))
|
||||
(dolist (row (cdr e))
|
||||
(dolist (col row)
|
||||
(fuel-markup--print col)
|
||||
(insert col-delim)))
|
||||
(table-capture start (point)
|
||||
col-delim nil nil
|
||||
(/ (- (window-width) 10) col-no) col-no))
|
||||
(goto-char (point-max))
|
||||
(table-recognize -1)
|
||||
(newline))
|
||||
|
||||
(defun fuel-markup--instance (e)
|
||||
(insert " an instance of ")
|
||||
(fuel-markup--print (cadr e)))
|
||||
|
||||
(defun fuel-markup--maybe (e)
|
||||
(fuel-markup--instance (cons '$instance (cdr e)))
|
||||
(insert " or f "))
|
||||
|
||||
(defun fuel-markup--values (e)
|
||||
(fuel-markup--insert-heading "Inputs and outputs")
|
||||
(dolist (val (cdr e))
|
||||
(insert " " (car val) " - ")
|
||||
(fuel-markup--print (cdr val))
|
||||
(newline)))
|
||||
|
||||
(defun fuel-markup--predicate (e)
|
||||
(fuel-markup--values '($values ("object" object) ("?" "a boolean")))
|
||||
(let ((word (make-symbol (substring (format "%s" (cadr e)) 0 -1))))
|
||||
(fuel-markup--description
|
||||
`($description "Tests if the object is an instance of the "
|
||||
($link ,word) " class."))))
|
||||
|
||||
(defun fuel-markup--side-effects (e)
|
||||
(fuel-markup--insert-heading "Side effects")
|
||||
(insert "Modifies ")
|
||||
(fuel-markup--print (cdr e))
|
||||
(fuel-markup--insert-newline))
|
||||
|
||||
(defun fuel-markup--definition (e)
|
||||
(fuel-markup--insert-heading "Definition")
|
||||
(fuel-markup--code (cons '$code (cdr e))))
|
||||
|
||||
(defun fuel-markup--methods (e)
|
||||
(fuel-markup--insert-heading "Methods")
|
||||
(fuel-markup--code (cons '$code (cdr e))))
|
||||
|
||||
(defun fuel-markup--value (e)
|
||||
(fuel-markup--insert-heading "Variable value")
|
||||
(insert "Current value in global namespace: ")
|
||||
(fuel-markup--snippet (cons '$snippet (cdr e)))
|
||||
(newline))
|
||||
|
||||
(defun fuel-markup--values-x/y (e)
|
||||
(fuel-markup--values '($values ("x" "number") ("y" "number"))))
|
||||
|
||||
(defun fuel-markup--curious (e)
|
||||
(fuel-markup--insert-heading "For the curious...")
|
||||
(fuel-markup--print (cdr e)))
|
||||
|
||||
(defun fuel-markup--references (e)
|
||||
(fuel-markup--insert-heading "References")
|
||||
(dolist (ref (cdr e))
|
||||
(if (listp ref)
|
||||
(fuel-markup--print ref)
|
||||
(fuel-markup--subsection (list '$subsection ref)))))
|
||||
|
||||
(defun fuel-markup--see-also (e)
|
||||
(fuel-markup--insert-heading "See also")
|
||||
(fuel-markup--links (cons '$links (cdr e))))
|
||||
|
||||
(defun fuel-markup--related (e)
|
||||
(fuel-markup--insert-heading "See also")
|
||||
(fuel-markup--links (cons '$links (cadr e))))
|
||||
|
||||
(defun fuel-markup--shuffle (e)
|
||||
(insert "\nShuffle word. Re-arranges the stack "
|
||||
"according to the stack effect pattern.")
|
||||
(fuel-markup--insert-newline))
|
||||
|
||||
(defun fuel-markup--low-level-note (e)
|
||||
(fuel-markup--print '($notes "Calling this word directly is not necessary "
|
||||
"in most cases. "
|
||||
"Higher-level words call it automatically.")))
|
||||
|
||||
(defun fuel-markup--parsing-note (e)
|
||||
(fuel-markup--insert-nl-if-nb)
|
||||
(insert "This word should only be called from parsing words.")
|
||||
(fuel-markup--insert-newline))
|
||||
|
||||
(defun fuel-markup--io-error (e)
|
||||
(fuel-markup--errors '($errors "Throws an error if the I/O operation fails.")))
|
||||
|
||||
(defun fuel-markup--prettyprinting-note (e)
|
||||
(fuel-markup--print '($notes ("This word should only be called within the "
|
||||
($link with-pprint) " combinator."))))
|
||||
|
||||
(defun fuel-markup--elem-with-heading (elem heading)
|
||||
(fuel-markup--insert-heading heading)
|
||||
(fuel-markup--print (cdr elem))
|
||||
(fuel-markup--insert-newline))
|
||||
|
||||
(defun fuel-markup--quotation (e)
|
||||
(insert "a ")
|
||||
(fuel-markup--link (list '$link 'quotation 'quotation 'word))
|
||||
(insert " with stack effect ")
|
||||
(fuel-markup--snippet (list '$snippet (nth 1 e))))
|
||||
|
||||
(defun fuel-markup--warning (e)
|
||||
(fuel-markup--elem-with-heading e "Warning"))
|
||||
|
||||
(defun fuel-markup--description (e)
|
||||
(fuel-markup--elem-with-heading e "Word description"))
|
||||
|
||||
(defun fuel-markup--class-description (e)
|
||||
(fuel-markup--elem-with-heading e "Class description"))
|
||||
|
||||
(defun fuel-markup--error-description (e)
|
||||
(fuel-markup--elem-with-heading e "Error description"))
|
||||
|
||||
(defun fuel-markup--var-description (e)
|
||||
(fuel-markup--elem-with-heading e "Variable description"))
|
||||
|
||||
(defun fuel-markup--contract (e)
|
||||
(fuel-markup--elem-with-heading e "Generic word contract"))
|
||||
|
||||
(defun fuel-markup--errors (e)
|
||||
(fuel-markup--elem-with-heading e "Errors"))
|
||||
|
||||
(defun fuel-markup--notes (e)
|
||||
(fuel-markup--elem-with-heading e "Notes"))
|
||||
|
||||
(defun fuel-markup--see (e)
|
||||
(let* ((word (nth 1 e))
|
||||
(cmd (and word `(:fuel* (,(format "%s" word) fuel-word-see) "fuel" t)))
|
||||
(res (and cmd
|
||||
(fuel-eval--retort-result (fuel-eval--send/wait cmd 100)))))
|
||||
(if res
|
||||
(fuel-markup--code (list '$code res))
|
||||
(fuel-markup--snippet (list '$snippet word)))))
|
||||
|
||||
(defun fuel-markup--synopsis (e)
|
||||
(insert (format " %S " e)))
|
||||
|
||||
|
||||
(provide 'fuel-markup)
|
||||
;;; fuel-markup.el ends here
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
;;; fuel-mode.el -- Minor mode enabling FUEL niceties
|
||||
|
||||
;; 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>
|
||||
|
|
@ -224,6 +224,11 @@ With prefix argument, ask for 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:
|
||||
|
||||
|
|
@ -289,6 +294,7 @@ interacting with a factor listener is at your disposal.
|
|||
(fuel-mode--key ?d ?> 'fuel-show-callees)
|
||||
(fuel-mode--key ?d ?< 'fuel-show-callers)
|
||||
(fuel-mode--key ?d ?a 'fuel-autodoc-mode)
|
||||
(fuel-mode--key ?d ?p 'fuel-apropos)
|
||||
(fuel-mode--key ?d ?d 'fuel-help)
|
||||
(fuel-mode--key ?d ?e 'fuel-stack-effect-sexp)
|
||||
(fuel-mode--key ?d ?s 'fuel-help-short)
|
||||
|
|
|
|||
|
|
@ -301,21 +301,9 @@
|
|||
(funcall fuel-syntax--current-vocab-function))
|
||||
|
||||
(defun fuel-syntax--find-in ()
|
||||
(let* ((vocab)
|
||||
(ip
|
||||
(save-excursion
|
||||
(when (re-search-backward fuel-syntax--current-vocab-regex nil t)
|
||||
(setq vocab (match-string-no-properties 1))
|
||||
(point)))))
|
||||
(when ip
|
||||
(let ((pp (save-excursion
|
||||
(when (re-search-backward fuel-syntax--sub-vocab-regex ip t)
|
||||
(point)))))
|
||||
(when (and pp (> pp ip))
|
||||
(let ((sub (match-string-no-properties 1)))
|
||||
(unless (save-excursion (search-backward (format "%s>" sub) pp t))
|
||||
(setq vocab (format "%s.%s" vocab (downcase sub))))))))
|
||||
vocab))
|
||||
(match-string-no-properties 1))))
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-syntax--usings-function 'fuel-syntax--find-usings))
|
||||
|
|
@ -323,13 +311,19 @@
|
|||
(defsubst fuel-syntax--usings ()
|
||||
(funcall fuel-syntax--usings-function))
|
||||
|
||||
(defun fuel-syntax--find-usings ()
|
||||
(defun fuel-syntax--find-usings (&optional no-private)
|
||||
(save-excursion
|
||||
(let ((usings))
|
||||
(goto-char (point-max))
|
||||
(while (re-search-backward fuel-syntax--using-lines-regex nil t)
|
||||
(dolist (u (split-string (match-string-no-properties 1) nil t))
|
||||
(push u usings)))
|
||||
(goto-char (point-min))
|
||||
(when (and (not no-private)
|
||||
(re-search-forward "\\_<<PRIVATE\\_>" nil t)
|
||||
(re-search-forward "\\_<PRIVATE>\\_>" nil t))
|
||||
(goto-char (point-max))
|
||||
(push (concat (fuel-syntax--find-in) ".private") usings))
|
||||
usings)))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; fuel-xref.el -- showing cross-reference info
|
||||
|
||||
;; 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>
|
||||
|
|
@ -75,11 +75,10 @@ cursor at the first ocurrence of the used word."
|
|||
(defvar fuel-xref--help-string "(Press RET or click to follow crossrefs)")
|
||||
|
||||
(defun fuel-xref--title (word cc count)
|
||||
(let ((cc (if cc "using" "used by")))
|
||||
(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)))))
|
||||
(t (format "%s words %s %s:" count cc word))))
|
||||
|
||||
(defun fuel-xref--insert-ref (ref)
|
||||
(when (and (stringp (first ref))
|
||||
|
|
@ -124,12 +123,17 @@ cursor at the first ocurrence of the used word."
|
|||
(defun fuel-xref--show-callers (word)
|
||||
(let* ((cmd `(:fuel* (((:quote ,word) fuel-callers-xref))))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(fuel-xref--fill-and-display word t res)))
|
||||
(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))))
|
||||
(fuel-xref--fill-and-display word nil res)))
|
||||
(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))))
|
||||
(fuel-xref--fill-and-display str "containing" res)))
|
||||
|
||||
|
||||
;;; Xref mode:
|
||||
|
|
@ -138,7 +142,6 @@ cursor at the first ocurrence of the used word."
|
|||
(let ((map (make-sparse-keymap)))
|
||||
(suppress-keymap map)
|
||||
(set-keymap-parent map button-buffer-map)
|
||||
(define-key map "q" 'bury-buffer)
|
||||
map))
|
||||
|
||||
(defun fuel-xref-mode ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue