352 lines
9.8 KiB
Factor
352 lines
9.8 KiB
Factor
! Copyright (C) 2004 Chris Double.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: lists lists.lazy promises kernel sequences strings math
|
|
arrays splitting quotations combinators namespaces locals
|
|
unicode sequences.deep accessors ;
|
|
IN: parser-combinators
|
|
|
|
! Parser combinator protocol
|
|
GENERIC: parse ( input parser -- list )
|
|
|
|
M: promise parse ( input parser -- list )
|
|
force parse ;
|
|
|
|
TUPLE: parse-result parsed unparsed ;
|
|
|
|
ERROR: cannot-parse input ;
|
|
|
|
: parse-1 ( input parser -- result )
|
|
dupd parse dup nil? [
|
|
swap cannot-parse
|
|
] [
|
|
nip car parsed>>
|
|
] if ;
|
|
|
|
C: <parse-result> parse-result
|
|
|
|
: <parse-results> ( parsed unparsed -- list )
|
|
<parse-result> 1list ;
|
|
|
|
: parse-result-parsed-slice ( parse-result -- slice )
|
|
dup parsed>> empty? [
|
|
unparsed>> 0 0 rot <slice>
|
|
] [
|
|
dup unparsed>>
|
|
dup from>> [ rot parsed>> length - ] keep
|
|
rot seq>> <slice>
|
|
] if ;
|
|
|
|
: string= ( str1 str2 ignore-case -- ? )
|
|
[ [ >upper ] bi@ ] when sequence= ;
|
|
|
|
: string-head? ( str head ignore-case -- ? )
|
|
2over shorter? [
|
|
3drop f
|
|
] [
|
|
[ [ length head-slice ] keep ] dip string=
|
|
] if ;
|
|
|
|
: ?string-head ( str head ignore-case -- newstr ? )
|
|
[ 2dup ] dip string-head?
|
|
[ length tail-slice t ] [ drop f ] if ;
|
|
|
|
TUPLE: token-parser string ignore-case? ;
|
|
|
|
C: <token-parser> token-parser
|
|
|
|
: token ( string -- parser ) f <token-parser> ;
|
|
|
|
: case-insensitive-token ( string -- parser ) t <token-parser> ;
|
|
|
|
M:: token-parser parse ( input parser -- list )
|
|
parser string>> :> str
|
|
parser ignore-case?>> :> case?
|
|
|
|
str input str case? ?string-head
|
|
[ <parse-results> ] [ 2drop nil ] if ;
|
|
|
|
: 1token ( n -- parser ) 1string token ;
|
|
|
|
TUPLE: satisfy-parser quot ;
|
|
|
|
C: satisfy satisfy-parser
|
|
|
|
M: satisfy-parser parse ( input parser -- list )
|
|
! A parser that succeeds if the predicate,
|
|
! when passed the first character in the input, returns
|
|
! true.
|
|
over empty? [
|
|
2drop nil
|
|
] [
|
|
quot>> [ unclip-slice dup ] dip call( char -- ? )
|
|
[ swap <parse-results> ] [ 2drop nil ] if
|
|
] if ;
|
|
|
|
LAZY: any-char-parser ( -- parser )
|
|
[ drop t ] satisfy ;
|
|
|
|
TUPLE: epsilon-parser ;
|
|
|
|
C: epsilon epsilon-parser
|
|
|
|
M: epsilon-parser parse ( input parser -- list )
|
|
! A parser that parses the empty string. It
|
|
! does not consume any input and always returns
|
|
! an empty list as the parse tree with the
|
|
! unmodified input.
|
|
drop "" swap <parse-results> ;
|
|
|
|
TUPLE: succeed-parser result ;
|
|
|
|
C: succeed succeed-parser
|
|
|
|
M: succeed-parser parse ( input parser -- list )
|
|
! A parser that always returns 'result' as a
|
|
! successful parse with no input consumed.
|
|
result>> swap <parse-results> ;
|
|
|
|
TUPLE: fail-parser ;
|
|
|
|
C: fail fail-parser
|
|
|
|
M: fail-parser parse ( input parser -- list )
|
|
! A parser that always fails and returns
|
|
! an empty list of successes.
|
|
2drop nil ;
|
|
|
|
TUPLE: ensure-parser test ;
|
|
|
|
: ensure ( parser -- ensure )
|
|
ensure-parser boa ;
|
|
|
|
M: ensure-parser parse ( input parser -- list )
|
|
2dup test>> parse nil?
|
|
[ 2drop nil ] [ drop t swap <parse-results> ] if ;
|
|
|
|
TUPLE: ensure-not-parser test ;
|
|
|
|
: ensure-not ( parser -- ensure )
|
|
ensure-not-parser boa ;
|
|
|
|
M: ensure-not-parser parse ( input parser -- list )
|
|
2dup test>> parse nil?
|
|
[ drop t swap <parse-results> ] [ 2drop nil ] if ;
|
|
|
|
TUPLE: and-parser parsers ;
|
|
|
|
: <&> ( parser1 parser2 -- parser )
|
|
over and-parser? [
|
|
[ parsers>> ] dip suffix
|
|
] [
|
|
2array
|
|
] if and-parser boa ;
|
|
|
|
: <and-parser> ( parsers -- parser )
|
|
dup length 1 = [ first ] [ and-parser boa ] if ;
|
|
|
|
: and-parser-parse ( list p1 -- list )
|
|
swap [
|
|
dup unparsed>> rot parse
|
|
[
|
|
[ parsed>> ] dip
|
|
[ parsed>> 2array ] keep
|
|
unparsed>> <parse-result>
|
|
] with lmap-lazy
|
|
] with lmap-lazy lconcat ;
|
|
|
|
M: and-parser parse ( input parser -- list )
|
|
! Parse 'input' by sequentially combining the
|
|
! two parsers. First parser1 is applied to the
|
|
! input then parser2 is applied to the rest of
|
|
! the input strings from the first parser.
|
|
parsers>> unclip swapd parse
|
|
[ [ and-parser-parse ] reduce ] 2curry <promise> ;
|
|
|
|
TUPLE: or-parser parsers ;
|
|
|
|
: <or-parser> ( parsers -- parser )
|
|
dup length 1 = [ first ] [ or-parser 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.
|
|
parsers>> sequence>list
|
|
[ parse ] with lmap-lazy lconcat ;
|
|
|
|
: trim-head-slice ( string -- string )
|
|
! Return a new string without any leading whitespace
|
|
! from the original string.
|
|
dup empty? [
|
|
dup first blank? [ rest-slice trim-head-slice ] when
|
|
] unless ;
|
|
|
|
TUPLE: sp-parser p1 ;
|
|
|
|
! Return a parser that first skips all whitespace before
|
|
! calling the original parser.
|
|
C: sp sp-parser
|
|
|
|
M: sp-parser parse ( input parser -- list )
|
|
! Skip all leading whitespace from the input then call
|
|
! the parser on the remaining input.
|
|
[ trim-head-slice ] dip p1>> parse ;
|
|
|
|
TUPLE: just-parser p1 ;
|
|
|
|
C: just just-parser
|
|
|
|
M: just-parser parse ( input parser -- result )
|
|
! Calls the given parser on the input removes
|
|
! from the results anything where the remaining
|
|
! input to be parsed is not empty. So ensures a
|
|
! fully parsed input string.
|
|
p1>> parse [ unparsed>> empty? ] lfilter ;
|
|
|
|
TUPLE: apply-parser p1 quot ;
|
|
|
|
C: <@ apply-parser
|
|
|
|
M: apply-parser parse ( input parser -- result )
|
|
! Calls the parser on the input. For each successful
|
|
! parse the quot is call with the parse result on the stack.
|
|
! The result of that quotation then becomes the new parse result.
|
|
! This allows modification of parse tree results (like
|
|
! converting strings to integers, etc).
|
|
[ p1>> ] [ quot>> ] bi
|
|
-rot parse [
|
|
[ parsed>> swap call ] keep
|
|
unparsed>> <parse-result>
|
|
] with lmap-lazy ;
|
|
|
|
TUPLE: some-parser p1 ;
|
|
|
|
C: some some-parser
|
|
|
|
M: some-parser parse ( input parser -- result )
|
|
! Calls the parser on the input, guarantees
|
|
! the parse is complete (the remaining input is empty),
|
|
! picks the first solution and only returns the parse
|
|
! tree since the remaining input is empty.
|
|
p1>> just parse-1 ;
|
|
|
|
: <& ( parser1 parser2 -- parser )
|
|
! Same as <&> except discard the results of the second parser.
|
|
<&> [ first ] <@ ;
|
|
|
|
: &> ( parser1 parser2 -- parser )
|
|
! Same as <&> except discard the results of the first parser.
|
|
<&> [ second ] <@ ;
|
|
|
|
: <:&> ( parser1 parser2 -- result )
|
|
! Same as <&> except flatten the result.
|
|
<&> [ first2 suffix ] <@ ;
|
|
|
|
: <&:> ( parser1 parser2 -- result )
|
|
! Same as <&> except flatten the result.
|
|
<&> [ first2 swap prefix ] <@ ;
|
|
|
|
: <:&:> ( parser1 parser2 -- result )
|
|
! Same as <&> except flatten the result.
|
|
<&> [ first2 append ] <@ ;
|
|
|
|
LAZY: <*> ( parser -- parser )
|
|
dup <*> <&:> { } succeed <|> ;
|
|
|
|
: <+> ( parser -- parser )
|
|
! Return a parser that accepts one or more occurrences of the original
|
|
! parser.
|
|
dup <*> <&:> ;
|
|
|
|
LAZY: <?> ( parser -- parser )
|
|
! Return a parser that optionally uses the parser
|
|
! if that parser would be successful.
|
|
[ 1array ] <@ f succeed <|> ;
|
|
|
|
TUPLE: only-first-parser p1 ;
|
|
|
|
LAZY: only-first ( parser -- parser )
|
|
only-first-parser boa ;
|
|
|
|
M: only-first-parser parse ( input parser -- list )
|
|
! Transform a parser into a parser that only yields
|
|
! the first possibility.
|
|
p1>> parse 1 swap ltake ;
|
|
|
|
LAZY: <!*> ( parser -- parser )
|
|
! Like <*> but only return one possible result
|
|
! containing all matching parses. Does not return
|
|
! partial matches. Useful for efficiency since that's
|
|
! usually the effect you want and cuts down on backtracking
|
|
! required.
|
|
<*> only-first ;
|
|
|
|
LAZY: <!+> ( parser -- parser )
|
|
! Like <+> but only return one possible result
|
|
! containing all matching parses. Does not return
|
|
! partial matches. Useful for efficiency since that's
|
|
! usually the effect you want and cuts down on backtracking
|
|
! required.
|
|
<+> only-first ;
|
|
|
|
LAZY: <!?> ( parser -- parser )
|
|
! Like <?> but only return one possible result
|
|
! containing all matching parses. Does not return
|
|
! partial matches. Useful for efficiency since that's
|
|
! usually the effect you want and cuts down on backtracking
|
|
! required.
|
|
<?> only-first ;
|
|
|
|
LAZY: <(?)> ( parser -- parser )
|
|
! Like <?> but take shortest match first.
|
|
f succeed swap [ 1array ] <@ <|> ;
|
|
|
|
LAZY: <(*)> ( parser -- parser )
|
|
! Like <*> but take shortest match first.
|
|
! Implementation by Matthew Willis.
|
|
{ } succeed swap dup <(*)> <&:> <|> ;
|
|
|
|
LAZY: <(+)> ( parser -- parser )
|
|
! Like <+> but take shortest match first.
|
|
! Implementation by Matthew Willis.
|
|
dup <(*)> <&:> ;
|
|
|
|
: pack ( close body open -- parser )
|
|
! Parse a construct enclosed by two symbols,
|
|
! given a parser for the opening symbol, the
|
|
! closing symbol, and the body.
|
|
<& &> ;
|
|
|
|
: nonempty-list-of ( items separator -- parser )
|
|
[ over &> <*> <&:> ] keep <?> [ nip ] 2keep pack ;
|
|
|
|
: list-of ( items separator -- parser )
|
|
! Given a parser for the separator and for the
|
|
! items themselves, return a parser that parses
|
|
! lists of those items. The parse tree is an
|
|
! array of the parsed items.
|
|
nonempty-list-of { } succeed <|> ;
|
|
|
|
LAZY: surrounded-by ( parser start end -- parser' )
|
|
[ token ] bi@ swapd pack ;
|
|
|
|
: exactly-n ( parser n -- parser' )
|
|
swap <repetition> <and-parser> [ flatten ] <@ ;
|
|
|
|
: at-most-n ( parser n -- parser' )
|
|
dup zero? [
|
|
2drop epsilon
|
|
] [
|
|
2dup exactly-n
|
|
-rot 1 - at-most-n <|>
|
|
] if ;
|
|
|
|
: at-least-n ( parser n -- parser' )
|
|
dupd exactly-n swap <*> <&> ;
|
|
|
|
: from-m-to-n ( parser m n -- parser' )
|
|
[ [ exactly-n ] 2keep ] dip swap - at-most-n <:&:> ;
|