extra/state-parser/state-parser.factor

   1 ! Copyright (C) 2005, 2006 Daniel Ehrenberg\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: io io.streams.string kernel math namespaces sequences\r
   4 strings circular prettyprint debugger ascii sbufs fry inspector\r
   5 accessors sequences.lib ;\r
   6 IN: state-parser\r
   7 \r
   8 ! * Basic underlying words\r
   9 ! Code stored in stdio\r
  10 ! Spot is composite so it won't be lost in sub-scopes\r
  11 TUPLE: spot char line column next ;\r
  12 \r
  13 C: <spot> spot\r
  14 \r
  15 : get-char ( -- char ) spot get char>> ;\r
  16 : set-char ( char -- ) spot get swap >>char drop ;\r
  17 : get-line ( -- line ) spot get line>> ;\r
  18 : set-line ( line -- ) spot get swap >>line drop ;\r
  19 : get-column ( -- column ) spot get column>> ;\r
  20 : set-column ( column -- ) spot get swap >>column drop ;\r
  21 : get-next ( -- char ) spot get next>> ;\r
  22 : set-next ( char -- ) spot get swap >>next drop ;\r
  23 \r
  24 ! * Errors\r
  25 TUPLE: parsing-error line column ;\r
  26 \r
  27 : parsing-error ( class -- obj )\r
  28     new\r
  29         get-line >>line\r
  30         get-column >>column ;\r
  31 M: parsing-error summary ( obj -- str )\r
  32     [\r
  33         "Parsing error" print\r
  34         "Line: " write dup line>> .\r
  35         "Column: " write column>> .\r
  36     ] with-string-writer ;\r
  37 \r
  38 TUPLE: expected < parsing-error should-be was ;\r
  39 : expected ( should-be was -- * )\r
  40     \ expected parsing-error\r
  41         swap >>was\r
  42         swap >>should-be throw ;\r
  43 M: expected summary ( obj -- str )\r
  44     [\r
  45         dup call-next-method write\r
  46         "Token expected: " write dup should-be>> print\r
  47         "Token present: " write was>> print\r
  48     ] with-string-writer ;\r
  49 \r
  50 TUPLE: unexpected-end < parsing-error ;\r
  51 : unexpected-end ( -- * ) \ unexpected-end parsing-error throw ;\r
  52 M: unexpected-end summary ( obj -- str )\r
  53     [\r
  54         call-next-method write\r
  55         "File unexpectedly ended." print\r
  56     ] with-string-writer ;\r
  57 \r
  58 TUPLE: missing-close < parsing-error ;\r
  59 : missing-close ( -- * ) \ missing-close parsing-error throw ;\r
  60 M: missing-close summary ( obj -- str )\r
  61     [\r
  62         call-next-method write\r
  63         "Missing closing token." print\r
  64     ] with-string-writer ;\r
  65 \r
  66 SYMBOL: prolog-data\r
  67 \r
  68 ! * Basic utility words\r
  69 \r
  70 : record ( char -- )\r
  71     CHAR: \n =\r
  72     [ 0 get-line 1+ set-line ] [ get-column 1+ ] if\r
  73     set-column ;\r
  74 \r
  75 ! (next) normalizes \r\n and \r\r
  76 : (next) ( -- char )\r
  77     get-next read1\r
  78     2dup swap CHAR: \r = [\r
  79         CHAR: \n =\r
  80         [ nip read1 ] [ nip CHAR: \n swap ] if\r
  81     ] [ drop ] if\r
  82     set-next dup set-char ;\r
  83 \r
  84 : next ( -- )\r
  85     #! Increment spot.\r
  86     get-char [ unexpected-end ] unless (next) record ;\r
  87 \r
  88 : next* ( -- )\r
  89     get-char [ (next) record ] when ;\r
  90 \r
  91 : skip-until ( quot -- )\r
  92     #! quot: ( -- ? )\r
  93     get-char [\r
  94         [ call ] keep swap [ drop ] [\r
  95             next skip-until\r
  96         ] if\r
  97     ] [ drop ] if ; inline\r
  98 \r
  99 : take-until ( quot -- string )\r
 100     #! Take the substring of a string starting at spot\r
 101     #! from code until the quotation given is true and\r
 102     #! advance spot to after the substring.\r
 103     10 <sbuf> [\r
 104         '[ @ [ t ] [ get-char , push f ] if ] skip-until\r
 105     ] keep >string ; inline\r
 106 \r
 107 : take-rest ( -- string )\r
 108     [ f ] take-until ;\r
 109 \r
 110 : take-char ( ch -- string )\r
 111     [ dup get-char = ] take-until nip ;\r
 112 \r
 113 TUPLE: not-enough-characters < parsing-error ;\r
 114 : not-enough-characters ( -- * )\r
 115     \ not-enough-characters parsing-error throw ;\r
 116 M: not-enough-characters summary ( obj -- str )\r
 117     [\r
 118         call-next-method write\r
 119         "Not enough characters" print\r
 120     ] with-string-writer ;\r
 121 \r
 122 : take ( n -- string )\r
 123     [ 1- ] [ <sbuf> ] bi [\r
 124         '[ drop get-char [ next , push f ] [ t ] if* ] attempt-each drop\r
 125     ] keep get-char [ over push ] when* >string ;\r
 126 \r
 127 : pass-blank ( -- )\r
 128     #! Advance code past any whitespace, including newlines\r
 129     [ get-char blank? not ] skip-until ;\r
 130 \r
 131 : string-matches? ( string circular -- ? )\r
 132     get-char over push-circular\r
 133     sequence= ;\r
 134 \r
 135 : take-string ( match -- string )\r
 136     dup length <circular-string>\r
 137     [ 2dup string-matches? ] take-until nip\r
 138     dup length rot length 1- - head\r
 139     get-char [ missing-close ] unless next ;\r
 140 \r
 141 : expect ( ch -- )\r
 142     get-char 2dup = [ 2drop ] [\r
 143         >r 1string r> 1string expected\r
 144     ] if next ;\r
 145 \r
 146 : expect-string ( string -- )\r
 147     dup [ drop get-char next ] map 2dup =\r
 148     [ 2drop ] [ expected ] if ;\r
 149 \r
 150 : init-parser ( -- )\r
 151     0 1 0 f <spot> spot set\r
 152     read1 set-next next ;\r
 153 \r
 154 : state-parse ( stream quot -- )\r
 155     ! with-input-stream implicitly creates a new scope which we use\r
 156     swap [ init-parser call ] with-input-stream ; inline\r
 157 \r
 158 : string-parse ( input quot -- )\r
 159     >r <string-reader> r> state-parse ; inline\r