aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--epl-v10.html261
-rw-r--r--source/lux.lux108
-rw-r--r--src/lux/analyser/base.clj1
-rw-r--r--src/lux/analyser/case.clj82
-rw-r--r--src/lux/analyser/env.clj24
-rw-r--r--src/lux/analyser/lambda.clj8
-rw-r--r--src/lux/analyser/lux.clj56
-rw-r--r--src/lux/analyser/module.clj97
-rw-r--r--src/lux/analyser/record.clj158
-rw-r--r--src/lux/base.clj130
-rw-r--r--src/lux/compiler.clj5
-rw-r--r--src/lux/compiler/cache.clj2
-rw-r--r--src/lux/compiler/case.clj23
-rw-r--r--src/lux/compiler/lux.clj21
-rw-r--r--src/lux/reader.clj10
-rw-r--r--src/lux/type.clj44
16 files changed, 689 insertions, 341 deletions
diff --git a/epl-v10.html b/epl-v10.html
new file mode 100644
index 000000000..813c07d8c
--- /dev/null
+++ b/epl-v10.html
@@ -0,0 +1,261 @@
+<?xml version="1.0" encoding="ISO-8859-1" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+
+<head>
+<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" />
+<title>Eclipse Public License - Version 1.0</title>
+<style type="text/css">
+ body {
+ size: 8.5in 11.0in;
+ margin: 0.25in 0.5in 0.25in 0.5in;
+ tab-interval: 0.5in;
+ }
+ p {
+ margin-left: auto;
+ margin-top: 0.5em;
+ margin-bottom: 0.5em;
+ }
+ p.list {
+ margin-left: 0.5in;
+ margin-top: 0.05em;
+ margin-bottom: 0.05em;
+ }
+ </style>
+
+</head>
+
+<body lang="EN-US">
+
+<p align=center><b>Eclipse Public License - v 1.0</b></p>
+
+<p>THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE
+PUBLIC LICENSE (&quot;AGREEMENT&quot;). ANY USE, REPRODUCTION OR
+DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS
+AGREEMENT.</p>
+
+<p><b>1. DEFINITIONS</b></p>
+
+<p>&quot;Contribution&quot; means:</p>
+
+<p class="list">a) in the case of the initial Contributor, the initial
+code and documentation distributed under this Agreement, and</p>
+<p class="list">b) in the case of each subsequent Contributor:</p>
+<p class="list">i) changes to the Program, and</p>
+<p class="list">ii) additions to the Program;</p>
+<p class="list">where such changes and/or additions to the Program
+originate from and are distributed by that particular Contributor. A
+Contribution 'originates' from a Contributor if it was added to the
+Program by such Contributor itself or anyone acting on such
+Contributor's behalf. Contributions do not include additions to the
+Program which: (i) are separate modules of software distributed in
+conjunction with the Program under their own license agreement, and (ii)
+are not derivative works of the Program.</p>
+
+<p>&quot;Contributor&quot; means any person or entity that distributes
+the Program.</p>
+
+<p>&quot;Licensed Patents&quot; mean patent claims licensable by a
+Contributor which are necessarily infringed by the use or sale of its
+Contribution alone or when combined with the Program.</p>
+
+<p>&quot;Program&quot; means the Contributions distributed in accordance
+with this Agreement.</p>
+
+<p>&quot;Recipient&quot; means anyone who receives the Program under
+this Agreement, including all Contributors.</p>
+
+<p><b>2. GRANT OF RIGHTS</b></p>
+
+<p class="list">a) Subject to the terms of this Agreement, each
+Contributor hereby grants Recipient a non-exclusive, worldwide,
+royalty-free copyright license to reproduce, prepare derivative works
+of, publicly display, publicly perform, distribute and sublicense the
+Contribution of such Contributor, if any, and such derivative works, in
+source code and object code form.</p>
+
+<p class="list">b) Subject to the terms of this Agreement, each
+Contributor hereby grants Recipient a non-exclusive, worldwide,
+royalty-free patent license under Licensed Patents to make, use, sell,
+offer to sell, import and otherwise transfer the Contribution of such
+Contributor, if any, in source code and object code form. This patent
+license shall apply to the combination of the Contribution and the
+Program if, at the time the Contribution is added by the Contributor,
+such addition of the Contribution causes such combination to be covered
+by the Licensed Patents. The patent license shall not apply to any other
+combinations which include the Contribution. No hardware per se is
+licensed hereunder.</p>
+
+<p class="list">c) Recipient understands that although each Contributor
+grants the licenses to its Contributions set forth herein, no assurances
+are provided by any Contributor that the Program does not infringe the
+patent or other intellectual property rights of any other entity. Each
+Contributor disclaims any liability to Recipient for claims brought by
+any other entity based on infringement of intellectual property rights
+or otherwise. As a condition to exercising the rights and licenses
+granted hereunder, each Recipient hereby assumes sole responsibility to
+secure any other intellectual property rights needed, if any. For
+example, if a third party patent license is required to allow Recipient
+to distribute the Program, it is Recipient's responsibility to acquire
+that license before distributing the Program.</p>
+
+<p class="list">d) Each Contributor represents that to its knowledge it
+has sufficient copyright rights in its Contribution, if any, to grant
+the copyright license set forth in this Agreement.</p>
+
+<p><b>3. REQUIREMENTS</b></p>
+
+<p>A Contributor may choose to distribute the Program in object code
+form under its own license agreement, provided that:</p>
+
+<p class="list">a) it complies with the terms and conditions of this
+Agreement; and</p>
+
+<p class="list">b) its license agreement:</p>
+
+<p class="list">i) effectively disclaims on behalf of all Contributors
+all warranties and conditions, express and implied, including warranties
+or conditions of title and non-infringement, and implied warranties or
+conditions of merchantability and fitness for a particular purpose;</p>
+
+<p class="list">ii) effectively excludes on behalf of all Contributors
+all liability for damages, including direct, indirect, special,
+incidental and consequential damages, such as lost profits;</p>
+
+<p class="list">iii) states that any provisions which differ from this
+Agreement are offered by that Contributor alone and not by any other
+party; and</p>
+
+<p class="list">iv) states that source code for the Program is available
+from such Contributor, and informs licensees how to obtain it in a
+reasonable manner on or through a medium customarily used for software
+exchange.</p>
+
+<p>When the Program is made available in source code form:</p>
+
+<p class="list">a) it must be made available under this Agreement; and</p>
+
+<p class="list">b) a copy of this Agreement must be included with each
+copy of the Program.</p>
+
+<p>Contributors may not remove or alter any copyright notices contained
+within the Program.</p>
+
+<p>Each Contributor must identify itself as the originator of its
+Contribution, if any, in a manner that reasonably allows subsequent
+Recipients to identify the originator of the Contribution.</p>
+
+<p><b>4. COMMERCIAL DISTRIBUTION</b></p>
+
+<p>Commercial distributors of software may accept certain
+responsibilities with respect to end users, business partners and the
+like. While this license is intended to facilitate the commercial use of
+the Program, the Contributor who includes the Program in a commercial
+product offering should do so in a manner which does not create
+potential liability for other Contributors. Therefore, if a Contributor
+includes the Program in a commercial product offering, such Contributor
+(&quot;Commercial Contributor&quot;) hereby agrees to defend and
+indemnify every other Contributor (&quot;Indemnified Contributor&quot;)
+against any losses, damages and costs (collectively &quot;Losses&quot;)
+arising from claims, lawsuits and other legal actions brought by a third
+party against the Indemnified Contributor to the extent caused by the
+acts or omissions of such Commercial Contributor in connection with its
+distribution of the Program in a commercial product offering. The
+obligations in this section do not apply to any claims or Losses
+relating to any actual or alleged intellectual property infringement. In
+order to qualify, an Indemnified Contributor must: a) promptly notify
+the Commercial Contributor in writing of such claim, and b) allow the
+Commercial Contributor to control, and cooperate with the Commercial
+Contributor in, the defense and any related settlement negotiations. The
+Indemnified Contributor may participate in any such claim at its own
+expense.</p>
+
+<p>For example, a Contributor might include the Program in a commercial
+product offering, Product X. That Contributor is then a Commercial
+Contributor. If that Commercial Contributor then makes performance
+claims, or offers warranties related to Product X, those performance
+claims and warranties are such Commercial Contributor's responsibility
+alone. Under this section, the Commercial Contributor would have to
+defend claims against the other Contributors related to those
+performance claims and warranties, and if a court requires any other
+Contributor to pay any damages as a result, the Commercial Contributor
+must pay those damages.</p>
+
+<p><b>5. NO WARRANTY</b></p>
+
+<p>EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS
+PROVIDED ON AN &quot;AS IS&quot; BASIS, WITHOUT WARRANTIES OR CONDITIONS
+OF ANY KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION,
+ANY WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY
+OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely
+responsible for determining the appropriateness of using and
+distributing the Program and assumes all risks associated with its
+exercise of rights under this Agreement , including but not limited to
+the risks and costs of program errors, compliance with applicable laws,
+damage to or loss of data, programs or equipment, and unavailability or
+interruption of operations.</p>
+
+<p><b>6. DISCLAIMER OF LIABILITY</b></p>
+
+<p>EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT
+NOR ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING
+WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR
+DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED
+HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.</p>
+
+<p><b>7. GENERAL</b></p>
+
+<p>If any provision of this Agreement is invalid or unenforceable under
+applicable law, it shall not affect the validity or enforceability of
+the remainder of the terms of this Agreement, and without further action
+by the parties hereto, such provision shall be reformed to the minimum
+extent necessary to make such provision valid and enforceable.</p>
+
+<p>If Recipient institutes patent litigation against any entity
+(including a cross-claim or counterclaim in a lawsuit) alleging that the
+Program itself (excluding combinations of the Program with other
+software or hardware) infringes such Recipient's patent(s), then such
+Recipient's rights granted under Section 2(b) shall terminate as of the
+date such litigation is filed.</p>
+
+<p>All Recipient's rights under this Agreement shall terminate if it
+fails to comply with any of the material terms or conditions of this
+Agreement and does not cure such failure in a reasonable period of time
+after becoming aware of such noncompliance. If all Recipient's rights
+under this Agreement terminate, Recipient agrees to cease use and
+distribution of the Program as soon as reasonably practicable. However,
+Recipient's obligations under this Agreement and any licenses granted by
+Recipient relating to the Program shall continue and survive.</p>
+
+<p>Everyone is permitted to copy and distribute copies of this
+Agreement, but in order to avoid inconsistency the Agreement is
+copyrighted and may only be modified in the following manner. The
+Agreement Steward reserves the right to publish new versions (including
+revisions) of this Agreement from time to time. No one other than the
+Agreement Steward has the right to modify this Agreement. The Eclipse
+Foundation is the initial Agreement Steward. The Eclipse Foundation may
+assign the responsibility to serve as the Agreement Steward to a
+suitable separate entity. Each new version of the Agreement will be
+given a distinguishing version number. The Program (including
+Contributions) may always be distributed subject to the version of the
+Agreement under which it was received. In addition, after a new version
+of the Agreement is published, Contributor may elect to distribute the
+Program (including its Contributions) under the new version. Except as
+expressly stated in Sections 2(a) and 2(b) above, Recipient receives no
+rights or licenses to the intellectual property of any Contributor under
+this Agreement, whether expressly, by implication, estoppel or
+otherwise. All rights in the Program not expressly granted under this
+Agreement are reserved.</p>
+
+<p>This Agreement is governed by the laws of the State of New York and
+the intellectual property laws of the United States of America. No party
+to this Agreement will bring a legal action under this Agreement more
+than one year after the cause of action arose. Each party waives its
+rights to a jury trial in any resulting litigation.</p>
+
+</body>
+
+</html>
diff --git a/source/lux.lux b/source/lux.lux
index 91e00d317..04f9df811 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -122,6 +122,7 @@
#Nil])]))])
#Nil)))])]))
(_lux_export Bindings)
+(_lux_declare-tags [#counter #mappings])
## (deftype (Env k v)
## (& #name Text
@@ -143,6 +144,7 @@
(#BoundT "v")])
#Nil])])])]))])]))
(_lux_export Env)
+(_lux_declare-tags [#name #inner-closures #locals #closure])
## (deftype Cursor
## (, Text Int Int))
@@ -243,19 +245,19 @@
(#Cons [(#BoundT "a")
#Nil])]))])])])]))
-## (deftype Reader
+## (deftype Source
## (List (Meta Cursor Text)))
-(_lux_def Reader
+(_lux_def Source
(#AppT [List
(#AppT [(#AppT [Meta Cursor])
Text])]))
-(_lux_export Reader)
+(_lux_export Source)
-## (deftype HostState
+## (deftype Host
## (& #writer (^ org.objectweb.asm.ClassWriter)
## #loader (^ java.net.URLClassLoader)
## #classes (^ clojure.lang.Atom)))
-(_lux_def HostState
+(_lux_def Host
(#RecordT (#Cons [## "lux;writer"
(#DataT "org.objectweb.asm.ClassWriter")
(#Cons [## "lux;loader"
@@ -263,6 +265,7 @@
(#Cons [## "lux;classes"
(#DataT "clojure.lang.Atom")
#Nil])])])))
+(_lux_declare-tags [#writer #loader #classes])
## (deftype (DefData' m)
## (| (#TypeD Type)
@@ -283,6 +286,7 @@
Ident
#Nil])])])]))]))
(_lux_export DefData')
+(_lux_declare-tags [#TypeD #ValueD #MacroD #AliasD])
## (deftype LuxVar
## (| (#Local Int)
@@ -294,6 +298,7 @@
Ident
#Nil])])))
(_lux_export LuxVar)
+(_lux_declare-tags [#Local #Global])
## (deftype (Module Compiler)
## (& #module-aliases (List (, Text Text))
@@ -323,44 +328,46 @@
#Nil)))])
#Nil])])])]))]))
(_lux_export Module)
+(_lux_declare-tags [#module-aliases #defs #imports #tags])
## (deftype #rec Compiler
-## (& #source Reader
+## (& #source Source
+## #cursor Cursor
## #modules (List (, Text (Module Compiler)))
## #envs (List (Env Text (, LuxVar Type)))
## #types (Bindings Int Type)
-## #host HostState
+## #expected Type
## #seed Int
## #eval? Bool
-## #expected Type
-## #cursor Cursor
+## #host Host
## ))
(_lux_def Compiler
(#AppT [(#AllT [(#Some #Nil) "lux;Compiler" ""
(#RecordT (#Cons [## "lux;source"
- Reader
- (#Cons [## "lux;modules"
- (#AppT [List (#TupleT (#Cons [Text
- (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])])
- #Nil])]))])
- (#Cons [## "lux;envs"
- (#AppT [List (#AppT [(#AppT [Env Text])
- (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])
- (#Cons [## "lux;types"
- (#AppT [(#AppT [Bindings Int]) Type])
- (#Cons [## "lux;host"
- HostState
- (#Cons [## "lux;seed"
- Int
- (#Cons [## "lux;eval?"
- Bool
- (#Cons [## "lux;expected"
- Type
- (#Cons [## "lux;cursor"
- Cursor
+ Source
+ (#Cons [## "lux;cursor"
+ Cursor
+ (#Cons [## "lux;modules"
+ (#AppT [List (#TupleT (#Cons [Text
+ (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])])
+ #Nil])]))])
+ (#Cons [## "lux;envs"
+ (#AppT [List (#AppT [(#AppT [Env Text])
+ (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])
+ (#Cons [## "lux;types"
+ (#AppT [(#AppT [Bindings Int]) Type])
+ (#Cons [## "lux;expected"
+ Type
+ (#Cons [## "lux;seed"
+ Int
+ (#Cons [## "lux;eval?"
+ Bool
+ (#Cons [## "lux;host"
+ Host
#Nil])])])])])])])])]))])
Void]))
(_lux_export Compiler)
+(_lux_declare-tags [#source #cursor #modules #envs #types #expected #seed #eval? #host])
## (deftype Macro
## (-> (List AST) (StateE Compiler (List AST))))
@@ -1016,18 +1023,19 @@
(def''' Monad
Type
(All' [m]
- (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))]
- ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b)))
- ($' (B' m) (B' a))
- ($' (B' m) (B' b))))]))))
+ (#RecordT (list (All' [a] (->' (B' a) ($' (B' m) (B' a))))
+ (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b)))
+ ($' (B' m) (B' a))
+ ($' (B' m) (B' b))))))))
+(_lux_declare-tags [#return #bind])
(def''' Maybe/Monad
($' Monad Maybe)
- {#lux;return
+ {#return
(lambda' return [x]
(#Some x))
- #lux;bind
+ #bind
(lambda' [f ma]
(_lux_case ma
#None #None
@@ -1035,12 +1043,12 @@
(def''' Lux/Monad
($' Monad Lux)
- {#lux;return
+ {#return
(lambda' [x]
(lambda' [state]
(#Right [state x])))
- #lux;bind
+ #bind
(lambda' [f ma]
(lambda' [state]
(_lux_case (ma state)
@@ -1073,12 +1081,12 @@
(defmacro (do tokens)
(_lux_case tokens
- (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])])
+ (#Cons monad (#Cons (#Meta _ (#TupleS bindings)) (#Cons body #Nil)))
(let' [body' (foldL (_lux_: (-> AST (, AST AST) AST)
(lambda' [body' binding]
(let' [[var value] binding]
(_lux_case var
- (#Meta [_ (#TagS ["" "let"])])
+ (#Meta _ (#TagS "" "let"))
(`' (;let' (~ value) (~ body')))
_
@@ -1108,11 +1116,11 @@
#Nil
(wrap #Nil)
- (#Cons [x xs'])
+ (#Cons x xs')
(do m
[y (f x)
ys (map% m f xs')]
- (wrap (#Cons [y ys])))
+ (wrap (#Cons y ys)))
)))
(def''' (. f g)
@@ -1385,6 +1393,10 @@
(#Cons [[k' v] dict'])
(#Cons [[k' v'] (put k v dict')]))))
+(def''' (->text x)
+ (-> (^ java.lang.Object) Text)
+ (_jvm_invokevirtual "java.lang.Object" "toString" [] x []))
+
(def''' (get-module-name state)
($' Lux Text)
(_lux_case state
@@ -1405,7 +1417,7 @@
($' Maybe Macro))
(do Maybe/Monad
[$module (get module modules)
- gdef (let' [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)]
+ gdef (let' [{#module-aliases _ #defs bindings #imports _ #tags tags} (_lux_: ($' Module Compiler) $module)]
(get name bindings))]
(_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef)
[exported? (#MacroD macro')]
@@ -1432,7 +1444,7 @@
#envs envs #types types #host host
#seed seed #eval? eval? #expected expected
#cursor cursor}
- (#Right [state (find-macro' modules current-module module name)]))))))
+ (#Right state (find-macro' modules current-module module name)))))))
(def''' (list:join xs)
(All [a]
@@ -1494,10 +1506,6 @@
(as-pairs tokens))]
(wrap (list (`' (#;RecordT (~ (untemplate-list pairs)))))))))
-(def''' (->text x)
- (-> (^ java.lang.Object) Text)
- (_jvm_invokevirtual "java.lang.Object" "toString" [] x []))
-
(def''' (interpose sep xs)
(All [a]
(-> a ($' List a) ($' List a)))
@@ -2508,7 +2516,7 @@
(if export?
(list name)
(list)))))
- (let [{#module-aliases _ #defs defs #imports _} =module]
+ (let [{#module-aliases _ #defs defs #imports _ #tags tags} =module]
defs))]
(#Right state (list:join to-alias)))
@@ -2721,7 +2729,7 @@
#None
#None
- (#Some {#defs defs #module-aliases _ #imports _})
+ (#Some {#defs defs #module-aliases _ #imports _ #tags tags})
(case (get v-name defs)
#None
#None
@@ -2742,7 +2750,7 @@
## #seed seed #eval? eval? #expected expected} state]
## (do Maybe/Monad
## [module (get v-prefix modules)
-## #let [{#defs defs #module-aliases _ #imports _} module]
+## #let [{#defs defs #module-aliases _ #imports _ #tags tags} module]
## def (get v-name defs)
## #let [[_ def-data] def]]
## (case def-data
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index 58c01e642..fe1e0d55b 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -21,7 +21,6 @@
"text"
"variant"
"tuple"
- "record"
"apply"
"case"
"lambda"
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 6992c11a3..34cbf8b48 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -14,7 +14,8 @@
[type :as &type])
(lux.analyser [base :as &&]
[env :as &env]
- [module :as &module])))
+ [module :as &module]
+ [record :as &&record])))
;; [Tags]
(deftags ""
@@ -25,7 +26,6 @@
"CharTotal"
"TextTotal"
"TupleTotal"
- "RecordTotal"
"VariantTotal"
)
@@ -37,7 +37,6 @@
"CharTestAC"
"TextTestAC"
"TupleTestAC"
- "RecordTestAC"
"VariantTestAC"
)
@@ -194,33 +193,25 @@
_
(fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*))))))
- (&/$RecordS ?slots)
- (|do [;; :let [_ (prn 'PRE (&type/show-type value-type))]
+ (&/$RecordS pairs)
+ (|do [?members (&&record/order-record pairs)
+ ;; :let [_ (prn 'PRE (&type/show-type value-type))]
value-type* (adjust-type value-type)
;; :let [_ (prn 'POST (&type/show-type value-type*))]
;; value-type* (resolve-type value-type)
]
(|case value-type*
- (&/$RecordT ?slot-types)
- (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots)))
- (fail (str "[Analyser Error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]"))
- (|do [[=tests =kont] (&/fold (fn [kont* slot]
- (|let [[sn sv] slot]
- (|case sn
- (&/$Meta _ (&/$TagS ?ident))
- (|do [=ident (&&/resolved-ident ?ident)
- :let [=tag (&/ident->text =ident)]]
- (if-let [=slot-type (&/|get =tag ?slot-types)]
- (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)]
- (return (&/T (&/|put =tag =test =tests) =kont)))
- (fail (str "[Pattern-matching Error] Record-type lacks slot: " =tag))))
-
- _
- (fail (str "[Pattern-matching Error] Record must use tags as slot-names: " (&/show-ast sn))))))
+ (&/$RecordT ?member-types)
+ (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members)))
+ (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require record[" (&/|length ?member-types) "]. Given record[" (&/|length ?members) "]"))
+ (|do [[=tests =kont] (&/fold (fn [kont* vm]
+ (|let [[v m] vm]
+ (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)]
+ (return (&/T (&/|cons =test =tests) =kont)))))
(|do [=kont kont]
- (return (&/T (&/|table) =kont)))
- (&/|reverse ?slots))]
- (return (&/T (&/V $RecordTestAC =tests) =kont))))
+ (return (&/T (&/|list) =kont)))
+ (&/|reverse (&/zip2 ?member-types ?members)))]
+ (return (&/T (&/V $TupleTestAC =tests) =kont))))
_
(fail "[Pattern-matching Error] Record requires record-type.")))
@@ -320,34 +311,6 @@
(return (&/V $TupleTotal (&/T total? structs))))
(fail "[Pattern-matching Error] Inconsistent tuple-size."))
- [($DefaultTotal total?) ($RecordTestAC ?tests)]
- (|do [structs (&/map% (fn [t]
- (|let [[slot value] t]
- (|do [struct* (merge-total (&/V $DefaultTotal total?) (&/T value ?body))]
- (return (&/T slot struct*)))))
- (->> ?tests
- &/->seq
- (sort compare-kv)
- &/->list))]
- (return (&/V $RecordTotal (&/T total? structs))))
-
- [($RecordTotal total? ?values) ($RecordTestAC ?tests)]
- (if (.equals ^Object (&/|length ?values) (&/|length ?tests))
- (|do [structs (&/map2% (fn [left right]
- (|let [[lslot sub-struct] left
- [rslot value]right]
- (if (.equals ^Object lslot rslot)
- (|do [sub-struct* (merge-total sub-struct (&/T value ?body))]
- (return (&/T lslot sub-struct*)))
- (fail "[Pattern-matching Error] Record slots mismatch."))))
- ?values
- (->> ?tests
- &/->seq
- (sort compare-kv)
- &/->list))]
- (return (&/V $RecordTotal (&/T total? structs))))
- (fail "[Pattern-matching Error] Inconsistent record-size."))
-
[($DefaultTotal total?) ($VariantTestAC ?tag ?test)]
(|do [sub-struct (merge-total (&/V $DefaultTotal total?)
(&/T ?test ?body))]
@@ -361,6 +324,7 @@
))))
(defn ^:private check-totality [value-type struct]
+ ;; (prn 'check-totality (&type/show-type value-type) (&/adt->text struct))
(|case struct
($BoolTotal ?total ?values)
(return (or ?total
@@ -389,14 +353,6 @@
?structs ?members)]
(return (&/fold #(and %1 %2) true totals)))
- _
- (fail "[Pattern-maching Error] Tuple is not total."))))
-
- ($RecordTotal ?total ?structs)
- (if ?total
- (return true)
- (|do [value-type* (resolve-type value-type)]
- (|case value-type*
(&/$RecordT ?members)
(|do [totals (&/map2% (fn [sub-struct ?member]
(check-totality ?member sub-struct))
@@ -404,7 +360,7 @@
(return (&/fold #(and %1 %2) true totals)))
_
- (fail "[Pattern-maching Error] Record is not total."))))
+ (fail "[Pattern-maching Error] Tuple is not total."))))
($VariantTotal ?total ?structs)
(if ?total
@@ -422,6 +378,10 @@
($DefaultTotal ?total)
(return ?total)
+
+ ;; _
+ ;; (assert false (prn-str 'check-totality (&type/show-type value-type)
+ ;; (&/adt->text struct)))
))
;; [Exports]
diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj
index 614b38799..4e9dcd79f 100644
--- a/src/lux/analyser/env.clj
+++ b/src/lux/analyser/env.clj
@@ -15,28 +15,28 @@
;; [Exports]
(def next-local-idx
(fn [state]
- (return* state (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))))
+ (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$counter)))))
(defn with-local [name type body]
;; (prn 'with-local name)
(fn [state]
;; (prn 'with-local name)
- (let [old-mappings (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS))
- =return (body (&/update$ &/$ENVS
+ (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings))
+ =return (body (&/update$ &/$envs
(fn [stack]
- (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER))))]
- (&/|cons (&/update$ &/$LOCALS #(->> %
- (&/update$ &/$COUNTER inc)
- (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m))))
+ (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))]
+ (&/|cons (&/update$ &/$locals #(->> %
+ (&/update$ &/$counter inc)
+ (&/update$ &/$mappings (fn [m] (&/|put name (&/T bound-unit type) m))))
(&/|head stack))
(&/|tail stack))))
state))]
(|case =return
(&/$Right ?state ?value)
- (return* (&/update$ &/$ENVS (fn [stack*]
- (&/|cons (&/update$ &/$LOCALS #(->> %
- (&/update$ &/$COUNTER dec)
- (&/set$ &/$MAPPINGS old-mappings))
+ (return* (&/update$ &/$envs (fn [stack*]
+ (&/|cons (&/update$ &/$locals #(->> %
+ (&/update$ &/$counter dec)
+ (&/set$ &/$mappings old-mappings))
(&/|head stack*))
(&/|tail stack*)))
?state)
@@ -47,4 +47,4 @@
(def captured-vars
(fn [state]
- (return* state (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS)))))
+ (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$closure) (&/get$ &/$mappings)))))
diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj
index 91cf3443b..aeb5a4814 100644
--- a/src/lux/analyser/lambda.clj
+++ b/src/lux/analyser/lambda.clj
@@ -27,10 +27,10 @@
(defn close-over [scope name register frame]
(|let [[_ register-type] register
register* (&/T (&/V &&/$captured (&/T scope
- (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER))
+ (->> frame (&/get$ &/$closure) (&/get$ &/$counter))
register))
register-type)]
- (&/T register* (&/update$ &/$CLOSURE #(->> %
- (&/update$ &/$COUNTER inc)
- (&/update$ &/$MAPPINGS (fn [mps] (&/|put name register* mps))))
+ (&/T register* (&/update$ &/$closure #(->> %
+ (&/update$ &/$counter inc)
+ (&/update$ &/$mappings (fn [mps] (&/|put name register* mps))))
frame))))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index e55d5fec8..449ef59c1 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -18,7 +18,8 @@
[lambda :as &&lambda]
[case :as &&case]
[env :as &&env]
- [module :as &&module])))
+ [module :as &&module]
+ [record :as &&record])))
(defn ^:private analyse-1+ [analyse ?token]
(&type/with-var
@@ -124,7 +125,7 @@
;; (fn [$var]
;; (|do [exo-type** (&type/apply-type exo-type* $var)]
;; (analyse-variant analyse exo-type** ident ?values))))
-
+
;; _
;; (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*))))))
@@ -150,26 +151,14 @@
(return ?table)
_
- (fail (str "[Analyser Error] The type of a record must be a record type:\n"
- (&type/show-type exo-type*)
- "\n")))
+ (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*))))
_ (&/assert! (= (&/|length types) (&/|length ?elems))
(str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems)))
- =slots (&/map% (fn [kv]
- (|case kv
- [(&/$Meta _ (&/$TagS ?ident)) ?value]
- (|do [=ident (&&/resolved-ident ?ident)
- :let [?tag (&/ident->text =ident)]
- slot-type (if-let [slot-type (&/|get ?tag types)]
- (return slot-type)
- (fail (str "[Analyser Error] Record type does not have slot: " ?tag)))
- =value (&&/analyse-1 analyse slot-type ?value)]
- (return (&/T ?tag =value)))
-
- _
- (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")))
- ?elems)]
- (return (&/|list (&/T (&/V &&/$record =slots) (&/V &/$RecordT exo-type))))))
+ members (&&record/order-record ?elems)
+ =members (&/map2% (fn [elem-t elem]
+ (&&/analyse-1 analyse elem-t elem))
+ types members)]
+ (return (&/|list (&/T (&/V &&/$tuple =members) exo-type)))))
(defn ^:private analyse-global [analyse exo-type module name]
(|do [[[r-module r-name] $def] (&&module/find-def module name)
@@ -193,9 +182,9 @@
(defn ^:private analyse-local [analyse exo-type name]
(fn [state]
- (|let [stack (&/get$ &/$ENVS state)
- no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? name) not)
- (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? name) not))
+ (|let [stack (&/get$ &/$envs state)
+ no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not)
+ (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not))
[inner outer] (&/|split-with no-binding? stack)]
(|case outer
(&/$Nil)
@@ -204,8 +193,8 @@
state)
(&/$Cons ?genv (&/$Nil))
- (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq))
- (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name))]
+ (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) &/|keys &/->seq))
+ (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))]
(do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0))
(|case global
[(&/$Global ?module* name*) _]
@@ -235,21 +224,21 @@
(&/$Cons top-outer _)
(do ;; (prn 'analyse-symbol/_3 ?module name)
- (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1)
- (&/|map #(&/get$ &/$NAME %) outer)
+ (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$name %2) %1)
+ (&/|map #(&/get$ &/$name %) outer)
(&/|reverse inner)))
[=local inner*] (&/fold2 (fn [register+new-inner frame in-scope]
(|let [[register new-inner] register+new-inner
[register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)]
(&/T register* (&/|cons frame* new-inner))))
- (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name))
- (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get name)))
+ (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))
+ (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name)))
(&/|list))
(&/|reverse inner) scopes)]
((|do [btype (&&/expr-type =local)
_ (&type/check exo-type btype)]
(return (&/|list =local)))
- (&/set$ &/$ENVS (&/|++ inner* outer) state))))
+ (&/set$ &/$envs (&/|++ inner* outer) state))))
))))
(defn analyse-symbol [analyse exo-type ident]
@@ -311,13 +300,14 @@
macro-expansion #(-> macro (.apply ?args) (.apply %))
;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))]
;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)]
- ;; :let [_ (when (or (= "<>" r-name)
+ ;; :let [_ (when (or (= ":" (aget real-name 1))
+ ;; (= "type" (aget real-name 1))
;; ;; (= &&/$struct r-name)
;; )
- ;; (->> (&/|map &/show-ast macro-expansion*)
+ ;; (->> (&/|map &/show-ast macro-expansion)
;; (&/|interpose "\n")
;; (&/fold str "")
- ;; (prn (str r-module ";" r-name))))]
+ ;; (prn (&/ident->text real-name))))]
]
(&/flat-map% (partial analyse exo-type) macro-expansion))
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index 68554a019..6cf25b738 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -11,23 +11,23 @@
(:require [clojure.string :as string]
clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|let |do return return* fail fail* |case]]
+ (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]]
[type :as &type]
- [host :as &host])
- [lux.analyser.base :as &&]))
+ [host :as &host])))
;; [Utils]
-(def ^:private $DEFS 0)
-(def ^:private $IMPORTS 1)
-(def ^:private $ALIASES 2)
-(def ^:private $tags 3)
+(deftags ""
+ "module-aliases"
+ "defs"
+ "imports"
+ "tags")
(def ^:private +init+
- (&/R ;; "lux;defs"
+ (&/R ;; "lux;module-aliases"
+ (&/|table)
+ ;; "lux;defs"
(&/|table)
;; "lux;imports"
(&/|list)
- ;; "lux;module-aliases"
- (&/|table)
;; "lux;tags"
(&/|list)
))
@@ -37,24 +37,24 @@
"(-> Text (Lux (,)))"
(|do [current-module &/get-module-name]
(fn [state]
- (return* (&/update$ &/$MODULES
+ (return* (&/update$ &/$modules
(fn [ms]
(&/|update current-module
- (fn [m] (&/update$ $IMPORTS (partial &/|cons module) m))
+ (fn [m] (&/update$ $imports (partial &/|cons module) m))
ms))
state)
nil))))
(defn define [module name def-data type]
(fn [state]
- (|case (&/get$ &/$ENVS state)
+ (|case (&/get$ &/$envs state)
(&/$Cons ?env (&/$Nil))
(return* (->> state
- (&/update$ &/$MODULES
+ (&/update$ &/$modules
(fn [ms]
(&/|update module
(fn [m]
- (&/update$ $DEFS
+ (&/update$ $defs
#(&/|put name (&/T false def-data) %)
m))
ms))))
@@ -66,8 +66,8 @@
(defn def-type [module name]
"(-> Text Text (Lux Type))"
(fn [state]
- (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))]
- (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))]
+ (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))]
+ (if-let [$def (->> $module (&/get$ $defs) (&/|get name))]
(|case $def
[_ (&/$TypeD _)]
(return* state &type/Type)
@@ -87,14 +87,14 @@
(defn def-alias [a-module a-name r-module r-name type]
;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type))
(fn [state]
- (|case (&/get$ &/$ENVS state)
+ (|case (&/get$ &/$envs state)
(&/$Cons ?env (&/$Nil))
(return* (->> state
- (&/update$ &/$MODULES
+ (&/update$ &/$modules
(fn [ms]
(&/|update a-module
(fn [m]
- (&/update$ $DEFS
+ (&/update$ $defs
#(&/|put a-name (&/T false (&/V &/$AliasD (&/T r-module r-name))) %)
m))
ms))))
@@ -107,15 +107,15 @@
"(-> Text (Lux Bool))"
(fn [state]
(return* state
- (->> state (&/get$ &/$MODULES) (&/|contains? name)))))
+ (->> state (&/get$ &/$modules) (&/|contains? name)))))
(defn alias [module alias reference]
(fn [state]
(return* (->> state
- (&/update$ &/$MODULES
+ (&/update$ &/$modules
(fn [ms]
(&/|update module
- #(&/update$ $ALIASES
+ #(&/update$ $module-aliases
(fn [aliases]
(&/|put alias reference aliases))
%)
@@ -125,7 +125,7 @@
(defn dealias [name]
(|do [current-module &/get-module-name]
(fn [state]
- (if-let [real-name (->> state (&/get$ &/$MODULES) (&/|get current-module) (&/get$ $ALIASES) (&/|get name))]
+ (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))]
(return* state real-name)
(fail* (str "Unknown alias: " name))))))
@@ -133,9 +133,9 @@
(|do [current-module &/get-module-name]
(fn [state]
;; (prn 'find-def/_0 module name 'current-module current-module)
- (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))]
+ (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))]
(do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module)))
- (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))]
+ (if-let [$def (->> $module (&/get$ $defs) (&/|get name))]
(|let [[exported? $$def] $def]
(do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module))
(if (or exported? (.equals ^Object current-module module))
@@ -158,7 +158,7 @@
(defn declare-macro [module name]
(fn [state]
- (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))]
+ (if-let [$module (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))]
(if-let [$def (&/|get name $module)]
(|case $def
[exported? (&/$ValueD ?type _)]
@@ -168,11 +168,11 @@
(.getField "_datum")
(.get nil))]]
(fn [state*]
- (return* (&/update$ &/$MODULES
+ (return* (&/update$ &/$modules
(fn [$modules]
(&/|update module
(fn [m]
- (&/update$ $DEFS
+ (&/update$ $defs
#(&/|put name (&/T exported? (&/V &/$MacroD macro)) %)
m))
$modules))
@@ -190,18 +190,18 @@
(defn export [module name]
(fn [state]
- (|case (&/get$ &/$ENVS state)
+ (|case (&/get$ &/$envs state)
(&/$Cons ?env (&/$Nil))
- (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS) (&/|get name))]
+ (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$ &/$modules (fn [ms]
(&/|update module (fn [m]
- (&/update$ $DEFS
+ (&/update$ $defs
#(&/|put name (&/T true ?data) %)
m))
ms))))
@@ -230,30 +230,30 @@
_
(&/T ?exported? k "V")))))
- (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS)))))))
+ (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs)))))))
(def imports
(|do [module &/get-module-name]
(fn [state]
- (return* state (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $IMPORTS))))))
+ (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports))))))
(defn create-module [name]
"(-> Text (Lux (,)))"
(fn [state]
- (return* (&/update$ &/$MODULES #(&/|put name +init+ %) state) nil)))
+ (return* (&/update$ &/$modules #(&/|put name +init+ %) state) nil)))
(defn enter-module [name]
"(-> Text (Lux (,)))"
(fn [state]
(return* (->> state
- (&/update$ &/$MODULES #(&/|put name +init+ %))
- (&/set$ &/$ENVS (&/|list (&/env name))))
+ (&/update$ &/$modules #(&/|put name +init+ %))
+ (&/set$ &/$envs (&/|list (&/env name))))
nil)))
(defn tags-by-module [module]
"(-> Text (Lux (List (, Text (, Int (List Text))))))"
(fn [state]
- (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))]
+ (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
(return* state (&/get$ $tags =module))
(fail* (str "[Lux Error] Unknown module: " module)))
))
@@ -261,9 +261,9 @@
(defn declare-tags [module tag-names]
"(-> Text (List Text) (Lux (,)))"
(fn [state]
- (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))]
+ (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
(let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)]
- (return* (&/update$ &/$MODULES
+ (return* (&/update$ &/$modules
(fn [=modules]
(&/|update module
#(&/set$ $tags (&/fold (fn [table idx+tag-name]
@@ -280,8 +280,17 @@
(defn tag-index [module tag-name]
"(-> Text Text (Lux Int))"
(fn [state]
- (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))]
+ (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
(if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))]
(return* state (aget idx+tags 0))
- (fail* (str "[Lux Error] Unknown tag: " (&/ident->text (&/T module tag-name)))))
- (fail* (str "[Lux Error] Unknown module: " module)))))
+ (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name)))))
+ (fail* (str "[Module Error] Unknown module: " module)))))
+
+(defn tag-group [module tag-name]
+ "(-> Text Text (Lux (List Ident)))"
+ (fn [state]
+ (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
+ (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))]
+ (return* state (aget idx+tags 1))
+ (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name)))))
+ (fail* (str "[Module Error] Unknown module: " module)))))
diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj
new file mode 100644
index 000000000..2b4b7e095
--- /dev/null
+++ b/src/lux/analyser/record.clj
@@ -0,0 +1,158 @@
+;; Copyright (c) Eduardo Julian. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns lux.analyser.record
+ (:require clojure.core.match
+ clojure.core.match.array
+ (lux [base :as & :refer [deftags |let |do return fail |case]])
+ (lux.analyser [base :as &&]
+ [module :as &&module])))
+
+;; [Tags]
+(deftags ""
+ "bool"
+ "int"
+ "real"
+ "char"
+ "text"
+ "variant"
+ "tuple"
+ "apply"
+ "case"
+ "lambda"
+ "ann"
+ "def"
+ "declare-macro"
+ "var"
+ "captured"
+
+ "jvm-getstatic"
+ "jvm-getfield"
+ "jvm-putstatic"
+ "jvm-putfield"
+ "jvm-invokestatic"
+ "jvm-instanceof"
+ "jvm-invokevirtual"
+ "jvm-invokeinterface"
+ "jvm-invokespecial"
+ "jvm-null?"
+ "jvm-null"
+ "jvm-new"
+ "jvm-new-array"
+ "jvm-aastore"
+ "jvm-aaload"
+ "jvm-class"
+ "jvm-interface"
+ "jvm-try"
+ "jvm-throw"
+ "jvm-monitorenter"
+ "jvm-monitorexit"
+ "jvm-program"
+
+ "jvm-iadd"
+ "jvm-isub"
+ "jvm-imul"
+ "jvm-idiv"
+ "jvm-irem"
+ "jvm-ieq"
+ "jvm-ilt"
+ "jvm-igt"
+
+ "jvm-ceq"
+ "jvm-clt"
+ "jvm-cgt"
+
+ "jvm-ladd"
+ "jvm-lsub"
+ "jvm-lmul"
+ "jvm-ldiv"
+ "jvm-lrem"
+ "jvm-leq"
+ "jvm-llt"
+ "jvm-lgt"
+
+ "jvm-fadd"
+ "jvm-fsub"
+ "jvm-fmul"
+ "jvm-fdiv"
+ "jvm-frem"
+ "jvm-feq"
+ "jvm-flt"
+ "jvm-fgt"
+
+ "jvm-dadd"
+ "jvm-dsub"
+ "jvm-dmul"
+ "jvm-ddiv"
+ "jvm-drem"
+ "jvm-deq"
+ "jvm-dlt"
+ "jvm-dgt"
+
+ "jvm-d2f"
+ "jvm-d2i"
+ "jvm-d2l"
+
+ "jvm-f2d"
+ "jvm-f2i"
+ "jvm-f2l"
+
+ "jvm-i2b"
+ "jvm-i2c"
+ "jvm-i2d"
+ "jvm-i2f"
+ "jvm-i2l"
+ "jvm-i2s"
+
+ "jvm-l2d"
+ "jvm-l2f"
+ "jvm-l2i"
+
+ "jvm-iand"
+ "jvm-ior"
+ "jvm-ixor"
+ "jvm-ishl"
+ "jvm-ishr"
+ "jvm-iushr"
+
+ "jvm-land"
+ "jvm-lor"
+ "jvm-lxor"
+ "jvm-lshl"
+ "jvm-lshr"
+ "jvm-lushr"
+
+ )
+
+;; [Exports]
+(defn order-record [pairs]
+ "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))"
+ (|do [tag-group (|case pairs
+ (&/$Nil)
+ (return (&/|list))
+
+ (&/$Cons [(&/$Meta _ (&/$TagS tag1)) _] _)
+ (|do [[module name] (&&/resolved-ident tag1)]
+ (&&module/tag-group module name))
+
+ _
+ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))
+ =pairs (&/map% (fn [kv]
+ (|case kv
+ [(&/$Meta _ (&/$TagS k)) v]
+ (|do [=k (&&/resolved-ident k)]
+ (return (&/T (&/ident->text =k) v)))
+
+ _
+ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")))
+ pairs)]
+ (&/map% (fn [tag]
+ (if-let [member (&/|get tag =pairs)]
+ (return member)
+ (fail (str "[Analyser Error] Unknown tag: " tag))))
+ (&/|map &/ident->text tag-group))))
diff --git a/src/lux/base.clj b/src/lux/base.clj
index a700a30c8..b8b7118f4 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -63,30 +63,34 @@
;; [Fields]
;; Binding
-(def $COUNTER 0)
-(def $MAPPINGS 1)
+(deftags ""
+ "counter"
+ "mappings")
;; Env
-(def $CLOSURE 0)
-(def $INNER-CLOSURES 1)
-(def $LOCALS 2)
-(def $NAME 3)
+(deftags ""
+ "name"
+ "inner-closures"
+ "locals"
+ "closure")
;; Host
-(def $CLASSES 0)
-(def $LOADER 1)
-(def $WRITER 2)
+(deftags ""
+ "writer"
+ "loader"
+ "classes")
;; Compiler
-(def $cursor 0)
-(def $ENVS 1)
-(def $EVAL? 2)
-(def $EXPECTED 3)
-(def $HOST 4)
-(def $MODULES 5)
-(def $SEED 6)
-(def $SOURCE 7)
-(def $TYPES 8)
+(deftags ""
+ "source"
+ "cursor"
+ "modules"
+ "envs"
+ "types"
+ "expected"
+ "seed"
+ "eval?"
+ "host")
;; Vars
(deftags "lux;"
@@ -533,11 +537,11 @@
(def loader
(fn [state]
- (return* state (->> state (get$ $HOST) (get$ $LOADER)))))
+ (return* state (->> state (get$ $host) (get$ $loader)))))
(def classes
(fn [state]
- (return* state (->> state (get$ $HOST) (get$ $CLASSES)))))
+ (return* state (->> state (get$ $host) (get$ $classes)))))
(def +init-bindings+
(R ;; "lux;counter"
@@ -546,14 +550,14 @@
(|table)))
(defn env [name]
- (R ;; "lux;closure"
- +init-bindings+
+ (R ;; "lux;name"
+ name
;; "lux;inner-closures"
0
;; "lux;locals"
+init-bindings+
- ;; "lux;name"
- name
+ ;; "lux;closure"
+ +init-bindings+
))
(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String
@@ -576,32 +580,32 @@
(defn host [_]
(let [store (atom {})]
- (R ;; "lux;classes"
- store
+ (R ;; "lux;writer"
+ (V $None nil)
;; "lux;loader"
(memory-class-loader store)
- ;; "lux;writer"
- (V $None nil))))
+ ;; "lux;classes"
+ store)))
(defn init-state [_]
- (R ;; "lux;cursor"
+ (R ;; "lux;source"
+ (V $None nil)
+ ;; "lux;cursor"
(T "" -1 -1)
+ ;; "lux;modules"
+ (|table)
;; "lux;envs"
(|list)
- ;; "lux;eval?"
- false
+ ;; "lux;types"
+ +init-bindings+
;; "lux;expected"
(V $VariantT (|list))
- ;; "lux;host"
- (host nil)
- ;; "lux;modules"
- (|table)
;; "lux;seed"
0
- ;; "lux;source"
- (V $None nil)
- ;; "lux;types"
- +init-bindings+
+ ;; "lux;eval?"
+ false
+ ;; "lux;host"
+ (host nil)
))
(defn save-module [body]
@@ -609,8 +613,8 @@
(|case (body state)
($Right state* output)
(return* (->> state*
- (set$ $ENVS (get$ $ENVS state))
- (set$ $SOURCE (get$ $SOURCE state)))
+ (set$ $envs (get$ $envs state))
+ (set$ $source (get$ $source state)))
output)
($Left msg)
@@ -618,20 +622,20 @@
(defn with-eval [body]
(fn [state]
- (|case (body (set$ $EVAL? true state))
+ (|case (body (set$ $eval? true state))
($Right state* output)
- (return* (set$ $EVAL? (get$ $EVAL? state) state*) output)
+ (return* (set$ $eval? (get$ $eval? state) state*) output)
($Left msg)
(fail* msg))))
(def get-eval
(fn [state]
- (return* state (get$ $EVAL? state))))
+ (return* state (get$ $eval? state))))
(def get-writer
(fn [state]
- (let [writer* (->> state (get$ $HOST) (get$ $WRITER))]
+ (let [writer* (->> state (get$ $host) (get$ $writer))]
(|case writer*
($Some datum)
(return* state datum)
@@ -641,15 +645,15 @@
(def get-top-local-env
(fn [state]
- (try (let [top (|head (get$ $ENVS state))]
+ (try (let [top (|head (get$ $envs state))]
(return* state top))
(catch Throwable _
(fail* "No local environment.")))))
(def gen-id
(fn [state]
- (let [seed (get$ $SEED state)]
- (return* (set$ $SEED (inc seed) state) seed))))
+ (let [seed (get$ $seed state)]
+ (return* (set$ $seed (inc seed) state) seed))))
(defn ->seq [xs]
(|case xs
@@ -671,19 +675,19 @@
(def get-module-name
(fn [state]
- (|case (|reverse (get$ $ENVS state))
+ (|case (|reverse (get$ $envs state))
($Nil)
(fail* "[Analyser Error] Can't get the module-name without a module.")
($Cons ?global _)
- (return* state (get$ $NAME ?global)))))
+ (return* state (get$ $name ?global)))))
(defn with-scope [name body]
(fn [state]
- (let [output (body (update$ $ENVS #(|cons (env name) %) state))]
+ (let [output (body (update$ $envs #(|cons (env name) %) state))]
(|case output
($Right state* datum)
- (return* (update$ $ENVS |tail state*) datum)
+ (return* (update$ $envs |tail state*) datum)
_
output))))
@@ -693,23 +697,23 @@
(defn with-closure [body]
(|do [closure-name (|do [top get-top-local-env]
- (return (->> top (get$ $INNER-CLOSURES) str)))]
+ (return (->> top (get$ $inner-closures) str)))]
(fn [state]
(let [body* (with-scope closure-name body)]
- (run-state body* (update$ $ENVS #(|cons (update$ $INNER-CLOSURES inc (|head %))
+ (run-state body* (update$ $envs #(|cons (update$ $inner-closures inc (|head %))
(|tail %))
state))))))
(def get-scope-name
(fn [state]
- (return* state (->> state (get$ $ENVS) (|map #(get$ $NAME %)) |reverse))))
+ (return* state (->> state (get$ $envs) (|map #(get$ $name %)) |reverse))))
(defn with-writer [writer body]
(fn [state]
- (let [output (body (update$ $HOST #(set$ $WRITER (V $Some writer) %) state))]
+ (let [output (body (update$ $host #(set$ $writer (V $Some writer) %) state))]
(|case output
($Right ?state ?value)
- (return* (update$ $HOST #(set$ $WRITER (->> state (get$ $HOST) (get$ $WRITER)) %) ?state)
+ (return* (update$ $host #(set$ $writer (->> state (get$ $host) (get$ $writer)) %) ?state)
?value)
_
@@ -718,10 +722,10 @@
(defn with-expected-type [type body]
"(All [a] (-> Type (Lux a)))"
(fn [state]
- (let [output (body (set$ $EXPECTED type state))]
+ (let [output (body (set$ $expected type state))]
(|case output
($Right ?state ?value)
- (return* (set$ $EXPECTED (get$ $EXPECTED state) ?state)
+ (return* (set$ $expected (get$ $expected state) ?state)
?value)
_
@@ -852,7 +856,7 @@
(def modules
"(Lux (List Text))"
(fn [state]
- (return* state (|keys (get$ $MODULES state)))))
+ (return* state (|keys (get$ $modules state)))))
(defn when% [test body]
"(-> Bool (Lux (,)) (Lux (,)))"
@@ -884,3 +888,9 @@
["" name] (|do [module get-module-name]
(return (T module name)))
_ (return ident)))
+
+(defn ident= [x y]
+ (|let [[xmodule xname] x
+ [ymodule yname] y]
+ (and (= xmodule ymodule)
+ (= xname yname))))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 7622e3002..1814a97c0 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -58,9 +58,6 @@
(&a/$tuple ?elems)
(&&lux/compile-tuple compile-expression ?type ?elems)
- (&a/$record ?elems)
- (&&lux/compile-record compile-expression ?type ?elems)
-
(&a/$var (&/$Local ?idx))
(&&lux/compile-local compile-expression ?type ?idx)
@@ -426,7 +423,7 @@
(fn [state]
(|case ((&/with-writer =class
(&/exhaust% compiler-step))
- (&/set$ &/$SOURCE (&reader/from file-name file-content) state))
+ (&/set$ &/$source (&reader/from file-name file-content) state))
(&/$Right ?state _)
(&/run-state (|do [defs &a-module/defs
imports &a-module/imports
diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj
index 742ac69d8..85488553c 100644
--- a/src/lux/compiler/cache.clj
+++ b/src/lux/compiler/cache.clj
@@ -58,7 +58,7 @@
(defn clean [state]
"(-> Compiler (,))"
- (let [needed-modules (->> state (&/get$ &/$MODULES) &/|keys &/->seq set)
+ (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set)
outdated? #(-> ^File % .getName (string/replace &host/module-separator "/") (->> (contains? needed-modules)) not)
outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?))
program-file (new File &&/output-package)]
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index b108d463c..4d8ac2190 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -102,29 +102,6 @@
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
- (&a-case/$RecordTestAC ?slots)
- (doto writer
- (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
- (-> (doto (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int idx))
- (.visitInsn Opcodes/AALOAD)
- (compile-match test $next $sub-else)
- (.visitLabel $sub-else)
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO $else)
- (.visitLabel $next))
- (->> (|let [[idx [_ test]] idx+member
- $next (new Label)
- $sub-else (new Label)])
- (doseq [idx+member (->> ?slots
- &/->seq
- (sort compare-kv)
- &/->list
- &/enumerate
- &/->seq)])))
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO $target))
-
(&a-case/$VariantTestAC ?tag ?test)
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index 9baefa21c..e2b9f0e89 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -72,27 +72,6 @@
(&/|range num-elems) ?elems)]
(return nil)))
-(defn compile-record [compile *type* ?elems]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [elems* (->> ?elems
- &/->seq
- (sort #(compare (&/|first %1) (&/|first %2)))
- &/->list)
- num-elems (&/|length elems*)
- _ (doto *writer*
- (.visitLdcInsn (int num-elems))
- (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))]
- _ (&/map2% (fn [idx kv]
- (|let [[k v] kv]
- (|do [:let [_ (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int idx)))]
- ret (compile v)
- :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
- (return ret))))
- (&/|range num-elems) elems*)]
- (return nil)))
-
(defn compile-variant [compile *type* ?tag ?value]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
diff --git a/src/lux/reader.clj b/src/lux/reader.clj
index 6aa8cca6d..e0195658f 100644
--- a/src/lux/reader.clj
+++ b/src/lux/reader.clj
@@ -21,7 +21,7 @@
;; [Utils]
(defn ^:private with-line [body]
(fn [state]
- (|case (&/get$ &/$SOURCE state)
+ (|case (&/get$ &/$source state)
(&/$Nil)
(fail* "[Reader Error] EOF")
@@ -32,19 +32,19 @@
(fail* msg)
($Done output)
- (return* (&/set$ &/$SOURCE more state)
+ (return* (&/set$ &/$source more state)
output)
($Yes output line*)
- (return* (&/set$ &/$SOURCE (&/|cons line* more) state)
+ (return* (&/set$ &/$source (&/|cons line* more) state)
output))
)))
(defn ^:private with-lines [body]
(fn [state]
- (|case (body (&/get$ &/$SOURCE state))
+ (|case (body (&/get$ &/$source state))
(&/$Right reader* match)
- (return* (&/set$ &/$SOURCE reader* state)
+ (return* (&/set$ &/$source reader* state)
match)
(&/$Left msg)
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 94b0fbc5e..92c986985 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -209,12 +209,12 @@
(Tuple$ (&/|list (Bound$ "s")
(Bound$ "a"))))))))
-(def Reader
+(def Source
(App$ List
(App$ (App$ Meta Cursor)
Text)))
-(def HostState
+(def Host
(Record$
(&/|list
;; "lux;writer"
@@ -274,7 +274,9 @@
(Record$
(&/|list
;; "lux;source"
- Reader
+ Source
+ ;; "lux;cursor"
+ Cursor
;; "lux;modules"
(App$ List (Tuple$ (&/|list Text
(App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ ""))))))
@@ -284,16 +286,14 @@
(Tuple$ (&/|list LuxVar Type))))
;; "lux;types"
(App$ (App$ Bindings Int) Type)
- ;; "lux;host"
- HostState
+ ;; "lux;expected"
+ Type
;; "lux;seed"
Int
;; "lux;eval?"
Bool
- ;; "lux;expected"
- Type
- ;; "lux;cursor"
- Cursor
+ ;; "lux;host"
+ Host
)))
$Void))
@@ -304,7 +304,7 @@
(defn bound? [id]
(fn [state]
- (if-let [type (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))]
+ (if-let [type (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))]
(|case type
(&/$Some type*)
(return* state true)
@@ -315,7 +315,7 @@
(defn deref [id]
(fn [state]
- (if-let [type* (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))]
+ (if-let [type* (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))]
(|case type*
(&/$Some type)
(return* state type)
@@ -326,26 +326,26 @@
(defn set-var [id type]
(fn [state]
- (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))]
+ (if-let [tvar (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))]
(|case tvar
(&/$Some bound)
(fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound)))
(&/$None)
- (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V &/$Some type) %)
+ (return* (&/update$ &/$types (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %)
ts))
state)
nil))
- (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length))))))
+ (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$types) (&/get$ &/$mappings) &/|length))))))
;; [Exports]
;; Type vars
(def ^:private create-var
(fn [state]
- (let [id (->> state (&/get$ &/$TYPES) (&/get$ &/$COUNTER))]
- (return* (&/update$ &/$TYPES #(->> %
- (&/update$ &/$COUNTER inc)
- (&/update$ &/$MAPPINGS (fn [ms] (&/|put id (&/V &/$None nil) ms))))
+ (let [id (->> state (&/get$ &/$types) (&/get$ &/$counter))]
+ (return* (&/update$ &/$types #(->> %
+ (&/update$ &/$counter inc)
+ (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms))))
state)
id))))
@@ -380,11 +380,11 @@
(|do [?type** (clean* id ?type*)]
(return (&/T ?id (&/V &/$Some ?type**)))))
))))
- (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS)))]
+ (->> state (&/get$ &/$types) (&/get$ &/$mappings)))]
(fn [state]
- (return* (&/update$ &/$TYPES #(->> %
- (&/update$ &/$COUNTER dec)
- (&/set$ &/$MAPPINGS (&/|remove id mappings*)))
+ (return* (&/update$ &/$types #(->> %
+ (&/update$ &/$counter dec)
+ (&/set$ &/$mappings (&/|remove id mappings*)))
state)
nil)))
state))))