extra/peg-lexer/peg-lexer.factor

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