aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-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
-rw-r--r--stdlib/source/lux.lux261
-rw-r--r--stdlib/source/lux/macro.lux18
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux14
-rw-r--r--stdlib/source/lux/type.lux77
-rw-r--r--stdlib/source/program/scriptum.lux4
10 files changed, 233 insertions, 219 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)
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index 0e231eb3a..5022eb2d3 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -782,11 +782,18 @@
(tuple$ (#Cons (text$ "a") #Nil))]
default-def-meta-exported))))
-## (type: Macro
+## (type: Macro'
## (-> (List Code) (Meta (List Code))))
+("lux def" Macro'
+ (#Named ["lux" "Macro'"]
+ (#Function Code-List (#Apply Code-List Meta)))
+ (record$ default-def-meta-exported))
+
+## (type: Macro
+## (primitive "#Macro"))
("lux def" Macro
(#Named ["lux" "Macro"]
- (#Function Code-List (#Apply Code-List Meta)))
+ (#Primitive "#Macro" #Nil))
(record$ (#Cons [(tag$ ["lux" "doc"])
(text$ "Functions that run at compile-time and allow you to transform and extend the language in powerful ways.")]
default-def-meta-exported)))
@@ -816,15 +823,8 @@
(#Left msg))))
(record$ #Nil))
-("lux def" default-macro-meta
- ("lux check" (#Apply (#Product Code Code) List)
- (#Cons [(tag$ ["lux" "macro?"])
- (bit$ #1)]
- #Nil))
- (record$ #Nil))
-
("lux def" let''
- ("lux check" Macro
+ ("lux macro"
([_ tokens]
({(#Cons lhs (#Cons rhs (#Cons body #Nil)))
(return (#Cons (form$ (#Cons (record$ (#Cons [lhs body] #Nil)) (#Cons rhs #Nil)))
@@ -833,10 +833,10 @@
_
(fail "Wrong syntax for let''")}
tokens)))
- (record$ default-macro-meta))
+ (record$ #.Nil))
("lux def" function''
- ("lux check" Macro
+ ("lux macro"
([_ tokens]
({(#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil))
(return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" ""]))
@@ -869,7 +869,7 @@
_
(fail "Wrong syntax for function''")}
tokens)))
- (record$ default-macro-meta))
+ (record$ #.Nil))
("lux def" cursor-code
("lux check" Code
@@ -903,11 +903,6 @@
(flag-meta "export?"))
(record$ #Nil))
-("lux def" macro?-meta
- ("lux check" Code
- (flag-meta "macro?"))
- (record$ #Nil))
-
("lux def" with-export-meta
("lux check" (#Function Code Code)
(function'' [tail]
@@ -916,126 +911,107 @@
(#Cons tail #Nil))))))
(record$ #Nil))
-("lux def" with-macro-meta
- ("lux check" (#Function Code Code)
- (function'' [tail]
- (form$ (#Cons (tag$ ["lux" "Cons"])
- (#Cons macro?-meta
- (#Cons tail #Nil))))))
- (record$ #Nil))
-
("lux def" doc-meta
("lux check" (#Function Text (#Product Code Code))
(function'' [doc] [(tag$ ["lux" "doc"]) (text$ doc)]))
(record$ #Nil))
+("lux def" as-def
+ ("lux check" (#Function Code (#Function Code (#Function Code Code)))
+ (function'' [name value annotations]
+ (form$ (#Cons (text$ "lux def") (#Cons name (#Cons value (#Cons annotations #Nil)))))))
+ (record$ #Nil))
+
+("lux def" as-checked
+ ("lux check" (#Function Code (#Function Code Code))
+ (function'' [type value]
+ (form$ (#Cons (text$ "lux check") (#Cons type (#Cons value #Nil))))))
+ (record$ #Nil))
+
+("lux def" as-function
+ ("lux check" (#Function Code (#Function (#Apply Code List) (#Function Code Code)))
+ (function'' [self inputs output]
+ (form$ (#Cons (identifier$ ["lux" "function''"])
+ (#Cons self
+ (#Cons (tuple$ inputs)
+ (#Cons output #Nil)))))))
+ (record$ #Nil))
+
+("lux def" as-macro
+ ("lux check" (#Function Code Code)
+ (function'' [expression]
+ (form$ (#Cons (text$ "lux macro")
+ (#Cons expression
+ #Nil)))))
+ (record$ #Nil))
+
("lux def" def:''
- ("lux check" Macro
+ ("lux macro"
(function'' [tokens]
({(#Cons [[_ (#Tag ["" "export"])]
(#Cons [[_ (#Form (#Cons [name args]))]
(#Cons [meta (#Cons [type (#Cons [body #Nil])])])])])
- (return (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux def"))
- (#Cons [name
- (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux check"))
- (#Cons [type
- (#Cons [(_ann (#Form (#Cons [(_ann (#Identifier ["lux" "function''"]))
- (#Cons [name
- (#Cons [(_ann (#Tuple args))
- (#Cons [body #Nil])])])])))
- #Nil])])])))
- (#Cons (form$ (#Cons (identifier$ ["lux" "record$"])
- (#Cons (with-export-meta meta)
- #Nil)))
- #Nil)])])])))
+ (return (#Cons [(as-def name (as-checked type (as-function name args body))
+ (form$ (#Cons (identifier$ ["lux" "record$"])
+ (#Cons (with-export-meta meta)
+ #Nil))))
#Nil]))
(#Cons [[_ (#Tag ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])])
- (return (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux def"))
- (#Cons [name
- (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux check"))
- (#Cons [type
- (#Cons [body
- #Nil])])])))
- (#Cons (form$ (#Cons (identifier$ ["lux" "record$"])
- (#Cons (with-export-meta meta)
- #Nil)))
- #Nil)])])])))
+ (return (#Cons [(as-def name (as-checked type body)
+ (form$ (#Cons (identifier$ ["lux" "record$"])
+ (#Cons (with-export-meta meta)
+ #Nil))))
#Nil]))
(#Cons [[_ (#Form (#Cons [name args]))]
(#Cons [meta (#Cons [type (#Cons [body #Nil])])])])
- (return (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux def"))
- (#Cons [name
- (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux check"))
- (#Cons [type
- (#Cons [(_ann (#Form (#Cons [(_ann (#Identifier ["lux" "function''"]))
- (#Cons [name
- (#Cons [(_ann (#Tuple args))
- (#Cons [body #Nil])])])])))
- #Nil])])])))
- (#Cons (form$ (#Cons (identifier$ ["lux" "record$"])
- (#Cons meta
- #Nil)))
- #Nil)])])])))
+ (return (#Cons [(as-def name (as-checked type (as-function name args body))
+ (form$ (#Cons (identifier$ ["lux" "record$"])
+ (#Cons meta
+ #Nil))))
#Nil]))
(#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])
- (return (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux def"))
- (#Cons [name
- (#Cons [(_ann (#Form (#Cons [(_ann (#Text "lux check"))
- (#Cons [type
- (#Cons [body
- #Nil])])])))
- (#Cons (form$ (#Cons (identifier$ ["lux" "record$"])
- (#Cons meta
- #Nil)))
- #Nil)])])])))
+ (return (#Cons [(as-def name (as-checked type body)
+ (form$ (#Cons (identifier$ ["lux" "record$"])
+ (#Cons meta
+ #Nil))))
#Nil]))
_
(fail "Wrong syntax for def''")}
tokens)))
- (record$ default-macro-meta))
-
-(def:'' (macro:' tokens)
- default-macro-meta
- Macro
- ({(#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil))
- (return (#Cons (form$ (#Cons (identifier$ ["lux" "def:''"])
- (#Cons (form$ (#Cons name args))
- (#Cons (with-macro-meta (tag$ ["lux" "Nil"]))
- (#Cons (identifier$ ["lux" "Macro"])
- (#Cons body
- #Nil)))
- )))
- #Nil))
-
- (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil)))
- (return (#Cons (form$ (#Cons (identifier$ ["lux" "def:''"])
- (#Cons (local-tag$ "export")
- (#Cons (form$ (#Cons name args))
- (#Cons (with-macro-meta (tag$ ["lux" "Nil"]))
- (#Cons (identifier$ ["lux" "Macro"])
- (#Cons body
- #Nil)))
- ))))
- #Nil))
-
- (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons meta-data (#Cons body #Nil))))
- (return (#Cons (form$ (#Cons (identifier$ ["lux" "def:''"])
- (#Cons (local-tag$ "export")
- (#Cons (form$ (#Cons name args))
- (#Cons (with-macro-meta meta-data)
- (#Cons (identifier$ ["lux" "Macro"])
- (#Cons body
- #Nil)))
- ))))
- #Nil))
+ (record$ #.Nil))
- _
- (fail "Wrong syntax for macro:'")}
- tokens))
+("lux def" macro:'
+ ("lux macro"
+ (function'' [tokens]
+ ({(#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil))
+ (return (#Cons (as-def name (as-macro (as-function name args body))
+ (form$ (#Cons (identifier$ ["lux" "record$"])
+ (#Cons (tag$ ["lux" "Nil"])
+ #Nil))))
+ #Nil))
+
+ (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons body #Nil)))
+ (return (#Cons (as-def name (as-macro (as-function name args body))
+ (form$ (#Cons (identifier$ ["lux" "record$"])
+ (#Cons (with-export-meta (tag$ ["lux" "Nil"]))
+ #Nil))))
+ #Nil))
+
+ (#Cons [_ (#Tag ["" "export"])] (#Cons [_ (#Form (#Cons name args))] (#Cons meta-data (#Cons body #Nil))))
+ (return (#Cons (as-def name (as-macro (as-function name args body))
+ (form$ (#Cons (identifier$ ["lux" "record$"])
+ (#Cons (with-export-meta meta-data)
+ #Nil))))
+ #Nil))
+
+ _
+ (fail "Wrong syntax for macro:'")}
+ tokens)))
+ (record$ #.Nil))
(macro:' #export (comment tokens)
(#Cons [(tag$ ["lux" "doc"])
@@ -2624,6 +2600,16 @@
(-> Bit Bit)
(if x #0 #1))
+(def:''' (macro-type? type)
+ (list)
+ (-> Type Bit)
+ ({(#Named ["lux" "Macro"] (#Primitive "#Macro" #Nil))
+ #1
+
+ _
+ #0}
+ type))
+
(def:''' (find-macro' modules current-module module name)
#Nil
(-> ($' List (& Text Module))
@@ -2634,7 +2620,7 @@
gdef (let' [{#module-hash _ #module-aliases _ #definitions bindings #imports _ #tags tags #types types #module-annotations _ #module-state _} ("lux check" Module $module)]
(get name bindings))]
(let' [[def-type def-meta def-value] ("lux check" Definition gdef)]
- ({(#Some [_ (#Bit #1)])
+ ({#1
({(#Some [_ (#Bit #1)])
(#Some ("lux coerce" Macro def-value))
@@ -2644,14 +2630,14 @@
#None)}
(get-meta ["lux" "export?"] def-meta))
- _
+ #0
({(#Some [_ (#Identifier [r-module r-name])])
(find-macro' modules current-module r-module r-name)
_
#None}
(get-meta ["lux" "alias"] def-meta))}
- (get-meta ["lux" "macro?"] def-meta)))
+ (macro-type? def-type)))
))
(def:''' (normalize name)
@@ -2719,7 +2705,7 @@
[macro-name' (normalize macro-name)
?macro (find-macro macro-name')]
({(#Some macro)
- (macro args)
+ (("lux coerce" Macro' macro) args)
#None
(return (list token))}
@@ -2738,7 +2724,7 @@
?macro (find-macro macro-name')]
({(#Some macro)
(do meta-monad
- [expansion (macro args)
+ [expansion (("lux coerce" Macro' macro) args)
expansion' (monad@map meta-monad macro-expand expansion)]
(wrap (list@join expansion')))
@@ -2759,7 +2745,7 @@
?macro (find-macro macro-name')]
({(#Some macro)
(do meta-monad
- [expansion (macro args)
+ [expansion (("lux coerce" Macro' macro) args)
expansion' (monad@map meta-monad macro-expand-all expansion)]
(wrap (list@join expansion')))
@@ -3455,36 +3441,39 @@
" _" ..new-line
" (fail ''Wrong syntax for name-of'')))"))])
(let [[exported? tokens] (export^ tokens)
- name+args+meta+body?? (: (Maybe [Name (List Code) Code Code])
+ name+args+meta+body?? (: (Maybe [Name (List Code) (List [Code Code]) Code])
(case tokens
(^ (list [_ (#Form (list& [_ (#Identifier name)] args))] body))
- (#Some [name args (` {}) body])
+ (#Some [name args (list) body])
(^ (list [_ (#Identifier name)] body))
- (#Some [name #Nil (` {}) body])
+ (#Some [name #Nil (list) body])
- (^ (list [_ (#Form (list& [_ (#Identifier name)] args))] [meta-rec-cursor (#Record meta-rec-parts)] body))
- (#Some [name args [meta-rec-cursor (#Record meta-rec-parts)] body])
+ (^ (list [_ (#Form (list& [_ (#Identifier name)] args))] [_ (#Record meta-rec-parts)] body))
+ (#Some [name args meta-rec-parts body])
- (^ (list [_ (#Identifier name)] [meta-rec-cursor (#Record meta-rec-parts)] body))
- (#Some [name #Nil [meta-rec-cursor (#Record meta-rec-parts)] body])
+ (^ (list [_ (#Identifier name)] [_ (#Record meta-rec-parts)] body))
+ (#Some [name #Nil meta-rec-parts body])
_
#None))]
(case name+args+meta+body??
(#Some [name args meta body])
(let [name (identifier$ name)
- def-sig (case args
- #Nil name
- _ (` ((~ name) (~+ args))))]
- (return (list (` (..def: (~+ (export exported?))
- (~ def-sig)
- (~ (meta-code-merge (` {#.macro? #1})
- meta))
-
- ..Macro
- (~ body))))))
-
+ body (case args
+ #Nil
+ body
+
+ _
+ (` ("lux macro"
+ (function ((~ name) (~+ args)) (~ body)))))
+ =meta (process-def-meta meta)]
+ (return (list (` ("lux def" (~ name)
+ (~ body)
+ [(~ cursor-code)
+ (#Record (~ (if exported?
+ (with-export-meta =meta)
+ =meta)))])))))
#None
(fail "Wrong syntax for macro:"))))
diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux
index b05b0682f..e5ac9a87a 100644
--- a/stdlib/source/lux/macro.lux
+++ b/stdlib/source/lux/macro.lux
@@ -202,7 +202,6 @@
(flag-set? (name-of <tag>)))]
[export? #.export? "exported"]
- [macro? #.macro? "a macro"]
[type? #.type? "a type"]
[structure? #.struct? "a structure"]
[recursive-type? #.type-rec? "a recursive type"]
@@ -247,13 +246,22 @@
[declared-tags #.tags "Looks up the tags of a tagged (variant or record) type."]
)
+(def: (macro-type? type)
+ (-> Type Bit)
+ (case type
+ (#.Named ["lux" "Macro"] (#.Primitive "#Macro" #.Nil))
+ true
+
+ _
+ false))
+
(def: (find-macro' modules this-module module name)
(-> (List [Text Module]) Text Text Text
(Maybe Macro))
(do maybe.monad
[$module (get module modules)
[def-type def-anns def-value] (: (Maybe Definition) (|> (: Module $module) (get@ #.definitions) (get name)))]
- (if (macro? def-anns)
+ (if (macro-type? def-type)
(#.Some (:coerce Macro def-value))
(case (get-identifier-ann (name-of #.alias) def-anns)
(#.Some [r-module r-name])
@@ -294,7 +302,7 @@
[?macro (find-macro name)]
(case ?macro
(#.Some macro)
- (macro args)
+ ((:coerce Macro' macro) args)
#.None
(:: ..monad wrap (list syntax))))
@@ -313,7 +321,7 @@
(case ?macro
(#.Some macro)
(do ..monad
- [expansion (macro args)
+ [expansion ((:coerce Macro' macro) args)
expansion' (monad.map ..monad expand expansion)]
(wrap (list@join expansion')))
@@ -333,7 +341,7 @@
(case ?macro
(#.Some macro)
(do ..monad
- [expansion (macro args)
+ [expansion ((:coerce Macro' macro) args)
expansion' (monad.map ..monad expand-all expansion)]
(wrap (list@join expansion')))
diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux
index dd645886f..c315f8d9d 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux
@@ -115,16 +115,15 @@
[lux::coerce Any]
)
-(def: lux::check::type
- Handler
+(def: (caster input output)
+ (-> Type Type Handler)
(function (_ extension-name analyse args)
(case args
(^ (list valueC))
(do ////.monad
- [_ (typeA.infer Type)
- valueA (typeA.with-type Type
- (analyse valueC))]
- (wrap valueA))
+ [_ (typeA.infer output)]
+ (typeA.with-type input
+ (analyse valueC)))
_
(/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)]))))
@@ -136,7 +135,8 @@
(///bundle.install "try" lux::try)
(///bundle.install "check" (lux::check eval))
(///bundle.install "coerce" (lux::coerce eval))
- (///bundle.install "check type" lux::check::type)
+ (///bundle.install "macro" (..caster .Macro' .Macro))
+ (///bundle.install "check type" (..caster .Type .Type))
(///bundle.install "in-module" lux::in-module)))
(def: bundle::io
diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux
index c540e6499..fd02c1497 100644
--- a/stdlib/source/lux/type.lux
+++ b/stdlib/source/lux/type.lux
@@ -169,44 +169,45 @@
(structure: #export equivalence (Equivalence Type)
(def: (= x y)
- (case [x y]
- [(#.Primitive xname xparams) (#.Primitive yname yparams)]
- (and (text@= xname yname)
- (n/= (list.size yparams) (list.size xparams))
- (list@fold (.function (_ [x y] prev) (and prev (= x y)))
- #1
- (list.zip2 xparams yparams)))
-
- (^template [<tag>]
- [(<tag> xid) (<tag> yid)]
- (n/= yid xid))
- ([#.Var] [#.Ex] [#.Parameter])
-
- (^or [(#.Function xleft xright) (#.Function yleft yright)]
- [(#.Apply xleft xright) (#.Apply yleft yright)])
- (and (= xleft yleft)
- (= xright yright))
-
- [(#.Named xname xtype) (#.Named yname ytype)]
- (and (name@= xname yname)
- (= xtype ytype))
-
- (^template [<tag>]
- [(<tag> xL xR) (<tag> yL yR)]
- (and (= xL yL) (= xR yR)))
- ([#.Sum] [#.Product])
-
- (^or [(#.UnivQ xenv xbody) (#.UnivQ yenv ybody)]
- [(#.ExQ xenv xbody) (#.ExQ yenv ybody)])
- (and (n/= (list.size yenv) (list.size xenv))
- (= xbody ybody)
- (list@fold (.function (_ [x y] prev) (and prev (= x y)))
- #1
- (list.zip2 xenv yenv)))
-
- _
- #0
- )))
+ (or (is? x y)
+ (case [x y]
+ [(#.Primitive xname xparams) (#.Primitive yname yparams)]
+ (and (text@= xname yname)
+ (n/= (list.size yparams) (list.size xparams))
+ (list@fold (.function (_ [x y] prev) (and prev (= x y)))
+ #1
+ (list.zip2 xparams yparams)))
+
+ (^template [<tag>]
+ [(<tag> xid) (<tag> yid)]
+ (n/= yid xid))
+ ([#.Var] [#.Ex] [#.Parameter])
+
+ (^or [(#.Function xleft xright) (#.Function yleft yright)]
+ [(#.Apply xleft xright) (#.Apply yleft yright)])
+ (and (= xleft yleft)
+ (= xright yright))
+
+ [(#.Named xname xtype) (#.Named yname ytype)]
+ (and (name@= xname yname)
+ (= xtype ytype))
+
+ (^template [<tag>]
+ [(<tag> xL xR) (<tag> yL yR)]
+ (and (= xL yL) (= xR yR)))
+ ([#.Sum] [#.Product])
+
+ (^or [(#.UnivQ xenv xbody) (#.UnivQ yenv ybody)]
+ [(#.ExQ xenv xbody) (#.ExQ yenv ybody)])
+ (and (n/= (list.size yenv) (list.size xenv))
+ (= xbody ybody)
+ (list@fold (.function (_ [x y] prev) (and prev (= x y)))
+ #1
+ (list.zip2 xenv yenv)))
+
+ _
+ #0
+ ))))
(def: #export (apply params func)
(-> (List Type) Type (Maybe Type))
diff --git a/stdlib/source/program/scriptum.lux b/stdlib/source/program/scriptum.lux
index 37205402e..e37d69d1b 100644
--- a/stdlib/source/program/scriptum.lux
+++ b/stdlib/source/program/scriptum.lux
@@ -21,7 +21,7 @@
["." sequence (#+ Sequence) ("#;." functor)]
["." list ("#;." functor fold)]]]
["." function]
- ["." type]
+ ["." type ("#@." equivalence)]
["." macro]
["." io (#+ IO io)]
[world
@@ -280,7 +280,7 @@
(|>> (#.Cons [name def-annotations (:coerce Type def-value)])))
organization)
- (macro.macro? def-annotations)
+ (type@= .Macro def-type)
(update@ #macros
(: (Mutation (List [Text Code]))
(|>> (#.Cons [name def-annotations])))