diff options
| -rw-r--r-- | stdlib/source/lux/data/text.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/data/text/escape.lux | 243 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/text.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/text/escape.lux | 156 |
4 files changed, 402 insertions, 1 deletions
diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index 18d51a25f..b344a2ad9 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -24,7 +24,7 @@ ## (The JVM specifies chars as 16-bit unsigned integers) (def: #export from_code (-> Char Text) - (|>> (:coerce Int) "lux i64 char")) + (|>> .int "lux i64 char")) (template [<code> <short> <long>] [(def: #export <long> (from_code <code>)) diff --git a/stdlib/source/lux/data/text/escape.lux b/stdlib/source/lux/data/text/escape.lux new file mode 100644 index 000000000..7a710ae74 --- /dev/null +++ b/stdlib/source/lux/data/text/escape.lux @@ -0,0 +1,243 @@ +(.module: + [lux #* + ["." meta] + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" code]]] + [data + ["." maybe]] + [math + [number (#+ hex) + ["n" nat]]] + [macro + [syntax (#+ syntax:)] + ["." code]]] + ["." // (#+ Char) + ["%" format (#+ format)]]) + +(def: sigil "\") + +(template [<char> <sigil>] + [(def: <char> + (|> <sigil> (//.nth 0) maybe.assume))] + + [sigil_char ..sigil] + [\u_sigil "u"] + ) + +(template [<literal> <sigil> <escaped>] + [(def: <sigil> + (|> <literal> (//.nth 0) maybe.assume)) + + (def: <escaped> + (format ..sigil <literal>))] + + ["0" \0_sigil escaped_\0] + ["a" \a_sigil escaped_\a] + ["b" \b_sigil escaped_\b] + ["t" \t_sigil escaped_\t] + ["n" \n_sigil escaped_\n] + ["v" \v_sigil escaped_\v] + ["f" \f_sigil escaped_\f] + ["r" \r_sigil escaped_\r] + [//.\'' \''_sigil escaped_\''] + [..sigil \\_sigil escaped_\\] + ) + +(template [<char> <text>] + [(def: <char> + (|> <text> (//.nth 0) maybe.assume))] + + [\0 //.\0] + [\a //.\a] + [\b //.\b] + [\t //.\t] + [\n //.\n] + [\v //.\v] + [\f //.\f] + [\r //.\r] + [\'' //.\''] + [\\ ..sigil] + ) + +(def: ascii_bottom (hex "20")) +(def: ascii_top (hex "7E")) + +(def: #export (escapable? char) + (-> Char Bit) + (case char + (^template [<char>] + [(^ (static <char>)) + true]) + ([..\0] [..\a] [..\b] [..\t] + [..\n] [..\v] [..\f] [..\r] + [..\''] [..\\]) + + _ + (or (n.< ..ascii_bottom char) + (n.> ..ascii_top char)))) + +(def: (ascii_escape replacement pre_offset pre_limit previous current) + (-> Text Nat Nat Text Text [Text Text Nat]) + (let [post_offset (inc pre_offset) + post_limit (n.- post_offset pre_limit)] + [(format previous + ("lux text clip" 0 pre_offset current) + replacement) + ("lux text clip" post_offset post_limit current) + post_limit])) + +(def: (unicode_escape char pre_offset pre_limit previous current) + (-> Char Nat Nat Text Text [Text Text Nat]) + (let [code (\ n.hex encode char) + replacement (format ..sigil "u" + (case ("lux text size" code) + 1 (format "000" code) + 2 (format "00" code) + 3 (format "0" code) + _ code)) + post_offset (inc pre_offset) + post_limit (n.- post_offset pre_limit)] + [(format previous + ("lux text clip" 0 pre_offset current) + replacement) + ("lux text clip" post_offset post_limit current) + post_limit])) + +(def: #export (escape text) + (-> Text Text) + (loop [offset 0 + previous "" + current text + limit ("lux text size" text)] + (if (n.< limit offset) + (case ("lux text char" offset current) + (^template [<char> <replacement>] + [(^ (static <char>)) + (let [[previous' current' limit'] (ascii_escape <replacement> offset limit previous current)] + (recur 0 previous' current' limit'))]) + ([..\0 ..escaped_\0] + [..\a ..escaped_\a] + [..\b ..escaped_\b] + [..\t ..escaped_\t] + [..\n ..escaped_\n] + [..\v ..escaped_\v] + [..\f ..escaped_\f] + [..\r ..escaped_\r] + [..\'' ..escaped_\''] + [..\\ ..escaped_\\]) + + char + (if (or (n.< ..ascii_bottom char) + (n.> ..ascii_top char)) + (let [[previous' current' limit'] (unicode_escape char offset limit previous current)] + (recur 0 previous' current' limit')) + (recur (inc offset) previous current limit))) + (format previous current)))) + +(exception: #export (dangling_escape {text Text}) + (exception.report + ["In" (%.text text)] + ["At" (%.nat (dec (//.size text)))])) + +(exception: #export (invalid_escape {text Text} {offset Nat} {sigil Char}) + (exception.report + ["In" (%.text text)] + ["At" (%.nat offset)] + ["Name" (%.text (//.from_code sigil))])) + +(exception: #export (invalid_unicode_escape {text Text} {offset Nat}) + (exception.report + ["In" (%.text text)] + ["At" (%.nat offset)])) + +(def: code_size + 4) + +(def: ascii_escape_offset + 2) + +(def: unicode_escape_offset + (n.+ ..ascii_escape_offset ..code_size)) + +(def: (ascii_un_escape replacement offset previous current limit) + (-> Text Nat Text Text Nat [Text Text Nat]) + (let [limit' (|> limit (n.- offset) (n.- ..ascii_escape_offset))] + [(format previous + ("lux text clip" 0 offset current) + replacement) + ("lux text clip" (n.+ ..ascii_escape_offset offset) limit' current) + limit'])) + +(def: (unicode_un_escape offset previous current limit) + (-> Nat Text Text Nat (Try [Text Text Nat])) + (case (|> current + ("lux text clip" (n.+ ..ascii_escape_offset offset) ..code_size) + (\ n.hex decode)) + (#try.Success char) + (let [limit' (|> limit (n.- offset) (n.- ..unicode_escape_offset))] + (#try.Success [(format previous + ("lux text clip" 0 offset current) + (//.from_code char)) + ("lux text clip" (n.+ ..unicode_escape_offset offset) limit' current) + limit'])) + + (#try.Failure error) + (exception.throw ..invalid_unicode_escape [current offset]))) + +(def: #export (un_escape text) + (-> Text (Try Text)) + (loop [offset 0 + previous "" + current text + limit ("lux text size" text)] + (if (n.< limit offset) + (case ("lux text char" offset current) + (^ (static ..sigil_char)) + (let [@sigil (inc offset)] + (if (n.< limit @sigil) + (case ("lux text char" @sigil current) + (^template [<sigil> <un_escaped>] + [(^ (static <sigil>)) + (let [[previous' current' limit'] (..ascii_un_escape <un_escaped> offset previous current limit)] + (recur 0 previous' current' limit'))]) + ([..\0_sigil //.\0] + [..\a_sigil //.\a] + [..\b_sigil //.\b] + [..\t_sigil //.\t] + [..\n_sigil //.\n] + [..\v_sigil //.\v] + [..\f_sigil //.\f] + [..\r_sigil //.\r] + [..\''_sigil //.\''] + [..\\_sigil ..sigil]) + + (^ (static ..\u_sigil)) + (let [@unicode (n.+ code_size @sigil)] + (if (n.< limit @unicode) + (do try.monad + [[previous' current' limit'] (..unicode_un_escape offset previous current limit)] + (recur 0 previous' current' limit')) + (exception.throw ..invalid_unicode_escape [text offset]))) + + invalid_sigil + (exception.throw ..invalid_escape [text offset invalid_sigil])) + (exception.throw ..dangling_escape [text]))) + + _ + (recur (inc offset) previous current limit)) + (#try.Success (case previous + "" current + _ (format previous current)))))) + +(syntax: #export (escaped {literal <code>.text}) + (case (..un_escape literal) + (#try.Success un_escaped) + (wrap (list (code.text un_escaped))) + + (#try.Failure error) + (meta.fail error))) diff --git a/stdlib/source/test/lux/data/text.lux b/stdlib/source/test/lux/data/text.lux index 28ba6fef5..8102ae30e 100644 --- a/stdlib/source/test/lux/data/text.lux +++ b/stdlib/source/test/lux/data/text.lux @@ -25,6 +25,7 @@ ["#." encoding] ["#." format] ["#." regex] + ["#." escape] ["#." unicode #_ ["#" set]]] {1 @@ -308,5 +309,6 @@ /encoding.test /format.test /regex.test + /escape.test /unicode.test ))) diff --git a/stdlib/source/test/lux/data/text/escape.lux b/stdlib/source/test/lux/data/text/escape.lux new file mode 100644 index 000000000..de8e77510 --- /dev/null +++ b/stdlib/source/test/lux/data/text/escape.lux @@ -0,0 +1,156 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + ["." debug] + ["." meta] + [abstract + [monad (#+ do)]] + [control + ["." try] + ["." exception] + [parser + ["<.>" code]]] + [data + ["." bit ("#\." equivalence)] + ["." text (#+ Char) ("#\." equivalence) + ["%" format (#+ format)]] + [collection + ["." set (#+ Set)]]] + [macro + [syntax (#+ syntax:)] + ["." code] + ["." template]] + [math + ["." random (#+ Random)] + [number (#+ hex) + ["n" nat]]]] + {1 + ["." / + [// + ["." unicode #_ + ["#" set]]]]}) + +(def: (range max min) + (-> Char Char (Random Char)) + (let [range (n.- min max)] + (\ random.monad map + (|>> (n.% range) (n.+ min)) + random.nat))) + +(def: under_range + (Random Char) + (..range (debug.private /.ascii_bottom) 0)) + +(def: over_range + (Random Char) + (..range (hex "FFFF") (inc (debug.private /.ascii_top)))) + +(def: in_range + (Random Char) + (..range (inc (debug.private /.ascii_top)) (debug.private /.ascii_bottom))) + +(def: ascii_range + (Random Char) + (..range (inc (debug.private /.ascii_top)) 0)) + +(def: valid_sigils + (Set Char) + (set.from_list n.hash + (list (debug.private /.\0_sigil) + (debug.private /.\a_sigil) + (debug.private /.\b_sigil) + (debug.private /.\t_sigil) + (debug.private /.\n_sigil) + (debug.private /.\v_sigil) + (debug.private /.\f_sigil) + (debug.private /.\r_sigil) + (debug.private /.\''_sigil) + (debug.private /.\\_sigil) + (debug.private /.\u_sigil)))) + +(syntax: (static_sample) + (do meta.monad + [seed meta.count + #let [[_ expected] (random.run (random.pcg32 [seed seed]) + (random.unicode 10))]] + (wrap (list (code.text expected))))) + +(syntax: (static_escape {un_escaped <code>.text}) + (wrap (list (code.text (/.escape un_escaped))))) + +(def: #export test + Test + (<| (_.covering /._) + ($_ _.and + (do random.monad + [ascii ..ascii_range] + (_.cover [/.escapable?] + (`` (if (or (~~ (template [<char>] + [(n.= (debug.private <char>) ascii)] + + [/.\0] [/.\a] [/.\b] [/.\t] + [/.\n] [/.\v] [/.\f] [/.\r] + [/.\''] [/.\\]))) + (/.escapable? ascii) + (bit\= (/.escapable? ascii) + (or (n.< (debug.private /.ascii_bottom) ascii) + (n.> (debug.private /.ascii_top) ascii))))))) + (do random.monad + [left (random.char unicode.character) + right (random.char unicode.character)] + (_.cover [/.escape /.un_escape] + (let [expected (format (text.from_code left) (text.from_code right))] + (if (or (/.escapable? left) + (/.escapable? right)) + (let [escaped (/.escape expected)] + (case (/.un_escape escaped) + (#try.Success un_escaped) + (and (not (text\= escaped expected)) + (text\= un_escaped expected)) + + (#try.Failure error) + false)) + (text\= expected (/.escape expected)))))) + (do {! random.monad} + [dummy (|> (random.char unicode.character) + (\ ! map text.from_code))] + (_.cover [/.dangling_escape] + (case (/.un_escape (format (/.escape dummy) "\")) + (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.dangling_escape error)))) + (do {! random.monad} + [dummy (|> (random.char unicode.character) + (random.filter (|>> (set.member? ..valid_sigils) not)) + (\ ! map text.from_code))] + (_.cover [/.invalid_escape] + (case (/.un_escape (format "\" dummy)) + (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.invalid_escape error)))) + (do {! random.monad} + [too_short (|> (random.char unicode.character) + (\ ! map (n.% (hex "1000")))) + code (|> (random.unicode 4) + (random.filter (function (_ code) + (case (\ n.hex decode code) + (#try.Failure error) true + (#try.Success _) false))))] + (_.cover [/.invalid_unicode_escape] + (template.with [(!invalid <code>) + (case (/.un_escape (format "\u" <code>)) + (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.invalid_unicode_escape error))] + (and (!invalid (\ n.hex encode too_short)) + (!invalid code))))) + (_.cover [/.escaped] + (with_expansions [<example> (..static_sample)] + (text\= <example> (`` (/.escaped (~~ (..static_escape <example>))))))) + ))) |