basis/formatting/formatting.factor

   1 ! Copyright (C) 2008 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3 USING: accessors arrays assocs calendar combinators fry kernel
   4 generalizations io io.streams.string macros math math.functions
   5 math.parser peg.ebnf quotations sequences splitting strings
   6 unicode.categories unicode.case vectors combinators.smart ;
   7 IN: formatting
   8
   9 <PRIVATE
  10
  11 : compose-all ( seq -- quot )
  12     [ ] [ compose ] reduce ;
  13
  14 : fix-sign ( string -- string )
  15     dup CHAR: 0 swap index 0 =
  16       [ dup 0 swap [ [ CHAR: 0 = not ] keep digit? and ] find-from
  17          [ dup 1 - rot dup [ nth ] dip swap
  18             {
  19                { CHAR: - [ [ 1 - ] dip remove-nth "-" prepend ] }
  20                { CHAR: + [ [ 1 - ] dip remove-nth "+" prepend ] }
  21                [ drop swap drop ]
  22             } case
  23          ] [ drop ] if
  24       ] when ;
  25
  26 : >digits ( string -- digits )
  27     [ 0 ] [ string>number ] if-empty ;
  28
  29 : pad-digits ( string digits -- string' )
  30     [ "." split1 ] dip [ CHAR: 0 pad-tail ] [ head-slice ] bi "." glue ;
  31
  32 : max-digits ( n digits -- n' )
  33     10^ [ * round ] keep / ; inline
  34
  35 : >exp ( x -- exp base )
  36     [
  37         abs 0 swap
  38         [ dup [ 10.0 >= ] [ 1.0 < ] bi or ]
  39         [ dup 10.0 >=
  40           [ 10.0 / [ 1 + ] dip ]
  41           [ 10.0 * [ 1 - ] dip ] if
  42         ] while
  43      ] keep 0 < [ neg ] when ;
  44
  45 : exp>string ( exp base digits -- string )
  46     [ max-digits ] keep -rot
  47     [
  48         [ 0 < "-" "+" ? ]
  49         [ abs number>string 2 CHAR: 0 pad-head ] bi
  50         "e" -rot 3append
  51     ]
  52     [ number>string ] bi*
  53     rot pad-digits prepend ;
  54
  55 EBNF: parse-printf
  56
  57 zero      = "0"                  => [[ CHAR: 0 ]]
  58 char      = "'" (.)              => [[ second ]]
  59
  60 pad-char  = (zero|char)?         => [[ CHAR: \s or ]]
  61 pad-align = ("-")?               => [[ \ pad-tail \ pad-head ? ]]
  62 pad-width = ([0-9])*             => [[ >digits ]]
  63 pad       = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 = [ drop [ ] ] when ]]
  64
  65 sign      = ("+")?               => [[ [ dup CHAR: - swap index [ "+" prepend ] unless ] [ ] ? ]]
  66
  67 width_    = "." ([0-9])*         => [[ second >digits '[ _ short head ] ]]
  68 width     = (width_)?            => [[ [ ] or ]]
  69
  70 digits_   = "." ([0-9])*         => [[ second >digits ]]
  71 digits    = (digits_)?           => [[ 6 or ]]
  72
  73 fmt-%     = "%"                  => [[ [ "%" ] ]]
  74 fmt-c     = "c"                  => [[ [ 1string ] ]]
  75 fmt-C     = "C"                  => [[ [ 1string >upper ] ]]
  76 fmt-s     = "s"                  => [[ [ dup number? [ number>string ] when ] ]]
  77 fmt-S     = "S"                  => [[ [ dup number? [ number>string ] when >upper ] ]]
  78 fmt-d     = "d"                  => [[ [ >fixnum number>string ] ]]
  79 fmt-e     = digits "e"           => [[ first '[ >exp _ exp>string ] ]]
  80 fmt-E     = digits "E"           => [[ first '[ >exp _ exp>string >upper ] ]]
  81 fmt-f     = digits "f"           => [[ first dup '[ >float _ max-digits number>string _ pad-digits ] ]]
  82 fmt-x     = "x"                  => [[ [ >hex ] ]]
  83 fmt-X     = "X"                  => [[ [ >hex >upper ] ]]
  84 unknown   = (.)*                 => [[ "Unknown directive" throw ]]
  85
  86 strings_  = fmt-c|fmt-C|fmt-s|fmt-S
  87 strings   = pad width strings_   => [[ reverse compose-all ]]
  88
  89 numbers_  = fmt-d|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X
  90 numbers   = sign pad numbers_    => [[ unclip-last prefix compose-all [ fix-sign ] append ]]
  91
  92 types     = strings|numbers
  93
  94 lists     = "[%" types ", %]"    => [[ second '[ _ map ", " join "{ " prepend " }" append ] ]]
  95
  96 assocs    = "[%" types ": %" types " %]" => [[ [ second ] [ fourth ] bi '[ unzip [ _ map ] dip _ map zip [ ":" join ] map ", " join "{ " prepend " }" append ] ]]
  97
  98 formats   = "%" (types|fmt-%|lists|assocs|unknown) => [[ second '[ _ dip ] ]]
  99
 100 plain-text = (!("%").)+          => [[ >string '[ _ swap ] ]]
 101
 102 text      = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
 103
 104 ;EBNF
 105
 106 PRIVATE>
 107
 108 MACRO: printf ( format-string -- )
 109     parse-printf [ length ] keep compose-all '[ _ <vector> @ reverse [ write ] each ] ;
 110
 111 : sprintf ( format-string -- result )
 112     [ printf ] with-string-writer ; inline
 113
 114 <PRIVATE
 115
 116 : pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline
 117
 118 : pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-head ; inline
 119
 120 : >time ( timestamp -- string )
 121     [ hour>> ] [ minute>> ] [ second>> floor ] tri 3array
 122     [ pad-00 ] map ":" join ; inline
 123
 124 : >date ( timestamp -- string )
 125     [ month>> ] [ day>> ] [ year>> ] tri 3array
 126     [ pad-00 ] map "/" join ; inline
 127
 128 : >datetime ( timestamp -- string )
 129     [
 130        {
 131           [ day-of-week day-abbreviation3 ]
 132           [ month>> month-abbreviation ]
 133           [ day>> pad-00 ]
 134           [ >time ]
 135           [ year>> number>string ]
 136        } cleave
 137     ] output>array " " join ; inline
 138
 139 : (week-of-year) ( timestamp day -- n )
 140     [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
 141     [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ;
 142
 143 : week-of-year-sunday ( timestamp -- n ) 0 (week-of-year) ; inline
 144
 145 : week-of-year-monday ( timestamp -- n ) 1 (week-of-year) ; inline
 146
 147 EBNF: parse-strftime
 148
 149 fmt-%     = "%"                  => [[ [ "%" ] ]]
 150 fmt-a     = "a"                  => [[ [ dup day-of-week day-abbreviation3 ] ]]
 151 fmt-A     = "A"                  => [[ [ dup day-of-week day-name ] ]]
 152 fmt-b     = "b"                  => [[ [ dup month>> month-abbreviation ] ]]
 153 fmt-B     = "B"                  => [[ [ dup month>> month-name ] ]]
 154 fmt-c     = "c"                  => [[ [ dup >datetime ] ]]
 155 fmt-d     = "d"                  => [[ [ dup day>> pad-00 ] ]]
 156 fmt-H     = "H"                  => [[ [ dup hour>> pad-00 ] ]]
 157 fmt-I     = "I"                  => [[ [ dup hour>> dup 12 > [ 12 - ] when pad-00 ] ]]
 158 fmt-j     = "j"                  => [[ [ dup day-of-year pad-000 ] ]]
 159 fmt-m     = "m"                  => [[ [ dup month>> pad-00 ] ]]
 160 fmt-M     = "M"                  => [[ [ dup minute>> pad-00 ] ]]
 161 fmt-p     = "p"                  => [[ [ dup hour>> 12 < "AM" "PM" ? ] ]]
 162 fmt-S     = "S"                  => [[ [ dup second>> floor pad-00 ] ]]
 163 fmt-U     = "U"                  => [[ [ dup week-of-year-sunday pad-00 ] ]]
 164 fmt-w     = "w"                  => [[ [ dup day-of-week number>string ] ]]
 165 fmt-W     = "W"                  => [[ [ dup week-of-year-monday pad-00 ] ]]
 166 fmt-x     = "x"                  => [[ [ dup >date ] ]]
 167 fmt-X     = "X"                  => [[ [ dup >time ] ]]
 168 fmt-y     = "y"                  => [[ [ dup year>> 100 mod pad-00 ] ]]
 169 fmt-Y     = "Y"                  => [[ [ dup year>> number>string ] ]]
 170 fmt-Z     = "Z"                  => [[ [ "Not yet implemented" throw ] ]]
 171 unknown   = (.)*                 => [[ "Unknown directive" throw ]]
 172
 173 formats_  = fmt-%|fmt-a|fmt-A|fmt-b|fmt-B|fmt-c|fmt-d|fmt-H|fmt-I|
 174             fmt-j|fmt-m|fmt-M|fmt-p|fmt-S|fmt-U|fmt-w|fmt-W|fmt-x|
 175             fmt-X|fmt-y|fmt-Y|fmt-Z|unknown
 176
 177 formats   = "%" (formats_)       => [[ second '[ _ dip ] ]]
 178
 179 plain-text = (!("%").)+          => [[ >string '[ _ swap ] ]]
 180
 181 text      = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
 182
 183 ;EBNF
 184
 185 PRIVATE>
 186
 187 MACRO: strftime ( format-string -- )
 188     parse-strftime [ length ] keep [ ] join
 189     '[ _ <vector> @ reverse concat nip ] ;