diff --git a/basis/calendar/format/format-tests.factor b/basis/calendar/format/format-tests.factor index 81930cdf49..f8864351a4 100644 --- a/basis/calendar/format/format-tests.factor +++ b/basis/calendar/format/format-tests.factor @@ -51,6 +51,11 @@ IN: calendar.format.tests timestamp>string ] unit-test +[ "20080504070000" ] [ + "Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp + timestamp>mdtm +] unit-test + [ T{ timestamp f 2008 @@ -74,3 +79,5 @@ IN: calendar.format.tests { gmt-offset T{ duration f 0 0 0 0 0 0 } } } ] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test + + diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index 15a4cb8266..916d3499fe 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -78,6 +78,9 @@ M: integer year. ( n -- ) M: timestamp year. ( timestamp -- ) year>> year. ; +: timestamp>mdtm ( timestamp -- str ) + [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ; + : (timestamp>string) ( timestamp -- ) { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ; diff --git a/basis/ftp/client/client.factor b/basis/ftp/client/client.factor index ac21bb8f78..14877110d3 100644 --- a/basis/ftp/client/client.factor +++ b/basis/ftp/client/client.factor @@ -93,7 +93,7 @@ ERROR: ftp-error got expected ; : ensure-login ( url -- url ) dup username>> [ "anonymous" >>username - "ftp-client" >>password + "ftp-client@factorcode.org" >>password ] unless ; : >ftp-url ( url -- url' ) >url ensure-port ensure-login ; diff --git a/basis/ftp/ftp.factor b/basis/ftp/ftp.factor index adf7d5b41b..eea98c0172 100644 --- a/basis/ftp/ftp.factor +++ b/basis/ftp/ftp.factor @@ -4,8 +4,7 @@ USING: accessors arrays assocs combinators io io.files kernel math.parser sequences strings ; IN: ftp -SINGLETON: active -SINGLETON: passive +SYMBOLS: +active+ +passive+ ; TUPLE: ftp-response n strings parsed ; @@ -17,5 +16,3 @@ TUPLE: ftp-response n strings parsed ; over strings>> push ; : ftp-send ( string -- ) write "\r\n" write flush ; -: ftp-ipv4 1 ; inline -: ftp-ipv6 2 ; inline diff --git a/basis/ftp/server/server-tests.factor b/basis/ftp/server/server-tests.factor new file mode 100644 index 0000000000..d7d9d8384d --- /dev/null +++ b/basis/ftp/server/server-tests.factor @@ -0,0 +1,50 @@ +USING: calendar ftp.server io.encodings.ascii io.files +io.files.unique namespaces threads tools.test kernel +io.servers.connection ftp.client accessors urls +io.pathnames io.directories sequences fry ; +IN: ftp.server.tests + +: test-file-contents ( -- string ) + "Files are so boring anymore." ; + +: create-test-file ( -- path ) + test-file-contents + "ftp.server" "test" make-unique-file + [ ascii set-file-contents ] keep canonicalize-path ; + +: test-ftp-server ( quot -- ) + '[ + current-temporary-directory get 0 + + [ start-server* ] + [ + sockets>> first addr>> port>> + + swap >>port + "ftp" >>protocol + "localhost" >>host + create-test-file >>path + _ call + ] + [ stop-server ] tri + ] with-unique-directory drop ; inline + +[ t ] +[ + + [ + unique-directory [ + [ ftp-get ] [ path>> file-name ascii file-contents ] bi + ] with-directory + ] test-ftp-server test-file-contents = +] unit-test + +[ + + [ + "/" >>path + unique-directory [ + [ ftp-get ] [ path>> file-name ascii file-contents ] bi + ] with-directory + ] test-ftp-server test-file-contents = +] must-fail diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index 20a753785c..8438aae94e 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -1,52 +1,46 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.short-circuit accessors combinators io -io.encodings.8-bit io.encodings io.encodings.binary -io.encodings.utf8 io.files io.files.info io.directories -io.sockets kernel math.parser namespaces make sequences -ftp io.launcher.unix.parser unicode.case splitting -assocs classes io.servers.connection destructors calendar -io.timeouts io.streams.duplex threads continuations math -concurrency.promises byte-arrays io.backend tools.hexdump -io.streams.string math.bitwise tools.files io.pathnames ; +USING: accessors assocs byte-arrays calendar classes +combinators combinators.short-circuit concurrency.promises +continuations destructors ftp io io.backend io.directories +io.encodings io.encodings.8-bit io.encodings.binary +tools.files io.encodings.utf8 io.files io.files.info +io.pathnames io.launcher.unix.parser io.servers.connection +io.sockets io.streams.duplex io.streams.string io.timeouts +kernel make math math.bitwise math.parser namespaces sequences +splitting threads unicode.case logging calendar.format +strings io.files.links io.files.types ; IN: ftp.server -TUPLE: ftp-client url mode state command-promise user password ; - -: ( url -- ftp-client ) - ftp-client new - swap >>url ; - +SYMBOL: server SYMBOL: client -: ftp-server-directory ( -- str ) - \ ftp-server-directory get-global "resource:temp" or - normalize-path ; +TUPLE: ftp-server < threaded-server { serving-directory string } ; + +TUPLE: ftp-client user password extra-connection ; TUPLE: ftp-command raw tokenized ; - -: ( -- obj ) - ftp-command new ; +: ( str -- obj ) + dup \ DEBUG log-message + ftp-command new + over >>raw + swap tokenize-command >>tokenized ; TUPLE: ftp-get path ; - : ( path -- obj ) ftp-get new swap >>path ; TUPLE: ftp-put path ; - : ( path -- obj ) ftp-put new swap >>path ; TUPLE: ftp-list ; - C: ftp-list -: read-command ( -- ftp-command ) - readln - [ >>raw ] [ tokenize-command >>tokenized ] bi ; +TUPLE: ftp-disconnect ; +C: ftp-disconnect : (send-response) ( n string separator -- ) [ number>string write ] 2dip write ftp-send ; @@ -56,28 +50,42 @@ C: ftp-list [ but-last-slice [ "-" (send-response) ] with each ] [ first " " (send-response) ] 2bi ; -: server-response ( n string -- ) +: server-response ( string n -- ) + 2dup number>string swap ":" glue \ server-response DEBUG log-message - swap add-response-line swap >>n + swap add-response-line send-response ; -: ftp-error ( string -- ) - 500 "Unrecognized command: " rot append server-response ; +: serving? ( path -- ? ) + canonicalize-path server get serving-directory>> head? ; + +: can-serve-directory? ( path -- ? ) + { [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ; + +: can-serve-file? ( path -- ? ) + { + [ exists? ] + [ file-info type>> +regular-file+ = ] + [ serving? ] + } 1&& ; + +: ftp-error ( string -- ) 500 server-response ; +: ftp-unimplemented ( string -- ) 502 server-response ; : send-banner ( -- ) - 220 "Welcome to " host-name append server-response ; + "Welcome to " host-name append 220 server-response ; : anonymous-only ( -- ) - 530 "This FTP server is anonymous only." server-response ; + "This FTP server is anonymous only." 530 server-response ; : handle-QUIT ( obj -- ) - drop 221 "Goodbye." server-response ; + drop "Goodbye." 221 server-response ; : handle-USER ( ftp-command -- ) [ tokenized>> second client get (>>user) - 331 "Please specify the password." server-response + "Please specify the password." 331 server-response ] [ 2drop "bad USER" ftp-error ] recover ; @@ -85,7 +93,7 @@ C: ftp-list : handle-PASS ( ftp-command -- ) [ tokenized>> second client get (>>password) - 230 "Login successful" server-response + "Login successful" 230 server-response ] [ 2drop "PASS error" ftp-error ] recover ; @@ -102,7 +110,7 @@ ERROR: type-error type ; : handle-TYPE ( obj -- ) [ tokenized>> second parse-type - [ 200 ] dip "Switching to " " mode" surround server-response + "Switching to " " mode" surround 200 server-response ] [ 2drop "TYPE is binary only" ftp-error ] recover ; @@ -115,65 +123,57 @@ ERROR: type-error type ; : handle-PWD ( obj -- ) drop - 257 current-directory get "\"" dup surround server-response ; + current-directory get "\"" dup surround 257 server-response ; : handle-SYST ( obj -- ) drop - 215 "UNIX Type: L8" server-response ; - -: if-command-promise ( quot -- ) - [ client get command-promise>> ] dip - [ "Establish an active or passive connection first" ftp-error ] if* ; - -: handle-STOR ( obj -- ) - [ - tokenized>> second - [ [ ] dip fulfill ] if-command-promise - ] [ - 2drop - ] recover ; - -! EPRT |2|::1|62138| -! : handle-EPRT ( obj -- ) - ! tokenized>> second "|" split harvest ; + "UNIX Type: L8" 215 server-response ; : start-directory ( -- ) - 150 "Here comes the directory listing." server-response ; + "Here comes the directory listing." 150 server-response ; + +: transfer-outgoing-file ( path -- ) + [ "Opening BINARY mode data connection for " ] dip + [ file-name ] [ + file-info size>> number>string + "(" " bytes)." surround + ] bi " " glue append 150 server-response ; + +: transfer-incoming-file ( path -- ) + "Opening BINARY mode data connection for " prepend + 150 server-response ; + +: finish-file-transfer ( -- ) + "File send OK." 226 server-response ; + +GENERIC: handle-passive-command ( stream obj -- ) + +: passive-loop ( server -- ) + [ + [ + |dispose + 30 seconds over set-timeout + accept drop &dispose + client get extra-connection>> + 30 seconds ?promise-timeout + handle-passive-command + ] + [ client get f >>extra-connection drop ] + [ drop ] cleanup + ] with-destructors ; : finish-directory ( -- ) - 226 "Directory send OK." server-response ; + "Directory send OK." 226 server-response ; -GENERIC: service-command ( stream obj -- ) - -M: ftp-list service-command ( stream obj -- ) +M: ftp-list handle-passive-command ( stream obj -- ) drop start-directory [ utf8 encode-output [ current-directory get directory. ] with-string-writer string-lines harvest [ ftp-send ] each - ] with-output-stream - finish-directory ; + ] with-output-stream finish-directory ; -: transfer-outgoing-file ( path -- ) - [ - 150 - "Opening BINARY mode data connection for " - ] dip - [ - file-name - ] [ - file-info size>> number>string - "(" " bytes)." surround - ] bi " " glue append server-response ; - -: transfer-incoming-file ( path -- ) - [ 150 ] dip "Opening BINARY mode data connection for " prepend - server-response ; - -: finish-file-transfer ( -- ) - 226 "File send OK." server-response ; - -M: ftp-get service-command ( stream obj -- ) +M: ftp-get handle-passive-command ( stream obj -- ) [ path>> [ transfer-outgoing-file ] @@ -183,7 +183,7 @@ M: ftp-get service-command ( stream obj -- ) 3drop "File transfer failed" ftp-error ] recover ; -M: ftp-put service-command ( stream obj -- ) +M: ftp-put handle-passive-command ( stream obj -- ) [ path>> [ transfer-incoming-file ] @@ -193,165 +193,165 @@ M: ftp-put service-command ( stream obj -- ) 3drop "File transfer failed" ftp-error ] recover ; -: passive-loop ( server -- ) - [ - [ - |dispose - 30 seconds over set-timeout - accept drop &dispose - client get command-promise>> - 30 seconds ?promise-timeout - service-command - ] - [ client get f >>command-promise drop ] - [ drop ] cleanup - ] with-destructors ; +M: ftp-disconnect handle-passive-command ( stream obj -- ) + drop dispose ; + +: fulfill-client ( obj -- ) + client get extra-connection>> [ + fulfill + ] [ + drop + "Establish an active or passive connection first" ftp-error + ] if* ; + +: handle-STOR ( obj -- ) + tokenized>> second + dup can-serve-file? [ + fulfill-client + ] [ + drop + fulfill-client + ] if ; : handle-LIST ( obj -- ) - drop - [ [ ] dip fulfill ] if-command-promise ; - -: handle-SIZE ( obj -- ) - [ - [ 213 ] dip - tokenized>> second file-info size>> - number>string server-response + drop current-directory get + can-serve-directory? [ + fulfill-client ] [ - 2drop - 550 "Could not get file size" server-response - ] recover ; + fulfill-client + ] if ; + +: not-a-plain-file ( path -- ) + ": not a plain file." append ftp-error ; : handle-RETR ( obj -- ) - [ tokenized>> second swap fulfill ] - curry if-command-promise ; + tokenized>> second + dup can-serve-file? [ + fulfill-client + ] [ + not-a-plain-file + fulfill-client + ] if ; + +: handle-SIZE ( obj -- ) + tokenized>> second + dup can-serve-file? [ + file-info size>> number>string 213 server-response + ] [ + not-a-plain-file + ] if ; : expect-connection ( -- port ) + client get (>>extra-connection) random-local-server - client get >>command-promise drop [ [ passive-loop ] curry in-thread ] [ addr>> port>> ] bi ; : handle-PASV ( obj -- ) - drop client get passive >>mode drop - 221 + drop expect-connection port>bytes [ number>string ] bi@ "," glue "Entering Passive Mode (127,0,0,1," ")" surround - server-response ; + 221 server-response ; : handle-EPSV ( obj -- ) drop - client get command-promise>> [ - "You already have a passive stream" ftp-error - ] [ - 229 - expect-connection number>string - "Entering Extended Passive Mode (|||" "|)" surround - server-response - ] if ; + client get f >>extra-connection drop + expect-connection number>string + "Entering Extended Passive Mode (|||" "|)" surround + 229 server-response ; -! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186 -! : handle-LPRT ( obj -- ) tokenized>> "," split ; - -ERROR: not-a-directory ; -ERROR: no-permissions ; - -: handle-CWD ( obj -- ) - [ - tokenized>> second dup normalize-path - dup ftp-server-directory head? [ - no-permissions - ] unless - - file-info directory? [ - set-current-directory - 250 "Directory successully changed." server-response +: handle-MDTM ( obj -- ) + tokenized>> 1 swap ?nth [ + dup file-info dup directory? [ + drop not-a-plain-file ] [ - not-a-directory + nip + modified>> timestamp>mdtm + 213 server-response ] if ] [ - 2drop - 550 "Failed to change directory." server-response - ] recover ; + "" not-a-plain-file + ] if* ; -: unrecognized-command ( obj -- ) raw>> ftp-error ; +ERROR: not-a-directory ; +ERROR: no-directory-permissions ; -: handle-client-loop ( -- ) - readln - USE: prettyprint global [ dup . flush ] bind - [ >>raw ] - [ tokenize-command >>tokenized ] bi +: directory-change-success ( -- ) + "Directory successully changed." 250 server-response ; + +: directory-change-failed ( -- ) + "Failed to change directory." 553 server-response ; + +: handle-CWD ( obj -- ) + tokenized>> 1 swap ?nth [ + dup can-serve-directory? [ + set-current-directory + directory-change-success + ] [ + drop + directory-change-failed + ] if + ] [ + directory-change-success + ] if* ; + +: unrecognized-command ( obj -- ) + raw>> "Unrecognized command: " prepend ftp-error ; + +: client-loop-dispatch ( str/f -- ? ) dup tokenized>> first >upper { + { "QUIT" [ handle-QUIT f ] } { "USER" [ handle-USER t ] } { "PASS" [ handle-PASS t ] } - { "ACCT" [ drop "ACCT unimplemented" ftp-error t ] } - { "CWD" [ handle-CWD t ] } - ! { "XCWD" [ ] } - ! { "CDUP" [ ] } - ! { "SMNT" [ ] } - - ! { "REIN" [ drop client get reset-ftp-client t ] } - { "QUIT" [ handle-QUIT f ] } - - ! { "PORT" [ ] } ! TODO - { "PASV" [ handle-PASV t ] } - ! { "MODE" [ ] } - { "TYPE" [ handle-TYPE t ] } - ! { "STRU" [ ] } - - ! { "ALLO" [ ] } - ! { "REST" [ ] } - { "STOR" [ handle-STOR t ] } - ! { "STOU" [ ] } - { "RETR" [ handle-RETR t ] } - { "LIST" [ handle-LIST t ] } - { "SIZE" [ handle-SIZE t ] } - ! { "NLST" [ ] } - ! { "APPE" [ ] } - ! { "RNFR" [ ] } - ! { "RNTO" [ ] } - ! { "DELE" [ handle-DELE t ] } - ! { "RMD" [ handle-RMD t ] } - ! ! { "XRMD" [ handle-XRMD t ] } - ! { "MKD" [ handle-MKD t ] } - { "PWD" [ handle-PWD t ] } - ! { "ABOR" [ ] } - { "SYST" [ handle-SYST t ] } - ! { "STAT" [ ] } - ! { "HELP" [ ] } - - ! { "SITE" [ ] } - ! { "NOOP" [ ] } - - ! { "EPRT" [ handle-EPRT ] } - ! { "LPRT" [ handle-LPRT ] } + { "ACCT" [ drop "ACCT unimplemented" ftp-unimplemented t ] } + { "PWD" [ handle-PWD t ] } + { "TYPE" [ handle-TYPE t ] } + { "CWD" [ handle-CWD t ] } + { "PASV" [ handle-PASV t ] } { "EPSV" [ handle-EPSV t ] } - ! { "LPSV" [ drop handle-LPSV t ] } + { "LIST" [ handle-LIST t ] } + { "STOR" [ handle-STOR t ] } + { "RETR" [ handle-RETR t ] } + { "SIZE" [ handle-SIZE t ] } + { "MDTM" [ handle-MDTM t ] } [ drop unrecognized-command t ] - } case [ handle-client-loop ] when ; + } case ; -TUPLE: ftp-server < threaded-server ; +: read-command ( -- ftp-command/f ) + readln [ f ] [ ] if-empty ; + +: handle-client-loop ( -- ) + read-command [ + client-loop-dispatch + [ handle-client-loop ] when + ] when* ; + +: serve-directory ( server -- ) + serving-directory>> [ + send-banner + handle-client-loop + ] with-directory ; M: ftp-server handle-client* ( server -- ) - drop [ - ftp-server-directory [ - host-name client set - send-banner handle-client-loop - ] with-directory + "New client" \ handle-client* DEBUG log-message + ftp-client new client set + [ server set ] [ serve-directory ] bi ] with-destructors ; -: ( port -- server ) +: ( directory port -- server ) ftp-server new-threaded-server swap >>insecure + swap canonicalize-path >>serving-directory "ftp.server" >>name 5 minutes >>timeout latin1 >>encoding ; -: ftpd ( port -- ) +: ftpd ( directory port -- ) start-server ; -: ftpd-main ( -- ) 2100 ftpd ; +: ftpd-main ( path -- ) 2100 ftpd ; MAIN: ftpd-main diff --git a/basis/images/images.factor b/basis/images/images.factor index c2dc33608e..5ac0da7a28 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -9,6 +9,24 @@ IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ; +: bytes-per-pixel ( component-order -- n ) + { + { BGR [ 3 ] } + { RGB [ 3 ] } + { BGRA [ 4 ] } + { RGBA [ 4 ] } + { ABGR [ 4 ] } + { ARGB [ 4 ] } + { RGBX [ 4 ] } + { XRGB [ 4 ] } + { BGRX [ 4 ] } + { XBGR [ 4 ] } + { R16G16B16 [ 6 ] } + { R32G32B32 [ 12 ] } + { R16G16B16A16 [ 8 ] } + { R32G32B32A32 [ 16 ] } + } case ; + TUPLE: image dim component-order bitmap ; : ( -- image ) image new ; inline @@ -63,4 +81,4 @@ M: image normalize-scan-line-order ; : normalize-image ( image -- image ) [ >byte-array ] change-bitmap normalize-component-order - normalize-scan-line-order ; + normalize-scan-line-order ; \ No newline at end of file diff --git a/basis/io/encodings/korean/korean-docs.factor b/basis/io/encodings/korean/korean-docs.factor new file mode 100644 index 0000000000..2500e794a7 --- /dev/null +++ b/basis/io/encodings/korean/korean-docs.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Yun, Jonghyouk. +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup ; +IN: io.encodings.korean + +ARTICLE: "io.encodings.korean" "Korean text encodings" +"The " { $vocab-link "io.encodings.korean" } " vocabulary implements encodings used for Korean text besides the standard UTF encodings for Unicode strings." +{ $subsection cp949 } ; + +ABOUT: "io.encodings.korean" + +HELP: cp949 +{ $class-description "This encoding class implements Microsoft's code page #949 encoding, also called Unified Hangul Code or ks_c_5601-1987, UHC. CP949 is extended version of EUC-KR and downward-compatibility to EUC-KR. " } +{ $see-also "encodings-introduction" } ; diff --git a/basis/io/encodings/korean/korean.factor b/basis/io/encodings/korean/korean.factor index cd98bb1eb0..a021cfce33 100644 --- a/basis/io/encodings/korean/korean.factor +++ b/basis/io/encodings/korean/korean.factor @@ -6,6 +6,8 @@ math.order math.parser memoize multiline sequences splitting values hashtables io.binary ; IN: io.encodings.korean +! TODO: migrate to common code-table parser (by Dan). + SINGLETON: cp949 cp949 "EUC-KR" register-encoding diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor index 5dddca4f9d..72401004ae 100644 --- a/basis/io/files/info/unix/linux/linux.factor +++ b/basis/io/files/info/unix/linux/linux.factor @@ -72,13 +72,14 @@ M: linux file-systems ] map ; : (find-mount-point) ( path mtab-paths -- mtab-entry ) - [ follow-links ] dip 2dup at* [ + 2dup at* [ 2nip ] [ drop [ parent-directory ] dip (find-mount-point) ] if ; : find-mount-point ( path -- mtab-entry ) + canonicalize-path parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ; ERROR: file-system-not-found ; diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor index 2f38c39e02..7d2a6ee4f3 100644 --- a/basis/io/files/links/unix/unix.factor +++ b/basis/io/files/links/unix/unix.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend io.files.links system unix ; +USING: io.backend io.files.links system unix io.pathnames kernel +io.files sequences ; IN: io.files.links.unix M: unix make-link ( path1 path2 -- ) @@ -8,3 +9,7 @@ M: unix make-link ( path1 path2 -- ) M: unix read-link ( path -- path' ) normalize-path read-symbolic-link ; + +M: unix canonicalize-path ( path -- path' ) + path-components "/" + [ append-path dup exists? [ follow-links ] when ] reduce ; diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index bc90915213..589a50d2eb 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -12,6 +12,7 @@ IN: io.servers.connection TUPLE: threaded-server name +log-level secure insecure secure-config sockets @@ -29,6 +30,7 @@ ready ; : new-threaded-server ( class -- threaded-server ) new "server" >>name + DEBUG >>log-level ascii >>encoding 1 minutes >>timeout V{ } clone >>sockets @@ -115,7 +117,7 @@ M: threaded-server handle-client* handler>> call ; : (start-server) ( threaded-server -- ) init-server dup threaded-server [ - dup name>> [ + [ ] [ name>> ] bi [ [ listen-on [ start-accept-loop ] parallel-each ] [ ready>> raise-flag ] bi diff --git a/basis/io/servers/packet/datagram.factor b/basis/io/servers/packet/packet.factor similarity index 83% rename from basis/io/servers/packet/datagram.factor rename to basis/io/servers/packet/packet.factor index c081dfb0fa..2a346b4d13 100644 --- a/basis/io/servers/packet/datagram.factor +++ b/basis/io/servers/packet/packet.factor @@ -1,4 +1,6 @@ -IN: io.servers.datagram +USING: concurrency.combinators destructors fry +io.sockets kernel logging ; +IN: io.servers.packet ( log-level log-level -- ? ) + [ log-levels at* [ undefined-log-level ] unless ] bi@ <=> ; + +: log? ( log-level -- ? ) + log-level get log-level<=> +lt+ = not ; : send-to-log-server ( array string -- ) prefix "log-server" get send ; SYMBOL: log-service +ERROR: bad-log-message-parameters msg word level ; + : check-log-message ( msg word level -- msg word level ) 3dup [ string? ] [ word? ] [ word? ] tri* and and - [ "Bad parameters to log-message" throw ] unless ; inline + [ bad-log-message-parameters ] unless ; inline : log-message ( msg word level -- ) check-log-message - log-service get dup [ + log-service get + 2dup [ log? ] [ ] bi* and [ [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip 4array "log-message" send-to-log-server ] [ @@ -36,7 +58,7 @@ SYMBOL: log-service { } "close-logs" send-to-log-server ; : with-logging ( service quot -- ) - log-service swap with-variable ; inline + [ log-service ] dip with-variable ; inline ! Aspect-oriented programming idioms diff --git a/basis/logging/parser/parser.factor b/basis/logging/parser/parser.factor index 07a84ec5c6..5406d8fcd0 100644 --- a/basis/logging/parser/parser.factor +++ b/basis/logging/parser/parser.factor @@ -3,7 +3,7 @@ USING: accessors peg peg.parsers memoize kernel sequences logging arrays words strings vectors io io.files io.encodings.utf8 namespaces make combinators logging.server -calendar calendar.format ; +calendar calendar.format assocs ; IN: logging.parser TUPLE: log-entry date level word-name message ; @@ -21,7 +21,7 @@ SYMBOL: multiline "[" "]" surrounded-by ; : 'log-level' ( -- parser ) - log-levels [ + log-levels keys [ [ name>> token ] keep [ nip ] curry action ] map choice ; diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 85b4d711ac..3a1ce18daa 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -252,10 +252,14 @@ M: real tanh ftanh ; : -i* ( x -- y ) >rect swap neg rect> ; -: asin ( x -- y ) +GENERIC: asin ( x -- y ) foldable + +M: number asin dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline -: acos ( x -- y ) +GENERIC: acos ( x -- y ) foldable + +M: number acos dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ; inline diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 5926f08d8c..db8abac441 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -56,7 +56,7 @@ ARTICLE: "inference-recursive" "Stack effects of recursive words" "When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect." $nl "Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":" -{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if" "[ foo ] infer." } +{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if ;" "[ foo ] infer." } "If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ; ARTICLE: "inference-recursive-combinators" "Recursive combinator inference" diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 7508c37cac..8d882099de 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -35,9 +35,10 @@ IN: tools.files PRIVATE> -SYMBOLS: file-name file-name/type permissions file-type nlinks file-size -file-date file-time file-datetime uid gid user group link-target unix-datetime -directory-or-size ; +SYMBOLS: +file-name+ +file-name/type+ +permissions+ +file-type+ ++nlinks+ +file-size+ +file-date+ +file-time+ +file-datetime+ ++uid+ +gid+ +user+ +group+ +link-target+ +unix-datetime+ ++directory-or-size+ ; TUPLE: listing-tool path specs sort ; @@ -48,10 +49,10 @@ C: file-listing : ( path -- listing-tool ) listing-tool new swap >>path - { file-name } >>specs ; + { +file-name+ } >>specs ; : list-slow? ( listing-tool -- ? ) - specs>> { file-name } sequence= not ; + specs>> { +file-name+ } sequence= not ; ERROR: unknown-file-spec symbol ; @@ -59,12 +60,12 @@ HOOK: file-spec>string os ( file-listing spec -- string ) M: object file-spec>string ( file-listing spec -- string ) { - { file-name [ directory-entry>> name>> ] } - { directory-or-size [ file-info>> dir-or-size ] } - { file-size [ file-info>> size>> number>string ] } - { file-date [ file-info>> modified>> listing-date ] } - { file-time [ file-info>> modified>> listing-time ] } - { file-datetime [ file-info>> modified>> timestamp>ymdhms ] } + { +file-name+ [ directory-entry>> name>> ] } + { +directory-or-size+ [ file-info>> dir-or-size ] } + { +file-size+ [ file-info>> size>> number>string ] } + { +file-date+ [ file-info>> modified>> listing-date ] } + { +file-time+ [ file-info>> modified>> listing-time ] } + { +file-datetime+ [ file-info>> modified>> timestamp>ymdhms ] } [ unknown-file-spec ] } case ; @@ -85,22 +86,22 @@ HOOK: (directory.) os ( path -- lines ) : directory. ( path -- ) (directory.) simple-table. ; -SYMBOLS: device-name mount-point type -available-space free-space used-space total-space -percent-used percent-free ; +SYMBOLS: +device-name+ +mount-point+ +type+ ++available-space+ +free-space+ +used-space+ +total-space+ ++percent-used+ +percent-free+ ; : percent ( real -- integer ) 100 * >integer ; inline : file-system-spec ( file-system-info obj -- str ) { - { device-name [ device-name>> "" or ] } - { mount-point [ mount-point>> "" or ] } - { type [ type>> "" or ] } - { available-space [ available-space>> 0 or ] } - { free-space [ free-space>> 0 or ] } - { used-space [ used-space>> 0 or ] } - { total-space [ total-space>> 0 or ] } - { percent-used [ + { +device-name+ [ device-name>> "" or ] } + { +mount-point+ [ mount-point>> "" or ] } + { +type+ [ type>> "" or ] } + { +available-space+ [ available-space>> 0 or ] } + { +free-space+ [ free-space>> 0 or ] } + { +used-space+ [ used-space>> 0 or ] } + { +total-space+ [ total-space>> 0 or ] } + { +percent-used+ [ [ used-space>> ] [ total-space>> ] bi [ 0 or ] bi@ dup 0 = [ 2drop 0 ] [ / percent ] if @@ -116,8 +117,8 @@ percent-used percent-free ; : file-systems. ( -- ) { - device-name available-space free-space used-space - total-space percent-used mount-point + +device-name+ +available-space+ +free-space+ +used-space+ + +total-space+ +percent-used+ +mount-point+ } print-file-systems ; { diff --git a/basis/tools/files/unix/unix.factor b/basis/tools/files/unix/unix.factor index e63ab09076..90e91529a1 100755 --- a/basis/tools/files/unix/unix.factor +++ b/basis/tools/files/unix/unix.factor @@ -47,21 +47,24 @@ IN: tools.files.unix M: unix (directory.) ( path -- lines ) - { permissions nlinks user group file-size file-date file-name } >>specs + { + +permissions+ +nlinks+ +user+ +group+ + +file-size+ +file-date+ +file-name+ + } >>specs { { directory-entry>> name>> <=> } } >>sort [ [ list-files ] with-group-cache ] with-user-cache ; M: unix file-spec>string ( file-listing spec -- string ) { - { file-name/type [ + { +file-name/type+ [ directory-entry>> [ name>> ] [ file-type>trailing ] bi append ] } - { permissions [ file-info>> permissions-string ] } - { nlinks [ file-info>> nlink>> number>string ] } - { user [ file-info>> uid>> user-name ] } - { group [ file-info>> gid>> group-name ] } - { uid [ file-info>> uid>> number>string ] } - { gid [ file-info>> gid>> number>string ] } + { +permissions+ [ file-info>> permissions-string ] } + { +nlinks+ [ file-info>> nlink>> number>string ] } + { +user+ [ file-info>> uid>> user-name ] } + { +group+ [ file-info>> gid>> group-name ] } + { +uid+ [ file-info>> uid>> number>string ] } + { +gid+ [ file-info>> gid>> number>string ] } [ call-next-method ] } case ; diff --git a/basis/tools/files/windows/windows.factor b/basis/tools/files/windows/windows.factor index f321c2fc7f..874b2ef5c1 100755 --- a/basis/tools/files/windows/windows.factor +++ b/basis/tools/files/windows/windows.factor @@ -9,7 +9,7 @@ IN: tools.files.windows M: windows (directory.) ( entries -- lines ) - { file-datetime directory-or-size file-name } >>specs + { +file-datetime+ +directory-or-size+ +file-name+ } >>specs { { directory-entry>> name>> <=> } } >>sort list-files ; diff --git a/core/io/pathnames/pathnames-docs.factor b/core/io/pathnames/pathnames-docs.factor index a4f261391a..f5ad6e533b 100644 --- a/core/io/pathnames/pathnames-docs.factor +++ b/core/io/pathnames/pathnames-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax io.backend io.files strings ; +USING: help.markup help.syntax io.backend io.files strings +sequences ; IN: io.pathnames HELP: path-separator? @@ -22,6 +23,10 @@ HELP: file-name { $example "USING: io.pathnames prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" } } ; +HELP: path-components +{ $values { "path" "a pathnames string" } { "seq" sequence } } +{ $description "Splits a pathname on the " { $link path-separator } " into its its component strings." } ; + HELP: append-path { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } { $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ; @@ -57,6 +62,10 @@ HELP: normalize-path { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } } { $description "Called by words such as " { $link } " and " { $link } " to prepare a pathname before passing it to underlying code." } ; +HELP: canonicalize-path +{ $values { "path" "a pathname string" } { "path'" "a new pathname string" } } +{ $description "Returns an canonical name for a path. The canonical name is an absolute path containing no symlinks." } ; + HELP: { $values { "string" "a pathname string" } { "pathname" pathname } } { $description "Creates a new " { $link pathname } "." } ; @@ -74,9 +83,12 @@ ARTICLE: "io.pathnames" "Pathname manipulation" { $subsection POSTPONE: P" } "Pathname manipulation:" { $subsection normalize-path } +{ $subsection canonicalize-path } { $subsection parent-directory } { $subsection file-name } { $subsection last-path-separator } +{ $subsection path-components } +{ $subsection prepend-path } { $subsection append-path } "Pathname presentations:" { $subsection pathname } diff --git a/core/io/pathnames/pathnames-tests.factor b/core/io/pathnames/pathnames-tests.factor index 41498fa15a..c3e419e60d 100644 --- a/core/io/pathnames/pathnames-tests.factor +++ b/core/io/pathnames/pathnames-tests.factor @@ -66,3 +66,7 @@ IN: io.pathnames.tests ] with-scope [ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test + +! Regression test for bug in file-extension +[ f ] [ "/funny.directory/file-with-no-extension" file-extension ] unit-test +[ "" ] [ "/funny.directory/file-with-no-extension." file-extension ] unit-test diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index 96ac872826..eba3e6a19f 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -119,7 +119,14 @@ PRIVATE> ] unless ; : file-extension ( filename -- extension ) - "." split1-last nip ; + file-name "." split1-last nip ; + +: path-components ( path -- seq ) + normalize-path path-separator split harvest ; + +HOOK: canonicalize-path os ( path -- path' ) + +M: object canonicalize-path normalize-path ; : resource-path ( path -- newpath ) "resource-path" get prepend-path ; diff --git a/extra/annotations/annotations-docs.factor b/extra/annotations/annotations-docs.factor index c340554119..bf8aef3a07 100644 --- a/extra/annotations/annotations-docs.factor +++ b/extra/annotations/annotations-docs.factor @@ -9,6 +9,22 @@ IN: annotations : comment-usage.-word ( base -- word ) "s." append "annotations" lookup ; PRIVATE> +: $annotation ( element -- ) + first + [ "!" " your comment here" surround 1array $syntax ] + [ [ "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 3array $description ] + [ ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 1array $unchecked-example ] + tri ; + +: $annotation-usage. ( element -- ) + first + [ "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 3array $description ; + +: $annotation-usage ( element -- ) + first + { "usages" sequence } $values + [ "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray ] bi 1array $description ; + "Code annotations" { "The " { $vocab-link "annotations" } " vocabulary provides syntax for comment-like annotations that can be looked up with Factor's " { $link usage } " mechanism." @@ -26,17 +42,9 @@ annotation-tags natural-sort annotation-tags [ { - [ [ \ $syntax ] dip "!" " your comment here" surround 2array ] - [ [ \ $description "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 4array ] - [ [ \ $unchecked-example ] dip ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 2array 3array ] - [ comment-word set-word-help ] - - [ [ \ $description "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 4array 1array ] - [ comment-usage.-word set-word-help ] - - [ [ { $values { "usages" sequence } } \ $description "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray 2array ] bi ] - [ comment-usage-word set-word-help ] - + [ [ \ $annotation swap 2array 1array ] [ comment-word set-word-help ] bi ] + [ [ \ $annotation-usage swap 2array 1array ] [ comment-usage-word set-word-help ] bi ] + [ [ \ $annotation-usage. swap 2array 1array ] [ comment-usage.-word set-word-help ] bi ] [ [ comment-word ] [ comment-usage-word ] [ comment-usage.-word ] tri 3array related-words ] } cleave ] each diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 2bf8f1b98d..403708e880 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -99,6 +99,8 @@ PRIVATE> : fuel-vocab-help ( name -- ) (fuel-vocab-help) fuel-eval-set-result ; +: fuel-word-synopsis ( word usings -- ) (fuel-word-synopsis) fuel-eval-set-result ; + : fuel-vocab-summary ( name -- ) (fuel-vocab-summary) fuel-eval-set-result ; diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index 55183734b3..bf637fd0b3 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -90,6 +90,12 @@ PRIVATE> : (fuel-word-help) ( name -- elem ) fuel-find-word [ [ auto-use? on (fuel-word-element) ] with-scope ] [ f ] if* ; +: (fuel-word-synopsis) ( word usings -- str/f ) + [ + [ vocab ] filter interactive-vocabs get append interactive-vocabs set + fuel-find-word [ synopsis ] when* + ] with-scope ; + : (fuel-word-see) ( word -- elem ) [ name>> \ article swap ] [ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor index da69c2ced3..a54bba1629 100644 --- a/extra/id3/id3-docs.factor +++ b/extra/id3/id3-docs.factor @@ -1,13 +1,19 @@ ! Copyright (C) 2008 Tim Wawrzynczak ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax sequences kernel ; +USING: help.markup help.syntax sequences kernel accessors ; IN: id3 HELP: file-id3-tags { $values { "path" "a path string" } { "object/f" "a tuple storing ID3 metadata or f" } } -{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present." } ; + { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Currently, the parser supports the following tags: " + $nl { $link title>> } + $nl { $link artist>> } + $nl { $link album>> } + $nl { $link year>> } + $nl { $link genre>> } + $nl { $link comment>> } } ; ARTICLE: "id3" "ID3 tags" "The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor index fdbaf69f03..bcdc312440 100644 --- a/extra/id3/id3-tests.factor +++ b/extra/id3/id3-tests.factor @@ -1,182 +1,35 @@ ! Copyright (C) 2009 Tim Wawrzynczak ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test id3 ; +USING: tools.test id3 id3.private ; IN: id3.tests -[ T{ mp3v2-file - { header T{ header f t 0 502 } } - { frames - { - T{ frame - { frame-id "COMM" } - { flags B{ 0 0 } } - { size 19 } - { data "eng, AG# 08E1C12E" } - } - T{ frame - { frame-id "TIT2" } - { flags B{ 0 0 } } - { size 15 } - { data "Stormy Weather" } - } - T{ frame - { frame-id "TRCK" } - { flags B{ 0 0 } } - { size 3 } - { data "32" } - } - T{ frame - { frame-id "TCON" } - { flags B{ 0 0 } } - { size 5 } - { data "(96)" } - } - T{ frame - { frame-id "TALB" } - { flags B{ 0 0 } } - { size 28 } - { data "Night and Day Frank Sinatra" } - } - T{ frame - { frame-id "PRIV" } - { flags B{ 0 0 } } - { size 39 } - { data "WM/MediaClassPrimaryID�}`�#��K�H�*(D" } - } - T{ frame - { frame-id "PRIV" } - { flags B{ 0 0 } } - { size 41 } - { data "WM/MediaClassSecondaryID" } - } - T{ frame - { frame-id "TPE1" } - { flags B{ 0 0 } } - { size 14 } - { data "Frank Sinatra" } - } - } - } -} -] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test +[ + T{ id3-info + { title "BLAH" } + { artist "ARTIST" } + { album "ALBUM" } + { year "2009" } + { comment "COMMENT" } + { genre "Bluegrass" } + } +] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test [ - T{ mp3v2-file - { header - T{ header { version t } { flags 0 } { size 1405 } } + T{ id3-info + { title "Anthem of the Trinity" } + { artist "Terry Riley" } + { album "Shri Camel" } + { genre "Classical" } } - { frames - { - T{ frame - { frame-id "TIT2" } - { flags B{ 0 0 } } - { size 22 } - { data "Anthem of the Trinity" } - } - T{ frame - { frame-id "TPE1" } - { flags B{ 0 0 } } - { size 12 } - { data "Terry Riley" } - } - T{ frame - { frame-id "TALB" } - { flags B{ 0 0 } } - { size 11 } - { data "Shri Camel" } - } - T{ frame - { frame-id "TCON" } - { flags B{ 0 0 } } - { size 10 } - { data "Classical" } - } - T{ frame - { frame-id "UFID" } - { flags B{ 0 0 } } - { size 23 } - { data "http://musicbrainz.org" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 23 } - { data "MusicBrainz Artist Id" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 22 } - { data "musicbrainz_artistid" } - } - T{ frame - { frame-id "TRCK" } - { flags B{ 0 0 } } - { size 2 } - { data "1" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 22 } - { data "MusicBrainz Album Id" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 21 } - { data "musicbrainz_albumid" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 29 } - { data "MusicBrainz Album Artist Id" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 27 } - { data "musicbrainz_albumartistid" } - } - T{ frame - { frame-id "TPOS" } - { flags B{ 0 0 } } - { size 2 } - { data "1" } - } - T{ frame - { frame-id "TSOP" } - { flags B{ 0 0 } } - { size 1 } - } - T{ frame - { frame-id "TMED" } - { flags B{ 0 0 } } - { size 4 } - { data "DIG" } - } - } - } -} ] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags ] unit-test [ - T{ mp3v1-file - { title - "BLAH" - } - { artist - "ARTIST" - } - { album - "ALBUM" - } - { year "2009" } - { comment - "COMMENT" - } - { genre 89 } - } -] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test + T{ id3-info + { title "Stormy Weather" } + { artist "Frank Sinatra" } + { album "Night and Day Frank Sinatra" } + { comment "eng, AG# 08E1C12E" } + { genre "Big Band" } + } +] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 5b0d3f373e..f2bbd08996 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -1,28 +1,159 @@ ! Copyright (C) 2009 Tim Wawrzynczak ! See http://factorcode.org/license.txt for BSD license. -USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays prettyprint io.encodings.string io.encodings.ascii ; +USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays io.encodings.string io.encodings.utf8 assocs math.parser ; IN: id3 + ( -- object ) mp3v1-file new ; +: ( -- object ) id3-info new ; -: ( header frames -- object ) mp3v2-file boa ; +: ( header frames -- object ) id3v2-info boa ; :
( -- object ) header new ; : ( -- object ) frame new ; - ] dip { - [ read-frame-id ascii decode >>frame-id ] + [ read-frame-id utf8 decode >>frame-id ] [ read-frame-flags >byte-array >>flags ] [ read-frame-size >28bitword >>size ] - [ read-frame-data ascii decode >>data ] + [ read-frame-data utf8 decode >>data ] } cleave ; : read-frame ( mmap -- frame/f ) @@ -98,9 +229,21 @@ TUPLE: mp3v1-file title artist album year comment genre ; : drop-header ( mmap -- seq1 seq2 ) dup 10 tail-slice swap ; -: read-v2-tag-data ( seq -- mp3v2-file ) - drop-header read-v2-header swap read-frames ; +: parse-frames ( id3v2-info -- id3-info ) + [ ] dip frames>> + { + [ [ frame-id>> "TIT2" = ] find nip [ data>> >>title ] when* ] + [ [ frame-id>> "TALB" = ] find nip [ data>> >>album ] when* ] + [ [ frame-id>> "TPE1" = ] find nip [ data>> >>artist ] when* ] + [ [ frame-id>> "TCON" = ] find nip [ data>> [ [ digit? ] filter string>number ] keep swap [ genres at nip ] when* + >>genre ] when* ] + [ [ frame-id>> "COMM" = ] find nip [ data>> >>comment ] when* ] + [ [ frame-id>> "TYER" = ] find nip [ data>> >>year ] when* ] + } cleave ; +: read-v2-tag-data ( seq -- id3-info ) + drop-header read-v2-header swap read-frames parse-frames ; + ! v1 information : skip-to-v1-data ( seq -- seq ) @@ -125,14 +268,14 @@ TUPLE: mp3v1-file title artist album year comment genre ; [ 124 ] dip nth ; : (read-v1-tag-data) ( seq -- mp3-file ) - [ ] dip + [ ] dip { - [ read-title ascii decode filter-text-data >>title ] - [ read-artist ascii decode filter-text-data >>artist ] - [ read-album ascii decode filter-text-data >>album ] - [ read-year ascii decode filter-text-data >>year ] - [ read-comment ascii decode filter-text-data >>comment ] - [ read-genre >fixnum >>genre ] + [ read-title utf8 decode filter-text-data >>title ] + [ read-artist utf8 decode filter-text-data >>artist ] + [ read-album utf8 decode filter-text-data >>album ] + [ read-year utf8 decode filter-text-data >>year ] + [ read-comment utf8 decode filter-text-data >>comment ] + [ read-genre >fixnum genres at >>genre ] } cleave ; : read-v1-tag-data ( seq -- mp3-file ) @@ -140,13 +283,13 @@ TUPLE: mp3v1-file title artist album year comment genre ; PRIVATE> -! main stuff +! public interface : file-id3-tags ( path -- object/f ) [ { - { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file ) - { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- mp3v1-file ) + { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- id3v2 ) + { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- id3-info ) [ drop f ] ! ( mmap -- f ) } cond ] with-mapped-uchar-file ; diff --git a/extra/literals/literals-docs.factor b/extra/literals/literals-docs.factor index ae25c75495..6525264f6a 100644 --- a/extra/literals/literals-docs.factor +++ b/extra/literals/literals-docs.factor @@ -1,19 +1,19 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax multiline ; +USING: help.markup help.syntax kernel multiline ; IN: literals HELP: $ { $syntax "$ word" } { $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." } -{ $notes "Since " { $snippet "word" } " is executed at parse time, " { $snippet "$" } " cannot be used with words defined in the same compilation unit." } +{ $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." } { $examples { $example <" USING: kernel literals prettyprint ; IN: scratchpad -<< : five 5 ; >> +CONSTANT: five 5 { $ five } . "> "{ 5 }" } @@ -30,7 +30,7 @@ IN: scratchpad HELP: $[ { $syntax "$[ code ]" } { $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." } -{ $notes "Since " { $snippet "code" } " is executed at parse time, it cannot reference any words defined in the same compilation unit." } +{ $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." } { $examples { $example <" diff --git a/extra/literals/literals-tests.factor b/extra/literals/literals-tests.factor index 34ea4d6415..0e933d5209 100644 --- a/extra/literals/literals-tests.factor +++ b/extra/literals/literals-tests.factor @@ -2,11 +2,12 @@ USING: kernel literals math tools.test ; IN: literals.tests << -: five 5 ; -: seven-eleven 7 11 ; : six-six-six 6 6 6 ; >> +: five 5 ; +: seven-eleven 7 11 ; + [ { 5 } ] [ { $ five } ] unit-test [ { 7 11 } ] [ { $ seven-eleven } ] unit-test [ { 6 6 6 } ] [ { $ six-six-six } ] unit-test diff --git a/extra/literals/literals.factor b/extra/literals/literals.factor index 6df51a35ef..d3cfcaae23 100644 --- a/extra/literals/literals.factor +++ b/extra/literals/literals.factor @@ -1,6 +1,6 @@ ! (c) Joe Groff, see license for details -USING: continuations kernel parser words quotations vectors ; +USING: accessors continuations kernel parser words quotations vectors ; IN: literals -: $ scan-word [ execute ] curry with-datastack >vector ; parsing +: $ scan-word [ def>> call ] curry with-datastack >vector ; parsing : $[ \ ] parse-until >quotation with-datastack >vector ; parsing diff --git a/extra/math/derivatives/authors.txt b/extra/math/derivatives/authors.txt new file mode 100644 index 0000000000..b6089d8622 --- /dev/null +++ b/extra/math/derivatives/authors.txt @@ -0,0 +1 @@ +Jason W. Merrill \ No newline at end of file diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor new file mode 100644 index 0000000000..4905f260bc --- /dev/null +++ b/extra/math/derivatives/derivatives-docs.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: math.derivatives + +ARTICLE: "math.derivatives" "Derivatives" +"The " { $vocab-link "math.derivatives" } " vocabulary defines the derivative of many of the words in the " { $vocab-link "math" } " and " { $vocab-link "math.functions" } " vocabularies. The derivative for a word is given by a sequence of quotations stored in its " { $snippet "derivative" } " word property that give the partial derivative of the word with respect to each of its inputs." +{ $see-also "math.derivatives.syntax" } +; + +ABOUT: "math.derivatives" diff --git a/extra/math/derivatives/derivatives-tests.factor b/extra/math/derivatives/derivatives-tests.factor new file mode 100644 index 0000000000..f95eb43849 --- /dev/null +++ b/extra/math/derivatives/derivatives-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test automatic-differentiation.derivatives ; +IN: automatic-differentiation.derivatives.tests diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor new file mode 100644 index 0000000000..c6a9d1a357 --- /dev/null +++ b/extra/math/derivatives/derivatives.factor @@ -0,0 +1,53 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions math.derivatives.syntax + math.order math.parser summary accessors make combinators ; +IN: math.derivatives + +ERROR: undefined-derivative point word ; +M: undefined-derivative summary + [ dup "Derivative of " % word>> name>> % + " is undefined at " % point>> # "." % ] + "" make ; + +DERIVATIVE: + [ 2drop ] [ 2drop ] +DERIVATIVE: - [ 2drop ] [ 2drop neg ] +DERIVATIVE: * [ nip * ] [ drop * ] +DERIVATIVE: / [ nip / ] [ sq / neg * ] +! Conditional checks if the epsilon-part of the exponent is +! 0 to avoid getting float answers for integer powers. +DERIVATIVE: ^ [ [ 1 - ^ ] keep * * ] + [ [ dup zero? ] 2dip [ 3drop 0 ] [ [ ^ ] keep log * * ] if ] + +DERIVATIVE: abs + [ 0 <=> + { + { +lt+ [ neg ] } + { +eq+ [ 0 \ abs undefined-derivative ] } + { +gt+ [ ] } + } case + ] + +DERIVATIVE: sqrt [ sqrt 2 * / ] + +DERIVATIVE: exp [ exp * ] +DERIVATIVE: log [ / ] + +DERIVATIVE: sin [ cos * ] +DERIVATIVE: cos [ sin neg * ] +DERIVATIVE: tan [ sec sq * ] + +DERIVATIVE: sinh [ cosh * ] +DERIVATIVE: cosh [ sinh * ] +DERIVATIVE: tanh [ sech sq * ] + +DERIVATIVE: asin [ sq neg 1 + sqrt / ] +DERIVATIVE: acos [ sq neg 1 + sqrt neg / ] +DERIVATIVE: atan [ sq 1 + / ] + +DERIVATIVE: asinh [ sq 1 + sqrt / ] +DERIVATIVE: acosh [ [ 1 + sqrt ] [ 1 - sqrt ] bi * / ] +DERIVATIVE: atanh [ sq neg 1 + / ] + +DERIVATIVE: neg [ drop neg ] +DERIVATIVE: recip [ sq recip neg * ] diff --git a/extra/math/derivatives/syntax/authors.txt b/extra/math/derivatives/syntax/authors.txt new file mode 100644 index 0000000000..b6089d8622 --- /dev/null +++ b/extra/math/derivatives/syntax/authors.txt @@ -0,0 +1 @@ +Jason W. Merrill \ No newline at end of file diff --git a/extra/math/derivatives/syntax/syntax-docs.factor b/extra/math/derivatives/syntax/syntax-docs.factor new file mode 100644 index 0000000000..2273e7b83c --- /dev/null +++ b/extra/math/derivatives/syntax/syntax-docs.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: math.derivatives.syntax + +HELP: DERIVATIVE: +{ $description "Defines the derivative of a word by setting its " { $snippet "derivative" } " word property. Reads a word followed by " { $snippet "n" } " quotations, giving the " { $snippet "n" } " partial derivatives of the word with respect to each of its arguments successively. Each quotation should take " { $snippet "n + 1" } " inputs, where the first input is an increment and the last " { $snippet "n" } " inputs are the point at which to evaluate the derivative. The derivative should be a linear function of the increment, and should have the same number of outputs as the original word." } +{ $examples + { $unchecked-example "USING: math math.functions math.derivatives.syntax ;" + "DERIVATIVE: sin [ cos * ]" + "DERIVATIVE: * [ nip * ] [ drop * ]" "" } +} ; + +ARTICLE: "math.derivatives.syntax" "Derivative Syntax" +"The " { $vocab-link "math.derivatives.syntax" } " vocabulary provides the " { $link POSTPONE: DERIVATIVE: } " syntax for specifying the derivative of a word." +; + +ABOUT: "math.derivatives.syntax" diff --git a/extra/math/derivatives/syntax/syntax.factor b/extra/math/derivatives/syntax/syntax.factor new file mode 100644 index 0000000000..02b0608ed8 --- /dev/null +++ b/extra/math/derivatives/syntax/syntax.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel parser words effects accessors sequences + math.ranges ; + +IN: math.derivatives.syntax + +: DERIVATIVE: scan-object dup stack-effect in>> length [1,b] + [ drop scan-object ] map + "derivative" set-word-prop ; parsing \ No newline at end of file diff --git a/extra/math/dual/authors.txt b/extra/math/dual/authors.txt new file mode 100644 index 0000000000..b6089d8622 --- /dev/null +++ b/extra/math/dual/authors.txt @@ -0,0 +1 @@ +Jason W. Merrill \ No newline at end of file diff --git a/extra/math/dual/dual-docs.factor b/extra/math/dual/dual-docs.factor new file mode 100644 index 0000000000..6c287a8f1e --- /dev/null +++ b/extra/math/dual/dual-docs.factor @@ -0,0 +1,132 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel words math math.functions math.derivatives.syntax ; +IN: math.dual + +HELP: +{ $values + { "ordinary-part" real } { "epsilon-part" real } + { "dual" dual number } +} +{ $description "Creates a dual number from its ordinary and epsilon parts." } ; + +HELP: d* +{ $values + { "x" dual } { "y" dual } + { "x*y" dual } +} +{ $description "Multiply dual numbers." } ; + +HELP: d+ +{ $values + { "x" dual } { "y" dual } + { "x+y" dual } +} +{ $description "Add dual numbers." } ; + +HELP: d- +{ $values + { "x" dual } { "y" dual } + { "x-y" dual } +} +{ $description "Subtract dual numbers." } ; + +HELP: d/ +{ $values + { "x" dual } { "y" dual } + { "x/y" dual } +} +{ $description "Divide dual numbers." } +{ $errors "Throws an error if the ordinary part of " { $snippet "x" } " is zero." } ; + +HELP: d^ +{ $values + { "x" dual } { "y" dual } + { "x^y" dual } +} +{ $description "Raise a dual number to a (possibly dual) power" } ; + +HELP: dabs +{ $values + { "x" dual } + { "|x|" dual } +} +{ $description "Absolute value of a dual number." } ; + +HELP: dacosh +{ $values + { "x" dual } + { "y" dual } +} +{ $description "Inverse hyberbolic cosine of a dual number." } ; + +HELP: dasinh +{ $values + { "x" dual } + { "y" dual } +} +{ $description "Inverse hyberbolic sine of a dual number." } ; + +HELP: datanh +{ $values + { "x" dual } + { "y" dual } +} +{ $description "Inverse hyberbolic tangent of a dual number." } ; + +HELP: dneg +{ $values + { "x" dual } + { "-x" dual } +} +{ $description "Negative of a dual number." } ; + +HELP: drecip +{ $values + { "x" dual } + { "1/x" dual } +} +{ $description "Reciprocal of a dual number." } ; + +HELP: define-dual-method +{ $values + { "word" word } +} +{ $description "Defines a method on the dual numbers for generic word." } +{ $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments. This can be set using " { $link POSTPONE: DERIVATIVE: } "." } ; + +{ define-dual-method dual-op POSTPONE: DERIVATIVE: } related-words + +HELP: dual +{ $class-description "The class of dual numbers with non-zero epsilon part." } ; + +HELP: dual-op +{ $values + { "word" word } +} +{ $description "Similar to " { $link execute } ", but promotes word to operate on duals." } +{ $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments. This can be set using " { $link POSTPONE: DERIVATIVE: } ". Once a derivative has been defined for a word, dual-op makes it easy to extend the definition to dual numbers." } +{ $examples + { $unchecked-example "USING: math math.dual math.derivatives.syntax math.functions ;" + "DERIVATIVE: sin [ cos * ]" + "M: dual sin \\sin dual-op ;" "" } + { $unchecked-example "USING: math math.dual math.derivatives.syntax ;" + "DERIVATIVE: * [ drop ] [ nip ]" + ": d* ( x y -- x*y ) \ * dual-op ;" "" } +} ; + +HELP: unpack-dual +{ $values + { "dual" dual } + { "ordinary-part" number } { "epsilon-part" number } +} +{ $description "Extracts the ordinary and epsilon part of a dual number." } ; + +ARTICLE: "math.dual" "Dual Numbers" +"The " { $vocab-link "math.dual" } " vocabulary implements dual numbers, along with arithmetic methods for working with them. Many of the functions in " { $vocab-link "math.functions" } " are extended to work with dual numbers." +$nl +"Dual numbers are ordered pairs " { $snippet ""} "--an ordinary part and an epsilon part--with component-wise addition and multiplication defined by "{ $snippet "* = " } ". They are analagous to complex numbers with " { $snippet "i^2 = 0" } "instead of " { $snippet "i^2 = -1" } ". For well-behaved functions " { $snippet "f" } ", " { $snippet "f() = f(o1) + e1*f'(o1)" } ", where " { $snippet "f'"} " is the derivative of " { $snippet "f" } "." +; + + +ABOUT: "math.dual" diff --git a/extra/math/dual/dual-tests.factor b/extra/math/dual/dual-tests.factor new file mode 100644 index 0000000000..ea46c46124 --- /dev/null +++ b/extra/math/dual/dual-tests.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test math.dual kernel accessors math math.functions + math.constants ; +IN: math.dual.tests + +[ 0.0 1.0 ] [ 0 1 sin unpack-dual ] unit-test +[ 1.0 0.0 ] [ 0 1 cos unpack-dual ] unit-test +[ 3 5 ] [ 1 5 2 d+ unpack-dual ] unit-test +[ 0 -1 ] [ 1 5 1 6 d- unpack-dual ] unit-test +[ 2 1 ] [ 2 3 1 -1 d* unpack-dual ] unit-test +[ 1/2 -1/4 ] [ 2 1 1 swap d/ unpack-dual ] unit-test +[ 2 ] [ 1 1 2 d^ epsilon-part>> ] unit-test +[ 2.0 .25 ] [ 4 1 sqrt unpack-dual ] unit-test +[ 2 -1 ] [ -2 1 dabs unpack-dual ] unit-test +[ -2 -1 ] [ 2 1 dneg unpack-dual ] unit-test \ No newline at end of file diff --git a/extra/math/dual/dual.factor b/extra/math/dual/dual.factor new file mode 100644 index 0000000000..36d684bc6d --- /dev/null +++ b/extra/math/dual/dual.factor @@ -0,0 +1,92 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions math.derivatives accessors + macros words effects sequences generalizations fry + combinators.smart generic compiler.units ; + +IN: math.dual + +TUPLE: dual ordinary-part epsilon-part ; + +C: dual + +! Ordinary numbers implement the dual protocol by returning +! themselves as the ordinary part, and 0 as the epsilon part. +M: number ordinary-part>> ; + +M: number epsilon-part>> drop 0 ; + +: unpack-dual ( dual -- ordinary-part epsilon-part ) + [ ordinary-part>> ] [ epsilon-part>> ] bi ; + +> length ; + +MACRO: ordinary-op ( word -- o ) + [ input-length ] keep + '[ [ ordinary-part>> ] _ napply _ execute ] ; + +! Takes N dual numbers ... and weaves +! their ordinary and epsilon parts to produce +! e1 o1 o2 ... oN e2 o1 o2 ... oN ... eN o1 o2 ... oN +! This allows a set of partial derivatives each to be evaluated +! at the same point. +MACRO: duals>nweave ( n -- ) + dup dup dup + '[ + [ [ epsilon-part>> ] _ napply ] + _ nkeep + [ ordinary-part>> ] _ napply + _ nweave + ] ; + +MACRO: chain-rule ( word -- e ) + [ input-length '[ _ duals>nweave ] ] + [ "derivative" word-prop ] + [ input-length 1+ '[ _ nspread ] ] + tri + '[ [ @ _ @ ] sum-outputs ] ; + +PRIVATE> + +MACRO: dual-op ( word -- ) + [ '[ _ ordinary-op ] ] + [ input-length '[ _ nkeep ] ] + [ '[ _ chain-rule ] ] + tri + '[ _ @ @ ] ; + +: define-dual-method ( word -- ) + [ \ dual swap create-method ] keep '[ _ dual-op ] define ; + +! Specialize math functions to operate on dual numbers. +[ { sqrt exp log sin cos tan sinh cosh tanh acos asin atan } + [ define-dual-method ] each ] with-compilation-unit + +! Inverse methods { asinh, acosh, atanh } are not generic, so +! there is no way to specialize them for dual numbers. However, +! they are defined in terms of functions that can operate on +! dual numbers and arithmetic methods, so if it becomes +! possible to make arithmetic operators work directly on dual +! numbers, we will get these for free. + +! Arithmetic words are not generic (yet?), so we have to +! define special versions of them to operate on dual numbers. +: d+ ( x y -- x+y ) \ + dual-op ; +: d- ( x y -- x-y ) \ - dual-op ; +: d* ( x y -- x*y ) \ * dual-op ; +: d/ ( x y -- x/y ) \ / dual-op ; +: d^ ( x y -- x^y ) \ ^ dual-op ; + +: dabs ( x -- |x| ) \ abs dual-op ; + +! The following words are also not generic, but are defined in +! terms of words that can operate on dual numbers and +! arithmetic. If it becomes possible to implement arithmetic on +! dual numbers directly, these functions can be deleted. +: dneg ( x -- -x ) \ neg dual-op ; +: drecip ( x -- 1/x ) \ recip dual-op ; +: dasinh ( x -- y ) \ asinh dual-op ; +: dacosh ( x -- y ) \ acosh dual-op ; +: datanh ( x -- y ) \ atanh dual-op ; \ No newline at end of file diff --git a/misc/fuel/README b/misc/fuel/README index d712560b03..79b8f49f9a 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -111,6 +111,7 @@ beast. | C-cC-ev | edit vocabulary (fuel-edit-vocabulary) | | C-cC-ew | edit word (fuel-edit-word-at-point) | | C-cC-ed | edit word's doc (C-u M-x fuel-edit-word-doc-at-point) | + | C-cC-el | load vocabs in USING: form | |-----------------+------------------------------------------------------------| | C-cC-er | eval region | | C-M-r, C-cC-ee | eval region, extending it to definition boundaries | diff --git a/misc/fuel/fuel-autodoc.el b/misc/fuel/fuel-autodoc.el index 76919702bb..d02e4fcfb9 100644 --- a/misc/fuel/fuel-autodoc.el +++ b/misc/fuel/fuel-autodoc.el @@ -32,6 +32,22 @@ :type 'boolean) +(defcustom fuel-autodoc-eval-using-form-p nil + "When enabled, automatically load vocabularies in USING: form +to display autodoc messages. + +In order to show autodoc messages for words in a Factor buffer, +the used vocabularies must be loaded in the Factor image. Setting +this variable to `t' will do that automatically for you, +asynchronously. That means that you'll be able to move around +while the vocabs are being loaded, but no other FUEL +functionality will be available until loading finishes (and it +may take a while). Thus, this functionality is disabled by +default. You can force loading the vocabs in a Factor buffer +USING: form with \\[fuel-load-usings]." + :group 'fuel-autodoc + :type 'boolean) + ;;; Eldoc function: @@ -41,9 +57,10 @@ (let ((word (or word (fuel-syntax-symbol-at-point))) (fuel-log--inhibit-p t)) (when word - (let* ((cmd (if (fuel-syntax--in-using) + (let* ((usings (if fuel-autodoc-eval-using-form-p :usings t)) + (cmd (if (fuel-syntax--in-using) `(:fuel* (,word fuel-vocab-summary) :in t) - `(:fuel* (((:quote ,word) synopsis :get)) :in))) + `(:fuel* ((,word :usings fuel-word-synopsis)) t ,usings))) (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)) diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el index 9e8210a3e3..985722854f 100644 --- a/misc/fuel/fuel-eval.el +++ b/misc/fuel/fuel-eval.el @@ -77,7 +77,7 @@ (t (error "Invalid 'in' (%s)" in)))) (defsubst factor--fuel-usings (usings) - (cond ((null usings) :usings) + (cond ((or (null usings) (eq usings :usings)) :usings) ((eq usings t) nil) ((listp usings) `(:array ,@usings)) (t (error "Invalid 'usings' (%s)" usings)))) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 504308fccd..c4f08f3c62 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -132,6 +132,18 @@ With prefix argument, ask for the file name." (let ((file (car (fuel-mode--read-file arg)))) (when file (fuel-debug--uses-for-file file)))) +(defun fuel-load-usings () + "Loads all vocabularies in the current buffer's USING: from. +Useful to activate autodoc help messages in a vocabulary not yet +loaded. See documentation for `fuel-autodoc-eval-using-form-p' +for details." + (interactive) + (message "Loading all vocabularies in USING: form ...") + (let ((err (fuel-eval--retort-error + (fuel-eval--send/wait '(:fuel* (t) t :usings) 120000)))) + (message (if err "Warning: some vocabularies failed to load" + "All vocabularies loaded")))) + ;;; Minor mode definition: @@ -191,7 +203,8 @@ interacting with a factor listener is at your disposal. (fuel-mode--key ?e ?d 'fuel-edit-word-doc-at-point) (fuel-mode--key ?e ?e 'fuel-eval-extended-region) -(fuel-mode--key ?e ?l 'fuel-run-file) +(fuel-mode--key ?e ?k 'fuel-run-file) +(fuel-mode--key ?e ?l 'fuel-load-usings) (fuel-mode--key ?e ?r 'fuel-eval-region) (fuel-mode--key ?e ?u 'fuel-update-usings) (fuel-mode--key ?e ?v 'fuel-edit-vocabulary)