extra/json/reader/reader.factor

   1 ! Copyright (C) 2006 Chris Double.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel parser-combinators namespaces sequences promises strings
   4        assocs math math.parser math.vectors math.functions
   5        lazy-lists hashtables ascii ;
   6 IN: json.reader
   7
   8 ! Grammar for JSON from RFC 4627
   9
  10 : [<&>] ( quot -- quot )
  11   { } make unclip [ <&> ] reduce ;
  12
  13 : [<|>] ( quot -- quot )
  14   { } make unclip [ <|> ] reduce ;
  15
  16 LAZY: 'ws' ( -- parser )
  17   " " token
  18   "\n" token <|>
  19   "\r" token <|>
  20   "\t" token <|>
  21   "" token <|> ;
  22
  23 LAZY: spaced ( parser -- parser )
  24   'ws' swap &> 'ws' <& ;
  25
  26 LAZY: 'begin-array' ( -- parser )
  27   "[" token spaced ;
  28
  29 LAZY: 'begin-object' ( -- parser )
  30   "{" token spaced ;
  31
  32 LAZY: 'end-array' ( -- parser )
  33   "]" token spaced ;
  34
  35 LAZY: 'end-object' ( -- parser )
  36   "}" token spaced ;
  37
  38 LAZY: 'name-separator' ( -- parser )
  39   ":" token spaced ;
  40
  41 LAZY: 'value-separator' ( -- parser )
  42   "," token spaced ;
  43
  44 LAZY: 'false' ( -- parser )
  45   "false" token ;
  46
  47 LAZY: 'null' ( -- parser )
  48   "null" token ;
  49
  50 LAZY: 'true' ( -- parser )
  51   "true" token ;
  52
  53 LAZY: 'quot' ( -- parser )
  54   "\"" token ;
  55
  56 LAZY: 'string' ( -- parser )
  57   'quot'
  58   [
  59     [ quotable? ] keep
  60     [ CHAR: \\ = or ] keep
  61     CHAR: " = not and
  62   ] satisfy <*> &>
  63   'quot' <& [ >string ] <@  ;
  64
  65 DEFER: 'value'
  66
  67 LAZY: 'member' ( -- parser )
  68   'string'
  69   'name-separator' <&
  70   'value' <&> ;
  71
  72 USE: prettyprint
  73 LAZY: 'object' ( -- parser )
  74   'begin-object'
  75   'member' 'value-separator' list-of &>
  76   'end-object' <& [ >hashtable ] <@ ;
  77
  78 LAZY: 'array' ( -- parser )
  79   'begin-array'
  80   'value' 'value-separator' list-of &>
  81   'end-array' <&  ;
  82
  83 LAZY: 'minus' ( -- parser )
  84   "-" token ;
  85
  86 LAZY: 'plus' ( -- parser )
  87   "+" token ;
  88
  89 LAZY: 'zero' ( -- parser )
  90   "0" token [ drop 0 ] <@ ;
  91
  92 LAZY: 'decimal-point' ( -- parser )
  93   "." token ;
  94
  95 LAZY: 'digit1-9' ( -- parser )
  96   [
  97     dup integer? [
  98       CHAR: 1 CHAR: 9 between?
  99     ] [
 100       drop f
 101     ] if
 102   ] satisfy [ digit> ] <@ ;
 103
 104 LAZY: 'digit0-9' ( -- parser )
 105   [ digit? ] satisfy [ digit> ] <@ ;
 106
 107 : decimal>integer ( seq -- num ) 10 swap digits>integer ;
 108
 109 LAZY: 'int' ( -- parser )
 110   'zero'
 111   'digit1-9' 'digit0-9' <*> <&:> [ decimal>integer ] <@ <|>  ;
 112
 113 LAZY: 'e' ( -- parser )
 114   "e" token "E" token <|> ;
 115
 116 : sign-number ( pair -- number )
 117   #! Pair is { minus? num }
 118   #! Convert the json number value to a factor number
 119   dup second swap first [ -1 * ] when ;
 120
 121 LAZY: 'exp' ( -- parser )
 122     'e'
 123     'minus' 'plus' <|> <?> &>
 124     'digit0-9' <+> [ decimal>integer ] <@ <&> [ sign-number ] <@ ;
 125
 126 : sequence>frac ( seq -- num )
 127   #! { 1 2 3 } => 0.123
 128   reverse 0 [ swap 10 / + ] reduce 10 / >float ;
 129
 130 LAZY: 'frac' ( -- parser )
 131   'decimal-point' 'digit0-9' <+> &> [ sequence>frac ] <@ ;
 132
 133 : raise-to-power ( pair -- num )
 134   #! Pair is { num exp }.
 135   #! Multiply 'num' by 10^exp
 136   dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ;
 137
 138 LAZY: 'number' ( -- parser )
 139   'minus' <?>
 140   [ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@
 141   'exp' <?> <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ;
 142
 143 LAZY: 'value' ( -- parser )
 144   [
 145     'false' ,
 146     'null' ,
 147     'true' ,
 148     'string' ,
 149     'object' ,
 150     'array' ,
 151     'number' ,
 152   ] [<|>] ;
 153
 154 : json> ( string -- object )
 155   #! Parse a json formatted string to a factor object
 156   'value' parse dup nil? [
 157     "Could not parse json" throw
 158   ] [
 159     car parse-result-parsed
 160   ] if ;