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 /lux-bootstrapper | |
| parent | c5b61d2f46ac19bf511197f3a537c4be0f47df33 (diff) | |
Made labels (tags & slots) into a form of global binding.
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] | 
