diff options
author | Eduardo Julian | 2016-01-02 00:51:31 -0400 |
---|---|---|
committer | Eduardo Julian | 2016-01-02 00:51:31 -0400 |
commit | ee48a4bd1b2f2df2d2a7bb87cc18b672a13546c1 (patch) | |
tree | 7c8454f952d98fc70fd21a1e952c9707d39fadb1 | |
parent | b541374a65ae70d070291e6a16ea266087601362 (diff) |
- Implemented the feature of adding arbitrary meta-data to definitions.
- Implemented exports, macros, tags and aliases on top of definition meta-data (a.k.a DefMeta).
Diffstat (limited to '')
-rw-r--r-- | src/lux/analyser.clj | 27 | ||||
-rw-r--r-- | src/lux/analyser/lux.clj | 111 | ||||
-rw-r--r-- | src/lux/analyser/meta.clj | 41 | ||||
-rw-r--r-- | src/lux/analyser/module.clj | 189 | ||||
-rw-r--r-- | src/lux/base.clj | 24 | ||||
-rw-r--r-- | src/lux/compiler.clj | 15 | ||||
-rw-r--r-- | src/lux/compiler/base.clj | 2 | ||||
-rw-r--r-- | src/lux/compiler/cache.clj | 45 | ||||
-rw-r--r-- | src/lux/compiler/lux.clj | 208 | ||||
-rw-r--r-- | src/lux/compiler/type.clj | 103 | ||||
-rw-r--r-- | src/lux/reader.clj | 17 | ||||
-rw-r--r-- | src/lux/type.clj | 36 |
12 files changed, 403 insertions, 415 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 5a0aa0b3c..71044b923 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -549,20 +549,10 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_def")] (&/$Cons [_ (&/$SymbolS "" ?name)] (&/$Cons ?value - (&/$Nil))))) - (&&lux/analyse-def analyse compile-token ?name ?value) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-macro")] - (&/$Cons [_ (&/$SymbolS "" ?name)] - (&/$Nil)))) - (&&lux/analyse-declare-macro analyse compile-token ?name) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-tags")] - (&/$Cons [_ (&/$TupleS tags)] - (&/$Cons [_ (&/$SymbolS "" type-name)] - (&/$Nil))))) - (|do [tags* (&/map% &&a-parser/parse-tag tags)] - (&&lux/analyse-declare-tags tags* type-name)) + (&/$Cons ?meta + (&/$Nil)) + )))) + (&&lux/analyse-def analyse eval! compile-token ?name ?value ?meta) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")] (&/$Cons [_ (&/$TextS ?path)] @@ -581,11 +571,6 @@ (&/$Nil))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_export")] - (&/$Cons [_ (&/$SymbolS "" ?ident)] - (&/$Nil)))) - (&&lux/analyse-export analyse compile-token ?ident) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_alias")] (&/$Cons [_ (&/$TextS ?alias)] (&/$Cons [_ (&/$TextS ?module)] @@ -687,14 +672,14 @@ (fn [state] (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) (&/$Right state* =fn) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type =fn ?args) state*) _ ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) _ (|do [=fn (just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn)] - (&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args))) + (&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type =fn ?args))) _ (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token)))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index c52cd5937..09e01b6aa 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -16,7 +16,8 @@ [case :as &&case] [env :as &&env] [module :as &&module] - [record :as &&record]))) + [record :as &&record] + [meta :as &&meta]))) ;; [Utils] (defn ^:private count-univq [type] @@ -223,16 +224,7 @@ ))) (defn ^:private analyse-global [analyse exo-type module name] - (|do [[[r-module r-name] $def] (&&module/find-def module name) - endo-type (|case $def - (&/$ValueD ?type _) - (return ?type) - - (&/$MacroD _) - (return &type/Macro) - - (&/$TypeD _) - (return &type/Type)) + (|do [[[r-module r-name] [endo-type ?meta ?value]] (&&module/find-def module name) _ (if (and (clojure.lang.Util/identical &type/Type endo-type) (clojure.lang.Util/identical &type/Type exo-type)) (return nil) @@ -258,25 +250,8 @@ (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] (|case global [(&/$Global ?module* name*) _] - ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) - endo-type (|case $def - (&/$ValueD ?type _) - (return ?type) - - (&/$MacroD _) - (return &type/Macro) - - (&/$TypeD _) - (return &type/Type)) - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta endo-type _cursor - (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) - )))) - state) + (&/run-state (analyse-global analyse exo-type ?module* name*) + state) _ (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")) @@ -350,22 +325,24 @@ (fail (str err "\n" "[Analyser Error] Can't apply function " (&type/show-type fun-type) " to args: " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) )) -(defn analyse-apply [analyse exo-type form-cursor =fn ?args] +(defn ^:private do-analyse-apply [analyse exo-type =fn ?args] + (|do [:let [[[=fn-type =fn-cursor] =fn-form] =fn] + [=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] + (return (&/|list (&&/|meta =output-t =fn-cursor + (&/V &&/$apply (&/T =fn =args)) + ))))) + +(defn analyse-apply [analyse exo-type =fn ?args] (|do [loader &/loader :let [[[=fn-type =fn-cursor] =fn-form] =fn]] (|case =fn-form (&&/$var (&/$Global ?module ?name)) - (|do [[real-name $def] (&&module/find-def ?module ?name)] - (|case $def - (&/$MacroD macro) - (|do [macro-expansion (fn [state] (-> macro (.apply ?args) (.apply state))) - ;; :let [_ (when (or (= "case" (aget real-name 1)) - ;; ;; (= "invoke-static$" (aget real-name 1)) - ;; ;; (= "invoke-virtual$" (aget real-name 1)) - ;; ;; (= "new$" (aget real-name 1)) - ;; ;; (= "let%" (aget real-name 1)) - ;; ;; (= "jvm-import" (aget real-name 1)) - ;; ) + (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)] + (|case (&&meta/meta-get &&meta/macro?-tag ?meta) + (&/$Some _) + (|do [macro-expansion (fn [state] (-> ?value (.apply ?args) (.apply state))) + ;; :let [_ (when (or (= "import" (aget real-name 1)) + ;; (= "defsig" (aget real-name 1))) ;; (->> (&/|map &/show-ast macro-expansion) ;; (&/|interpose "\n") ;; (&/fold str "") @@ -374,16 +351,10 @@ (&/flat-map% (partial analyse exo-type) macro-expansion)) _ - (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&&/|meta =output-t =fn-cursor - (&/V &&/$apply (&/T =fn =args)) - )))))) + (do-analyse-apply analyse exo-type =fn ?args))) _ - (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&&/|meta =output-t =fn-cursor - (&/V &&/$apply (&/T =fn =args)) - ))))) + (do-analyse-apply analyse exo-type =fn ?args)) )) (defn analyse-case [analyse exo-type ?value ?branches] @@ -492,37 +463,20 @@ (|do [output (analyse-lambda** analyse exo-type ?self ?arg ?body)] (return (&/|list output)))) -(defn analyse-def [analyse compile-token ?name ?value] +(defn analyse-def [analyse eval! compile-token ?name ?value ?meta] (|do [module-name &/get-module-name ? (&&module/defined? module-name ?name)] (if ? (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) (|do [=value (&/with-scope ?name - (&&/analyse-1+ analyse ?value))] - (|case =value - [_ (&&/$var (&/$Global ?r-module ?r-name))] - (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value))] - (return &/Nil$)) - - _ - (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) - :let [[[def-type def-cursor] def-analysis] =value - _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) - )]] - (return &/Nil$))) - )))) - -(defn analyse-declare-macro [analyse compile-token ?name] - (|do [module-name &/get-module-name - _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))] - (return &/Nil$))) - -(defn analyse-declare-tags [tags type-name] - (|do [module-name &/get-module-name - [_ def-data] (&&module/find-def module-name type-name) - def-type (&&module/ensure-type-def def-data) - _ (&&module/declare-tags module-name tags def-type)] - (return &/Nil$))) + (&&/analyse-1+ analyse ?value)) + =meta (&&/analyse-1 analyse &type/DefMeta ?meta) + ==meta (eval! =meta) + _ (&&module/test-type module-name ?name ==meta (&&/expr-type* =value)) + _ (&&module/test-macro module-name ?name ==meta (&&/expr-type* =value)) + _ (compile-token (&/V &&/$def (&/T ?name =value ==meta)))] + (return &/Nil$)) + ))) (defn analyse-import [analyse compile-module compile-token path] (|do [module-name &/get-module-name @@ -539,11 +493,6 @@ (return nil))] (return &/Nil$))))) -(defn analyse-export [analyse compile-token name] - (|do [module-name &/get-module-name - _ (&&module/export module-name name)] - (return &/Nil$))) - (defn analyse-alias [analyse compile-token ex-alias ex-module] (|do [module-name &/get-module-name _ (&&module/alias module-name ex-alias ex-module)] diff --git a/src/lux/analyser/meta.clj b/src/lux/analyser/meta.clj new file mode 100644 index 000000000..6b9d91695 --- /dev/null +++ b/src/lux/analyser/meta.clj @@ -0,0 +1,41 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.meta + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]]))) + +;; [Utils] +(defn ^:private ident= [x y] + (|let [[px nx] x + [py ny] y] + (and (= px py) + (= nx ny)))) + +(def ^:private tag-prefix "lux") + +;; [Values] +(defn meta-get [ident dict] + "(-> Ident DefMeta (Maybe DefMetaValue))" + (|case dict + (&/$Cons [k v] dict*) + (if (ident= k ident) + (&/Some$ v) + (meta-get ident dict*)) + + (&/$Nil) + &/None$)) + +(do-template [<name> <tag-name>] + (def <name> (&/V tag-prefix <tag-name>)) + + type?-tag "type?" + alias-tag "alias" + macro?-tag "macro?" + export?-tag "export?" + tags-tag "tags" + ) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 75a62bf95..83a641707 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -12,7 +12,8 @@ (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] [type :as &type] [host :as &host]) - [lux.host.generics :as &host-generics])) + [lux.host.generics :as &host-generics] + (lux.analyser [meta :as &meta]))) ;; [Utils] (deftags @@ -60,10 +61,10 @@ state) nil)))) -(defn define [module name ^objects def-data type] +(defn define [module name def-type def-meta def-value] (fn [state] (when (and (= "Macro" name) (= "lux" module)) - (&type/set-macro-type! (aget def-data 1))) + (&type/set-macro-type! def-value)) (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state @@ -72,7 +73,7 @@ (&/|update module (fn [m] (&/update$ $defs - #(&/|put name (&/T false def-data) %) + #(&/|put name (&/T def-type def-meta def-value) %) m)) ms)))) nil) @@ -85,19 +86,8 @@ (fn [state] (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|case $def - [_ (&/$TypeD _)] - (return* state &type/Type) - - [_ (&/$MacroD _)] - (return* state &type/Macro) - - [_ (&/$ValueD _type _)] - (return* state _type) - - [_ (&/$AliasD ?r-module ?r-name)] - (&/run-state (def-type ?r-module ?r-name) - state)) + (|let [[?type ?meta ?value] $def] + (return* state ?type)) (fail* (str "[Analyser Error] Unknown definition: " (str module ";" name)))) (fail* (str "[Analyser Error] Unknown module: " module))))) @@ -106,33 +96,16 @@ (fn [state] (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|case $def - [_ (&/$TypeD _type)] - (return* state _type) + (|let [[?type ?meta ?value] $def] + (|case (&meta/meta-get &meta/type?-tag ?meta) + (&/$Some _) + (return* state ?value) - _ - (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/T module name))))) + _ + (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/T module name)))))) (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T module name))))) (fail* (str "[Analyser Error] Unknown module: " module))))) -(defn def-alias [a-module a-name r-module r-name type] - (fn [state] - (|case (&/get$ &/$envs state) - (&/$Cons ?env (&/$Nil)) - (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update a-module - (fn [m] - (&/update$ $defs - #(&/|put a-name (&/T false (&/V &/$AliasD (&/T r-module r-name))) %) - m)) - ms)))) - nil) - - _ - (fail* "[Analyser Error] Can't alias a global definition outside of a global environment.")))) - (defn exists? [name] "(-> Text (Lux Bool))" (fn [state] @@ -166,109 +139,39 @@ (fn [state] (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|let [[exported? $$def] $def] - (if (or exported? (.equals ^Object current-module module)) - (|case $$def - (&/$AliasD ?r-module ?r-name) + (|let [[?type ?meta ?value] $def] + (if (.equals ^Object current-module module) + (|case (&meta/meta-get &meta/alias-tag ?meta) + (&/$Some (&/$IdentM [?r-module ?r-name])) ((find-def ?r-module ?r-name) state) _ - (return* state (&/T (&/T module name) $$def))) - (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name))))) + (return* state (&/T (&/T module name) $def))) + (|case (&meta/meta-get &meta/export?-tag ?meta) + (&/$Some (&/$BoolM true)) + (return* state (&/T (&/T module name) $def)) + + _ + (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) (defn ensure-type-def [def-data] "(-> DefData (Lux Type))" - (|case def-data - (&/$TypeD type) - (return type) + (|let [[?type ?meta ?value] def-data] + (|case (&meta/meta-get &meta/type?-tag ?meta) + (&/$Some _) + (return ?type) - _ - (fail (str "[Analyser Error] Not a type definition: " (&/adt->text def-data))))) + _ + (fail (str "[Analyser Error] Not a type definition: " (&/adt->text def-data)))))) (defn defined? [module name] (&/try-all% (&/|list (|do [_ (find-def module name)] (return true)) (return false)))) -(defn declare-macro [module name] - (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))] - (if-let [$def (&/|get name $module)] - (|case $def - [exported? (&/$ValueD ?type _)] - ((|do [_ (&type/check &type/Macro ?type) - ^ClassLoader loader &/loader - :let [macro (-> (.loadClass loader (str (&host-generics/->class-name module) "." (&host/def-name name))) - (.getField &/datum-field) - (.get nil))]] - (fn [state*] - (return* (&/update$ &/$modules - (fn [$modules] - (&/|update module - (fn [m] - (&/update$ $defs - #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %) - m)) - $modules)) - state*) - nil))) - state) - - [_ (&/$MacroD _)] - (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name))) - - [_ _] - (fail* (str "[Analyser Error] Definition does not have macro type: " (str module &/+name-separator+ name)))) - (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) - (fail* (str "[Analyser Error] Module does not exist: " module))))) - -(defn export [module name] - (fn [state] - (|case (&/get$ &/$envs state) - (&/$Cons ?env (&/$Nil)) - (if-let [$def (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) (&/|get name))] - (|case $def - [true _] - (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) - - [false ?data] - (return* (->> state - (&/update$ &/$modules (fn [ms] - (&/|update module (fn [m] - (&/update$ $defs - #(&/|put name (&/T true ?data) %) - m)) - ms)))) - nil)) - (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) - - _ - (fail* "[Analyser Error] Can't export a global definition outside of a global environment.")))) - -(def defs - (|do [module &/get-module-name] - (fn [state] - (return* state - (&/|map (fn [kv] - (|let [[k [?exported? ?def]] kv] - (do ;; (prn 'defs k ?exported?) - (|case ?def - (&/$AliasD ?r-module ?r-name) - (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) - - (&/$MacroD _) - (&/T ?exported? k "M") - - (&/$TypeD _) - (&/T ?exported? k "T") - - _ - (&/T ?exported? k "V"))))) - (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))))))) - (def imports (|do [module &/get-module-name] (fn [state] @@ -311,7 +214,8 @@ (defn ensure-undeclared-type [module name] (|do [types-table (types-by-module module) - _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T module name))))] + _ (&/assert! (nil? (&/|get name types-table)) + (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T module name))))] (return nil))) (defn declare-tags [module tag-names type] @@ -354,3 +258,32 @@ tag-group 1 "(-> Text Text (Lux (List Ident)))" tag-type 2 "(-> Text Text (Lux Type))" ) + +(def defs + (|do [module &/get-module-name] + (fn [state] + (return* state + (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) + (&/|map (fn [kv] + (|let [[k [?def-type ?def-meta ?def-value]] kv] + (|case (&meta/meta-get &meta/alias-tag ?def-meta) + (&/$Some (&/$IdentM [?r-module ?r-name])) + (&/T k (str ?r-module ";" ?r-name)) + + _ + (&/T k "") + ))))))))) + +(do-template [<name> <type> <tag> <desc>] + (defn <name> [module name meta type] + (|case (&meta/meta-get <tag> meta) + (&/$Some (&/$BoolM true)) + (&/try-all% (&/|list (&type/check <type> type) + (fail (str "[Analyser Error] Can't tag as lux;" <desc> "? if it's not a " <desc> ": " (str module ";" name))))) + + _ + (return nil))) + + test-type &type/Type &meta/type?-tag "type" + test-macro &type/Macro &meta/macro?-tag "macro" + ) diff --git a/src/lux/base.clj b/src/lux/base.clj index c0c72c084..ee5e728a1 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -61,13 +61,6 @@ ["Local" "Global"]) -;; Definitions -(deftags - ["ValueD" - "TypeD" - "MacroD" - "AliasD"]) - ;; Binding (deftags ["counter" @@ -125,11 +118,23 @@ "VirtualMethodAnalysis" "OverridenMethodAnalysis"]) +;; Meta-data +(deftags + ["BoolM" + "IntM" + "RealM" + "CharM" + "TextM" + "IdentM" + "ListM" + "DictM"]) + ;; [Exports] -(def datum-field "_datum") -(def meta-field "_meta") (def name-field "_name") (def hash-field "_hash") +(def type-field "_type") +(def meta-field "_meta") +(def value-field "_value") (def compiler-field "_compiler") (def imports-field "_imports") (def defs-field "_defs") @@ -137,7 +142,6 @@ (def tags-field "_tags") (def module-class-name "_") (def +name-separator+ ";") -(def lib-dir "lib") (defn T [& elems] (to-array elems)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 9b16a2001..2a8c64c25 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -424,11 +424,8 @@ (defn ^:private compile-token [syntax] (|case syntax - (&o/$def ?name ?body) - (&&lux/compile-def compile-expression ?name ?body) - - (&o/$declare-macro ?module ?name) - (&&lux/compile-declare-macro compile-expression ?module ?name) + (&o/$def ?name ?body ?meta) + (&&lux/compile-def compile-expression ?name ?body ?meta) (&o/$jvm-program ?body) (&&host/compile-jvm-program compile-expression ?body) @@ -509,12 +506,10 @@ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/defs-field "Ljava/lang/String;" nil (->> defs (&/|map (fn [_def] - (|let [[?exported ?name ?ann] _def] - (str (if ?exported &&/exported-true &&/exported-false) - &&/exported-separator - ?name + (|let [[?name ?alias] _def] + (str ?name &&/exported-separator - ?ann)))) + ?alias)))) (&/|interpose &&/def-separator) (&/fold str ""))) .visitEnd) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 4358ebdac..988502a5f 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -37,8 +37,6 @@ (def ^String closure-prefix "c") (def ^String apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;") -(def exported-true "1") -(def exported-false "0") (def exported-separator " ") (def def-separator "\t") (def import-separator "\t") diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 3337b9b76..fac6b666a 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -14,7 +14,8 @@ [host :as &host]) [lux.host.generics :as &host-generics] (lux.analyser [base :as &a] - [module :as &a-module]) + [module :as &a-module] + [meta :as &a-meta]) (lux.compiler [base :as &&] [io :as &&io])) (:import (java.io File @@ -121,27 +122,24 @@ _ (&/flag-cached-module module) _ (&a-module/set-imports imports) _ (&/map% (fn [_def] - (let [[_exported? _name _ann] (string/split _def #" ")] - (|do [_ (case _ann - "T" (let [def-class (&&/load-class! loader (str module* "." (&host/def-name _name))) - def-value (get-field &/datum-field def-class)] - (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) - "M" (let [def-class (&&/load-class! loader (str module* "." (&host/def-name _name))) - def-value (get-field &/datum-field def-class)] - (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] - (&a-module/declare-macro module _name))) - "V" (let [def-class (&&/load-class! loader (str module* "." (&host/def-name _name))) - def-meta (get-field &/meta-field def-class)] - (|case def-meta - (&/$ValueD def-type _) - (&a-module/define module _name def-meta def-type))) - ;; else - (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] - (|do [__type (&a-module/def-type __module __name)] - (&a-module/def-alias module _name __module __name __type))))] - (if (= &&/exported-true _exported?) - (&a-module/export module _name) - (return nil))) + (let [[_name _alias] (string/split _def #" ")] + (if (= nil _alias) + (let [def-class (&&/load-class! loader (str module* "." (&host/def-name _name))) + def-meta (get-field &/meta-field def-class) + def-type (|case (&a-meta/meta-get &a-meta/type?-tag def-meta) + (&/$Some (&/$BoolM true)) + &type/Type + + _ + (get-field &/type-field def-class)) + def-value (get-field &/value-field def-class)] + (&a-module/define module _name def-type def-meta def-value)) + (let [[_ __module __name] (re-find #"^(.*);(.*)$" _alias) + def-class (&&/load-class! loader (str (&host-generics/->class-name __module) "." (&host/def-name __name))) + def-type (get-field &/type-field def-class) + def-meta (&/|list (&/T &a-meta/alias-tag (&/V &/$IdentM (&/T __module __name)))) + def-value (get-field &/value-field def-class)] + (&a-module/define module _name def-type def-meta def-value))) )) (if (= [""] defs) &/Nil$ @@ -153,6 +151,5 @@ tag-groups)] (return true)))) redo-cache))) - redo-cache) - ) + redo-cache)) redo-cache))))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 54c103c1d..f6abed570 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -17,7 +17,8 @@ [host :as &host]) [lux.host.generics :as &host-generics] (lux.analyser [base :as &a] - [module :as &a-module]) + [module :as &a-module] + [meta :as &a-meta]) (lux.compiler [base :as &&] [lambda :as &&lambda] [type :as &&type])) @@ -104,7 +105,7 @@ (defn compile-global [compile ?owner-class ?name] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&host/def-name ?name)) &/datum-field "Ljava/lang/Object;")]] + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&host/def-name ?name)) &/value-field "Ljava/lang/Object;")]] (return nil))) (defn compile-apply [compile ?fn ?args] @@ -117,111 +118,118 @@ ?args)] (return nil))) -(defn ^:private compile-def-type [compile current-class ?body def-type] - (|do [^MethodVisitor **writer** &/get-writer] - (|case def-type - "type" - (|do [:let [_ (doto **writer** - ;; Tail: Begin - (.visitLdcInsn (int 2)) ;; S - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V - (.visitInsn Opcodes/DUP) ;; VV - (.visitLdcInsn (int 0)) ;; VVI - (.visitLdcInsn &/$TypeD) ;; VVIT - (&&/wrap-long) - (.visitInsn Opcodes/AASTORE) ;; V - (.visitInsn Opcodes/DUP) ;; VV - (.visitLdcInsn (int 1)) ;; VVI - (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;") - (.visitInsn Opcodes/AASTORE) ;; V - )]] - (return nil)) +(defn ^:private compile-def-type [compile ?body] + (|do [:let [?def-type (|case ?body + [[?def-type ?def-cursor] (&a/$ann ?def-value ?type-expr ?def-value-type)] + ?type-expr + + [[?def-type ?def-cursor] ?def-value] + (if (&type/type= &type/Type ?def-type) + (&/T (&/T ?def-type ?def-cursor) + (&/V &a/$tuple (&/|list))) + (&&type/type->analysis ?def-type)))]] + (compile ?def-type))) - "value" - (|let [?def-type (|case ?body - [[?def-type ?def-cursor] (&a/$ann ?def-value ?type-expr ?def-value-type)] - ?type-expr - - [[?def-type ?def-cursor] ?def-value] - (&&type/->analysis ?def-type))] - (|do [:let [_ (doto **writer** - (.visitLdcInsn (int 2)) ;; S - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V - (.visitInsn Opcodes/DUP) ;; VV - (.visitLdcInsn (int 0)) ;; VVI - (.visitLdcInsn &/$ValueD) ;; VVIT - (&&/wrap-long) - (.visitInsn Opcodes/AASTORE) ;; V - (.visitInsn Opcodes/DUP) ;; VV - (.visitLdcInsn (int 1)) ;; VVI - )] - :let [_ (doto **writer** - (.visitLdcInsn (int 2)) ;; S - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V - (.visitInsn Opcodes/DUP) ;; VV - (.visitLdcInsn (int 0)) ;; VVI - )] - _ (compile ?def-type) - :let [_ (.visitInsn **writer** Opcodes/AASTORE)] - :let [_ (doto **writer** - (.visitInsn Opcodes/DUP) ;; VV - (.visitLdcInsn (int 1)) ;; VVI - (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;") - (.visitInsn Opcodes/AASTORE))] - :let [_ (.visitInsn **writer** Opcodes/AASTORE)]] - (return nil))) - ))) +(defn ^:private compile-def-meta [compile ?meta] + (|let [analysis (&&type/defmeta->analysis ?meta)] + (compile analysis))) (let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)] - (defn compile-def [compile ?name ?body] - (|do [:let [=value-type (&a/expr-type* ?body) - def-type (cond (&type/type= &type/Type =value-type) - "type" - - :else - "value")] - ^ClassWriter *writer* &/get-writer - module-name &/get-module-name - [file-name _ _] &/cursor - :let [datum-sig "Ljava/lang/Object;" - def-name (&host/def-name ?name) - current-class (str (&host/->module-class module-name) "/" def-name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version class-flags - current-class nil "java/lang/Object" (into-array [&&/function-class])) - (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) - (doto (.visitEnd))) - (-> (.visitField field-flags &/datum-field datum-sig nil nil) - (doto (.visitEnd))) - (-> (.visitField field-flags &/meta-field datum-sig nil nil) - (doto (.visitEnd))) - (.visitSource file-name nil))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) - (|do [^MethodVisitor **writer** &/get-writer - :let [_ (.visitCode **writer**)] - _ (compile ?body) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/datum-field datum-sig)] - _ (compile-def-type compile current-class ?body def-type) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)] - :let [_ (doto **writer** - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [_ (.visitEnd *writer*)] - _ (&&/save-class! def-name (.toByteArray =class)) - class-loader &/loader - :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class))] - _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)] - (return nil)))) + (defn compile-def [compile ?name ?body ?meta] + (|do [module-name &/get-module-name + class-loader &/loader] + (|case (&a-meta/meta-get &a-meta/alias-tag ?meta) + (&/$Some (&/$IdentM [r-module r-name])) + (if (= 1 (&/|length ?meta)) + (|do [:let [current-class (&host-generics/->class-name (str (&host/->module-class r-module) "/" (&host/def-name r-name))) + def-class (&&/load-class! class-loader current-class) + def-type (-> def-class (.getField &/type-field) (.get nil)) + def-meta ?meta + def-value (-> def-class (.getField &/value-field) (.get nil))] + _ (&a-module/define module-name ?name def-type def-meta def-value)] + (return nil)) + (fail (str "[Compilation Error] Aliases cannot contain meta-data: " module-name ";" ?name))) + + (&/$Some _) + (fail "[Compilation Error] Invalid syntax for lux;alias meta-data. Must be an Ident.") + + _ + (|do [:let [=value-type (&a/expr-type* ?body)] + ^ClassWriter *writer* &/get-writer + [file-name _ _] &/cursor + :let [datum-sig "Ljava/lang/Object;" + def-name (&host/def-name ?name) + current-class (str (&host/->module-class module-name) "/" def-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version class-flags + current-class nil "java/lang/Object" (into-array [&&/function-class])) + (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) + (doto (.visitEnd))) + (-> (.visitField field-flags &/type-field datum-sig nil nil) + (doto (.visitEnd))) + (-> (.visitField field-flags &/meta-field datum-sig nil nil) + (doto (.visitEnd))) + (-> (.visitField field-flags &/value-field datum-sig nil nil) + (doto (.visitEnd))) + (.visitSource file-name nil))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) + (|do [^MethodVisitor **writer** &/get-writer + :let [_ (.visitCode **writer**)] + _ (compile-def-type compile ?body) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/type-field datum-sig)] + _ (compile-def-meta compile ?meta) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)] + _ (compile ?body) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] + :let [_ (doto **writer** + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd *writer*)] + _ (&&/save-class! def-name (.toByteArray =class)) + :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) + [def-type is-type?] (|case (&a-meta/meta-get &a-meta/type?-tag ?meta) + (&/$Some (&/$BoolM true)) + (&/T &type/Type + true) + + _ + (if (&type/type= &type/Type =value-type) + (&/T &type/Type + false) + (&/T (-> def-class (.getField &/type-field) (.get nil)) + false))) + def-meta ?meta + def-value (-> def-class (.getField &/value-field) (.get nil))] + _ (&a-module/define module-name ?name def-type def-meta def-value) + _ (|case (&/T is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)) + [true (&/$Some (&/$ListM tags*))] + (|do [tags (&/map% (fn [tag*] + (|case tag* + (&/$TextM tag) + (return tag) + + _ + (fail "[Compiler Error] Incorrect format for tags."))) + tags*) + _ (&a-module/declare-tags module-name tags def-value)] + (return nil)) + + [false (&/$Some _)] + (fail "[Compiler Error] Can't define tags for non-type.") + + [true (&/$Some _)] + (fail "[Compiler Error] Incorrect format for tags.") + + [_ (&/$None)] + (return nil)) + :let [_ (println 'DEF (str module-name ";" ?name))]] + (return nil)))))) (defn compile-ann [compile ?value-ex ?type-ex ?value-type] (compile ?value-ex)) (defn compile-coerce [compile ?value-ex ?type-ex ?value-type] (compile ?value-ex)) - -(defn compile-declare-macro [compile module name] - (|do [_ (&a-module/declare-macro module name)] - (return nil))) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index c1615f9b6..5b460858c 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -4,7 +4,8 @@ ;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.type - (:require clojure.core.match + (:require [clojure.template :refer [do-template]] + clojure.core.match clojure.core.match.array (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type]) @@ -14,26 +15,30 @@ (defn ^:private variant$ [tag body] "(-> Text Analysis Analysis)" (&a/|meta &type/$Void &/empty-cursor - (&/V &a/$variant (&/T tag body)) - )) + (&/V &a/$variant (&/T tag body)))) (defn ^:private tuple$ [members] "(-> (List Analysis) Analysis)" (&a/|meta &type/$Void &/empty-cursor - (&/V &a/$tuple members) - )) - -(defn ^:private int$ [value] - "(-> Int Analysis)" - (&a/|meta &type/$Void &/empty-cursor - (&/V &a/$int value) - )) - -(defn ^:private text$ [text] - "(-> Text Analysis)" - (&a/|meta &type/$Void &/empty-cursor - (&/V &a/$text text) - )) + (&/V &a/$tuple members))) + +(do-template [<name> <tag> <doc>] + (defn <name> [value] + <doc> + (&a/|meta &type/$Void &/empty-cursor + (&/V <tag> value))) + + ^:private bool$ &a/$bool "(-> Bool Analysis)" + ^:private int$ &a/$int "(-> Int Analysis)" + ^:private real$ &a/$real "(-> Real Analysis)" + ^:private char$ &a/$char "(-> Char Analysis)" + ^:private text$ &a/$text "(-> Text Analysis)" + ) + +(defn ^:private ident$ [value] + "(-> Ident Analysis)" + (|let [[p n] value] + (tuple$ (&/|list (text$ p) (text$ n))))) (def ^:private $Nil "Analysis" @@ -50,37 +55,81 @@ (&/|reverse elems))) ;; [Exports] -(defn ->analysis [type] +(defn type->analysis [type] "(-> Type Analysis)" (|case type (&/$DataT class params) (variant$ &/$DataT (tuple$ (&/|list (text$ class) - (List$ (&/|map ->analysis params))))) + (List$ (&/|map type->analysis params))))) (&/$TupleT members) - (variant$ &/$TupleT (List$ (&/|map ->analysis members))) + (variant$ &/$TupleT (List$ (&/|map type->analysis members))) (&/$VariantT members) - (variant$ &/$VariantT (List$ (&/|map ->analysis members))) + (variant$ &/$VariantT (List$ (&/|map type->analysis members))) (&/$LambdaT input output) - (variant$ &/$LambdaT (tuple$ (&/|list (->analysis input) (->analysis output)))) + (variant$ &/$LambdaT (tuple$ (&/|list (type->analysis input) (type->analysis output)))) (&/$UnivQ env body) (variant$ &/$UnivQ - (tuple$ (&/|list (List$ (&/|map ->analysis env)) - (->analysis body)))) + (tuple$ (&/|list (List$ (&/|map type->analysis env)) + (type->analysis body)))) (&/$BoundT idx) (variant$ &/$BoundT (int$ idx)) (&/$AppT fun arg) - (variant$ &/$AppT (tuple$ (&/|list (->analysis fun) (->analysis arg)))) + (variant$ &/$AppT (tuple$ (&/|list (type->analysis fun) (type->analysis arg)))) (&/$NamedT [module name] type*) (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ module) (text$ name))) - (->analysis type*)))) + (type->analysis type*)))) + + _ + (assert false (prn 'type->analysis (&/adt->text type))) + )) + +(defn ^:private defmetavalue->analysis [dmv] + "(-> DefMetaValue Analysis)" + (|case dmv + (&/$BoolM value) + (variant$ &/$BoolM (bool$ value)) + + (&/$IntM value) + (variant$ &/$IntM (int$ value)) + + (&/$RealM value) + (variant$ &/$RealM (real$ value)) + + (&/$CharM value) + (variant$ &/$CharM (char$ value)) + + (&/$TextM value) + (variant$ &/$TextM (text$ value)) + + (&/$IdentM value) + (variant$ &/$IdentM (ident$ value)) + + (&/$ListM xs) + (variant$ &/$ListM (List$ (&/|map defmetavalue->analysis xs))) + + (&/$DictM kvs) + (variant$ &/$DictM + (List$ (&/|map (fn [kv] + (|let [[k v] kv] + (tuple$ (&/|list (text$ k) + (defmetavalue->analysis v))))) + kvs))) _ - (assert false (prn '->analysis (&type/show-type type) (&/adt->text type))) + (assert false (prn 'defmetavalue->analysis (&/adt->text dmv))) )) + +(defn defmeta->analysis [xs] + "(-> DefMeta Analysis)" + (List$ (&/|map (fn [kv] + (|let [[k v] kv] + (tuple$ (&/|list (ident$ k) + (defmetavalue->analysis v))))) + xs))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index ce25527f3..5d4a73504 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -126,11 +126,12 @@ (&/V $No (str "[Reader Error] Text failed: " text)))))) (defn from [^String name ^String source-code] - (->> source-code - (string/split-lines) - (&/->list) - (&/enumerate) - (&/|map (fn [line+line-num] - (|let [[line-num line] line+line-num] - (&/T (&/T name (inc line-num) 0) - line)))))) + (let [lines (string/split-lines source-code) + indexed-lines (map (fn [line line-num] + (&/T (&/T name (inc line-num) 0) + line)) + lines + (range (count lines)))] + (reduce (fn [tail head] (&/Cons$ head tail)) + &/Nil$ + (reverse indexed-lines)))) diff --git a/src/lux/type.clj b/src/lux/type.clj index f53e80af7..b03558d38 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -115,6 +115,34 @@ ))) $Void)))) +(def DefMetaValue + (Named$ (&/T "lux" "DefMetaValue") + (let [DefMetaValue (App$ (Bound$ 0) (Bound$ 1))] + (App$ (Univ$ empty-env + (Variant$ (&/|list + ;; BoolM + Bool + ;; IntM + Int + ;; RealM + Real + ;; CharM + Char + ;; TextM + Text + ;; IdentM + Ident + ;; ListM + (App$ List DefMetaValue) + ;; DictM + (App$ List (Tuple$ (&/|list Text DefMetaValue))) + ))) + $Void)))) + +(def DefMeta + (Named$ (&/T "lux" "DefMeta") + (App$ List (Tuple$ (&/|list Ident DefMetaValue))))) + (def Macro) (defn set-macro-type! [type] @@ -419,10 +447,10 @@ (defn ^:private check-error [expected actual] (|do [=expected (show-type+ expected) =actual (show-type+ actual)] - (return (str "[Type Checker]\n" - "Expected: " =expected "\n\n" - "Actual: " =actual - "\n")))) + (fail (str "[Type Checker]\n" + "Expected: " =expected "\n\n" + "Actual: " =actual + "\n")))) (defn beta-reduce [env type] (|case type |