From 24cc40e76f83188688ad43c499a44508e1aa5d60 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 5 Aug 2015 20:21:04 -0400 Subject: - Local vars can now longer have prefixed symbols. --- source/lux.lux | 220 +++++++++++++++++++++++-------------------- source/lux/codata/stream.lux | 2 +- source/lux/control/monad.lux | 15 +-- source/lux/data/text.lux | 2 +- source/lux/host/jvm.lux | 16 ++-- source/lux/meta/lux.lux | 16 ++-- source/lux/meta/syntax.lux | 20 ++-- src/lux/analyser.clj | 18 ++-- src/lux/analyser/case.clj | 7 +- src/lux/analyser/host.clj | 17 ++-- src/lux/analyser/lambda.clj | 24 ++--- src/lux/analyser/lux.clj | 167 ++++++++++++++++---------------- 12 files changed, 270 insertions(+), 254 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) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 871c50821..728adc174 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -132,4 +132,4 @@ (do List/Monad [pattern (l;reverse patterns)] (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]] - (M;wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) + (wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index 53ab7301b..c87c4fdc3 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -9,7 +9,8 @@ (;import lux (.. (functor #as F) (monoid #as M)) - lux/meta/macro) + (lux/meta macro + ast)) ## [Utils] (def (foldL f init xs) @@ -54,7 +55,9 @@ (case tokens ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) - (let [body' (foldL (: (-> AST (, AST AST) AST) + (let [g!map (symbol$ ["" " map "]) + g!join (symbol$ ["" " join "]) + body' (foldL (: (-> AST (, AST AST) AST) (lambda [body' binding] (let [[var value] binding] (case var @@ -62,15 +65,13 @@ (` (;let (~ value) (~ body'))) _ - (` (;case ;;_functor - {#F;map F;map} - (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join)))) + (` (;|> (~ value) ((~ g!map) (;lambda [(~ var)] (~ body'))) (~ g!join))) ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join))) )))) body (reverse (as-pairs bindings)))] (#;Right [state (#;Cons [(` (;case (~ monad) - {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} + {#;;_functor {#F;map (~ g!map)} #;;wrap (~ (' wrap)) #;;join (~ g!join)} (~ body'))) #;Nil])])) @@ -95,5 +96,5 @@ (do m [y (f x) ys (map% m f xs')] - (;;wrap (#;Cons [y ys]))) + (wrap (#;Cons [y ys]))) )) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index f691be397..81a642698 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -155,7 +155,7 @@ post-idx (index-of "}" in) [var post] (split post-idx in) [_ post] (split 1 post)] - (M;wrap [pre var post]))) + (wrap [pre var post]))) (def (unravel-template template) (-> Text (List AST)) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index f136bd73b..4f3d6df8a 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -24,7 +24,7 @@ (form^ (do Parser/Monad [_ (symbol?^ ["" "finally"]) expr id^] - (M;wrap expr)))) + (wrap expr)))) (def catch^ (Parser (, Text Ident AST)) @@ -33,7 +33,7 @@ ex-class local-symbol^ ex symbol^ expr id^] - (M;wrap [ex-class ex expr])))) + (wrap [ex-class ex expr])))) (def method-decl^ (Parser (, (List Text) Text (List Text) Text)) @@ -42,7 +42,7 @@ name local-symbol^ inputs (tuple^ (*^ local-symbol^)) output local-symbol^] - (M;wrap [modifiers name inputs output])))) + (wrap [modifiers name inputs output])))) (def field-decl^ (Parser (, (List Text) Text Text)) @@ -50,14 +50,14 @@ [modifiers (*^ local-tag^) name local-symbol^ class local-symbol^] - (M;wrap [modifiers name class])))) + (wrap [modifiers name class])))) (def arg-decl^ (Parser (, Text Text)) (form^ (do Parser/Monad [arg-name local-symbol^ arg-class local-symbol^] - (M;wrap [arg-name arg-class])))) + (wrap [arg-name arg-class])))) (def method-def^ (Parser (, (List Text) Text (List (, Text Text)) Text AST)) @@ -67,7 +67,7 @@ inputs (tuple^ (*^ arg-decl^)) output local-symbol^ body id^] - (M;wrap [modifiers name inputs output body])))) + (wrap [modifiers name inputs output body])))) (def method-call^ (Parser (, Text (List Text) (List AST))) @@ -78,9 +78,9 @@ _ (: (Parser (,)) (if (i= (size arity-classes) (size arity-args)) - (M;wrap []) + (wrap []) (lambda [_] #;None)))] - (M;wrap [method arity-classes arity-args]) + (wrap [method arity-classes arity-args]) ))) ## [Syntax] diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 4d6c15bde..d1bc4e219 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -114,7 +114,7 @@ ["" name] (do Lux/Monad [module-name get-module-name] - (M;wrap (: Ident [module-name name]))) + (wrap (: Ident [module-name name]))) _ (:: Lux/Monad (M;wrap ident)))) @@ -131,7 +131,7 @@ (do Lux/Monad [expansion (macro args) expansion' (M;map% Lux/Monad macro-expand expansion)] - (M;wrap (:: List/Monad (M;join expansion')))) + (wrap (:: List/Monad (M;join expansion')))) #;None (:: Lux/Monad (M;wrap (list syntax))))) @@ -151,23 +151,23 @@ (do Lux/Monad [expansion (macro args) expansion' (M;map% Lux/Monad macro-expand-all expansion)] - (M;wrap (:: List/Monad (M;join expansion')))) + (wrap (:: List/Monad (M;join expansion')))) #;None (do Lux/Monad [parts' (M;map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] - (M;wrap (list (form$ (:: List/Monad (M;join parts')))))))) + (wrap (list (form$ (:: List/Monad (M;join parts')))))))) (#;Meta [_ (#;FormS (#;Cons [harg targs]))]) (do Lux/Monad [harg+ (macro-expand-all harg) targs+ (M;map% Lux/Monad macro-expand-all targs)] - (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List AST)) targs+)))))))) + (wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List AST)) targs+)))))))) (#;Meta [_ (#;TupleS members)]) (do Lux/Monad [members' (M;map% Lux/Monad macro-expand-all members)] - (M;wrap (list (tuple$ (:: List/Monad (M;join members')))))) + (wrap (list (tuple$ (:: List/Monad (M;join members')))))) _ (:: Lux/Monad (M;wrap (list syntax))))) @@ -175,7 +175,7 @@ (def #export (gensym prefix state) (-> Text (Lux AST)) (#;Right [(update@ #;seed (i+ 1) state) - (symbol$ ["__gensym__" (:: I;Int/Show (S;show (get@ #;seed state)))])])) + (symbol$ ["" ($ text:++ "__gensym__" prefix (:: I;Int/Show (S;show (get@ #;seed state))))])])) (def #export (emit datum) (All [a] @@ -195,7 +195,7 @@ [token+ (macro-expand token)] (case token+ (\ (list token')) - (M;wrap token') + (wrap token') _ (fail "Macro expanded to more than 1 element.")))) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index a69a89cb3..f1644cdb5 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -166,7 +166,7 @@ #;None (#;Some [tokens (list)]) (#;Some [tokens' x]) (run-parser (do Parser/Monad [xs (*^ p)] - (M;wrap (list& x xs))) + (wrap (list& x xs))) tokens'))) (def #export (+^ p) @@ -175,7 +175,7 @@ (do Parser/Monad [x p xs (*^ p)] - (M;wrap (list& x xs)))) + (wrap (list& x xs)))) (def #export (&^ p1 p2) (All [a b] @@ -183,7 +183,7 @@ (do Parser/Monad [x1 p1 x2 p2] - (M;wrap [x1 x2]))) + (wrap [x1 x2]))) (def #export (|^ p1 p2 tokens) (All [a b] @@ -192,7 +192,7 @@ (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) #;None (run-parser (do Parser/Monad [x2 p2] - (M;wrap (#;Right x2))) + (wrap (#;Right x2))) tokens))) (def #export (||^ ps tokens) @@ -230,10 +230,10 @@ (case arg (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) parser))])) - (M;wrap [(symbol$ var-name) parser]) + (wrap [(symbol$ var-name) parser]) (\ (#;Meta [_ (#;SymbolS var-name)])) - (M;wrap [(symbol$ var-name) (` id^)]) + (wrap [(symbol$ var-name) (` id^)]) _ (l;fail "Syntax pattern expects 2-tuples or symbols.")))) @@ -256,10 +256,10 @@ macro-def (: AST (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) (~ body'))))]] - (M;wrap (list& macro-def - (if exported? - (list (` (_lux_export (~ (symbol$ ["" name]))))) - (list))))) + (wrap (list& macro-def + (if exported? + (list (` (_lux_export (~ (symbol$ ["" name]))))) + (list))))) _ (l;fail "Wrong syntax for defsyntax")))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index d18c2cfcf..7dc4c7607 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -24,15 +24,18 @@ (matchv ::M/objects [token] [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_catch"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?ex-class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?ex-arg]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ex-arg]]]] ["lux;Cons" [?catch-body ["lux;Nil" _]]]]]]]]]]]]] - (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+) + (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_finally"]]]] ["lux;Cons" [?finally-body ["lux;Nil" _]]]]]]]]] - (&/T catch+ (&/V "lux;Some" ?finally-body)))) + (return (&/T catch+ (&/V "lux;Some" ?finally-body))) + + [_] + (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] @@ -74,7 +77,7 @@ ;; Programs [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?args]]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-program analyse compile-token ?args ?body) @@ -246,7 +249,8 @@ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_try"]]]] ["lux;Cons" [?body ?handlers]]]]]] - (&&host/analyse-jvm-try analyse exo-type ?body (&/fold parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers)) + (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers)] + (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_throw"]]]] ["lux;Cons" [?ex @@ -398,8 +402,8 @@ (&&lux/analyse-case analyse exo-type ?value ?branches) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?self]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?arg]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?self]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?arg]]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]]]] (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 77f8c418c..7f2c34924 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -116,12 +116,15 @@ (matchv ::M/objects [pattern] [["lux;Meta" [_ pattern*]]] (matchv ::M/objects [pattern*] - [["lux;SymbolS" ?ident]] - (|do [=kont (&env/with-local (&/ident->text ?ident) value-type + [["lux;SymbolS" ["" name]]] + (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] (return (&/T (&/V "StoreTestAC" idx) =kont))) + [["lux;SymbolS" ident]] + (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) + [["lux;BoolS" ?value]] (|do [_ (&type/check value-type &type/Bool) =kont kont] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 663c650e7..d03d0e65c 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -299,10 +299,10 @@ ["lux;Nil" _]]]]]]]]]]]]]]]] (|do [=method-inputs (&/map% (fn [minput] (matchv ::M/objects [minput] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?input-name]]] + [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?input-name]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?input-type]]] ["lux;Nil" _]]]]]]]]] - (return (&/T (&/ident->text ?input-name) ?input-type)) + (return (&/T ?input-name ?input-type)) [_] (fail "[Analyser Error] Wrong syntax for method input."))) @@ -358,7 +358,7 @@ (|do [:let [[?catches ?finally] ?catches+?finally] =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local (str ";" ?ex-arg) (&/V "lux;DataT" ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&/V "lux;DataT" ?ex-class) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) @@ -434,9 +434,8 @@ ) (defn analyse-jvm-program [analyse compile-token ?args ?body] - (|let [[_module _name] ?args] - (|do [=body (&/with-scope "" - (&&env/with-local (str _module ";" _name) (&/V "lux;AppT" (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body))) - _ (compile-token (&/V "jvm-program" =body))] - (return (&/|list))))) + (|do [=body (&/with-scope "" + (&&env/with-local ?args (&/V "lux;AppT" (&/T &type/List &type/Text)) + (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body))) + _ (compile-token (&/V "jvm-program" =body))] + (return (&/|list)))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index b1b9e2c22..7c7b80577 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -16,26 +16,22 @@ ;; [Resource] (defn with-lambda [self self-type arg arg-type body] - (|let [[?module1 ?name1] self - [?module2 ?name2] arg] - (&/with-closure - (|do [scope-name &/get-scope-name] - (&env/with-local (str ?module1 ";" ?name1) self-type - (&env/with-local (str ?module2 ";" ?name2) arg-type - (|do [=return body - =captured &env/captured-vars] - (return (&/T scope-name =captured =return))))))))) + (&/with-closure + (|do [scope-name &/get-scope-name] + (&env/with-local self self-type + (&env/with-local arg arg-type + (|do [=return body + =captured &env/captured-vars] + (return (&/T scope-name =captured =return)))))))) -(defn close-over [scope ident register frame] +(defn close-over [scope name register frame] (matchv ::M/objects [register] [[_ register-type]] (|let [register* (&/T (&/V "captured" (&/T scope (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) register)) - register-type) - [?module ?name] ident - full-name (str ?module ";" ?name)] + register-type)] (&/T register* (&/update$ &/$CLOSURE #(->> % (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [mps] (&/|put full-name register* mps)))) + (&/update$ &/$MAPPINGS (fn [mps] (&/|put name register* mps)))) frame))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index c86df3027..7aba5dd39 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -143,90 +143,91 @@ ?elems)] (return (&/|list (&/T (&/V "record" =slots) (&/V "lux;RecordT" exo-type)))))) +(defn ^:private analyse-global [analyse exo-type module name] + (|do [[[r-module r-name] $def] (&&module/find-def module name) + ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" [?type _]]] + (return ?type) + + [["lux;MacroD" _]] + (return &type/Macro) + + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type))))) + +(defn ^:private analyse-local [analyse exo-type name] + (fn [state] + (|let [stack (&/get$ &/$ENVS state) + no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? name) not) + (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? name) not)) + [inner outer] (&/|split-with no-binding? stack)] + (matchv ::M/objects [outer] + [["lux;Nil" _]] + (&/run-state (|do [module-name &/get-module-name] + (analyse-global analyse exo-type module-name name)) + state) + + [["lux;Cons" [?genv ["lux;Nil" _]]]] + (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) + (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name))] + (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) + (matchv ::M/objects [global] + [[["lux;Global" [?module* name*]] _]] + ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) + ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" [?type _]]] + (return ?type) + + [["lux;MacroD" _]] + (return &type/Macro) + + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type)))) + state) + + [_] + (do ;; (prn 'analyse-symbol/_2.1.2 ?module name name) + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) + (fail* "_{_ analyse-symbol _}_"))) + + [["lux;Cons" [top-outer _]]] + (do ;; (prn 'analyse-symbol/_3 ?module name) + (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) + (&/|map #(&/get$ &/$NAME %) outer) + (&/|reverse inner))) + [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] + (|let [[register new-inner] register+new-inner + [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] + (&/T register* (&/|cons frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name)) + (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get name))) + (&/|list)) + (&/|reverse inner) scopes)] + ((|do [btype (&&/expr-type =local) + _ (&type/check exo-type btype)] + (return (&/|list =local))) + (&/set$ &/$ENVS (&/|++ inner* outer) state)))) + )))) + (defn analyse-symbol [analyse exo-type ident] - (|do [module-name &/get-module-name] - (fn [state] - (|let [[?module ?name] ident - ;; _ (prn 'analyse-symbol/_0 ?module ?name) - local-ident (str ?module ";" ?name) - stack (&/get$ &/$ENVS state) - no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not) - (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not)) - [inner outer] (&/|split-with no-binding? stack)] - (matchv ::M/objects [outer] - [["lux;Nil" _]] - (do ;; (prn 'analyse-symbol/_1 - ;; [?module ?name] - ;; [(if (.equals "" ?module) module-name ?module) - ;; ?name]) - ((|do [[[r-module r-name] $def] (&&module/find-def (if (.equals "" ?module) module-name ?module) - ?name) - ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" [?type _]]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state)) - - [["lux;Cons" [?genv ["lux;Nil" _]]]] - (do ;; (prn 'analyse-symbol/_2 ?module ?name local-ident (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))] - (do ;; (prn 'analyse-symbol/_2.1 ?module ?name local-ident (aget global 0)) - (matchv ::M/objects [global] - [[["lux;Global" [?module* ?name*]] _]] - ((|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*) - ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" [?type _]]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state) - - [_] - (do ;; (prn 'analyse-symbol/_2.1.2 ?module ?name local-ident) - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) - (fail* "_{_ analyse-symbol _}_"))) - - [["lux;Cons" [top-outer _]]] - (do ;; (prn 'analyse-symbol/_3 ?module ?name) - (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) - (&/|map #(&/get$ &/$NAME %) outer) - (&/|reverse inner))) - [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] - (|let [[register new-inner] register+new-inner - [register* frame*] (&&lambda/close-over (&/|reverse in-scope) ident register frame)] - (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident)) - (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident))) - (&/|list)) - (&/|reverse inner) scopes)] - ((|do [btype (&&/expr-type =local) - _ (&type/check exo-type btype)] - (return (&/|list =local))) - (&/set$ &/$ENVS (&/|++ inner* outer) state)))) - ))) + (|do [:let [[?module ?name] ident]] + (if (= "" ?module) + (analyse-local analyse exo-type ?name) + (analyse-global analyse exo-type ?module ?name)) )) (defn ^:private analyse-apply* [analyse exo-type fun-type ?args] -- cgit v1.2.3