basis/calendar/parser/parser.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs calendar calendar.english combinators
   4 continuations generalizations io io.streams.string kernel macros math
   5 math.functions math.parser sequences ;
   6 IN: calendar.parser
   7
   8 : read-00 ( -- n ) 2 read string>number ;
   9
  10 : read-000 ( -- n ) 3 read string>number ;
  11
  12 : read-0000 ( -- n ) 4 read string>number ;
  13
  14 : expect ( str -- )
  15     read1 swap member? [ "Parse error" throw ] unless ;
  16
  17 ERROR: invalid-timestamp-format ;
  18
  19 : check-timestamp ( obj/f -- obj )
  20     [ invalid-timestamp-format ] unless* ;
  21
  22 : checked-number ( str -- n )
  23     string>number check-timestamp ;
  24
  25 : read-token ( seps -- token )
  26     [ read-until ] keep member? check-timestamp drop ;
  27
  28 : read-sp ( -- token ) " " read-token ;
  29
  30 : signed-gmt-offset ( dt ch -- dt' )
  31     { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
  32
  33 : read-rfc3339-gmt-offset ( ch -- dt )
  34     {
  35         { f [ instant ] }
  36         { CHAR: Z [ instant ] }
  37         [
  38             [
  39                 read-00 hours
  40                 read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
  41                 time+
  42             ] dip signed-gmt-offset
  43         ]
  44     } case ;
  45
  46 : read-ymd ( -- y m d )
  47     read-0000 "-" expect read-00 "-" expect read-00 ;
  48
  49 : read-hms ( -- h m s )
  50     read-00 ":" expect read-00 ":" expect read-00 ;
  51
  52 : read-rfc3339-seconds ( s -- s' ch )
  53     "+-Z" read-until [
  54         [ string>number ] [ length 10^ ] bi / +
  55     ] dip ;
  56
  57 : (rfc3339>timestamp) ( -- timestamp )
  58     read-ymd
  59     "Tt \t" expect
  60     read-hms
  61     read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case
  62     read-rfc3339-gmt-offset
  63     <timestamp> ;
  64
  65 : rfc3339>timestamp ( str -- timestamp )
  66     [ (rfc3339>timestamp) ] with-string-reader ;
  67
  68 : parse-rfc822-military-offset ( string -- dt )
  69     first CHAR: A - {
  70         -1 -2 -3 -4 -5 -6 -7 -8 -9 f -10 -11 -12
  71         1 2 3 4 5 6 7 8 9 10 11 12 0
  72     } nth hours ;
  73
  74 CONSTANT: rfc822-named-zones H{
  75     { "EST" -5 }
  76     { "EDT" -4 }
  77     { "CST" -6 }
  78     { "CDT" -5 }
  79     { "MST" -7 }
  80     { "MDT" -6 }
  81     { "PST" -8 }
  82     { "PDT" -7 }
  83 }
  84
  85 : parse-rfc822-gmt-offset ( string -- dt )
  86     {
  87         { [ dup { "UTC" "GMT" } member? ] [ drop instant ] }
  88         { [ dup length 1 = ] [ parse-rfc822-military-offset ] }
  89         { [ dup rfc822-named-zones key? ] [ rfc822-named-zones at hours ] }
  90         [
  91             unclip [
  92                 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
  93             ] dip signed-gmt-offset
  94         ]
  95     } cond ;
  96
  97 : read-hh:mm:ss ( -- hh mm ss )
  98     ":" read-token checked-number
  99     ":" read-token checked-number
 100     read-sp checked-number ;
 101
 102 : (rfc822>timestamp) ( -- timestamp )
 103     "," read-token day-abbreviations3 member? check-timestamp drop
 104     read1 CHAR: \s assert=
 105     read-sp checked-number
 106     read-sp month-abbreviations index 1 + check-timestamp
 107     read-sp checked-number spin
 108     read-hh:mm:ss
 109     " " read-until drop parse-rfc822-gmt-offset <timestamp> ;
 110
 111 : rfc822>timestamp ( str -- timestamp )
 112     [ (rfc822>timestamp) ] with-string-reader ;
 113
 114 : check-day-name ( str -- )
 115     [ day-abbreviations3 member? ] [ day-names member? ] bi or
 116     check-timestamp drop ;
 117
 118 : (cookie-string>timestamp-1) ( -- timestamp )
 119     "," read-token check-day-name
 120     read1 CHAR: \s assert=
 121     "-" read-token checked-number
 122     "-" read-token month-abbreviations index 1 + check-timestamp
 123     read-sp checked-number spin
 124     read-hh:mm:ss
 125     " " read-until drop parse-rfc822-gmt-offset <timestamp> ;
 126
 127 : cookie-string>timestamp-1 ( str -- timestamp )
 128     [ (cookie-string>timestamp-1) ] with-string-reader ;
 129
 130 : (cookie-string>timestamp-2) ( -- timestamp )
 131     read-sp check-day-name
 132     read-sp month-abbreviations index 1 + check-timestamp
 133     read-sp checked-number
 134     read-hh:mm:ss
 135     [ read-sp checked-number ] 5 ndip
 136     " " read-until drop parse-rfc822-gmt-offset <timestamp> ;
 137
 138 : cookie-string>timestamp-2 ( str -- timestamp )
 139     [ (cookie-string>timestamp-2) ] with-string-reader ;
 140
 141 MACRO: attempt-all-quots ( quots -- quot )
 142     dup length 1 = [ first ] [
 143         unclip swap
 144         [ nip attempt-all-quots ] curry
 145         [ recover ] 2curry
 146     ] if ;
 147
 148 : cookie-string>timestamp ( str -- timestamp )
 149     {
 150         [ cookie-string>timestamp-1 ]
 151         [ cookie-string>timestamp-2 ]
 152         [ rfc822>timestamp ]
 153     } attempt-all-quots ;
 154
 155 : (ymdhms>timestamp) ( -- timestamp )
 156     read-ymd " " expect read-hms instant <timestamp> ;
 157
 158 : ymdhms>timestamp ( str -- timestamp )
 159     [ (ymdhms>timestamp) ] with-string-reader ;
 160
 161 : (ymd>timestamp) ( -- timestamp )
 162     read-ymd <date-gmt> ;
 163
 164 : ymd>timestamp ( str -- timestamp )
 165     [ (ymd>timestamp) ] with-string-reader ;
 166
 167 ! Duration parsing
 168 : hhmm>duration ( hhmm -- duration )
 169     [ instant read-00 >>hour read-00 >>minute ] with-string-reader ;
 170
 171 : hms>duration ( str -- duration )
 172     [ 0 0 0 read-hms <duration> ] with-string-reader ;