diff options
Diffstat (limited to '')
| -rw-r--r-- | luxc/src/lux/analyser/lux.clj | 20 | ||||
| -rw-r--r-- | luxc/src/lux/analyser/meta.clj | 4 | ||||
| -rw-r--r-- | luxc/src/lux/analyser/module.clj | 5 | ||||
| -rw-r--r-- | luxc/src/lux/analyser/proc/common.clj | 12 | ||||
| -rw-r--r-- | luxc/src/lux/type.clj | 37 |
5 files changed, 47 insertions, 31 deletions
diff --git a/luxc/src/lux/analyser/lux.clj b/luxc/src/lux/analyser/lux.clj index dc08ac765..2a4240aa6 100644 --- a/luxc/src/lux/analyser/lux.clj +++ b/luxc/src/lux/analyser/lux.clj @@ -18,8 +18,9 @@ ;; [Utils] ;; TODO: Walk the type to set up the parameter-type, instead of doing a ;; rough calculation like this one. -(defn ^:private count-univq [type] +(defn ^:private count-univq "(-> Type Int)" + [type] (|case type (&/$UnivQ env type*) (inc (count-univq type*)) @@ -29,12 +30,14 @@ ;; TODO: This technique will not work if the body of the type contains ;; nested quantifications that cannot be directly counted. -(defn ^:private next-parameter-type [type] +(defn ^:private next-parameter-type "(-> Type Type)" + [type] (&/$Parameter (->> (count-univq type) (* 2) (+ 1)))) -(defn ^:private embed-inferred-input [input output] +(defn ^:private embed-inferred-input "(-> Type Type Type)" + [input output] (|case output (&/$UnivQ env output*) (&/$UnivQ env (embed-inferred-input input output*)) @@ -379,8 +382,7 @@ (|case =fn [_ (&&/$def ?module ?name)] (|do [[real-name [?type ?meta ?value]] (&&module/find-def! ?module ?name)] - (|case (&&meta/meta-get &&meta/macro?-tag ?meta) - (&/$Some _) + (if (&type/type= &type/Macro ?type) (|do [macro-expansion (fn [state] (|case (macro-caller ?value ?args state) (&/$Right state* output) @@ -390,15 +392,13 @@ ((&/fail-with-loc error) state))) ;; module-name &/get-module-name ;; :let [[r-prefix r-name] real-name - ;; _ (when (= "syntax:" r-name) + ;; _ (when (= "macro:'" r-name) ;; (->> (&/|map &/show-ast macro-expansion) ;; (&/|interpose "\n") ;; (&/fold str "") ;; (println 'macro-expansion (&/ident->text real-name) "@" module-name)))] ] (&/flat-map% (partial analyse exo-type) macro-expansion)) - - _ (do-analyse-apply analyse exo-type =fn ?args))) _ @@ -554,7 +554,6 @@ =meta (&&/analyse-1 analyse &type/Code ?meta) ==meta (eval! (optimize =meta)) _ (&&module/test-type module-name ?name ==meta (&&/expr-type* =value)) - _ (&&module/test-macro module-name ?name ==meta (&&/expr-type* =value)) _ (compile-def ?name (optimize =value) ==meta) _ &type/reset-mappings] (return &/$Nil))) @@ -685,8 +684,9 @@ =asyncs)] (return &/$Nil))) -(defn ^:private coerce [new-type analysis] +(defn ^:private coerce "(-> Type Analysis Analysis)" + [new-type analysis] (|let [[[_type _cursor] _analysis] analysis] (&&/|meta new-type _cursor _analysis))) diff --git a/luxc/src/lux/analyser/meta.clj b/luxc/src/lux/analyser/meta.clj index 1770372a9..d7a68ecb4 100644 --- a/luxc/src/lux/analyser/meta.clj +++ b/luxc/src/lux/analyser/meta.clj @@ -14,8 +14,9 @@ (def ^:private tag-prefix "lux") ;; [Values] -(defn meta-get [ident annotations] +(defn meta-get "(-> Ident Code (Maybe Code))" + [ident annotations] (|case annotations [_ (&/$Record dict)] (loop [dict dict] @@ -41,7 +42,6 @@ type?-tag "type?" alias-tag "alias" - macro?-tag "macro?" export?-tag "export?" tags-tag "tags" imports-tag "imports" diff --git a/luxc/src/lux/analyser/module.clj b/luxc/src/lux/analyser/module.clj index 70e463432..b749b64e4 100644 --- a/luxc/src/lux/analyser/module.clj +++ b/luxc/src/lux/analyser/module.clj @@ -108,8 +108,8 @@ (defn define [module name def-type def-meta def-value] (fn [state] - (when (and (= "Macro" name) (= "lux" module)) - (&type/set-macro-type! def-value)) + (when (and (= "Macro'" name) (= "lux" module)) + (&type/set-macro*-type! def-value)) (|case (&/get$ &/$scopes state) (&/$Cons ?env (&/$Nil)) (return* (->> state @@ -445,7 +445,6 @@ (return nil))) test-type &type/Type &meta/type?-tag "type" - test-macro &type/Macro &meta/macro?-tag "macro" ) (defn fetch-imports [meta] diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 75c2cd3c9..f055fc99c 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -22,13 +22,20 @@ (fn [$var] (|do [:let [(&/$Cons op (&/$Nil)) ?values] =op (&&/analyse-1 analyse (&/$Apply $var &type/IO) op) - _ (&type/check exo-type (&/$Sum &type/Text ;; lux;Left - $var ;; lux;Right + _ (&type/check exo-type (&/$Sum &type/Text ;; lux.Left + $var ;; lux.Right )) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["lux" "try"]) (&/|list =op) (&/|list))))))))) +(defn- analyse-lux-macro [analyse exo-type ?values] + (|do [:let [(&/$Cons macro (&/$Nil)) ?values] + [[=macro*-type =cursor] =macro] (&&/analyse-1 analyse &type/Macro* macro) + _ (&type/check exo-type &type/Macro)] + (return (&/|list (&&/|meta exo-type =cursor + =macro))))) + (do-template [<name> <proc> <input-type> <output-type>] (defn- <name> [analyse exo-type ?values] (|do [:let [(&/$Cons reference (&/$Cons sample (&/$Nil))) ?values] @@ -250,6 +257,7 @@ (try (case proc "lux is" (analyse-lux-is analyse exo-type ?values) "lux try" (analyse-lux-try analyse exo-type ?values) + "lux macro" (analyse-lux-macro analyse exo-type ?values) "lux io log" (analyse-io-log analyse exo-type ?values) "lux io error" (analyse-io-error analyse exo-type ?values) diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj index 7939d3717..20126417f 100644 --- a/luxc/src/lux/type.clj +++ b/luxc/src/lux/type.clj @@ -180,11 +180,12 @@ (let [w (&/$Apply Cursor Meta)] (&/$Apply (&/$Apply w Code*) w)))) -(def Macro) +(def Macro*) +(defn set-macro*-type! [type] (def Macro* type)) -(defn set-macro-type! [type] - (def Macro type) - nil) +(def Macro + (&/$Named (&/T ["lux" "Macro"]) + (&/$Primitive "#Macro" &/$Nil))) (defn bound? [id] (fn [state] @@ -232,7 +233,7 @@ (&/$None) (return* (&/update$ &/$type-context (fn [ts] (&/update$ &/$var-bindings #(&/|put id (&/$Some type) %) - ts)) + ts)) state) nil)) ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) &/|length))) @@ -242,7 +243,7 @@ (fn [state] (if-let [tvar (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] (return* (&/update$ &/$type-context (fn [ts] (&/update$ &/$var-bindings #(&/|put id (&/$Some type) %) - ts)) + ts)) state) nil) ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) &/|length))) @@ -386,8 +387,9 @@ (unravel-app fun-type &/$Nil))) (do-template [<tag> <flatten> <at> <desc>] - (do (defn <flatten> [type] + (do (defn <flatten> "(-> Type (List Type))" + [type] (|case type (<tag> left right) (&/$Cons left (<flatten> right)) @@ -395,8 +397,9 @@ _ (&/|list type))) - (defn <at> [tag type] + (defn <at> "(-> Int Type (Lux Type))" + [tag type] (|case type (&/$Named ?name ?type) (<at> tag ?type) @@ -417,8 +420,9 @@ ) (do-template [<name> <ctor> <unit>] - (defn <name> [types] + (defn <name> "(-> (List Type) Type)" + [types] (|case (&/|reverse types) (&/$Cons last prevs) (&/fold (fn [right left] (<ctor> left right)) last prevs) @@ -857,8 +861,9 @@ (|do [_ (check* init-fixpoints false expected actual)] (return nil))) -(defn actual-type [type] +(defn actual-type "(-> Type (Lux Type))" + [type] (|case type (&/$Apply ?param ?all) (|do [type* (apply-type ?all ?param)] @@ -875,8 +880,9 @@ (return type) )) -(defn type-name [type] +(defn type-name "(-> Type (Lux Ident))" + [type] (|case type (&/$Named name _) (return name) @@ -885,8 +891,9 @@ (&/fail-with-loc (str "[Type Error] Type is not named: " (show-type type))) )) -(defn unknown? [type] +(defn unknown? "(-> Type (Lux Bit))" + [type] (|case type (&/$Var id) (|do [? (bound? id)] @@ -895,8 +902,9 @@ _ (return false))) -(defn resolve-type [type] +(defn resolve-type "(-> Type (Lux Type))" + [type] (|case type (&/$Var id) (|do [? (bound? id)] @@ -907,8 +915,9 @@ _ (return type))) -(defn tuple-types-for [size-members type] +(defn tuple-types-for "(-> Int Type [Int (List Type)])" + [size-members type] (|let [?member-types (flatten-prod type) size-types (&/|length ?member-types)] (if (>= size-types size-members) |