diff options
| -rw-r--r-- | src/lux/analyser.clj | 31 | ||||
| -rw-r--r-- | src/lux/analyser/base.clj | 5 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 106 |
3 files changed, 98 insertions, 44 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index d17eeea2a..a9689a9d0 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -43,6 +43,23 @@ _ (fail (str "[Analyser Error] Not a tag: " (&/show-ast ast))))) +(defn analyse-variant+ [analyser exo-type ident values] + (|do [[module tag-name] (&/normalize ident) + idx (&&module/tag-index module tag-name)] + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if (or ? (&&/type-tag? module tag-name)) + (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) + (|do [wanted-type (&&module/tag-type module tag-name) + [variant-analysis variant-type] (&&/cap-1 (&&lux/analyse-variant analyser (&/V &/$Left wanted-type) idx values)) + _ (&type/check exo-type variant-type)] + (return (&/|list (&/T variant-analysis exo-type)))))) + + _ + (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) + ))) + (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays @@ -505,9 +522,7 @@ (&&lux/analyse-record analyse exo-type ?elems) (&/$TagS ?ident) - (|do [[module tag-name] (&/normalize ?ident) - idx (&&module/tag-index module tag-name)] - (&&lux/analyse-variant analyse exo-type idx (&/|list))) + (analyse-variant+ analyse exo-type ?ident (&/|list)) (&/$SymbolS _ "_jvm_null") (&&host/analyse-jvm-null analyse exo-type) @@ -573,16 +588,10 @@ (&/with-expected-type exo-type (|case token [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) (&/V &/$Right exo-type) idx ?values) [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] - (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] - [module tag-name] (&/normalize ?ident) - ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] - idx (&&module/tag-index module tag-name) - ;; :let [_ (println 'analyse-ast/_2 idx)] - ] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) + (analyse-variant+ (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) [meta (&/$FormS (&/$Cons ?fn ?args))] (fn [state] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index e27b2e42e..1507a3a76 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -156,3 +156,8 @@ &/get-module-name (return ?module))] (return (&/T module* ?name))))) + +(let [tag-names #{"DataT" "VariantT" "TupleT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}] + (defn type-tag? [module name] + (and (= "lux" module) + (contains? tag-names name)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index a6f41c9fd..b8239d1a9 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -133,41 +133,75 @@ _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) -(defn analyse-variant [analyse exo-type idx ?values] - (|do [exo-type* (|case exo-type - (&/$VarT ?id) - (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] - (&type/actual-type exo-type*)) - (|do [_ (&type/set-var ?id &type/Type)] - (&type/actual-type &type/Type)))) - - _ - (&type/actual-type exo-type))] - (|case exo-type* - (&/$VariantT ?cases) - (|case (&/|at idx ?cases) - (&/$Some vtype) - (|do [=value (with-attempt - (analyse-variant-body analyse vtype ?values) - (fn [err] - (|do [_exo-type (&type/deref+ exo-type)] - (fail (str err "\n" - 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type) - " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))] - (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) - exo-type)))) +(defn analyse-variant [analyse ?exo-type idx ?values] + (|case ?exo-type + (&/$Left exo-type) + (|do [;; :let [_ (println 'analyse-variant/Left 0 (&type/show-type exo-type))] + exo-type* (&type/actual-type exo-type) + ;; :let [_ (println 'analyse-variant/Left 1 (&type/show-type exo-type*))] + ] + (|case exo-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + ;; :let [_ (println 'analyse-variant/Left 2 (&type/show-type exo-type**))] + [variant-analysis variant-type] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx ?values)) + ;; :let [_ (println 'analyse-variant/Left 3 (&type/show-type variant-type))] + =var (&type/resolve-type $var) + ;; :let [_ (println 'analyse-variant/Left 4 (&type/show-type =var))] + inferred-type (|case =var + (&/$VarT iid) + (|do [:let [=var* (next-bound-type variant-type)] + _ (&type/set-var iid =var*) + variant-type* (&type/clean $var variant-type)] + (return (&type/Univ$ (&/|list) variant-type*))) - (&/$None) - (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) + _ + (&type/clean $var variant-type)) + ;; :let [_ (println 'analyse-variant/Left 5 (&type/show-type inferred-type))] + ] + (return (&/|list (&/T variant-analysis inferred-type)))))) - (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse exo-type** idx ?values)))) - - _ - (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) + _ + (analyse-variant analyse (&/V &/$Right exo-type*) idx ?values))) + + (&/$Right exo-type) + ;; [_ exo-type] + (|do [;; :let [_ (println 'analyse-variant/Right 0 (&type/show-type exo-type))] + exo-type* (|case exo-type + (&/$VarT ?id) + (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] + (&type/actual-type exo-type*)) + (|do [_ (&type/set-var ?id &type/Type)] + (&type/actual-type &type/Type)))) + + _ + (&type/actual-type exo-type))] + (|case exo-type* + (&/$VariantT ?cases) + (|case (&/|at idx ?cases) + (&/$Some vtype) + (|do [=value (with-attempt + (analyse-variant-body analyse vtype ?values) + (fn [err] + (|do [_exo-type (&type/deref+ exo-type)] + (fail (str err "\n" + 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type) + " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))] + (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) + exo-type)))) + + (&/$None) + (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) + + (&/$UnivQ _) + (|do [$var &type/existential + exo-type** (&type/apply-type exo-type* $var)] + (analyse-variant analyse (&/V &/$Right exo-type**) idx ?values)) + + _ + (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*))))))) (defn analyse-record [analyse exo-type ?elems] (|do [[rec-members rec-type] (&&record/order-record ?elems)] @@ -465,6 +499,12 @@ _ (do ;; (println 'DEF (str module-name ";" ?name)) (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) + ;; _ (if (and (= "lux" module-name) + ;; (= "Type" ?name)) + ;; (|do [newly-defined-Type + ;; :let [_ (&type/redefine-type! newly-defined-Type)]] + ;; (return nil)) + ;; (return nil)) :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) [def-analysis def-type] =value _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) |