From 7abfef5e4a61fb8b98fdbcedff0732442e50677b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 17 Apr 2019 19:37:20 -0400 Subject: - Made the "open:" and "^open" macros not generate record-patterns, and thus not need (or impose a need on) tags. - The "do" macro for monads also doesn't need tags anymore. --- stdlib/source/lux.lux | 100 +++++++++++++++++++++++++++++--------------------- 1 file changed, 58 insertions(+), 42 deletions(-) (limited to 'stdlib/source/lux.lux') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 1a3d71480..6fe8100ba 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -447,6 +447,11 @@ ([_ name] (_ann (#Tag name)))) [dummy-cursor (#Record #Nil)]) +("lux def" local-tag$ + ("lux check" (#Function Text Code) + ([_ name] (_ann (#Tag ["" name])))) + [dummy-cursor (#Record #Nil)]) + ("lux def" form$ ("lux check" (#Function (#Apply Code List) Code) ([_ tokens] (_ann (#Form tokens)))) @@ -1008,7 +1013,7 @@ (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil))) (return (#Cons (form$ (#Cons (identifier$ ["lux" "def:''"]) - (#Cons (tag$ ["" "export"]) + (#Cons (local-tag$ "export") (#Cons (form$ (#Cons name args)) (#Cons (with-macro-meta (tag$ ["lux" "Nil"])) (#Cons (identifier$ ["lux" "Macro"]) @@ -1019,7 +1024,7 @@ (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons meta-data (#Cons body #Nil)))) (return (#Cons (form$ (#Cons (identifier$ ["lux" "def:''"]) - (#Cons (tag$ ["" "export"]) + (#Cons (local-tag$ "export") (#Cons (form$ (#Cons name args)) (#Cons (with-macro-meta meta-data) (#Cons (identifier$ ["lux" "Macro"]) @@ -1424,10 +1429,10 @@ (fail "function' requires a non-empty arguments tuple.") (#Cons [harg targs]) - (return (list (form$ (list (tuple$ (list (identifier$ ["" name]) + (return (list (form$ (list (tuple$ (list (local-identifier$ name) harg)) (list@fold (function'' [arg body'] - (form$ (list (tuple$ (list (identifier$ ["" ""]) + (form$ (list (tuple$ (list (local-identifier$ "") arg)) body'))) body @@ -1674,8 +1679,8 @@ (macro:' (do tokens) ({(#Cons monad (#Cons [_ (#Tuple bindings)] (#Cons body #Nil))) - (let' [g!wrap (identifier$ ["" "wrap"]) - g!bind (identifier$ ["" " bind "]) + (let' [g!wrap (local-identifier$ "wrap") + g!bind (local-identifier$ " bind ") body' (list@fold ("lux check" (-> (& Code Code) Code Code) (function' [binding body'] (let' [[var value] binding] @@ -1684,7 +1689,7 @@ _ (form$ (list g!bind - (form$ (list (tuple$ (list (identifier$ ["" ""]) var)) body')) + (form$ (list (tuple$ (list (local-identifier$ "") var)) body')) value))} var)))) body @@ -2948,7 +2953,7 @@ #seed (n/+ 1 seed) #expected expected #cursor cursor #extensions extensions #scope-type-vars scope-type-vars} - (identifier$ ["" ($_ text@compose "__gensym__" prefix (nat@encode seed))]))} + (local-identifier$ ($_ text@compose "__gensym__" prefix (nat@encode seed))))} state)) (macro:' #export (Rec tokens) @@ -2976,7 +2981,7 @@ " " "(log! ''#3'')" ..new-line "''YOLO'')"))]) ({(#Cons value actions) - (let' [dummy (identifier$ ["" ""])] + (let' [dummy (local-identifier$ "")] (return (list (list@fold ("lux check" (-> Code Code Code) (function' [pre post] (` ({(~ dummy) (~ post)} (~ pre))))) @@ -3250,8 +3255,8 @@ _ #None)) (#Some g!name head tail body) - (let [g!blank (identifier$ ["" ""]) - g!name (identifier$ ["" g!name]) + (let [g!blank (local-identifier$ "") + g!name (local-identifier$ g!name) body+ (list@fold (: (-> Code Code Code) (function' [arg body'] (if (identifier? arg) @@ -3535,7 +3540,7 @@ def-name (identifier$ name) sig-type (record$ (list@map (: (-> [Text Code] [Code Code]) (function (_ [m-name m-type]) - [(tag$ ["" m-name]) m-type])) + [(local-tag$ m-name) m-type])) members)) sig-meta (meta-code-merge (` {#.sig? #1}) meta) @@ -3998,7 +4003,7 @@ (do meta-monad [type+tags?? (unfold-type-def type-codes) module-name current-module-name] - (let [type-name (identifier$ ["" name]) + (let [type-name (local-identifier$ name) [type tags??] type+tags?? type-meta (: Code (case tags?? @@ -4011,8 +4016,8 @@ type' (: (Maybe Code) (if rec? (if (empty? args) - (let [g!param (identifier$ ["" ""]) - prime-name (identifier$ ["" name]) + (let [g!param (local-identifier$ "") + prime-name (local-identifier$ name) type+ (replace-syntax (list [name (` ((~ prime-name) .Nothing))]) type)] (#Some (` ((All (~ prime-name) [(~ g!param)] (~ type+)) .Nothing)))) @@ -4572,25 +4577,25 @@ (do meta-monad [full-body ((: (-> Name [(List Name) (List Type)] Code (Meta Code)) (function (recur source [tags members] target) - (let [pattern (record$ (list@map (function (_ [t-module t-name]) - [(tag$ [t-module t-name]) - (identifier$ ["" (de-alias "" t-name alias)])]) - tags))] + (let [locals (list@map (function (_ [t-module t-name]) + ["" (de-alias "" t-name alias)]) + tags) + pattern (tuple$ (list@map identifier$ locals))] (do meta-monad [enhanced-target (monad/fold meta-monad - (function (_ [[_ m-name] m-type] enhanced-target) + (function (_ [m-local m-type] enhanced-target) (do meta-monad [m-structure (resolve-type-tags m-type)] (case m-structure (#Some m-tags&members) - (recur ["" (de-alias "" m-name alias)] + (recur m-local m-tags&members enhanced-target) #None (wrap enhanced-target)))) target - (zip2 tags members))] + (zip2 locals members))] (wrap (` ({(~ pattern) (~ enhanced-target)} (~ (identifier$ source))))))))) name tags&members body)] (wrap (list full-body))))) @@ -4682,22 +4687,32 @@ _ (fail "Wrong syntax for get@"))) -(def: (open-field alias [module name] source type) - (-> Text Name Code Type (Meta (List Code))) +(def: (open-field alias tags my-tag-index [module short] source type) + (-> Text (List Name) Nat Name Code Type (Meta (List Code))) (do meta-monad [output (resolve-type-tags type) - #let [source+ (` (get@ (~ (tag$ [module name])) (~ source)))]] + g!_ (gensym "g!_") + #let [g!output (local-identifier$ short) + pattern (|> tags + enumerate + (list@map (function (_ [tag-idx tag]) + (if (n/= my-tag-index tag-idx) + g!output + g!_))) + tuple$) + source+ (` ({(~ pattern) (~ g!output)} (~ source)))]] (case output - (#Some [tags members]) + (#Some [tags' members']) (do meta-monad [decls' (monad@map meta-monad - (: (-> [Name Type] (Meta (List Code))) - (function (_ [sname stype]) (open-field alias sname source+ stype))) - (zip2 tags members))] + (: (-> [Nat Name Type] (Meta (List Code))) + (function (_ [sub-tag-index sname stype]) + (open-field alias tags' sub-tag-index sname source+ stype))) + (enumerate (zip2 tags' members')))] (return (list@join decls'))) _ - (return (list (` ("lux def" (~ (identifier$ ["" (de-alias "" name alias)])) + (return (list (` ("lux def" (~ (local-identifier$ (de-alias "" short alias))) (~ source+) [(~ cursor-code) (#.Record #Nil)]))))))) @@ -4724,10 +4739,10 @@ (case output (#Some [tags members]) (do meta-monad - [decls' (monad@map meta-monad (: (-> [Name Type] (Meta (List Code))) - (function (_ [sname stype]) - (open-field alias sname source stype))) - (zip2 tags members))] + [decls' (monad@map meta-monad (: (-> [Nat Name Type] (Meta (List Code))) + (function (_ [tag-index sname stype]) + (open-field alias tags tag-index sname source stype))) + (enumerate (zip2 tags members)))] (return (list@join decls'))) _ @@ -4837,7 +4852,7 @@ (wrap (list))) #let [defs (list@map (: (-> Text Code) (function (_ def) - (` ("lux def alias" (~ (identifier$ ["" def])) (~ (identifier$ [module-name def])))))) + (` ("lux def alias" (~ (local-identifier$ def)) (~ (identifier$ [module-name def])))))) defs') openings (join-map (: (-> Openings (List Code)) (function (_ [alias structs]) @@ -5400,7 +5415,7 @@ (#.Some [name bindings body]) (^ (list [_ (#Tuple bindings)] body)) - (#.Some [(identifier$ ["" "recur"]) bindings body]) + (#.Some [(local-identifier$ "recur") bindings body]) _ #.None)] @@ -5460,7 +5475,8 @@ g!_ (gensym "_") #let [[idx tags exported? type] output slot-pairings (list@map (: (-> Name [Text Code]) - (function (_ [module name]) [name (identifier$ ["" name])])) + (function (_ [module name]) + [name (local-identifier$ name)])) (list& hslot tslots)) pattern (record$ (list@map (: (-> Name [Code Code]) (function (_ [module name]) @@ -5819,7 +5835,7 @@ (to-list set))))} (case tokens (^ (list& [_meta (#Form (list [_ (#Identifier ["" name])] pattern))] body branches)) - (let [g!whole (identifier$ ["" name])] + (let [g!whole (local-identifier$ name)] (return (list& g!whole (` (case (~ g!whole) (~ pattern) (~ body))) branches))) @@ -5834,7 +5850,7 @@ (foo value)))} (case tokens (^ (list& [_meta (#Form (list [_ (#Identifier ["" name])] [_ (#Tuple steps)]))] body branches)) - (let [g!name (identifier$ ["" name])] + (let [g!name (local-identifier$ name)] (return (list& g!name (` (let [(~ g!name) (|> (~ g!name) (~+ steps))] (~ body))) @@ -5974,14 +5990,14 @@ g!compiler (gensym "compiler") g!_ (gensym "_") #let [rep-env (list@map (function (_ arg) - [arg (` ((~' ~) (~ (identifier$ ["" arg]))))]) + [arg (` ((~' ~) (~ (local-identifier$ arg))))]) args)] this-module current-module-name] (wrap (list (` (macro: (~+ (export export?)) - ((~ (identifier$ ["" name])) (~ g!tokens) (~ g!compiler)) + ((~ (local-identifier$ name)) (~ g!tokens) (~ g!compiler)) (~ anns) (case (~ g!tokens) - (^ (list (~+ (list@map (|>> [""] identifier$) args)))) + (^ (list (~+ (list@map local-identifier$ args)))) (#.Right [(~ g!compiler) (list (~+ (list@map (function (_ template) (` (`' (~ (replace-syntax rep-env template))))) -- cgit v1.2.3