diff options
Diffstat (limited to 'lux-bootstrapper')
| -rw-r--r-- | lux-bootstrapper/src/lux/analyser.clj | 16 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/analyser/case.clj | 12 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/analyser/lux.clj | 49 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/analyser/module.clj | 334 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/analyser/record.clj | 39 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/base.clj | 7 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/compiler/cache.clj | 72 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/compiler/cache/type.clj | 4 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/compiler/core.clj | 86 | ||||
| -rw-r--r-- | lux-bootstrapper/src/lux/compiler/jvm/lux.clj | 15 |
10 files changed, 386 insertions, 248 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] |