diff options
| author | Eduardo Julian | 2021-08-29 14:57:15 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2021-08-29 14:57:15 -0400 |
| commit | 1680d4d8bc4046ed4728413f1e7cfd77aa7e84b7 (patch) | |
| tree | 7e79997206c0102e4cd63f34e4da2a4336df52f4 | |
| parent | c5b61d2f46ac19bf511197f3a537c4be0f47df33 (diff) | |
Made labels (tags & slots) into a form of global binding.
Diffstat (limited to '')
41 files changed, 1008 insertions, 644 deletions
diff --git a/lux-bootstrapper/src/lux/analyser.clj b/lux-bootstrapper/src/lux/analyser.clj index e139e085f..ccd0144f6 100644 --- a/lux-bootstrapper/src/lux/analyser.clj +++ b/lux-bootstrapper/src/lux/analyser.clj @@ -17,9 +17,7 @@ ;; [Utils] (defn analyse-variant+ [analyse exo-type ident values] (|do [[module tag-name] (&/normalize ident) - _ (&&module/ensure-can-see-tag module tag-name) - idx (&&module/tag-index module tag-name) - group (&&module/tag-group module tag-name) + [exported? wanted-type group idx] (&&module/find-tag module (str "#" tag-name)) :let [is-last? (= idx (dec (&/|length group)))]] (if (= 1 (&/|length group)) (|do [_location &/location] @@ -29,8 +27,7 @@ (|do [? (&type/bound? id)] (if (or ? (&&/type-tag? module tag-name)) (&&lux/analyse-variant analyse (&/$Right exo-type) idx is-last? values) - (|do [wanted-type (&&module/tag-type module tag-name) - wanted-type* (&type/instantiate-inference wanted-type) + (|do [wanted-type* (&type/instantiate-inference wanted-type) [[variant-type variant-location] variant-analysis] (&&/cap-1 (&&lux/analyse-variant analyse (&/$Left wanted-type*) idx is-last? values)) _ (&type/check exo-type variant-type)] (return (&/|list (&&/|meta exo-type variant-location variant-analysis)))))) @@ -149,12 +146,17 @@ (|let [(&/$Item [_ (&/$Identifier "" ?name)] (&/$Item ?value (&/$Item ?meta - (&/$Item [_ (&/$Tuple ?tags)] + (&/$Item ?labels (&/$Item exported? (&/$End)))) )) parameters] (&/with-location location - (&&lux/analyse-def-type-tagged analyse optimize eval! compile-def ?name ?value ?meta ?tags exported?))) + (|case ?labels + [_ (&/$Form ?tags)] + (&&lux/analyse-def-type-tagged analyse optimize eval! compile-def ?name ?value ?meta false ?tags exported?) + + [_ (&/$Tuple ?slots)] + (&&lux/analyse-def-type-tagged analyse optimize eval! compile-def ?name ?value ?meta true ?slots exported?)))) "lux def program" (|let [(&/$Item ?program (&/$End)) parameters] diff --git a/lux-bootstrapper/src/lux/analyser/case.clj b/lux-bootstrapper/src/lux/analyser/case.clj index ba8afd4e8..062467ca3 100644 --- a/lux-bootstrapper/src/lux/analyser/case.clj +++ b/lux-bootstrapper/src/lux/analyser/case.clj @@ -347,15 +347,13 @@ (&/$Tag ?ident) (|do [[=module =name] (&&/resolved-ident ?ident) must-infer? (&type/unknown? value-type) + [_exported? variant-type** group idx] (&module/find-tag =module (str "#" =name)) variant-type (if must-infer? - (|do [variant-type (&module/tag-type =module =name) - variant-type* (&type/instantiate-inference variant-type) + (|do [variant-type* (&type/instantiate-inference variant-type**) _ (&type/check value-type variant-type*)] (return variant-type*)) (return value-type)) value-type* (adjust-type variant-type) - idx (&module/tag-index =module =name) - group (&module/tag-group =module =name) case-type (&type/sum-at idx value-type*) [=test =kont] (analyse-pattern &/$None case-type unit-tuple kont)] (return (&/T [($VariantTestAC (&/T [idx (&/|length group) =test])) =kont]))) @@ -374,15 +372,13 @@ (&/$Form (&/$Item [_ (&/$Tag ?ident)] ?values)) (|do [[=module =name] (&&/resolved-ident ?ident) must-infer? (&type/unknown? value-type) + [_exported? variant-type** group idx] (&module/find-tag =module (str "#" =name)) variant-type (if must-infer? - (|do [variant-type (&module/tag-type =module =name) - variant-type* (&type/instantiate-inference variant-type) + (|do [variant-type* (&type/instantiate-inference variant-type**) _ (&type/check value-type variant-type*)] (return variant-type*)) (return value-type)) value-type* (adjust-type variant-type) - idx (&module/tag-index =module =name) - group (&module/tag-group =module =name) case-type (&type/sum-at idx value-type*) [=test =kont] (case (int (&/|length ?values)) 0 (analyse-pattern &/$None case-type unit-tuple kont) diff --git a/lux-bootstrapper/src/lux/analyser/lux.clj b/lux-bootstrapper/src/lux/analyser/lux.clj index 769b85e30..8b93faea8 100644 --- a/lux-bootstrapper/src/lux/analyser/lux.clj +++ b/lux-bootstrapper/src/lux/analyser/lux.clj @@ -248,9 +248,9 @@ (|do [[rec-members rec-type] (&&record/order-record ?elems)] (|case exo-type (&/$Var id) - (|do [? (&type/bound? id)] - (if ? - (analyse-tuple analyse (&/$Right exo-type) rec-members) + (|do [verdict (&type/bound? id)] + (if verdict + (analyse-tuple analyse (&/$Right exo-type) rec-members) (|do [[[tuple-type tuple-location] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left rec-type) rec-members)) _ (&type/check exo-type tuple-type)] (return (&/|list (&&/|meta exo-type tuple-location @@ -261,7 +261,7 @@ ))) (defn ^:private analyse-global [analyse exo-type module name] - (|do [[[r-module r-name] [exported? endo-type ?meta ?value]] (&&module/find-def module name) + (|do [[[r-module r-name] [exported? endo-type ?annotations ?value]] (&&module/find-def module name) ;; This is a small shortcut to optimize analysis of typing code. _ (if (and (&type/type= &type/Type endo-type) (&type/type= &type/Type exo-type)) @@ -376,7 +376,7 @@ (defn analyse-apply [analyse location exo-type macro-caller =fn ?args] (|case =fn [_ (&&/$def ?module ?name)] - (|do [[real-name [exported? ?type ?meta ?value]] (&&module/find-def! ?module ?name)] + (|do [[real-name [exported? ?type ?annotations ?value]] (&&module/find-def! ?module ?name)] (if (&type/type= &type/Macro ?type) (|do [macro-expansion (fn [state] (|case (macro-caller ?value ?args state) @@ -549,7 +549,7 @@ (str "\nThis is an alias for " source-name))))) (return &/$End)))) -(defn analyse-def* [analyse optimize eval! compile-def ?name ?value ?meta exported? & [?expected-type]] +(defn analyse-def* [analyse optimize eval! compile-def ?name ?value ?annotations exported? type? & [?expected-type]] (|do [_ &/ensure-directive module-name &/get-module-name _ (ensure-undefined! module-name ?name) @@ -561,32 +561,29 @@ (&&/analyse-1+ analyse ?value)))) =exported? (&&/analyse-1 analyse &type/Bit exported?) ==exported? (eval! (optimize =exported?)) - =meta (&&/analyse-1 analyse &type/Code ?meta) - ==meta (eval! (optimize =meta)) - def-value (compile-def ?name (optimize =value) ==meta ==exported?) + =annotations (&&/analyse-1 analyse &type/Code ?annotations) + ==annotations (eval! (optimize =annotations)) + def-value (compile-def ?name (optimize =value) ==annotations ==exported? type?) _ &type/reset-mappings :let [def-type (&&/expr-type* =value) _ (println 'DEF (str module-name &/+name-separator+ ?name " : " (&type/show-type def-type)))]] (return (&/T [module-name def-type def-value ==exported?])))) -(defn analyse-def [analyse optimize eval! compile-def ?name ?value ?meta exported?] - (|do [_ (analyse-def* analyse optimize eval! compile-def ?name ?value ?meta exported?)] +(defn analyse-def [analyse optimize eval! compile-def ?name ?value ?annotations exported?] + (|do [_ (analyse-def* analyse optimize eval! compile-def ?name ?value ?annotations exported? &/$None)] (return &/$End))) -(defn analyse-def-type-tagged [analyse optimize eval! compile-def ?name ?value ?meta tags* exported?] - (|do [[module-name def-type def-value =exported?] (analyse-def* analyse optimize eval! compile-def ?name ?value ?meta exported? &type/Type) - _ (&/assert! (&type/type= &type/Type def-type) - "[Analyser Error] Cannot define tags for non-type.") - tags (&/map% (fn [tag*] - (|case tag* - [_ (&/$Text tag)] - (return tag) - - _ - (&/fail-with-loc "[Analyser Error] Incorrect format for tags."))) - tags*) - _ (&&module/declare-tags module-name tags =exported? def-value)] +(defn analyse-def-type-tagged [analyse optimize eval! compile-def ?name ?value ?annotations record? labels* exported?] + (|do [labels (&/map% (fn [tag*] + (|case tag* + [_ (&/$Text tag)] + (return tag) + + _ + (&/fail-with-loc "[Analyser Error] Incorrect format for labels."))) + labels*) + _ (analyse-def* analyse optimize eval! compile-def ?name ?value ?annotations exported? (&/$Some (&/T [record? labels])) &type/Type)] (return &/$End))) (defn analyse-def-alias [?alias ?original] @@ -661,9 +658,9 @@ (return (doto (promise) (deliver (&/$Right _compiler)))))))) -(defn analyse-module [analyse optimize eval! compile-module ?meta ?imports] +(defn analyse-module [analyse optimize eval! compile-module ?annotations ?imports] (|do [_ &/ensure-directive - =anns (&&/analyse-1 analyse &type/Code ?meta) + =anns (&&/analyse-1 analyse &type/Code ?annotations) ==anns (eval! (optimize =anns)) module-name &/get-module-name _ (&&module/set-anns ==anns module-name) diff --git a/lux-bootstrapper/src/lux/analyser/module.clj b/lux-bootstrapper/src/lux/analyser/module.clj index 12e6b816a..8c6f06d88 100644 --- a/lux-bootstrapper/src/lux/analyser/module.clj +++ b/lux-bootstrapper/src/lux/analyser/module.clj @@ -22,8 +22,6 @@ "module-aliases" "defs" "imports" - "tags" - "types" "module-annotations" "module-state"]) @@ -36,10 +34,6 @@ (&/|table) ;; "lux;imports" &/$End - ;; "lux;tags" - (&/|table) - ;; "lux;types" - (&/|table) ;; module-annotations &/$None ;; "module-state" @@ -115,7 +109,7 @@ (&/|update module (fn [m] (&/update$ $defs - #(&/|put name (&/$Left de-aliased) %) + #(&/|put name (&/$AliasG de-aliased) %) m)) ms)))) nil) @@ -134,7 +128,7 @@ (&/|update module (fn [m] (&/update$ $defs - #(&/|put name (&/$Right (&/T [exported? def-type def-meta def-value])) %) + #(&/|put name (&/$DefinitionG (&/T [exported? def-type def-meta def-value])) %) m)) ms)))) nil) @@ -150,15 +144,26 @@ (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|case $def - (&/$Left [o-module o-name]) + (&/$AliasG [o-module o-name]) ((type-def o-module o-name) state) - (&/$Right [exported? ?type ?meta ?value]) + (&/$DefinitionG [exported? ?type ?meta ?value]) (if (&type/type= &type/Type ?type) (return* state (&/T [exported? ?value])) ((&/fail-with-loc (str "[Analyser Error] Not a type: " (&/ident->text (&/T [module name])) "\nMETA: " (&/show-ast ?meta))) - state))) + state)) + + (&/$TypeG [exported? ?value labels]) + (return* state (&/T [exported? ?value])) + + (&/$TagG _) + ((&/fail-with-loc (str "[Analyser Error] Not a type: " (&/ident->text (&/T [module name])))) + state) + + (&/$SlotG _) + ((&/fail-with-loc (str "[Analyser Error] Not a type: " (&/ident->text (&/T [module name])))) + state)) ((&/fail-with-loc (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T [module name])))) state)) ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module)) @@ -226,18 +231,35 @@ ms)))) nil))) +(def empty_annotations + (let [dummy_location (&/T ["" 0 0])] + (&/T [dummy_location + (&/$Record &/$End)]))) + (defn find-def! [module name] (|do [current-module &/get-module-name] (fn [state] (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|case $def - (&/$Left [?r-module ?r-name]) + (&/$AliasG [?r-module ?r-name]) ((find-def! ?r-module ?r-name) state) - (&/$Right $def*) - (return* state (&/T [(&/T [module name]) $def*]))) + (&/$DefinitionG $def*) + (return* state (&/T [(&/T [module name]) $def*])) + + (&/$TypeG [exported? ?value labels]) + (return* state (&/T [(&/T [module name]) + (&/T [exported? &type/Type empty_annotations ?value])])) + + (&/$TagG _) + ((&/fail-with-loc (str "[Analyser Error] Not a definition: " (&/ident->text (&/T [module name])))) + state) + + (&/$SlotG _) + ((&/fail-with-loc (str "[Analyser Error] Not a definition: " (&/ident->text (&/T [module name])))) + state)) ((&/fail-with-loc (str "[Analyser Error @ find-def!] Definition does not exist: " (str module &/+name-separator+ name) " at module: " current-module)) state)) @@ -251,7 +273,7 @@ (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|case $def - (&/$Left [?r-module ?r-name]) + (&/$AliasG [?r-module ?r-name]) (if (.equals ^Object current-module module) ((find-def! ?r-module ?r-name) state) @@ -259,7 +281,7 @@ " at module: " current-module)) state)) - (&/$Right [exported? ?type ?meta ?value]) + (&/$DefinitionG [exported? ?type ?meta ?value]) (if (or (.equals ^Object current-module module) (and exported? (or (.equals ^Object module &/prelude) @@ -268,7 +290,26 @@ (&/T [exported? ?type ?meta ?value])])) ((&/fail-with-loc (str "[Analyser Error @ find-def] Cannot use private definition: " (str module &/+name-separator+ name) " at module: " current-module)) - state))) + state)) + + (&/$TypeG [exported? ?value labels]) + (if (or (.equals ^Object current-module module) + (and exported? + (or (.equals ^Object module &/prelude) + (imports? state module current-module)))) + (return* state (&/T [(&/T [module name]) + (&/T [exported? &type/Type empty_annotations ?value])])) + ((&/fail-with-loc (str "[Analyser Error @ find-def] Cannot use private definition: " (str module &/+name-separator+ name) + " at module: " current-module)) + state)) + + (&/$TagG _) + ((&/fail-with-loc (str "[Analyser Error] Not a definition: " (&/ident->text (&/T [module name])))) + state) + + (&/$SlotG _) + ((&/fail-with-loc (str "[Analyser Error] Not a definition: " (&/ident->text (&/T [module name])))) + state)) ((&/fail-with-loc (str "[Analyser Error @ find-def] Definition does not exist: " (str module &/+name-separator+ name) " at module: " current-module)) state)) @@ -276,6 +317,73 @@ " at module: " current-module)) state))))) +(do-template [<tag> <find!> <find>] + (do (defn <find!> [module name] + (|do [current-module &/get-module-name] + (fn [state] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|case $def + (&/$AliasG [?r-module ?r-name]) + ((<find!> ?r-module ?r-name) + state) + + (<tag> ?payload) + (return* state ?payload) + + _ + ((&/fail-with-loc (str "[Analyser Error] Not a label: " (&/ident->text (&/T [module name])) + " @ " (quote <find!>))) + state)) + ((&/fail-with-loc (str "[Analyser Error] Label does not exist: " (str module &/+name-separator+ name) + " at module: " current-module + " @ " (quote <find!>))) + state)) + ((&/fail-with-loc (str "[Analyser Error] Module does not exist: " module + " at module: " current-module + " @ " (quote <find!>))) + state))))) + (defn <find> [module name] + (|do [current-module &/get-module-name] + (fn [state] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|case $def + (&/$AliasG [?r-module ?r-name]) + (if (.equals ^Object current-module module) + ((<find!> ?r-module ?r-name) + state) + ((&/fail-with-loc (str "[Analyser Error] Cannot use (private) alias: " (str module &/+name-separator+ name) + " at module: " current-module + " @ " (quote <find>))) + state)) + + (<tag> [exported? type group index]) + (if (or (.equals ^Object current-module module) + exported?) + (return* state (&/T [exported? type group index])) + ((&/fail-with-loc (str "[Analyser Error] Cannot use private label: " (str module &/+name-separator+ name) + " at module: " current-module + " @ " (quote <find>))) + state)) + + _ + ((&/fail-with-loc (str "[Analyser Error] Not a label: " (&/ident->text (&/T [module name])) + " @ " (quote <find>))) + state)) + ((&/fail-with-loc (str "[Analyser Error] Label does not exist: " (str module &/+name-separator+ name) + " at module: " current-module + " @ " (quote <find>))) + state)) + ((&/fail-with-loc (str "[Analyser Error] Module does not exist: " module + " at module: " current-module + " @ " (quote <find>))) + state)))))) + + &/$TagG find-tag! find-tag + &/$SlotG find-slot! find-slot + ) + (defn defined? [module name] (&/try-all% (&/|list (|do [_ (find-def! module name)] (return true)) @@ -291,21 +399,14 @@ (&/set$ &/$current-module (&/$Some name))) nil))) -(do-template [<name> <tag> <type>] - (defn <name> - <type> - [module] - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (return* state (&/get$ <tag> =module)) - ((&/fail-with-loc (str "[Lux Error] Unknown module: " module)) - state)) - )) - - tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" - types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" - module-hash $module-hash "(-> Text (Lux Int))" - ) +(defn module-hash + "(-> Text (Lux Int))" + [module] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (return* state (&/get$ $module-hash =module)) + ((&/fail-with-loc (str "[Lux Error] Unknown module: " module)) + state)))) (def imports (|do [module &/get-module-name @@ -316,85 +417,90 @@ (return (&/T [_module _hash])))) _imports))) -(defn ensure-undeclared-tags [module tags] - (|do [tags-table (tags-by-module module) - _ (&/map% (fn [tag] - (if (&/|get tag tags-table) - (&/fail-with-loc (str "[Analyser Error] Cannot re-declare tag: " (&/ident->text (&/T [module tag])))) - (return nil))) - tags)] - (return nil))) - -(defn ensure-undeclared-type [module name] - (|do [types-table (types-by-module module) - _ (&/assert! (nil? (&/|get name types-table)) - (str "[Analyser Error] Cannot re-declare type: " (&/ident->text (&/T [module name]))))] - (return nil))) - -(defn declare-tags +(defn define_tag [module name exported? type group index] + (fn [state] + (|case (&/get$ &/$scopes state) + (&/$Item ?env (&/$End)) + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module + (fn [m] + (&/update$ $defs + #(&/|put name (&/$TagG (&/T [exported? type group index])) %) + m)) + ms)))) + nil) + + _ + ((&/fail-with-loc (str "[Analyser Error] Cannot create a new global tag outside of a global environment: " (str module &/+name-separator+ name))) + state)))) + +(defn define_slot [module name exported? type group index] + (fn [state] + (|case (&/get$ &/$scopes state) + (&/$Item ?env (&/$End)) + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module + (fn [m] + (&/update$ $defs + #(&/|put name (&/$SlotG (&/T [exported? type group index])) %) + m)) + ms)))) + nil) + + _ + ((&/fail-with-loc (str "[Analyser Error] Cannot create a new global slot outside of a global environment: " (str module &/+name-separator+ name))) + state)))) + +(defn declare-labels "(-> Text (List Text) Bit Type (Lux Null))" - [module tag-names was-exported? type] - (|do [_ (ensure-undeclared-tags module tag-names) - type-name (&type/type-name type) + [module record? label-names was-exported? type] + (|do [type-name (&type/type-name type) :let [[_module _name] type-name] _ (&/assert! (= module _module) - (str "[Module Error] Cannot define tags for a type belonging to a foreign module: " (&/ident->text type-name))) - _ (ensure-undeclared-type _module _name)] - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (let [tags (&/|map (fn [tag-name] (&/T [module tag-name])) tag-names)] - (return* (&/update$ &/$modules - (fn [=modules] - (&/|update module - #(->> % - (&/set$ $tags (&/fold (fn [table idx+tag-name] - (|let [[idx tag-name] idx+tag-name] - (&/|put tag-name (&/T [idx tags was-exported? type]) table))) - (&/get$ $tags %) - (&/enumerate tag-names))) - (&/update$ $types (partial &/|put _name (&/T [tags was-exported? type])))) - =modules)) - state) - nil)) - ((&/fail-with-loc (str "[Lux Error] Unknown module: " module)) - state))))) - -(defn ensure-can-see-tag - "(-> Text Text (Lux Any))" - [module tag-name] - (|do [current-module &/get-module-name] - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [^objects idx+tags+exported+type (&/|get tag-name (&/get$ $tags =module))] - (|let [[?idx ?tags ?exported ?type] idx+tags+exported+type] - (if (or ?exported - (= module current-module)) - (return* state &/unit-tag) - ((&/fail-with-loc (str "[Analyser Error] Cannot access tag #" (&/ident->text (&/T [module tag-name])) " from module " current-module)) - state))) - ((&/fail-with-loc (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name])))) - state)) - ((&/fail-with-loc (str "[Module Error] Unknown module: " module)) - state))))) - -(do-template [<name> <part> <doc>] - (defn <name> - <doc> - [module tag-name] - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [^objects idx+tags+exported+type (&/|get tag-name (&/get$ $tags =module))] - (|let [[?idx ?tags ?exported ?type] idx+tags+exported+type] - (return* state <part>)) - ((&/fail-with-loc (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name])))) - state)) - ((&/fail-with-loc (str "[Module Error] Unknown module: " module)) - state)))) - - tag-index ?idx "(-> Text Text (Lux Int))" - tag-group ?tags "(-> Text Text (Lux (List Ident)))" - tag-type ?type "(-> Text Text (Lux Type))" - ) + (str "[Module Error] Cannot define labels for a type belonging to a foreign module: " (&/ident->text type-name)))] + (if (nil? record?) + (return &/unit-tag) + (if record? + (&/map% (fn [idx+label-name] + (|let [[index label-name] idx+label-name] + (define_slot module (str "#" label-name) was-exported? type label-names index))) + (&/enumerate label-names)) + (&/map% (fn [idx+label-name] + (|let [[index label-name] idx+label-name] + (define_tag module (str "#" label-name) was-exported? type label-names index))) + (&/enumerate label-names)))))) + +(defn define-type [module name exported? def-meta def-value record? labels] + (|case labels + (&/$End) + (define module name exported? &type/Type def-meta def-value) + + (&/$Item labelH labelT) + (|do [_ (declare-labels module record? labels exported? def-value)] + (fn [state] + (|case (&/get$ &/$scopes state) + (&/$Item ?env (&/$End)) + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module + (fn [m] + (&/update$ $defs + #(&/|put name (&/$TypeG (&/T [exported? def-value (if record? + (&/$Right (&/T [labelH labelT])) + (&/$Left (&/T [labelH labelT])))])) + %) + m)) + ms)))) + nil) + + _ + ((&/fail-with-loc (str "[Analyser Error] Cannot create a new global definition outside of a global environment: " (str module &/+name-separator+ name))) + state)))))) (def defs (|do [module &/get-module-name] @@ -417,15 +523,3 @@ _ (&/fail-with-loc "[Analyser Error] Incorrect import syntax."))) - -(def ^{:doc "(Lux (List [Text (List Text)]))"} - tag-groups - (|do [module &/get-current-module] - (return (&/|map (fn [pair] - (|case pair - [name [tags exported? _]] - (&/T [name (&/|map (fn [tag] - (|let [[t-prefix t-name] tag] - t-name)) - tags)]))) - (&/get$ $types module))))) diff --git a/lux-bootstrapper/src/lux/analyser/record.clj b/lux-bootstrapper/src/lux/analyser/record.clj index 53f6c4d5c..7af3c17ac 100644 --- a/lux-bootstrapper/src/lux/analyser/record.clj +++ b/lux-bootstrapper/src/lux/analyser/record.clj @@ -10,18 +10,18 @@ (defn order-record "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" [pairs] - (|do [[tag-group tag-type] (|case pairs - (&/$End) - (return (&/T [&/$End &type/Any])) - - (&/$Item [[_ (&/$Tag tag1)] _] _) - (|do [[module name] (&&/resolved-ident tag1) - tags (&&module/tag-group module name) - type (&&module/tag-type module name)] - (return (&/T [tags type]))) + (|do [[module slot-group slot-type] (|case pairs + (&/$End) + (|do [module &/get-module-name] + (return (&/T [module &/$End &type/Any]))) + + (&/$Item [[_ (&/$Tag slot1)] _] _) + (|do [[module name] (&&/resolved-ident slot1) + [_exported? type slots _index] (&&module/find-slot module (str "#" name))] + (return (&/T [module slots type]))) - _ - (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) + _ + (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be slots.")) =pairs (&/map% (fn [kv] (|case kv [[_ (&/$Tag k)] v] @@ -29,15 +29,16 @@ (return (&/T [(&/ident->text =k) v]))) _ - (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) + (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be slots."))) pairs) - _ (let [num-expected (&/|length tag-group) + _ (let [num-expected (&/|length slot-group) num-got (&/|length =pairs)] (&/assert! (= num-expected num-got) (str "[Analyser Error] Wrong number of record members. Expected " num-expected ", but got " num-got "."))) - =members (&/map% (fn [tag] - (if-let [member (&/|get tag =pairs)] - (return member) - (&/fail-with-loc (str "[Analyser Error] Missing tag: " tag)))) - (&/|map &/ident->text tag-group))] - (return (&/T [=members tag-type])))) + =members (&/map% (fn [slot] + (let [slot (&/ident->text (&/T [module slot]))] + (if-let [member (&/|get slot =pairs)] + (return member) + (&/fail-with-loc (str "[Analyser Error] Missing slot: " slot))))) + slot-group)] + (return (&/T [=members slot-type])))) diff --git a/lux-bootstrapper/src/lux/base.clj b/lux-bootstrapper/src/lux/base.clj index 1367bdc1c..f95c4d6d5 100644 --- a/lux-bootstrapper/src/lux/base.clj +++ b/lux-bootstrapper/src/lux/base.clj @@ -148,6 +148,13 @@ ("Jvm" 1) ("Js" 1)) +(defvariant + ("DefinitionG" 1) + ("TypeG" 1) + ("TagG" 1) + ("SlotG" 1) + ("AliasG" 1)) + (deftuple ["info" "source" diff --git a/lux-bootstrapper/src/lux/compiler/cache.clj b/lux-bootstrapper/src/lux/compiler/cache.clj index bbe9e7882..d2b232f74 100644 --- a/lux-bootstrapper/src/lux/compiler/cache.clj +++ b/lux-bootstrapper/src/lux/compiler/cache.clj @@ -69,48 +69,50 @@ (delete-all-module-files (new File (str output-dir-prefix f)))) nil)) -(defn ^:private parse-tag-groups [^String tags-section] - (if (= "" tags-section) - &/$End - (-> tags-section - (.split &&core/entry-separator) - seq - (->> (map (fn [^String _group] - (let [[_type & _tags] (.split _group &&core/datum-separator)] - (&/T [_type (->> _tags seq &/->list)]))))) - &/->list))) - -(defn ^:private process-tag-group [module group] - (|let [[_type _tags] group] - (|do [[was-exported? =type] (&a-module/type-def module _type)] - (&a-module/declare-tags module _tags was-exported? =type)))) - (defn make-tag [ident] (&/T [(&/T ["" 0 0]) (&/$Tag ident)])) (defn make-identifier [ident] (&/T [(&/T ["" 0 0]) (&/$Identifier ident)])) -(defn make-record [ident] - (&/T [(&/T ["" 0 0]) (&/$Record ident)])) +(defn make-record [kvs] + (&/T [(&/T ["" 0 0]) (&/$Record kvs)])) (defn ^:private process-def-entry [load-def-value module ^String _def-entry] (let [parts (.split _def-entry &&core/datum-separator)] - (case (alength parts) - 2 (let [[_name ^String _alias] parts - [__module __name] (.split _alias &/+name-separator+)] - (&a-module/define-alias module _name (&/T [__module __name]))) - 4 (let [[_name _exported? _type _anns] parts - [def-anns _] (&&&ann/deserialize _anns) - [def-type _] (&&&type/deserialize-type _type)] - (|do [def-value (load-def-value module _name)] - (&a-module/define module _name (= "1" _exported?) def-type def-anns def-value)))))) + (case (first parts) + "A" (let [[_ _name ^String _alias] parts + [__module __name] (.split _alias &/+name-separator+)] + (&a-module/define-alias module _name (&/T [__module __name]))) + "D" (let [[_ _name _exported? _type _anns] parts + [def-anns _] (&&&ann/deserialize _anns) + [def-type _] (&&&type/deserialize-type _type)] + (|do [def-value (load-def-value module _name)] + (&a-module/define module _name (= "1" _exported?) def-type def-anns def-value))) + ":" (let [[_ _name _exported? _record? _head _tail] parts + labels (&/$Item _head (if _tail + (&/->list (seq (.split _tail "\\."))) + &/$End))] + (|do [def-value (load-def-value module _name)] + (&a-module/define-type + module _name + (= "1" _exported?) (make-record &/$End) + def-value (= "1" _record?) labels))) + ;; "T" (let [[_ _name _exported? _type _index _group] parts + ;; [_type _] (&&&type/deserialize-type _type) + ;; _group (&/->list (seq (.split _group "\\.")))] + ;; (&a-module/define_tag module _name (= "1" _exported?) _type _group (Long/parseLong _index))) + ;; "S" (let [[_ _name _exported? _type _index _group] parts + ;; [_type _] (&&&type/deserialize-type _type) + ;; _group (&/->list (seq (.split _group "\\.")))] + ;; (&a-module/define_slot module _name (= "1" _exported?) _type _group (Long/parseLong _index))) + ))) (defn ^:private uninstall-cache [module] (|do [_ (delete module)] (return false))) -(defn ^:private install-module [load-def-value module module-hash imports tag-groups ?module-anns def-entries] +(defn ^:private install-module [load-def-value module module-hash imports ?module-anns def-entries] (|do [_ (&a-module/create-module module module-hash) _ (&a-module/flag-cached-module module) _ (|case ?module-anns @@ -121,12 +123,11 @@ (return nil)) _ (&a-module/set-imports imports) _ (&/map% (partial process-def-entry load-def-value module) - def-entries) - _ (&/map% (partial process-tag-group module) tag-groups)] + def-entries)] (return nil))) (defn ^:private process-module [pre-load! source-dirs cache-table module-name module-hash - _imports-section _tags-section _module-anns-section _defs-section + _imports-section _module-anns-section _defs-section load-def-value install-all-defs-in-module uninstall-all-defs-in-module] (|do [^String descriptor (&&core/read-module-descriptor! module-name) :let [imports (let [imports (vec (.split ^String _imports-section &&core/entry-separator)) @@ -143,8 +144,7 @@ imports)] (if (&/|every? (fn [_module] (contains? cache-table* _module)) imports) - (let [tag-groups (parse-tag-groups _tags-section) - [?module-anns _] (if (= "..." _module-anns-section) + (let [[?module-anns _] (if (= "..." _module-anns-section) [&/$None nil] (let [[module-anns _] (&&&ann/deserialize _module-anns-section)] [(&/$Some module-anns) _])) @@ -154,7 +154,7 @@ (&/->list def-entries)))] (|do [_ (install-all-defs-in-module module-name) _ (install-module load-def-value module-name module-hash - imports tag-groups ?module-anns def-entries) + imports ?module-anns def-entries) =module (&/find-module module-name)] (return (&/T [true (assoc cache-table* module-name =module)])))) (return (&/T [false cache-table*]))))) @@ -191,14 +191,14 @@ :else (|do [^String descriptor (&&core/read-module-descriptor! module-name) - :let [[_compiler _hash _imports-section _tags-section _module-anns-section _defs-section] (.split descriptor &&core/section-separator) + :let [[_compiler _hash _imports-section _module-anns-section _defs-section] (.split descriptor &&core/section-separator) drop-cache! (|do [_ (uninstall-cache module-name) _ (uninstall-all-defs-in-module module-name)] (return cache-table))]] (if (and (= module-hash (Long/parseUnsignedLong ^String _hash)) (= &/version _compiler)) (|do [[success? cache-table*] (process-module pre-load! source-dirs cache-table module-name module-hash - _imports-section _tags-section _module-anns-section _defs-section + _imports-section _module-anns-section _defs-section load-def-value install-all-defs-in-module uninstall-all-defs-in-module) _ (if success? (return nil) diff --git a/lux-bootstrapper/src/lux/compiler/cache/type.clj b/lux-bootstrapper/src/lux/compiler/cache/type.clj index f4d33edc1..50e943b73 100644 --- a/lux-bootstrapper/src/lux/compiler/cache/type.clj +++ b/lux-bootstrapper/src/lux/compiler/cache/type.clj @@ -97,8 +97,8 @@ [(<type> (Long/parseLong idx)) input*]))) ^:private deserialize-parameter "$" &/$Parameter - ^:private deserialize-ex "!" &/$Ex - ^:private deserialize-var "?" &/$Var + ^:private deserialize-ex "!" &/$Ex + ^:private deserialize-var "?" &/$Var ) (defn ^:private deserialize-named [^String input] diff --git a/lux-bootstrapper/src/lux/compiler/core.clj b/lux-bootstrapper/src/lux/compiler/core.clj index 88da626bd..b2d366d5d 100644 --- a/lux-bootstrapper/src/lux/compiler/core.clj +++ b/lux-bootstrapper/src/lux/compiler/core.clj @@ -47,40 +47,76 @@ ?module-anns (&a-module/get-anns module-name) defs &a-module/defs imports &a-module/imports - tag-groups &a-module/tag-groups - :let [def-entries (->> defs - (&/|map (fn [_def] - (|let [[?name _definition] _def] - (|case _definition - (&/$Left [_dmodule _dname]) - (str ?name datum-separator _dmodule &/+name-separator+ _dname) - - (&/$Right [exported? ?def-type ?def-anns ?def-value]) - (str ?name - datum-separator (if exported? "1" "0") - datum-separator (&&&type/serialize-type ?def-type) - datum-separator (&&&ann/serialize ?def-anns)))))) - (&/|interpose entry-separator) - (&/fold str "")) + :let [def-entries (&/fold (fn [def-entries _def] + (|let [[?name _definition] _def] + (|case _definition + (&/$AliasG [_dmodule _dname]) + (str "A" + datum-separator ?name + datum-separator _dmodule &/+name-separator+ _dname + ;; Next + entry-separator def-entries) + + (&/$DefinitionG [exported? ?def-type ?def-anns ?def-value]) + (str "D" + datum-separator ?name + datum-separator (if exported? "1" "0") + datum-separator (&&&type/serialize-type ?def-type) + datum-separator (&&&ann/serialize ?def-anns) + ;; Next + entry-separator def-entries) + + (&/$TypeG [exported? value labels]) + (let [[record? head tail] (|case labels + (&/$Left [head tail]) + [false head tail] + + (&/$Right [head tail]) + [true head tail])] + (str ":" + datum-separator ?name + datum-separator (if exported? "1" "0") + datum-separator (if record? "1" "0") + datum-separator head + datum-separator (->> tail + (&/|interpose &/+name-separator+) + (&/fold str "")) + ;; Next + entry-separator def-entries)) + + (&/$TagG [?export ?type ?group ?index]) + def-entries + ;; (str "T" + ;; datum-separator ?name + ;; datum-separator (if ?export "1" "0") + ;; datum-separator (&&&type/serialize-type ?type) + ;; datum-separator ?index + ;; datum-separator (->> ?group + ;; (&/|interpose &/+name-separator+) + ;; (&/fold str ""))) + + (&/$SlotG [?export ?type ?group ?index]) + def-entries + ;; (str "S" + ;; datum-separator ?name + ;; datum-separator (if ?export "1" "0") + ;; datum-separator (&&&type/serialize-type ?type) + ;; datum-separator ?index + ;; datum-separator (->> ?group + ;; (&/|interpose &/+name-separator+) + ;; (&/fold str ""))) + ))) + "" + defs) import-entries (->> imports (&/|map (fn [import] (|let [[_module _hash] import] (str _module datum-separator _hash)))) (&/|interpose entry-separator) (&/fold str "")) - tag-entries (->> tag-groups - (&/|map (fn [group] - (|let [[type tags] group] - (->> tags - (&/|interpose datum-separator) - (&/fold str "") - (str type datum-separator))))) - (&/|interpose entry-separator) - (&/fold str "")) module-descriptor (->> (&/|list &/version (Long/toUnsignedString file-hash) import-entries - tag-entries (|case ?module-anns (&/$Some module-anns) (&&&ann/serialize module-anns) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/lux.clj b/lux-bootstrapper/src/lux/compiler/jvm/lux.clj index 973d0e8c6..a93c87ae8 100644 --- a/lux-bootstrapper/src/lux/compiler/jvm/lux.clj +++ b/lux-bootstrapper/src/lux/compiler/jvm/lux.clj @@ -250,7 +250,7 @@ (str base "\n\n" "Caused by: " (throwable->text cause)) base))) -(defn ^:private install-def! [class-loader current-class module-name ?name ?body ?meta exported?] +(defn ^:private install-def! [class-loader current-class module-name ?name ?body ?meta exported? type?] (|do [_ (return nil) :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) def-type (&a/expr-type* ?body)] @@ -260,12 +260,17 @@ (str "Error during value initialization:\n" (throwable->text t))))) _ (&/without-repl-closure - (&a-module/define module-name ?name exported? def-type ?meta def-value))] + (|case type? + (&/$Some [record? labels]) + (&a-module/define-type module-name ?name exported? ?meta def-value record? labels) + + (&/$None) + (&a-module/define module-name ?name exported? def-type ?meta def-value)))] (return def-value))) (let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)] - (defn compile-def [compile ?name ?body ?meta exported?] + (defn compile-def [compile ?name ?body ?meta exported? type?] (|do [module-name &/get-module-name class-loader &/loader] (|case (de-ann ?body) @@ -296,7 +301,7 @@ (return nil))) :let [_ (.visitEnd =class)] _ (&&/save-class! def-name (.toByteArray =class)) - def-value (install-def! class-loader current-class module-name ?name ?body ?meta exported?)] + def-value (install-def! class-loader current-class module-name ?name ?body ?meta exported? type?)] (return def-value))) _ @@ -322,7 +327,7 @@ (return nil))) :let [_ (.visitEnd =class)] _ (&&/save-class! def-name (.toByteArray =class)) - def-value (install-def! class-loader current-class module-name ?name ?body ?meta exported?)] + def-value (install-def! class-loader current-class module-name ?name ?body ?meta exported? type?)] (return def-value)))))) (defn compile-program [compile ?program] diff --git a/lux-jvm/source/luxc/lang/host/jvm.lux b/lux-jvm/source/luxc/lang/host/jvm.lux index 3b03f1510..df9575ef4 100644 --- a/lux-jvm/source/luxc/lang/host/jvm.lux +++ b/lux-jvm/source/luxc/lang/host/jvm.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Definition Type) + [lux (#- Definition Type Label) [ffi (#+ import:)] [abstract monad] diff --git a/lux-jvm/source/luxc/lang/translation/jvm/case.lux b/lux-jvm/source/luxc/lang/translation/jvm/case.lux index eb1f37f0b..4c385c0e4 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/case.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/case.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Type if let case) + [lux (#- Type Label if let case) [abstract ["." monad (#+ do)]] [control diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux index 5de412695..7db88c007 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Type) + [lux (#- Type Label) [ffi (#+ import:)] [abstract ["." monad (#+ do)]] diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux index e132e9eb9..0b3a0f9fd 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Type primitive int char type) + [lux (#- Type Label primitive int char type) [ffi (#+ import:)] [abstract ["." monad (#+ do)]] diff --git a/lux-jvm/source/luxc/lang/translation/jvm/function.lux b/lux-jvm/source/luxc/lang/translation/jvm/function.lux index df80c6088..877194de1 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/function.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/function.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Type function) + [lux (#- Type Label function) [abstract ["." monad (#+ do)] ["." enum]] diff --git a/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux index 5b1743157..a9f58e932 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Type try) + [lux (#- Type Label try) [abstract [monad (#+ do)] ["." enum]] diff --git a/stdlib/source/library/lux.lux b/stdlib/source/library/lux.lux index 20614dc2f..804c27ee5 100644 --- a/stdlib/source/library/lux.lux +++ b/stdlib/source/library/lux.lux @@ -53,7 +53,7 @@ (9 #1 (0 #1 [[dummy_location (7 #0 ["library/lux" "type_args"])] [dummy_location (9 #0 (0 #1 [dummy_location (5 #0 "a")] (0 #0)))]] (0 #0)))] - ["End" "Item"] + ("End" "Item") #1) ("lux def" Bit @@ -135,7 +135,7 @@ (9 #1 (#Item [[dummy_location (7 #0 ["library/lux" "type_args"])] [dummy_location (9 #0 (#Item [dummy_location (5 #0 "a")] #End))]] #End))] - ["None" "Some"] + ("None" "Some") #1) ... (type: .public Type @@ -196,7 +196,7 @@ ("lux type check type" (9 #0 (4 #0 1) (4 #0 0))))) [dummy_location (9 #1 #End)] - ["Primitive" "Sum" "Product" "Function" "Parameter" "Var" "Ex" "UnivQ" "ExQ" "Apply" "Named"] + ("Primitive" "Sum" "Product" "Function" "Parameter" "Var" "Ex" "UnivQ" "ExQ" "Apply" "Named") #1) ... (type: .public Location @@ -276,7 +276,7 @@ (9 #1 (#Item [[dummy_location (7 #0 ["library/lux" "type_args"])] [dummy_location (9 #0 (#Item [dummy_location (5 #0 "w")] #End))]] #End))] - ["Bit" "Nat" "Int" "Rev" "Frac" "Text" "Identifier" "Tag" "Form" "Tuple" "Record"] + ("Bit" "Nat" "Int" "Rev" "Frac" "Text" "Identifier" "Tag" "Form" "Tuple" "Record") #1) ... (type: .public Code @@ -420,15 +420,33 @@ (record$ #End) .public) +... (type: .public Label +... [Bit Type (List Text) Nat]) +("lux def" Label + ("lux type check type" + (#Named ["library/lux" "Label"] + (#Product Bit (#Product Type (#Product (#Apply Text List) Nat))))) + (record$ #End) + .public) + ... (type: .public Global -... (#Alias Alias) -... (#Definition Definition)) +... (Variant +... (#Definition Definition) +... (#Type [Bit Type (Either [Text (List Text)] [Text (List Text)])]) +... (#Tag Label) +... (#Slot Label) +... (#Alias Alias))) ("lux def type tagged" Global (#Named ["library/lux" "Global"] - (#Sum Alias - Definition)) + (#Sum Definition + (#Sum ({labels + (#Product Bit (#Product Type (#Sum labels labels)))} + (#Product Text (#Apply Text List))) + (#Sum Label + (#Sum Label + Alias))))) (record$ #End) - ["Alias" "Definition"] + ("Definition" "Type" "Label" "Slot" "Alias") .public) ... (type: .public (Bindings k v) @@ -460,7 +478,7 @@ ... Captured Nat)) (record$ #End) - ["Local" "Captured"] + ("Local" "Captured") .public) ... (type: .public Scope @@ -502,7 +520,7 @@ (record$ (#Item [(tag$ ["library/lux" "type_args"]) (tuple$ (#Item (text$ "l") (#Item (text$ "r") #End)))] #End)) - ["Left" "Right"] + ("Left" "Right") .public) ... (type: .public Source @@ -529,47 +547,39 @@ ... #Cached Any))) (record$ #End) - ["Active" "Compiled" "Cached"] + ("Active" "Compiled" "Cached") .public) ... (type: .public Module -... {#module_hash Nat -... #module_aliases (List [Text Text]) -... #definitions (List [Text Global]) -... #imports (List Text) -... #tags (List [Text [Nat (List Name) Bit Type]]) -... #types (List [Text [(List Name) Bit Type]]) -... #module_annotations (Maybe Code) -... #module_state Module_State}) +... (Record +... {#module_hash Nat +... #module_aliases (List [Text Text]) +... #definitions (List [Text Global]) +... #imports (List Text) +... #module_annotations (Maybe Code) +... #module_state Module_State})) ("lux def type tagged" Module (#Named ["library/lux" "Module"] - (#Product ... "lux.module_hash" + (#Product + ... "lux.module_hash" Nat - (#Product ... "lux.module_aliases" + (#Product + ... "lux.module_aliases" (#Apply (#Product Text Text) List) - (#Product ... "lux.definitions" + (#Product + ... "lux.definitions" (#Apply (#Product Text Global) List) - (#Product ... "lux.imports" + (#Product + ... "lux.imports" (#Apply Text List) - (#Product ... "lux.tags" - (#Apply (#Product Text - (#Product Nat - (#Product (#Apply Name List) - (#Product Bit - Type)))) - List) - (#Product ... "lux.types" - (#Apply (#Product Text - (#Product (#Apply Name List) - (#Product Bit - Type))) - List) - (#Product ... "lux.module_annotations" - (#Apply Code Maybe) - Module_State)) - )))))) + (#Product + ... "lux.module_annotations" + (#Apply Code Maybe) + ... module_state + Module_State) + ))))) (record$ #End) - ["module_hash" "module_aliases" "definitions" "imports" "tags" "types" "module_annotations" "module_state"] + ["module_hash" "module_aliases" "definitions" "imports" "module_annotations" "module_state"] .public) ... (type: .public Type_Context @@ -602,7 +612,7 @@ ... Interpreter Any))) (record$ #End) - ["Build" "Eval" "Interpreter"] + ("Build" "Eval" "Interpreter") .public) ... (type: .public Info @@ -1668,13 +1678,22 @@ #scopes scopes #type_context types #host host #seed seed #expected expected #location location #extensions extensions #scope_type_vars scope_type_vars #eval _eval} state] - ({(#Some {#module_hash _ #module_aliases _ #definitions definitions #imports _ #tags tags #types types #module_annotations _ #module_state _}) + ({(#Some {#module_hash _ #module_aliases _ #definitions definitions #imports _ #module_annotations _ #module_state _}) ({(#Some constant) - ({(#Left real_name) + ({(#Alias real_name) (#Right [state real_name]) - (#Right [exported? def_type def_meta def_value]) - (#Right [state full_name])} + (#Definition [exported? def_type def_meta def_value]) + (#Right [state full_name]) + + (#Type [exported? type labels]) + (#Right [state full_name]) + + (#Label _) + (#Left ($_ text\composite "Unknown definition: " (name\encoded full_name))) + + (#Slot _) + (#Left ($_ text\composite "Unknown definition: " (name\encoded full_name)))} constant) #None @@ -2189,26 +2208,35 @@ #0} type)) -(def:''' .private (macro' modules current_module module name) +(def:''' .private (macro'' modules current_module module name) #End (-> ($' List (Tuple Text Module)) Text Text Text ($' Maybe Macro)) (do maybe_monad [$module (plist\value module modules) - gdef (let' [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags #types types #module_annotations _ #module_state _} ("lux type check" Module $module)] + gdef (let' [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #module_annotations _ #module_state _} ("lux type check" Module $module)] (plist\value name bindings))] - ({(#Left [r_module r_name]) - (macro' modules current_module r_module r_name) + ({(#Alias [r_module r_name]) + (macro'' modules current_module r_module r_name) - (#Right [exported? def_type def_meta def_value]) + (#Definition [exported? def_type def_meta def_value]) (if (macro_type? def_type) (if exported? (#Some ("lux type as" Macro def_value)) (if (text\= module current_module) (#Some ("lux type as" Macro def_value)) #None)) - #None)} + #None) + + (#Type [exported? type labels]) + #None + + (#Label _) + #None + + (#Slot _) + #None} ("lux type check" Global gdef)))) (def:''' .private (normal name) @@ -2223,7 +2251,7 @@ (in_meta name)} name)) -(def:''' .private (macro full_name) +(def:''' .private (macro' full_name) #End (-> Name ($' Meta ($' Maybe Macro))) (do meta_monad @@ -2235,7 +2263,7 @@ #seed seed #expected expected #location location #extensions extensions #scope_type_vars scope_type_vars #eval _eval} - (#Right state (macro' modules current_module module name))} + (#Right state (macro'' modules current_module module name))} state))))) (def:''' .private (macro? name) @@ -2243,7 +2271,7 @@ (-> Name ($' Meta Bit)) (do meta_monad [name (normal name) - output (macro name)] + output (macro' name)] (in ({(#Some _) #1 #None #0} output)))) @@ -2268,7 +2296,7 @@ ({[_ (#Form (#Item [_ (#Identifier name)] args))] (do meta_monad [name' (normal name) - ?macro (macro name')] + ?macro (macro' name')] ({(#Some macro) (("lux type as" Macro' macro) args) @@ -2286,7 +2314,7 @@ ({[_ (#Form (#Item [_ (#Identifier name)] args))] (do meta_monad [name' (normal name) - ?macro (macro name')] + ?macro (macro' name')] ({(#Some macro) (do meta_monad [top_level_expansion (("lux type as" Macro' macro) args) @@ -2307,7 +2335,7 @@ ({[_ (#Form (#Item [_ (#Identifier name)] args))] (do meta_monad [name' (normal name) - ?macro (macro name')] + ?macro (macro' name')] ({(#Some macro) (do meta_monad [expansion (("lux type as" Macro' macro) args) @@ -3270,17 +3298,22 @@ _ (#Left ($_ text\composite "Unknown module: " name)))))) -(def: (type_tag [module name]) +(def: (type_slot [module name]) (-> Name (Meta [Nat (List Name) Bit Type])) (do meta_monad [=module (..module module) - .let [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags_table #types types #module_annotations _ #module_state _} =module]] - (case (plist\value name tags_table) - (#Some output) - (in_meta output) + .let [{#module_hash _ #module_aliases _ #definitions definitions #imports _ #module_annotations _ #module_state _} =module]] + (case (plist\value (text\composite "#" name) definitions) + (#Some (#Slot [exported type group index])) + (in_meta [index + (list\each (function (_ slot) + [module slot]) + group) + exported + type]) _ - (failure (text\composite "Unknown tag: " (name\encoded [module name])))))) + (failure (text\composite "Unknown slot: " (name\encoded [module name])))))) (def: (record_slots type) (-> Type (Meta (Maybe [(List Name) (List Type)]))) @@ -3297,12 +3330,14 @@ (#Named [module name] unnamed) (do meta_monad [=module (..module module) - .let [{#module_hash _ #module_aliases _ #definitions bindings #imports _ #tags tags #types types #module_annotations _ #module_state _} =module]] - (case (plist\value name types) - (#Some [tags exported? (#Named _ _type)]) + .let [{#module_hash _ #module_aliases _ #definitions definitions #imports _ #module_annotations _ #module_state _} =module]] + (case (plist\value name definitions) + (#Some (#Type [exported? (#Named _ _type) (#Right slots)])) (case (interface_methods _type) (#Some members) - (in_meta (#Some [tags members])) + (in_meta (#Some [(list\each (function (_ slot) [module slot]) + (#Item slots)) + members])) _ (in_meta #None)) @@ -3520,9 +3555,9 @@ (case (everyP caseP tokens) (#Some cases) (in_meta (list (` (..Union (~+ (list\each product\right cases)))) - (tuple$ (list\each (function (_ case) - (text$ (product\left case))) - cases)))) + (form$ (list\each (function (_ case) + (text$ (product\left case))) + cases)))) #None (failure "Wrong syntax for Variant"))) @@ -3616,15 +3651,23 @@ #None)) (def: (type_declaration it) - (-> Code (Meta (Tuple Code (Maybe (List Text))))) + (-> Code (Meta (Tuple Code (Maybe (Either (List Text) (List Text)))))) ({[_ (#Form (#Item [_ (#Identifier declarer)] parameters))] (do meta_monad [declaration (single_expansion (form$ (list& (identifier$ declarer) parameters)))] (case declaration - (^ (list type [_ (#Tuple tags)])) + (^ (list type [_ (#Form tags)])) (case (everyP textP tags) (#Some tags) - (in_meta [type (#Some tags)]) + (in_meta [type (#Some (#Left tags))]) + + #None + (failure "Improper type-definition syntax")) + + (^ (list type [_ (#Tuple slots)])) + (case (everyP textP slots) + (#Some slots) + (in_meta [type (#Some (#Right slots))]) #None (failure "Improper type-definition syntax")) @@ -3643,10 +3686,10 @@ (case (typeP tokens) (#Some [export_policy name args meta type_codes]) (do meta_monad - [type+tags?? (..type_declaration type_codes) + [type+labels?? (..type_declaration type_codes) module_name current_module_name .let' [type_name (local_identifier$ name) - [type tags??] type+tags?? + [type labels??] type+labels?? type' (: (Maybe Code) (case args #End @@ -3663,13 +3706,22 @@ (let [typeC (` (#.Named [(~ (text$ module_name)) (~ (text$ name))] (.type (~ type''))))] - (in_meta (list (case tags?? - (#Some tags) - (` ("lux def type tagged" (~ type_name) - (~ typeC) - (~ total_meta) - [(~+ (list\each text$ tags))] - (~ export_policy))) + (in_meta (list (case labels?? + (#Some labels) + (case labels + (#Left tags) + (` ("lux def type tagged" (~ type_name) + (~ typeC) + (~ total_meta) + ((~+ (list\each text$ tags))) + (~ export_policy))) + + (#Right slots) + (` ("lux def type tagged" (~ type_name) + (~ typeC) + (~ total_meta) + [(~+ (list\each text$ slots))] + (~ export_policy)))) _ (` ("lux def" (~ type_name) @@ -3980,14 +4032,25 @@ (List Text)) (function (_ [name definition]) (case definition - (#Left _) + (#Alias _) (list) - (#Right [exported? def_type def_meta def_value]) + (#Definition [exported? def_type def_meta def_value]) + (if exported? + (list name) + (list)) + + (#Type [exported? type labels]) (if exported? (list name) - (list))))) - (let [{#module_hash _ #module_aliases _ #definitions definitions #imports _ #tags tags #types types #module_annotations _ #module_state _} =module] + (list)) + + (#Label _) + (list) + + (#Slot _) + (list)))) + (let [{#module_hash _ #module_aliases _ #definitions definitions #imports _ #module_annotations _ #module_state _} =module] definitions))] (#Right state (list\conjoint to_alias))) @@ -4069,18 +4132,27 @@ #None #None - (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #tags tags #types types #module_annotations _ #module_state _}) + (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #module_annotations _ #module_state _}) (case (plist\value v_name definitions) #None #None (#Some definition) (case definition - (#Left real_name) + (#Alias real_name) (definition_type real_name state) - (#Right [exported? def_type def_meta def_value]) - (#Some def_type)))))) + (#Definition [exported? def_type def_meta def_value]) + (#Some def_type) + + (#Type [exported? type labels]) + (#Some ..Type) + + (#Label _) + #None + + (#Slot _) + #None))))) (def: (definition_value name state) (-> Name (Meta [Type Any])) @@ -4093,18 +4165,27 @@ #None (#Left (text\composite "Unknown definition: " (name\encoded name))) - (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #tags tags #types types #module_annotations _ #module_state _}) + (#Some {#definitions definitions #module_hash _ #module_aliases _ #imports _ #module_annotations _ #module_state _}) (case (plist\value v_name definitions) #None (#Left (text\composite "Unknown definition: " (name\encoded name))) (#Some definition) (case definition - (#Left real_name) + (#Alias real_name) (definition_value real_name state) - (#Right [exported? def_type def_meta def_value]) - (#Right [state [def_type def_value]])))))) + (#Definition [exported? def_type def_meta def_value]) + (#Right [state [def_type def_value]]) + + (#Type [exported? type labels]) + (#Right [state [..Type type]]) + + (#Label _) + (#Left (text\composite "Unknown definition: " (name\encoded name))) + + (#Slot _) + (#Left (text\composite "Unknown definition: " (name\encoded name)))))))) (def: (type_variable idx bindings) (-> Nat (List [Nat (Maybe Type)]) (Maybe Type)) @@ -4254,7 +4335,7 @@ (^ (list [_ (#Tag slot')] record)) (do meta_monad [slot (normal slot') - output (..type_tag slot) + output (..type_slot slot) .let [[idx tags exported? type] output] g!_ (..identifier "_") g!output (..identifier "")] @@ -4366,7 +4447,7 @@ (-> Text Text (Meta Bit)) (do meta_monad [module (module module_name) - .let [{#module_hash _ #module_aliases _ #definitions _ #imports imports #tags _ #types _ #module_annotations _ #module_state _} module]] + .let [{#module_hash _ #module_aliases _ #definitions _ #imports imports #module_annotations _ #module_state _} module]] (in (is_member? imports import_name)))) (def: (referrals module_name options) @@ -4514,7 +4595,7 @@ (^ (list [_ (#Tag slot')] value record)) (do meta_monad [slot (normal slot') - output (..type_tag slot) + output (..type_slot slot) .let [[idx tags exported? type] output]] (case (interface_methods type) (#Some members) @@ -4593,7 +4674,7 @@ (^ (list [_ (#Tag slot')] fun record)) (do meta_monad [slot (normal slot') - output (..type_tag slot) + output (..type_slot slot) .let [[idx tags exported? type] output]] (case (interface_methods type) (#Some members) @@ -4798,7 +4879,7 @@ .let [[hslot tslots] slots] hslot (..normal hslot) tslots (monad\each meta_monad ..normal tslots) - output (..type_tag hslot) + output (..type_slot hslot) g!_ (..identifier "_") .let [[idx tags exported? type] output slot_pairings (list\each (: (-> Name [Text Code]) @@ -5520,3 +5601,7 @@ _ (failure "Wrong syntax for Rec"))) + +(def: .public macro + (-> Macro Macro') + (|>> (:as Macro'))) diff --git a/stdlib/source/library/lux/control/function/mutual.lux b/stdlib/source/library/lux/control/function/mutual.lux index 3d26dedd1..5ef853829 100644 --- a/stdlib/source/library/lux/control/function/mutual.lux +++ b/stdlib/source/library/lux/control/function/mutual.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Definition let def:) + [lux (#- Definition let def: macro) ["." meta] [abstract ["." monad (#+ do)]] diff --git a/stdlib/source/library/lux/control/parser/binary.lux b/stdlib/source/library/lux/control/parser/binary.lux index 409d2a872..6c0f82a06 100644 --- a/stdlib/source/library/lux/control/parser/binary.lux +++ b/stdlib/source/library/lux/control/parser/binary.lux @@ -110,16 +110,28 @@ [(do {! //.monad} [flag (: (Parser Nat) ..bits/8)] - (`` (case flag - (^template [<number> <tag> <parser>] - [<number> (\ ! each (|>> <tag>) <parser>)]) - ((~~ (template.spliced <case>+))) - _ (//.lifted (exception.except ..invalid_tag [(~~ (template.amount <case>+)) flag])))))]) + (with_expansions [<case>+' (template.spliced <case>+)] + (case flag + (^template [<number> <tag> <parser>] + [<number> (`` (\ ! each (|>> ((~~ (template.spliced <tag>)))) <parser>))]) + (<case>+') + + _ (//.lifted (exception.except ..invalid_tag [(template.amount [<case>+]) flag])))))]) (def: .public (or left right) (All (_ l r) (-> (Parser l) (Parser r) (Parser (Or l r)))) - (!variant [[0 #.Left left] - [1 #.Right right]])) + (!variant [[0 [#.Left] left] + [1 [#.Right] right]])) + +(def: .public (or/5 p/0 p/1 p/2 p/3 p/4) + (All (_ p/0 p/1 p/2 p/3 p/4) + (-> (Parser p/0) (Parser p/1) (Parser p/2) (Parser p/3) (Parser p/4) + (Parser (Or p/0 p/1 p/2 p/3 p/4)))) + (!variant [[0 [0 #0] p/0] + [1 [1 #0] p/1] + [2 [2 #0] p/2] + [3 [3 #0] p/3] + [4 [3 #1] p/4]])) (def: .public (rec body) (All (_ a) (-> (-> (Parser a) (Parser a)) (Parser a))) @@ -242,17 +254,17 @@ (let [pair (//.and type type) indexed ..nat quantified (//.and (..list type) type)] - (!variant [[0 #.Primitive (//.and ..text (..list type))] - [1 #.Sum pair] - [2 #.Product pair] - [3 #.Function pair] - [4 #.Parameter indexed] - [5 #.Var indexed] - [6 #.Ex indexed] - [7 #.UnivQ quantified] - [8 #.ExQ quantified] - [9 #.Apply pair] - [10 #.Named (//.and ..name type)]]))))) + (!variant [[0 [#.Primitive] (//.and ..text (..list type))] + [1 [#.Sum] pair] + [2 [#.Product] pair] + [3 [#.Function] pair] + [4 [#.Parameter] indexed] + [5 [#.Var] indexed] + [6 [#.Ex] indexed] + [7 [#.UnivQ] quantified] + [8 [#.ExQ] quantified] + [9 [#.Apply] pair] + [10 [#.Named] (//.and ..name type)]]))))) (def: .public location (Parser Location) @@ -264,14 +276,14 @@ (function (_ recur) (let [sequence (..list recur)] (//.and ..location - (!variant [[0 #.Bit ..bit] - [1 #.Nat ..nat] - [2 #.Int ..int] - [3 #.Rev ..rev] - [4 #.Frac ..frac] - [5 #.Text ..text] - [6 #.Identifier ..name] - [7 #.Tag ..name] - [8 #.Form sequence] - [9 #.Tuple sequence] - [10 #.Record (..list (//.and recur recur))]])))))) + (!variant [[0 [#.Bit] ..bit] + [1 [#.Nat] ..nat] + [2 [#.Int] ..int] + [3 [#.Rev] ..rev] + [4 [#.Frac] ..frac] + [5 [#.Text] ..text] + [6 [#.Identifier] ..name] + [7 [#.Tag] ..name] + [8 [#.Form] sequence] + [9 [#.Tuple] sequence] + [10 [#.Record] (..list (//.and recur recur))]])))))) diff --git a/stdlib/source/library/lux/data/format/binary.lux b/stdlib/source/library/lux/data/format/binary.lux index 109b1c19d..8ffed2724 100644 --- a/stdlib/source/library/lux/data/format/binary.lux +++ b/stdlib/source/library/lux/data/format/binary.lux @@ -98,6 +98,29 @@ [1 #.Right right]) ))) +(def: .public (or/5 w/0 w/1 w/2 w/3 w/4) + (All (_ w/0 w/1 w/2 w/3 w/4) + (-> (Writer w/0) (Writer w/1) (Writer w/2) (Writer w/3) (Writer w/4) + (Writer (Or w/0 w/1 w/2 w/3 w/4)))) + (function (_ altV) + (case altV + (^template [<number> <tag> <right?> <writer>] + [(<tag> <right?> caseV) + (let [[caseS caseT] (<writer> caseV)] + [(.++ caseS) + (function (_ [offset binary]) + (|> binary + (binary.write/8! offset <number>) + try.trusted + [(.++ offset)] + caseT))])]) + ([0 0 #0 w/0] + [1 1 #0 w/1] + [2 2 #0 w/2] + [3 3 #0 w/3] + [4 3 #1 w/4]) + ))) + (def: .public (and pre post) (All (_ a b) (-> (Writer a) (Writer b) (Writer [a b]))) (function (_ [preV postV]) diff --git a/stdlib/source/library/lux/macro/template.lux b/stdlib/source/library/lux/macro/template.lux index 65b4f96ba..3c18f9f9e 100644 --- a/stdlib/source/library/lux/macro/template.lux +++ b/stdlib/source/library/lux/macro/template.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- let local) + [lux (#- let local macro) ["." meta] [abstract ["." monad (#+ do)]] diff --git a/stdlib/source/library/lux/meta.lux b/stdlib/source/library/lux/meta.lux index 208663367..f19bc2964 100644 --- a/stdlib/source/library/lux/meta.lux +++ b/stdlib/source/library/lux/meta.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- type) + [lux (#- type macro) [abstract [functor (#+ Functor)] [apply (#+ Apply)] @@ -189,7 +189,16 @@ (#.Definition [exported? def_type def_anns def_value]) (if (macro_type? def_type) (#.Some (:as Macro def_value)) - #.None))))))]))))) + #.None) + + (#.Type [exported? type labels]) + #.None + + (#.Label _) + #.None + + (#.Slot _) + #.None)))))]))))) (def: .public seed (Meta Nat) @@ -315,13 +324,20 @@ (value@ #.definitions) (list.all (function (_ [def_name global]) (case global - (#.Definition [exported? _ _ _]) + (^or (#.Definition [exported? _]) + (#.Type [exported? _])) (if (and exported? (text\= normal_short def_name)) (#.Some (name\encoded [module_name def_name])) #.None) (#.Alias _) + #.None + + (#.Label _) + #.None + + (#.Slot _) #.None)))))) list.together (list.sorted text\<) @@ -348,27 +364,55 @@ (do ..monad [definition (..definition name)] (case definition - (#.Left de_aliased) - (failure ($_ text\composite - "Aliases are not considered exports: " - (name\encoded name))) - - (#.Right definition) + (#.Definition definition) (let [[exported? def_type def_data def_value] definition] (if exported? (in definition) - (failure ($_ text\composite "Definition is not an export: " (name\encoded name)))))))) + (failure ($_ text\composite "Definition is not an export: " (name\encoded name))))) + + (#.Type [exported? type labels]) + (if exported? + (in [exported? .Type (' {}) type]) + (failure ($_ text\composite "Type is not an export: " (name\encoded name)))) + + (#.Alias de_aliased) + (failure ($_ text\composite + "Aliases are not considered exports: " + (name\encoded name))) + + (#.Label _) + (failure ($_ text\composite + "Tags are not considered exports: " + (name\encoded name))) + + (#.Slot _) + (failure ($_ text\composite + "Slots are not considered exports: " + (name\encoded name)))))) (def: .public (definition_type name) (-> Name (Meta Type)) (do ..monad [definition (definition name)] (case definition - (#.Left de_aliased) + (#.Alias de_aliased) (definition_type de_aliased) - (#.Right [exported? def_type def_data def_value]) - (clean_type def_type)))) + (#.Definition [exported? def_type def_data def_value]) + (clean_type def_type) + + (#.Type [exported? type labels]) + (in .Type) + + (#.Label _) + (failure ($_ text\composite + "Tags have no type: " + (name\encoded name))) + + (#.Slot _) + (failure ($_ text\composite + "Slots have no type: " + (name\encoded name)))))) (def: .public (type name) (-> Name (Meta Type)) @@ -385,17 +429,26 @@ (do ..monad [definition (definition name)] (case definition - (#.Left de_aliased) + (#.Alias de_aliased) (type_definition de_aliased) - (#.Right [exported? def_type def_data def_value]) + (#.Definition [exported? def_type def_data def_value]) (let [type_code (`` ("lux in-module" (~~ (static .prelude_module)) .type_code))] (if (or (same? .Type def_type) (\ code.equivalence = (type_code .Type) (type_code def_type))) (in (:as Type def_value)) - (..failure ($_ text\composite "Definition is not a type: " (name\encoded name)))))))) + (..failure ($_ text\composite "Definition is not a type: " (name\encoded name))))) + + (#.Type [exported? type labels]) + (in type) + + (#.Label _) + (..failure ($_ text\composite "Tag is not a type: " (name\encoded name))) + + (#.Slot _) + (..failure ($_ text\composite "Slot is not a type: " (name\encoded name)))))) (def: .public (globals module) (-> Text (Meta (List [Text Global]))) @@ -412,11 +465,20 @@ (\ ..monad each (list.all (function (_ [name global]) (case global - (#.Left de_aliased) + (#.Alias de_aliased) #.None - (#.Right definition) - (#.Some [name definition])))) + (#.Definition definition) + (#.Some [name definition]) + + (#.Type [exported? type labels]) + (#.Some [name [exported? .Type (' {}) type]]) + + (#.Label _) + #.None + + (#.Slot _) + #.None))) (..globals module))) (def: .public (exports module_name) @@ -440,11 +502,12 @@ (def: .public (tags_of type_name) (-> Name (Meta (Maybe (List Name)))) (do ..monad - [.let [[module name] type_name] - module (..module module)] - (case (plist.value name (value@ #.types module)) - (#.Some [tags _]) - (in (#.Some tags)) + [.let [[module_name name] type_name] + module (..module module_name)] + (case (plist.value name (value@ #.definitions module)) + (#.Some (#.Type [exported? type (#.Right slots)])) + (in (#.Some (list\each (|>> [module_name]) + (#.Item slots)))) _ (in #.None)))) @@ -489,33 +552,41 @@ =module (..module module) this_module_name ..current_module_name imported! (..imported? module)] - (case (plist.value name (value@ #.tags =module)) - (#.Some [idx tag_list exported? type]) + (case (plist.value (text\composite "#" name) (value@ #.definitions =module)) + (^or (#.Some (#.Label [exported? type group idx])) + (#.Some (#.Slot [exported? type group idx]))) (if (or (text\= this_module_name module) (and imported! exported?)) - (in [idx tag_list type]) + (in [idx (list\each (|>> [module]) group) type]) (..failure ($_ text\composite "Cannot access tag: " (name\encoded tag_name) " from module " this_module_name))) _ (..failure ($_ text\composite - "Unknown tag: " (name\encoded tag_name) text.new_line - " Known tags: " (|> =module - (value@ #.tags) - (list\each (|>> product.left [module] name\encoded (text.prefix text.new_line))) - text.together) - ))))) + "Unknown tag: " (name\encoded tag_name)))))) (def: .public (tag_lists module) (-> Text (Meta (List [(List Name) Type]))) (do ..monad [=module (..module module) this_module_name ..current_module_name] - (in (|> (value@ #.types =module) - (list.only (function (_ [type_name [tag_list exported? type]]) - (or exported? - (text\= this_module_name module)))) - (list\each (function (_ [type_name [tag_list exported? type]]) - [tag_list type])))))) + (in (list.all (function (_ [short global]) + (case global + (#.Type [exported? type labels]) + (if (or exported? + (text\= this_module_name module)) + (#.Some [(list\each (|>> [module]) + (case labels + (#.Left tags) + (#.Item tags) + + (#.Right slots) + (#.Item slots))) + type]) + #.None) + + _ + #.None)) + (value@ #.definitions =module))))) (def: .public locals (Meta (List (List [Text Type]))) @@ -536,10 +607,19 @@ (do ..monad [constant (..definition def_name)] (in (case constant - (#.Left real_def_name) + (#.Alias real_def_name) real_def_name - (#.Right _) + (#.Definition _) + def_name + + (#.Type _) + def_name + + (#.Label _) + def_name + + (#.Slot _) def_name)))) (def: .public compiler_state diff --git a/stdlib/source/library/lux/target/js.lux b/stdlib/source/library/lux/target/js.lux index 07318b451..62ce204c5 100644 --- a/stdlib/source/library/lux/target/js.lux +++ b/stdlib/source/library/lux/target/js.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Location Code or and function if cond undefined for comment not int try ++ --) + [lux (#- Location Code Label or and function if cond undefined for comment not int try ++ --) [control [pipe (#+ case>)]] [data diff --git a/stdlib/source/library/lux/target/jvm.lux b/stdlib/source/library/lux/target/jvm.lux index ce273f401..50543961c 100644 --- a/stdlib/source/library/lux/target/jvm.lux +++ b/stdlib/source/library/lux/target/jvm.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Type) + [lux (#- Type Label) [data [collection [row (#+ Row)]]] diff --git a/stdlib/source/library/lux/target/jvm/bytecode.lux b/stdlib/source/library/lux/target/jvm/bytecode.lux index 9c106e442..53886c7b5 100644 --- a/stdlib/source/library/lux/target/jvm/bytecode.lux +++ b/stdlib/source/library/lux/target/jvm/bytecode.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Type int try) + [lux (#- Type Label int try) ["." ffi (#+ import:)] [abstract [monoid (#+ Monoid)] diff --git a/stdlib/source/library/lux/target/jvm/reflection.lux b/stdlib/source/library/lux/target/jvm/reflection.lux index 3fdf491bc..55316e26f 100644 --- a/stdlib/source/library/lux/target/jvm/reflection.lux +++ b/stdlib/source/library/lux/target/jvm/reflection.lux @@ -174,7 +174,7 @@ (do {! try.monad} [paramsT (|> reflection java/lang/reflect/ParameterizedType::getActualTypeArguments - array.list + (array.list #.None) (monad.each ! parameter))] (in (/.class (|> raw (:as (java/lang/Class java/lang/Object)) @@ -297,7 +297,7 @@ (case type (#.Primitive name params) (let [class_name (java/lang/Class::getName class) - class_params (array.list (java/lang/Class::getTypeParameters class)) + class_params (array.list #.None (java/lang/Class::getTypeParameters class)) num_class_params (list.size class_params) num_type_params (list.size params)] (if (text\= class_name name) @@ -360,7 +360,7 @@ (def: .public deprecated? (-> (array.Array java/lang/annotation/Annotation) Bit) - (|>> array.list + (|>> (array.list #.None) (list.all (|>> (ffi.check java/lang/Deprecated))) list.empty? not)) diff --git a/stdlib/source/library/lux/target/lua.lux b/stdlib/source/library/lux/target/lua.lux index 42d8d60e5..faac1b184 100644 --- a/stdlib/source/library/lux/target/lua.lux +++ b/stdlib/source/library/lux/target/lua.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Location Code int if cond function or and not let ^ local) + [lux (#- Location Code Label int if cond function or and not let ^ local) ["@" target] [abstract [equivalence (#+ Equivalence)] diff --git a/stdlib/source/library/lux/target/php.lux b/stdlib/source/library/lux/target/php.lux index 0e228dc57..a14b3e0ce 100644 --- a/stdlib/source/library/lux/target/php.lux +++ b/stdlib/source/library/lux/target/php.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Location Code Global static int if cond or and not comment for try global) + [lux (#- Location Code Global Label static int if cond or and not comment for try global) ["@" target] [abstract [equivalence (#+ Equivalence)] diff --git a/stdlib/source/library/lux/target/python.lux b/stdlib/source/library/lux/target/python.lux index 8a41d3ae8..6b24b6ae2 100644 --- a/stdlib/source/library/lux/target/python.lux +++ b/stdlib/source/library/lux/target/python.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Location Code not or and list if cond int comment exec try) + [lux (#- Location Code Label not or and list if cond int comment exec try) ["@" target] ["." ffi] [abstract diff --git a/stdlib/source/library/lux/tool/compiler/language/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux.lux index e86bd51aa..5bb42e533 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux.lux @@ -24,24 +24,23 @@ (Writer .Module) (let [definition (: (Writer Definition) ($_ _.and _.bit _.type _.code _.any)) + labels (: (Writer [Text (List Text)]) + (_.and _.text (_.list _.text))) + global_type (: (Writer [Bit Type (Either [Text (List Text)] + [Text (List Text)])]) + ($_ _.and _.bit _.type (_.or labels labels))) + global_label (: (Writer .Label) + ($_ _.and _.bit _.type (_.list _.text) _.nat)) name (: (Writer Name) (_.and _.text _.text)) alias (: (Writer Alias) (_.and _.text _.text)) global (: (Writer Global) - (_.or alias - definition)) - tag (: (Writer [Nat (List Name) Bit Type]) - ($_ _.and - _.nat - (_.list name) - _.bit - _.type)) - type (: (Writer [(List Name) Bit Type]) - ($_ _.and - (_.list name) - _.bit - _.type))] + (_.or/5 definition + global_type + global_label + global_label + alias))] ($_ _.and ... #module_hash _.nat @@ -51,10 +50,6 @@ (_.list (_.and _.text global)) ... #imports (_.list _.text) - ... #tags - (_.list (_.and _.text tag)) - ... #types - (_.list (_.and _.text type)) ... #module_annotations (_.maybe _.code) ... #module_state @@ -64,24 +59,23 @@ (Parser .Module) (let [definition (: (Parser Definition) ($_ <>.and <b>.bit <b>.type <b>.code <b>.any)) + labels (: (Parser [Text (List Text)]) + (<>.and <b>.text (<b>.list <b>.text))) + global_type (: (Parser [Bit Type (Either [Text (List Text)] + [Text (List Text)])]) + ($_ <>.and <b>.bit <b>.type (<b>.or labels labels))) + global_label (: (Parser .Label) + ($_ <>.and <b>.bit <b>.type (<b>.list <b>.text) <b>.nat)) name (: (Parser Name) (<>.and <b>.text <b>.text)) alias (: (Parser Alias) (<>.and <b>.text <b>.text)) global (: (Parser Global) - (<b>.or alias - definition)) - tag (: (Parser [Nat (List Name) Bit Type]) - ($_ <>.and - <b>.nat - (<b>.list name) - <b>.bit - <b>.type)) - type (: (Parser [(List Name) Bit Type]) - ($_ <>.and - (<b>.list name) - <b>.bit - <b>.type))] + (<b>.or/5 definition + global_type + global_label + global_label + alias))] ($_ <>.and ... #module_hash <b>.nat @@ -91,10 +85,6 @@ (<b>.list (<>.and <b>.text global)) ... #imports (<b>.list <b>.text) - ... #tags - (<b>.list (<>.and <b>.text tag)) - ... #types - (<b>.list (<>.and <b>.text type)) ... #module_annotations (<b>.maybe <b>.code) ... #module_state diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux index 42dc67db6..b6817b6c8 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux @@ -28,11 +28,6 @@ (exception.report ["Module" module])) -(exception: .public (cannot_declare_tag_twice {module Text} {tag Text}) - (exception.report - ["Module" module] - ["Tag" tag])) - (template [<name>] [(exception: .public (<name> {tags (List Text)} {owner Type}) (exception.report @@ -51,7 +46,16 @@ (format "alias " (%.name alias)) (#.Definition definition) - (format "definition " (%.name name)))])) + (format "definition " (%.name name)) + + (#.Type _) + (format "type " (%.name name)) + + (#.Label _) + (format "tag " (%.name name)) + + (#.Slot _) + (format "slot " (%.name name)))])) (exception: .public (can_only_change_state_of_active_module {module Text} {state Module_State}) (exception.report @@ -73,8 +77,6 @@ #.module_aliases (list) #.definitions (list) #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}) @@ -211,41 +213,20 @@ [set_cached cached? #.Cached] ) -(template [<name> <tag> <type>] - [(def: (<name> module_name) - (-> Text (Operation <type>)) - (///extension.lifted - (function (_ state) - (case (|> state (value@ #.modules) (plist.value module_name)) - (#.Some module) - (#try.Success [state (value@ <tag> module)]) - - #.None - ((/.except' unknown_module module_name) state)))))] +(def: (hash module_name) + (-> Text (Operation Nat)) + (///extension.lifted + (function (_ state) + (case (|> state (value@ #.modules) (plist.value module_name)) + (#.Some module) + (#try.Success [state (value@ #.module_hash module)]) - [tags #.tags (List [Text [Nat (List Name) Bit Type]])] - [types #.types (List [Text [(List Name) Bit Type]])] - [hash #.module_hash Nat] - ) + #.None + ((/.except' unknown_module module_name) state))))) -(def: (ensure_undeclared_tags module_name tags) - (-> Text (List Tag) (Operation Any)) +(def: .public (declare_tags record? tags exported? type) + (-> Bit (List Tag) Bit Type (Operation Any)) (do {! ///.monad} - [bindings (..tags module_name) - _ (monad.each ! - (function (_ tag) - (case (plist.value tag bindings) - #.None - (in []) - - (#.Some _) - (/.except ..cannot_declare_tag_twice [module_name tag]))) - tags)] - (in []))) - -(def: .public (declare_tags tags exported? type) - (-> (List Tag) Bit Type (Operation Any)) - (do ///.monad [self_name (///extension.lifted meta.current_module_name) [type_module type_name] (case type (#.Named type_name _) @@ -253,23 +234,11 @@ _ (/.except ..cannot_declare_tags_for_unnamed_type [tags type])) - _ (ensure_undeclared_tags self_name tags) _ (///.assertion cannot_declare_tags_for_foreign_type [tags type] (text\= self_name type_module))] - (///extension.lifted - (function (_ state) - (case (|> state (value@ #.modules) (plist.value self_name)) - (#.Some module) - (let [namespaced_tags (list\each (|>> [self_name]) tags)] - (#try.Success [(revised@ #.modules - (plist.revised self_name - (|>> (revised@ #.tags (function (_ tag_bindings) - (list\mix (function (_ [idx tag] table) - (plist.has tag [idx namespaced_tags exported? type] table)) - tag_bindings - (list.enumeration tags)))) - (revised@ #.types (plist.has type_name [namespaced_tags exported? type])))) - state) - []])) - #.None - ((/.except' unknown_module self_name) state)))))) + (monad.each ! (function (_ [index short]) + (..define (format "#" short) + (if record? + (#.Slot [exported? type tags index]) + (#.Label [exported? type tags index])))) + (list.enumeration tags)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux index 92a7a8f9c..d7d19e802 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux @@ -29,16 +29,20 @@ (exception.report ["Definition" (%.name definition)])) +(exception: .public (labels_are_not_definitions {definition Name}) + (exception.report + ["Label" (%.name definition)])) + (def: (definition def_name) (-> Name (Operation Analysis)) (with_expansions [<return> (in (|> def_name ///reference.constant #/.Reference))] (do {! ///.monad} [constant (///extension.lifted (meta.definition def_name))] (case constant - (#.Left real_def_name) + (#.Alias real_def_name) (definition real_def_name) - (#.Right [exported? actualT def_anns _]) + (#.Definition [exported? actualT def_anns _]) (do ! [_ (//type.infer actualT) (^@ def_name [::module ::name]) (///extension.lifted (meta.normal def_name)) @@ -51,7 +55,28 @@ (if imported! <return> (/.except foreign_module_has_not_been_imported [current ::module]))) - (/.except definition_has_not_been_exported def_name)))))))) + (/.except definition_has_not_been_exported def_name)))) + + (#.Type [exported? value labels]) + (do ! + [_ (//type.infer .Type) + (^@ def_name [::module ::name]) (///extension.lifted (meta.normal def_name)) + current (///extension.lifted meta.current_module_name)] + (if (text\= current ::module) + <return> + (if exported? + (do ! + [imported! (///extension.lifted (meta.imported_by? ::module current))] + (if imported! + <return> + (/.except foreign_module_has_not_been_imported [current ::module]))) + (/.except definition_has_not_been_exported def_name)))) + + (#.Label _) + (/.except labels_are_not_definitions [def_name]) + + (#.Slot _) + (/.except labels_are_not_definitions [def_name]))))) (def: (variable var_name) (-> Text (Operation (Maybe Analysis))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux index d3384588e..30da17c13 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux @@ -876,13 +876,13 @@ (in [[super_name superT] (java/lang/Class::isAssignableFrom super_class target_class)]))) (case (java/lang/Class::getGenericSuperclass source_class) (#.Some super) - (list& super (array.list (java/lang/Class::getGenericInterfaces source_class))) + (list& super (array.list #.None (java/lang/Class::getGenericInterfaces source_class))) #.None (if (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers source_class)) (#.Item (:as java/lang/reflect/Type (ffi.class_for java/lang/Object)) - (array.list (java/lang/Class::getGenericInterfaces source_class))) - (array.list (java/lang/Class::getGenericInterfaces source_class))))))) + (array.list #.None (java/lang/Class::getGenericInterfaces source_class))) + (array.list #.None (java/lang/Class::getGenericInterfaces source_class))))))) (def: (inheritance_candidate_parents class_loader fromT target_class toT fromC) (-> java/lang/ClassLoader .Type (java/lang/Class java/lang/Object) .Type Code (Operation (List [[Text .Type] Bit]))) @@ -1092,7 +1092,7 @@ (-> Aliasing (java/lang/Class java/lang/Object) Text Method_Style (List (Type Value)) java/lang/reflect/Method (Operation Bit)) (do phase.monad [parameters (|> (java/lang/reflect/Method::getGenericParameterTypes method) - array.list + (array.list #.None) (monad.each try.monad reflection!.type) phase.lifted) .let [modifiers (java/lang/reflect/Method::getModifiers method) @@ -1138,7 +1138,7 @@ (-> Aliasing (java/lang/Class java/lang/Object) (List (Type Value)) (java/lang/reflect/Constructor java/lang/Object) (Operation Bit)) (do phase.monad [parameters (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor) - array.list + (array.list #.None) (monad.each try.monad reflection!.type) phase.lifted)] (in (and (java/lang/Object::equals class (java/lang/reflect/Constructor::getDeclaringClass constructor)) @@ -1183,15 +1183,15 @@ _ (|> (java/lang/Class::getTypeParameters owner) - array.list + (array.list #.None) (list\each (|>> java/lang/reflect/TypeVariable::getName)))) method_tvars (|> (java/lang/reflect/Method::getTypeParameters method) - array.list + (array.list #.None) (list\each (|>> java/lang/reflect/TypeVariable::getName))) [owner_tvarsT mapping] (jvm_type_var_mapping owner_tvars method_tvars)] (do {! phase.monad} [inputsT (|> (java/lang/reflect/Method::getGenericParameterTypes method) - array.list + (array.list #.None) (monad.each ! (|>> reflection!.type phase.lifted)) (phase\each (monad.each ! (..reflection_type mapping))) phase\conjoint) @@ -1202,7 +1202,7 @@ (phase\each (..reflection_return mapping)) phase\conjoint) exceptionsT (|> (java/lang/reflect/Method::getGenericExceptionTypes method) - array.list + (array.list #.None) (monad.each ! (|>> reflection!.type phase.lifted)) (phase\each (monad.each ! (..reflection_type mapping))) phase\conjoint) @@ -1223,20 +1223,20 @@ (-> (java/lang/reflect/Constructor java/lang/Object) (Operation Method_Signature)) (let [owner (java/lang/reflect/Constructor::getDeclaringClass constructor) owner_tvars (|> (java/lang/Class::getTypeParameters owner) - array.list + (array.list #.None) (list\each (|>> java/lang/reflect/TypeVariable::getName))) method_tvars (|> (java/lang/reflect/Constructor::getTypeParameters constructor) - array.list + (array.list #.None) (list\each (|>> java/lang/reflect/TypeVariable::getName))) [owner_tvarsT mapping] (jvm_type_var_mapping owner_tvars method_tvars)] (do {! phase.monad} [inputsT (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor) - array.list + (array.list #.None) (monad.each ! (|>> reflection!.type phase.lifted)) (phase\each (monad.each ! (reflection_type mapping))) phase\conjoint) exceptionsT (|> (java/lang/reflect/Constructor::getGenericExceptionTypes constructor) - array.list + (array.list #.None) (monad.each ! (|>> reflection!.type phase.lifted)) (phase\each (monad.each ! (reflection_type mapping))) phase\conjoint) @@ -1270,7 +1270,7 @@ [(def: <name> (-> <type> (List (Type Var))) (|>> <method> - array.list + (array.list #.None) (list\each (|>> java/lang/reflect/TypeVariable::getName jvm.var))))] [class_type_variables (java/lang/Class java/lang/Object) java/lang/Class::getTypeParameters] @@ -1291,7 +1291,7 @@ .let [expected_class_tvars (class_type_variables class)] candidates (|> class java/lang/Class::getDeclaredMethods - array.list + (array.list #.None) (list.only (|>> java/lang/reflect/Method::getName (text\= method_name))) (monad.each ! (: (-> java/lang/reflect/Method (Operation Evaluation)) (function (_ method) @@ -1324,7 +1324,7 @@ .let [expected_class_tvars (class_type_variables class)] candidates (|> class java/lang/Class::getConstructors - array.list + (array.list #.None) (monad.each ! (function (_ constructor) (do ! [.let [expected_method_tvars (constructor_type_variables constructor) @@ -1549,23 +1549,23 @@ (-> (java/lang/Class java/lang/Object) (Try (List [Text (Type Method)]))) (|>> java/lang/Class::getDeclaredMethods - array.list + (array.list #.None) <only> (monad.each try.monad (function (_ method) (do {! try.monad} [.let [type_variables (|> (java/lang/reflect/Method::getTypeParameters method) - array.list + (array.list #.None) (list\each (|>> java/lang/reflect/TypeVariable::getName jvm.var)))] inputs (|> (java/lang/reflect/Method::getGenericParameterTypes method) - array.list + (array.list #.None) (monad.each ! reflection!.type)) return (|> method java/lang/reflect/Method::getGenericReturnType reflection!.return) exceptions (|> (java/lang/reflect/Method::getGenericExceptionTypes method) - array.list + (array.list #.None) (monad.each ! reflection!.class))] (in [(java/lang/reflect/Method::getName method) (jvm.method [type_variables inputs return exceptions])]))))))] @@ -2066,7 +2066,7 @@ [.let [[name actual_parameters] (jvm_parser.read_class class)] class (phase.lifted (reflection!.load class_loader name)) .let [expected_parameters (|> (java/lang/Class::getTypeParameters class) - array.list + (array.list #.None) (list\each (|>> java/lang/reflect/TypeVariable::getName)))] _ (phase.assertion ..class_parameter_mismatch [expected_parameters actual_parameters] (n.= (list.size expected_parameters) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux index 7952434ee..278447d11 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux @@ -199,6 +199,10 @@ (typeA.with_type input (phase archive valueC))))])) +(exception: .public (not_a_type {symbol Name}) + (exception.report + ["Symbol" (%.name symbol)])) + (def: lux::macro Handler (..custom @@ -210,9 +214,14 @@ (do ! [input_type (///.lifted (meta.definition (name_of .Macro')))] (case input_type - (#.Definition [exported? def_type def_data def_value]) + (^or (#.Definition [exported? def_type def_data def_value]) + (#.Type [exported? def_value labels])) (in (:as Type def_value)) + (^or (#.Label _) + (#.Slot _)) + (////.failure (exception.error ..not_a_type [(name_of .Macro')])) + (#.Alias real_name) (recur real_name))))] (typeA.with_type input_type diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux index c805124dd..f2ffaccae 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux @@ -228,7 +228,7 @@ [_ _ exported?] (evaluate! archive Bit exported?C) [_ _ annotations] (evaluate! archive Code annotationsC) _ (/////directive.lifted_analysis - (module.define short_name (#.Right [(:as Bit exported?) type (:as Code annotations) value]))) + (module.define short_name (#.Definition [(:as Bit exported?) type (:as Code annotations) value]))) _ (..refresh expander host_analysis) _ (..announce_definition! short_name type)] (in /////directive.no_requirements)) @@ -236,7 +236,7 @@ _ (phase.except ///.invalid_syntax [extension_name %.code inputsC+])))) -(def: (announce_tags! tags owner) +(def: (announce_labels! tags owner) (All (_ anchor expression directive) (-> (List Text) Type (Operation anchor expression directive (List Any)))) (/////directive.lifted_generation @@ -247,8 +247,11 @@ (def: (def::type_tagged expander host_analysis) (-> Expander /////analysis.Bundle Handler) (..custom - [($_ <>.and <code>.local_identifier <code>.any <code>.any (<code>.tuple (<>.some <code>.text)) <code>.any) - (function (_ extension_name phase archive [short_name valueC annotationsC tags exported?C]) + [($_ <>.and <code>.local_identifier <code>.any <code>.any + (<>.or (<code>.form (<>.some <code>.text)) + (<code>.tuple (<>.some <code>.text))) + <code>.any) + (function (_ extension_name phase archive [short_name valueC annotationsC labels exported?C]) (do phase.monad [current_module (/////directive.lifted_analysis (///.lifted meta.current_module_name)) @@ -258,13 +261,27 @@ .let [exported? (:as Bit exported?) annotations (:as Code annotations)] [type valueT value] (..definition archive full_name (#.Some .Type) valueC) - _ (/////directive.lifted_analysis - (do phase.monad - [_ (module.define short_name (#.Right [exported? type annotations value]))] - (module.declare_tags tags exported? (:as Type value)))) + labels (/////directive.lifted_analysis + (do phase.monad + [.let [[record? labels] (case labels + (#.Left tags) + [false tags] + + (#.Right slots) + [true slots])] + _ (case labels + #.End + (module.define short_name (#.Definition [exported? type annotations value])) + + (#.Item labels) + (module.define short_name (#.Type [exported? (:as .Type value) (if record? + (#.Right labels) + (#.Left labels))]))) + _ (module.declare_tags record? labels exported? (:as .Type value))] + (in labels))) _ (..refresh expander host_analysis) _ (..announce_definition! short_name type) - _ (..announce_tags! tags (:as Type value))] + _ (..announce_labels! labels (:as Type value))] (in /////directive.no_requirements)))])) (def: imports @@ -300,17 +317,27 @@ ["Foreign alias" (%.name foreign)] ["Target definition" (%.name target)])) +(exception: .public (cannot_alias_a_label {local Alias} {foreign Alias}) + (exception.report + ["Alias" (%.name local)] + ["Label" (%.name foreign)])) + (def: (define_alias alias original) (-> Text Name (/////analysis.Operation Any)) (do phase.monad [current_module (///.lifted meta.current_module_name) constant (///.lifted (meta.definition original))] (case constant - (#.Left de_aliased) + (#.Alias de_aliased) (phase.except ..cannot_alias_an_alias [[current_module alias] original de_aliased]) - (#.Right [exported? original_type original_annotations original_value]) - (module.define alias (#.Left original))))) + (^or (#.Definition _) + (#.Type _)) + (module.define alias (#.Alias original)) + + (^or (#.Label _) + (#.Slot _)) + (phase.except ..cannot_alias_a_label [[current_module alias] original])))) (def: def::alias Handler diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux index d99cfca3d..54c3ac8ba 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Type Definition case false true try) + [lux (#- Type Definition Label case false true try) [abstract ["." monad (#+ do)] ["." enum]] diff --git a/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux index 25b9ec0b4..a2b2908b3 100644 --- a/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux +++ b/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux @@ -323,8 +323,12 @@ content (document.read $.key document) definitions (monad.each ! (function (_ [def_name def_global]) (case def_global - (#.Alias alias) - (in [def_name (#.Alias alias)]) + (^template [<tag>] + [(<tag> payload) + (in [def_name (<tag> payload)])]) + ([#.Alias] + [#.Label] + [#.Slot]) (#.Definition [exported? type annotations _]) (|> definitions @@ -332,7 +336,14 @@ try.of_maybe (\ ! each (|>> [exported? type annotations] #.Definition - [def_name]))))) + [def_name]))) + + (#.Type [exported? _ labels]) + (|> definitions + (dictionary.value def_name) + try.of_maybe + (\ ! each (function (_ def_value) + [def_name (#.Type [exported? (:as .Type def_value) labels])]))))) (value@ #.definitions content))] (in [(document.write $.key (with@ #.definitions definitions content)) bundles]))) diff --git a/stdlib/source/library/lux/type/abstract.lux b/stdlib/source/library/lux/type/abstract.lux index 837f6ba11..9a0edab98 100644 --- a/stdlib/source/library/lux/type/abstract.lux +++ b/stdlib/source/library/lux/type/abstract.lux @@ -60,11 +60,14 @@ (-> Text (List [Text Global]) (Stack Frame)) (!peek source reference (case head - (#.Left _) - (undefined) + (#.Definition [exported? frame_type frame_anns frame_value]) + (:as (Stack Frame) frame_value) - (#.Right [exported? frame_type frame_anns frame_value]) - (:as (Stack Frame) frame_value)))) + (^or (#.Type _) + (#.Alias _) + (#.Label _) + (#.Slot _)) + (undefined)))) (def: (peek_frames reference definition_reference source) (-> Text Text (List [Text Module]) (Stack Frame)) @@ -117,14 +120,17 @@ (-> Text Frame (List [Text Global]) (List [Text Global])) (!push source reference (case head - (#.Left _) - (undefined) - - (#.Right [exported? frames_type frames_anns frames_value]) - (#.Right [exported? - frames_type - frames_anns - (..push frame (:as (Stack Frame) frames_value))])))) + (#.Definition [exported? frames_type frames_anns frames_value]) + (#.Definition [exported? + frames_type + frames_anns + (..push frame (:as (Stack Frame) frames_value))]) + + (^or (#.Type _) + (#.Alias _) + (#.Label _) + (#.Slot _)) + (undefined)))) (def: (push_frame [module_reference definition_reference] frame source) (-> Name Frame (List [Text Module]) (List [Text Module])) @@ -143,20 +149,23 @@ (-> Text (List [Text Global]) (List [Text Global])) (!push source reference (case head - (#.Left _) - (undefined) - - (#.Right [exported? frames_type frames_anns frames_value]) - (#.Right [exported? - frames_type - frames_anns - (let [current_frames (:as (Stack Frame) frames_value)] - (case (..pop current_frames) - (#.Some current_frames') - current_frames' - - #.None - current_frames))])))) + (#.Definition [exported? frames_type frames_anns frames_value]) + (#.Definition [exported? + frames_type + frames_anns + (let [current_frames (:as (Stack Frame) frames_value)] + (case (..pop current_frames) + (#.Some current_frames') + current_frames' + + #.None + current_frames))]) + + (^or (#.Type _) + (#.Alias _) + (#.Label _) + (#.Slot _)) + (undefined)))) (def: (pop_frame [module_reference definition_reference] source) (-> Name (List [Text Module]) (List [Text Module])) diff --git a/stdlib/source/test/lux/macro.lux b/stdlib/source/test/lux/macro.lux index 2e8c199b4..fa117e96b 100644 --- a/stdlib/source/test/lux/macro.lux +++ b/stdlib/source/test/lux/macro.lux @@ -79,8 +79,6 @@ (!global /.log_expansion!) (!global /.log_full_expansion!))) #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}] [current_module @@ -91,8 +89,6 @@ (!global ..pow/4) (!global ..repeated))) #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}]) #.scopes (list) diff --git a/stdlib/source/test/lux/meta.lux b/stdlib/source/test/lux/meta.lux index 7d397e5d5..9e0175947 100644 --- a/stdlib/source/test/lux/meta.lux +++ b/stdlib/source/test/lux/meta.lux @@ -183,16 +183,12 @@ #.module_aliases (list) #.definitions (list) #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active} expected_module {#.module_hash 0 #.module_aliases (list) #.definitions (list) #.imports (list imported_module_name) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active} expected_modules (list [expected_current_module @@ -384,8 +380,6 @@ #.module_aliases (list) #.definitions current_globals #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}] [expected_macro_module @@ -393,8 +387,6 @@ #.module_aliases (list) #.definitions macro_globals #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}]) #.scopes (list) @@ -506,8 +498,6 @@ #.module_aliases (list) #.definitions current_globals #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}] [expected_macro_module @@ -515,8 +505,6 @@ #.module_aliases (list) #.definitions macro_globals #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}]) #.scopes (list) @@ -655,19 +643,22 @@ (random.ascii/upper 1)) .let [random_tag (\ ! each (|>> [tag_module]) - (random.ascii/upper 1))] - all_tags (|> random_tag - (random.set name.hash 10) - (\ ! each set.list)) - .let [tags_0 (list.first 5 all_tags) - tags_1 (list.after 5 all_tags) - - type_0 (#.Primitive name_0 (list)) + (random.ascii/upper 1)) + random_labels (: (Random [Text (List Text)]) + (do ! + [head (random.ascii/lower 5)] + (|> (random.ascii/lower 5) + (random.only (|>> (text\= head) not)) + (random.set text.hash 3) + (\ ! each set.list) + (random.and (in head)))))] + tags_0 random_labels + tags_1 (let [set/0 (set.of_list text.hash (#.Item tags_0))] + (random.only (|>> #.Item (list.any? (set.member? set/0))not) + random_labels)) + .let [type_0 (#.Primitive name_0 (list)) type_1 (#.Primitive name_1 (list)) - entry_0 [name_0 [tags_0 false type_0]] - entry_1 [name_1 [tags_1 true type_1]] - expected_lux (: Lux {#.info {#.target "" @@ -681,24 +672,23 @@ #.module_aliases (list) #.definitions (list) #.imports (list tag_module) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}] [tag_module {#.module_hash 0 #.module_aliases (list) - #.definitions (list) + #.definitions (list& [name_0 (#.Type [false type_0 (#.Left tags_0)])] + [name_1 (#.Type [true type_1 (#.Right tags_1)])] + ($_ list\composite + (|> (#.Item tags_0) + list.enumeration + (list\each (function (_ [index short]) + [(format "#" short) (#.Label [false type_0 (#.Item tags_0) index])]))) + (|> (#.Item tags_1) + list.enumeration + (list\each (function (_ [index short]) + [(format "#" short) (#.Slot [true type_1 (#.Item tags_1) index])]))))) #.imports (list) - #.tags (list\composite (|> tags_0 - list.enumeration - (list\each (function (_ [index [_ short]]) - [short [index tags_0 false type_0]]))) - (|> tags_1 - list.enumeration - (list\each (function (_ [index [_ short]]) - [short [index tags_1 true type_1]])))) - #.types (list entry_0 entry_1) #.module_annotations #.None #.module_state #.Active}]) #.scopes (list) @@ -719,28 +709,29 @@ type.equivalence))] (|> (/.tag_lists tag_module) (/.result expected_lux) - (try\each (\ equivalence = (list [tags_1 type_1]))) + (try\each (\ equivalence = (list [(list\each (|>> [tag_module]) (#.Item tags_1)) + type_1]))) (try.else false)))) (_.cover [/.tags_of] (|> (/.tags_of [tag_module name_1]) (/.result expected_lux) - (try\each (\ (maybe.equivalence (list.equivalence name.equivalence)) = (#.Some tags_1))) + (try\each (\ (maybe.equivalence (list.equivalence name.equivalence)) = (#.Some (list\each (|>> [tag_module]) (#.Item tags_1))))) (try.else false))) (_.cover [/.tag] - (|> tags_1 + (|> (#.Item tags_1) list.enumeration (list.every? (function (_ [expected_index tag]) - (|> tag + (|> [tag_module tag] /.tag (/.result expected_lux) - (!expect (^multi (^ (#try.Success [actual_index actual_tags actual_type])) + (!expect (^multi (#try.Success [actual_index actual_tags actual_type]) (let [correct_index! (n.= expected_index actual_index) correct_tags! (\ (list.equivalence name.equivalence) = - tags_1 + (list\each (|>> [tag_module]) (#.Item tags_1)) actual_tags) correct_type! @@ -748,7 +739,8 @@ actual_type)] (and correct_index! correct_tags! - correct_type!))))))))) + correct_type!)))) + ))))) ))) (def: locals_related @@ -807,8 +799,6 @@ #.module_aliases (list) #.definitions globals #.imports (list) - #.tags (list) - #.types (list) #.module_annotations #.None #.module_state #.Active}]) #.scopes scopes diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux index 9494096f2..6dd299f2c 100644 --- a/stdlib/source/test/lux/target/jvm.lux +++ b/stdlib/source/test/lux/target/jvm.lux @@ -1,6 +1,6 @@ (.module: [library - [lux (#- Type type primitive int) + [lux (#- Type Label type primitive int) ["." ffi (#+ import:)] ["@" target] [abstract |