diff options
Diffstat (limited to 'stdlib/source')
| -rw-r--r-- | stdlib/source/lux.lux | 11 | ||||
| -rw-r--r-- | stdlib/source/lux/control/concatenative.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/data/coll/tree/parser.lux | 50 | ||||
| -rw-r--r-- | stdlib/source/lux/data/coll/tree/zipper.lux | 68 | ||||
| -rw-r--r-- | stdlib/source/lux/data/format/xml.lux | 140 | ||||
| -rw-r--r-- | stdlib/source/lux/math.lux | 89 |
6 files changed, 257 insertions, 103 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 641e8693d..6b29d7c42 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -5603,10 +5603,10 @@ (macro: #export (undefined tokens) {#;doc (doc "Meant to be used as a stand-in for functions with undefined implementations." "Undefined expressions will type-check against everything, so they make good dummy implementations." + "However, if an undefined expression is ever evaluated, it will raise a runtime error." (def: (square x) (-> Int Int) - (undefined)) - "If an undefined expression is ever evaluated, it will raise an error.")} + (undefined)))} (case tokens #;Nil (return (list (` (error! "Undefined behavior.")))) @@ -5761,3 +5761,10 @@ _ (#;Left "Wrong syntax for char"))) + +(def: #export (when test f) + (All [a] (-> Bool (-> a a) (-> a a))) + (function [value] + (if test + (f value) + value))) diff --git a/stdlib/source/lux/control/concatenative.lux b/stdlib/source/lux/control/concatenative.lux index 61a6ddbd0..cdb9cc457 100644 --- a/stdlib/source/lux/control/concatenative.lux +++ b/stdlib/source/lux/control/concatenative.lux @@ -1,4 +1,4 @@ -(;module: [lux #- if loop +(;module: [lux #- if loop when n.+ n.- n.* n./ n.% n.= n.< n.<= n.> n.>= i.+ i.- i.* i./ i.% i.= i.< i.<= i.> i.>= d.+ d.- d.* d./ d.% d.= d.< d.<= d.> d.>= diff --git a/stdlib/source/lux/data/coll/tree/parser.lux b/stdlib/source/lux/data/coll/tree/parser.lux new file mode 100644 index 000000000..203f55b16 --- /dev/null +++ b/stdlib/source/lux/data/coll/tree/parser.lux @@ -0,0 +1,50 @@ +(;module: + lux + (lux (control ["p" parser] + ["ex" exception #+ exception:]) + (data ["R" result])) + (.. ["T" rose] + ["Z" zipper])) + +(type: #export (Parser t a) + (p;Parser (Z;Zipper t) a)) + +(def: #export (run-zipper zipper parser) + (All [t a] (-> (Z;Zipper t) (Parser t a) (R;Result a))) + (case (p;run zipper parser) + (#R;Success [zipper output]) + (#R;Success output) + + (#R;Error error) + (#R;Error error))) + +(def: #export (run tree parser) + (All [t a] (-> (T;Tree t) (Parser t a) (R;Result a))) + (run-zipper (Z;zip tree) parser)) + +(def: #export value + (All [t] (Parser t t)) + (function [zipper] + (#R;Success [zipper (Z;value zipper)]))) + +(exception: #export Cannot-Move-Further) + +(do-template [<name> <direction>] + [(def: #export <name> + (All [t] (Parser t [])) + (function [zipper] + (let [next (<direction> zipper)] + (if (is zipper next) + (ex;throw Cannot-Move-Further "") + (#R;Success [next []])))))] + + [up Z;up] + [down Z;down] + [left Z;left] + [right Z;right] + [root Z;root] + [rightmost Z;rightmost] + [leftmost Z;leftmost] + [next Z;next] + [prev Z;prev] + ) diff --git a/stdlib/source/lux/data/coll/tree/zipper.lux b/stdlib/source/lux/data/coll/tree/zipper.lux index b217a0677..6b39178bc 100644 --- a/stdlib/source/lux/data/coll/tree/zipper.lux +++ b/stdlib/source/lux/data/coll/tree/zipper.lux @@ -21,24 +21,24 @@ #node (Tree a)}) ## [Values] -(def: #export (from-tree tree) +(def: #export (zip tree) (All [a] (-> (Tree a) (Zipper a))) {#parent #;None #lefts stack;empty #rights stack;empty #node tree}) -(def: #export (to-tree zipper) +(def: #export (unzip zipper) (All [a] (-> (Zipper a) (Tree a))) (get@ #node zipper)) (def: #export (value zipper) (All [a] (-> (Zipper a) a)) - (|> zipper (get@ #node) (get@ #rose;value))) + (|> zipper (get@ [#node #rose;value]))) (def: #export (children zipper) (All [a] (-> (Zipper a) (List (Tree a)))) - (|> zipper (get@ #node) (get@ #rose;children))) + (|> zipper (get@ [#node #rose;children]))) (def: #export (branch? zipper) (All [a] (-> (Zipper a) Bool)) @@ -48,9 +48,19 @@ (All [a] (-> (Zipper a) Bool)) (|> zipper branch? not)) -(def: #export (parent zipper) - (All [a] (-> (Zipper a) (Maybe (Zipper a)))) - (get@ #parent zipper)) +(def: #export (end? zipper) + (All [a] (-> (Zipper a) Bool)) + (and (list;empty? (get@ #rights zipper)) + (list;empty? (children zipper)))) + +(def: #export (root? zipper) + (All [a] (-> (Zipper a) Bool)) + (case (get@ #parent zipper) + #;None + true + + _ + false)) (def: #export (down zipper) (All [a] (-> (Zipper a) (Zipper a))) @@ -108,6 +118,20 @@ [left leftmost #lefts #rights] ) +(do-template [<name> <h-side> <h-op> <v-op>] + [(def: #export (<name> zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ <h-side> zipper) + #;Nil + (<v-op> zipper) + + _ + (<h-op> zipper)))] + + [next #rights right down] + [prev #lefts left up] + ) + (def: #export (set value zipper) (All [a] (-> a (Zipper a) (Zipper a))) (set@ [#node #rose;value] value zipper)) @@ -169,34 +193,6 @@ [insert-right #rights] ) -(do-template [<name> <h-side> <h-op> <v-op>] - [(def: #export (<name> zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (get@ <h-side> zipper) - #;Nil - (<v-op> zipper) - - _ - (<h-op> zipper)))] - - [next #rights right down] - [prev #lefts left up] - ) - -(def: #export (end? zipper) - (All [a] (-> (Zipper a) Bool)) - (and (list;empty? (get@ #rights zipper)) - (list;empty? (children zipper)))) - -(def: #export (root? zipper) - (All [a] (-> (Zipper a) Bool)) - (case (get@ #parent zipper) - #;None - true - - _ - false)) - (struct: #export _ (Functor Zipper) (def: (map f fa) {#parent (|> fa (get@ #parent) (M/map (map f))) @@ -211,7 +207,7 @@ ## (def: (split wa) ## (let [tree-splitter (function tree-splitter [tree] -## {#rose;value (from-tree tree) +## {#rose;value (zip tree) ## #rose;children (L/map tree-splitter ## (get@ #rose;children tree))})] ## {#parent (|> wa (get@ #parent) (M/map split)) diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux index 4ff38380f..dc6074ef5 100644 --- a/stdlib/source/lux/data/format/xml.lux +++ b/stdlib/source/lux/data/format/xml.lux @@ -3,37 +3,28 @@ (lux (control monad [eq #+ Eq] codec - ["p" parser "p/" Monad<Parser>]) + ["p" parser "p/" Monad<Parser>] + ["ex" exception #+ exception:]) (data [text "text/" Eq<Text> Monoid<Text>] (text ["l" lexer]) [number] ["R" result] [product] [maybe "m/" Monad<Maybe>] - [ident "Ident/" Eq<Ident> Codec<Text,Ident>] + [ident "ident/" Eq<Ident> Codec<Text,Ident>] (coll [list "L/" Monad<List>] - ["d" dict] - (tree ["T" rose] - ["Z" zipper]))) + ["d" dict])) )) -## [Types] (type: #export Tag Ident) (type: #export Attrs (d;Dict Ident Text)) +(def: #export attrs Attrs (d;new ident;Hash<Ident>)) + (type: #export #rec XML (#Text Text) (#Node Tag Attrs (List XML))) -(def: #export (text value) - (-> Text XML) - (#Text value)) - -(def: #export (node tag attrs children) - (-> Tag Attrs (List XML) XML) - (#Node tag attrs children)) - -## [Parsing] (def: xml-standard-escape-char^ (l;Lexer Text) ($_ p;either @@ -119,9 +110,9 @@ (p;after (l;this "/")) (l;enclosed ["<" ">"]))] (p;assert ($_ text/append "Close tag does not match open tag.\n" - "Expected: " (Ident/encode expected) "\n" - " Actual: " (Ident/encode actual) "\n") - (Ident/= expected actual)))) + "Expected: " (ident/encode expected) "\n" + " Actual: " (ident/encode actual) "\n") + (ident/= expected actual)))) (def: comment^ (l;Lexer Text) @@ -163,12 +154,12 @@ attrs (spaced^ attrs^) #let [no-children^ (do p;Monad<Parser> [_ (l;this "/>")] - (wrap (node tag attrs (list)))) + (wrap (#Node tag attrs (list)))) with-children^ (do p;Monad<Parser> [_ (l;this ">") children (p;some node^) _ (close-tag^ tag)] - (wrap (node tag attrs children)))]] + (wrap (#Node tag attrs children)))]] (p;either no-children^ with-children^)))))) ## This is put outside of the call to "rec" because comments @@ -182,7 +173,6 @@ (-> Text (R;Result XML)) (l;run input xml^)) -## [Generation] (def: (sanitize-value input) (-> Text Text) (|> input @@ -231,7 +221,6 @@ (text;join-with "")) "</" tag ">"))))))) -## [Structs] (struct: #export _ (Codec Text XML) (def: encode write) (def: decode read)) @@ -244,7 +233,7 @@ [(#Node reference/tag reference/attrs reference/children) (#Node sample/tag sample/attrs sample/children)] - (and (Ident/= reference/tag sample/tag) + (and (ident/= reference/tag sample/tag) (:: (d;Eq<Dict> text;Eq<Text>) = reference/attrs sample/attrs) (n.= (list;size reference/children) (list;size sample/children)) @@ -253,3 +242,108 @@ _ false))) + +(type: #export (Reader a) + (p;Parser (List XML) a)) + +(exception: #export Empty-Input) +(exception: #export Unexpected-Input) +(exception: #export Unknown-Attribute) +(exception: #export Wrong-Tag) +(exception: #export Unconsumed-Inputs) + +(def: #export text + (Reader Text) + (function [docs] + (case docs + #;Nil + (ex;throw Empty-Input "") + + (#;Cons head tail) + (case head + (#Text value) + (#R;Success [tail value]) + + (#Node _) + (ex;throw Unexpected-Input ""))))) + +(def: #export (attr name) + (-> Ident (Reader Text)) + (function [docs] + (case docs + #;Nil + (ex;throw Empty-Input "") + + (#;Cons head _) + (case head + (#Text _) + (ex;throw Unexpected-Input "") + + (#Node tag attrs children) + (case (d;get name attrs) + #;None + (ex;throw Unknown-Attribute "") + + (#;Some value) + (#R;Success [docs value])))))) + +(def: (run' docs reader) + (All [a] (-> (List XML) (Reader a) (R;Result a))) + (case (p;run docs reader) + (#R;Success [remaining output]) + (if (list;empty? remaining) + (#R;Success output) + (ex;throw Unconsumed-Inputs (|> remaining + (L/map (:: Codec<Text,XML> encode)) + (text;join-with "\n\n")))) + + (#R;Error error) + (#R;Error error))) + +(def: #export (node tag) + (-> Ident (Reader Unit)) + (function [docs] + (case docs + #;Nil + (ex;throw Empty-Input "") + + (#;Cons head _) + (case head + (#Text _) + (ex;throw Unexpected-Input "") + + (#Node _tag _attrs _children) + (if (ident/= tag _tag) + (#R;Success [docs []]) + (ex;throw Wrong-Tag (ident/encode tag))))))) + +(def: #export (children reader) + (All [a] (-> (Reader a) (Reader a))) + (function [docs] + (case docs + #;Nil + (ex;throw Empty-Input "") + + (#;Cons head tail) + (case head + (#Text _) + (ex;throw Unexpected-Input "") + + (#Node _tag _attrs _children) + (do R;Monad<Result> + [output (run' _children reader)] + (wrap [tail output])))))) + +(def: #export ignore + (Reader Unit) + (function [docs] + (case docs + #;Nil + (ex;throw Empty-Input "") + + (#;Cons head tail) + (#R;Success [tail []])))) + +(def: #export (run document reader) + (All [a] (-> XML (Reader a) (R;Result a))) + (run' (list document) reader)) diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux index 73c37d598..c2933ba85 100644 --- a/stdlib/source/lux/math.lux +++ b/stdlib/source/lux/math.lux @@ -99,45 +99,48 @@ (type: #rec Infix (#Const Code) (#Call (List Code)) - (#Infix Infix Code Infix)) - -(def: (infix^ _) - (-> Unit (Syntax Infix)) - ($_ p;alt - ($_ p;either - (p/map code;bool s;bool) - (p/map code;nat s;nat) - (p/map code;int s;int) - (p/map code;deg s;deg) - (p/map code;frac s;frac) - (p/map code;text s;text) - (p/map code;symbol s;symbol) - (p/map code;tag s;tag)) - (s;form (p;many s;any)) - (s;tuple (p;either (do p;Monad<Parser> - [_ (s;this (' #and)) - init-subject (infix^ []) - init-op s;any - init-param (infix^ []) - steps (p;some (p;seq s;any (infix^ [])))] - (wrap (product;right (L/fold (function [[op param] [subject [_subject _op _param]]] - [param [(#Infix _subject _op _param) - (` and) - (#Infix subject op param)]]) - [init-param [init-subject init-op init-param]] - steps)))) - (do p;Monad<Parser> - [_ (wrap []) - init-subject (infix^ []) - init-op s;any - init-param (infix^ []) - steps (p;some (p;seq s;any (infix^ [])))] - (wrap (L/fold (function [[op param] [_subject _op _param]] - [(#Infix _subject _op _param) op param]) - [init-subject init-op init-param] - steps))) - )) - )) + (#Unary Code Infix) + (#Binary Infix Code Infix)) + +(def: infix^ + (Syntax Infix) + (<| p;rec (function [infix^]) + ($_ p;alt + ($_ p;either + (p/map code;bool s;bool) + (p/map code;nat s;nat) + (p/map code;int s;int) + (p/map code;deg s;deg) + (p/map code;frac s;frac) + (p/map code;text s;text) + (p/map code;symbol s;symbol) + (p/map code;tag s;tag)) + (s;form (p;many s;any)) + (s;tuple (p;seq s;any infix^)) + (s;tuple ($_ p;either + (do p;Monad<Parser> + [_ (s;this (' #and)) + init-subject infix^ + init-op s;any + init-param infix^ + steps (p;some (p;seq s;any infix^))] + (wrap (product;right (L/fold (function [[op param] [subject [_subject _op _param]]] + [param [(#Binary _subject _op _param) + (` and) + (#Binary subject op param)]]) + [init-param [init-subject init-op init-param]] + steps)))) + (do p;Monad<Parser> + [init-subject infix^ + init-op s;any + init-param infix^ + steps (p;some (p;seq s;any infix^))] + (wrap (L/fold (function [[op param] [_subject _op _param]] + [(#Binary _subject _op _param) op param]) + [init-subject init-op init-param] + steps))) + )) + ))) (def: (infix-to-prefix infix) (-> Infix Code) @@ -147,15 +150,19 @@ (#Call parts) (code;form parts) + + (#Unary op subject) + (` ((~ op) (~ (infix-to-prefix subject)))) - (#Infix left op right) + (#Binary left op right) (` ((~ op) (~ (infix-to-prefix right)) (~ (infix-to-prefix left)))) )) -(syntax: #export (infix [expr (infix^ [])]) +(syntax: #export (infix [expr infix^]) {#;doc (doc "Infix math syntax." (infix [x i.* 10]) (infix [[x i.+ y] i.* [x i.- y]]) + (infix [sin [x i.+ y]]) (infix [[x n.< y] and [y n.< z]]) (infix [#and x n.< y n.< z]) (infix [(n.* +3 +9) gcd +450]) |