extra/sequences/parser/parser.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors circular combinators.short-circuit io kernel
   4 math math.order sequences sequences.parser sequences.private
   5 sorting unicode ;
   6 IN: sequences.parser
   7
   8 TUPLE: sequence-parser sequence n ;
   9
  10 : <sequence-parser> ( sequence -- sequence-parser )
  11     sequence-parser new
  12         swap >>sequence
  13         0 >>n ;
  14
  15 :: with-sequence-parser ( sequence-parser quot -- seq/f )
  16     sequence-parser n>> :> n
  17     sequence-parser quot call [
  18         n sequence-parser n<< f
  19     ] unless* ; inline
  20
  21 : offset  ( sequence-parser offset -- char/f )
  22     swap
  23     [ n>> + ] [ sequence>> ?nth ] bi ; inline
  24
  25 : current ( sequence-parser -- char/f ) 0 offset ; inline
  26
  27 : previous ( sequence-parser -- char/f ) -1 offset ; inline
  28
  29 : peek-next ( sequence-parser -- char/f ) 1 offset ; inline
  30
  31 : advance ( sequence-parser -- sequence-parser )
  32     [ 1 + ] change-n ; inline
  33
  34 : consume ( sequence-parser -- char/f )
  35     [ current ] [ advance drop ] bi ; inline
  36
  37 : next ( sequence-parser -- char/f )
  38     [ advance drop ] [ current ] bi ; inline
  39
  40 :: skip-until ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... )
  41     sequence-parser current [
  42         sequence-parser quot call
  43         [ sequence-parser advance quot skip-until ] unless
  44     ] when ; inline recursive
  45
  46 : sequence-parse-end? ( sequence-parser -- ? ) current not ;
  47
  48 : take-until ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... sequence/f )
  49     over sequence-parse-end? [
  50         2drop f
  51     ] [
  52         [ drop n>> ]
  53         [ skip-until ]
  54         [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
  55     ] if ; inline
  56
  57 : take-while ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... sequence/f )
  58     [ not ] compose take-until ; inline
  59
  60 : <safe-slice> ( from to seq -- slice/f )
  61     3dup {
  62         [ 2drop 0 < ]
  63         [ nipd length > ]
  64         [ drop > ]
  65     } 3|| [ 3drop f ] [ <slice-unsafe> ] if ; inline
  66
  67 :: take-sequence ( sequence-parser sequence -- obj/f )
  68     sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
  69     <safe-slice> sequence sequence= [
  70         sequence
  71         sequence-parser [ sequence length + ] change-n drop
  72     ] [
  73         f
  74     ] if ;
  75
  76 : take-sequence* ( sequence-parser sequence -- )
  77     take-sequence drop ;
  78
  79 :: take-until-sequence ( sequence-parser sequence -- sequence'/f )
  80     sequence-parser n>> :> saved
  81     sequence length <growing-circular> :> growing
  82     sequence-parser
  83     [
  84         current growing growing-circular-push
  85         sequence growing sequence=
  86     ] take-until :> found
  87     growing sequence sequence= [
  88         found dup length
  89         growing length 1 - - head
  90         sequence-parser [ growing length - 1 + ] change-n drop
  91         ! sequence-parser advance drop
  92     ] [
  93         saved sequence-parser n<<
  94         f
  95     ] if ;
  96
  97 :: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
  98     sequence-parser sequence take-until-sequence :> out
  99     out [
 100         sequence-parser [ sequence length + ] change-n drop
 101     ] when out ;
 102
 103 : skip-whitespace ( sequence-parser -- sequence-parser )
 104     [ [ current blank? not ] take-until drop ] keep ;
 105
 106 : skip-whitespace-eol ( sequence-parser -- sequence-parser )
 107     [ [ current " \t\r" member? not ] take-until drop ] keep ;
 108
 109 : take-rest-slice ( sequence-parser -- sequence/f )
 110     [ sequence>> ] [ n>> ] bi
 111     2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
 112
 113 : take-rest ( sequence-parser -- sequence )
 114     [ take-rest-slice ] [ sequence>> like ] bi f like ;
 115
 116 : take-until-object ( sequence-parser obj -- sequence )
 117     '[ current _ = ] take-until ;
 118
 119 : parse-sequence ( sequence quot -- )
 120     [ <sequence-parser> ] dip call ; inline
 121
 122 : take-integer ( sequence-parser -- n/f )
 123     [ current digit? ] take-while ;
 124
 125 :: take-n ( sequence-parser n -- seq/f )
 126     n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
 127         sequence-parser take-rest
 128     ] [
 129         sequence-parser n>> dup n + sequence-parser sequence>> subseq
 130         sequence-parser [ n + ] change-n drop
 131     ] if ;
 132
 133 : sort-tokens ( seq -- seq' ) [ length ] inv-sort-by ;
 134
 135 : take-first-matching ( sequence-parser seq -- seq )
 136     swap
 137     '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
 138
 139 : take-longest ( sequence-parser seq -- seq )
 140     sort-tokens take-first-matching ;
 141
 142 : write-full ( sequence-parser -- ) sequence>> write ;
 143 : write-rest ( sequence-parser -- ) take-rest write ;