diff --git a/extra/L-system/L-system.factor b/extra/L-system/L-system.factor new file mode 100644 index 0000000000..97a971de47 --- /dev/null +++ b/extra/L-system/L-system.factor @@ -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: 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 ) 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: < 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 * ] | + + 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:: 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:: graft* ( L-SYSTEM -- ) + + L-SYSTEM find-gl-context + + 1 glGenLists L-SYSTEM (>>display-list) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M:: 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 ; + + +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 ) + + new-gadget + + turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/extra/L-system/models/abop-1/abop-1.factor b/extra/L-system/models/abop-1/abop-1.factor new file mode 100644 index 0000000000..45cc522470 --- /dev/null +++ b/extra/L-system/models/abop-1/abop-1.factor @@ -0,0 +1,29 @@ + +USING: accessors kernel ui L-system ; + +IN: L-system.models.abop-1 + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: abop-1 ( -- ) + + 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 diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 7f6af22df8..80d8cde654 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -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 diff --git a/misc/fuel/README b/misc/fuel/README index b670eef84d..6c03c7aa01 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -1,108 +1,115 @@ -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 "/misc/fuel/fu.el") -or + or (add-to-list load-path "/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 "/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 accept also C- (e.g. -C-cC-eC-r is the same as C-cC-er)). + (Triple chords ending in a single letter accept also C- (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 + - C-cz : switch to listener + - C-co : cycle between code, tests and docs factor files - - M-. : edit word at point in Emacs - - M-TAB : complete word at point - - C-cC-eu : update USING: line - - C-cC-ev : edit vocabulary (M-x fuel-edit-vocabulary) - - C-cC-ew : edit word (M-x fuel-edit-word-at-point) - - C-cC-ed : edit word's doc (M-x fuel-edit-word-at-point) + - M-. : edit word at point in Emacs + - M-TAB : complete word at point + - C-cC-eu : update USING: line + - C-cC-ev : edit vocabulary (M-x fuel-edit-vocabulary) + - C-cC-ew : edit word (M-x fuel-edit-word-at-point) + - C-cC-ed : edit word's doc (M-x fuel-edit-word-at-point) - - C-cr, C-cC-er : eval region - - C-M-r, C-cC-ee : eval region, extending it to definition boundaries - - C-M-x, C-cC-ex : eval definition around point - - C-ck, C-cC-ek : run file + - C-cr, C-cC-er : eval region + - C-M-r, C-cC-ee : eval region, extending it to definition boundaries + - C-M-x, C-cC-ex : eval definition around point + - C-ck, C-cC-ek : run file - - C-cC-da : toggle autodoc mode - - 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-da : toggle autodoc mode + - 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 + - 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-cs : toggle stack mode - - C-cv : edit vocabulary - - C-ch : help for word at point - - C-ck : run file + - 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 - - : invoke nth restart - - w/e/l : invoke :warnings, :errors, :linkage - - q : bury buffer + - g : go to error + - : 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 - - SPC/S-SPC : scroll up/down - - TAB/S-TAB : next/previous headline - - C-cz : switch to listener - - q : bury buffer + - 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 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 - - q : bury buffer + - TAB/BACKTAB : navigate links + - RET/mouse click : follow link + - q : bury buffer diff --git a/misc/fuel/fuel-autodoc.el b/misc/fuel/fuel-autodoc.el index a1c1d19b98..53b5228965 100644 --- a/misc/fuel/fuel-autodoc.el +++ b/misc/fuel/fuel-autodoc.el @@ -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 @@ -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")) diff --git a/misc/fuel/fuel-debug-uses.el b/misc/fuel/fuel-debug-uses.el index 127e11d23e..7b90093c21 100644 --- a/misc/fuel/fuel-debug-uses.el +++ b/misc/fuel/fuel-debug-uses.el @@ -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) - (insert "\nDone!") - (fuel-debug--uses-clean) - (bury-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) + (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))) @@ -210,11 +170,11 @@ (defconst fuel-debug--uses-header-regex (format "^%s.*$" (regexp-opt '("Infering USING: stanza for " - "Current USING: is already fine!" - "Current vocabulary list:" - "Correct vocabulary list:" - "Sorry, couldn't infer the vocabulary list." - "Done!")))) + "Current USING: is already fine!" + "Current vocabulary list:" + "Correct vocabulary list:" + "Sorry, couldn't infer the vocabulary list." + "Done!")))) (defconst fuel-debug--uses-prompt-regex (format "^%s" (regexp-opt '("Asking Factor. Please, wait ..." diff --git a/misc/fuel/fuel-debug.el b/misc/fuel/fuel-debug.el index f376bde1c9..4d84ad5141 100644 --- a/misc/fuel/fuel-debug.el +++ b/misc/fuel/fuel-debug.el @@ -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))))) diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index 1c37de7b18..d4ce88cf20 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -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 @@ -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 diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 9216a9fd02..12091ea399 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -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 @@ -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 - def - 'fuel-help--prompt-history - t) - def)) - (cmd `(:fuel* ((:quote ,def) ,(if see 'see 'help)) t))) - (message "Looking up '%s' ..." def) - (fuel-eval--send cmd `(lambda (r) (fuel-help--show-help-cont ,def r))))) + fuel-help-always-ask))) + (if ask (fuel-completion--read-word prompt + def + 'fuel-help--prompt-history + t) + def))) -(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)) - (message "No help for '%s'" def) - (fuel-help--insert-contents def out)))) +(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) + (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 (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)) diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index eb159eb56e..ecb47f68a2 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -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 @@ -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) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el new file mode 100644 index 0000000000..a2c94d4f4a --- /dev/null +++ b/misc/fuel/fuel-markup.el @@ -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 +;; 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 diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 1074f60f5f..df06584fab 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -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 @@ -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) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 8234f9fcc8..036ac7cbd0 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -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)) + (save-excursion + (when (re-search-backward fuel-syntax--current-vocab-regex nil t) + (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 "\\_<" nil t) + (re-search-forward "\\_\\_>" nil t)) + (goto-char (point-max)) + (push (concat (fuel-syntax--find-in) ".private") usings)) usings))) diff --git a/misc/fuel/fuel-xref.el b/misc/fuel/fuel-xref.el index be976a5392..31f8bcb69b 100644 --- a/misc/fuel/fuel-xref.el +++ b/misc/fuel/fuel-xref.el @@ -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 @@ -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))))) + (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)))) (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 ()