Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
b75e6ff445
|
|
@ -23,5 +23,8 @@ IN: base64.tests
|
|||
ascii encode >base64-lines >string
|
||||
] unit-test
|
||||
|
||||
[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
|
||||
[ malformed-base64? ] must-fail-with
|
||||
|
||||
\ >base64 must-infer
|
||||
\ base64> must-infer
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@ io.streams.byte-array kernel math namespaces
|
|||
sequences strings io.crlf ;
|
||||
IN: base64
|
||||
|
||||
ERROR: malformed-base64 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: read1-ignoring ( ignoring -- ch )
|
||||
|
|
@ -25,7 +27,7 @@ IN: base64
|
|||
f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
|
||||
22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
|
||||
40 41 42 43 44 45 46 47 48 49 50 51
|
||||
} nth ; inline
|
||||
} nth [ malformed-base64 ] unless* ; inline
|
||||
|
||||
SYMBOL: column
|
||||
|
||||
|
|
@ -48,8 +50,6 @@ SYMBOL: column
|
|||
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
|
||||
[ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
|
||||
|
||||
ERROR: malformed-base64 ;
|
||||
|
||||
: decode4 ( seq -- )
|
||||
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
|
||||
[ [ CHAR: = = ] count ] bi head-slice*
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: accessors kernel math namespaces make sequences random
|
|||
strings math.parser math.intervals combinators math.bitwise
|
||||
nmake db db.tuples db.types classes words shuffle arrays
|
||||
destructors continuations db.tuples.private prettyprint
|
||||
db.private ;
|
||||
db.private byte-arrays ;
|
||||
IN: db.queries
|
||||
|
||||
GENERIC: where ( specs obj -- )
|
||||
|
|
@ -115,6 +115,9 @@ M: sequence where ( spec obj -- )
|
|||
[ " or " 0% ] [ dupd where ] interleave drop
|
||||
] in-parens ;
|
||||
|
||||
M: byte-array where ( spec obj -- )
|
||||
over column-name>> 0% " = " 0% bind# ;
|
||||
|
||||
M: NULL where ( spec obj -- )
|
||||
drop column-name>> 0% " is NULL" 0% ;
|
||||
|
||||
|
|
|
|||
|
|
@ -634,3 +634,22 @@ compound-foo "COMPOUND_FOO"
|
|||
|
||||
[ test-compound-primary-key ] test-sqlite
|
||||
[ test-compound-primary-key ] test-postgresql
|
||||
|
||||
|
||||
TUPLE: example id data ;
|
||||
|
||||
example "EXAMPLE"
|
||||
{
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
{ "data" "DATA" BLOB }
|
||||
} define-persistent
|
||||
|
||||
: test-blob-select ( -- )
|
||||
example ensure-table
|
||||
[ ] [ example new B{ 1 2 3 4 5 } >>data insert-tuple ] unit-test
|
||||
[
|
||||
T{ example { id 1 } { data B{ 1 2 3 4 5 } } }
|
||||
] [ example new B{ 1 2 3 4 5 } >>data select-tuple ] unit-test ;
|
||||
|
||||
[ test-blob-select ] test-sqlite
|
||||
[ test-blob-select ] test-postgresql
|
||||
|
|
|
|||
|
|
@ -16,10 +16,11 @@ IN: tools.hexdump
|
|||
16 * >hex 8 CHAR: 0 pad-head write "h: " write ;
|
||||
|
||||
: >hex-digit ( digit -- str )
|
||||
>hex 2 CHAR: 0 pad-head " " append ;
|
||||
>hex 2 CHAR: 0 pad-head ;
|
||||
|
||||
: >hex-digits ( bytes -- str )
|
||||
[ >hex-digit ] { } map-as concat 48 CHAR: \s pad-tail ;
|
||||
[ >hex-digit " " append ] { } map-as concat
|
||||
48 CHAR: \s pad-tail ;
|
||||
|
||||
: >ascii ( bytes -- str )
|
||||
[ [ printable? ] keep CHAR: . ? ] "" map-as ;
|
||||
|
|
|
|||
|
|
@ -224,6 +224,10 @@ M: x-clipboard paste-clipboard
|
|||
[ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
|
||||
utf8 encode dup length XChangeProperty drop ;
|
||||
|
||||
: set-class ( dpy window -- )
|
||||
XA_WM_CLASS XA_STRING 8 PropModeReplace "Factor"
|
||||
utf8 encode dup length XChangeProperty drop ;
|
||||
|
||||
M: x11-ui-backend set-title ( string world -- )
|
||||
handle>> window>> swap
|
||||
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
|
||||
|
|
@ -242,11 +246,15 @@ M: x11-ui-backend set-fullscreen* ( ? world -- )
|
|||
|
||||
M: x11-ui-backend (open-window) ( world -- )
|
||||
dup gadget-window
|
||||
handle>> window>> dup set-closable map-window ;
|
||||
handle>> window>>
|
||||
[ set-closable ] [ dpy get swap set-class ] [ map-window ] tri ;
|
||||
|
||||
M: x11-ui-backend raise-window* ( world -- )
|
||||
handle>> [
|
||||
dpy get swap window>> XRaiseWindow drop
|
||||
dpy get swap window>>
|
||||
[ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
|
||||
[ XRaiseWindow drop ]
|
||||
2bi
|
||||
] when* ;
|
||||
|
||||
M: x11-handle select-gl-context ( handle -- )
|
||||
|
|
|
|||
|
|
@ -12,10 +12,7 @@ IN: ui
|
|||
! Assoc mapping aliens to gadgets
|
||||
SYMBOL: windows
|
||||
|
||||
ERROR: no-window handle ;
|
||||
|
||||
: window ( handle -- world )
|
||||
windows get-global ?at [ no-window ] unless ;
|
||||
: window ( handle -- world ) windows get-global at ;
|
||||
|
||||
: window-focus ( handle -- gadget ) window world-focus ;
|
||||
|
||||
|
|
@ -199,4 +196,4 @@ M: object close-window
|
|||
: with-ui ( quot -- )
|
||||
ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;
|
||||
|
||||
HOOK: beep ui-backend ( -- )
|
||||
HOOK: beep ui-backend ( -- )
|
||||
|
|
|
|||
|
|
@ -6,10 +6,10 @@ arrays fry ;
|
|||
IN: x11.windows
|
||||
|
||||
: create-window-mask ( -- n )
|
||||
{ CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ;
|
||||
{ CWColormap CWEventMask } flags ;
|
||||
|
||||
: create-colormap ( visinfo -- colormap )
|
||||
dpy get root get rot XVisualInfo-visual AllocNone
|
||||
[ dpy get root get ] dip XVisualInfo-visual AllocNone
|
||||
XCreateColormap ;
|
||||
|
||||
: event-mask ( -- n )
|
||||
|
|
@ -29,8 +29,6 @@ IN: x11.windows
|
|||
|
||||
: window-attributes ( visinfo -- attributes )
|
||||
"XSetWindowAttributes" <c-object>
|
||||
0 over set-XSetWindowAttributes-background_pixel
|
||||
0 over set-XSetWindowAttributes-border_pixel
|
||||
[ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep
|
||||
event-mask over set-XSetWindowAttributes-event_mask ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: html.parser.state io io.encodings.utf8 io.files
|
||||
USING: sequence-parser io io.encodings.utf8 io.files
|
||||
io.streams.string kernel combinators accessors io.pathnames
|
||||
fry sequences arrays locals namespaces io.directories
|
||||
assocs math splitting make unicode.categories
|
||||
|
|
@ -41,7 +41,7 @@ ifs elifs elses ;
|
|||
|
||||
DEFER: preprocess-file
|
||||
|
||||
ERROR: unknown-c-preprocessor state-parser name ;
|
||||
ERROR: unknown-c-preprocessor sequence-parser name ;
|
||||
|
||||
ERROR: bad-include-line line ;
|
||||
|
||||
|
|
@ -69,8 +69,16 @@ ERROR: header-file-missing path ;
|
|||
drop
|
||||
] if ;
|
||||
|
||||
: handle-include ( preprocessor-state state-parser -- )
|
||||
skip-whitespace advance dup previous {
|
||||
: skip-whitespace/comments ( sequence-parser -- sequence-parser )
|
||||
skip-whitespace
|
||||
{
|
||||
{ [ dup take-c-comment ] [ skip-whitespace/comments ] }
|
||||
{ [ dup take-c++-comment ] [ skip-whitespace/comments ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
|
||||
: handle-include ( preprocessor-state sequence-parser -- )
|
||||
skip-whitespace/comments advance dup previous {
|
||||
{ CHAR: < [ CHAR: > take-until-object read-standard-include ] }
|
||||
{ CHAR: " [ CHAR: " take-until-object read-local-include ] }
|
||||
[ bad-include-line ]
|
||||
|
|
@ -81,58 +89,58 @@ ERROR: header-file-missing path ;
|
|||
|
||||
: readlns ( -- string ) [ (readlns) ] { } make concat ;
|
||||
|
||||
: take-define-identifier ( state-parser -- string )
|
||||
skip-whitespace
|
||||
: take-define-identifier ( sequence-parser -- string )
|
||||
skip-whitespace/comments
|
||||
[ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
|
||||
|
||||
: handle-define ( preprocessor-state state-parser -- )
|
||||
: handle-define ( preprocessor-state sequence-parser -- )
|
||||
[ take-define-identifier ]
|
||||
[ skip-whitespace take-rest ] bi
|
||||
[ skip-whitespace/comments take-rest ] bi
|
||||
"\\" ?tail [ readlns append ] when
|
||||
spin symbol-table>> set-at ;
|
||||
|
||||
: handle-undef ( preprocessor-state state-parser -- )
|
||||
: handle-undef ( preprocessor-state sequence-parser -- )
|
||||
take-token swap symbol-table>> delete-at ;
|
||||
|
||||
: handle-ifdef ( preprocessor-state state-parser -- )
|
||||
: handle-ifdef ( preprocessor-state sequence-parser -- )
|
||||
[ [ 1 + ] change-ifdef-nesting ] dip
|
||||
take-token over symbol-table>> key?
|
||||
[ drop ] [ t >>processing-disabled? drop ] if ;
|
||||
|
||||
: handle-ifndef ( preprocessor-state state-parser -- )
|
||||
: handle-ifndef ( preprocessor-state sequence-parser -- )
|
||||
[ [ 1 + ] change-ifdef-nesting ] dip
|
||||
take-token over symbol-table>> key?
|
||||
[ t >>processing-disabled? drop ]
|
||||
[ drop ] if ;
|
||||
|
||||
: handle-endif ( preprocessor-state state-parser -- )
|
||||
: handle-endif ( preprocessor-state sequence-parser -- )
|
||||
drop [ 1 - ] change-ifdef-nesting drop ;
|
||||
|
||||
: handle-if ( preprocessor-state state-parser -- )
|
||||
: handle-if ( preprocessor-state sequence-parser -- )
|
||||
[ [ 1 + ] change-ifdef-nesting ] dip
|
||||
skip-whitespace take-rest swap ifs>> push ;
|
||||
skip-whitespace/comments take-rest swap ifs>> push ;
|
||||
|
||||
: handle-elif ( preprocessor-state state-parser -- )
|
||||
skip-whitespace take-rest swap elifs>> push ;
|
||||
: handle-elif ( preprocessor-state sequence-parser -- )
|
||||
skip-whitespace/comments take-rest swap elifs>> push ;
|
||||
|
||||
: handle-else ( preprocessor-state state-parser -- )
|
||||
skip-whitespace take-rest swap elses>> push ;
|
||||
: handle-else ( preprocessor-state sequence-parser -- )
|
||||
skip-whitespace/comments take-rest swap elses>> push ;
|
||||
|
||||
: handle-pragma ( preprocessor-state state-parser -- )
|
||||
skip-whitespace take-rest swap pragmas>> push ;
|
||||
: handle-pragma ( preprocessor-state sequence-parser -- )
|
||||
skip-whitespace/comments take-rest swap pragmas>> push ;
|
||||
|
||||
: handle-include-next ( preprocessor-state state-parser -- )
|
||||
skip-whitespace take-rest swap include-nexts>> push ;
|
||||
: handle-include-next ( preprocessor-state sequence-parser -- )
|
||||
skip-whitespace/comments take-rest swap include-nexts>> push ;
|
||||
|
||||
: handle-error ( preprocessor-state state-parser -- )
|
||||
skip-whitespace take-rest swap errors>> push ;
|
||||
: handle-error ( preprocessor-state sequence-parser -- )
|
||||
skip-whitespace/comments take-rest swap errors>> push ;
|
||||
! nip take-rest throw ;
|
||||
|
||||
: handle-warning ( preprocessor-state state-parser -- )
|
||||
skip-whitespace
|
||||
: handle-warning ( preprocessor-state sequence-parser -- )
|
||||
skip-whitespace/comments
|
||||
take-rest swap warnings>> push ;
|
||||
|
||||
: parse-directive ( preprocessor-state state-parser string -- )
|
||||
: parse-directive ( preprocessor-state sequence-parser string -- )
|
||||
{
|
||||
{ "warning" [ handle-warning ] }
|
||||
{ "error" [ handle-error ] }
|
||||
|
|
@ -150,7 +158,7 @@ ERROR: header-file-missing path ;
|
|||
[ unknown-c-preprocessor ]
|
||||
} case ;
|
||||
|
||||
: parse-directive-line ( preprocessor-state state-parser -- )
|
||||
: parse-directive-line ( preprocessor-state sequence-parser -- )
|
||||
advance dup take-token
|
||||
pick processing-disabled?>> [
|
||||
"endif" = [
|
||||
|
|
@ -162,14 +170,14 @@ ERROR: header-file-missing path ;
|
|||
parse-directive
|
||||
] if ;
|
||||
|
||||
: preprocess-line ( preprocessor-state state-parser -- )
|
||||
skip-whitespace dup current CHAR: # =
|
||||
: preprocess-line ( preprocessor-state sequence-parser -- )
|
||||
skip-whitespace/comments dup current CHAR: # =
|
||||
[ parse-directive-line ]
|
||||
[ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
|
||||
|
||||
: preprocess-lines ( preprocessor-state -- )
|
||||
readln
|
||||
[ <state-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
|
||||
[ <sequence-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
|
||||
[ drop ] if* ;
|
||||
|
||||
ERROR: include-nested-too-deeply ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays hashtables html.parser.state
|
||||
USING: accessors arrays hashtables sequence-parser
|
||||
html.parser.utils kernel namespaces sequences
|
||||
unicode.case unicode.categories combinators.short-circuit
|
||||
quoting fry ;
|
||||
|
|
@ -37,89 +37,89 @@ SYMBOL: tagstack
|
|||
swap >>name
|
||||
swap >>text ; inline
|
||||
|
||||
: (read-quote) ( state-parser ch -- string )
|
||||
: (read-quote) ( sequence-parser ch -- string )
|
||||
'[ [ current _ = ] take-until ] [ advance drop ] bi ;
|
||||
|
||||
: read-single-quote ( state-parser -- string )
|
||||
: read-single-quote ( sequence-parser -- string )
|
||||
CHAR: ' (read-quote) ;
|
||||
|
||||
: read-double-quote ( state-parser -- string )
|
||||
: read-double-quote ( sequence-parser -- string )
|
||||
CHAR: " (read-quote) ;
|
||||
|
||||
: read-quote ( state-parser -- string )
|
||||
: read-quote ( sequence-parser -- string )
|
||||
dup get+increment CHAR: ' =
|
||||
[ read-single-quote ] [ read-double-quote ] if ;
|
||||
|
||||
: read-key ( state-parser -- string )
|
||||
: read-key ( sequence-parser -- string )
|
||||
skip-whitespace
|
||||
[ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
|
||||
|
||||
: read-token ( state-parser -- string )
|
||||
: read-token ( sequence-parser -- string )
|
||||
[ current blank? ] take-until ;
|
||||
|
||||
: read-value ( state-parser -- string )
|
||||
: read-value ( sequence-parser -- string )
|
||||
skip-whitespace
|
||||
dup current quote? [ read-quote ] [ read-token ] if
|
||||
[ blank? ] trim ;
|
||||
|
||||
: read-comment ( state-parser -- )
|
||||
: read-comment ( sequence-parser -- )
|
||||
"-->" take-until-sequence comment new-tag push-tag ;
|
||||
|
||||
: read-dtd ( state-parser -- )
|
||||
: read-dtd ( sequence-parser -- )
|
||||
">" take-until-sequence dtd new-tag push-tag ;
|
||||
|
||||
: read-bang ( state-parser -- )
|
||||
: read-bang ( sequence-parser -- )
|
||||
advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
|
||||
[ advance advance read-comment ] [ read-dtd ] if ;
|
||||
|
||||
: read-tag ( state-parser -- string )
|
||||
: read-tag ( sequence-parser -- string )
|
||||
[ [ current "><" member? ] take-until ]
|
||||
[ dup current CHAR: < = [ advance ] unless drop ] bi ;
|
||||
|
||||
: read-until-< ( state-parser -- string )
|
||||
: read-until-< ( sequence-parser -- string )
|
||||
[ current CHAR: < = ] take-until ;
|
||||
|
||||
: parse-text ( state-parser -- )
|
||||
: parse-text ( sequence-parser -- )
|
||||
read-until-< [ text new-tag push-tag ] unless-empty ;
|
||||
|
||||
: parse-key/value ( state-parser -- key value )
|
||||
: parse-key/value ( sequence-parser -- key value )
|
||||
[ read-key >lower ]
|
||||
[ skip-whitespace "=" take-sequence ]
|
||||
[ swap [ read-value ] [ drop dup ] if ] tri ;
|
||||
|
||||
: (parse-attributes) ( state-parser -- )
|
||||
: (parse-attributes) ( sequence-parser -- )
|
||||
skip-whitespace
|
||||
dup state-parse-end? [
|
||||
dup sequence-parse-end? [
|
||||
drop
|
||||
] [
|
||||
[ parse-key/value swap set ] [ (parse-attributes) ] bi
|
||||
] if ;
|
||||
|
||||
: parse-attributes ( state-parser -- hashtable )
|
||||
: parse-attributes ( sequence-parser -- hashtable )
|
||||
[ (parse-attributes) ] H{ } make-assoc ;
|
||||
|
||||
: (parse-tag) ( string -- string' hashtable )
|
||||
[
|
||||
[ read-token >lower ] [ parse-attributes ] bi
|
||||
] state-parse ;
|
||||
] parse-sequence ;
|
||||
|
||||
: read-< ( state-parser -- string/f )
|
||||
: read-< ( sequence-parser -- string/f )
|
||||
advance dup current [
|
||||
CHAR: ! = [ read-bang f ] [ read-tag ] if
|
||||
] [
|
||||
drop f
|
||||
] if* ;
|
||||
|
||||
: parse-tag ( state-parser -- )
|
||||
: parse-tag ( sequence-parser -- )
|
||||
read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
|
||||
|
||||
: (parse-html) ( state-parser -- )
|
||||
: (parse-html) ( sequence-parser -- )
|
||||
dup peek-next [
|
||||
[ parse-text ] [ parse-tag ] [ (parse-html) ] tri
|
||||
] [ drop ] if ;
|
||||
|
||||
: tag-parse ( quot -- vector )
|
||||
V{ } clone tagstack [ state-parse ] with-variable ; inline
|
||||
V{ } clone tagstack [ parse-sequence ] with-variable ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -1,104 +0,0 @@
|
|||
USING: tools.test html.parser.state ascii kernel accessors ;
|
||||
IN: html.parser.state.tests
|
||||
|
||||
[ "hello" ]
|
||||
[ "hello" [ take-rest ] state-parse ] unit-test
|
||||
|
||||
[ "hi" " how are you?" ]
|
||||
[
|
||||
"hi how are you?"
|
||||
[ [ [ current blank? ] take-until ] [ take-rest ] bi ] state-parse
|
||||
] unit-test
|
||||
|
||||
[ "foo" ";bar" ]
|
||||
[
|
||||
"foo;bar" [
|
||||
[ CHAR: ; take-until-object ] [ take-rest ] bi
|
||||
] state-parse
|
||||
] unit-test
|
||||
|
||||
[ "foo " " bar" ]
|
||||
[
|
||||
"foo and bar" [
|
||||
[ "and" take-until-sequence ] [ take-rest ] bi
|
||||
] state-parse
|
||||
] unit-test
|
||||
|
||||
[ 6 ]
|
||||
[
|
||||
" foo " [ skip-whitespace n>> ] state-parse
|
||||
] unit-test
|
||||
|
||||
[ { 1 2 } ]
|
||||
[ { 1 2 3 } <state-parser> [ current 3 = ] take-until ] unit-test
|
||||
|
||||
[ { 1 2 } ]
|
||||
[ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
|
||||
|
||||
[ "ab" ]
|
||||
[ "abcd" <state-parser> "ab" take-sequence ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ "abcd" <state-parser> "lol" take-sequence ] unit-test
|
||||
|
||||
[ "ab" ]
|
||||
[
|
||||
"abcd" <state-parser>
|
||||
[ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
|
||||
] unit-test
|
||||
|
||||
[ "" ]
|
||||
[ "abcd" <state-parser> "" take-sequence ] unit-test
|
||||
|
||||
[ "cd" ]
|
||||
[ "abcd" <state-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
|
||||
|
||||
[ f ]
|
||||
[
|
||||
"\"abc\" asdf" <state-parser>
|
||||
[ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
|
||||
] unit-test
|
||||
|
||||
[ "abc\\\"def" ]
|
||||
[
|
||||
"\"abc\\\"def\" asdf" <state-parser>
|
||||
CHAR: \ CHAR: " take-quoted-string
|
||||
] unit-test
|
||||
|
||||
[ "asdf" ]
|
||||
[
|
||||
"\"abc\" asdf" <state-parser>
|
||||
[ CHAR: \ CHAR: " take-quoted-string drop ]
|
||||
[ skip-whitespace "asdf" take-sequence ] bi
|
||||
] unit-test
|
||||
|
||||
[ f ]
|
||||
[
|
||||
"\"abc asdf" <state-parser>
|
||||
CHAR: \ CHAR: " take-quoted-string
|
||||
] unit-test
|
||||
|
||||
[ "\"abc" ]
|
||||
[
|
||||
"\"abc asdf" <state-parser>
|
||||
[ CHAR: \ CHAR: " take-quoted-string drop ]
|
||||
[ "\"abc" take-sequence ] bi
|
||||
] unit-test
|
||||
|
||||
[ "c" ]
|
||||
[ "c" <state-parser> take-token ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ "" <state-parser> take-token ] unit-test
|
||||
|
||||
[ "abcd e \\\"f g" ]
|
||||
[ "\"abcd e \\\"f g\"" <state-parser> CHAR: \ CHAR: " take-token* ] unit-test
|
||||
|
||||
[ "" ]
|
||||
[ "" <state-parser> take-rest ] unit-test
|
||||
|
||||
[ "" ]
|
||||
[ "abc" <state-parser> dup "abc" take-sequence drop take-rest ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ "abc" <state-parser> "abcdefg" take-sequence ] unit-test
|
||||
|
|
@ -1,127 +0,0 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces math kernel sequences accessors fry circular
|
||||
unicode.case unicode.categories locals combinators.short-circuit
|
||||
make combinators io splitting ;
|
||||
|
||||
IN: html.parser.state
|
||||
|
||||
TUPLE: state-parser sequence n ;
|
||||
|
||||
: <state-parser> ( sequence -- state-parser )
|
||||
state-parser new
|
||||
swap >>sequence
|
||||
0 >>n ;
|
||||
|
||||
: offset ( state-parser offset -- char/f )
|
||||
swap
|
||||
[ n>> + ] [ sequence>> ?nth ] bi ; inline
|
||||
|
||||
: current ( state-parser -- char/f ) 0 offset ; inline
|
||||
|
||||
: previous ( state-parser -- char/f ) -1 offset ; inline
|
||||
|
||||
: peek-next ( state-parser -- char/f ) 1 offset ; inline
|
||||
|
||||
: advance ( state-parser -- state-parser )
|
||||
[ 1 + ] change-n ; inline
|
||||
|
||||
: advance* ( state-parser -- )
|
||||
advance drop ; inline
|
||||
|
||||
: get+increment ( state-parser -- char/f )
|
||||
[ current ] [ advance drop ] bi ; inline
|
||||
|
||||
:: skip-until ( state-parser quot: ( obj -- ? ) -- )
|
||||
state-parser current [
|
||||
state-parser quot call [ state-parser advance quot skip-until ] unless
|
||||
] when ; inline recursive
|
||||
|
||||
: state-parse-end? ( state-parser -- ? ) current not ;
|
||||
|
||||
: take-until ( state-parser quot: ( obj -- ? ) -- sequence/f )
|
||||
over state-parse-end? [
|
||||
2drop f
|
||||
] [
|
||||
[ drop n>> ]
|
||||
[ skip-until ]
|
||||
[ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
|
||||
] if ; inline
|
||||
|
||||
: take-while ( state-parser quot: ( obj -- ? ) -- sequence/f )
|
||||
[ not ] compose take-until ; inline
|
||||
|
||||
: <safe-slice> ( from to seq -- slice/f )
|
||||
3dup {
|
||||
[ 2drop 0 < ]
|
||||
[ [ drop ] 2dip length > ]
|
||||
[ drop > ]
|
||||
} 3|| [ 3drop f ] [ slice boa ] if ; inline
|
||||
|
||||
:: take-sequence ( state-parser sequence -- obj/f )
|
||||
state-parser [ n>> dup sequence length + ] [ sequence>> ] bi
|
||||
<safe-slice> sequence sequence= [
|
||||
sequence
|
||||
state-parser [ sequence length + ] change-n drop
|
||||
] [
|
||||
f
|
||||
] if ;
|
||||
|
||||
:: take-until-sequence ( state-parser sequence -- sequence' )
|
||||
sequence length <growing-circular> :> growing
|
||||
state-parser
|
||||
[
|
||||
current growing push-growing-circular
|
||||
sequence growing sequence=
|
||||
] take-until :> found
|
||||
found dup length
|
||||
growing length 1- - head
|
||||
state-parser advance drop ;
|
||||
|
||||
: skip-whitespace ( state-parser -- state-parser )
|
||||
[ [ current blank? not ] take-until drop ] keep ;
|
||||
|
||||
: take-rest-slice ( state-parser -- sequence/f )
|
||||
[ sequence>> ] [ n>> ] bi
|
||||
2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
|
||||
|
||||
: take-rest ( state-parser -- sequence )
|
||||
[ take-rest-slice ] [ sequence>> like ] bi ;
|
||||
|
||||
: take-until-object ( state-parser obj -- sequence )
|
||||
'[ current _ = ] take-until ;
|
||||
|
||||
: state-parse ( sequence quot -- )
|
||||
[ <state-parser> ] dip call ; inline
|
||||
|
||||
:: take-quoted-string ( state-parser escape-char quote-char -- string )
|
||||
state-parser n>> :> start-n
|
||||
state-parser advance
|
||||
[
|
||||
{
|
||||
[ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
|
||||
[ current quote-char = not ]
|
||||
} 1||
|
||||
] take-while :> string
|
||||
state-parser current quote-char = [
|
||||
state-parser advance* string
|
||||
] [
|
||||
start-n state-parser (>>n) f
|
||||
] if ;
|
||||
|
||||
: (take-token) ( state-parser -- string )
|
||||
skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
|
||||
|
||||
:: take-token* ( state-parser escape-char quote-char -- string/f )
|
||||
state-parser skip-whitespace
|
||||
dup current {
|
||||
{ quote-char [ escape-char quote-char take-quoted-string ] }
|
||||
{ f [ drop f ] }
|
||||
[ drop (take-token) ]
|
||||
} case ;
|
||||
|
||||
: take-token ( state-parser -- string/f )
|
||||
CHAR: \ CHAR: " take-token* ;
|
||||
|
||||
: write-full ( state-parser -- ) sequence>> write ;
|
||||
: write-rest ( state-parser -- ) take-rest write ;
|
||||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs circular combinators continuations hashtables
|
||||
hashtables.private io kernel math namespaces prettyprint
|
||||
quotations sequences splitting html.parser.state strings
|
||||
combinators.short-circuit quoting ;
|
||||
quotations sequences splitting strings quoting
|
||||
combinators.short-circuit ;
|
||||
IN: html.parser.utils
|
||||
|
||||
: trim1 ( seq ch -- newseq )
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: id3
|
|||
HELP: mp3>id3
|
||||
{ $values
|
||||
{ "path" "a path string" }
|
||||
{ "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } }
|
||||
{ "id3/f" "a tuple storing ID3v2 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. Words to access the ID3v1 information are here:"
|
||||
{ $list
|
||||
{ $link title }
|
||||
|
|
@ -22,49 +22,49 @@ HELP: mp3>id3
|
|||
|
||||
HELP: album
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "album/f" "string or f" }
|
||||
{ "id3" id3 }
|
||||
{ "string/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the album, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: artist
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "artist/f" "string or f" }
|
||||
{ "id3" id3 }
|
||||
{ "string/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the artist, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: comment
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "comment/f" "string or f" }
|
||||
{ "id3" id3 }
|
||||
{ "string/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the comment, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: genre
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "genre/f" "string or f" }
|
||||
{ "id3" id3 }
|
||||
{ "string/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the genre, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: title
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "title/f" "string or f" }
|
||||
{ "id3" id3 }
|
||||
{ "string/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the title, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: year
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "year/f" "string or f" }
|
||||
{ "id3" id3 }
|
||||
{ "string/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the year, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: find-id3-frame
|
||||
{ $values
|
||||
{ "id3" id3v2-info } { "name" string }
|
||||
{ "id3" id3 } { "name" string }
|
||||
{ "obj/f" "object or f" }
|
||||
}
|
||||
{ $description "Returns the " { $slot "data" } " slot of the ID3 frame with the given name, or " { $link f } "." } ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2009 Tim Wawrzynczak
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test id3 combinators ;
|
||||
USING: tools.test id3 combinators grouping id3.private
|
||||
sequences math ;
|
||||
IN: id3.tests
|
||||
|
||||
: id3-params ( id3 -- title artist album year comment genre )
|
||||
|
|
@ -40,3 +41,6 @@ IN: id3.tests
|
|||
"Big Band"
|
||||
] [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test
|
||||
|
||||
|
||||
[ t ]
|
||||
[ 10000 [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ combinators math.ranges unicode.categories byte-arrays
|
|||
io.encodings.string io.encodings.utf16 assocs math.parser
|
||||
combinators.short-circuit fry namespaces combinators.smart
|
||||
splitting io.encodings.ascii arrays io.files.info unicode.case
|
||||
io.directories.search ;
|
||||
io.directories.search literals math.functions ;
|
||||
IN: id3
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -37,58 +37,83 @@ CONSTANT: genres
|
|||
"Primus" "Porn Groove" "Satire" "Slow Jam" "Club" "Tango"
|
||||
"Samba" "Folklore" "Ballad" "Power Ballad" "Rhythmic Soul"
|
||||
"Freestyle" "Duet" "Punk Rock" "Drum Solo" "A capella"
|
||||
"Euro-House" "Dance Hall"
|
||||
"Euro-House" "Dance Hall" "Goa" "Drum & Bass" "Club-House"
|
||||
"Hardcore" "Terror" "Indie" "BritPop" "Negerpunk"
|
||||
"Polsk Punk" "Beat" "Christian Gangsta Rap" "Heavy Metal"
|
||||
"Black Metal" "Crossover" "Contemporary Christian"
|
||||
"Christian Rock"
|
||||
}
|
||||
|
||||
TUPLE: header version flags size ;
|
||||
|
||||
TUPLE: frame frame-id flags size data ;
|
||||
TUPLE: frame tag flags size data ;
|
||||
|
||||
TUPLE: id3v2-info header frames ;
|
||||
TUPLE: id3 header frames
|
||||
title artist album year comment genre
|
||||
speed genre-name start-time end-time ;
|
||||
|
||||
TUPLE: id3v1-info title artist album year comment genre ;
|
||||
|
||||
: <id3v1-info> ( -- object ) id3v1-info new ; inline
|
||||
|
||||
: <id3v2-info> ( header frames -- object )
|
||||
[ [ frame-id>> ] keep ] H{ } map>assoc id3v2-info boa ;
|
||||
: <id3> ( -- id3 )
|
||||
id3 new
|
||||
H{ } clone >>frames ; inline
|
||||
|
||||
: <header> ( -- object ) header new ; inline
|
||||
|
||||
: <frame> ( -- object ) frame new ; inline
|
||||
|
||||
: id3v2? ( mmap -- ? ) "ID3" head? ; inline
|
||||
: id3v2? ( seq -- ? ) "ID3" head? ; inline
|
||||
|
||||
: id3v1? ( mmap -- ? )
|
||||
{ [ length 128 >= ] [ 128 tail-slice* "TAG" head? ] } 1&& ; inline
|
||||
CONSTANT: id3v1-length 128
|
||||
CONSTANT: id3v1-offset 128
|
||||
CONSTANT: id3v1+-length 227
|
||||
CONSTANT: id3v1+-offset $[ 128 227 + ]
|
||||
|
||||
: id3v1-frame ( string key -- frame )
|
||||
<frame>
|
||||
swap >>frame-id
|
||||
swap >>data ; inline
|
||||
: id3v1? ( seq -- ? )
|
||||
{
|
||||
[ length id3v1-offset >= ]
|
||||
[ id3v1-length tail-slice* "TAG" head? ]
|
||||
} 1&& ; inline
|
||||
|
||||
: id3v1>id3v2 ( id3v1 -- id3v2 )
|
||||
: id3v1+? ( seq -- ? )
|
||||
{
|
||||
[ length id3v1+-offset >= ]
|
||||
[ id3v1+-length tail-slice* "TAG+" head? ]
|
||||
} 1&& ; inline
|
||||
|
||||
: pair>frame ( string key -- frame/f )
|
||||
over [
|
||||
<frame>
|
||||
swap >>tag
|
||||
swap >>data
|
||||
] [
|
||||
2drop f
|
||||
] if ; inline
|
||||
|
||||
: id3v1>frames ( id3v1 -- seq )
|
||||
[
|
||||
{
|
||||
[ title>> "TIT2" id3v1-frame ]
|
||||
[ artist>> "TPE1" id3v1-frame ]
|
||||
[ album>> "TALB" id3v1-frame ]
|
||||
[ year>> "TYER" id3v1-frame ]
|
||||
[ comment>> "COMM" id3v1-frame ]
|
||||
[ genre>> "TCON" id3v1-frame ]
|
||||
[ title>> "TIT2" pair>frame ]
|
||||
[ artist>> "TPE1" pair>frame ]
|
||||
[ album>> "TALB" pair>frame ]
|
||||
[ year>> "TYER" pair>frame ]
|
||||
[ comment>> "COMM" pair>frame ]
|
||||
[ genre>> "TCON" pair>frame ]
|
||||
} cleave
|
||||
] output>array f swap <id3v2-info> ; inline
|
||||
] output>array sift ;
|
||||
|
||||
: >28bitword ( seq -- int )
|
||||
: seq>synchsafe ( seq -- n )
|
||||
0 [ [ 7 shift ] dip bitor ] reduce ; inline
|
||||
|
||||
: synchsafe>seq ( n -- seq )
|
||||
dup 1+ log2 1+ 7 / ceiling
|
||||
[ [ -7 shift ] keep HEX: 7f bitand ] replicate nip reverse ; inline
|
||||
|
||||
: filter-text-data ( data -- filtered )
|
||||
[ printable? ] filter ; inline
|
||||
|
||||
: valid-frame-id? ( id -- ? )
|
||||
: valid-tag? ( id -- ? )
|
||||
[ { [ digit? ] [ LETTER? ] } 1|| ] all? ; inline
|
||||
|
||||
: read-frame-data ( frame mmap -- frame data )
|
||||
: read-frame-data ( frame seq -- frame data )
|
||||
[ 10 over size>> 10 + ] dip <slice> filter-text-data ; inline
|
||||
|
||||
: decode-text ( string -- string' )
|
||||
|
|
@ -96,44 +121,48 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
{ { HEX: ff HEX: fe } { HEX: fe HEX: ff } } member?
|
||||
utf16 ascii ? decode ; inline
|
||||
|
||||
: (read-frame) ( mmap -- frame )
|
||||
: (read-frame) ( seq -- frame )
|
||||
[ <frame> ] dip
|
||||
{
|
||||
[ 4 head-slice decode-text >>frame-id ]
|
||||
[ [ 4 8 ] dip subseq >28bitword >>size ]
|
||||
[ 4 head-slice decode-text >>tag ]
|
||||
[ [ 4 8 ] dip subseq seq>synchsafe >>size ]
|
||||
[ [ 8 10 ] dip subseq >byte-array >>flags ]
|
||||
[ read-frame-data decode-text >>data ]
|
||||
} cleave ; inline
|
||||
|
||||
: read-frame ( mmap -- frame/f )
|
||||
dup 4 head-slice valid-frame-id?
|
||||
: read-frame ( seq -- frame/f )
|
||||
dup 4 head-slice valid-tag?
|
||||
[ (read-frame) ] [ drop f ] if ; inline
|
||||
|
||||
: remove-frame ( mmap frame -- mmap )
|
||||
: remove-frame ( seq frame -- seq )
|
||||
size>> 10 + tail-slice ; inline
|
||||
|
||||
: read-frames ( mmap -- frames )
|
||||
[ dup read-frame dup ]
|
||||
[ [ remove-frame ] keep ]
|
||||
produce 2nip ; inline
|
||||
: frames>assoc ( seq -- assoc )
|
||||
[ [ tag>> ] keep ] H{ } map>assoc ; inline
|
||||
|
||||
: read-frames ( seq -- assoc )
|
||||
[ dup read-frame dup ] [ [ remove-frame ] keep ] produce 2nip ; inline
|
||||
|
||||
: read-v2-header ( seq -- id3header )
|
||||
: read-v2-header ( seq -- header )
|
||||
[ <header> ] dip
|
||||
{
|
||||
[ [ 3 5 ] dip <slice> >array >>version ]
|
||||
[ [ 5 ] dip nth >>flags ]
|
||||
[ [ 6 10 ] dip <slice> >28bitword >>size ]
|
||||
[ [ 6 10 ] dip <slice> seq>synchsafe >>size ]
|
||||
} cleave ; inline
|
||||
|
||||
: read-v2-tag-data ( seq -- id3v2-info )
|
||||
10 cut-slice
|
||||
[ read-v2-header ]
|
||||
[ read-frames ] bi* <id3v2-info> ; inline
|
||||
|
||||
: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline
|
||||
: merge-frames ( id3 assoc -- id3 )
|
||||
[ dup frames>> ] dip update ; inline
|
||||
|
||||
: (read-v1-tag-data) ( seq -- mp3-file )
|
||||
[ <id3v1-info> ] dip
|
||||
: merge-id3v1 ( id3 -- id3 )
|
||||
dup id3v1>frames frames>assoc merge-frames ; inline
|
||||
|
||||
: read-v2-tags ( id3 seq -- id3 )
|
||||
10 cut-slice
|
||||
[ read-v2-header >>header ]
|
||||
[ read-frames frames>assoc merge-frames ] bi* ; inline
|
||||
|
||||
: extract-v1-tags ( id3 seq -- id3 )
|
||||
{
|
||||
[ 30 head-slice decode-text filter-text-data >>title ]
|
||||
[ [ 30 60 ] dip subseq decode-text filter-text-data >>artist ]
|
||||
|
|
@ -143,8 +172,30 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
[ [ 124 ] dip nth number>string >>genre ]
|
||||
} cleave ; inline
|
||||
|
||||
: read-v1-tag-data ( seq -- mp3-file )
|
||||
skip-to-v1-data (read-v1-tag-data) ; inline
|
||||
: read-v1-tags ( id3 seq -- id3 )
|
||||
id3v1-offset tail-slice* 3 tail-slice
|
||||
extract-v1-tags ; inline
|
||||
|
||||
: extract-v1+-tags ( id3 seq -- id3 )
|
||||
{
|
||||
[ 60 head-slice decode-text filter-text-data [ append ] change-title ]
|
||||
[
|
||||
[ 60 120 ] dip subseq decode-text filter-text-data
|
||||
[ append ] change-artist
|
||||
]
|
||||
[
|
||||
[ 120 180 ] dip subseq decode-text filter-text-data
|
||||
[ append ] change-album
|
||||
]
|
||||
[ [ 180 ] dip nth >>speed ]
|
||||
[ [ 181 211 ] dip subseq decode-text >>genre-name ]
|
||||
[ [ 211 217 ] dip subseq decode-text >>start-time ]
|
||||
[ [ 217 223 ] dip subseq decode-text >>end-time ]
|
||||
} cleave ; inline
|
||||
|
||||
: read-v1+-tags ( id3 seq -- id3 )
|
||||
id3v1+-offset tail-slice* 4 tail-slice
|
||||
extract-v1+-tags ; inline
|
||||
|
||||
: parse-genre ( string -- n/f )
|
||||
dup "(" ?head-slice drop ")" ?tail-slice drop
|
||||
|
|
@ -154,34 +205,35 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
drop
|
||||
] if ; inline
|
||||
|
||||
: (mp3>id3) ( path -- id3v2-info/f )
|
||||
: (mp3>id3) ( path -- id3v2/f )
|
||||
[
|
||||
[ <id3> ] dip
|
||||
{
|
||||
{ [ dup id3v2? ] [ read-v2-tag-data ] }
|
||||
{ [ dup id3v1? ] [ read-v1-tag-data id3v1>id3v2 ] }
|
||||
[ drop f ]
|
||||
} cond
|
||||
[ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ]
|
||||
[ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
|
||||
[ dup id3v2? [ read-v2-tags ] [ drop ] if ]
|
||||
} cleave
|
||||
] with-mapped-uchar-file ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: mp3>id3 ( path -- id3v2-info/f )
|
||||
: mp3>id3 ( path -- id3/f )
|
||||
dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline
|
||||
|
||||
: find-id3-frame ( id3 name -- obj/f )
|
||||
swap frames>> at* [ data>> ] when ; inline
|
||||
|
||||
: title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline
|
||||
: title ( id3 -- string/f ) "TIT2" find-id3-frame ; inline
|
||||
|
||||
: artist ( id3 -- artist/f ) "TPE1" find-id3-frame ; inline
|
||||
: artist ( id3 -- string/f ) "TPE1" find-id3-frame ; inline
|
||||
|
||||
: album ( id3 -- album/f ) "TALB" find-id3-frame ; inline
|
||||
: album ( id3 -- string/f ) "TALB" find-id3-frame ; inline
|
||||
|
||||
: year ( id3 -- year/f ) "TYER" find-id3-frame ; inline
|
||||
: year ( id3 -- string/f ) "TYER" find-id3-frame ; inline
|
||||
|
||||
: comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline
|
||||
: comment ( id3 -- string/f ) "COMM" find-id3-frame ; inline
|
||||
|
||||
: genre ( id3 -- genre/f )
|
||||
: genre ( id3 -- string/f )
|
||||
"TCON" find-id3-frame parse-genre ; inline
|
||||
|
||||
: find-mp3s ( path -- seq )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,191 @@
|
|||
USING: tools.test sequence-parser ascii kernel accessors ;
|
||||
IN: sequence-parser.tests
|
||||
|
||||
[ "hello" ]
|
||||
[ "hello" [ take-rest ] parse-sequence ] unit-test
|
||||
|
||||
[ "hi" " how are you?" ]
|
||||
[
|
||||
"hi how are you?"
|
||||
[ [ [ current blank? ] take-until ] [ take-rest ] bi ] parse-sequence
|
||||
] unit-test
|
||||
|
||||
[ "foo" ";bar" ]
|
||||
[
|
||||
"foo;bar" [
|
||||
[ CHAR: ; take-until-object ] [ take-rest ] bi
|
||||
] parse-sequence
|
||||
] unit-test
|
||||
|
||||
[ "foo " "and bar" ]
|
||||
[
|
||||
"foo and bar" [
|
||||
[ "and" take-until-sequence ] [ take-rest ] bi
|
||||
] parse-sequence
|
||||
] unit-test
|
||||
|
||||
[ "foo " " bar" ]
|
||||
[
|
||||
"foo and bar" [
|
||||
[ "and" take-until-sequence ]
|
||||
[ "and" take-sequence drop ]
|
||||
[ take-rest ] tri
|
||||
] parse-sequence
|
||||
] unit-test
|
||||
|
||||
[ "foo " " bar" ]
|
||||
[
|
||||
"foo and bar" [
|
||||
[ "and" take-until-sequence* ]
|
||||
[ take-rest ] bi
|
||||
] parse-sequence
|
||||
] unit-test
|
||||
|
||||
[ { 1 2 } ]
|
||||
[ { 1 2 3 4 } <sequence-parser> { 3 4 } take-until-sequence ] unit-test
|
||||
|
||||
[ f "aaaa" ]
|
||||
[
|
||||
"aaaa" <sequence-parser>
|
||||
[ "b" take-until-sequence ] [ take-rest ] bi
|
||||
] unit-test
|
||||
|
||||
[ 6 ]
|
||||
[
|
||||
" foo " [ skip-whitespace n>> ] parse-sequence
|
||||
] unit-test
|
||||
|
||||
[ { 1 2 } ]
|
||||
[ { 1 2 3 } <sequence-parser> [ current 3 = ] take-until ] unit-test
|
||||
|
||||
[ "ab" ]
|
||||
[ "abcd" <sequence-parser> "ab" take-sequence ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ "abcd" <sequence-parser> "lol" take-sequence ] unit-test
|
||||
|
||||
[ "ab" ]
|
||||
[
|
||||
"abcd" <sequence-parser>
|
||||
[ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
|
||||
] unit-test
|
||||
|
||||
[ "" ]
|
||||
[ "abcd" <sequence-parser> "" take-sequence ] unit-test
|
||||
|
||||
[ "cd" ]
|
||||
[ "abcd" <sequence-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
|
||||
|
||||
[ f ]
|
||||
[
|
||||
"\"abc\" asdf" <sequence-parser>
|
||||
[ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
|
||||
] unit-test
|
||||
|
||||
[ "abc\\\"def" ]
|
||||
[
|
||||
"\"abc\\\"def\" asdf" <sequence-parser>
|
||||
CHAR: \ CHAR: " take-quoted-string
|
||||
] unit-test
|
||||
|
||||
[ "asdf" ]
|
||||
[
|
||||
"\"abc\" asdf" <sequence-parser>
|
||||
[ CHAR: \ CHAR: " take-quoted-string drop ]
|
||||
[ skip-whitespace "asdf" take-sequence ] bi
|
||||
] unit-test
|
||||
|
||||
[ f ]
|
||||
[
|
||||
"\"abc asdf" <sequence-parser>
|
||||
CHAR: \ CHAR: " take-quoted-string
|
||||
] unit-test
|
||||
|
||||
[ "\"abc" ]
|
||||
[
|
||||
"\"abc asdf" <sequence-parser>
|
||||
[ CHAR: \ CHAR: " take-quoted-string drop ]
|
||||
[ "\"abc" take-sequence ] bi
|
||||
] unit-test
|
||||
|
||||
[ "c" ]
|
||||
[ "c" <sequence-parser> take-token ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ "" <sequence-parser> take-token ] unit-test
|
||||
|
||||
[ "abcd e \\\"f g" ]
|
||||
[ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
|
||||
|
||||
[ "" ]
|
||||
[ "" <sequence-parser> take-rest ] unit-test
|
||||
|
||||
[ "" ]
|
||||
[ "abc" <sequence-parser> dup "abc" take-sequence drop take-rest ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ "abc" <sequence-parser> "abcdefg" take-sequence ] unit-test
|
||||
|
||||
[ "1234" ]
|
||||
[ "1234f" <sequence-parser> take-integer ] unit-test
|
||||
|
||||
[ "yes" ]
|
||||
[
|
||||
"yes1234f" <sequence-parser>
|
||||
[ take-integer drop ] [ "yes" take-sequence ] bi
|
||||
] unit-test
|
||||
|
||||
[ f ] [ "" <sequence-parser> 4 take-n ] unit-test
|
||||
[ "abcd" ] [ "abcd" <sequence-parser> 4 take-n ] unit-test
|
||||
[ "abcd" "efg" ] [ "abcdefg" <sequence-parser> [ 4 take-n ] [ take-rest ] bi ] unit-test
|
||||
|
||||
[ "asdfasdf" ] [
|
||||
"/*asdfasdf*/" <sequence-parser> take-c-comment
|
||||
] unit-test
|
||||
|
||||
[ "k" ] [
|
||||
"/*asdfasdf*/k" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
|
||||
] unit-test
|
||||
|
||||
[ "omg" ] [
|
||||
"//asdfasdf\nomg" <sequence-parser>
|
||||
[ take-c++-comment drop ] [ take-rest ] bi
|
||||
] unit-test
|
||||
|
||||
[ "omg" ] [
|
||||
"omg" <sequence-parser>
|
||||
[ take-c++-comment drop ] [ take-rest ] bi
|
||||
] unit-test
|
||||
|
||||
[ "/*asdfasdf" ] [
|
||||
"/*asdfasdf" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
|
||||
] unit-test
|
||||
|
||||
[ "asdf" "eoieoei" ] [
|
||||
"//asdf\neoieoei" <sequence-parser>
|
||||
[ take-c++-comment ] [ take-rest ] bi
|
||||
] unit-test
|
||||
|
||||
[ f "33asdf" ]
|
||||
[ "33asdf" <sequence-parser> [ take-c-identifier ] [ take-rest ] bi ] unit-test
|
||||
|
||||
[ "asdf" ]
|
||||
[ "asdf" <sequence-parser> take-c-identifier ] unit-test
|
||||
|
||||
[ "_asdf" ]
|
||||
[ "_asdf" <sequence-parser> take-c-identifier ] unit-test
|
||||
|
||||
[ "_asdf400" ]
|
||||
[ "_asdf400" <sequence-parser> take-c-identifier ] unit-test
|
||||
|
||||
[ "123" ]
|
||||
[ "123jjj" <sequence-parser> take-c-integer ] unit-test
|
||||
|
||||
[ "123uLL" ]
|
||||
[ "123uLL" <sequence-parser> take-c-integer ] unit-test
|
||||
|
||||
[ "123ull" ]
|
||||
[ "123ull" <sequence-parser> take-c-integer ] unit-test
|
||||
|
||||
[ "123u" ]
|
||||
[ "123u" <sequence-parser> take-c-integer ] unit-test
|
||||
|
|
@ -0,0 +1,229 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces math kernel sequences accessors fry circular
|
||||
unicode.case unicode.categories locals combinators.short-circuit
|
||||
make combinators io splitting math.parser math.ranges
|
||||
generalizations sorting.functor math.order sorting.slots ;
|
||||
IN: sequence-parser
|
||||
|
||||
TUPLE: sequence-parser sequence n ;
|
||||
|
||||
: <sequence-parser> ( sequence -- sequence-parser )
|
||||
sequence-parser new
|
||||
swap >>sequence
|
||||
0 >>n ;
|
||||
|
||||
:: with-sequence-parser ( sequence-parser quot -- seq/f )
|
||||
sequence-parser n>> :> n
|
||||
sequence-parser quot call [
|
||||
n sequence-parser (>>n) f
|
||||
] unless* ; inline
|
||||
|
||||
: offset ( sequence-parser offset -- char/f )
|
||||
swap
|
||||
[ n>> + ] [ sequence>> ?nth ] bi ; inline
|
||||
|
||||
: current ( sequence-parser -- char/f ) 0 offset ; inline
|
||||
|
||||
: previous ( sequence-parser -- char/f ) -1 offset ; inline
|
||||
|
||||
: peek-next ( sequence-parser -- char/f ) 1 offset ; inline
|
||||
|
||||
: advance ( sequence-parser -- sequence-parser )
|
||||
[ 1 + ] change-n ; inline
|
||||
|
||||
: advance* ( sequence-parser -- )
|
||||
advance drop ; inline
|
||||
|
||||
: get+increment ( sequence-parser -- char/f )
|
||||
[ current ] [ advance drop ] bi ; inline
|
||||
|
||||
:: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
|
||||
sequence-parser current [
|
||||
sequence-parser quot call
|
||||
[ sequence-parser advance quot skip-until ] unless
|
||||
] when ; inline recursive
|
||||
|
||||
: sequence-parse-end? ( sequence-parser -- ? ) current not ;
|
||||
|
||||
: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
|
||||
over sequence-parse-end? [
|
||||
2drop f
|
||||
] [
|
||||
[ drop n>> ]
|
||||
[ skip-until ]
|
||||
[ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
|
||||
] if ; inline
|
||||
|
||||
: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
|
||||
[ not ] compose take-until ; inline
|
||||
|
||||
: <safe-slice> ( from to seq -- slice/f )
|
||||
3dup {
|
||||
[ 2drop 0 < ]
|
||||
[ [ drop ] 2dip length > ]
|
||||
[ drop > ]
|
||||
} 3|| [ 3drop f ] [ slice boa ] if ; inline
|
||||
|
||||
:: take-sequence ( sequence-parser sequence -- obj/f )
|
||||
sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
|
||||
<safe-slice> sequence sequence= [
|
||||
sequence
|
||||
sequence-parser [ sequence length + ] change-n drop
|
||||
] [
|
||||
f
|
||||
] if ;
|
||||
|
||||
: take-sequence* ( sequence-parser sequence -- )
|
||||
take-sequence drop ;
|
||||
|
||||
:: take-until-sequence ( sequence-parser sequence -- sequence'/f )
|
||||
sequence-parser n>> :> saved
|
||||
sequence length <growing-circular> :> growing
|
||||
sequence-parser
|
||||
[
|
||||
current growing push-growing-circular
|
||||
sequence growing sequence=
|
||||
] take-until :> found
|
||||
growing sequence sequence= [
|
||||
found dup length
|
||||
growing length 1- - head
|
||||
sequence-parser [ growing length - 1 + ] change-n drop
|
||||
! sequence-parser advance drop
|
||||
] [
|
||||
saved sequence-parser (>>n)
|
||||
f
|
||||
] if ;
|
||||
|
||||
:: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
|
||||
sequence-parser sequence take-until-sequence :> out
|
||||
out [
|
||||
sequence-parser [ sequence length + ] change-n drop
|
||||
] when out ;
|
||||
|
||||
: skip-whitespace ( sequence-parser -- sequence-parser )
|
||||
[ [ current blank? not ] take-until drop ] keep ;
|
||||
|
||||
: take-rest-slice ( sequence-parser -- sequence/f )
|
||||
[ sequence>> ] [ n>> ] bi
|
||||
2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
|
||||
|
||||
: take-rest ( sequence-parser -- sequence )
|
||||
[ take-rest-slice ] [ sequence>> like ] bi ;
|
||||
|
||||
: take-until-object ( sequence-parser obj -- sequence )
|
||||
'[ current _ = ] take-until ;
|
||||
|
||||
: parse-sequence ( sequence quot -- )
|
||||
[ <sequence-parser> ] dip call ; inline
|
||||
|
||||
:: take-quoted-string ( sequence-parser escape-char quote-char -- string )
|
||||
sequence-parser n>> :> start-n
|
||||
sequence-parser advance
|
||||
[
|
||||
{
|
||||
[ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
|
||||
[ current quote-char = not ]
|
||||
} 1||
|
||||
] take-while :> string
|
||||
sequence-parser current quote-char = [
|
||||
sequence-parser advance* string
|
||||
] [
|
||||
start-n sequence-parser (>>n) f
|
||||
] if ;
|
||||
|
||||
: (take-token) ( sequence-parser -- string )
|
||||
skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
|
||||
|
||||
:: take-token* ( sequence-parser escape-char quote-char -- string/f )
|
||||
sequence-parser skip-whitespace
|
||||
dup current {
|
||||
{ quote-char [ escape-char quote-char take-quoted-string ] }
|
||||
{ f [ drop f ] }
|
||||
[ drop (take-token) ]
|
||||
} case ;
|
||||
|
||||
: take-token ( sequence-parser -- string/f )
|
||||
CHAR: \ CHAR: " take-token* ;
|
||||
|
||||
: take-integer ( sequence-parser -- n/f )
|
||||
[ current digit? ] take-while ;
|
||||
|
||||
:: take-n ( sequence-parser n -- seq/f )
|
||||
n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
|
||||
f
|
||||
] [
|
||||
sequence-parser n>> dup n + sequence-parser sequence>> subseq
|
||||
sequence-parser [ n + ] change-n drop
|
||||
] if ;
|
||||
|
||||
: take-c-comment ( sequence-parser -- seq/f )
|
||||
[
|
||||
dup "/*" take-sequence [
|
||||
"*/" take-until-sequence*
|
||||
] [
|
||||
drop f
|
||||
] if
|
||||
] with-sequence-parser ;
|
||||
|
||||
: take-c++-comment ( sequence-parser -- seq/f )
|
||||
[
|
||||
dup "//" take-sequence [
|
||||
[
|
||||
[
|
||||
{ [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
|
||||
] take-until
|
||||
] [
|
||||
advance drop
|
||||
] bi
|
||||
] [
|
||||
drop f
|
||||
] if
|
||||
] with-sequence-parser ;
|
||||
|
||||
: c-identifier-begin? ( ch -- ? )
|
||||
CHAR: a CHAR: z [a,b]
|
||||
CHAR: A CHAR: Z [a,b]
|
||||
{ CHAR: _ } 3append member? ;
|
||||
|
||||
: c-identifier-ch? ( ch -- ? )
|
||||
CHAR: a CHAR: z [a,b]
|
||||
CHAR: A CHAR: Z [a,b]
|
||||
CHAR: 0 CHAR: 9 [a,b]
|
||||
{ CHAR: _ } 4 nappend member? ;
|
||||
|
||||
: take-c-identifier ( state-parser -- string/f )
|
||||
[
|
||||
dup current c-identifier-begin? [
|
||||
[ current c-identifier-ch? ] take-while
|
||||
] [
|
||||
drop f
|
||||
] if
|
||||
] with-sequence-parser ;
|
||||
|
||||
<< "length" [ length ] define-sorting >>
|
||||
|
||||
: sort-tokens ( seq -- seq' )
|
||||
{ length>=< <=> } sort-by ;
|
||||
|
||||
: take-first-matching ( state-parser seq -- seq )
|
||||
swap
|
||||
'[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
|
||||
|
||||
|
||||
: take-longest ( state-parser seq -- seq )
|
||||
sort-tokens take-first-matching ;
|
||||
|
||||
: take-c-integer ( state-parser -- string/f )
|
||||
[
|
||||
dup take-integer [
|
||||
swap
|
||||
{ "ull" "uLL" "Ull" "ULL" "ll" "LL" "l" "L" "u" "U" }
|
||||
take-longest [ append ] when*
|
||||
] [
|
||||
drop f
|
||||
] if*
|
||||
] with-sequence-parser ;
|
||||
|
||||
: write-full ( sequence-parser -- ) sequence>> write ;
|
||||
: write-rest ( sequence-parser -- ) take-rest write ;
|
||||
|
|
@ -29,3 +29,9 @@ TUPLE: unique-deque assoc deque ;
|
|||
: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
|
||||
|
||||
: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
|
||||
|
||||
: slurp-deque-when ( deque quot1 quot2: ( value -- ) -- )
|
||||
pick deque-empty? [ 3drop ] [
|
||||
[ [ pop-front dup ] 2dip slip [ t ] compose [ drop f ] if ]
|
||||
[ roll [ slurp-deque-when ] [ 3drop ] if ] 3bi
|
||||
] if ; inline recursive
|
||||
|
|
|
|||
Loading…
Reference in New Issue