Globs

extra/globs/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/globs/globs-tests.factor

@@ -0,0 +1,18 @@
+IN: temporary
+USING: tools.test globs ;
+
+[ f ] [ "abd" "fdf" glob-matches? ] unit-test
+[ f ] [ "fdsafas" "?" glob-matches? ] unit-test
+[ t ] [ "fdsafas" "*as" glob-matches? ] unit-test
+[ t ] [ "fdsafas" "*a*" glob-matches? ] unit-test
+[ t ] [ "fdsafas" "*a?" glob-matches? ] unit-test
+[ t ] [ "fdsafas" "*?" glob-matches? ] unit-test
+[ f ] [ "fdsafas" "*s?" glob-matches? ] unit-test
+[ t ] [ "a" "[abc]" glob-matches? ] unit-test
+[ f ] [ "a" "[^abc]" glob-matches? ] unit-test
+[ t ] [ "d" "[^abc]" glob-matches? ] unit-test
+[ f ] [ "foo.java" "*.{xml,txt}" glob-matches? ] unit-test
+[ t ] [ "foo.txt" "*.{xml,txt}" glob-matches? ] unit-test
+[ t ] [ "foo.xml" "*.{xml,txt}" glob-matches? ] unit-test
+[ f ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test
+[ t ] [ "foo.{" "*.{" glob-matches? ] unit-test

extra/globs/globs.factor

@@ -0,0 +1,42 @@
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser-combinators regexp lazy-lists sequences kernel
+promises ;
+IN: globs
+
+<PRIVATE
+
+: 'char'
+    [ ",*?" member? not ] satisfy ;
+
+: 'string'
+    'char' <+> [ token ] <@ ;
+
+: 'escaped-char'
+    "\\" token any-char-parser &> [ 1token ] <@ ;
+
+: 'escaped-string'
+    'string' 'escaped-char' <|> ;
+
+DEFER: 'term'
+
+: 'glob' ( -- parser )
+    'term' <*> [ <and-parser> ] <@ ;
+
+: 'union' ( -- parser )
+    'glob' "," token nonempty-list-of "{" "}" surrounded-by
+    [ <or-parser> ] <@ ;
+
+LAZY: 'term'
+    'union'
+    'character-class' <|>
+    "?" token [ drop any-char-parser ] <@ <|>
+    "*" token [ drop any-char-parser <*> ] <@ <|>
+    'escaped-string' <|> ;
+
+PRIVATE>
+
+: <glob> 'glob' just parse-1 just ;
+
+: glob-matches? ( input glob -- ? )
+    <glob> parse nil? not ;

extra/globs/summary.txt

@@ -0,0 +1 @@
+Unix shell-style glob pattern matching

extra/parser-combinators/parser-combinators.factor

@@ -13,10 +13,10 @@ M: promise parse ( input parser -- list )
 TUPLE: parse-result parsed unparsed ;
 
 : parse-1 ( input parser -- result )
-    parse dup nil? [
-        "Parse error" throw
+    dupd parse dup nil? [
+        "Cannot parse " rot append throw
     ] [
-        car parse-result-parsed
+        nip car parse-result-parsed
     ] if ;
 
 C: <parse-result> parse-result
@@ -93,6 +93,9 @@ TUPLE: and-parser parsers ;
         2array
     ] if and-parser construct-boa ;
 
+: <and-parser> ( parsers -- parser )
+    dup length 1 = [ first ] [ and-parser construct-boa ] if ;
+
 : and-parser-parse ( list p1  -- list )
     swap [
         dup parse-result-unparsed rot parse
@@ -111,15 +114,20 @@ M: and-parser parse ( input parser -- list )
     and-parser-parsers unclip swapd parse
     [ [ and-parser-parse ] reduce ] 2curry promise ;
 
-TUPLE: or-parser p1 p2 ;
+TUPLE: or-parser parsers ;
 
-C: <|> or-parser ( parser1 parser2 -- parser )
+: <or-parser> ( parsers -- parser )
+    dup length 1 = [ first ] [ or-parser construct-boa ] if ;
+
+: <|> ( parser1 parser2 -- parser )
+    2array <or-parser> ;
 
 M: or-parser parse ( input parser1 -- list )
     #! Return the combined list resulting from the parses
     #! of parser1 and parser2 being applied to the same
     #! input. This implements the choice parsing operator.
-    [ or-parser-p1 ] keep or-parser-p2 >r dupd parse swap r> parse lappend ;
+    or-parser-parsers 0 swap seq>list
+    [ parse ] lmap-with lconcat ;
 
 : left-trim-slice ( string -- string )
     #! Return a new string without any leading whitespace