aboutsummaryrefslogtreecommitdiff
path: root/lux-bootstrapper/src
diff options
context:
space:
mode:
Diffstat (limited to 'lux-bootstrapper/src')
-rw-r--r--lux-bootstrapper/src/lux/analyser.clj16
-rw-r--r--lux-bootstrapper/src/lux/analyser/case.clj12
-rw-r--r--lux-bootstrapper/src/lux/analyser/lux.clj49
-rw-r--r--lux-bootstrapper/src/lux/analyser/module.clj334
-rw-r--r--lux-bootstrapper/src/lux/analyser/record.clj39
-rw-r--r--lux-bootstrapper/src/lux/base.clj7
-rw-r--r--lux-bootstrapper/src/lux/compiler/cache.clj72
-rw-r--r--lux-bootstrapper/src/lux/compiler/cache/type.clj4
-rw-r--r--lux-bootstrapper/src/lux/compiler/core.clj86
-rw-r--r--lux-bootstrapper/src/lux/compiler/jvm/lux.clj15
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]