From 77aae538ed0d128e291292b5defe80967d181be9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 6 Sep 2015 20:37:10 -0400 Subject: - Added the (untested) inference of tuple destructuring. - Removed several (unnecessary) type annotations. --- src/lux/analyser/base.clj | 8 +++++++ src/lux/analyser/case.clj | 60 ++++++++++++++++++++++++++++++----------------- src/lux/analyser/lux.clj | 18 ++++---------- src/lux/type.clj | 13 ++++++++-- 4 files changed, 62 insertions(+), 37 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 414d005f1..7f7980e76 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -139,6 +139,14 @@ _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) +(defn analyse-1+ [analyse ?token] + (&type/with-var + (fn [$var] + (|do [=expr (analyse-1 analyse $var ?token) + :let [[?item ?type] =expr] + =type (&type/clean $var ?type)] + (return (&/T ?item =type)))))) + (defn resolved-ident [ident] (|let [[?module ?name] ident] (|do [module* (if (.equals "" ?module) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index f302088d9..3b12270c2 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -184,11 +184,7 @@ (&/$RecordS pairs) (|do [?members (&&record/order-record pairs) - ;; :let [_ (prn 'PRE (&type/show-type value-type))] - value-type* (adjust-type value-type) - ;; :let [_ (prn 'POST (&type/show-type value-type*))] - ;; value-type* (resolve-type value-type) - ] + value-type* (adjust-type value-type)] (|case value-type* (&/$TupleT ?member-types) (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) @@ -333,6 +329,15 @@ (return (&/V $VariantTotal (&/T total? structs)))) )))) +(defn check-totality+ [check-totality] + (fn [?token] + (&type/with-var + (fn [$var] + (|do [=output (check-totality $var ?token) + ?type (&type/deref+ $var) + =type (&type/clean $var ?type)] + (return (&/T =output =type))))))) + (defn ^:private check-totality [value-type struct] ;; (prn 'check-totality (&type/show-type value-type) (&/adt->text struct)) (|case struct @@ -340,34 +345,45 @@ (return ?total) ($BoolTotal ?total ?values) - (return (or ?total - (= #{true false} (set (&/->seq ?values))))) + (|do [_ (&type/check value-type &type/Bool)] + (return (or ?total + (= #{true false} (set (&/->seq ?values)))))) ($IntTotal ?total _) - (return ?total) + (|do [_ (&type/check value-type &type/Int)] + (return ?total)) ($RealTotal ?total _) - (return ?total) + (|do [_ (&type/check value-type &type/Real)] + (return ?total)) ($CharTotal ?total _) - (return ?total) + (|do [_ (&type/check value-type &type/Char)] + (return ?total)) ($TextTotal ?total _) - (return ?total) + (|do [_ (&type/check value-type &type/Text)] + (return ?total)) ($TupleTotal ?total ?structs) - (if ?total - (return true) - (|do [value-type* (resolve-type value-type)] - (|case value-type* - (&/$TupleT ?members) - (|do [totals (&/map2% (fn [sub-struct ?member] - (check-totality ?member sub-struct)) - ?structs ?members)] - (return (&/fold #(and %1 %2) true totals))) + (|do [unknown? (&type/unknown? value-type)] + (if unknown? + (|do [=structs (&/map% (check-totality+ check-totality) ?structs) + _ (&type/check value-type (&/V &/$TupleT (&/|map &/|second =structs)))] + (return (or ?total + (&/fold #(and %1 %2) true (&/|map &/|first =structs))))) + (if ?total + (return true) + (|do [value-type* (resolve-type value-type)] + (|case value-type* + (&/$TupleT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) - _ - (fail "[Pattern-maching Error] Tuple is not total.")))) + _ + (fail "[Pattern-maching Error] Tuple is not total.")))))) ($VariantTotal ?total ?structs) (if ?total diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 62202c1c9..3a9b822ca 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -18,19 +18,11 @@ [module :as &&module] [record :as &&record]))) -(defn ^:private analyse-1+ [analyse ?token] - (&type/with-var - (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var ?token) - :let [[?item ?type] =expr] - =type (&type/clean $var ?type)] - (return (&/T ?item =type)))))) - ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] (|do [unknown? (&type/unknown? exo-type)] (if unknown? - (|do [=elems (&/map% #(|do [=analysis (analyse-1+ analyse %)] + (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] (return =analysis)) ?elems) _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))] @@ -52,7 +44,7 @@ (analyse-tuple analyse exo-type** ?elems)))) _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))))) + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) (&type/show-type exo-type)))))))) (defn ^:private analyse-variant-body [analyse exo-type ?values] (|do [output (|case ?values @@ -303,7 +295,7 @@ (|do [:let [num-branches (&/|length ?branches)] _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.") _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.") - =value (analyse-1+ analyse ?value) + =value (&&/analyse-1+ analyse ?value) =match (&&case/analyse-branches analyse exo-type (&&/expr-type* =value) (&/|as-pairs ?branches))] (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) @@ -382,7 +374,7 @@ (if ? (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) (|do [=value (&/with-scope ?name - (analyse-1+ analyse ?value))] + (&&/analyse-1+ analyse ?value))] (|case =value [(&&/$var (&/$Global ?r-module ?r-name)) _] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value)) @@ -452,6 +444,6 @@ (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) _ (&type/check exo-type ==type) - =value (analyse-1+ analyse ?value)] + =value (&&/analyse-1+ analyse ?value)] (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) diff --git a/src/lux/type.clj b/src/lux/type.clj index f067867d8..5fbc33de2 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -336,6 +336,14 @@ (fail* (str "[Type Error] Unbound type-var: " id))) (fail* (str "[Type Error] Unknown type-var: " id))))) +(defn deref+ [type] + (|case type + (&/$VarT id) + (deref id) + + _ + (fail (str "[Type Error] Type is not a variable: " (show-type type))))) + (defn set-var [id type] (fn [state] (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] @@ -914,8 +922,9 @@ (|do [type* (apply-type ?all ?param)] (actual-type type*)) - (&/$VarT ?id) - (deref ?id) + (&/$VarT id) + (|do [=type (deref id)] + (actual-type =type)) (&/$NamedT ?name ?type) (actual-type ?type) -- cgit v1.2.3