├── LICENSE ├── README.md ├── composite.red ├── date-time-format-challenge.red ├── format-date-time.red ├── format.red ├── formatting-functions.adoc ├── short-format.red ├── string-formatting.red ├── test-composite.red ├── test-format.red └── test-short-format.red /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2017, Gregg Irwin 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # red-formatting 2 | Red formatting functions and dialect design experiments 3 | -------------------------------------------------------------------------------- /composite.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | Author: [@greggirwin @endo @toomasv @hiiamboris] 3 | Purpose: "COMPOSE for strings" 4 | Notes: { 5 | TBD: Security model for eval'ing expressions 6 | TBD: Decide if support for custom marker and eval contexts are worthwhile 7 | TBD: Finalize refinement names 8 | TBD: Decide if suport for function contexts is worthwhile 9 | TBD: Make it a macro? 10 | } 11 | ] 12 | 13 | composite-ctx: context [ 14 | 15 | eval: func [ 16 | "Evaluate expr and return the result" 17 | expr [string!] "Valid Red, as a string expression" 18 | err-val "If not none, return this instead of formed error information, if eval fails" 19 | ctx [none! object! function!] "Evaluate expr in the given context; none means use global context" 20 | /local res 21 | ][ 22 | if error? set/any 'res try [expr: load expr][ 23 | ;return any [err-val form reduce [" *** Error: Invalid expression Where:" expr "*** "]] 24 | cause-error 'syntax 'invalid [arg1: 'composite-expression arg2: expr] 25 | ] 26 | ; If they used a literal string, return it. 27 | if string? :expr [return expr] 28 | ; If expression evaluates to a non-block value that is anything other than a 29 | ; word, we can't bind it. And if ctx is a function, we have to reassign the 30 | ; rebound expr, so we do it in every case, as it's harmless for objects. 31 | if all [:ctx any [block? :expr word? :expr]][expr: bind expr :ctx] 32 | either error? set/any 'res try [do expr][ 33 | any [err-val form reduce [" *** Error:" res/id "Where:" expr "*** "]] 34 | ][ 35 | either unset? get/any 'res [""][:res] 36 | ] 37 | ] 38 | 39 | ; One of the big questions is what to do if there are mismatched expr 40 | ; markers. We can treat them as errors, or just pass through them, so 41 | ; they will be visible in the output. We can support both behaviors 42 | ; with a refinement, and then just have to choose the default. 43 | ; Putting the colons on the outside gives you a clean paren expression 44 | ; on the inside. 45 | ; `Compose` could be extended, to work as-is for blocks, but add support for 46 | ; this behavior for strings. The extra refinements are an issue, though. 47 | ; They don't conflict with the existing `compose` refinements, but we 48 | ; have to see how they might cause confusion given the different behaviors. 49 | set 'composite func [ 50 | "Returns a copy of a string, evaluating :( ... ): sections" 51 | ;"Replace :( ... ): sections in a string with their evaluated results" 52 | ;"Returns a copy of a string, replacing :( ... ): sections with their evaluated results" 53 | data [string! file! url!] 54 | /marks markers [block!] "Use custom expression markers in place of :( and ):" 55 | /with ctx [object! function!] "Evaluate the expressions in the given context" 56 | /err-val e "Use instead of formed error info from eval error" 57 | ; /into might be useful, but it also complicates things, given the current implementation. 58 | ; Need to weigh the value. If we always create or use the out buffer, rather than changing 59 | ; the input data in place, it won't add much complexity. 60 | ;/into "Put results in `out`, instead of creating a new string" 61 | ; out [string!] "Target for results, when /into is used" 62 | /local expr expr-beg= expr-end= pos 63 | ][ 64 | if all [marks not parse markers [2 [char! | string! | tag!]]][ 65 | cause-error 'script 'invalid-arg [arg1: markers] 66 | ;cause-error 'script 'invalid-data [arg1: markers] 67 | ;return make error! "Markers must be a block containing two char/string/tag values" 68 | ] 69 | set [expr-beg= expr-end=] either marks [markers][ [":(" "):"] ] 70 | data: either string? data [copy data][read data] ; Don't modify the input 71 | parse data [ 72 | ; If we take out the cause-error actions here, mismatched expression markers 73 | ; will pass through unscathed. That would adhere to Postel's Law 74 | ; (https://en.wikipedia.org/wiki/Robustness_principle), but I think that's a 75 | ; bad criteria when we're evaluating expressions. R2's build-markup treats 76 | ; an unterminated expression as a full expression to the end of input, and 77 | ; an uninitiated expression as data thru the expr-end marker. 78 | any [ 79 | end break 80 | | change [expr-beg= copy expr to expr-end= expr-end=] (eval expr e :ctx) 81 | | expr-beg= pos: to end (cause-error 'syntax 'missing [arg1: expr-end= arg2: pos]) 82 | | to expr-beg= ; find the next expression 83 | | pos: to expr-end= (cause-error 'syntax 'missing [arg1: expr-beg= arg2: pos]) 84 | ] 85 | ] 86 | data 87 | ] 88 | 89 | ] 90 | 91 | ;composite/marks {Some [probe "interesting"] Red expressions like 3 + 2 = [3 + 2]} ["[" "]"] 92 | ;composite/marks {Some (probe "curious") Red expressions like 3 + 2 = (3 + 2)} ["(" ")"] 93 | ;composite {Some :(probe "curious"): Red expressions like 3 + 2 = :(3 + 2):} 94 | ;o: object [a: 1 b: 2] 95 | ;composite/with {Some :(probe "curious"): Red expressions like a + b = :(a + b):} o 96 | ;composite {Some Red expressions like :(":(3 + 2):"): = :(3 + 2):} 97 | ;composite {Some Red expressions like :(":():"): = :(3 + 2):} 98 | 99 | 100 | ;composite-ctx: context [ 101 | ; 102 | ; eval: func [ 103 | ; "Evaluate expr and return the result" 104 | ; expr [string!] "Valid Red, as a string expression" 105 | ; err-val "If not none, return this instead of formed error information, if eval fails" 106 | ; /local res 107 | ; ][ 108 | ; either error? set/any 'res try [do expr][ 109 | ; any [err-val form reduce [" *** Error:" res/id "Where:" expr "*** "]] 110 | ; ][ 111 | ; either unset? get/any 'res [""][:res] 112 | ; ] 113 | ; ] 114 | ; 115 | ; ; Putting the colons on the outside gives you a clean paren expression 116 | ; ; on the inside. 117 | ; expr-beg=: ":(" 118 | ; expr-end=: "):" 119 | ; 120 | ; ; One of the big questions is what to do if there are mismatched expr 121 | ; ; markers. We can treat them as errors, or just pass through them, so 122 | ; ; they will be visible in the output. We can support both behaviors 123 | ; ; with a refinement, and then just have to choose the default. 124 | ; set 'composite func [ 125 | ; "Replace :( ... ): sections in a string with their evaluated results." 126 | ; data [string! file! url!] 127 | ; /err-val e "Use instead of formed error info from eval error" 128 | ; /local expr 129 | ; ][ 130 | ; data: either string? data [copy data] [read data] ; Don't modify the input 131 | ; parse data [ 132 | ; any [ 133 | ; end break 134 | ; | change [expr-beg= copy expr to expr-end= expr-end=] (eval expr e) 135 | ; | expr-beg= to end 136 | ; | to expr-beg= 137 | ; ] 138 | ; ] 139 | ; data 140 | ; ] 141 | ; 142 | ;] 143 | -------------------------------------------------------------------------------- /date-time-format-challenge.red: -------------------------------------------------------------------------------- 1 | Red [] 2 | 3 | ; Quiz/challenge app 4 | ; Show a date and expected output format 5 | ; Track time and count of attempts 6 | ; Log attempts so we can see what people expect should work 7 | -------------------------------------------------------------------------------- /format-date-time.red: -------------------------------------------------------------------------------- 1 | Red [] 2 | 3 | ;do %/d/red/mezz/select-case.red 4 | 5 | ;if not value? 'format-number-by-width [ 6 | ; do %format.red 7 | ;] 8 | if not value? 'as-ordinal [ 9 | do %format.red 10 | ] 11 | 12 | date-time-formatting: context [ 13 | 14 | as-utc: func [date [date!]] [ 15 | if all [date/zone 0:00 <> date/zone] [ 16 | date: date - date/zone 17 | ] 18 | date/zone: 0:00 19 | if none? date/time [date/time: 0:0:0] 20 | date 21 | ] 22 | 23 | pad-num: func [num [integer! float!] wd [integer!]][ 24 | pad/with/left form num wd #"0" 25 | ] 26 | 27 | pad-decimal: function [ 28 | "Formats a decimal with a minimum number of digits on the left and a maximum number of digits on the right. No separators added." 29 | value [integer! float!] "The value to format" 30 | int-len [integer!] "The number of digits desired on the left of the decimal point. (right justified, never truncates)" 31 | dec-len [integer!] "The number of digits desired on the right of the decimal point. (left justified, may truncate)" 32 | ][ 33 | dec: round/to absolute (mod value 1) (10 ** negate dec-len) 34 | int-part: pad-num to integer! value int-len 35 | dec-part: find/tail form dec #"." 36 | ;!! `pad` modifies the arg, and returns the HEAD. We don't want that in 37 | ; this case, so we don't re-set dec-part to refer to pad's result. 38 | pad/with dec-part dec-len #"0" 39 | rejoin [int-part #"." dec-part] 40 | ] 41 | 42 | combine: func [ 43 | "Merge values, modifying a if possible" 44 | a "Modified if series or map" 45 | b "Single value or block of values; reduced if `a` is not an object or map" 46 | ][ 47 | if all [block? :b not object? :a not map? :a] [b: reduce b] 48 | case [ 49 | series? :a [append a :b] 50 | map? :a [extend a :b] 51 | object? :a [make a :b] 52 | 'else [append form :a :b] 53 | ] 54 | ] 55 | join: func [ 56 | "Concatenate/merge values" 57 | a "Coerced to string if not a series, map, or object" 58 | b "Single value or block of values; reduced if `a` is not an object or map" 59 | ][ 60 | if all [block? :b not object? :a not map? :a] [b: reduce b] 61 | case [ 62 | series? :a [a: copy a] 63 | map? :a [a: copy a] 64 | object? :a [] ; form or mold? 65 | 'else [a: form :a] 66 | ] 67 | combine a b 68 | ] 69 | 70 | 71 | ; ; rel-time-map: [ ; use 't for actual time value; result will be form reduced. 72 | ; ; -0:0:5 to 0:0:5 ["right now"] 73 | ; ; -0:1:0 to 0:0:0 ["moments ago"] 74 | ; ; 0:0:0 to 0:1:0 ["in less than a minute"] 75 | ; ; -0:5:0 to 0:0:0 ["a few minutes ago"] 76 | ; ; 0:0:0 to 0:5:0 ["in a few minutes"] 77 | ; ; -0:45:0 to 0:0:0 [[absolute to integer! t / 60 "minutes ago"]] 78 | ; ; 0:0:0 to 0:45:0 [["in" to integer! t / 60 "minutes"]] 79 | ; ; -1:15:0 to -0:45:0 ["about an hour ago"] 80 | ; ; 0:45:0 to 1:15:0 ["in about an hour"] 81 | ; ; case is < -1:15:0 [[format-date-time absolute t 'short-time "ago"]] 82 | ; ; case is > 1:15:0 [["in" format-date-time absolute t 'short-time]] 83 | ; ; ] 84 | ; 85 | ; rel-day-string: func [days [integer!]] [ 86 | ; form reduce select-case days [ 87 | ; 0 ["today"] 88 | ; -1 ["yesterday"] 89 | ; 1 ["tomorrow"] 90 | ; case is < -1 [format-number absolute days 'r-general "days ago"] 91 | ; case else ["in" format-number days 'r-general "days"] 92 | ; ] 93 | ; ] 94 | ; 95 | ; rel-hour-string: func [time [time!]] [ 96 | ; time: round/to time 0:15:0 97 | ; ;time: time/hour 98 | ; form reduce select-case time [ 99 | ; 0:0:0 ["now"] 100 | ; -1:0:0 ["an hour ago"] 101 | ; 1:0:0 ["in an hour"] 102 | ; -0:15:0 ["about 15 mintues ago"] 103 | ; 0:15:0 ["in about 15 mintues"] 104 | ; -0:30:0 ["about half an hour ago"] 105 | ; 0:30:0 ["in about half an hour"] 106 | ; -0:45:0 ["almost an hour ago"] 107 | ; 0:45:0 ["in less than an hour"] 108 | ; -1:45:0 to -1:0:0 ["more than an hour ago"] 109 | ; 1:0:0 to 1:45:0 ["more than an hour from now"] 110 | ; ; With detault rounding, times like 2:25:0 will go to 3:0:0 because they 111 | ; ; get rounded to 2:30:0 at the top of the func. Using /half-down means 112 | ; ; times like 2:35 will round to 2:0:0 which I like a little better in 113 | ; ; this case, based on using it for upcoming event warnings. 114 | ; case is < -1:45:0 [absolute round/half-down/to time 1:0:0 "hours ago"] 115 | ; case else ["in" round/half-down/to time 1:0:0 "hours"] 116 | ; ] 117 | ; ] 118 | ; 119 | ; rel-time-string: func [time [time!]] [ ; use 't for actual time value; result will be form reduceed. 120 | ; form reduce select-case time [ 121 | ; -0:0:5 to 0:0:5 ["right now"] 122 | ; -0:1:0 to 0:0:0 ["moments ago"] 123 | ; 0:0:0 to 0:1:0 ["in less than a minute"] 124 | ; -0:5:0 to 0:0:0 ["a few minutes ago"] 125 | ; 0:0:0 to 0:5:0 ["in a few minutes"] 126 | ; -0:45:0 to 0:0:0 [absolute to integer! time / 60 "minutes ago"] 127 | ; 0:0:0 to 0:45:0 ["in" to integer! time / 60 "minutes"] 128 | ; -1:15:0 to -0:45:0 ["about an hour ago"] 129 | ; 0:45:0 to 1:15:0 ["in about an hour"] 130 | ; case is < -1:15:0 [format-date-time absolute time 'short-time "ago"] 131 | ; case is > 1:15:0 ["in" format-date-time absolute time 'short-time] 132 | ; ] 133 | ; ] 134 | 135 | ; INET/W3C standards, like RFC822, require English names, not localized. 136 | en-days: ["Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"] 137 | en-days-abbr: ["Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"] 138 | en-months: ["January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "Decdember"] 139 | en-months-abbr: ["Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] 140 | 141 | set 'format-date-time func [ 142 | value [date! time!] 143 | fmt [word! string! block!] "Named, custom, or accessor format" 144 | /local d t tt res time-only local-date std-time year-week month-qtr rfc-3339-fmt was-time? 145 | ] [ 146 | ; If we only got a time, assume the current date. But also set a flag so 147 | ; we can determine later if we got a time! value as an argument. That way 148 | ; most logic can safely assume a full date arg, but special handling can 149 | ; also be used. 150 | if time? value [ 151 | was-time?: yes ; so we can check later if the input arg was time! 152 | d: now 153 | d/time: value 154 | value: d 155 | ] 156 | ;?? If there is no /time, should we set that to the current time or 00:00? 157 | if all [date? value none? value/time][ 158 | value/time: 00:00:00 159 | ] 160 | 161 | ; Helper funcs 162 | time-only: func [val [date! time!]] [either time? val [val][val/time]] 163 | date-only: func [val [date! time!]] [either date? val [val/date][none]] 164 | local-date: func [date] [date - date/zone + now/zone] 165 | am-pm: func [time [time!] /uppercase][ 166 | pick either uppercase [[AM PM]] [[am pm]] time < 12:00 167 | ] 168 | am-pm-time: func [ 169 | "Convert 24-hour time to 12-hour time. THIS INTENTIONALLY LOSES INFORMATION" 170 | time [time!] 171 | ][ 172 | if time >= 12:00 [time: mod time 12:00] ; Constrain to >= 00:00 and < 12:00 173 | if zero? time/hour [time/hour: 12] ; Humans don't have 0 on a round clock 174 | time 175 | ] 176 | ; Not used currently 177 | ; std-time: func [ 178 | ; "Time formatted for humans" 179 | ; time [time!] 180 | ; /full 181 | ; ][ 182 | ; if not full [time/second: 0] 183 | ; form reduce [am-pm-time time am-pm/uppercase time] 184 | ; ] 185 | year-week: function [date [date!]][ 186 | new-year: make date! reduce [1 1 date/year] ; to-date join "1-Jan-" year 187 | day-num: date - new-year + 1 188 | offset: new-year/weekday - 1 189 | either not zero? remainder (day-num + offset) 7 [ 190 | to integer! (day-num + offset / 7) + 1 191 | ][ 192 | day-num + offset / 7 193 | ] 194 | ] 195 | month-qtr: func [month [integer!]] [to integer! month - 1 / 3 + 1] 196 | zone: func [ 197 | "Format a timezone value, including the sign." 198 | z [date! time!] 199 | /with sep [char! string!] "Include a separator between the hours and minutes" 200 | ][ 201 | if date? z [z: z/zone] 202 | rejoin [ 203 | (pick "-+" negative? z) (pad-num absolute z/hour 2) (any [sep ""]) (pad-num z/minute 2) 204 | ] 205 | ] 206 | ; Fractional seconds are considered a rarely used option in the RFC. 207 | ; The question for us is whether to have the user control whether 208 | ; fractional seconds are used via a special name, or by modding their 209 | ; data values, by trimming fractional seconds, to avoid them being 210 | ; included. 211 | rfc-3339-fmt: func [value /local t] [ 212 | t: time-only value 213 | ; If the time includes fractional seconds, include them in 214 | ; the format, otherwise omit them. 215 | format-date-time value either zero? remainder t/second 1 [ 216 | "yyyy-mm-dd\Thhh:mm:ss±zz:zz" 217 | ][ 218 | "yyyy-mm-dd\Thhh:mm:sss±zz:zz" 219 | ] 220 | ] 221 | 222 | date-time-mask-formatting: context [ 223 | res: none 224 | pos: none 225 | emit: func [val] [append res val] 226 | 227 | any-char: complement charset "" 228 | pass-char: charset " ^-^/,.' " ; space tab newline , . ' nbsp 229 | escape: ["^^" | "\"] 230 | time-sep: ":" ; Should this be customizable? 231 | date-sep: "-" ; Should this be customizable? 232 | ; English versions, for RFC822+ 233 | en-day-name: func [index] [pick en-days index] 234 | en-day-abbr: func [index] [pick en-days-abbr index] 235 | en-month-name: func [index] [pick en-months index] 236 | en-month-abbr: func [index] [pick en-months-abbr index] 237 | ; localized versions 238 | day-name: func [index] [pick system/locale/days index] 239 | month-name: func [index] [pick system/locale/months index] 240 | ;day-abbr: func [index] [pick system/locale/days-abbr index] 241 | ;month-abbr: func [index] [pick system/locale/months-abbr index] 242 | rules: [ 243 | (d: date-only value t: time-only value) 244 | any [ 245 | copy ch pass-char (emit ch) 246 | | escape copy ch any-char (emit ch) 247 | | ":" (emit time-sep) 248 | | copy ch ["-" | "/"] (emit ch) ;(emit date-sep) 249 | | "c" (emit format-date-time value "dd/mm/yyyy hh:mm:ss AM/PM") ; c = "C"omplete 250 | | "dddddd" (emit format-date-time value "dddd, mmmm dd, yyyy") 251 | | "ddddd" (emit format-date-time value "dd/mm/yyyy") 252 | ;!! Note that we have *-en versions for RFC format use 253 | | ["dddd-en" | "monday-en" | "Monday-en"] (emit en-day-name d/weekday) 254 | | ["ddd-en" | "mon-en" | "Mon-en"] (emit en-day-abbr d/weekday) 255 | | ["dddd" | "monday" | "Monday"] (emit day-name d/weekday) ; MS uses 'aaaa for localized 'dddd 256 | | ["ddd" | "mon" | "Mon"] (emit copy/part day-name d/weekday 3) 257 | | "dd" (emit pad-num d/day 2) ; TBD allow 2 digit chars? 258 | | "d" (emit d/day) ; TBD allow 1 digit char? 259 | ; Day ordinal requires case-sensitive parsing right now. 260 | | "Dth" (emit as-ordinal d/day) ; ?? ["DDD" | "Dth"] 261 | ;| "ww" (emit to integer! d/julian / 7) ; week of year 262 | | "ww" (emit year-week d) ; week of year 263 | | ["weekday" | "w"] (emit d/weekday) 264 | | [ 265 | ; "hhhh" (emit pad-num t/hour 2 emit pad-num t/minute 2 ) ; = 0800 2300 etc. 266 | "hhh" (emit pad-num t/hour 2) ; mil-time 00-23 267 | | "hh" (tt: am-pm-time t emit pad-num tt/hour 2) ; note that this doesn't work for hour values > 24:00, because we just subtract 12:00. 268 | | "h" (tt: am-pm-time t emit tt/hour) 269 | ] 270 | opt [":" (emit time-sep)] 271 | opt [ 272 | ["mm" | "nn"] (emit pad-num t/minute 2) ;?? not sure 'nn is worth having 273 | | ["m" | "n"] (emit t/minute) ;?? not sure 'n is worth having 274 | ] 275 | | "sss" (emit pad-decimal t/second 2 3) ; include decimal component to 3 places 276 | | "ss" (emit pad-num to integer! t/second 2) 277 | | "s" (emit to integer! t/second) 278 | | "ttttt" (emit format-date-time value "hh:mm:sss AM/PM") ; long-time 279 | ; Time meridian requires case-sensitive parsing right now. 280 | | ["AM/PM" | "AM-PM"] (emit am-pm/uppercase t) ;?? Are alternates helpful here? 281 | | ["am/pm" | "am-pm"] (emit am-pm t) 282 | | ["A/P" | "A-P"] (emit first form am-pm/uppercase t) 283 | | ["a/p" | "a-p"] (emit first form am-pm t) 284 | ;!! Note that we have *-en versions for RFC format use 285 | | ["mmmm-en" | "january-en" | "January-en"] (emit en-month-name d/month) ; MS uses 'oooo for localized 'mmmm 286 | | ["mmm-en" | "jan-en" | "Jan-en"] (emit en-month-abbr d/month) 287 | | ["mmmm" | "january" | "January"] (emit month-name d/month) 288 | | ["mmm" | "jan" | "Jan"] (emit copy/part month-name d/month 3) 289 | | "mm" (emit pad-num either was-time? [t/minute][d/month] 2) 290 | | "m" (emit either was-time? [t/minute][d/month]) 291 | | ["Mth"] (emit as-ordinal d/month) ;?? ["MMM" | "Mth"] 292 | | "qqqq" (emit pick [first second third fourth] (month-qtr d/month)) ; Not locale aware 293 | | "Qth" (emit as-ordinal month-qtr d/month) ;?? ["QQQ" | "Qth"] 294 | | "qq" (emit pad-num (month-qtr d/month) 2) 295 | | "q" (emit month-qtr d/month) 296 | | "yyyy" (emit d/year) 297 | | "yy" (emit at form d/year 3) 298 | | "y" (emit d/julian) ;?? yd ytd 299 | ; Supporting the optional ± sigil may seem unnecessary, but 300 | ; it can act as documentation in the format string. It 301 | ; indicates that a sign character will be there. Since the 302 | ; zone often comes after seconds (ss) in format strings, it 303 | ; can also clarify that value marker position. 304 | | opt #"±" "zz:zz" (emit zone/with value #":") 305 | | opt #"±" "zzzz" (emit zone value) 306 | | pos: ( 307 | print [ 308 | "Unexpected value in format string:" newline 309 | tab "Where:" mold pos newline 310 | tab "Index:" index? pos newline 311 | tab "Value:" mold pos/1 newline 312 | tab "Code Point:" to integer! pos/1 313 | ] 314 | ) reject 315 | ] 316 | ] 317 | set 'format-date-time-via-mask func [ 318 | value [date! time!] 319 | fmt [string!] 320 | ][ 321 | ;!! This isn't great, because mutually recursive calls to formatting, 322 | ; which can be useful in some cases, are unsafe. The reason it's 323 | ; set up to use the context level var is that Red currently has 324 | ; some limitations when compiling functions inside functions. We 325 | ; might be able to use a context in the func, which would be cleaner, 326 | ; but then we have all that overhead in every format call, to build 327 | ; the context. 328 | res: copy "" ; context level var so parse actions can change it 329 | if parse/case fmt rules [res] 330 | ] 331 | ] 332 | 333 | date-time-accessor-formatting: context [ 334 | var: none 335 | pos: none 336 | set 'format-date-time-via-accessors function [ 337 | value [date! time!] 338 | fmt [block!] 339 | ][ 340 | ; Rejoin will let us butt up commas and such, but also means we 341 | ; MUST use delimiting values between accessors. 342 | rejoin collect [ 343 | rules: [ 344 | any [ 345 | set var word! ( 346 | keep either pos: find system/catalog/accessors/date! var [ 347 | if pos/1 = 'julian [ ;<< synonym for yearday, and not a valid index 348 | pos: find system/catalog/accessors/date! 'yearday 349 | ] 350 | pick value index? pos 351 | ][#NO_ACCESSOR_BY_THAT_NAME] 352 | ) 353 | | set var string! (keep var) 354 | | set var any-type! (keep form :var) 355 | ] 356 | ] 357 | parse fmt rules 358 | ] 359 | ] 360 | ] 361 | 362 | case [ 363 | string? fmt [format-date-time-via-mask value fmt] 364 | block? fmt [format-date-time-via-accessors value fmt] 365 | ;!! If we check for named formats first, and just set the format 366 | ; to the string format associated with the name, we eliminate 367 | ; the recursive call. There are a few exception cases, where we 368 | ; just FORM the value, and where we force it to be a UTC time. 369 | 'else [ 370 | ; named formats 371 | ; TBD: consolidate `format-date-time value "..."` calls by setting 372 | ; the format string, checking that, and then having the function 373 | ; call in just one place. 374 | switch/default fmt [ 375 | general [form value] 376 | long-date [format-date-time value "dddd, mmmm dd, yyyy"] 377 | medium-date [form date-only value] 378 | short-date [format-date-time value "dd/mm/yyyy"] 379 | ; 'rel-days is handled in format-number 380 | long-time [format-date-time value "hh:mm:sss AM/PM"] 381 | medium-time [format-date-time value "hh:mm:ss AM/PM"] 382 | short-time [format-date-time value "hh:mm AM/PM"] 383 | 384 | ;!! Relative days and times may be outside the current scope, as 385 | ; they need to be locale aware. 386 | ;rel-days [rel-day-string value - now] 387 | ;rel-hours [rel-hour-string either time? value [value - now/time] [difference value now]] 388 | ;rel-time [rel-time-string either time? value [value - now/time] [difference value now]] 389 | 390 | ; http://www.hackcraft.net/web/datetime/ 391 | 392 | ; http://tools.ietf.org/html/rfc3339 393 | ; http://www.w3.org/TR/NOTE-datetime.html 394 | RFC3339 Atom W3C W3C-DTF [rfc-3339-fmt value] 395 | 396 | ; http://en.wikipedia.org/wiki/ISO_8601 397 | ISO8601 [ ; ISO8601 without separators 398 | either none? value/time [ 399 | format-date-time value "yyyymmdd" 400 | ][ 401 | ; If we want to emit Z for UTC times, we can use the first 402 | ; option here. The second is simpler, though, and the 403 | ; output just as valid (and more consistent to boot). 404 | ;format-date-time value join "yyyymmdd^^Thhhmmss" either 0:00 = value/zone ["^^Z"] ["zzzz"] 405 | format-date-time value "yyyymmdd^^Thhhmmss±zzzz" 406 | ] 407 | ] 408 | ISO-8601 [ ; ISO8601 with separators 409 | either none? value/time [ 410 | format-date-time value "yyyy-mm-dd" 411 | ][ 412 | ; If we want to emit Z for UTC times, we can use the first 413 | ; option here. The second is simpler, though, and the 414 | ; output just as valid (and more consistent to boot). 415 | ;format-date-time value join "yyyy-mm-dd^^Thhh:mm:ss" either 0:00 = value/zone ["^^Z"] ["zzzz"] 416 | format-date-time value "yyyy-mm-dd^^Thhh:mm:ss±zzzz" 417 | ] 418 | ] 419 | 420 | ; http://www.w3.org/Protocols/rfc822/ 421 | ; http://feed2.w3.org/docs/error/InvalidRFC2822Date.html 422 | ; http://tech.groups.yahoo.com/group/rss-public/message/536 423 | RFC822 [ 424 | ; We use 2 digits for the year to match the spec. RFC2822 uses 4 digits. 425 | format-date-time value "ddd-en, dd mmm-en yy hhh:mm:ss ±zzzz" 426 | ] 427 | 428 | ; http://cyber.law.harvard.edu/rss/rss.html 429 | ; http://diveintomark.org/archives/2003/06/21/history_of_rss_date_formats 430 | ; http://www.ietf.org/rfc/rfc1123.txt 431 | ; http://tools.ietf.org/html/rfc2822#page-14 432 | RFC2822 RFC1123 RSS [ 433 | format-date-time value "ddd-en, dd mmm-en yyyy hhh:mm:ss ±zzzz" 434 | ] 435 | 436 | ; Must be in UTC 437 | ; HTTP-date is case sensitive and MUST NOT include additional 438 | ; LWS beyond that specifically included as SP in the grammar. 439 | ; Per https://tools.ietf.org/html/rfc2616#section-3.3.1 440 | ; HTTP-date = rfc1123-date | rfc850-date | asctime-date 441 | ; rfc1123-date = wkday "," SP date1 SP time SP "GMT" 442 | ; rfc850-date = weekday "," SP date2 SP time SP "GMT" 443 | ; asctime-date = wkday SP date3 SP time SP 4DIGIT 444 | ;HTTP-Cookie [format-date-time value "ddd, dd mmm yyyy hhh:mm:ss GMT"] 445 | HTTP-Cookie [format-date-time as-utc value "dddd-en, dd mmm-en yyyy hhh:mm:ss ^^G^^M^^T"] 446 | RFC850 USENET [format-date-time as-utc value "dddd-en, dd mmm-en yy hhh:mm:ss ^^G^^M^^T"] 447 | ; http://www.ietf.org/rfc/rfc1036.txt §2.1.2 448 | RFC1036 [format-date-time as-utc value "ddd-en, dd mmm-en yy hhh:mm:ss ±zzzz"] 449 | 450 | ; throw error - unknown named format specified? 451 | ][either any-block? value [form reduce value] [form value]] 452 | ] 453 | ] 454 | ] 455 | 456 | ] 457 | 458 | e.g.: :comment 459 | e.g.: :do 460 | e.g. [ 461 | test: func [val fmt /local res][ 462 | res: format-date-time val fmt 463 | print [mold fmt tab mold res] 464 | ] 465 | 466 | dt: now/precise 467 | foreach fmt [ 468 | general 469 | long-date 470 | medium-date 471 | short-date 472 | long-time 473 | medium-time 474 | short-time 475 | ;rel-days 476 | ;rel-hours 477 | ;rel-time 478 | 479 | ;idate 480 | 481 | RFC3339 482 | Atom 483 | W3C 484 | W3C-DTF 485 | 486 | ISO8601 487 | ISO-8601 488 | RFC822 489 | RSS 490 | RFC2822 491 | RFC1123 492 | 493 | HTTP-Cookie 494 | RFC850 495 | USENET 496 | RFC1036 497 | 498 | 499 | "Mon, dd January, yyyy" 500 | "monday, dd jan, yyyy" 501 | "monday, dd jan, yyyy ±zzzz" 502 | "monday, dd jan, yyyy ±zz:zz" 503 | 504 | "c" 505 | "dddddd" 506 | "ddddd" 507 | "dddd" 508 | "ddd" 509 | "dd" 510 | "d" 511 | "Mon" 512 | "Monday" 513 | 514 | "Dth" 515 | 516 | "w" 517 | "ww" 518 | "weekday" 519 | 520 | "ttttt" 521 | "h:m:s" 522 | "hh:mm:ss" 523 | "hhh:mm:sss" 524 | "hAM/PM" 525 | "ham/pm" 526 | "hA/P" 527 | "ha/p" 528 | 529 | "mmmm" 530 | "mmm" 531 | "mm" 532 | "m" 533 | "Mth" 534 | 535 | "qqqq" 536 | "Qth" 537 | "qq" 538 | "q" 539 | 540 | "yyyy" 541 | "yy" 542 | "y" 543 | 544 | "zz:zz" 545 | "±zzzz" 546 | 547 | [date] 548 | [date time] 549 | [yearday julian] 550 | [ 551 | date year month day zone time hour minute second weekday yearday 552 | timezone week isoweek julian 553 | ] 554 | [bad-accessor-name] 555 | [date " " time] 556 | [year "." month "." day "|" hour "_" minute "_" second] 557 | ][test dt fmt] 558 | 559 | val: 0:0:0 560 | foreach fmt [long-time medium-time short-time][ 561 | test val fmt 562 | ] 563 | val: 12:0:0 564 | foreach fmt [long-time medium-time short-time][ 565 | test val fmt 566 | ] 567 | val: 13:0:0 568 | foreach fmt [long-time medium-time short-time][ 569 | test val fmt 570 | ] 571 | 572 | test now "monday, dd jan, yyyy ±zz:zz" ; nbsp 573 | 574 | test now "x" 575 | test now "monday, dd jan, yyyy ±±zz:zz" 576 | test now "monday, dd jan,$yyyy ±zz:zz" 577 | test now "monday, dd jan, yyyy ±zz:zz$" 578 | 579 | ] -------------------------------------------------------------------------------- /format.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | File: %format.red 3 | Purpose: "Red formatting functions" 4 | Date: "13-Apr-2017" 5 | Version: 0.0.1 6 | Author: "Gregg Irwin" 7 | Notes: { 8 | (DONE) means done enough for initial review and RFC 9 | - block-format (printf) (DONE) 10 | - masked format (DONE) 11 | - short-format/printf (DONE) 12 | - Format by width (DONE) 13 | - form-num-with-group-seps (DONE) 14 | - format-number-with-style (DONE) 15 | - format bytes (DONE) 16 | - format logic (DONE) 17 | - mold-logic (DONE) 18 | - Composite (DONE) 19 | - as-ordinal (DONE) 20 | 21 | - block interpolation 22 | - string interpolation 23 | - date format 24 | - format-number-via-masks 25 | } 26 | TBD: { 27 | - Determine exact format-by-width/short-form+prec behavior! It seems like the 28 | precision should fix the deci width *exactly*, rather than letting it float. 29 | Printf changes the output based on alignment. 30 | - Multi-form auto format selection (semicolon format) 31 | - Decide on real func names. Very verbose and intentionally bad sometimes, right now. 32 | - SCI E notation for scientific formatting in masks 33 | - ENG Engineering notation 34 | - 1.#INF and 1.#NaN support 35 | - Format style system 36 | - Masked: Decide if plain spaces are allowed as group separators 37 | - Multi-form: Decide if we need to allow ";" in multi-part format strings, e.g. in quotes or escaped 38 | 39 | - Far future: optimize. Terribly slow right now, what with all the special 40 | case checks, and no concern for speed. R/S will be the way to go, but 41 | this version is all about the design of the interface, not speed. My old 42 | R2 version is 3x faster, but has no concept of international strings, 43 | control over group sep width, and such. Speed isn't an issue for a small 44 | number of calls, but one of the possible uses is for spreadsheets. 45 | Interactive speed and hundreds of cells are in play, there, so speed counts. 46 | } 47 | ] 48 | 49 | 50 | formatting: context [ 51 | e.g.: :comment 52 | 53 | ; Generic support funcs (belong in more general mezzanine libs) 54 | 55 | abs: :absolute 56 | 57 | ; This is a temp version of a split-at func, hence the different name. 58 | break-at: function [ 59 | "Split the series at a position or value, returning the two halves, excluding delim." 60 | series [series!] 61 | delim "Delimiting value, or index if an integer" 62 | /last "Split at the last occurrence of value, from the tail" 63 | /local s 64 | ][ 65 | reduce either all [integer? delim not last] [ 66 | parse series [collect [keep delim skip keep to end]] 67 | ][ 68 | if string? series [delim: form delim] 69 | if not find/only series delim [ 70 | return reduce [copy series copy ""] 71 | ] 72 | either last [ 73 | reduce [ 74 | copy/part series find/only/last series :delim 75 | copy find/only/last/tail series :delim 76 | ] 77 | ][ 78 | ; `copy s` is here because `keep to` doesn't collect anything if the 79 | ; delim is the first thing in the string. 80 | parse series [collect [keep copy s to delim delim keep to end]] 81 | ] 82 | ] 83 | ] 84 | ;>> break-at "" "." 85 | ;== ["" ""] 86 | ;>> break-at "132" "." 87 | ;== ["132" ""] 88 | ;>> break-at "132." "." 89 | ;== ["132" #"^@"] 90 | 91 | change-all: func [ 92 | "Change each value in the series by applying a function to it" 93 | series [series!] 94 | fn [any-function!] "Function that takes one arg" 95 | ][ 96 | forall series [change series fn first series] 97 | series 98 | ] 99 | 100 | ; I've never liked the name of this func, but I'm including it here 101 | ; because the behavior is handy for how I'm merging masks currently. 102 | ; pick-and-advance 103 | first+: func [ 104 | "Return first value in series, and increment the series index." 105 | 'word [word! paren!] "Word must be a series." 106 | ][ 107 | if paren? :word [set/any 'word do :word] 108 | also pick get word 1 set word next get word 109 | ] 110 | 111 | form-if-char: func [val][either char? val [form val][:val]] 112 | 113 | ; I have this here because some old format code I'm porting uses it. 114 | ; It may all change to `rejoin`, but it gave me a reason to port `join` 115 | ; to Red for real and think about object/map support. `Rejoin` doesn't 116 | ; work for those. The question, then, is what value there is in a 117 | ; uniform interface for copy+extend. 118 | join: func [ 119 | "Concatenate/merge values" 120 | a "Coerced to string if not a series, map, or object" 121 | b "Single value or block of values; reduced if `a` is not an object or map" 122 | ][ 123 | if all [block? :b not object? :a not map? :a] [b: reduce b] 124 | case [ 125 | series? :a [append copy a :b] 126 | map? :a [extend copy a :b] 127 | object? :a [make a :b] 128 | 'else [append form :a :b] 129 | ] 130 | ] 131 | 132 | ;--------------------------------------------------------------------------- 133 | 134 | set 'ordinal-suffix func [ ; English only right now. 135 | "Return the ordinal suffix for a number (th, st, nd, rd, etc.)" 136 | val [integer!] 137 | ][ 138 | ;if negative? val [make error! "Ordinal-suffix doesn't support negative numbers"] 139 | either all [val >= 10 val <= 20] ['th] [ 140 | switch/default remainder val 10 [1 ['st] 2 ['nd] 3 ['rd]] ['th] 141 | ] 142 | ] 143 | 144 | set 'as-ordinal func [ 145 | "Return the ordinal string for a number (1st, 2nd, 3rd, etc.)" 146 | val [integer!] 147 | ][ 148 | if negative? val [make error! "Ordinal doesn't support negative numbers"] 149 | append form val ordinal-suffix val 150 | ; append form val either all [val >= 10 val <= 20] ['th] [ 151 | ; switch/default remainder val 10 [1 ['st] 2 ['nd] 3 ['rd]] ['th] 152 | ; ] 153 | ] 154 | 155 | set 'form-num-with-group-seps function [ 156 | "Insert group separators into a numeric string" 157 | num [number! any-string!] 158 | /with sep [string! char!] 159 | /every ct [integer!] ; /skip may be a better name, but conflicts with system/words/skip 160 | ][ 161 | num: form num ; Form strings, too, so they're not modified 162 | sep: any [sep #","] 163 | ct: negate abs any [ct 3] 164 | num: skip any [ 165 | find num deci-char num ; start at the decimal point, if there is one 166 | find/last/tail num digit ; or at the last digit (support, e.g., "123rd") 167 | tail num ; or at the end of the string 168 | ] ct 169 | while [not head? num] [ 170 | ; We want to catch cases where the preceding char is not a digit, 171 | ; and *not* insert a sep if that's the case. 172 | if find digit pick num -1 [ 173 | insert num sep 174 | ] 175 | num: skip num ct 176 | ] 177 | num 178 | ] 179 | 180 | set 'INF? func [val][val = 1.#INF] 181 | set '-INF? func [val][val = -1.#INF] 182 | ;set 'NaN? func [val][val = 1.#NaN] ; Doesn't work currently 183 | set 'NaN? func [val]["1.#NaN" = form val] 184 | 185 | pad-aligned: func [ 186 | "Wrapper for `pad` to ease refinement propagation" 187 | str [string!] align [word!] wd [integer!] ch [char!] 188 | ][ 189 | switch align [ 190 | left [pad/with str wd ch] 191 | right [pad/with/left str wd ch] 192 | ] 193 | ] 194 | 195 | ; May be worth having something like this, if it will simplify other funcs enough. 196 | sign-chars: function [ 197 | "Return a block with left/right padding values, based on n's sign" 198 | n [number!] 199 | /use+ "Left: + or -, right: nothing" 200 | /acct "Left: ( or space, right: ) or space" 201 | ][ 202 | neg?: negative? n 203 | vals: case [ 204 | all [neg? acct] ["()"] ; 205 | all [neg? use+] [" "] ; Force the + sign on, pad if negative 206 | neg? ["-"] ; - for negative and not accounting 207 | ; -- Now we know it's not negative -- 208 | all [positive? n use+]["+"] ; Don't want + for zero 209 | acct [""] ; Positive accounting 210 | 'else [""] ; Don't force + 211 | ] 212 | reduce ['left any [vals/1 ""] 'right any [vals/2 ""]] 213 | ] 214 | e.g. [ 215 | sign-chars 1 216 | sign-chars 0 217 | sign-chars -1 218 | sign-chars/use+ 1 219 | sign-chars/use+ 0 220 | sign-chars/use+ -1 221 | sign-chars/acct 1 222 | sign-chars/acct 0 223 | sign-chars/acct -1 224 | foreach val [1 0 -1][ 225 | ch: sign-chars val print [val tab mold rejoin [ch/left absolute val ch/right]] 226 | ch: sign-chars/use+ val print [val /use+ tab mold rejoin [ch/left absolute val ch/right]] 227 | ch: sign-chars/acct val print [val /acct tab mold rejoin [ch/left absolute val ch/right]] 228 | ] 229 | ] 230 | 231 | ;--------------------------------------------------------------------------- 232 | ; Inspired by how Wolfram works 233 | 234 | ; TBD: Think about whether to allow custom exponent-functions 235 | ; exponent-function: function [ 236 | ; type [word!] "[gen sci eng acct]" 237 | ; ][ 238 | ; ; TBD: Don't generate these dynamically, for performance 239 | ; func [n [integer!] "Exponent"] switch type [ 240 | ; gen [[either any [n < -4 n > 15][n][none]]] ; Use E if <= 1e-5 or >= 1e16 241 | ; sci [[either n = 0 [none][n]]] ; E for values >= 10 242 | ; eng [[round/to n - 1 3]] ; Use E that is a multiple of 3, scaled for 1-3 digits to left of decimal 243 | ; acct [[none]] ; Never use E notation 244 | ; ] 245 | ; ] 246 | ; If the result of an exponent-function is an integer, it should be used 247 | ; as the exponent of a number. If it's none, the number should be shown 248 | ; without scientific notation. 249 | make-exponent-function: func [body [block!]][ 250 | func ["Return exponent to use, or none" e [integer!] "Exponent"] body 251 | ] 252 | _exp-fn-gen: make-exponent-function [either any [e < -4 e > 15][e][none]] ; Use E if <= 1e-5 or >= 1e16 253 | _exp-fn-sci: make-exponent-function [either e = 0 [none][e]] ; E for values >= 10 254 | _exp-fn-eng: make-exponent-function [round/to e - 1 3] ; Use E that is a multiple of 3, scaled for 1-3 digits to left of decimal 255 | _exp-fn-acct: make-exponent-function [none] ; Never use E notation 256 | ;_exp-fn-: func [n [integer!] "Exponent"][] 257 | exponent-function: function [ 258 | type [word! function!] "[gen sci eng acct] or custom func" 259 | ][ 260 | either function? :type [:type][ 261 | switch type [ 262 | gen [:_exp-fn-gen] ; Use E if <= 1e-5 or >= 1e16 263 | sci [:_exp-fn-sci] ; E for values >= 10 264 | eng [:_exp-fn-eng] ; Use E that is a multiple of 3, scaled for 1-3 whole digits 265 | acct [:_exp-fn-acct] ; Never use E notation 266 | ] 267 | ] 268 | ] 269 | 270 | ; If the result of an exponent-function is an integer, it should be used 271 | ; as the exponent of a number. If it's none, the number should be shown 272 | ; without scientific notation. 273 | find-E-to-use: function [ 274 | e [integer!] "Exponent" 275 | type [word! function!] "[gen sci eng acct] or custom exponent function" 276 | ][ 277 | fn: exponent-function :type 278 | fn e 279 | ] 280 | 281 | ; Return Exponent that makes exactly one digit appear to the left of the 282 | ; decimal point. 283 | one-digit-E: function [n [number!] return: [integer!]][ 284 | ;!! Very important to round before integer conversion here or 285 | ; it will just truncate. And log-10 returns 1.#NaN for 286 | ; negatives, which is why absolute is used. 287 | to integer! round log-10 absolute n 288 | ] 289 | 290 | use-E-notation?: func [n [number!] type [word! function!]][ 291 | not none? find-E-to-use n :type 292 | ] 293 | 294 | set 'form-num-ex function [ 295 | "Extended FORM for numbers, lets you control E notation and rounding" 296 | n [number!] 297 | /type t [word! function!] "[gen sci eng acct] Default is gen, or custom exponent function" 298 | /to scale [number!] "Rounding scale (must be positive)" 299 | ][ 300 | if n = 0 [return "0"] ; zero? is broken for floats right now 301 | if all [scale scale <= 0][return make error! "Scale must be positive"] 302 | ; Round 303 | if all [scale scale > 0][ 304 | if all [percent? n float? scale] [scale: scale / 100.0] 305 | n: round/to n scale 306 | ] 307 | either e: find-E-to-use one-digit-E n any [:t 'gen] [ 308 | ; Form using given exponent 309 | rejoin [ 310 | divide (system/words/to float! n) 10.0 ** e ;!! 10.0, not int 10! Int will round at E=16 311 | either all [e e <> 0] [join "e" e][""] 312 | ] 313 | ][ 314 | ; Form with no E notation 315 | ;!! Trick FORM into giving us a non-scientific format. Currently, 316 | ; .1 is the lower limit where Red formats with E notation. 317 | ; Though now I can't find how I determined that, as 0.0001 works. 318 | either all [n > -0.1 n < .1 n <> 0 not percent? n][ 319 | ; Add 1 to the absolute value of the number, to trick FORM. 320 | num: form n + (1 * sign? n) 321 | ; Now our first digit is 1, but we added that, so change it to 0. 322 | head change find num #"1" #"0" 323 | ; Apply accounting format 324 | if all [negative? n :t = 'acct] [ 325 | append change find num #"-" #"(" #")" 326 | ] 327 | num 328 | ][ 329 | either any [not negative? n :t <> 'acct] [form n][ 330 | rejoin [#"(" abs n #")"] 331 | ] 332 | ] 333 | ] 334 | 335 | ] 336 | ; e.g. [ 337 | ; form-num-ex/type 0 'gen 338 | ; form-num-ex/type -0 'gen 339 | ; form-num-ex/type 0.45 'gen 340 | ; form-num-ex/type 1.45 'gen 341 | ; form-num-ex/type 12.45 'gen 342 | ; form-num-ex/type 123.45 'gen 343 | ; form-num-ex/type 1234.0 'gen 344 | ; form-num-ex/type 12345.0 'gen 345 | ; form-num-ex/type 123450.0 'gen 346 | ; form-num-ex/type 1234500.0 'gen 347 | ; form-num-ex/type 12345000.0 'gen 348 | ; form-num-ex/type 123'450'000.0 'gen 349 | ; form-num-ex/type 1'234'500'000.0 'gen 350 | ; form-num-ex/type -1'234'500'000.0 'gen 351 | ; form-num-ex/type -0.000'000'123'45 'gen 352 | ; form-num-ex/type 0.000'000'123'45 'gen 353 | ; form-num-ex/type 0.00'000'123'45 'gen 354 | ; form-num-ex/type 0.0'000'123'45 'gen 355 | ; form-num-ex/type 0.000'123'45 'gen 356 | ; form-num-ex/type 0.0012345 'gen 357 | ; form-num-ex/type 0.012345 'gen 358 | ; form-num-ex/type 0.12345 'gen 359 | ; form-num-ex/type 0.2345 'gen 360 | ; form-num-ex/type 0.345 'gen 361 | ; form-num-ex/type 0.45 'gen 362 | ; form-num-ex/type 0.5 'gen 363 | ; form-num-ex/type 1e16 'gen 364 | ; form-num-ex/type 1e-5 'gen 365 | ; form-num-ex/type 123.45% 'gen 366 | ; form-num-ex/type/to 123.45% 'gen 10% 367 | ; form-num-ex/type/to 123.45% 'gen 1% 368 | ; form-num-ex/type/to 123.45% 'gen .1 369 | ; 370 | ; form-num-ex/type 0 'eng 371 | ; form-num-ex/type -0 'eng 372 | ; form-num-ex/type 0.45 'eng 373 | ; form-num-ex/type 1.45 'eng 374 | ; form-num-ex/type 12.45 'eng 375 | ; form-num-ex/type 123.45 'eng 376 | ; form-num-ex/type 1234.0 'eng 377 | ; form-num-ex/type 12345.0 'eng 378 | ; form-num-ex/type 123450.0 'eng 379 | ; form-num-ex/type 1234500.0 'eng 380 | ; form-num-ex/type 12345000.0 'eng 381 | ; form-num-ex/type 123'450'000.0 'eng 382 | ; form-num-ex/type 1'234'500'000.0 'eng 383 | ; form-num-ex/type -1'234'500'000.0 'eng 384 | ; form-num-ex/type -0.000'000'123'45 'eng 385 | ; form-num-ex/type 0.000'000'123'45 'eng 386 | ; form-num-ex/type 0.00'000'123'45 'eng 387 | ; form-num-ex/type 0.0'000'123'45 'eng 388 | ; form-num-ex/type 0.000'123'45 'eng 389 | ; form-num-ex/type 0.0012345 'eng 390 | ; form-num-ex/type 0.012345 'eng 391 | ; form-num-ex/type 0.12345 'eng 392 | ; form-num-ex/type 0.2345 'eng 393 | ; form-num-ex/type 0.345 'eng 394 | ; form-num-ex/type 0.45 'eng 395 | ; form-num-ex/type 0.5 'eng 396 | ; form-num-ex/type 1e16 'eng 397 | ; form-num-ex/type 1e-5 'eng 398 | ; 399 | ; form-num-ex/type 0 'sci 400 | ; form-num-ex/type -0 'sci 401 | ; form-num-ex/type 0.45 'sci 402 | ; form-num-ex/type 1.45 'sci 403 | ; form-num-ex/type 12.45 'sci 404 | ; form-num-ex/type 123.45 'sci 405 | ; form-num-ex/type 1234.0 'sci 406 | ; form-num-ex/type 12345.0 'sci 407 | ; form-num-ex/type 123450.0 'sci 408 | ; form-num-ex/type 1234500.0 'sci 409 | ; form-num-ex/type 12345000.0 'sci 410 | ; form-num-ex/type 123'450'000.0 'sci 411 | ; form-num-ex/type 1'234'500'000.0 'sci 412 | ; form-num-ex/type -1'234'500'000.0 'sci 413 | ; form-num-ex/type -0.000'000'123'45 'sci 414 | ; form-num-ex/type 0.000'000'123'45 'sci 415 | ; form-num-ex/type 0.00'000'123'45 'sci 416 | ; form-num-ex/type 0.0'000'123'45 'sci 417 | ; form-num-ex/type 0.000'123'45 'sci 418 | ; form-num-ex/type 0.0012345 'sci 419 | ; form-num-ex/type 0.012345 'sci 420 | ; form-num-ex/type 0.12345 'sci 421 | ; form-num-ex/type 0.2345 'sci 422 | ; form-num-ex/type 0.345 'sci 423 | ; form-num-ex/type 0.45 'sci 424 | ; form-num-ex/type 0.5 'sci 425 | ; form-num-ex/type 1e16 'sci 426 | ; form-num-ex/type 1e-5 'sci 427 | ; 428 | ; form-num-ex/type 0 'acct 429 | ; form-num-ex/type -0 'acct 430 | ; form-num-ex/type 0.45 'acct 431 | ; form-num-ex/type 1.45 'acct 432 | ; form-num-ex/type 12.45 'acct 433 | ; form-num-ex/type 123.45 'acct 434 | ; form-num-ex/type 1234.0 'acct 435 | ; form-num-ex/type 12345.0 'acct 436 | ; form-num-ex/type 123450.0 'acct 437 | ; form-num-ex/type 1234500.0 'acct 438 | ; form-num-ex/type 12345000.0 'acct 439 | ; form-num-ex/type 123'450'000.0 'acct 440 | ; form-num-ex/type 1'234'500'000.0 'acct 441 | ; form-num-ex/type -1'234'500'000.0 'acct 442 | ; form-num-ex/type -0.000'000'123'45 'acct 443 | ; form-num-ex/type 0.000'000'123'45 'acct 444 | ; form-num-ex/type 0.00'000'123'45 'acct 445 | ; form-num-ex/type 0.0'000'123'45 'acct 446 | ; form-num-ex/type 0.000'123'45 'acct 447 | ; form-num-ex/type 0.0012345 'acct 448 | ; form-num-ex/type 0.012345 'acct 449 | ; form-num-ex/type 0.12345 'acct 450 | ; form-num-ex/type 0.2345 'acct 451 | ; form-num-ex/type 0.345 'acct 452 | ; form-num-ex/type 0.45 'acct 453 | ; form-num-ex/type 0.5 'acct 454 | ; form-num-ex/type 1e16 'acct ; limit of std notation 455 | ; form-num-ex/type 1e-14 'acct ; lower limit of precision 456 | ; form-num-ex/type 123.45% 'acct 457 | ; form-num-ex/type/to 123.45% 'acct 10% 458 | ; form-num-ex/type/to 123.45% 'acct 1% 459 | ; form-num-ex/type/to 123.45% 'acct .1 460 | 461 | ; form-num-ex/type 1234.5678 func [n [integer!] "Exponent"][either any [n < -7 n > 7][n][none]] 462 | ; form-num-ex/type 124123234.5678 func [n [integer!] "Exponent"][either any [n < -7 n > 7][n][none]] 463 | ; form-num-ex/type 14123234.5678 func [n [integer!] "Exponent"][either any [n < -7 n > 7][n][none]] 464 | ; form-num-ex/type 0.0000000123456789 func [n [integer!] "Exponent"][either any [n < -7 n > 7][n][none]] 465 | ; form-num-ex/type 0.000000123456789 func [n [integer!] "Exponent"][either any [n < -7 n > 7][n][none]] 466 | ; ] 467 | 468 | ;--------------------------------------------------------------------------- 469 | 470 | ; Experimental refinement approach. 471 | ; set 'format-bytes function [ 472 | ; "Return a string containing the size and units, auto-scaled" 473 | ; size [number!] 474 | ; /+ spec [block!] "[as to sep ]" 475 | ; ;/to scale "Rounding precision; default is 1" 476 | ; ;/as unit [word!] "One of [bytes KB MB GB TB PB EB ZB YB]" 477 | ; ;/sep ch [char! string!] "Separator to use between number and unit" 478 | ; ][ 479 | ; if negative? size [ 480 | ; return make error! "Format-bytes doesn't like negative numbers" 481 | ; ] 482 | ; if none? spec [spec: []] 483 | ; scale: any [spec/to 1] 484 | ; unit: spec/as 485 | ; ; 1 byte will come back as "1 bytes", unless we add it as a special case. 486 | ; units: [bytes KB MB GB TB PB EB ZB YB] 487 | ; either unit [ 488 | ; if not find units unit [ 489 | ; return make error! rejoin [mold unit " is not a valid unit for format-bytes"] 490 | ; ] 491 | ; ; Convert unit to a scaled power of 2 by finding the offset in 492 | ; ; the list of units. e.g. KB = 2 ** 10, MB = 2 ** 20, etc. 493 | ; size: size / (2.0 ** (10 * subtract index? find units unit 1)) 494 | ; rejoin [round/to size scale any [spec/sep ""] unit] 495 | ; ][ 496 | ; ; Credit to Gabriele Santilli for the idea this is based on. 497 | ; while [size > 1024][ 498 | ; size: size / 1024.0 499 | ; units: next units 500 | ; ] 501 | ; if tail? units [return make error! "Number too large for format-bytes"] 502 | ; rejoin [round/to size scale any [spec/sep ""] units/1] 503 | ; ] 504 | ; ] 505 | ; format-bytes 1000000000 506 | ; format-bytes/+ 1000000000 [as gb] 507 | ; format-bytes/+ 1000000000 [as gb to .01] 508 | ; format-bytes/+ 1000000000 [as gb to .01 sep #" "] 509 | 510 | ; set 'format-bytes function [ 511 | ; "Return a string containing the size and units, auto-scaled" 512 | ; size [number!] 513 | ; /to scale "Rounding precision; default is 1" 514 | ; /as unit [word!] "One of [bytes KB MB GB TB PB EB ZB YB]" 515 | ; /sep ch [char! string!] "Separator to use between number and unit" 516 | ; ][ 517 | ; scale: any [scale 1] 518 | ; ; 1 byte will come back as "1 bytes", unless we add it as a special case. 519 | ; units: [bytes KB MB GB TB PB EB ZB YB] 520 | ; either unit [ 521 | ; if not find units unit [ 522 | ; return make error! rejoin [mold unit " is not a valid unit for format-bytes"] 523 | ; ] 524 | ; ; Convert unit to a scaled power of 2 by finding the offset in 525 | ; ; the list of units. e.g. KB = 2 ** 10, MB = 2 ** 20, etc. 526 | ; size: size / (2.0 ** (10 * subtract index? find units unit 1)) 527 | ; rejoin [round/to size scale any [ch ""] unit] 528 | ; ][ 529 | ; ; Credit to Gabriele Santilli for the idea this is based on. 530 | ; while [size > 1024][ 531 | ; size: size / 1024.0 532 | ; units: next units 533 | ; ] 534 | ; if tail? units [return make error! "Number too large for format-bytes"] 535 | ; rejoin [round/to size scale any [ch ""] units/1] 536 | ; ] 537 | ; ] 538 | 539 | set 'format-bytes function [ 540 | "Return a string containing the size and unit suffix, auto-scaled" 541 | size [integer! float!] 542 | /to scale "Rounding precision; default is 1" 543 | /as unit [word!] "units: [bytes KiB MiB GiB TiB PiB EiB ZiB YiB]" 544 | /sep ch [char! string!] "Separator to use between number and unit" 545 | /SI "Use SI unit size of (1000); units: [bytes kB MB GB TB PB EB ZB YB]" 546 | /local unit-sz units 547 | ][ 548 | scale: any [scale 1] 549 | ; 1 byte will come back as "1 bytes", unless we add it as a special case. 550 | ;!! Float used for unit-sz to prevent integer division. 551 | set [unit-sz units] either SI [ 552 | [1000.0 [bytes kB MB GB TB PB EB ZB YB]] 553 | ][ 554 | [1024.0 [bytes KiB MiB GiB TiB PiB EiB ZiB YiB]] 555 | ] 556 | either unit [ 557 | if not find units unit [ ;?? Default to 'bytes to avoid error? 558 | return make error! rejoin [mold unit " is not a valid unit for format-bytes"] 559 | ] 560 | ; Convert unit to a scaled power based on the offset in the list of units. 561 | size: size / (unit-sz ** ((index? find units unit) - 1)) 562 | rejoin [round/to size scale any [ch ""] unit] 563 | ][ 564 | ; Credit to Gabriele Santilli for the idea this is based on. 565 | while [size >= unit-sz][ 566 | size: size / unit-sz 567 | units: next units 568 | ] 569 | if tail? units [return make error! "Number too large for format-bytes"] 570 | rejoin [round/to size scale any [ch ""] units/1] 571 | ] 572 | ] 573 | 574 | ; Should this also support integers, so format-number doesn't have to call this 575 | ; func? Really, it could support any value that can be converted to logic, but 576 | ; is that more helpful to the user, or will it make things more confusing for 577 | ; values like "" that convert to TRUE? 578 | set 'form-logic function [ 579 | "Format a logic value as a string" 580 | value [logic!] "If a custom format is used, fmt/1 is for true, fmt/2 for false" 581 | fmt [word! string! block!] "Custom format, or one of [true-false on-off yes-no TF YN]" 582 | ][ 583 | fmts: [ 584 | true-false ["True" "False"] 585 | on-off ["On" "Off"] 586 | yes-no ["Yes" "No"] 587 | TF "TF" 588 | YN "YN" 589 | ] 590 | if word? fmt [ ; Named formats 591 | if not find/skip fmts fmt 2 [ 592 | return make error! rejoin ["Unknown named format passed to form-logic: " fmt] 593 | ] 594 | fmt: fmts/:fmt 595 | ] 596 | if 2 <> length? fmt [ 597 | return make error! rejoin ["Format must contain 2 values: " fmt] 598 | ] 599 | form pick fmt value ; Form is used here to support custom values 600 | ] 601 | 602 | set 'mold-logic function [ 603 | "Return a logic value as a word" 604 | value [logic!] 605 | /true-false "(default)" 606 | /on-off 607 | /yes-no 608 | ][ 609 | pick case [ 610 | on-off [[on off]] 611 | yes-no [[yes no]] 612 | 'else [[true false]] 613 | ] value 614 | ] 615 | 616 | ;--------------------------------------------------------------------------- 617 | ; Mask formatting parse rules 618 | 619 | nbsp: " " ; char 160 - non-breaking space alt syntax = #"^(A0)" 620 | thinsp: " " ; 8201 \u+2009 thin space 621 | narrow-nbsp: #" " ; 8239 622 | dot-above: #"˙" ; 729 623 | digit: charset "0123456789" 624 | mask-digit: charset "0123456789#?" 625 | mask-group: charset "' ·_" ; group seps EXCLUDING ', and '. Add nbsp thinsp 626 | mask-other: charset "+-()$%£¥€¢¤" 627 | not-point: charset [not #"."] 628 | not-comma: charset [not #","] 629 | not-dbl-quote: charset [not "^""] 630 | dbl-quote-str: [#"^"" any not-dbl-quote #"^""] 631 | ; ×xeE ×=char 215 632 | 633 | ;--------------------------------------------------------------------------- 634 | ; Numeric formatting support funcs 635 | 636 | ; Need to think about this, and refactor them into a generic func. 637 | ; Another way to approach this will be to count the number of commas and 638 | ; points, and mark the last position of each. That can drive a heuristic 639 | ; to determine which is the group sep and which is the deci sep. 640 | deci-point?: function [ 641 | "Returns true if . is the decimal separator" 642 | str [any-string!] 643 | ][ 644 | if not empty? str [ 645 | to logic! any [ 646 | parse str [ 647 | some [mask-digit | mask-other | mask-group | dbl-quote-str | #","] 648 | #"." any [mask-digit | mask-group] any [dbl-quote-str | mask-other] 649 | ] 650 | parse str [#"." some [mask-digit | mask-group] any [dbl-quote-str | mask-other]] 651 | ;?? If there is no decimal mark at all, what should we do? 652 | (parse str [some [mask-digit | mask-other | dbl-quote-str]] return false) 653 | ] 654 | ] 655 | ] 656 | deci-comma?: function [ 657 | "Returns true if , is the decimal separator" 658 | str [any-string!] 659 | ][ 660 | if not empty? str [ 661 | to logic! any [ 662 | parse str [ 663 | some [mask-digit | mask-other | mask-group | dbl-quote-str | #"."] 664 | #"," any [mask-digit | mask-group] any [dbl-quote-str | mask-other] 665 | ] 666 | parse str [#"," some [mask-digit | mask-group] any [dbl-quote-str | mask-other]] 667 | ;?? If there is no decimal mark at all, what should we do? 668 | (parse str [some [mask-digit | mask-other | dbl-quote-str]] return false) 669 | ] 670 | ] 671 | ] 672 | deci-char: function [ 673 | "Returns decimal separator for a mask string" 674 | mask [any-string!] 675 | ][ 676 | case [ 677 | deci-point? mask [#"."] 678 | deci-comma? mask [#","] 679 | not find mask charset ",." [""] 680 | 'else [""] ;[make error! form reduce ["Ambiguous or malformed format-number mask:" mask]] 681 | ] 682 | ] 683 | 684 | 685 | ;!! Won't work for E notation numbers yet (>= 1.0e16, < 1e-5), 686 | ;!! because we rely on FORM. We can trick things on the small 687 | ;!! side, by adding 1 to them, forming, then treating the whole 688 | ;!! part as zero. Ick. Hack. 689 | ; This approach is not intended to be clever, efficient, elegant, 690 | ; or Reddish. It's to help think through the combinations we need 691 | ; to support. 692 | merge-number-mask: function [ 693 | mask [string!] 694 | num [string!] "Formed number" 695 | sign [integer!] "1, 0, -1" 696 | /whole "Merge from right to left" 697 | /frac "Merge from left to right" 698 | ][ 699 | ; We're going to process the whole part of our number from 700 | ; least to most significant digit. Reversing them lets the 701 | ; merge logic walk forward through them. 702 | if whole [ 703 | reverse mask 704 | reverse num 705 | ] 706 | result: make string! length? mask 707 | while [any [not tail? mask not tail? num]][ 708 | new-ch: switch/default ch: first+ mask [ 709 | #"^^" [first+ mask] ; escape, take the next char 710 | #"0" [any [first+ num #"0"]] 711 | #"9" [any [first+ num #" "]] 712 | #"?" [any [first+ num #" "]] 713 | #"#" [any [first+ num ""]] 714 | #[none] [first+ num] ; We ran out of mask chars 715 | #"(" [s?: yes either negative? sign [#"("][""]] ; If we hit any sign char, set a flag 716 | #")" [s?: yes either negative? sign [#")"][" "]] 717 | #"+" [s?: yes either negative? sign [#"-"][#"+"]] 718 | #"-" [s?: yes either negative? sign [#"-"][#" "]] 719 | #"^"" [ 720 | while [dbl-quote <> str-ch: first+ mask][append result str-ch] 721 | "" ; Return empty string so we don't append anything else 722 | ] 723 | ][ch] 724 | ;print [tab mold mask mold num mold ch mold new-ch] 725 | ; If our mask is too short, we may have added a sign/special char already, 726 | ; which means that any extra digits from the number will be appended 727 | ; after it. When reversed, that puts the sign between some digits. 728 | ; What we'll do is look at the last char we added. If it's a sign, 729 | ; and if we have a digit to add, we'll step back one when adding it. 730 | ;!! There is a case this will not catch. If "-" is used in the mask, 731 | ; but the number is positive, we'll end up with a space at the end 732 | ; and we have to decide if we should check for spaces, or if they're 733 | ; valid group separators. 734 | either all [not empty? result find mask-other last result find digit new-ch][ 735 | insert back tail result new-ch 736 | ][ 737 | append result new-ch 738 | ] 739 | ] 740 | if all [not frac not s? negative? sign][append result #"-"] 741 | 742 | either whole [ 743 | reverse mask 744 | reverse num 745 | reverse result 746 | ][result] 747 | ] 748 | 749 | ;!! If we're going to remove extra group seps, we have to decide 750 | ; what to do about spaces. They should probably not be used as 751 | ; group seps, because we can't tell them from placeholder spaces. 752 | ; thinsp might be OK. nbsp, not sure. 753 | remove-leading-group-separators: function [str [string!] dec-ch [char! string!]][ 754 | ; If we include the space char here, it conflicts with using 9/?, 755 | ; instead of #, because those spaces are intentional. Otherwise 756 | ; we could just use 'mask-group here. 757 | sep: charset "'·_" ; group seps EXCLUDING ', and '. Add nbsp thinsp 758 | 759 | ; Add the standard group sep that is NOT the deci char they gave us. 760 | if all [string? dec-ch empty? dec-ch] [dec-ch: #"."] 761 | append sep either #"." = dec-ch [#","][#"."] 762 | 763 | parse str [ 764 | any [ 765 | [[digit | dec-ch] to end] 766 | | remove sep 767 | | skip 768 | ] 769 | ] 770 | str 771 | ] 772 | 773 | remove-trailing-group-separators: function [str [string!] dec-ch [char! string!]][ 774 | reverse str 775 | remove-leading-group-separators str dec-ch 776 | reverse str 777 | ] 778 | 779 | ; These are here because things get tricky once we decide to break 780 | ; up the mask and merge the whole and fractional parts separately. 781 | ; The issue being whether the whole part merge should automatically 782 | ; add a - for negative numbers where no sign sigil is given in the 783 | ; mask. For international use, the sign may also go on the right. 784 | ; See: https://msdn.microsoft.com/en-us/globalization/mt662322.aspx 785 | ; If the sign is on the fraction in the mask, the whole part doesn't 786 | ; know about that, and will erroneously add one. In that case, we 787 | ; need to use the absolute value of the number when formatting the 788 | ; whole part. But if a sign sigil is in both mask parts, explicitly, 789 | ; we should include it in both. That's also true for parens in 790 | ; accounting format, which need to be applied to both sides. 791 | sign-ch: charset "+-" 792 | acct-sign-ch: charset "()" 793 | whole-sign?: func [mask [block!] n [number!]][ 794 | ; If all these things are true, use the absolute value for the whole part. 795 | sign? either all [ 796 | find mask/frac sign-ch 797 | not find mask/frac acct-sign-ch 798 | not find mask/whole sign-ch 799 | not find mask/whole acct-sign-ch 800 | ][abs n][n] 801 | ] 802 | ; Don't need this yet 803 | ;frac-sign?: func [mask [block!] n [number!]][] 804 | 805 | set 'format-number-with-mask function [ 806 | "Return a formatted number, using a mask as a template" 807 | n [number!] 808 | mask [string!] 809 | ][ 810 | result: make string! length? mask 811 | 812 | ; Convert number to string, removing standard type decorations, 813 | ; then split it at the decimal mark. 814 | ;!! We do NOT round when formatting. That's up to the caller. 815 | ;!! We always break at #"." against a FORMed number, as Red 816 | ; will always use that as the default decimal separtaor. 817 | ;!! Merge-number-mask can't handle E notation numbers, so we'll 818 | ; hack our way around that while experimenting, and trick FORM 819 | ; into giving us a non-scientific format. Currently, .1 is the 820 | ; lower limit where Red formats with E notation. 821 | either all [n > -0.1 n < .1 n <> 0 not percent? n][ 822 | ; Add 1 to the absolute value of the number, to trick FORM. 823 | ; We don't want the sign, hence ABS, or we could instead to 824 | ; `num: form n + (1 * sign? n)` 825 | num: form 1 + abs n 826 | ; Now our first digit is 1, but we added that, so change it to 0. 827 | change num #"0" 828 | ][ 829 | num: form abs n 830 | ; Just in case Red changes the rules on us. 831 | if find num #"e" [return make error! rejoin ["format-number-with-mask doesn't like " n]] 832 | ] 833 | num: break-at trim/with num "$%" "." 834 | num: reduce ['whole num/1 'frac num/2] 835 | 836 | ; Split the mask at the decimal mark. The mask is what defines 837 | ; the decimal character, which we remember, so we can use it 838 | ; when rebuilding the complete number. 839 | mask: break-at mask d-ch: deci-char mask 840 | mask: reduce ['whole mask/1 'frac mask/2] 841 | 842 | ; If breaking the string produced single chars, instead of strings, 843 | ; we need to form them for the merge processing to work. 844 | change-all num :form-if-char 845 | change-all mask :form-if-char 846 | 847 | ; It's a bit redundant to use /whole and /frac multiple times, but 848 | ; if we pass the blocks with each part, then merge-number-mask has 849 | ; a more demanding interface for independent use. This way it uses 850 | ; plain strings. 851 | whole: merge-number-mask/whole mask/whole num/whole whole-sign? mask n 852 | frac: either empty? mask/frac [""][ 853 | merge-number-mask/frac mask/frac num/frac sign? n 854 | ] 855 | 856 | ;prin mold reduce [whole d-ch frac] 857 | repend/only result [whole d-ch frac] ; d-ch = decimal char 858 | 859 | ; Now we may have a group separator before any digits, which 860 | ; we don't want. Other chars, like currency symbols and signs 861 | ; are fine, but not group separators. 862 | remove-leading-group-separators result d-ch 863 | remove-trailing-group-separators result d-ch 864 | 865 | ;set 'dbg reduce [num mask whole frac] 866 | result 867 | ] 868 | 869 | 870 | ; 'via instead of 'with to make it clearer that this is different, for now. 871 | set 'format-number-via-masks function [ 872 | "Return a formatted number, selecting a mask as a template based on the number's value" 873 | value [number!] 874 | fmts [string! block! map!] "Masks appplied based on the sign or special value of n" 875 | ][ 876 | ; custom format 877 | either any-string? fmt [ 878 | fmts: split fmt ";" 879 | ][ 880 | set-fmt: func [val] [change find fmts none val] 881 | ; any-block? 882 | 883 | ; If they give us a block with four items, having "0" as our first 884 | ; element here messes us up. Instead, we'll set it later if need be. 885 | ;fmts: reduce ["0" none none none] ; pos neg zero none 886 | fmts: reduce [none none none none] ; pos neg zero none 887 | 888 | parse fmt [ 889 | some [ 890 | set f string! ( 891 | either find fmts none [set-fmt f] [ 892 | print ["Too many formats specified," mold f "will be ignored"] 893 | ] 894 | ) 895 | | ['pos | 'positive | 'positive?] set f string! (fmts/1: f) 896 | | ['neg | 'negative | 'negative?] set f string! (fmts/2: f) 897 | | ['zero | 'zero?] set f string! (fmts/3: f) 898 | | ['none | 'none?] set f string! (fmts/4: f) 899 | ] 900 | ] 901 | ] 902 | 903 | if empty? fmts [insert fmts "0"] 904 | if none? fmts/1 [fmts/1: "0"] 905 | ;print ["fmts:" mold fmts] 906 | 907 | ;#fmts 908 | ; 1 1 - all vals 909 | ; 2 1 - pos and zero, 2 - neg 910 | ; 3 1 - pos, 2 - neg, 3 - zero 911 | ; 4 1 - pos, 2 - neg, 3 - zero, 4 - none 912 | ; missing fmts deault back to pos fmt 913 | fmt: case [ 914 | ; have to try NONE? first; NONE will choke the other funcs. 915 | ; Formats are: [pos neg zero none] 916 | ;none? value [any [fmts/4 fmts/1]] 917 | none? value [pick fmts 4] 918 | positive? value [fmts/1] 919 | negative? value [any [fmts/2 fmts/1]] 920 | zero? value [any [fmts/3 fmts/1]] 921 | ] 922 | ;print ["fmt:" mold fmt] 923 | 924 | ; A NONE value is a special case. We can't really format it as a number, so 925 | ; we return the specified format string directly. If they didn't provide one, 926 | ; should we fall back to fmts/1 as I did originally, or should we return a 927 | ; known error value (e.g. #ERR)? 928 | ;if none? value [return fmt] 929 | if none? value [return either fmt [fmt] [#ERR]] 930 | 931 | format-number-with-mask value fmt 932 | ] 933 | 934 | 935 | num-to-bin-str: func [ 936 | num [number!] "Rounded to integer before formatting" 937 | return: [string!] 938 | ][ 939 | enbase/base num-to-hex-bin num 2 940 | ] 941 | num-to-hex-bin: func [ 942 | num [number!] "Rounded to integer before conversion" 943 | return: [binary!] 944 | ][ 945 | to binary! to integer! round num 946 | ] 947 | 948 | set 'format-number-with-style function [ 949 | "Return a formatted number, by named style" 950 | n [number!] 951 | name [word!] "Named or direct style" ; object! map! 952 | ][ 953 | r-sep: #"'" 954 | add-seps: :form-num-with-group-seps 955 | switch name [ 956 | ;The 'r- prefix stands for "round-trip/Ren/Redbol" 957 | r-general 958 | r-standard [add-seps/with n r-sep] ; #'##0.0# 959 | r-fixed [add-seps/with format-number-by-width n 1 2 r-sep] ; #'##0.00 960 | ;r-currency [add-seps/with to money! n r-sep] ; $#'##0.00 961 | ;r-money [add-seps/with to money! n r-sep] ; $#'##0.00 962 | r-money 963 | r-currency [format-number-with-mask round/to n .01 "$#'###'###'###'##0.00"] ; $#'##0.00 -$#'##0.00 964 | ;r-currency [add-seps/with round/to n .01 r-sep] ; $#'##0.00 -$#'##0.00 965 | r-percent [add-seps/with format-number-by-width to percent! n 1 2 r-sep] ; format-number-by-width auto handles percent 966 | r-ordinal [add-seps/with as-ordinal to integer! n r-sep] 967 | r-hex [to-hex to integer! n] 968 | 969 | gen general standard [add-seps n] ; #,##0.0# 970 | fixed [add-seps format-number-by-width n 1 2] ; #,##0.00 971 | ;currency [add-seps to money! n] ; $#,##0.00 972 | ;money [add-seps to money! n] ; $#,##0.00 973 | money 974 | currency [format-number-with-mask round/to n .01 "$#,###,###,###,##0.00"] ; $#,##0.00 975 | ;currency [add-seps round/to n .01] ; $#,##0.00 976 | percent [add-seps format-number-by-width to percent! n 1 2] 977 | ;percent [join add-seps next form to money! value * 100 #"%"] 978 | sci scientific [form-num-ex/type n 'sci] 979 | eng engineering [form-num-ex/type n 'eng] 980 | acct accounting [add-seps form-num-ex/type n 'acct] 981 | ;accounting [format-number-via-masks n [pos " #,##0.00 " neg "(#,##0.00)" zero "-" none ""]] 982 | ordinal [add-seps as-ordinal to integer! n] 983 | 984 | base-64 [enbase/base form n 64] 985 | hex [form to-hex to integer! n] 986 | min-hex [ ; No leading zeros 987 | either zero? n [""] [ 988 | find form to-hex to integer! n complement charset "0"] ; No leading zeros 989 | ] 990 | C-hex [join "0x" to-hex to integer! n] 991 | ;VB-hex [join "&H" to-hex to integer! n] 992 | ;octal [] ; maybe useful for things like `chmod 755` viz ; no enbase for octal yet 993 | bin binary [num-to-bin-str n] 994 | min-bin [ ; No leading zeros 995 | either zero? n [""] [ 996 | form find num-to-bin-str n complement charset "0" 997 | ] 998 | ] 999 | 1000 | 1001 | ;rel-days [num-to-rel-date-time n 'rel-days] 1002 | ;rel-hours [num-to-rel-date-time n 'rel-hours] 1003 | ;rel-time [num-to-rel-date-time n 'rel-time] 1004 | ; throw error - unknown named format specified? 1005 | ;case else [either any-block? value [reform n] [form n]] 1006 | ] 1007 | ] 1008 | 1009 | ; The printf model of . lengths is unintuitive to me. It seems more 1010 | ; natural to use .. The question is how much "discussion" that 1011 | ; will cause. . makes sense at the higher level, assuming 1012 | ; accounts for signs and the decimal point. My issue is that it looks like you're 1013 | ; mapping m.n to . directly, if you think of how the number looks. 1014 | set 'format-number-by-width function [ 1015 | "Formats a number given a total length and a maximum number of decimal digits. No separators added." 1016 | value [number!] "The value to format" 1017 | tot-len [integer!] "Minimum total width. (right justified, never truncates)" 1018 | dec-len [integer!] "Maximum digits to the right of the decimal point. (left justified, may round)" 1019 | ; Using left/right saves a param over [/align dir] and will catch more errors 1020 | /left "Left align" 1021 | /right "Right align (default)" 1022 | /use+ "Include + sign for positive values" 1023 | /with 1024 | ch [char!] "Alternate fill char (default is space)" 1025 | ][ 1026 | ch: any [ch #" "] 1027 | sign: case [ 1028 | negative? value ["-"] ; Always use - for negative 1029 | use+ ["+"] ; Force the + sign on 1030 | left [" "] ; Reserve space to match +/- 1031 | 'else [""] ; Positive or right align, don't force + 1032 | ] 1033 | if percent? value [dec-len: dec-len + 2] ; Percents look like whole values, but are scaled. 1034 | ; It would be nice if we could just join the sign to the rest here, 1035 | ; which I did first. The problem is that fill chars end up to the 1036 | ; left of it. Fine for spaces, underscore, etc., not for 0. 1037 | either ch = #"0" [ 1038 | value: mold round/to abs value 10 ** negate dec-len 1039 | value: pad-aligned value either left ['left]['right] (tot-len - length? sign) ch 1040 | head insert find value digit sign 1041 | ][ 1042 | value: join sign mold round/to abs value 10 ** negate dec-len 1043 | pad-aligned value either left ['left]['right] tot-len ch 1044 | ] 1045 | ] 1046 | 1047 | ] ; end of formatting context 1048 | 1049 | ;------------------------------------------------------------------------------- 1050 | ;------------------------------------------------------------------------------- 1051 | 1052 | is-named-logic-format?: func [fmt][find [YN TF yes-no on-off true-false] fmt] 1053 | 1054 | format-number: function [ 1055 | value [number!] 1056 | fmt [word! string! block!] "Named or custom format" 1057 | ][ 1058 | 1059 | case [ 1060 | is-named-logic-format? fmt [form-logic not zero? value fmt] ; to logic! 0 == true in Red. 1061 | block? fmt [format-number-via-masks value fmt] 1062 | string? fmt [format-number-via-masks value fmt] 1063 | word? fmt [format-number-with-style value fmt] 1064 | ] 1065 | ] 1066 | 1067 | 1068 | ;------------------------------------------------------------------------------- 1069 | ; This is the block equivalent to the short-form string interpolation formatter. 1070 | ; TBD: It would be really nice if they could share a common infrastructure. 1071 | if not value? 'short-format-ctx [do %short-format.red] 1072 | 1073 | block-format-ctx: context [ 1074 | 1075 | ;--------------------------------------------------------------------------- 1076 | ;-- Block-Form Field Parser 1077 | 1078 | ; TBD: 1079 | ; A|a flags for upper/lower case 1080 | ; Aa for mixed case (but it's not a single char flag) 1081 | ; Named formats 1082 | format-proto: context [ 1083 | key: ; No key means take the next value; /n means pick by index if int or key if not int; 1084 | flags: ; 0 or more of "<>_+0Zº$¤" 1085 | width: ; Minimum TOTAL field width 1086 | prec: ; Maximum number of decimal places (may be less, not zero padded on right) 1087 | style: ; Named format 1088 | none 1089 | ] 1090 | 1091 | =key: 1092 | =flags: 1093 | =width: 1094 | =prec: 1095 | =style: 1096 | =plain: 1097 | =parts: 1098 | none 1099 | 1100 | digit=: charset "0123456789" 1101 | flag-char=: charset "_+0<>Zzº$¤" ; º=186=ordinal ¤=164=currency 1102 | 1103 | flags=: [ 1104 | set =flags get-word! ( 1105 | =flags: form =flags 1106 | if not parse =flags [some flag-char=][ 1107 | make error! rejoin ["Unknown flag characters found: " =flags] 1108 | ] 1109 | ) 1110 | ] 1111 | width=: [set =width integer!] 1112 | prec=: [set =prec integer!] 1113 | style=: [set =style word!] 1114 | key=: [ 1115 | set =key [refinement! | path! | paren!] ( 1116 | if refinement? =key [=key: load form =key] ;=key: to either parse form =key [some digit=] [integer!][word!] 1117 | ) 1118 | ] 1119 | 1120 | ; `[/key][:flags][width][.precision]]['style]` 1121 | ; `:[flags][width][.precision]['style]` 1122 | ; `:[flags]['style]` 1123 | ; there may be (in this order) zero or more flags, an optional minimum 1124 | ; field width, an optional precision and an optional length modifier. 1125 | fmt=: [opt flags= opt [width= opt prec=] opt style=] 1126 | 1127 | field=: [ 1128 | (=flags: =width: =prec: =key: =style: none) 1129 | [key= opt fmt= | fmt=] ( 1130 | ;if find =flags #"º" [=style: quote 'ordinal] 1131 | ;?? If there is a ' following the currency flag, should we use r-money? 1132 | if find =flags charset "$¤" [=style: quote 'money] 1133 | append/only =parts make format-proto compose [ 1134 | key: :=key flags: (=flags) width: (=width) prec: (=prec) style: =style 1135 | ] 1136 | ) 1137 | ] 1138 | not-paren!: make typeset! head remove find to block! default! 'paren! 1139 | ;plain=: [(=plain: none) set =plain not-paren! (append =parts =plain)] 1140 | plain=: [(=plain: none) copy =plain some not-paren! (append =parts =plain)] 1141 | format=: [ 1142 | ( 1143 | =parts: copy [] 1144 | =plain: none 1145 | ) 1146 | any [ 1147 | end break 1148 | ;| set =plain any-string! (append =parts =plain) ; prevent into on strings 1149 | | ahead paren! into field= 1150 | | plain= 1151 | ] 1152 | ] 1153 | 1154 | ;--------------------------------------------------------------------------- 1155 | 1156 | with: func [ 1157 | obj [object! none!] 1158 | body [block!] 1159 | ][ 1160 | if obj [do bind/copy body obj] 1161 | ] 1162 | 1163 | set 'parse-as-block-format func [ 1164 | "Parse input, returning block of literal string and field spec blocks" 1165 | input [block!] 1166 | ][ 1167 | if parse input format= [ 1168 | ; If there was only a format in the input, return just 1169 | ; that spec directly. 1170 | ;!! Can't use WITH on this right now. Parse conflict in rules. 1171 | either short-format-ctx/one-spec? =parts [=parts/1][=parts] 1172 | ] 1173 | ] 1174 | 1175 | with short-format-ctx [ ; leverage internals now, work on commonality 1176 | 1177 | set 'block-form function [ 1178 | "Format and substitute values into a template block" 1179 | input [block!] "Template block containing (/value:format) fields and literal data" 1180 | data "Value(s) to apply to template fields" 1181 | /only "Return as block, instead of string" 1182 | /tight "Don't put spaces between elements" 1183 | ][ 1184 | result: clear [] 1185 | if series? data [data: copy data] 1186 | if none? spec: parse-as-block-format input [return none] ; Bail if the format string wasn't valid 1187 | if object? spec [ ; We got a single format spec 1188 | result: apply-format-by-key+data spec data 1189 | return either only [reduce [result]][result] 1190 | ] 1191 | collect/into [ 1192 | foreach item spec [ 1193 | keep either not object? item [mold :item][ ; literal data from template string 1194 | apply-format-by-key+data item data 1195 | ] 1196 | ] 1197 | ] result 1198 | either only [result][either tight [rejoin result][form result]] 1199 | ] 1200 | ] 1201 | 1202 | ] 1203 | 1204 | ;------------------------------------------------------------------------------- 1205 | 1206 | 1207 | set 'format-value func [ 1208 | value [number! none! time! logic! any-string!] ; money! date! 1209 | fmt [word! string! block!] "Named or custom format" 1210 | /local type 1211 | ] [ 1212 | type: type?/word value 1213 | ;print ['xxx type mold value mold :fmt] 1214 | case [ 1215 | ; not sure what to do with NONE values. 1216 | find [integer! float! percent! none!] type [format-number value fmt] ; decimal! money! 1217 | ; find [time!] type [format-date-time value fmt] ; date! 1218 | type = 'logic! [form-logic value fmt] 1219 | any-string? value [format-string value fmt] 1220 | ] 1221 | ] 1222 | 1223 | 1224 | ;[number! not 'bytes] format-number 1225 | ;[number! 'bytes] format-bytes 1226 | ;[logic! *] form-logic 1227 | ;[parse-as-composite string!] composite 1228 | ;[parse-as-short-format string! any-type!] short-form 1229 | ;[parse-as-block-format block! any-type!] block-form 1230 | ;[any-string! *] format-string 1231 | ;[[date! time!] *] format-date-time 1232 | ;else 1233 | 1234 | multi-format?: func [fmt][ 1235 | case [ 1236 | string? fmt [all [find fmt #";" 4 >= length? split fmt #";"]] 1237 | ] 1238 | ] 1239 | 1240 | select-format: func [fmts value][] 1241 | 1242 | ; Interpolation funcs are not handled here, because arg order is reversed. 1243 | set 'format function [ 1244 | value [any-type!] 1245 | fmt [word! string! block! function! object! map!] "Named or custom format" 1246 | ][ 1247 | type: type?/word :value 1248 | ;print ['xxx type mold value mold :fmt] 1249 | 1250 | if multi-format? fmt [ 1251 | fmt: select-format fmt value 1252 | ] 1253 | 1254 | case [ 1255 | none? :value [] ; dispatch based on fmt 1256 | all [number? :value :fmt <> 'bytes] [format-number value :fmt] ; decimal! money! 1257 | all [number? :value :fmt = 'bytes] [format-bytes value :fmt] 1258 | 1259 | ;find [date! time!] type [format-date-time value fmt] 1260 | 1261 | logic? :value [form-logic value :fmt] 1262 | 1263 | any-string? :value [format-string value fmt] 1264 | 1265 | ; interpolation (doubtful we'll keep this here) 1266 | all [block? :value parse-as-block-format :value] [block-form value fmt] 1267 | all [string? :value parse-as-short-format :value] [short-form value fmt] 1268 | ] 1269 | ] 1270 | 1271 | ; Rather than having these REFORM the result, if they just return the block of 1272 | ; formatted values, the caller can choose to rejoin, reform, delimit, etc. 1273 | ; We also need to make sure we add value over what PRINT does by default. 1274 | 1275 | ;set 'reformat func [input [block!]] [ 1276 | ; reform collect item [ 1277 | ; foreach val input [ 1278 | ; item: either block? :val [format val/1 val/2] [form val] 1279 | ; ] 1280 | ; ] 1281 | ;] 1282 | ; 1283 | ;set 'reformat-b func [data [block!] template [block!] /local res] [ 1284 | ; reform collect item [ 1285 | ; foreach val template [ 1286 | ; item: either all [block? :val not empty? val] [ 1287 | ; res: format data/1 val/1 1288 | ; data: next data 1289 | ; res 1290 | ; ] [form val] 1291 | ; ] 1292 | ; ] 1293 | ;] 1294 | -------------------------------------------------------------------------------- /formatting-functions.adoc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/greggirwin/red-formatting/3ff508b55cdb8ae6400789295b24045c8eea196b/formatting-functions.adoc -------------------------------------------------------------------------------- /short-format.red: -------------------------------------------------------------------------------- 1 | Red [] 2 | 3 | short-format-ctx: none 4 | if not value? 'apply-format-style [do %format.red] 5 | 6 | short-format-ctx: context [ 7 | 8 | ; I've never liked the name of this func, but I'm including it here 9 | ; because the behavior is handy for how I'm merging masks currently. 10 | first+: func [ ; first+next 11 | "Return first value in series, and increment the series index." 12 | 'word [word! paren!] "Word must be a series." 13 | ][ 14 | if paren? :word [set/any 'word do :word] 15 | also pick get word 1 set word next get word 16 | ] 17 | 18 | ;--------------------------------------------------------------------------- 19 | ;-- Short-Form Field Parser 20 | 21 | ; TBD: 22 | ; A|a flags for upper/lower case 23 | ; Aa for mixed case (but it's not a single char flag) 24 | ; Named formats 25 | format-proto: context [ 26 | key: ; No key means take the next value; /n means pick by index if int or key if not int; 27 | flags: ; 0 or more of "<>_+0Zº$¤" 28 | width: ; Minimum TOTAL field width 29 | prec: ; Maximum number of decimal places (may be less, not zero padded on right) 30 | style: ; Named format 31 | none 32 | ] 33 | 34 | =key: 35 | =flags: 36 | =width: 37 | =prec: 38 | =style: 39 | =plain: 40 | =parts: 41 | =esc: 42 | none 43 | 44 | digit=: charset "0123456789" 45 | flag-char=: charset "_+0<>Zzº$¤" ; º=186=ordinal ª=170=ordinal ¤=164=currency 46 | ; Could add ª ordinal support, which is easy here, but adds 47 | ; more every place we have to check for it as a flag. 48 | key-sigil=: #"/" 49 | fmt-sigil=: #":" ; _=&@! 50 | sty-sigil=: #"'" 51 | sigil=: [key-sigil= | fmt-sigil=] 52 | ;| "^^" [#":" (append =parts ":") | "/" (append =parts "/")] 53 | esc=: [ 54 | [copy =esc [": " | "://" | "/ "] | "^^" copy =esc [":" | "/"]] 55 | (append =parts =esc) 56 | ] 57 | flags=: [copy =flags some flag-char=] 58 | width=: [#"*" (=width: none) | copy =width some digit= (=width: to integer! =width)] 59 | prec=: [#"." [#"*" (=prec: none) | copy =prec some digit= (=prec: to integer! =prec)]] 60 | end-key=: [#":" | #" " | end] 61 | end-style=: [#":" | #" " | #"/" | end] 62 | style=: [sty-sigil= copy =style to end-style= (=style: to lit-word! =style)] 63 | key=: [ 64 | key-sigil= [ 65 | [copy =key some digit= (=key: to integer! =key)] ; produce int index 66 | ; TBD: Think about security. DOing parens is great, until you 67 | ; get some untrusted data being used. We could easily limit 68 | ; the length or have a secure mode lock on by default though. 69 | | [copy =key [#"(" thru #")"] (=key: load =key)] ; produce paren! 70 | | [copy =key to [end-key= skip | end] (=key: either empty? =key [none][load =key])] ; produce other key (word, path, etc.) 71 | ] 72 | ] 73 | 74 | ; `/[key][:[flags][width][.precision]]['style]` 75 | ; `:[flags][width][.precision]['style]` 76 | ; `:[flags]['style]` 77 | ; there may be (in this order) zero or more flags, an optional minimum 78 | ; field width, an optional precision and an optional length modifier. 79 | fmt=: [fmt-sigil= opt flags= opt width= opt prec= opt style=] 80 | 81 | field=: [ 82 | (=flags: =width: =prec: =key: =style: none) 83 | [key= opt fmt= | fmt=] ( 84 | ;if find =flags #"º" [=style: quote 'ordinal] 85 | ;?? If there is a ' following the currency flag, should we use r-money? 86 | if find =flags charset "$¤" [=style: quote 'money] ; quote because we compose it in below 87 | append/only =parts make format-proto compose [ 88 | key: :=key flags: (=flags) width: (=width) prec: (=prec) style: (=style) 89 | ] 90 | ) 91 | ] 92 | ;TBD: support :// as plain text for urls. 93 | plain=: [ 94 | (=plain: none) 95 | copy =plain to [sigil= | #"^^" | end] (append =parts =plain) 96 | ] 97 | ;plain=: [(=plain: none) copy =plain some [not sigil=] (append =parts =plain)] 98 | format=: [ 99 | ( 100 | =parts: copy [] 101 | =plain: none 102 | ) 103 | any [ 104 | end break 105 | | esc= 106 | | field= 107 | | plain= 108 | ] 109 | ] 110 | 111 | ;--------------------------------------------------------------------------- 112 | ;-- Internal 113 | 114 | do-paren: func [val [paren!] /local res] [ 115 | either error? set/any 'res try [do val][ 116 | form reduce ["*** Error:" res/id "Where:" val] 117 | ][ 118 | either unset? get/any 'res [""][:res] 119 | ] 120 | ] 121 | 122 | flag?: func [spec [block! object!] flag [char!]][find spec/flags flag] 123 | 124 | get-path-key: function [ 125 | "Return a value for a path/key, either in data or the global context" 126 | data ;[block! object! map!] 127 | key [path!] 128 | ][ 129 | ;!! DO key here produces strange results. Sometimes false, sometimes ["-"] 130 | ;!! for system/words/pi, even though they look the same and the binding 131 | ;!! appears to be the same. 132 | ;print ['*** mold data key do key key = 'system/words/pi same? context? last key system/words] 133 | ;if unstruct-data? data [return try [get key]] 134 | 135 | ; First, try to find the key in the data we were given. 136 | ; Failing that, try to get it from the global context. 137 | ; That may also fail. Now/time is a special failure case, 138 | ; but we may also get a 'no-value error. If that happens 139 | ; when trying to GET it, there's no point in DOing it. 140 | val: try [get append to path! 'data key] 141 | if all [error? val find [bad-path-type invalid-path no-value] val/id] [ 142 | val: try [get key] ; now/time, e.g., fails here 143 | if all [error? val val/id = 'invalid-path-get][ 144 | val: try [do key] 145 | ] 146 | ] 147 | val 148 | ] 149 | 150 | one-spec?: func [data [block!]][all [1 = length? data object? data/1]] 151 | 152 | pad-aligned: func [str [string!] align [word!] wd [integer!] ch][ 153 | switch align [ 154 | left [pad/with str wd ch] 155 | right [pad/with/left str wd ch] 156 | ] 157 | ] 158 | 159 | pick-val: func [data [block! map! object!] index [integer!]] [ 160 | pick either block? data [data][values-of data] index 161 | ] 162 | 163 | sign-from-flags: func [ 164 | spec [object! block! map!] 165 | value 166 | ][ 167 | either negative? value ["-"][ ; always use "-" for negative 168 | any [ 169 | all [flag? spec #"+" "+"] ; + forces + sign 170 | all [flag? spec #"_" " "] ; _ reserves space for +/- 171 | "" ; no sign flag = no space for sign on pos num 172 | ] 173 | ] 174 | ] 175 | 176 | struct-data?: func [data][any [block? :data object? :data map? :data]] 177 | unstruct-data?: func [data][not struct-data? :data] 178 | 179 | ;--------------------------------------------------------------------------- 180 | ;-- Public 181 | 182 | apply-format-style: func [v style][ 183 | ;print ['apply-format-style v style] 184 | either number? v [ 185 | any [ 186 | format-number-with-style :v style 187 | to tag! rejoin ["Unknown style: " style] 188 | ] 189 | ][ 190 | 191 | ] 192 | ] 193 | 194 | set 'apply-short-format function [ 195 | "Apply a format spec to a single value" 196 | spec [block! object!] "Must support [flags width prec] keys" 197 | value 198 | return: [string!] 199 | ][ 200 | ;print [mold spec mold value] 201 | ; Prep 202 | fill-ch: either any [flag? spec #"0" flag? spec #"Z"] [#"0"][#" "] ;TBD 0 or Z? 203 | align: either flag? spec #"<" ['left]['right] 204 | sign-ch: either number? value [sign-from-flags spec value][""] 205 | if number? value [ 206 | if integer? prec: spec/prec [ ; If we have a precision... 207 | ; Think about how best to force extra deci zeros. Can't just 208 | ; do this addition, because we then round it off. 209 | ;value: value + (10 ** negate (prec + 1)) ; Add an extra digit to force 0s in frac 210 | if percent? value [prec: add prec 2] ; Scale precision for percent! values 211 | value: round/to value 10 ** negate prec ; Round the number so we can just mold it 212 | ] 213 | ] 214 | ; Form 215 | value: case [ ; Reassign 'value to string result for later padding 216 | spec/style [apply-format-style value spec/style] ; A named format style was used 217 | not number? :value [form any [:value ""]] ; Coerce none to ""; form to prevent arg modifcation 218 | ; ?? What about FALSE? 219 | 'else [ 220 | suffix: either all [integer? value flag? spec #"º"] [ordinal-suffix value][""] 221 | append mold absolute value suffix ; Note: absolute; no sign here 222 | ] 223 | ] 224 | ; Pad 225 | either none? spec/width [value][pad-aligned value align (spec/width - length? sign-ch) fill-ch] 226 | ; Sign 227 | insert value sign-ch ; Sign always goes at head 228 | ; Return 229 | value 230 | ] 231 | 232 | set 'looks-like-short-format? function [ 233 | "Return true if input looks like it contains short-format commands" 234 | input [string!] 235 | ][ 236 | to logic! all [ 237 | res: parse-as-short-format input 238 | any [object? res find res object!] ; single object or block that has at least one object 239 | ] 240 | ] 241 | 242 | set 'parse-as-short-format func [ 243 | "Parse input, returning block of literal string and field spec blocks" 244 | input [string!] 245 | ][ 246 | if parse input format= [ 247 | ; If there was only a short-format in the input, return just 248 | ; that spec directly. 249 | either one-spec? =parts [=parts/1][=parts] 250 | ] 251 | ] 252 | 253 | ; Temp helper to dispatch by spec/key type and data. 254 | ; Exported for testing from %format.red 255 | set 'apply-format-by-key+data func [spec [object!] data][ 256 | ;print [w mold data unstruct-data? data spec/key] 257 | ; If we allow objects and maps to be used, so you can select by 258 | ; key, they won't work for format-only fields or numeric index 259 | ; access. 260 | ; If we get a scalar value, but more than one format placeholder, 261 | ; does it make sense to apply to value to every placeholder? 262 | apply-short-format spec either unstruct-data? data [ 263 | case [ 264 | none? spec/key [data] ; unkeyed field, use data 265 | integer? spec/key [if series? data [pick data spec/key]] ; can still try to pick from series vals 266 | paren? spec/key [do-paren spec/key] ; expression to evaluate 267 | path? spec/key [get-path-key data spec/key] ; deep key 268 | 'else [attempt [do spec/key]] ; simple key name 269 | ] 270 | ][ 271 | ; Something interesting to consider here is whether key lookups 272 | ; should always start at the head of the series, as it may have 273 | ; been advanced. This gets especially tricky, because you might 274 | ; have advanced an odd/unknown number of values. We might also 275 | ; then want a way to skip to a new index in the values. 276 | case [ 277 | none? spec/key [if series? data [take data]] ; unkeyed field, take sequentially from data 278 | integer? spec/key [pick-val data spec/key] ; index key 279 | paren? spec/key [do-paren spec/key] ; expression to evaluate 280 | path? spec/key [get-path-key data spec/key] ; deep key 281 | 'else [ ; simple key name 282 | ;?? Do we want to allow functions? I'm not so sure. 283 | val: select data spec/key 284 | either any-function? :val [val][val] 285 | ] 286 | ] 287 | ] 288 | ] 289 | 290 | set 'short-form function [ 291 | "Format and substitute values into a template string" 292 | string [string!] "Template string containing `/value:format` fields and literal data" 293 | data "Value(s) to apply to template fields" 294 | ][ 295 | result: clear "" 296 | if series? data [data: copy data] 297 | if none? spec: parse-as-short-format string [return none] ; Bail if the format string wasn't valid 298 | if object? spec [return apply-format-by-key+data spec data] ; We got a single format spec 299 | collect/into [ 300 | foreach item spec [ 301 | keep either not object? item [item][ ; literal data from template string 302 | apply-format-by-key+data item data 303 | ] 304 | ] 305 | ] result 306 | ] 307 | 308 | ] 309 | 310 | -------------------------------------------------------------------------------- /string-formatting.red: -------------------------------------------------------------------------------- 1 | Red [ 2 | File: %string-formatting.red 3 | Purpose: "Red string formatting functions" 4 | Date: "13-Apr-2017" 5 | Version: 0.0.1 6 | Author: "Gregg Irwin" 7 | Notes: { 8 | } 9 | TBD: { 10 | } 11 | ] 12 | 13 | 14 | string-formatting: context [ 15 | e.g.: :comment 16 | 17 | ; Generic support funcs (belong in more general mezzanine libs) 18 | 19 | ; This is a temp version of a split-at func, hence the different name. 20 | break-at: function [ 21 | "Split the series at a position or value, returning the two halves, excluding delim." 22 | series [series!] 23 | delim "Delimiting value, or index if an integer" 24 | /last "Split at the last occurrence of value, from the tail" 25 | /local s 26 | ][ 27 | reduce either all [integer? delim not last] [ 28 | parse series [collect [keep delim skip keep to end]] 29 | ][ 30 | if string? series [delim: form delim] 31 | if not find/only series delim [ 32 | return reduce [copy series copy ""] 33 | ] 34 | either last [ 35 | reduce [ 36 | copy/part series find/only/last series :delim 37 | copy find/only/last/tail series :delim 38 | ] 39 | ][ 40 | ; `copy s` is here because `keep to` doesn't collect anything if the 41 | ; delim is the first thing in the string. 42 | parse series [collect [keep copy s to delim delim keep to end]] 43 | ] 44 | ] 45 | ] 46 | ;>> break-at "" "." 47 | ;== ["" ""] 48 | ;>> break-at "132" "." 49 | ;== ["132" ""] 50 | ;>> break-at "132." "." 51 | ;== ["132" #"^@"] 52 | 53 | change-all: func [ 54 | "Change each value in the series by applying a function to it" 55 | series [series!] 56 | fn [any-function!] "Function that takes one arg" 57 | ][ 58 | forall series [change series fn first series] 59 | series 60 | ] 61 | 62 | ; I've never liked the name of this func, but I'm including it here 63 | ; because the behavior is handy for how I'm merging masks currently. 64 | first+: func [ 65 | "Return first value in series, and increment the series index." 66 | 'word [word! paren!] "Word must be a series." 67 | ][ 68 | if paren? :word [set/any 'word do :word] 69 | also pick get word 1 set word next get word 70 | ] 71 | 72 | form-if-char: func [val][either char? val [form val][:val]] 73 | 74 | ; I have this here because some old format code I'm porting uses it. 75 | ; It may all change to `rejoin`, but it gave me a reason to port `join` 76 | ; to Red for real and think about object/map support. `Rejoin` doesn't 77 | ; work for those. The question, then, is what value there is in a 78 | ; uniform interface for copy+extend. 79 | join: func [ 80 | "Concatenate values" 81 | a "Coerced to string if not a series, map, or object" 82 | b "Single value or block of values; reduced if a is not an object or map" 83 | ][ 84 | if all [block? :b not object? :a not map? :a] [b: reduce b] 85 | case [ 86 | series? :a [append copy a :b] 87 | map? :a [extend copy a :b] 88 | object? :a [make a :b] 89 | 'else [append form :a :b] 90 | ] 91 | ] 92 | 93 | ;--------------------------------------------------------------------------- 94 | 95 | set 'align function [ 96 | {Justify the given string to the specified width and direction} 97 | s [any-string!] "The string to justify" 98 | wd [integer!] "The target width, in characters" 99 | /left "Left align the string (default)" 100 | /center "Center align the string" 101 | ; {Center justify the string. If the total length of the padding 102 | ; is an odd number of characters, the extra character will be on 103 | ; the right.} 104 | /right "Right align the string" 105 | /with "Fill with something other than space" 106 | ; {Allows you to specify filler other than space. If you specify a 107 | ; string more than 1 character in length, it will be repeated as 108 | ; many times as necessary.} 109 | filler [any-string! char!] "The character, or string, to use as filler" 110 | ][ 111 | if 0 >= pad-len: (wd - length? s) [return s] ; Never truncate 112 | filler: form any [filler space] 113 | result: head insert/dup make string! wd filler (wd / length? filler) 114 | ; If they gave us a multi-char filler, and it isn't evenly multiplied 115 | ; into the desired width, we have to add some extra chars at the end 116 | ; to make up for the difference. 117 | if wd > length? result [ 118 | append result copy/part filler (wd - length? result) 119 | ] 120 | pos: either center [ 121 | add 1 to integer! divide pad-len 2 122 | ][ 123 | either right [add 1 pad-len] [1] 124 | ] 125 | head change/part at result pos s length? s 126 | ] 127 | e.g. [ 128 | align "a" 10 129 | align/center "a" 10 130 | align/right "a" 10 131 | align/with "a" 10 #"*" 132 | align/center/with "a" 10 #"*" 133 | align/right/with "a" 10 #"*" 134 | align/with "a" 10 "._" 135 | align/center/with "a" 10 "._" 136 | align/right/with "a" 10 "._" 137 | align/with "a" 10 "+________+" 138 | align/center/with "a" 10 "+________+" 139 | align/right/with "a" 10 "+________+" 140 | template: "+________+" 141 | align/with "abcd" length? template template 142 | align/center/with "abcd" length? template template 143 | align/right/with "abcd" length? template template 144 | ] 145 | 146 | fill: function [ 147 | "Fill part of a template string with a formed value" 148 | str [any-string!] "Template string" 149 | align [word!] "[left center right]" 150 | val "(formed) Value to insert in template string" 151 | ;/trunc "Truncate val if longer than str" ;?? make ellipsis last char if truncated? 152 | ][ 153 | str: copy str ; Don't modify template string 154 | ;if not any-string? val [val: form val] ; Prep the value 155 | val: form val ; Prep val; always copy as we may return it 156 | diff: (length? str) - (length? val) ; How much longer is the template than the value 157 | if not positive? diff [return val] ; Never truncate the formed value 158 | pos: switch/default align [ 159 | left [1] 160 | center [add 1 to integer! divide diff 2] 161 | right [add 1 diff] 162 | ][1] 163 | head change at str pos val 164 | ] 165 | e.g. [ 166 | template: "+________+" 167 | fill template 'left "" 168 | fill template 'right "" 169 | fill template 'center "" 170 | fill template 'left "abc" 171 | fill template 'right "abc" 172 | fill template 'center "abc" 173 | fill template 'left "abcd" 174 | fill template 'right "abcd" 175 | fill template 'center "abcd" 176 | fill template 'left "abcdefghi" 177 | fill template 'right "abcdefghi" 178 | fill template 'center "abcdefghi" 179 | fill template 'left "abcdefghij" 180 | fill template 'right "abcdefghij" 181 | fill template 'center "abcdefghij" 182 | fill template 'left "abcdefghijk" 183 | fill template 'right "abcdefghijk" 184 | fill template 'center "abcdefghijk" 185 | ] 186 | 187 | pad-aligned: func [ 188 | "Wrapper for `pad` to ease refinement propagation" 189 | str [string!] align [word!] wd [integer!] ch [char!] 190 | ][ 191 | switch align [ 192 | left [pad/with str wd ch] 193 | right [pad/with/left str wd ch] 194 | ] 195 | ] 196 | 197 | ;--------------------------------------------------------------------------- 198 | 199 | format-string: func [ 200 | value [any-string!] 201 | fmt [word! string! block!] "Named or custom format" 202 | /local fmts 203 | 204 | ][ 205 | either word? fmt [ 206 | ; Named formats. Can't use AA/aa/Aa because switch isn't case sensitive. 207 | ; Need to use something else to do that here. 208 | switch fmt [ 209 | ;general [value] 210 | upper uppercase all-caps [uppercase value] 211 | lower lowercase [lowercase value] 212 | cap capitalize [uppercase/part lowercase value 1] 213 | ;proper [uppercase/part lowercase value 1] 214 | ;camel 215 | ; throw error - unknown named format specified? 216 | ;case else [either any-block? value [reform value] [form value]] 217 | ] 218 | ][ 219 | ; custom format 220 | either block? fmt [ 221 | context [ 222 | align=: wd=: fill=: rules: 223 | =align: =wd: =fill: mod: res: 224 | none 225 | 226 | align=: [opt 'align set =align ['left | 'center | 'right]] ; opt 'align set =align 227 | ; 'size or 'pad keywods for width? 228 | wd=: [opt ['width | 'wd] set =wd integer! (if negative? =wd [=wd: abs =wd align: 'right])] 229 | fill=: [opt ['filler | 'fill opt 'with] set =fill [char! | string!]] 230 | rules: [ 231 | ( 232 | =align: 'left 233 | =fill: #" " 234 | =wd: 0 235 | ) 236 | ; Case change rules have to come first, before alignment rules. 237 | ; Will that confuse people? 238 | opt [ 239 | ['upper | 'uppercase] (uppercase value) 240 | | ['lower | 'lowercase] (lowercase value) 241 | | ['cap | 'capitalize] (uppercase/part lowercase value 1) 242 | ] 243 | any [align= | wd= | fill=] ( 244 | res: do reduce [ 245 | to path! compose [justify (=align) with] value =wd =fill 246 | ] 247 | ) 248 | ] 249 | either parse fmt rules [res] [#ERR] 250 | ] 251 | ][ 252 | ; TBD - string format? 253 | ; @&<>! ; specials 254 | ; aa - lower 255 | ; AA - upper 256 | ; Aa - capitalize 257 | ; AaAa - camel 258 | ; left center right < ^ > 259 | ; ... ; show ellipsis if truncated 260 | ; width (left justify) 261 | ; negative width (right justify) 262 | 263 | ; What do we do for an as-is format? i.e. strings in a block that 264 | ; they don't want formatted? 265 | ] 266 | ] 267 | ] 268 | 269 | 270 | 271 | ] ; end of string-formatting context 272 | 273 | ;------------------------------------------------------------------------------- 274 | ; 275 | ; Capitalization (still very much experimental and incomplete) 276 | ; 277 | ; http://en.wikipedia.org/wiki/Capitalization 278 | ; http://individed.com/code/to-title-case/ 279 | ; http://individed.com/code/to-title-case/tests.html 280 | ; http://daringfireball.net/2008/08/title_case_update 281 | ; http://www.heikniemi.net/hardcoded/2004/10/propercase-for-c/ 282 | ; http://blogs.msdn.com/b/michkap/archive/2005/03/04/384927.aspx 283 | 284 | ; Title Case - the first letter of each word is capitalized, the rest are lower case. 285 | ; In some cases short articles, prepositions, and conjunctions are not capitalized. 286 | ; 287 | ; Proper Case - Used for proper nouns, the first letter of each word is capitalized. 288 | ; 289 | ; CamelCase - First letter of each word capitalized, spaces and punctuation removed. 290 | 291 | ; "Q&A" "R&D" "AT&T" 292 | 293 | ; http://www.sti.nasa.gov/sp7084/ch4.html 294 | capitalization-ctx: context [ 295 | ch-whitespace=: charset " ^/^-" 296 | 297 | ch-digit=: charset "1234567890" 298 | ;ch-hexdigit=: charset "1234567890abcdefABCDEF" 299 | 300 | ch-lower=: charset [#"a" - #"z"] 301 | ch-upper=: charset [#"A" - #"Z"] 302 | ch-alpha=: union ch-lower= ch-upper= 303 | ch-alphanum=: union ch-alpha= ch-digit= 304 | ;ch-ascii=: charset [#"^(00)" - #"^(7F)"] 305 | ;ch-low-ascii=: charset [#"^(00)" - #"^(1F)"] 306 | ;ch-high-ascii=: charset [#"^(80)" - #"^(FF)"] 307 | 308 | ch-word=: ch-alphanum= 309 | ;ch-word=: union ch-alphanum= charset "_" ;? 310 | ch-non-word=: complement ch-word= 311 | 312 | ;auxilliaries: ["is" "am" "are" "was" "be" "has" "had" "do" "did"] 313 | articles: ["the" "a" "an"] 314 | prepositions: ["of" "to" "in" "for" "with" "on"] 315 | conjunctions: ["for" "and" "nor" "but" "or" "yet" "so"] ; "either" "not" "neither" "both" "whether" 316 | 317 | foreign-particles: [ 318 | "von" ; German - don't cap 319 | "van" "de" "der" "ter" ; Dutch - "Van der" only cap first, cap only if no given name 320 | ] 321 | 322 | ;medial-prefixes: ["Mc" "Mc'" "Mac" "Mac'" "O'" "M'"] 323 | medial-prefixes: ["Mc"] ; "Mac"? 324 | 325 | word=: [ 326 | copy =word some ch-word= 327 | ;copy =word to ch-non-word= 328 | ] 329 | 330 | def-dict: compose/deep [ 331 | lower [(union union articles prepositions conjunctions)] 332 | upper [ 333 | "NW" "SW" "NE" "SE" "SSW" "SSE" "NNW" "NNE" 334 | ;"Q&A" "R&D" "AT&T" ; & is a break char right now, so we need to consider how best to do this. 335 | "UK" "USA" 336 | ] 337 | fixed ["MHz"] 338 | ] 339 | 340 | ; U.S.A. is a tricky one, because the dot is seen as a break and the 'a is 341 | ; seen as an article, which is then converted to lowercase. So we end up 342 | ; parsing it as three separate, single-letter words with breaks. 343 | 344 | ; uppercase/part 1 345 | ; 346 | ; last-break: :this-break 347 | ; this-break: Look for word break 348 | ; If last-word (last-break to this-break) is 349 | ; acronym [no change] 350 | ; small word [lowercase it] 351 | ; starts with o' and is > 3 chars [uppercase/part 3] 352 | ; ? starts with mc [uppercase/part 1 at str 3 uppercase/part 1] 353 | ; ? starts with mac [uppercase/part 1 at str 4 uppercase/part 1] 354 | ; [van von der ] [lowercase it] 355 | ; ? should 356 | set 'capitalize func [ 357 | string [any-string!] 358 | /name "Don't use dict for special processing" 359 | /address "Don't use dict for special processing" 360 | /camel "Non-word chars are removed" 361 | ;/break-at non-word-chars [bitset!] 362 | /with dict [block!] {[lower ["a" "an" "the"] upper ["AT&T"] fixed ["MacLeod"]} 363 | /show "Show words and their offsets as they are found" 364 | ] [ 365 | if empty? string [return string] 366 | 367 | dict: any [dict def-dict] 368 | 369 | ; cap: func [ 370 | ; string [any-string!] 371 | ; ] [ 372 | ; uppercase/part lowercase string 1 373 | ; ] 374 | ; 375 | ; cap-it?: func [ 376 | ; string [any-string!] 377 | ; ] [ 378 | ; if any [name address] [return true] 379 | ; ] 380 | ; 381 | ; uppercase?: func [ 382 | ; "Returns true if the string is all caps." 383 | ; string [any-string!] 384 | ; ][ 385 | ; parse string [some [ch-upper=]] 386 | ; ] 387 | ; 388 | ; lowercase?: func [ 389 | ; "Returns true if the string is all lowercase chars." 390 | ; string [any-string!] 391 | ; ][ 392 | ; parse string [some [ch-lower=]] 393 | ; ] 394 | 395 | 396 | w-start: none 397 | w-end: none 398 | 399 | lower-wd: does [ 400 | change/part w-start lowercase/part w-start w-end w-end 401 | ] 402 | upper-wd: does [ 403 | change/part w-start uppercase/part w-start w-end w-end 404 | ] 405 | cap-wd: does [ 406 | change/part w-start uppercase/part w-start 1 w-end 407 | ] 408 | chg-wd: func [new-wd [string!]] [ 409 | change/part w-start new-wd w-end 410 | ] 411 | 412 | parse string [ 413 | some [ 414 | w-start: word= w-end: ( 415 | if show [print [=word index? w-start index? w-end]] 416 | case [ 417 | 418 | find dict/fixed =word [ 419 | chg-wd pick dict/fixed index? find dict/fixed =word 420 | ] 421 | 422 | any [ 423 | find foreign-particles =word 424 | find dict/lower =word 425 | ] [lower-wd] 426 | 427 | ; Need to determine what to do about & breaking words, which these may be. 428 | find dict/upper =word [upper-wd] 429 | 430 | ; Medial prefixes - make this dynamic for different prefixes 431 | "Mc" = copy/part =word 2 [ 432 | lower-wd 433 | cap-wd 434 | change/part next next w-start w-end uppercase/part next next w-start 1 435 | ] 436 | 437 | ; End of a contraction of possesive 438 | all [ 439 | find ["T" "S"] =word 440 | #"'" = attempt [first back w-start] 441 | ] [lower-wd] 442 | 443 | 444 | ; Standard word to capitalize 445 | 'else [lower-wd cap-wd] 446 | ] 447 | ) :w-end 448 | | skip 449 | ] 450 | ] 451 | 452 | ; This does NOT strip leading digits from the word. 453 | if camel [ 454 | parse string [ 455 | some [ 456 | mark: ch-non-word= (mark: remove mark) :mark 457 | | skip 458 | ] 459 | ] 460 | ] 461 | 462 | ; Always capitalize the first letter. 463 | ; Should fixed words override this? 464 | uppercase/part string 1 465 | 466 | ] 467 | 468 | ] 469 | 470 | comment { 471 | capitalize-tests: [ 472 | "ALONZO-MEDRANO" 473 | "URDANETA-ROSARIO" 474 | 475 | "MIGUEL" "BENAVIDESAQUILLILA" "5559 Gatlin Av # G" "Orlando" 476 | "JOSE" "FELICIANODELGADO" "114 Sandy Point Way" "Clermont" 477 | "YOANDRIS" "ALVAREZ GUTIERREZ" "70 E 55TH ST" 478 | "11120 SW 196TH ST 402 B" 479 | "mccray" 480 | "mckinzie" 481 | "Mcleod" 482 | "Macleod" 483 | "o'Brien" 484 | "O'reilly" 485 | 486 | "von helsing" 487 | "van der meer" 488 | 489 | "500mhz" 490 | "500 mhz" 491 | 492 | "u.s.a" 493 | ] 494 | 495 | foreach str capitalize-tests [ 496 | print [mold str tab mold capitalize copy str] 497 | ] 498 | } 499 | 500 | -------------------------------------------------------------------------------- /test-composite.red: -------------------------------------------------------------------------------- 1 | Red [] 2 | 3 | do %composite.red 4 | 5 | test-composite: func [input][ 6 | print [mold input "==" mold composite input] 7 | ] 8 | test-composite-custom-err: func [input][ 9 | print [mold input "==" mold composite/err-val input "#ERR"] 10 | ] 11 | test-bad-composite: func [input][ 12 | print [mold input "==" mold try [composite input]] 13 | ] 14 | test-composite-marks: func [input markers][ 15 | print [mold input mold marks tab "==" mold composite/marks input markers] 16 | ] 17 | test-composite-with: func [input ctx][ 18 | print [mold input "==" mold composite/with input ctx] 19 | ] 20 | test-composite-with-fn: func [input [string!] fn [function!] arg][ 21 | print [mold input "==" mold fn input arg] 22 | ] 23 | 24 | print "Composite" 25 | s: "1 + 2" 26 | foreach val [ 27 | "" 28 | ":(1):" 29 | ":(pi):" 30 | {:("foo"):} 31 | ":(rejoin ['a 'b]):" 32 | "a:('--):b" 33 | "a:('--):" 34 | ":('--):b" 35 | "ax:(1 / 0):xb" 36 | 37 | "alpha: :(rejoin ['a 'b]): answer: :(42 / 3):" 38 | { 39 | name: :(form-full-name cust): 40 | rank: :(as-ordinal index? find scores cust): 41 | ser#: :(cust/uuid): 42 | } 43 | 44 | "a :('--): b" 45 | "a :('--):" 46 | ":('--): b" 47 | "ax :(1 / 0): xb" 48 | 49 | {a :("1 + 2"): b} 50 | {a :({{1 + 2}}): b} 51 | {a :({"1 + 2"}): b} 52 | {a :(s): b} 53 | ][test-composite val] 54 | 55 | print "^/Composite/custom-error-val" 56 | 57 | test-composite-custom-err "ax:(1 / 0):xb" 58 | test-composite-custom-err "ax :(1 / 0): xb" 59 | 60 | print "^/Bad Composite Input" 61 | foreach val [ 62 | ":(" 63 | ":('end" 64 | "asdf:('end" 65 | "):" 66 | "beg):" 67 | ")::(" 68 | ":(1):beg):" 69 | "asdf:(1):beg):" 70 | ":(1/a/b/c):" 71 | ":(2abc):" 72 | ][test-bad-composite val] 73 | 74 | print "^/Composite/Marks" 75 | foreach [val marks] [ 76 | "" ["" ""] 77 | ":(1):" [":(" "):"] 78 | "):pi:(" ["):" ":("] 79 | "a<%'--%>b" ["<%" "%>"] 80 | "a{'--}b" [#"{" #"}"] 81 | "a{'--}}b" [#"{" "}}"] 82 | "a{{'--}b" ["{{" #"}"] 83 | "a'--b" ["" ""] 84 | "a'--b" [ ] 85 | ][test-composite-marks val marks] 86 | 87 | print "^/Composite/with" 88 | o: object [a: 1 b: 2] 89 | foreach val [ 90 | "" 91 | ":(1):" 92 | ":(pi + a):" 93 | ":(reduce [a b]):" 94 | ":(rejoin [a b]):" 95 | "a:(a + b):b" 96 | ][test-composite-with val o] 97 | 98 | ; Function support is from @hiiamboris. I'm not sure about it's usefulness yet. 99 | print "^/Composite/with (func)" 100 | f: func [str w][ 101 | composite/with str context? 'w 102 | ] 103 | test-composite-with-fn ":(w):" :f 100 104 | 105 | 106 | print "" 107 | 108 | halt 109 | -------------------------------------------------------------------------------- /test-format.red: -------------------------------------------------------------------------------- 1 | Red [] 2 | 3 | do %format.red 4 | do %short-format.red 5 | do %format-date-time.red 6 | 7 | ;------------------------------------------------------------------------------- 8 | 9 | using: func [ 10 | "Like USE, but combines the local words and their initial values in a spec block." 11 | spec [block!] "Spec-block format of words and values" 12 | body [block!] "Block to evaluate" 13 | ][ 14 | with context spec body 15 | ] 16 | ; using [a: 3 b: 5] [a + b] 17 | 18 | ; Sort of like VB's with statement. 19 | ; Should it return the result of the DO, or the object? 20 | ;!! There is a risk here. If the object does NOT contain words set in 21 | ; the body, they will escape and bind to an outer context. 22 | with: func [ 23 | object [object! none!] 24 | body [block!] 25 | ][ 26 | if object [do bind/copy body object] 27 | ] 28 | ; >> o: context [a: 1 b: 2] 29 | ; >> oo: context [c: 3 d: 4] 30 | ; >> oo: context [a: 3 b: 4] 31 | ; >> with o [a + b] 32 | ; == 3 33 | ; >> with oo [a + b] 34 | ; == 7 35 | 36 | ;------------------------------------------------------------------------------- 37 | 38 | with formatting [ 39 | tests: [ 40 | join [ 41 | join 1 2 42 | join "a" 'b 43 | join %a #b 44 | join [a] 'b 45 | join 'a/b 'c 46 | join #(a: 1) [b: 2] 47 | join #(a: 1) #(b: 2) 48 | join context [a: 1] [b: 2] 49 | ] 50 | form-num-with-group-seps [ 51 | form-num-with-group-seps 9 52 | form-num-with-group-seps 99 53 | form-num-with-group-seps 999 54 | form-num-with-group-seps 9999 55 | form-num-with-group-seps 99999 56 | form-num-with-group-seps 999999 57 | form-num-with-group-seps 9999999 58 | form-num-with-group-seps -9999999 59 | form-num-with-group-seps 9999999.9 60 | form-num-with-group-seps -9999999.9 61 | form-num-with-group-seps/with "-9999999,9" #"." 62 | form-num-with-group-seps/every 9 2 63 | form-num-with-group-seps/every 99 2 64 | form-num-with-group-seps/every 999 2 65 | form-num-with-group-seps/every 9999 2 66 | form-num-with-group-seps/every 99999 2 67 | form-num-with-group-seps/every 999999 2 68 | form-num-with-group-seps/every 9999999 2 69 | form-num-with-group-seps/every -9999999 2 70 | form-num-with-group-seps/every 9999999.9 2 71 | form-num-with-group-seps/every -9999999.9 2 72 | form-num-with-group-seps/with/every "-9999999,9" #"." 2 73 | ] 74 | pad-aligned [ 75 | pad-aligned "" 'left 10 #" " 76 | pad-aligned "" 'left 10 #"0" 77 | pad-aligned "x" 'left 10 #"." 78 | pad-aligned "x" 'right 10 #"." 79 | pad-aligned "x" 'right -10 #"." 80 | pad-aligned "xxxxxxxxx" 'right 10 #"." 81 | pad-aligned "xxxxxxxxxx" 'right 10 #"." 82 | pad-aligned "xxxxxxxxxxx" 'right 10 #"." 83 | ] 84 | sign-chars [ 85 | sign-chars 1 86 | sign-chars 0 87 | sign-chars -1 88 | sign-chars/use+ 1 89 | sign-chars/use+ 0 90 | sign-chars/use+ -1 91 | sign-chars/acct 1 92 | sign-chars/acct 0 93 | sign-chars/acct -1 94 | ] 95 | format-bytes [ 96 | format-bytes 1 97 | format-bytes 1500 98 | format-bytes/to 1500 .1 99 | format-bytes 2048 100 | format-bytes 9999 101 | format-bytes 99999 102 | format-bytes 999999 103 | format-bytes 9999999 104 | format-bytes 99999999 105 | format-bytes 999999999 106 | format-bytes 9999999999 107 | format-bytes 99999999999 108 | format-bytes 999999999999 109 | format-bytes 9999999999999 110 | format-bytes 99999999999999 111 | format-bytes 999999999999999 112 | format-bytes 9999999999999999 113 | format-bytes 99999999999999999 114 | format-bytes 999999999999999999 115 | format-bytes 9999999999999999999 116 | format-bytes 99999999999999999999 117 | format-bytes 999999999999999999999 118 | format-bytes 9999999999999999999999 119 | format-bytes 99999999999999999999999 120 | format-bytes 999999999999999999999999 121 | format-bytes 9999999999999999999999999 122 | format-bytes 99999999999999999999999999 123 | format-bytes 999999999999999999999999999 124 | format-bytes/to 999999999999999999999999999 .01 125 | format-bytes 99999999999999999999999999999 126 | 127 | format-bytes 999999999 128 | format-bytes/as 999999999 'GiB 129 | format-bytes/as/to 999999999 'GiB 1.0 130 | format-bytes/to 999999999 .01 131 | format-bytes/as/to 999999999 'GiB .01 132 | format-bytes/to/as 1500 .1 'bytes 133 | format-bytes/to/as/sep 1500 .1 'bytes space 134 | format-bytes/to/as/sep 1500 .1 'bytes #"_" 135 | format-bytes 1125899906842624.0 ; 1PiB 136 | 137 | format-bytes/SI 1 138 | format-bytes/SI 1500 139 | format-bytes/SI/to 1500 .1 140 | format-bytes/SI 2048 141 | format-bytes/SI 9999 142 | format-bytes/SI 99999 143 | format-bytes/SI 999999 144 | format-bytes/SI 9999999 145 | format-bytes/SI 99999999 146 | format-bytes/SI 999999999 147 | format-bytes/SI 9999999999 148 | format-bytes/SI 99999999999 149 | format-bytes/SI 999999999999 150 | format-bytes/SI 9999999999999 151 | format-bytes/SI 99999999999999 152 | format-bytes/SI 999999999999999 153 | format-bytes/SI 9999999999999999 154 | format-bytes/SI 99999999999999999 155 | format-bytes/SI 999999999999999999 156 | format-bytes/SI 9999999999999999999 157 | format-bytes/SI 99999999999999999999 158 | format-bytes/SI 999999999999999999999 159 | format-bytes/SI 9999999999999999999999 160 | format-bytes/SI 99999999999999999999999 161 | format-bytes/SI 999999999999999999999999 162 | format-bytes/SI 9999999999999999999999999 163 | format-bytes/SI 99999999999999999999999999 164 | format-bytes/SI 999999999999999999999999999 165 | format-bytes/SI/to 999999999999999999999999999 .01 166 | 167 | format-bytes/SI 999999999 168 | format-bytes/SI/as 999999999 'GB 169 | format-bytes/SI/as/to 999999999 'GB 1.0 170 | format-bytes/SI/to 999999999 .01 171 | format-bytes/SI/as/to 999999999 'GB .01 172 | format-bytes/SI/to/as 1500 .1 'bytes 173 | format-bytes/SI/to/as/sep 1500 .1 'bytes space 174 | format-bytes/SI/to/as/sep 1500 .1 'bytes #"_" 175 | 176 | ] 177 | form-logic [ 178 | form-logic true 'true-false 179 | form-logic false 'true-false 180 | form-logic true 'on-off 181 | form-logic false 'on-off 182 | form-logic true 'yes-no 183 | form-logic false 'yes-no 184 | form-logic true 'TF 185 | form-logic false 'TF 186 | form-logic true 'YN 187 | form-logic false 'YN 188 | form-logic true "+-" 189 | form-logic false "+-" 190 | form-logic true [.t .f] 191 | form-logic false [.t .f] 192 | form-logic true "" 193 | form-logic false "" 194 | form-logic true [] 195 | form-logic false [] 196 | form-logic true 'xyz 197 | ] 198 | merge-number-mask [ 199 | ; Remember when testing this to reverse the strings being merged. 200 | merge-number-mask "000" "123" 1 201 | merge-number-mask/whole "0000" "123" 1 202 | merge-number-mask "000?" "123" 1 203 | merge-number-mask "000" "" 0 204 | merge-number-mask "000#" "123" 1 205 | merge-number-mask "+000" "123" -1 206 | merge-number-mask "-000" "123" -1 207 | merge-number-mask "-000" "123" 1 208 | merge-number-mask "(000)" "123" -1 209 | merge-number-mask "(000)" "123" 1 210 | 211 | merge-number-mask/frac "(0.00)" "123" -1 212 | merge-number-mask/frac "-00" "123" -1 213 | merge-number-mask/frac "00" "123" -1 214 | 215 | merge-number-mask/whole "0,000" "123" 1 216 | merge-number-mask/whole "#,000" "123" 1 217 | merge-number-mask/whole "#,000" "12345" 1 218 | merge-number-mask/whole "## #0 00" "123" 1 219 | merge-number-mask/whole "## #0 00" "1234" 1 220 | merge-number-mask/whole "## #0 00" "12345" 1 221 | merge-number-mask/whole "## ## ## #0 00" "123456789" 1 222 | merge-number-mask/whole "00 00" "12345" 1 223 | merge-number-mask/whole "00 ^#00" "12345" 1 224 | merge-number-mask/whole {00 00 " text"} "12345" 1 225 | merge-number-mask/whole {####00" text"} "12345" 1 226 | merge-number-mask/whole {00 00 00" text"} "12345" 1 227 | merge-number-mask/whole {"text " 00 00} "12345" 1 228 | 229 | merge-number-mask/whole "#.##0,000" "12345" 1 230 | ] 231 | format-number-with-style [ 232 | format-number-with-style 0 'r-general 233 | format-number-with-style 0 'r-standard 234 | format-number-with-style 0 'r-fixed 235 | format-number-with-style 0 'r-currency 236 | format-number-with-style 0 'r-money 237 | format-number-with-style 0 'r-percent 238 | format-number-with-style 0 'r-ordinal 239 | 240 | format-number-with-style 0 'general 241 | format-number-with-style 0 'standard 242 | format-number-with-style 0 'fixed 243 | format-number-with-style 0 'currency 244 | format-number-with-style 0 'money 245 | format-number-with-style 0 'percent 246 | format-number-with-style 0 'ordinal 247 | 248 | format-number-with-style 0 'hex 249 | format-number-with-style 0 'min-hex 250 | format-number-with-style 0 'C-hex 251 | format-number-with-style 0 'bin 252 | format-number-with-style 0 'min-bin 253 | 254 | format-number-with-style 0 'sci 255 | format-number-with-style 0 'eng 256 | format-number-with-style 0 'accounting 257 | 258 | format-number-with-style 1234543.678 'r-general 259 | format-number-with-style 1234543.678 'r-standard 260 | format-number-with-style 1234543.678 'r-fixed 261 | format-number-with-style 1234543.678 'r-currency 262 | format-number-with-style 1234543.678 'r-money 263 | format-number-with-style 1234543.678 'r-percent 264 | format-number-with-style 1234543.678 'r-ordinal 265 | 266 | format-number-with-style 1234543.678 'general 267 | format-number-with-style 1234543.678 'standard 268 | format-number-with-style 1234543.678 'fixed 269 | format-number-with-style 1234543.678 'currency 270 | format-number-with-style 1234543.678 'money 271 | format-number-with-style 1234543.678 'percent 272 | format-number-with-style 1234543.678 'ordinal 273 | 274 | format-number-with-style 32767 'hex 275 | format-number-with-style 32767 'min-hex 276 | format-number-with-style 32767 'C-hex 277 | format-number-with-style 32767 'bin 278 | format-number-with-style 32767 'min-bin 279 | 280 | format-number-with-style 12345.678 'sci 281 | format-number-with-style 12345.678 'eng 282 | format-number-with-style 12345.678 'accounting 283 | 284 | format-number-with-style -1234543.678 'r-general 285 | format-number-with-style -1234543.678 'r-standard 286 | format-number-with-style -1234543.678 'r-fixed 287 | format-number-with-style -1234543.678 'r-currency 288 | format-number-with-style -1234543.678 'r-money 289 | format-number-with-style -1234543.678 'r-percent 290 | 291 | format-number-with-style -1234543.678 'general 292 | format-number-with-style -1234543.678 'standard 293 | format-number-with-style -1234543.678 'fixed 294 | format-number-with-style -1234543.678 'currency 295 | format-number-with-style -1234543.678 'money 296 | format-number-with-style -1234543.678 'percent 297 | 298 | format-number-with-style -12345.678 'hex 299 | format-number-with-style -12345.678 'min-hex 300 | format-number-with-style -12345.678 'C-hex 301 | format-number-with-style -12345.678 'bin 302 | format-number-with-style -12345.678 'min-bin 303 | 304 | format-number-with-style -12345.678 'sci 305 | format-number-with-style -12345.678 'eng 306 | format-number-with-style -12345.678 'accounting 307 | format-number-with-style -12345 'accounting 308 | 309 | ] 310 | format-number-by-width [ 311 | format-number-by-width 0 0 0 312 | format-number-by-width 1 0 0 313 | format-number-by-width 123.456 0 0 314 | format-number-by-width -123.456 0 0 315 | 316 | format-number-by-width 10.5% 0 0 317 | format-number-by-width -10.5% 0 0 318 | format-number-by-width/with -10.5% 8 2 #"0" 319 | format-number-by-width/with -10.56% 8 2 #"0" 320 | 321 | format-number-by-width/with -10.5 8 2 #"0" 322 | format-number-by-width/with/use+ 10.5 8 2 #"0" 323 | format-number-by-width/with/left 10.5 8 2 #"0" 324 | format-number-by-width/with 10.5 8 2 #"0" 325 | 326 | format-number-by-width/with -10.5 8 2 #"0" 327 | format-number-by-width/with -10.5 8 2 #"_" 328 | format-number-by-width/with -10.5% 8 2 #"0" 329 | format-number-by-width/with/use+ 10.5 8 2 #"_" 330 | 331 | format-number-by-width 0 5 0 332 | format-number-by-width 1 5 0 333 | format-number-by-width 123.456 5 0 334 | format-number-by-width -123.456 5 0 335 | format-number-by-width 123.456 5 2 336 | format-number-by-width -123.456 5 2 337 | 338 | format-number-by-width 123.456 10 0 339 | format-number-by-width -123.456 10 0 340 | format-number-by-width/left 123.456 10 2 341 | format-number-by-width/right -123.456 10 2 342 | 343 | format-number-by-width/left/use+ 123.456 10 2 344 | format-number-by-width/right/use+ 123.456 10 2 345 | 346 | ] 347 | form-num-ex [ 348 | form-num-ex/type 0 'gen 349 | form-num-ex/type -0 'gen 350 | form-num-ex/type 0.45 'gen 351 | form-num-ex/type 1.45 'gen 352 | form-num-ex/type 12.45 'gen 353 | form-num-ex/type 123.45 'gen 354 | form-num-ex/type 1234.0 'gen 355 | form-num-ex/type 12345.0 'gen 356 | form-num-ex/type 123450.0 'gen 357 | form-num-ex/type 1234500.0 'gen 358 | form-num-ex/type 12345000.0 'gen 359 | form-num-ex/type 123'450'000.0 'gen 360 | form-num-ex/type 1'234'500'000.0 'gen 361 | form-num-ex/type -1'234'500'000.0 'gen 362 | form-num-ex/type -0.000'000'123'45 'gen 363 | form-num-ex/type 0.000'000'123'45 'gen 364 | form-num-ex/type 0.00'000'123'45 'gen 365 | form-num-ex/type 0.0'000'123'45 'gen 366 | form-num-ex/type 0.000'123'45 'gen 367 | form-num-ex/type 0.0012345 'gen 368 | form-num-ex/type 0.012345 'gen 369 | form-num-ex/type 0.12345 'gen 370 | form-num-ex/type 0.2345 'gen 371 | form-num-ex/type 0.345 'gen 372 | form-num-ex/type 0.45 'gen 373 | form-num-ex/type 0.5 'gen 374 | form-num-ex/type 1e16 'gen 375 | form-num-ex/type 1e-5 'gen 376 | form-num-ex/type 123.45% 'gen 377 | form-num-ex/type/to 123.45% 'gen 10% 378 | form-num-ex/type/to 123.45% 'gen 1% 379 | form-num-ex/type/to 123.45% 'gen .1 380 | 381 | form-num-ex/type 0 'eng 382 | form-num-ex/type -0 'eng 383 | form-num-ex/type 0.45 'eng 384 | form-num-ex/type 1.45 'eng 385 | form-num-ex/type 12.45 'eng 386 | form-num-ex/type 123.45 'eng 387 | form-num-ex/type 1234.0 'eng 388 | form-num-ex/type 12345.0 'eng 389 | form-num-ex/type 123450.0 'eng 390 | form-num-ex/type 1234500.0 'eng 391 | form-num-ex/type 12345000.0 'eng 392 | form-num-ex/type 123'450'000.0 'eng 393 | form-num-ex/type 1'234'500'000.0 'eng 394 | form-num-ex/type -1'234'500'000.0 'eng 395 | form-num-ex/type -0.000'000'123'45 'eng 396 | form-num-ex/type 0.000'000'123'45 'eng 397 | form-num-ex/type 0.00'000'123'45 'eng 398 | form-num-ex/type 0.0'000'123'45 'eng 399 | form-num-ex/type 0.000'123'45 'eng 400 | form-num-ex/type 0.0012345 'eng 401 | form-num-ex/type 0.012345 'eng 402 | form-num-ex/type 0.12345 'eng 403 | form-num-ex/type 0.2345 'eng 404 | form-num-ex/type 0.345 'eng 405 | form-num-ex/type 0.45 'eng 406 | form-num-ex/type 0.5 'eng 407 | form-num-ex/type 1e16 'eng 408 | form-num-ex/type 1e-5 'eng 409 | 410 | form-num-ex/type 0 'sci 411 | form-num-ex/type -0 'sci 412 | form-num-ex/type 0.45 'sci 413 | form-num-ex/type 1.45 'sci 414 | form-num-ex/type 12.45 'sci 415 | form-num-ex/type 123.45 'sci 416 | form-num-ex/type 1234.0 'sci 417 | form-num-ex/type 12345.0 'sci 418 | form-num-ex/type 123450.0 'sci 419 | form-num-ex/type 1234500.0 'sci 420 | form-num-ex/type 12345000.0 'sci 421 | form-num-ex/type 123'450'000.0 'sci 422 | form-num-ex/type 1'234'500'000.0 'sci 423 | form-num-ex/type -1'234'500'000.0 'sci 424 | form-num-ex/type -0.000'000'123'45 'sci 425 | form-num-ex/type 0.000'000'123'45 'sci 426 | form-num-ex/type 0.00'000'123'45 'sci 427 | form-num-ex/type 0.0'000'123'45 'sci 428 | form-num-ex/type 0.000'123'45 'sci 429 | form-num-ex/type 0.0012345 'sci 430 | form-num-ex/type 0.012345 'sci 431 | form-num-ex/type 0.12345 'sci 432 | form-num-ex/type 0.2345 'sci 433 | form-num-ex/type 0.345 'sci 434 | form-num-ex/type 0.45 'sci 435 | form-num-ex/type 0.5 'sci 436 | form-num-ex/type 1e16 'sci 437 | form-num-ex/type 1e-5 'sci 438 | 439 | form-num-ex/type 0 'acct 440 | form-num-ex/type -0 'acct 441 | form-num-ex/type 0.45 'acct 442 | form-num-ex/type 1.45 'acct 443 | form-num-ex/type 12.45 'acct 444 | form-num-ex/type 123.45 'acct 445 | form-num-ex/type 1234.0 'acct 446 | form-num-ex/type 12345.0 'acct 447 | form-num-ex/type 123450.0 'acct 448 | form-num-ex/type 1234500.0 'acct 449 | form-num-ex/type 12345000.0 'acct 450 | form-num-ex/type 123'450'000.0 'acct 451 | form-num-ex/type 1'234'500'000.0 'acct 452 | form-num-ex/type -1'234'500'000.0 'acct 453 | form-num-ex/type -0.000'000'123'45 'acct 454 | form-num-ex/type 0.000'000'123'45 'acct 455 | form-num-ex/type 0.00'000'123'45 'acct 456 | form-num-ex/type 0.0'000'123'45 'acct 457 | form-num-ex/type 0.000'123'45 'acct 458 | form-num-ex/type 0.0012345 'acct 459 | form-num-ex/type 0.012345 'acct 460 | form-num-ex/type 0.12345 'acct 461 | form-num-ex/type 0.2345 'acct 462 | form-num-ex/type 0.345 'acct 463 | form-num-ex/type 0.45 'acct 464 | form-num-ex/type 0.5 'acct 465 | form-num-ex/type 1e16 'acct ; limit of std notation 466 | form-num-ex/type 1e-14 'acct ; lower limit of precision 467 | form-num-ex/type 123.45% 'acct 468 | form-num-ex/type/to 123.45% 'acct 10% 469 | form-num-ex/type/to 123.45% 'acct 1% 470 | form-num-ex/type/to 123.45% 'acct .1 471 | 472 | form-num-ex/type 1234.5678 :cust-exp-fn 473 | form-num-ex/type 124123234.5678 :cust-exp-fn 474 | form-num-ex/type 14123234.5678 :cust-exp-fn 475 | form-num-ex/type 0.0000000123456789 :cust-exp-fn 476 | form-num-ex/type 0.000000123456789 :cust-exp-fn 477 | form-num-ex/type -1'234'500'000.0 :cust-exp-fn 478 | 479 | ] 480 | ] 481 | print mold reduce tests/join 482 | print mold reduce tests/form-num-with-group-seps 483 | print mold reduce tests/pad-aligned 484 | print mold reduce tests/sign-chars 485 | print mold reduce tests/format-bytes 486 | print mold reduce tests/form-logic 487 | print mold reduce tests/merge-number-mask 488 | print mold reduce tests/format-number-with-style 489 | print mold reduce tests/format-number-by-width 490 | cust-exp-fn: formatting/make-exponent-function [either any [e < -7 e > 7][e][none]] 491 | cust-exp-fn: func [e [integer!] "Exponent"][either any [e < -7 e > 7][e][none]] 492 | print mold reduce tests/form-num-ex 493 | ;print mold reduce tests/ 494 | ;print mold reduce tests/ 495 | 496 | deci-char-tests: reduce [ 497 | 'deci-point? "" none 498 | 'deci-point? "." false 499 | 'deci-point? ".0" true 500 | 'deci-point? "0." true 501 | 'deci-point? "000" false 502 | 'deci-point? "#,00.00" true 503 | 'deci-point? "?,#,00.0" true 504 | 'deci-point? "#,00,00" false 505 | 'deci-point? "#.00,00" false 506 | 'deci-point? "-$ #.00,00" false 507 | 'deci-point? "-$ #,00.00" true 508 | 'deci-point? {"kr"-#,00.00} true 509 | 'deci-point? {-#.00,00"F"} false 510 | 'deci-point? {-#,00.00" F"} true 511 | 'deci-point? "($#,00.00)" true 512 | 'deci-point? "($#.00,00)" false 513 | 'deci-point? "-#'###'##0.0##'###'#" true 514 | 'deci-point? "-#'###'##0,0##'###'#" false 515 | 516 | 'deci-comma? "" none 517 | 'deci-comma? "," false 518 | 'deci-comma? ",0" true 519 | 'deci-comma? "0," true 520 | 'deci-comma? "000" false 521 | 'deci-comma? "#.00,00" true 522 | 'deci-comma? "?.#.00,0" true 523 | 'deci-comma? "#.00.00" false 524 | 'deci-comma? "#,00.00" false 525 | 'deci-comma? "-$ #,00.00" false 526 | 'deci-comma? "-$ #.00,00" true 527 | 'deci-comma? {"kr"-#,00.00} false 528 | 'deci-comma? {-#.00,00" F"} true ; MUST put spaces inside quotes 529 | 'deci-comma? "($#,00.00)" false 530 | 'deci-comma? "($#.00,00)" true 531 | 'deci-comma? "-#'###'##0,0##'###'#" true 532 | 'deci-comma? "-#'###'##0.0##'###'#" false 533 | ] 534 | foreach [name str res] deci-char-tests [ 535 | fn: get name 536 | if res <> act: fn str [print [name "FAILED!" mold str 'expected res 'got act]] 537 | ] 538 | print "deci-char-tests complete." 539 | 540 | 541 | format-number-with-mask-tests: context [ 542 | test: func [ 543 | value 544 | fmt 545 | ][ 546 | print [mold value tab mold fmt tab mold format-number-with-mask value fmt] 547 | ] 548 | specs: [ 549 | [-12345.67 " ######" ] 550 | [-12345.67 "-??????" ] 551 | [-12345.67 " 999999" ] ; Extra space before sign 552 | [-12345.67 "-000000" ] 553 | [-12345.67 "-$000 000.000" ] 554 | [-12345.67 "-$999 999.999" ] 555 | [-12345.67 "-$9_99_999.999" ] 556 | [-12345.67 "$(999 999.999)" ] 557 | [-12345.67 "$(### ###.999)" ] 558 | [123456.78 "£+ 999,990.000"] 559 | [123456.78 "£ 999,990.000"] 560 | [-123456.78 "£ 999,990.000"] 561 | 562 | [-12345.67 "-###,##0.000" ] 563 | [-1234.67 "-###,##0.00?" ] 564 | [-123.45 "-###,##0.000" ] 565 | [-12345.67 "-#,##0.000" ] 566 | 567 | [-12345.67 "-##.##0,000" ] 568 | [-12345.67 "-#.##0,000" ] 569 | 570 | [12345.67 "-#,##0.000" ] ; FAIL! too-short masks are a problem 571 | [12345.67 "#,##0.000" ] ; FAIL! too-short masks are a problem 572 | [12345.67 "+#,##0.000" ] ; FAIL! too-short masks are a problem 573 | 574 | [-12345.6789 "-#,###,##0.0##,###,#" ] ; These cause issues. Can we support group 575 | [-12345.6789 "-#.###.##0,0##.###.#" ] ; seps in the fractional part with masks, 576 | [-12345.6789 "-# ### ##0.0## ### #" ] ; without things getting really ugly? The 577 | [-12345.6789 "-#'###'##0.0##'###'#" ] ; heuristics may not always win. Space and 578 | ; tick seps are OK. 579 | 580 | [-12345.67 "-£##.##0,000"] 581 | [-12345.67 {-##.##0,000" F"}] 582 | [-12345.67 {"kr"-##.##0,000}] 583 | [-12345.67 "€ ##.##0,000-"] 584 | [-12345.67 "($##.##0,000)"] 585 | 586 | [-12345.67 "-£##.###.##0,000"] 587 | [-12345.67 {-##.###.##0,000" F"}] 588 | [-12345.67 {"kr"-##.###.##0,000}] 589 | [-12345.67 "€ ##.###.##0,000-"] 590 | [-12345.67 "($##.###.##0,000)"] 591 | 592 | [0.0001 "0"] 593 | [0.0001 ".00000"] 594 | [0.0001 "0.#"] 595 | [0.0001 ".#"] 596 | [0.0001 "0.#"] 597 | 598 | [0.00000001 ".00000"] 599 | [0.00000000000001 ".00000"] ; lower limit 600 | 601 | ; [-12345.67 "-£#.##0,000"] 602 | ; [-12345.67 "-#.##0,000 F"] 603 | ; [-12345.67 "kr-#.##0,000"] 604 | ; [-12345.67 "€ #.##0,000-"] 605 | ; [-12345.67 "($#.##0,000)"] 606 | 607 | [.00001% "#.000%" ] 608 | [-.00001% "#.000%" ] 609 | [.4567% "#.000%" ] 610 | [-.4567% "#.000%" ] 611 | [1.4567% "##,##0.000%" ] 612 | [12.4567% "##,##0.0#" ] 613 | [123.4567% "##,##0.000%" ] 614 | [12345.6789% "##,##0.000%" ] 615 | [-123.4567% "#,##0.000%" ] 616 | [123.4567% "##.##0,000%" ] 617 | [-123.4567% "#.##0,000%" ] 618 | 619 | ] 620 | run: does [ 621 | print "" 622 | foreach spec specs [test spec/1 spec/2] 623 | ] 624 | ] 625 | format-number-with-mask-tests/run 626 | 627 | ] 628 | 629 | block-form-tests: context [ 630 | parse-test: function [ 631 | input [block!] 632 | ][ 633 | print "parse-as-block-format" 634 | print [tab "INPUT: ^/^-^-" mold input] 635 | res: parse-as-block-format input 636 | print [tab "OUTPUT:"] 637 | if res [ 638 | either object? res [print [tab tab trim/lines mold res]][ 639 | foreach item res [print [tab tab trim/lines mold item]] 640 | ] 641 | ] 642 | ] 643 | parse-specs: [ 644 | [(test)] 645 | [(20 10)] 646 | [tab (20 10) newline] 647 | [(:+)] 648 | [(:<)] 649 | [(:> 5)] 650 | [(:>)] 651 | [(5)] 652 | [(0 5)] 653 | [(:+0<_Zz¤º)] ; multi flags $ isn't allowed. Lexing issue. 654 | [(/5)] 655 | [(/a)] 656 | [(/num 20 10)] 657 | [(/abc #xyz)] 658 | [(/abc :xyz)] 659 | [(a/b/c)] 660 | [((code here) xyz)] 661 | 662 | [(:º)] 663 | [(:¤)] 664 | 665 | [(:< fixed)] 666 | [(money)] 667 | [(/num :+ 0 2)] 123.456 701 | [(:< 10)] 123.456 702 | [(10)] 123.456 703 | [(/5)] 123.456 ; produces "123.456123.456" This is the single-value multi-placeholder question 704 | [(0 5)] 123.456 705 | [(:Z 7 1)] 123.456 706 | [(:Z 10 1)] 123.456 707 | [(:Z 0 1)] 123.456 708 | [(:Z 007 1)] 123.456 709 | [(:Z 15 4)] 123.456789 710 | [(:Z 15 4)] -123.456789 711 | [(:_)] 123.456 712 | [(:+<0_)] 123.456 713 | 714 | [(10)] 123.456% 715 | [(:< 10)] 123.456% 716 | [(:+ 10)] 123.456% 717 | [(5 1)] 123.456% 718 | [(5 2)] 123.456% 719 | [(10 3)] 123.456% 720 | [(10 4)] -123.456% 721 | 722 | [(2 2)] 1.2 723 | 724 | [(10 4) " | " (8 2) " | " (5 0)] -123.456% 725 | [(8 2)] -10.5 726 | [(:Z 8 2)] -10.5 727 | [(:*.5" 32 | ":>" 33 | ":5" 34 | ":.5" 35 | ":0*.*" 36 | ": *.*" 37 | ":+<>0_*.*" ; multi flags 38 | "0:*.*" 39 | "Color :s, number1 :d, number2 :05, float :5.2.\n" 40 | ":/" 41 | ":/5" 42 | "/a" 43 | "/1" 44 | "/num:20.10" 45 | "/abc xyz" 46 | "/abc:xyz" 47 | "/a/b/c:xyz" 48 | "/(code here)xyz" 49 | 50 | ":º" 51 | ":$" 52 | ":¤" 53 | 54 | ":>'fixed" 55 | ":'money" 56 | "/num:+<>Z_5.2'general" 57 | "/abc:'ordinal xyz" 58 | "/abc:'hex:<5.2" 59 | "/abc:'hex:xyz" 60 | "/a/b/c:'binary/key-x" 61 | "/(code here):'base-64 " 62 | 63 | "/(1 + 1)" 64 | ":/(1 + 1)" 65 | ": /(1 + 1) :" 66 | 67 | "Color: :<10, number1/ :3, http://:05, float: :<5.2" 68 | ] 69 | run-parse-tests: does [ 70 | print "" 71 | foreach spec parse-specs [parse-test dbg: spec] 72 | ] 73 | ;------------------------------------------------------ 74 | apply-test: function [ 75 | input [string!] "Spec as string to be parsed" 76 | value 77 | ][ 78 | print "apply-test" 79 | print [tab "INPUT: " mold input] 80 | print [tab "VALUE: " trim/lines mold value] 81 | res: short-form input value 82 | print [tab "OUTPUT:" mold res] 83 | ] 84 | apply-specs: compose/only [ 85 | "" 123.456 86 | ":" 123.456 87 | "^^:^^:" 123.456 88 | "^^:" 123.456 89 | "test" 123.456 90 | ":*.*d" 123.456 91 | ":20.10d" 123.456 92 | "\t:*.*\n" 123.456 93 | "\t:20.10d\n" 123.456 94 | ":+*.*" 123.456 95 | ":<*.*" 123.456 96 | ":>*.2" 123.456 97 | ":<10" 123.456 98 | ":>10" 123.456 99 | ":10" 123.456 100 | ":/5" 123.456 ; produces "123.456123.456" This is the single-value multi-placeholder question 101 | ":.5" 123.456 102 | ":07.1" 123.456 103 | ":010.1" 123.456 ; This is confusing, with 0 as a flag 104 | ":00.1" 123.456 ; This is confusing, with 0 as a flag 105 | ":0007.1" 123.456 ; This is confusing, with 0 as a flag 106 | ":015.4" 123.456789 ; This is confusing, with 0 as a flag 107 | ":Z10.1" 123.456 108 | ":Z0.1" 123.456 109 | ":Z007.1" 123.456 110 | ":Z15.4" 123.456789 111 | ":_*.*" 123.456 112 | ":+<>0_*.*" 123.456 113 | "0:*.*" 123.456 114 | 115 | ":10" 123.456% 116 | ":<10" 123.456% 117 | ":+10" 123.456% 118 | ":5.1" 123.456% 119 | ":5.2" 123.456% 120 | ":10.3" 123.456% 121 | ":10.4" -123.456% 122 | 123 | ":2.2" 1.2 124 | 125 | ":10.4 :8.2 :5.0" -123.456% 126 | ":8.2" -10.5 127 | ":Z8.2" -10.5 128 | ":