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 unicode.categories ;\r
   5 IN: state-parser\r
   6 \r
   7 ! * Basic underlying words\r
   8 ! Code stored in stdio\r
   9 ! Spot is composite so it won't be lost in sub-scopes\r
  10 TUPLE: spot char line column next ;\r
  11 \r
  12 C: <spot> spot\r
  13 \r
  14 : get-char ( -- char ) spot get spot-char ;\r
  15 : set-char ( char -- ) spot get set-spot-char ;\r
  16 : get-line ( -- line ) spot get spot-line ;\r
  17 : set-line ( line -- ) spot get set-spot-line ;\r
  18 : get-column ( -- column ) spot get spot-column ;\r
  19 : set-column ( column -- ) spot get set-spot-column ;\r
  20 : get-next ( -- char ) spot get spot-next ;\r
  21 : set-next ( char -- ) spot get set-spot-next ;\r
  22 \r
  23 ! * Errors\r
  24 TUPLE: parsing-error line column ;\r
  25 : <parsing-error> ( -- parsing-error )\r
  26     get-line get-column parsing-error construct-boa ;\r
  27 \r
  28 : construct-parsing-error ( ... slots class -- error )\r
  29     construct <parsing-error> over set-delegate ; inline\r
  30 \r
  31 : parsing-error. ( parsing-error -- )\r
  32     "Parsing error" print\r
  33     "Line: " write dup parsing-error-line .\r
  34     "Column: " write parsing-error-column . ;\r
  35 \r
  36 TUPLE: expected should-be was ;\r
  37 : <expected> ( should-be was -- error )\r
  38     { set-expected-should-be set-expected-was }\r
  39     expected construct-parsing-error ;\r
  40 M: expected error.\r
  41     dup parsing-error.\r
  42     "Token expected: " write dup expected-should-be print\r
  43     "Token present: " write expected-was print ;\r
  44 \r
  45 TUPLE: unexpected-end ;\r
  46 : <unexpected-end> ( -- unexpected-end )\r
  47     { } unexpected-end construct-parsing-error ;\r
  48 M: unexpected-end error.\r
  49     parsing-error.\r
  50     "File unexpectedly ended." print ;\r
  51 \r
  52 TUPLE: missing-close ;\r
  53 : <missing-close> ( -- missing-close )\r
  54     { } missing-close construct-parsing-error ;\r
  55 M: missing-close error.\r
  56     parsing-error.\r
  57     "Missing closing token." print ;\r
  58 \r
  59 SYMBOL: prolog-data\r
  60 \r
  61 ! * Basic utility words\r
  62 \r
  63 : record ( char -- )\r
  64     CHAR: \n =\r
  65     [ 0 get-line 1+ set-line ] [ get-column 1+ ] if\r
  66     set-column ;\r
  67 \r
  68 : (next) ( -- char ) ! this normalizes \r\n and \r\r
  69     get-next read1\r
  70     2dup swap CHAR: \r = [\r
  71         CHAR: \n =\r
  72         [ nip read1 ] [ nip CHAR: \n swap ] if\r
  73     ] [ drop ] if\r
  74     set-next dup set-char ;\r
  75 \r
  76 : next ( -- )\r
  77     #! Increment spot.\r
  78     get-char [\r
  79         <unexpected-end> throw\r
  80     ] unless\r
  81     (next) record ;\r
  82 \r
  83 : next* ( -- )\r
  84     get-char [ (next) record ] when ;\r
  85 \r
  86 : skip-until ( quot -- )\r
  87     #! quot: ( -- ? )\r
  88     get-char [\r
  89         [ call ] keep swap [ drop ] [\r
  90             next skip-until\r
  91         ] if\r
  92     ] [ drop ] if ; inline\r
  93 \r
  94 : take-until ( quot -- string )\r
  95     #! Take the substring of a string starting at spot\r
  96     #! from code until the quotation given is true and\r
  97     #! advance spot to after the substring.\r
  98     [ [\r
  99         dup slip swap dup [ get-char , ] unless\r
 100     ] skip-until ] "" make nip ;\r
 101 \r
 102 : rest ( -- string )\r
 103     [ f ] take-until ;\r
 104 \r
 105 : take-char ( ch -- string )\r
 106     [ dup get-char = ] take-until nip ;\r
 107 \r
 108 : pass-blank ( -- )\r
 109     #! Advance code past any whitespace, including newlines\r
 110     [ get-char blank? not ] skip-until ;\r
 111 \r
 112 : string-matches? ( string circular -- ? )\r
 113     get-char over push-circular\r
 114     sequence= ;\r
 115 \r
 116 : take-string ( match -- string )\r
 117     dup length <circular-string>\r
 118     [ 2dup string-matches? ] take-until nip\r
 119     dup length rot length 1- - head\r
 120     get-char [ <missing-close> throw ] unless next ;\r
 121 \r
 122 : expect ( ch -- )\r
 123     get-char 2dup = [ 2drop ] [\r
 124         >r 1string r> 1string <expected> throw\r
 125     ] if next ;\r
 126 \r
 127 : expect-string ( string -- )\r
 128     dup [ drop get-char next ] map 2dup =\r
 129     [ 2drop ] [ <expected> throw ] if ;\r
 130 \r
 131 : init-parser ( -- )\r
 132     0 1 0 f <spot> spot set\r
 133     read1 set-next next ;\r
 134 \r
 135 : state-parse ( stream quot -- )\r
 136     ! with-stream implicitly creates a new scope which we use\r
 137     swap [ init-parser call ] with-stream ; inline\r
 138 \r
 139 : string-parse ( input quot -- )\r
 140     >r <string-reader> r> state-parse ; inline\r