diff options
Diffstat (limited to 'stdlib/source')
| -rw-r--r-- | stdlib/source/lux/control/parser/text.lux | 85 | ||||
| -rw-r--r-- | stdlib/source/lux/control/parser/tree.lux | 24 | ||||
| -rw-r--r-- | stdlib/source/lux/data/collection/tree.lux | 20 | ||||
| -rw-r--r-- | stdlib/source/lux/data/collection/tree/zipper.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/data/number/int.lux | 1 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux | 106 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/parser/text.lux | 55 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/parser/tree.lux | 172 |
9 files changed, 346 insertions, 125 deletions
diff --git a/stdlib/source/lux/control/parser/text.lux b/stdlib/source/lux/control/parser/text.lux index b74be5022..114b53deb 100644 --- a/stdlib/source/lux/control/parser/text.lux +++ b/stdlib/source/lux/control/parser/text.lux @@ -8,7 +8,7 @@ [data ["." product] ["." maybe] - ["/" text ("#@." monoid)] + ["/" text (#+ Char) ("#@." monoid)] [number ["n" nat ("#@." decimal)]] [collection @@ -96,7 +96,7 @@ #distance 1}]) _ - (exception.throw ..cannot-parse [])))) + (exception.throw ..cannot-slice [])))) (template [<name> <type> <any>] [(def: #export (<name> p) @@ -114,20 +114,23 @@ [not! Slice ..any!] ) -(with-expansions [<failure> (as-is (#try.Failure ($_ /@compose "Could not match: " (/.encode reference) " @ " (maybe.assume (/.clip' offset tape)))))] - (def: #export (this reference) - {#.doc "Lex a text if it matches the given sample."} - (-> Text (Parser Any)) - (function (_ [offset tape]) - (case (/.index-of' reference offset tape) - (#.Some where) - (if (n.= offset where) - (#try.Success [[("lux i64 +" (/.size reference) offset) tape] - []]) - <failure>) - - _ - <failure>)))) +(exception: #export (cannot-match {reference Text}) + (exception.report + ["Reference" (/.encode reference)])) + +(def: #export (this reference) + {#.doc "Lex a text if it matches the given sample."} + (-> Text (Parser Any)) + (function (_ [offset tape]) + (case (/.index-of' reference offset tape) + (#.Some where) + (if (n.= offset where) + (#try.Success [[("lux i64 +" (/.size reference) offset) tape] + []]) + (exception.throw ..cannot-match [reference])) + + _ + (exception.throw ..cannot-match [reference])))) (def: #export end! {#.doc "Ensure the parser's input is empty."} @@ -195,59 +198,69 @@ (range (char "a") (char "f")) (range (char "A") (char "F")))) -(template [<name> <description-modifier> <modifier>] +(template [<name>] + [(exception: #export (<name> {options Text} {character Char}) + (exception.report + ["Options" (/.encode options)] + ["Character" (/.encode (/.from-code character))]))] + + [character-should-be] + [character-should-not-be] + ) + +(template [<name> <modifier> <exception> <description-modifier>] [(def: #export (<name> options) {#.doc (code.text ($_ /@compose "Only lex characters that are" <description-modifier> " part of a piece of text."))} (-> Text (Parser Text)) (function (_ [offset tape]) (case (/.nth offset tape) (#.Some output) - (let [output (/.from-code output)] - (if (<modifier> (/.contains? output options)) - (#try.Success [[("lux i64 +" 1 offset) tape] output]) - (#try.Failure ($_ /@compose "Character (" output - ") is should " <description-modifier> - "be one of: " options)))) + (let [output' (/.from-code output)] + (if (<modifier> (/.contains? output' options)) + (#try.Success [[("lux i64 +" 1 offset) tape] output']) + (exception.throw <exception> [options output]))) _ (exception.throw ..cannot-parse []))))] - [one-of "" |>] - [none-of " not" .not] + [one-of |> ..character-should-be ""] + [none-of .not ..character-should-not-be " not"] ) -(template [<name> <description-modifier> <modifier>] +(template [<name> <modifier> <exception> <description-modifier>] [(def: #export (<name> options) {#.doc (code.text ($_ /@compose "Only lex characters that are" <description-modifier> " part of a piece of text."))} (-> Text (Parser Slice)) (function (_ [offset tape]) (case (/.nth offset tape) (#.Some output) - (let [output (/.from-code output)] - (if (<modifier> (/.contains? output options)) + (let [output' (/.from-code output)] + (if (<modifier> (/.contains? output' options)) (#try.Success [[("lux i64 +" 1 offset) tape] {#basis offset #distance 1}]) - (#try.Failure ($_ /@compose "Character (" output - ") is should " <description-modifier> - "be one of: " options)))) + (exception.throw <exception> [options output]))) _ - (exception.throw ..cannot-parse []))))] + (exception.throw ..cannot-slice []))))] - [one-of! "" |>] - [none-of! " not" .not] + [one-of! |> ..character-should-be ""] + [none-of! .not ..character-should-not-be " not"] ) +(exception: #export (character-does-not-satisfy-predicate {character Char}) + (exception.report + ["Character" (/.encode (/.from-code character))])) + (def: #export (satisfies p) {#.doc "Only lex characters that satisfy a predicate."} - (-> (-> Nat Bit) (Parser Text)) + (-> (-> Char Bit) (Parser Text)) (function (_ [offset tape]) (case (/.nth offset tape) (#.Some output) (if (p output) (#try.Success [[("lux i64 +" 1 offset) tape] (/.from-code output)]) - (#try.Failure ($_ /@compose "Character does not satisfy predicate: " (/.from-code output)))) + (exception.throw ..character-does-not-satisfy-predicate [output])) _ (exception.throw ..cannot-parse [])))) diff --git a/stdlib/source/lux/control/parser/tree.lux b/stdlib/source/lux/control/parser/tree.lux index 3dbc5522d..5ca642b75 100644 --- a/stdlib/source/lux/control/parser/tree.lux +++ b/stdlib/source/lux/control/parser/tree.lux @@ -4,25 +4,26 @@ ["." try (#+ Try)] ["." exception (#+ exception:)]] [data - [tree (#+ Tree) - ["." zipper (#+ Zipper)]]]] + [collection + [tree (#+ Tree) + ["." zipper (#+ Zipper)]]]]] ["." //]) (type: #export (Parser t a) (//.Parser (Zipper t) a)) -(def: #export (run-zipper zipper parser) - (All [t a] (-> (Zipper t) (Parser t a) (Try a))) - (case (//.run zipper parser) +(def: #export (run' parser zipper) + (All [t a] (-> (Parser t a) (Zipper t) (Try a))) + (case (//.run parser zipper) (#try.Success [zipper output]) (#try.Success output) (#try.Failure error) (#try.Failure error))) -(def: #export (run tree parser) - (All [t a] (-> (Tree t) (Parser t a) (Try a))) - (run-zipper (zipper.zip tree) parser)) +(def: #export (run parser tree) + (All [t a] (-> (Parser t a) (Tree t) (Try a))) + (run' parser (zipper.zip tree))) (def: #export value (All [t] (Parser t t)) @@ -40,13 +41,14 @@ (exception.throw cannot-move-further []) (#try.Success [next []])))))] - [up zipper.up] [down zipper.down] - [left zipper.left] + [up zipper.up] [right zipper.right] - [root zipper.root] + [left zipper.left] [rightmost zipper.rightmost] [leftmost zipper.leftmost] [next zipper.next] [prev zipper.prev] + [end zipper.end] + [start zipper.start] ) diff --git a/stdlib/source/lux/data/collection/tree.lux b/stdlib/source/lux/data/collection/tree.lux index a3fb711d3..eed5bd860 100644 --- a/stdlib/source/lux/data/collection/tree.lux +++ b/stdlib/source/lux/data/collection/tree.lux @@ -6,14 +6,14 @@ [equivalence (#+ Equivalence)] [fold (#+ Fold)]] [control - ["p" parser - ["s" code (#+ Parser)]]] + ["<>" parser + ["<c>" code (#+ Parser)]]] [data [collection ["." list ("#@." monad fold)]]] ["." macro - ["." code] - [syntax (#+ syntax:)]]]) + [syntax (#+ syntax:)] + ["." code]]]) (type: #export (Tree a) {#value a @@ -39,12 +39,12 @@ (def: tree^ (Parser Tree-Code) - (|> (|>> p.some s.record (p.and s.any)) - p.rec - p.some - s.record - (p.and s.any) - s.tuple)) + (|> (|>> <>.some <c>.record (<>.and <c>.any)) + <>.rec + <>.some + <c>.record + (<>.and <c>.any) + <c>.tuple)) (syntax: #export (tree {root tree^}) {#.doc (doc "Tree literals." diff --git a/stdlib/source/lux/data/collection/tree/zipper.lux b/stdlib/source/lux/data/collection/tree/zipper.lux index 47e125e4a..d4b7ec4f6 100644 --- a/stdlib/source/lux/data/collection/tree/zipper.lux +++ b/stdlib/source/lux/data/collection/tree/zipper.lux @@ -173,6 +173,10 @@ (#.Cons _) (end (..rightmost zipper)))) +(def: #export (end? zipper) + (All [a] (-> (Zipper a) Bit)) + (is? zipper (end zipper))) + (def: #export (prev zipper) (All [a] (-> (Zipper a) (Zipper a))) (let [forward (..left zipper)] diff --git a/stdlib/source/lux/data/number/int.lux b/stdlib/source/lux/data/number/int.lux index a5c7cbbea..fb1ceb224 100644 --- a/stdlib/source/lux/data/number/int.lux +++ b/stdlib/source/lux/data/number/int.lux @@ -147,6 +147,7 @@ (def: succ inc) (def: pred dec)) +## TODO: Find out why the numeric literals fail during JS compilation. (structure: #export interval (Interval Int) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux index ed7cdc5ff..78c6c94e1 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux @@ -71,10 +71,6 @@ (let [mask (dec (i64.left-shift 32 1))] (|>> (i64.and mask)))) -(def: #export variant-tag-field "_lux_tag") -(def: #export variant-flag-field "_lux_flag") -(def: #export variant-value-field "_lux_value") - (def: #export unit Computation (_.string /////synthesis.unit)) (def: #export (flag value) @@ -83,28 +79,6 @@ (_.string "") _.null)) -(def: #export (variant tag last? value) - (-> Expression Expression Expression Computation) - (_.object (list [..variant-tag-field tag] - [..variant-flag-field last?] - [..variant-value-field value]))) - -(def: none - Computation - (..variant (_.i32 +0) (flag #0) unit)) - -(def: some - (-> Expression Computation) - (..variant (_.i32 +1) (flag #1))) - -(def: left - (-> Expression Computation) - (..variant (_.i32 +0) (flag #0))) - -(def: right - (-> Expression Computation) - (..variant (_.i32 +1) (flag #1))) - (def: (feature name definition) (-> Var (-> Var Expression) Statement) (_.define name (definition name))) @@ -173,11 +147,6 @@ (_.function (~ g!_) (list (~+ inputsC)) (~ code))))))))))))) -(runtime: (lux//try op) - (with-vars [ex] - (_.try (_.return (..right (_.apply/1 op ..unit))) - [ex (_.return (..left (|> ex (_.do "toString" (list)))))]))) - (def: length (-> Expression Computation) (_.the "length")) @@ -190,25 +159,6 @@ (_.at (..last-index tuple) tuple)) -(runtime: (lux//program-args inputs) - (with-vars [output idx] - ($_ _.then - (_.define output ..none) - (_.for idx - (..last-index inputs) - (_.>= (_.i32 +0) idx) - (_.-- idx) - (_.set output (..some (_.array (list (_.at idx inputs) - output))))) - (_.return output)))) - -(def: runtime//lux - Statement - ($_ _.then - @lux//try - @lux//program-args - )) - (with-expansions [<recur> (as-is ($_ _.then (_.set lefts (_.- last-index-right lefts)) (_.set tuple (_.at last-index-right tuple))))] @@ -237,6 +187,19 @@ (_.return (_.do "slice" (list right-index) tuple))) ))))) +(def: #export variant-tag-field "_lux_tag") +(def: #export variant-flag-field "_lux_flag") +(def: #export variant-value-field "_lux_value") + +(runtime: (variant//create tag last? value) + (_.return (_.object (list [..variant-tag-field tag] + [..variant-flag-field last?] + [..variant-value-field value])))) + +(def: #export (variant tag last? value) + (-> Expression Expression Expression Computation) + (..variant//create tag last? value)) + (runtime: (sum//get sum wants-last wanted-tag) (let [no-match! (_.return _.null) sum-tag (|> sum (_.the ..variant-tag-field)) @@ -263,14 +226,55 @@ extrac-sub-variant!]) no-match!)))) +(def: none + Computation + (..variant (_.i32 +0) (flag #0) unit)) + +(def: some + (-> Expression Computation) + (..variant (_.i32 +1) (flag #1))) + +(def: left + (-> Expression Computation) + (..variant (_.i32 +0) (flag #0))) + +(def: right + (-> Expression Computation) + (..variant (_.i32 +1) (flag #1))) + (def: runtime//structure Statement ($_ _.then @tuple//left @tuple//right + @variant//create @sum//get )) +(runtime: (lux//try op) + (with-vars [ex] + (_.try (_.return (..right (_.apply/1 op ..unit))) + [ex (_.return (..left (|> ex (_.do "toString" (list)))))]))) + +(runtime: (lux//program-args inputs) + (with-vars [output idx] + ($_ _.then + (_.define output ..none) + (_.for idx + (..last-index inputs) + (_.>= (_.i32 +0) idx) + (_.-- idx) + (_.set output (..some (_.array (list (_.at idx inputs) + output))))) + (_.return output)))) + +(def: runtime//lux + Statement + ($_ _.then + @lux//try + @lux//program-args + )) + (def: #export i64-low-field Text "_lux_low") (def: #export i64-high-field Text "_lux_high") @@ -752,13 +756,13 @@ (def: runtime Statement ($_ _.then - runtime//lux runtime//structure runtime//i64 runtime//text runtime//io runtime//js runtime//array + runtime//lux )) (def: #export artifact diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index f51e07767..9beb884b4 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -25,7 +25,8 @@ ["#/." code] ["#/." json] ["#/." synthesis] - ["#/." text]] + ["#/." text] + ["#/." tree]] ["#." pipe] ["#." reader] ["#." region] @@ -69,6 +70,7 @@ /parser/json.test /parser/synthesis.test /parser/text.test + /parser/tree.test )) (def: security diff --git a/stdlib/source/test/lux/control/parser/text.lux b/stdlib/source/test/lux/control/parser/text.lux index 860d4b7bc..30ebe0cad 100644 --- a/stdlib/source/test/lux/control/parser/text.lux +++ b/stdlib/source/test/lux/control/parser/text.lux @@ -5,7 +5,7 @@ [monad (#+ do)]] [control ["." try (#+ Try)] - ["." exception] + ["." exception (#+ Exception)] ["." function]] [data ["." maybe] @@ -34,6 +34,15 @@ _ false)) +(def: (should-fail' sample parser exception) + (All [a e] (-> Text (/.Parser a) (Exception e) Bit)) + (case (/.run parser sample) + (#try.Failure error) + (exception.match? exception error) + + _ + false)) + (def: (should-fail sample parser) (All [a] (-> Text (/.Parser a) Bit)) (case (/.run parser sample) @@ -153,12 +162,16 @@ (text.contains? options) not) (random.char unicode.full))] - (_.cover [/.one-of /.one-of!] + (_.cover [/.one-of /.one-of! /.character-should-be] (and (..should-pass (text.from-code expected) (/.one-of options)) (..should-fail (text.from-code invalid) (/.one-of options)) + (..should-fail' (text.from-code invalid) (/.one-of options) + /.character-should-be) (..should-pass! (text.from-code expected) (/.one-of! options)) - (..should-fail (text.from-code invalid) (/.one-of options))))) + (..should-fail (text.from-code invalid) (/.one-of! options)) + (..should-fail' (text.from-code invalid) (/.one-of! options) + /.character-should-be)))) (do {@ random.monad} [#let [num-options 3] options (|> (random.char unicode.full) @@ -175,12 +188,16 @@ (text.contains? options) not) (random.char unicode.full))] - (_.cover [/.none-of /.none-of!] + (_.cover [/.none-of /.none-of! /.character-should-not-be] (and (..should-pass (text.from-code expected) (/.none-of options)) (..should-fail (text.from-code invalid) (/.none-of options)) + (..should-fail' (text.from-code invalid) (/.none-of options) + /.character-should-not-be) (..should-pass! (text.from-code expected) (/.none-of! options)) - (..should-fail (text.from-code invalid) (/.none-of! options))))) + (..should-fail (text.from-code invalid) (/.none-of! options)) + (..should-fail' (text.from-code invalid) (/.none-of! options) + /.character-should-not-be)))) )) (def: runs @@ -288,19 +305,23 @@ expected (random.unicode size) dummy (|> (random.unicode size) (random.filter (|>> (text@= expected) not)))] - (_.cover [/.this] + (_.cover [/.this /.cannot-match] (and (|> (/.run (/.this expected) expected) (!expect (#try.Success []))) (|> (/.run (/.this expected) dummy) - (!expect (#try.Failure _)))))) - (do {@ random.monad} - [expected (random.unicode 1)] - (_.cover [/.Slice /.slice /.cannot-slice] - (|> "" - (/.run (/.slice /.any!)) - (!expect (^multi (#try.Failure error) + (!expect (^multi (#try.Failure error) + (exception.match? /.cannot-match error))))))) + (_.cover [/.Slice /.slice /.cannot-slice] + (|> "" + (/.run (do <>.monad + [#let [_ (log! " PRE SLICE")] + slice (/.slice /.any!) + #let [_ (log! "POST SLICE")]] + (wrap slice))) + (!expect (^multi (#try.Failure error) + (exec (log! (format "error = " error)) (exception.match? /.cannot-slice error)))))) (do {@ random.monad} [expected (random.unicode 1)] @@ -344,7 +365,8 @@ (/.run (do <>.monad [pre /.get-input _ /.any - post /.get-input] + post /.get-input + _ /.any] (wrap (and (text@= input pre) (text@= right post))))) (!expect (#try.Success #1))))) @@ -411,9 +433,10 @@ (do {@ random.monad} [expected (random.unicode 1) invalid (random.unicode 1)] - (_.cover [/.satisfies] + (_.cover [/.satisfies /.character-does-not-satisfy-predicate] (and (..should-pass expected (/.satisfies (function.constant true))) - (..should-fail invalid (/.satisfies (function.constant false)))))) + (..should-fail' invalid (/.satisfies (function.constant false)) + /.character-does-not-satisfy-predicate)))) ..character-classes ..runs ))) diff --git a/stdlib/source/test/lux/control/parser/tree.lux b/stdlib/source/test/lux/control/parser/tree.lux new file mode 100644 index 000000000..d451e6298 --- /dev/null +++ b/stdlib/source/test/lux/control/parser/tree.lux @@ -0,0 +1,172 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try] + ["." exception]] + [data + [number + ["n" nat]] + [collection + ["." tree + ["." zipper]]]] + [math + ["." random]]] + {1 + ["." / + ["/#" //]]}) + +(template: (!expect <pattern> <value>) + (case <value> + <pattern> + true + + _ + false)) + +(template: (!cover <coverage> <parser> <sample>) + (do {@ random.monad} + [dummy random.nat + expected (|> random.nat (random.filter (|>> (n.= dummy) not)))] + (_.cover <coverage> + (|> (/.run <parser> + <sample>) + (!expect (^multi (#try.Success actual) + (n.= expected actual))))))) + +(template: (!cover2 <coverage> <parser> <sample0> <sample1>) + (do {@ random.monad} + [dummy random.nat + expected (|> random.nat (random.filter (|>> (n.= dummy) not)))] + (_.cover <coverage> + (and (|> (/.run <parser> <sample0>) + (!expect (^multi (#try.Success actual) + (n.= expected actual)))) + (|> (/.run <parser> <sample1>) + (!expect (^multi (#try.Success actual) + (n.= expected actual)))))))) + +(def: #export test + Test + (<| (_.covering /._) + (_.with-cover [/.Parser]) + ($_ _.and + (!cover [/.run /.value] + /.value + (tree.leaf expected)) + (do {@ random.monad} + [expected random.nat] + (_.cover [/.run'] + (|> (/.run' /.value + (zipper.zip (tree.leaf expected))) + (!expect (^multi (#try.Success actual) + (n.= expected actual)))))) + (!cover [/.down] + (do //.monad + [_ /.down] + /.value) + (tree.branch dummy + (list (tree.leaf expected)))) + (!cover [/.up] + (do //.monad + [_ /.down + _ /.up] + /.value) + (tree.branch expected + (list (tree.leaf dummy)))) + (!cover [/.right] + (do //.monad + [_ /.down + _ /.right] + /.value) + (tree.branch dummy + (list (tree.leaf dummy) + (tree.leaf expected)))) + (!cover [/.left] + (do //.monad + [_ /.down + _ /.right + _ /.left] + /.value) + (tree.branch dummy + (list (tree.leaf expected) + (tree.leaf dummy)))) + (!cover [/.rightmost] + (do //.monad + [_ /.down + _ /.rightmost] + /.value) + (tree.branch dummy + (list (tree.leaf dummy) + (tree.leaf dummy) + (tree.leaf expected)))) + (!cover [/.leftmost] + (do //.monad + [_ /.down + _ /.rightmost + _ /.leftmost] + /.value) + (tree.branch dummy + (list (tree.leaf expected) + (tree.leaf dummy) + (tree.leaf dummy)))) + (!cover2 [/.next] + (do //.monad + [_ /.next + _ /.next] + /.value) + (tree.branch dummy + (list (tree.branch dummy + (list (tree.leaf expected))))) + (tree.branch dummy + (list (tree.leaf dummy) + (tree.leaf expected)))) + (!cover2 [/.prev] + (do //.monad + [_ /.next + _ /.next + _ /.prev] + /.value) + (tree.branch dummy + (list (tree.branch expected + (list (tree.leaf dummy))))) + (tree.branch dummy + (list (tree.leaf expected) + (tree.leaf dummy)))) + (!cover2 [/.end] + (do //.monad + [_ /.end] + /.value) + (tree.branch dummy + (list (tree.branch dummy + (list (tree.leaf expected))))) + (tree.branch dummy + (list (tree.leaf dummy) + (tree.leaf expected)))) + (!cover2 [/.start] + (do //.monad + [_ /.end + _ /.start] + /.value) + (tree.branch expected + (list (tree.branch dummy + (list (tree.leaf dummy))))) + (tree.branch expected + (list (tree.leaf dummy) + (tree.leaf dummy)))) + (do {@ random.monad} + [dummy random.nat] + (_.cover [/.cannot-move-further] + (`` (and (~~ (template [<parser>] + [(|> (/.run <parser> + (tree.leaf dummy)) + (!expect (^multi (#try.Failure error) + (exception.match? /.cannot-move-further error))))] + + [/.down] [/.up] + [/.right] [/.left] + [/.next] [/.prev] + )))))) + ))) |