basis/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 summary\r
   5 accessors ;\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     get-char [\r
  93         [ call ] keep swap [ drop ] [\r
  94             next skip-until\r
  95         ] if\r
  96     ] [ drop ] if ; inline recursive\r
  97 \r
  98 : take-until ( quot -- string )\r
  99     #! Take the substring of a string starting at spot\r
 100     #! from code until the quotation given is true and\r
 101     #! advance spot to after the substring.\r
 102     10 <sbuf> [\r
 103         '[ @ [ t ] [ get-char , push f ] if ] skip-until\r
 104     ] keep >string ; inline\r
 105 \r
 106 : take-rest ( -- string )\r
 107     [ f ] take-until ;\r
 108 \r
 109 : take-char ( ch -- string )\r
 110     [ dup get-char = ] take-until nip ;\r
 111 \r
 112 TUPLE: not-enough-characters < parsing-error ;\r
 113 : not-enough-characters ( -- * )\r
 114     \ not-enough-characters parsing-error throw ;\r
 115 M: not-enough-characters summary ( obj -- str )\r
 116     [\r
 117         call-next-method write\r
 118         "Not enough characters" print\r
 119     ] with-string-writer ;\r
 120 \r
 121 : take ( n -- string )\r
 122     [ 1- ] [ <sbuf> ] bi [\r
 123         '[ drop get-char [ next , push f ] [ t ] if* ] contains? drop\r
 124     ] keep get-char [ over push ] when* >string ;\r
 125 \r
 126 : pass-blank ( -- )\r
 127     #! Advance code past any whitespace, including newlines\r
 128     [ get-char blank? not ] skip-until ;\r
 129 \r
 130 : string-matches? ( string circular -- ? )\r
 131     get-char over push-circular\r
 132     sequence= ;\r
 133 \r
 134 : take-string ( match -- string )\r
 135     dup length <circular-string>\r
 136     [ 2dup string-matches? ] take-until nip\r
 137     dup length rot length 1- - head\r
 138     get-char [ missing-close ] unless next ;\r
 139 \r
 140 : expect ( ch -- )\r
 141     get-char 2dup = [ 2drop ] [\r
 142         >r 1string r> 1string expected\r
 143     ] if next ;\r
 144 \r
 145 : expect-string ( string -- )\r
 146     dup [ get-char next ] replicate 2dup =\r
 147     [ 2drop ] [ expected ] if ;\r
 148 \r
 149 : init-parser ( -- )\r
 150     0 1 0 f <spot> spot set\r
 151     read1 set-next next ;\r
 152 \r
 153 : state-parse ( stream quot -- )\r
 154     ! with-input-stream implicitly creates a new scope which we use\r
 155     swap [ init-parser call ] with-input-stream ; inline\r
 156 \r
 157 : string-parse ( input quot -- )\r
 158     >r <string-reader> r> state-parse ; inline\r