contrib/json/json-reader.factor

   1 ! Copyright (C) 2006 Chris Double.
   2 !
   3 ! Redistribution and use in source and binary forms, with or without
   4 ! modification, are permitted provided that the following conditions are met:
   5 !
   6 ! 1. Redistributions of source code must retain the above copyright notice,
   7 !    this list of conditions and the following disclaimer.
   8 !
   9 ! 2. Redistributions in binary form must reproduce the above copyright notice,
  10 !    this list of conditions and the following disclaimer in the documentation
  11 !    and/or other materials provided with the distribution.
  12 !
  13 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
  14 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
  15 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  16 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  17 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  18 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
  19 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  20 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  21 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  22 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  23 !
  24 USING: kernel namespaces sequences strings math hashtables parser-combinators lazy-lists ;
  25 IN: json
  26
  27 ! Grammar for JSON from RFC 4627
  28 USE: tools
  29
  30 : [<&>] ( quot - quot )
  31   { } make unclip [ <&> ] reduce ;
  32
  33 : [<|>] ( quot - quot )
  34   { } make unclip [ <|> ] reduce ;
  35
  36 LAZY: 'ws' ( -- parser )
  37   " " token
  38   "\n" token <|>
  39   "\r" token <|>
  40   "\t" token <|>
  41   "" token <|> ;
  42
  43 LAZY: spaced ( parser -- parser )
  44   'ws' swap &> 'ws' <& ;
  45
  46 LAZY: 'begin-array' ( -- parser )
  47   "[" token spaced ;
  48
  49 LAZY: 'begin-object' ( -- parser )
  50   "{" token spaced ;
  51
  52 LAZY: 'end-array' ( -- parser )
  53   "]" token spaced ;
  54
  55 LAZY: 'end-object' ( -- parser )
  56   "}" token spaced ;
  57
  58 LAZY: 'name-separator' ( -- parser )
  59   ":" token spaced ;
  60
  61 LAZY: 'value-separator' ( -- parser )
  62   "," token spaced ;
  63
  64 LAZY: 'false' ( -- parser )
  65   "false" token ;
  66
  67 LAZY: 'null' ( -- parser )
  68   "null" token ;
  69
  70 LAZY: 'true' ( -- parser )
  71   "true" token ;
  72
  73 LAZY: 'quot' ( -- parser )
  74   "\"" token ;
  75
  76 LAZY: 'string' ( -- parser )
  77   'quot'
  78   [ quotable? ] satisfy <+> &>
  79   'quot' <& [ >string ] <@  ;
  80
  81 DEFER: 'value'
  82
  83 LAZY: 'member' ( -- parser )
  84   'string'
  85   'name-separator' <&
  86   'value' <&> ;
  87
  88 : object>hashtable ( object -- hashtable )
  89   #! Convert json object to hashtable
  90   H{ } clone dup rot [ dup second swap first rot set-hash ] each-with ;
  91
  92 LAZY: 'object' ( -- parser )
  93   'begin-object'
  94   'member' &>
  95   'value-separator' 'member' &> <*> <&:>
  96   'end-object' <& [ object>hashtable ] <@ ;
  97
  98 LAZY: 'array' ( -- parser )
  99   'begin-array'
 100   'value' &>
 101   'value-separator' 'value' &> <*> <&:>
 102   'end-array' <&  ;
 103
 104 LAZY: 'minus' ( -- parser )
 105   "-" token ;
 106
 107 LAZY: 'plus' ( -- parser )
 108   "+" token ;
 109
 110 LAZY: 'zero' ( -- parser )
 111   "0" token [ drop 0 ] <@ ;
 112
 113 LAZY: 'decimal-point' ( -- parser )
 114   "." token ;
 115
 116 LAZY: 'digit1-9' ( -- parser )
 117   [
 118     dup integer? [
 119       CHAR: 1 CHAR: 9 between?
 120     ] [
 121       drop f
 122     ] if
 123   ] satisfy [ digit> ] <@ ;
 124
 125 LAZY: 'digit0-9' ( -- parser )
 126   [ digit? ] satisfy [ digit> ] <@ ;
 127
 128 : sequence>number ( seq -- num )
 129   #! { 1 2 3 } => 123
 130   0 [ swap 10 * + ] reduce ;
 131
 132 LAZY: 'int' ( -- parser )
 133   'zero'
 134   'digit1-9' 'digit0-9' <*> <&:> [ sequence>number ] <@ <|>  ;
 135
 136 LAZY: 'e' ( -- parser )
 137   "e" token "E" token <|> ;
 138
 139 : sign-number ( { minus? num } -- number )
 140   #! Convert the json number value to a factor number
 141   dup second swap first [ -1 * ] when ;
 142
 143 LAZY: 'exp' ( -- parser )
 144     'e'
 145     'minus' 'plus' <|> <?> &>
 146     'digit0-9' <+> [ sequence>number ] <@ <&> [ sign-number ] <@ ;
 147
 148 : sequence>frac ( seq -- num )
 149   #! { 1 2 3 } => 0.123
 150   reverse 0 [ swap 10 / + ] reduce 10 / >float ;
 151
 152 LAZY: 'frac' ( -- parser )
 153   'decimal-point' 'digit0-9' <+> &> [ sequence>frac ] <@ ;
 154
 155 : raise-to-power ( { num exp } -- num )
 156   #! Multiply 'num' by 10^exp
 157   dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ;
 158
 159 LAZY: 'number' ( -- parser )
 160   'minus' <?>
 161   [ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@
 162   'exp' <?> <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ;
 163
 164 LAZY: 'value' ( -- parser )
 165   [
 166     'false' ,
 167     'null' ,
 168     'true' ,
 169     'string' ,
 170     'object' ,
 171     'array' ,
 172     'number' ,
 173   ] [<|>] ;
 174
 175 : json> ( string -- object )
 176   #! Parse a json formatted string to a factor object
 177   'value' some parse force ;