unmaintained/peg-lexer/peg-lexer.factor

   1 USING: hashtables assocs sequences locals math accessors multiline delegate strings
   2 delegate.protocols kernel peg peg.ebnf peg.private lexer namespaces combinators parser
   3 words ;
   4 IN: peg-lexer
   5
   6 TUPLE: lex-hash hash ;
   7 CONSULT: assoc-protocol lex-hash hash>> ;
   8 : <lex-hash> ( a -- lex-hash ) lex-hash boa ;
   9
  10 : pos-or-0 ( neg? -- pos/0 ) dup 0 < [ drop 0 ] when ;
  11
  12 :: prepare-pos ( v i -- c l )
  13     [let | n [ i v head-slice ] |
  14            v CHAR: \n n last-index -1 or 1 + -
  15            n [ CHAR: \n = ] count 1 +
  16     ] ;
  17
  18 : store-pos ( v a -- )
  19     input of prepare-pos
  20     lexer get [ line<< ] keep column<< ;
  21
  22 M: lex-hash set-at
  23     swap {
  24         { pos [ store-pos ] }
  25         [ swap hash>> set-at ]
  26     } case ;
  27
  28 :: at-pos ( t l c -- p ) t l head-slice [ length ] map-sum l 1 - + c + ;
  29
  30 M: lex-hash at*
  31     swap {
  32       { input [ drop lexer get text>> "\n" join t ] }
  33       { pos [ drop lexer get [ text>> ] [ line>> 1 - ] [ column>> 1 + ] tri at-pos t ] }
  34       [ swap hash>> at* ]
  35     } case ;
  36
  37 : with-global-lexer ( quot -- result )
  38    [
  39        f lrstack set
  40        V{ } clone error-stack set H{ } clone \ heads set
  41        H{ } clone \ packrat set
  42    ] f make-assoc <lex-hash>
  43    swap bind ; inline
  44
  45 : parse* ( parser -- ast )
  46     compile
  47     [ execute [ error-stack get first throw ] unless* ] with-global-lexer
  48     ast>> ; inline
  49
  50 : create-bnf ( name parser -- )
  51     reset-tokenizer [ lexer get skip-blank parse* dup ignore? [ drop ] [ parsed ] if ] curry
  52     define-syntax word make-inline ;
  53
  54 SYNTAX: ON-BNF:
  55     scan-new-word reset-tokenizer ";ON-BNF" parse-multiline-string parse-ebnf
  56     main of create-bnf ;
  57
  58 ! Tokenizer like standard factor lexer
  59 EBNF: factor
  60 space = " " | "\n" | "\t"
  61 spaces = space* => [[ drop ignore ]]
  62 chunk = (!(space) .)+ => [[ >string ]]
  63 expr = spaces chunk
  64 ;EBNF