aboutsummaryrefslogtreecommitdiff
path: root/luxc/src
diff options
context:
space:
mode:
Diffstat (limited to 'luxc/src')
-rw-r--r--luxc/src/lux/analyser/lux.clj20
-rw-r--r--luxc/src/lux/analyser/meta.clj4
-rw-r--r--luxc/src/lux/analyser/module.clj5
-rw-r--r--luxc/src/lux/analyser/proc/common.clj12
-rw-r--r--luxc/src/lux/type.clj37
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)