basis/calendar/parser/parser.factor

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