From c0613f6fb6d225c022c306ce70c8b18c0ec9cf71 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 10 Sep 2015 20:03:14 -0400 Subject: - Implemented inference for constructing records. --- src/lux/analyser.clj | 2 +- src/lux/analyser/base.clj | 9 ++- src/lux/analyser/case.clj | 4 +- src/lux/analyser/lux.clj | 146 ++++++++++++++++++++++++++--------------- src/lux/analyser/module.clj | 31 ++++----- src/lux/analyser/record.clj | 154 ++++++-------------------------------------- 6 files changed, 139 insertions(+), 207 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 9a57191f5..d17eeea2a 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -499,7 +499,7 @@ (return (&/|list (&/T (&/V &&/$text ?value) exo-type)))) (&/$TupleS ?elems) - (&&lux/analyse-tuple analyse exo-type ?elems) + (&&lux/analyse-tuple analyse (&/V &/$Right exo-type) ?elems) (&/$RecordS ?elems) (&&lux/analyse-record analyse exo-type ?elems) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 7f7980e76..e27b2e42e 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -130,15 +130,18 @@ (|let [[_ type] syntax+] type)) -(defn analyse-1 [analyse exo-type elem] - (|do [output (analyse exo-type elem)] - (|case output +(defn cap-1 [action] + (|do [result action] + (|case result (&/$Cons x (&/$Nil)) (return x) _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) +(defn analyse-1 [analyse exo-type elem] + (cap-1 (analyse exo-type elem))) + (defn analyse-1+ [analyse ?token] (&type/with-var (fn [$var] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index f2afdb0e9..7226b98e4 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -178,8 +178,8 @@ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) (&/$RecordS pairs) - (|do [?members (&&record/order-record pairs)] - (analyse-pattern value-type (&/T meta (&/V &/$TupleS ?members)) kont)) + (|do [[rec-members rec-type] (&&record/order-record pairs)] + (analyse-pattern value-type (&/T meta (&/V &/$TupleS rec-members)) kont)) (&/$TagS ?ident) (|do [;; :let [_ (println "#00" (&/ident->text ?ident))] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 39eda451f..a6f41c9fd 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -18,35 +18,84 @@ [module :as &&module] [record :as &&record]))) +;; [Utils] +(defn ^:private count-univq [type] + "(-> Type Int)" + (|case type + (&/$UnivQ env type*) + (inc (count-univq type*)) + + _ + 0)) + +(defn ^:private next-bound-type [type] + "(-> Type Type)" + (&type/Bound$ (->> (count-univq type) (* 2) (+ 1)))) + +(defn ^:private embed-inferred-input [input output] + "(-> Type Type Type)" + (|case output + (&/$UnivQ env output*) + (&type/Univ$ env (embed-inferred-input input output*)) + + _ + (&type/Lambda$ input output))) + ;; [Exports] -(defn analyse-tuple [analyse exo-type ?elems] - (|do [unknown? (&type/unknown? exo-type)] - (if unknown? - (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] - (return =analysis)) - ?elems) - _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))] - (return (&/|list (&/T (&/V &&/$tuple =elems) - exo-type)))) - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type* - (&/$TupleT ?members) - (|do [=elems (&/map2% (fn [elem-t elem] - (&&/analyse-1 analyse elem-t elem)) - ?members ?elems)] - (return (&/|list (&/T (&/V &&/$tuple =elems) - exo-type)))) - - (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-tuple analyse exo-type** ?elems)))) +(defn analyse-tuple [analyse ?exo-type ?elems] + (|case ?exo-type + (&/$Left exo-type) + (|do [;; :let [_ (println 'analyse-tuple/$Left (&type/show-type exo-type))] + exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + [tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left exo-type**) ?elems)) + =var (&type/resolve-type $var) + inferred-type (|case =var + (&/$VarT iid) + (|do [:let [=var* (next-bound-type tuple-type)] + _ (&type/set-var iid =var*) + tuple-type* (&type/clean $var tuple-type)] + (return (&type/Univ$ (&/|list) tuple-type*))) + + _ + (&type/clean $var tuple-type))] + (return (&/|list (&/T tuple-analysis inferred-type)))))) - _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) - ;; (assert false (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) - ))))) + _ + (analyse-tuple analyse (&/V &/$Right exo-type*) ?elems))) + + (&/$Right exo-type) + (|do [unknown? (&type/unknown? exo-type)] + (if unknown? + (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] + (return =analysis)) + ?elems) + _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))] + (return (&/|list (&/T (&/V &&/$tuple =elems) + exo-type)))) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$TupleT ?members) + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + ?members ?elems)] + (return (&/|list (&/T (&/V &&/$tuple =elems) + exo-type)))) + + (&/$UnivQ _) + (|do [$var &type/existential + exo-type** (&type/apply-type exo-type* $var) + [tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Right exo-type**) ?elems))] + (return (&/|list (&/T tuple-analysis exo-type)))) + + _ + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) + ;; (assert false (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) + )))))) (defn with-attempt [m-value on-error] (fn [state] @@ -61,13 +110,13 @@ (|do [output (with-attempt (|case ?values (&/$Nil) - (analyse-tuple analyse exo-type (&/|list)) + (analyse-tuple analyse (&/V &/$Right exo-type) (&/|list)) (&/$Cons ?value (&/$Nil)) (analyse exo-type ?value) _ - (analyse-tuple analyse exo-type ?values)) + (analyse-tuple analyse (&/V &/$Right exo-type) ?values)) (fn [err] (fail (str err "\n" 'analyse-variant-body " " (&type/show-type exo-type) @@ -121,8 +170,19 @@ (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 [members (&&record/order-record ?elems)] - (analyse-tuple analyse exo-type members))) + (|do [[rec-members rec-type] (&&record/order-record ?elems)] + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (analyse-tuple analyse (&/V &/$Right exo-type) rec-members) + (|do [[tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left rec-type) rec-members)) + _ (&type/check exo-type tuple-type)] + (return (&/|list (&/T tuple-analysis exo-type)))))) + + _ + (analyse-tuple analyse (&/V &/$Right exo-type) rec-members) + ))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -301,24 +361,6 @@ (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) -(defn ^:private count-univq [type] - "(-> Type Int)" - (|case type - (&/$UnivQ env type*) - (inc (count-univq type*)) - - _ - 0)) - -(defn ^:private embed-inferred-input [input output] - "(-> Type Type Type)" - (|case output - (&/$UnivQ env output*) - (&type/Univ$ env (embed-inferred-input input output*)) - - _ - (&type/Lambda$ input output))) - (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] (|case exo-type (&/$VarT id) @@ -336,7 +378,7 @@ =output (&type/resolve-type $output) inferred-type (|case =input (&/$VarT iid) - (|do [:let [=input* (&type/Bound$ (->> (count-univq =output) (* 2) (+ 1)))] + (|do [:let [=input* (next-bound-type =output)] _ (&type/set-var iid =input*) =output* (&type/clean $input =output) =output** (&type/clean $output =output*)] @@ -424,7 +466,9 @@ (do ;; (println 'DEF (str module-name ";" ?name)) (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) - _ (println 'DEF (str module-name ";" ?name))]] + [def-analysis def-type] =value + _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) + )]] (return (&/|list))))) )))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 8c27fc08d..aaed26a7a 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -343,20 +343,17 @@ nil)) (fail* (str "[Lux Error] Unknown module: " module)))))) -(defn tag-index [module tag-name] - "(-> Text Text (Lux Int))" - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] - (return* state (aget idx+tags 0)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) - (fail* (str "[Module Error] Unknown module: " module))))) - -(defn tag-group [module tag-name] - "(-> Text Text (Lux (List Ident)))" - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] - (return* state (aget idx+tags 1)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) - (fail* (str "[Module Error] Unknown module: " module))))) +(do-template [ ] + (defn [module tag-name] + + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags+type (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags+type )) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) + + tag-index 0 "(-> Text Text (Lux Int))" + tag-group 1 "(-> Text Text (Lux (List Ident)))" + tag-type 2 "(-> Text Text (Lux Type))" + ) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index 8b70bbcb4..0f860888b 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -6,139 +6,26 @@ (ns lux.analyser.record (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |let |do return fail |case]]) + (lux [base :as & :refer [deftags |let |do return fail |case]] + [type :as &type]) (lux.analyser [base :as &&] [module :as &&module]))) -;; [Tags] -(deftags "" - "bool" - "int" - "real" - "char" - "text" - "variant" - "tuple" - "apply" - "case" - "lambda" - "ann" - "def" - "declare-macro" - "var" - "captured" - - "jvm-getstatic" - "jvm-getfield" - "jvm-putstatic" - "jvm-putfield" - "jvm-invokestatic" - "jvm-instanceof" - "jvm-invokevirtual" - "jvm-invokeinterface" - "jvm-invokespecial" - "jvm-null?" - "jvm-null" - "jvm-new" - "jvm-new-array" - "jvm-aastore" - "jvm-aaload" - "jvm-class" - "jvm-interface" - "jvm-try" - "jvm-throw" - "jvm-monitorenter" - "jvm-monitorexit" - "jvm-program" - - "jvm-iadd" - "jvm-isub" - "jvm-imul" - "jvm-idiv" - "jvm-irem" - "jvm-ieq" - "jvm-ilt" - "jvm-igt" - - "jvm-ceq" - "jvm-clt" - "jvm-cgt" - - "jvm-ladd" - "jvm-lsub" - "jvm-lmul" - "jvm-ldiv" - "jvm-lrem" - "jvm-leq" - "jvm-llt" - "jvm-lgt" - - "jvm-fadd" - "jvm-fsub" - "jvm-fmul" - "jvm-fdiv" - "jvm-frem" - "jvm-feq" - "jvm-flt" - "jvm-fgt" - - "jvm-dadd" - "jvm-dsub" - "jvm-dmul" - "jvm-ddiv" - "jvm-drem" - "jvm-deq" - "jvm-dlt" - "jvm-dgt" - - "jvm-d2f" - "jvm-d2i" - "jvm-d2l" - - "jvm-f2d" - "jvm-f2i" - "jvm-f2l" - - "jvm-i2b" - "jvm-i2c" - "jvm-i2d" - "jvm-i2f" - "jvm-i2l" - "jvm-i2s" - - "jvm-l2d" - "jvm-l2f" - "jvm-l2i" - - "jvm-iand" - "jvm-ior" - "jvm-ixor" - "jvm-ishl" - "jvm-ishr" - "jvm-iushr" - - "jvm-land" - "jvm-lor" - "jvm-lxor" - "jvm-lshl" - "jvm-lshr" - "jvm-lushr" - - ) - ;; [Exports] (defn order-record [pairs] "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" - (|do [tag-group (|case pairs - (&/$Nil) - (return (&/|list)) - - (&/$Cons [[_ (&/$TagS tag1)] _] _) - (|do [[module name] (&&/resolved-ident tag1)] - (&&module/tag-group module name)) - - _ - (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) + (|do [[tag-group tag-type] (|case pairs + (&/$Nil) + (return (&/T (&/|list) &type/Unit)) + + (&/$Cons [[_ (&/$TagS tag1)] _] _) + (|do [[module name] (&&/resolved-ident tag1) + tags (&&module/tag-group module name) + type (&&module/tag-type module name)] + (return (&/T tags type))) + + _ + (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) =pairs (&/map% (fn [kv] (|case kv [[_ (&/$TagS k)] v] @@ -147,9 +34,10 @@ _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) - pairs)] - (&/map% (fn [tag] - (if-let [member (&/|get tag =pairs)] - (return member) - (fail (str "[Analyser Error] Unknown tag: " tag)))) - (&/|map &/ident->text tag-group)))) + pairs) + =members (&/map% (fn [tag] + (if-let [member (&/|get tag =pairs)] + (return member) + (fail (str "[Analyser Error] Unknown tag: " tag)))) + (&/|map &/ident->text tag-group))] + (return (&/T =members tag-type)))) -- cgit v1.2.3