diff options
| -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 | ||||
| -rw-r--r-- | stdlib/source/lux.lux | 261 | ||||
| -rw-r--r-- | stdlib/source/lux/macro.lux | 18 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux | 14 | ||||
| -rw-r--r-- | stdlib/source/lux/type.lux | 77 | ||||
| -rw-r--r-- | stdlib/source/program/scriptum.lux | 4 |
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]))) |