diff options
Diffstat (limited to 'source/lux.lux')
-rw-r--r-- | source/lux.lux | 220 |
1 files changed, 116 insertions, 104 deletions
diff --git a/source/lux.lux b/source/lux.lux index 36a0997f4..7110cc709 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1010,14 +1010,14 @@ (`' (;let' (~ value) (~ body'))) _ - (`' (;bind (_lux_lambda (~ (symbol$ ["" ""])) - (~ var) - (~ body')) - (~ value))))))) + (`' (bind (_lux_lambda (~ (symbol$ ["" ""])) + (~ var) + (~ body')) + (~ value))))))) body (reverse (as-pairs bindings)))] (return (list (`' (_lux_case (~ monad) - {#;return ;return #;bind ;bind} + {#;return wrap #;bind bind} (~ body')))))) _ @@ -1031,16 +1031,16 @@ (-> (B' a) ($' (B' m) (B' b))) ($' List (B' a)) ($' (B' m) ($' List (B' b))))) - (let' [{#;return ;return #;bind _} m] + (let' [{#;return wrap #;bind _} m] (_lux_case xs #Nil - (;return #Nil) + (wrap #Nil) (#Cons [x xs']) (do m [y (f x) ys (map% m f xs')] - (;return (#Cons [y ys]))) + (wrap (#Cons [y ys]))) ))) (def''' (. f g) @@ -1373,7 +1373,7 @@ ["" name] (do Lux/Monad [module-name get-module-name] - (;return (_lux_: Ident [module-name name]))) + (wrap (_lux_: Ident [module-name name]))) _ (return ident))) @@ -1387,7 +1387,7 @@ (#Meta [_ (#TagS ident)]) (do Lux/Monad [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) + (wrap (`' [(~ (text$ (ident->text ident))) (;,)]))) (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) values]))]) (do Lux/Monad @@ -1397,12 +1397,12 @@ #Nil (`' Unit) (#Cons value #Nil) value _ (`' (, (~@ values)))))]] - (;return (`' [(~ (text$ (ident->text ident))) (~ case-body)]))) + (wrap (`' [(~ (text$ (ident->text ident))) (~ case-body)]))) _ (fail "Wrong syntax for |")))) tokens)] - (;return (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) + (wrap (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) (defmacro #export (& tokens) (if (not (multiple? 2 (length tokens))) @@ -1415,12 +1415,12 @@ [(#Meta [_ (#TagS ident)]) value] (do Lux/Monad [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) + (wrap (`' [(~ (text$ (ident->text ident))) (~ value)]))) _ (fail "Wrong syntax for &")))) (as-pairs tokens))] - (;return (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) + (wrap (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) (def''' (->text x) (-> (^ java.lang.Object) Text) @@ -1451,7 +1451,7 @@ (do Lux/Monad [expansion (macro args) expansion' (map% Lux/Monad macro-expand expansion)] - (;return (list:join expansion'))) + (wrap (list:join expansion'))) #None (return (list token)))) @@ -1471,23 +1471,23 @@ (do Lux/Monad [expansion (macro args) expansion' (map% Lux/Monad macro-expand-all expansion)] - (;return (list:join expansion'))) + (wrap (list:join expansion'))) #None (do Lux/Monad [parts' (map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] - (;return (list (form$ (list:join parts'))))))) + (wrap (list (form$ (list:join parts'))))))) (#Meta [_ (#FormS (#Cons [harg targs]))]) (do Lux/Monad [harg+ (macro-expand-all harg) targs+ (map% Lux/Monad macro-expand-all targs)] - (;return (list (form$ (list:++ harg+ (list:join targs+)))))) + (wrap (list (form$ (list:++ harg+ (list:join targs+)))))) (#Meta [_ (#TupleS members)]) (do Lux/Monad [members' (map% Lux/Monad macro-expand-all members)] - (;return (list (tuple$ (list:join members'))))) + (wrap (list (tuple$ (list:join members'))))) _ (return (list syntax)))) @@ -1516,7 +1516,7 @@ [type+ (macro-expand-all type)] (_lux_case type+ (#Cons type' #Nil) - (;return (list (walk-type type'))) + (wrap (list (walk-type type'))) _ (fail "The expansion of the type-syntax had to yield a single element."))) @@ -1718,13 +1718,13 @@ (do Lux/Monad [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) expansions (map% Lux/Monad expander (as-pairs expansion))] - (;return (list:join expansions))) + (wrap (list:join expansions))) _ - (;return (list branch)))))) + (wrap (list branch)))))) (as-pairs branches))] - (;return (list (`' (_lux_case (~ value) - (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) + (wrap (list (`' (_lux_case (~ value) + (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) _ (fail "Wrong syntax for case"))) @@ -1736,7 +1736,7 @@ [pattern+ (macro-expand-all pattern)] (case pattern+ (#Cons pattern' #Nil) - (;return (list pattern' body)) + (wrap (list pattern' body)) _ (fail "\\ can only expand to 1 pattern."))) @@ -1754,8 +1754,8 @@ _ (do Lux/Monad [patterns' (map% Lux/Monad macro-expand-all patterns)] - (;return (list:join (map (lambda' [pattern] (list pattern body)) - (list:join patterns')))))) + (wrap (list:join (map (lambda' [pattern] (list pattern body)) + (list:join patterns')))))) _ (fail "Wrong syntax for \\or"))) @@ -1765,7 +1765,7 @@ [module-name get-module-name] (case tokens (\ (list template)) - (;return (list (untemplate true module-name template))) + (wrap (list (untemplate true module-name template))) _ (fail "Wrong syntax for `")))) @@ -1849,13 +1849,13 @@ (let [g!blank (symbol$ ["" ""]) g!name (symbol$ ident) body+ (: AST (foldL (: (-> AST AST AST) - (lambda' [body' arg] - (if (symbol? arg) - (` (_lux_lambda (~ g!blank) (~ arg) (~ body'))) - (` (_lux_lambda (~ g!blank) (~ g!blank) - (case (~ g!blank) (~ arg) (~ body'))))))) - body - (reverse tail)))] + (lambda' [body' arg] + (if (symbol? arg) + (` (_lux_lambda (~ g!blank) (~ arg) (~ body'))) + (` (_lux_lambda (~ g!blank) (~ g!blank) + (case (~ g!blank) (~ arg) (~ body'))))))) + body + (reverse tail)))] (return (list (if (symbol? head) (` (_lux_lambda (~ g!name) (~ head) (~ body+))) (` (_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) @@ -1922,7 +1922,7 @@ #envs envs #types types #host host #seed (i+ 1 seed) #eval? eval? #expected expected #cursor cursor} - (symbol$ ["__gensym__" (->text seed)])))) + (symbol$ ["" ($ text:++ "__gensym__" prefix (->text seed))])))) (defmacro #export (sig tokens) (do Lux/Monad @@ -1934,17 +1934,17 @@ (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS name)))))) (do Lux/Monad [name' (normalize name)] - (;return (: (, Ident AST) [name' type]))) + (wrap (: (, Ident AST) [name' type]))) _ (fail "Signatures require typed members!")))) (list:join tokens'))] - (;return (list (` (#;RecordT (~ (untemplate-list (map (: (-> (, Ident AST) AST) - (lambda [pair] - (let [[name type] pair] - (` [(~ (|> name ident->text text$)) - (~ type)])))) - members))))))))) + (wrap (list (` (#;RecordT (~ (untemplate-list (map (: (-> (, Ident AST) AST) + (lambda [pair] + (let [[name type] pair] + (` [(~ (|> name ident->text text$)) + (~ type)])))) + members))))))))) (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List AST)) @@ -2216,7 +2216,7 @@ (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS ["" name])) value)))) (case (get name translations) (#Some tag-name) - (;return (: (, AST AST) [(tag$ tag-name) value])) + (wrap (: (, AST AST) [(tag$ tag-name) value])) _ (fail "Structures require defined members")) @@ -2224,7 +2224,7 @@ _ (fail "Structures members must be unqualified.")))) (list:join tokens'))] - (;return (list (record$ members)))) + (wrap (list (record$ members)))) _ (fail "struct can only use records.")))) @@ -2384,7 +2384,7 @@ (lambda [token] (case token (#Meta _ (#SymbolS "" m-name)) - (;return (list [m-name #None #All #None])) + (wrap (list [m-name #None #All #None])) (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" m-name)) extra)))) (do Lux/Monad @@ -2396,14 +2396,14 @@ #let [[openings extra] openings+extra] extra (decorate-imports m-name extra) sub-imports (parse-imports extra)] - (;return (case (: (, Referrals (Maybe Text) (Maybe Openings)) [referral alias openings]) - [#Nothing #None #None] sub-imports - _ (list& [m-name alias referral openings] sub-imports)))) + (wrap (case (: (, Referrals (Maybe Text) (Maybe Openings)) [referral alias openings]) + [#Nothing #None #None] sub-imports + _ (list& [m-name alias referral openings] sub-imports)))) _ (fail "Wrong syntax for import")))) imports)] - (;return (list:join imports')))) + (wrap (list:join imports')))) (def (module-exists? module state) (-> Text (Lux Bool)) @@ -2527,7 +2527,7 @@ [m-name m-alias m-referrals m-openings] (do Lux/Monad [m-name (clean-module m-name)] - (;return (: Import [m-name m-alias m-referrals m-openings])))))) + (wrap (: Import [m-name m-alias m-referrals m-openings])))))) imports) unknowns' (map% Lux/Monad (: (-> Import (Lux (List Text))) @@ -2536,9 +2536,9 @@ [m-name _ _ _] (do Lux/Monad [? (module-exists? m-name)] - (;return (if ? - (list) - (list m-name))))))) + (wrap (if ? + (list) + (list m-name))))))) imports) #let [unknowns (list:join unknowns')]] (case unknowns @@ -2557,15 +2557,15 @@ (#Only +defs) (do Lux/Monad [*defs (exported-defs m-name)] - (;return (filter (is-member? +defs) *defs))) + (wrap (filter (is-member? +defs) *defs))) (#Exclude -defs) (do Lux/Monad [*defs (exported-defs m-name)] - (;return (filter (. not (is-member? -defs)) *defs))) + (wrap (filter (. not (is-member? -defs)) *defs))) #Nothing - (;return (list))) + (wrap (list))) #let [openings (: (List AST) (case m-openings #None @@ -2577,24 +2577,24 @@ (let [[_ name] struct] (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) structs)))]] - (;return ($ list:++ - (list (` (_lux_import (~ (text$ m-name))))) - (case m-alias - #None (list) - (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) - (map (: (-> Text AST) - (lambda [def] - (` (_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) - defs) - openings)))))) + (wrap ($ list:++ + (list (` (_lux_import (~ (text$ m-name))))) + (case m-alias + #None (list) + (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) + (map (: (-> Text AST) + (lambda [def] + (` (_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) + defs) + openings)))))) imports)] - (;return (list:join output'))) + (wrap (list:join output'))) _ - (;return (: (List AST) - (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) - unknowns) - (list (` (import (~@ tokens)))))))))) + (wrap (: (List AST) + (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) + unknowns) + (list (` (import (~@ tokens)))))))))) (def (try-both f x1 x2) (All [a b] @@ -2604,26 +2604,25 @@ (#;Some y) (#;Some y))) (def (find-in-env name state) - (-> Ident Compiler (Maybe Type)) - (let [vname' (ident->text name)] - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) - (lambda [env] - (case env - {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} - (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= vname' bname) - (#Some type) - #None))))) - locals - closure)))) - envs)))) + (-> Text Compiler (Maybe Type)) + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} + (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) + (lambda [env] + (case env + {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} + (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (lambda [binding] + (let [[bname [_ type]] binding] + (if (text:= name bname) + (#Some type) + #None))))) + locals + closure)))) + envs))) (def (show-envs envs) (-> (List (Env Text (, LuxVar Type))) Text) @@ -2675,22 +2674,34 @@ ## def (get v-name defs) ## #let [[_ def-data] def]] ## (case def-data -## #TypeD (;return Type) -## (#ValueD type) (;return type) -## (#MacroD m) (;return Macro) +## #TypeD (wrap Type) +## (#ValueD type) (wrap type) +## (#MacroD m) (wrap Macro) ## (#AliasD name') (find-in-defs name' state)))))) -(def (find-var-type name) +(def (find-var-type ident) (-> Ident (Lux Type)) (do Lux/Monad - [name' (normalize name)] + [#let [[module name] ident] + current-module get-module-name] (lambda [state] - (case (find-in-env name state) - (#Some struct-type) - (#Right state struct-type) + (if (text:= "" module) + (case (find-in-env name state) + (#Some struct-type) + (#Right state struct-type) - _ - (case (find-in-defs name' state) + _ + (case (find-in-defs [current-module name] state) + (#Some struct-type) + (#Right state struct-type) + + _ + (let [{#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} state] + (#Left ($ text:++ "Unknown var: " (ident->text ident) "\n\n" (show-envs envs)))))) + (case (find-in-defs ident state) (#Some struct-type) (#Right state struct-type) @@ -2699,7 +2710,8 @@ #envs envs #types types #host host #seed seed #eval? eval? #expected expected #cursor cursor} state] - (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))) + (#Left ($ text:++ "Unknown var: " (ident->text ident) "\n\n" (show-envs envs)))))) + ))) (def (use-field field-name type) (-> Text Type (, AST AST)) @@ -2982,7 +2994,7 @@ (lambda [env] (map (apply-template env) templates)))] (|> data' (join-map (. apply (make-env bindings'))) - ;return)))) + wrap)))) (#Some output) (return output) |