diff options
| -rw-r--r-- | lux-mode/lux-mode.el | 4 | ||||
| -rw-r--r-- | stdlib/source/lux.lux | 65 | ||||
| -rw-r--r-- | stdlib/source/lux/data/coll/ordered/dict.lux | 34 | ||||
| -rw-r--r-- | stdlib/source/lux/meta/poly/eq.lux | 228 |
4 files changed, 191 insertions, 140 deletions
diff --git a/lux-mode/lux-mode.el b/lux-mode/lux-mode.el index 633c42244..da60f5699 100644 --- a/lux-mode/lux-mode.el +++ b/lux-mode/lux-mode.el @@ -227,7 +227,7 @@ Called by `imenu--generic-function'." "function" "case" ":" ":!" ":!!" "undefined" "ident-for" "and" "or" "char" - "exec" "let" "with-expansions" "if" "cond" "do" "be" "open" "loop" "recur" "comment" "for" + "exec" "let" "if" "cond" "do" "be" "open" "loop" "recur" "comment" "for" "list" "list&" "io" "sequence" "tree" "get@" "set@" "update@" "|>" "|>." "<|" "<|." "_$" "$_" "~" "~@" "~'" "::" ":::" "|" "&" "->" "All" "Ex" "Rec" "host" "$" "type" @@ -237,7 +237,7 @@ Called by `imenu--generic-function'." "sig" "struct" "derive" "infix" "format" - "`" "`'" "'" "do-template" + "`" "`'" "'" "do-template" "with-expansions" "``" "~~" "object" "do-to" "synchronized" "class-for" "doc" "regex" diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 205f1a543..fd8948164 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -4556,8 +4556,8 @@ ## => (function [<arg>] (fold text/compose \"\" - (interpose \" \" - (map int/encode <arg>))))"} + (interpose \" \" + (map int/encode <arg>))))"} (do Monad<Meta> [g!arg (gensym "arg")] (return (list (` (function [(~ g!arg)] (|> (~ g!arg) (~@ tokens)))))))) @@ -4568,8 +4568,8 @@ ## => (function [<arg>] (fold text/compose \"\" - (interpose \" \" - (map int/encode <arg>))))"} + (interpose \" \" + (map int/encode <arg>))))"} (do Monad<Meta> [g!arg (gensym "arg")] (return (list (` (function [(~ g!arg)] (<| (~@ tokens) (~ g!arg)))))))) @@ -5906,3 +5906,60 @@ _ (fail "Wrong syntax for 'for'")))) + +(do-template [<name> <type> <output>] + [(def: (<name> xy) + (All [a b] (-> [a b] <type>)) + (let [[x y] xy] + <output>))] + + [left a x] + [right b y]) + +(def: (label-code code) + (-> Code (Meta [(List [Code Code]) Code])) + (case code + (^ [ann (#Form (list [_ (#Symbol ["" "~~"])] expansion))]) + (do Monad<Meta> + [g!expansion (gensym "g!expansion")] + (wrap [(list [g!expansion expansion]) g!expansion])) + + (^template [<tag>] + [ann (<tag> parts)] + (do Monad<Meta> + [=parts (mapM Monad<Meta> label-code parts)] + (wrap [(fold list/compose (list) (map left =parts)) + [ann (<tag> (map right =parts))]]))) + ([#Form] [#Tuple]) + + [ann (#Record kvs)] + (do Monad<Meta> + [=kvs (mapM Monad<Meta> + (function [[key val]] + (do Monad<Meta> + [=key (label-code key) + =val (label-code val) + #let [[key-labels key-labelled] =key + [val-labels val-labelled] =val]] + (wrap [(list/compose key-labels val-labels) [key-labelled val-labelled]]))) + kvs)] + (wrap [(fold list/compose (list) (map left =kvs)) + [ann (#Record (map right =kvs))]])) + + _ + (:: Monad<Meta> wrap [(list) code]))) + +(macro: #export (`` tokens) + (case tokens + (^ (list raw)) + (do Monad<Meta> + [=raw (label-code raw) + #let [[labels labelled] =raw]] + (wrap (list (` (with-expansions [(~@ (|> labels + (map (function [[label expansion]] (list label expansion))) + list/join))] + (~ labelled)))))) + + _ + (fail "Wrong syntax for ``") + )) diff --git a/stdlib/source/lux/data/coll/ordered/dict.lux b/stdlib/source/lux/data/coll/ordered/dict.lux index 21cd20eb8..1151a018b 100644 --- a/stdlib/source/lux/data/coll/ordered/dict.lux +++ b/stdlib/source/lux/data/coll/ordered/dict.lux @@ -251,24 +251,22 @@ (#;Some root) (let [reference (get@ #key root)] - (with-expansions - [<sides> (do-template [<comp> <tag> <add>] - [(<comp> reference key) - (let [side-root (get@ <tag> root) - outcome (recur side-root)] - (if (is side-root outcome) - ?root - (#;Some (<add> (maybe;assume outcome) - root))))] - - [T/< #left add-left] - [T/> #right add-right] - )] - (cond <sides> - - ## (T/= reference key) - ?root - ))) + (`` (cond (~~ (do-template [<comp> <tag> <add>] + [(<comp> reference key) + (let [side-root (get@ <tag> root) + outcome (recur side-root)] + (if (is side-root outcome) + ?root + (#;Some (<add> (maybe;assume outcome) + root))))] + + [T/< #left add-left] + [T/> #right add-right] + )) + + ## (T/= reference key) + ?root + ))) ))] (set@ #root root' dict))) diff --git a/stdlib/source/lux/meta/poly/eq.lux b/stdlib/source/lux/meta/poly/eq.lux index 86a373a4c..c2ecd5988 100644 --- a/stdlib/source/lux/meta/poly/eq.lux +++ b/stdlib/source/lux/meta/poly/eq.lux @@ -30,122 +30,118 @@ ## [Derivers] (poly: #export Eq<?> - (with-expansions - [<basic> (do-template [<matcher> <eq>] - [(do @ - [_ <matcher>] - (wrap (` (: (~ (@Eq inputT)) - <eq>))))] + (`` (do @ + [#let [g!_ (code;local-symbol "\u0000_")] + *env* poly;env + inputT poly;peek + #let [@Eq (: (-> Type Code) + (function [type] + (` (eq;Eq (~ (poly;to-ast *env* type))))))]] + ($_ p;either + ## Primitive types + (~~ (do-template [<matcher> <eq>] + [(do @ + [_ <matcher>] + (wrap (` (: (~ (@Eq inputT)) + <eq>))))] - [poly;unit (function [(~ g!_) (~ g!_)] true)] - [poly;bool bool;Eq<Bool>] - [poly;nat number;Eq<Nat>] - [poly;int number;Eq<Int>] - [poly;deg number;Eq<Deg>] - [poly;frac number;Eq<Frac>] - [poly;text text;Eq<Text>]) - <time> (do-template [<type> <eq>] - [(do @ - [_ (poly;this <type>)] - (wrap (` (: (~ (@Eq inputT)) - <eq>))))] + [poly;unit (function [(~ g!_) (~ g!_)] true)] + [poly;bool bool;Eq<Bool>] + [poly;nat number;Eq<Nat>] + [poly;int number;Eq<Int>] + [poly;deg number;Eq<Deg>] + [poly;frac number;Eq<Frac>] + [poly;text text;Eq<Text>])) + ## Composite types + (~~ (do-template [<name> <eq>] + [(do @ + [[_ argC] (poly;apply (p;seq (poly;this <name>) + Eq<?>))] + (wrap (` (: (~ (@Eq inputT)) + (<eq> (~ argC))))))] - [du;Duration du;Eq<Duration>] - [i;Instant i;Eq<Instant>] - [da;Date da;Eq<Date>] - [da;Day da;Eq<Day>] - [da;Month da;Eq<Month>]) - <composites> (do-template [<name> <eq>] - [(do @ - [[_ argC] (poly;apply (p;seq (poly;this <name>) - Eq<?>))] - (wrap (` (: (~ (@Eq inputT)) - (<eq> (~ argC))))))] + [;Maybe maybe;Eq<Maybe>] + [;List list;Eq<List>] + [sequence;Sequence sequence;Eq<Sequence>] + [;Array array;Eq<Array>] + [queue;Queue queue;Eq<Queue>] + [set;Set set;Eq<Set>] + [rose;Tree rose;Eq<Tree>] + )) + (do @ + [[_ _ valC] (poly;apply ($_ p;seq + (poly;this dict;Dict) + poly;any + Eq<?>))] + (wrap (` (: (~ (@Eq inputT)) + (dict;Eq<Dict> (~ valC)))))) + ## Models + (~~ (do-template [<type> <eq>] + [(do @ + [_ (poly;this <type>)] + (wrap (` (: (~ (@Eq inputT)) + <eq>))))] - [;Maybe maybe;Eq<Maybe>] - [;List list;Eq<List>] - [sequence;Sequence sequence;Eq<Sequence>] - [;Array array;Eq<Array>] - [queue;Queue queue;Eq<Queue>] - [set;Set set;Eq<Set>] - [rose;Tree rose;Eq<Tree>] - )] - (do @ - [#let [g!_ (code;local-symbol "\u0000_")] - *env* poly;env - inputT poly;peek - #let [@Eq (: (-> Type Code) - (function [type] - (` (eq;Eq (~ (poly;to-ast *env* type))))))]] - ($_ p;either - ## Primitive types - <basic> - ## Composite types - <composites> - (do @ - [[_ _ valC] (poly;apply ($_ p;seq - (poly;this dict;Dict) - poly;any - Eq<?>))] - (wrap (` (: (~ (@Eq inputT)) - (dict;Eq<Dict> (~ valC)))))) - ## Models - <time> - (do @ - [_ (poly;apply (p;seq (poly;this unit;Qty) - poly;any))] - (wrap (` (: (~ (@Eq inputT)) - unit;Eq<Qty>)))) - ## Variants - (do @ - [members (poly;variant (p;many Eq<?>)) - #let [g!left (code;local-symbol "\u0000left") - g!right (code;local-symbol "\u0000right")]] - (wrap (` (: (~ (@Eq inputT)) - (function [(~ g!left) (~ g!right)] - (case [(~ g!left) (~ g!right)] - (~@ (list/join (list/map (function [[tag g!eq]] - (list (` [((~ (code;nat tag)) (~ g!left)) - ((~ (code;nat tag)) (~ g!right))]) - (` ((~ g!eq) (~ g!left) (~ g!right))))) - (list;enumerate members)))) - (~ g!_) - false)))))) - ## Tuples - (do @ - [g!eqs (poly;tuple (p;many Eq<?>)) - #let [indices (|> (list;size g!eqs) n.dec (list;n.range +0)) - g!lefts (list/map (|>. nat/encode (text/compose "left") code;local-symbol) indices) - g!rights (list/map (|>. nat/encode (text/compose "right") code;local-symbol) indices)]] - (wrap (` (: (~ (@Eq inputT)) - (function [[(~@ g!lefts)] [(~@ g!rights)]] - (and (~@ (|> (list;zip3 g!eqs g!lefts g!rights) - (list/map (function [[g!eq g!left g!right]] - (` ((~ g!eq) (~ g!left) (~ g!right))))))))))))) - ## Type recursion - (do @ - [[g!self bodyC] (poly;recursive Eq<?>)] - (wrap (` (: (~ (@Eq inputT)) - (eq;rec (;function [(~ g!self)] - (~ bodyC))))))) - poly;recursive-self - ## Type applications - (do @ - [[funcC argsC] (poly;apply (p;seq Eq<?> (p;many Eq<?>)))] - (wrap (` ((~ funcC) (~@ argsC))))) - ## Bound type-vars - poly;bound - ## Polymorphism - (do @ - [[funcC varsC bodyC] (poly;polymorphic Eq<?>)] - (wrap (` (: (All [(~@ varsC)] - (-> (~@ (list/map (|>. (~) eq;Eq (`)) varsC)) - (eq;Eq ((~ (poly;to-ast *env* inputT)) (~@ varsC))))) - (function (~ funcC) [(~@ varsC)] - (~ bodyC)))))) - poly;recursive-call - ## If all else fails... - (|> poly;any - (:: @ map (|>. %type (format "Cannot create Eq for: ") p;fail)) - (:: @ join)) - )))) + [du;Duration du;Eq<Duration>] + [i;Instant i;Eq<Instant>] + [da;Date da;Eq<Date>] + [da;Day da;Eq<Day>] + [da;Month da;Eq<Month>])) + (do @ + [_ (poly;apply (p;seq (poly;this unit;Qty) + poly;any))] + (wrap (` (: (~ (@Eq inputT)) + unit;Eq<Qty>)))) + ## Variants + (do @ + [members (poly;variant (p;many Eq<?>)) + #let [g!left (code;local-symbol "\u0000left") + g!right (code;local-symbol "\u0000right")]] + (wrap (` (: (~ (@Eq inputT)) + (function [(~ g!left) (~ g!right)] + (case [(~ g!left) (~ g!right)] + (~@ (list/join (list/map (function [[tag g!eq]] + (list (` [((~ (code;nat tag)) (~ g!left)) + ((~ (code;nat tag)) (~ g!right))]) + (` ((~ g!eq) (~ g!left) (~ g!right))))) + (list;enumerate members)))) + (~ g!_) + false)))))) + ## Tuples + (do @ + [g!eqs (poly;tuple (p;many Eq<?>)) + #let [indices (|> (list;size g!eqs) n.dec (list;n.range +0)) + g!lefts (list/map (|>. nat/encode (text/compose "left") code;local-symbol) indices) + g!rights (list/map (|>. nat/encode (text/compose "right") code;local-symbol) indices)]] + (wrap (` (: (~ (@Eq inputT)) + (function [[(~@ g!lefts)] [(~@ g!rights)]] + (and (~@ (|> (list;zip3 g!eqs g!lefts g!rights) + (list/map (function [[g!eq g!left g!right]] + (` ((~ g!eq) (~ g!left) (~ g!right))))))))))))) + ## Type recursion + (do @ + [[g!self bodyC] (poly;recursive Eq<?>)] + (wrap (` (: (~ (@Eq inputT)) + (eq;rec (;function [(~ g!self)] + (~ bodyC))))))) + poly;recursive-self + ## Type applications + (do @ + [[funcC argsC] (poly;apply (p;seq Eq<?> (p;many Eq<?>)))] + (wrap (` ((~ funcC) (~@ argsC))))) + ## Bound type-vars + poly;bound + ## Polymorphism + (do @ + [[funcC varsC bodyC] (poly;polymorphic Eq<?>)] + (wrap (` (: (All [(~@ varsC)] + (-> (~@ (list/map (|>. (~) eq;Eq (`)) varsC)) + (eq;Eq ((~ (poly;to-ast *env* inputT)) (~@ varsC))))) + (function (~ funcC) [(~@ varsC)] + (~ bodyC)))))) + poly;recursive-call + ## If all else fails... + (|> poly;any + (:: @ map (|>. %type (format "Cannot create Eq for: ") p;fail)) + (:: @ join)) + )))) |