aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/README.md15
-rw-r--r--stdlib/license.txt374
-rw-r--r--stdlib/project.clj19
-rw-r--r--stdlib/source/lux.lux5541
-rw-r--r--stdlib/source/lux/cli.lux271
-rw-r--r--stdlib/source/lux/codata/cont.lux64
-rw-r--r--stdlib/source/lux/codata/env.lux65
-rw-r--r--stdlib/source/lux/codata/function.lux23
-rw-r--r--stdlib/source/lux/codata/io.lux56
-rw-r--r--stdlib/source/lux/codata/state.lux114
-rw-r--r--stdlib/source/lux/codata/struct/stream.lux135
-rw-r--r--stdlib/source/lux/compiler.lux559
-rw-r--r--stdlib/source/lux/concurrency/actor.lux278
-rw-r--r--stdlib/source/lux/concurrency/atom.lux41
-rw-r--r--stdlib/source/lux/concurrency/frp.lux194
-rw-r--r--stdlib/source/lux/concurrency/promise.lux233
-rw-r--r--stdlib/source/lux/concurrency/stm.lux237
-rw-r--r--stdlib/source/lux/control/applicative.lux33
-rw-r--r--stdlib/source/lux/control/bounded.lux14
-rw-r--r--stdlib/source/lux/control/codec.lux28
-rw-r--r--stdlib/source/lux/control/comonad.lux54
-rw-r--r--stdlib/source/lux/control/effect.lux315
-rw-r--r--stdlib/source/lux/control/enum.lux24
-rw-r--r--stdlib/source/lux/control/eq.lux29
-rw-r--r--stdlib/source/lux/control/fold.lux12
-rw-r--r--stdlib/source/lux/control/functor.lux16
-rw-r--r--stdlib/source/lux/control/hash.lux15
-rw-r--r--stdlib/source/lux/control/monad.lux142
-rw-r--r--stdlib/source/lux/control/monoid.lux13
-rw-r--r--stdlib/source/lux/control/number.lux22
-rw-r--r--stdlib/source/lux/control/ord.lux44
-rw-r--r--stdlib/source/lux/data/bit.lux66
-rw-r--r--stdlib/source/lux/data/bool.lux47
-rw-r--r--stdlib/source/lux/data/char.lux107
-rw-r--r--stdlib/source/lux/data/error.lux66
-rw-r--r--stdlib/source/lux/data/error/exception.lux62
-rw-r--r--stdlib/source/lux/data/format/json.lux1031
-rw-r--r--stdlib/source/lux/data/ident.lux57
-rw-r--r--stdlib/source/lux/data/identity.lux37
-rw-r--r--stdlib/source/lux/data/log.lux62
-rw-r--r--stdlib/source/lux/data/maybe.lux82
-rw-r--r--stdlib/source/lux/data/number.lux222
-rw-r--r--stdlib/source/lux/data/product.lux35
-rw-r--r--stdlib/source/lux/data/struct/array.lux224
-rw-r--r--stdlib/source/lux/data/struct/dict.lux675
-rw-r--r--stdlib/source/lux/data/struct/list.lux487
-rw-r--r--stdlib/source/lux/data/struct/queue.lux79
-rw-r--r--stdlib/source/lux/data/struct/set.lux85
-rw-r--r--stdlib/source/lux/data/struct/stack.lux47
-rw-r--r--stdlib/source/lux/data/struct/tree.lux54
-rw-r--r--stdlib/source/lux/data/struct/vector.lux428
-rw-r--r--stdlib/source/lux/data/struct/zipper.lux196
-rw-r--r--stdlib/source/lux/data/sum.lux45
-rw-r--r--stdlib/source/lux/data/text.lux223
-rw-r--r--stdlib/source/lux/data/text/format.lux54
-rw-r--r--stdlib/source/lux/host.lux2137
-rw-r--r--stdlib/source/lux/lexer.lux439
-rw-r--r--stdlib/source/lux/macro.lux31
-rw-r--r--stdlib/source/lux/macro/ast.lux149
-rw-r--r--stdlib/source/lux/macro/poly.lux364
-rw-r--r--stdlib/source/lux/macro/poly/eq.lux103
-rw-r--r--stdlib/source/lux/macro/poly/functor.lux126
-rw-r--r--stdlib/source/lux/macro/poly/text-encoder.lux126
-rw-r--r--stdlib/source/lux/macro/syntax.lux472
-rw-r--r--stdlib/source/lux/macro/syntax/common.lux164
-rw-r--r--stdlib/source/lux/macro/template.lux54
-rw-r--r--stdlib/source/lux/math.lux158
-rw-r--r--stdlib/source/lux/math/complex.lux291
-rw-r--r--stdlib/source/lux/math/random.lux283
-rw-r--r--stdlib/source/lux/math/ratio.lux141
-rw-r--r--stdlib/source/lux/pipe.lux147
-rw-r--r--stdlib/source/lux/regex.lux432
-rw-r--r--stdlib/source/lux/test.lux330
-rw-r--r--stdlib/source/lux/type.lux275
-rw-r--r--stdlib/source/lux/type/auto.lux211
-rw-r--r--stdlib/source/lux/type/check.lux518
-rw-r--r--stdlib/test/test/lux.lux164
-rw-r--r--stdlib/test/test/lux/cli.lux84
-rw-r--r--stdlib/test/test/lux/codata/env.lux23
-rw-r--r--stdlib/test/test/lux/codata/io.lux21
-rw-r--r--stdlib/test/test/lux/codata/state.lux34
-rw-r--r--stdlib/test/test/lux/codata/struct/stream.lux68
-rw-r--r--stdlib/test/test/lux/concurrency/actor.lux70
-rw-r--r--stdlib/test/test/lux/concurrency/frp.lux54
-rw-r--r--stdlib/test/test/lux/concurrency/promise.lux31
-rw-r--r--stdlib/test/test/lux/concurrency/stm.lux57
-rw-r--r--stdlib/test/test/lux/data/bit.lux65
-rw-r--r--stdlib/test/test/lux/data/bool.lux38
-rw-r--r--stdlib/test/test/lux/data/char.lux47
-rw-r--r--stdlib/test/test/lux/data/error.lux42
-rw-r--r--stdlib/test/test/lux/data/format/json.lux314
-rw-r--r--stdlib/test/test/lux/data/ident.lux53
-rw-r--r--stdlib/test/test/lux/data/identity.lux36
-rw-r--r--stdlib/test/test/lux/data/log.lux32
-rw-r--r--stdlib/test/test/lux/data/maybe.lux49
-rw-r--r--stdlib/test/test/lux/data/number.lux135
-rw-r--r--stdlib/test/test/lux/data/product.lux20
-rw-r--r--stdlib/test/test/lux/data/struct/array.lux130
-rw-r--r--stdlib/test/test/lux/data/struct/dict.lux136
-rw-r--r--stdlib/test/test/lux/data/struct/list.lux191
-rw-r--r--stdlib/test/test/lux/data/struct/queue.lux54
-rw-r--r--stdlib/test/test/lux/data/struct/set.lux67
-rw-r--r--stdlib/test/test/lux/data/struct/stack.lux47
-rw-r--r--stdlib/test/test/lux/data/struct/tree.lux39
-rw-r--r--stdlib/test/test/lux/data/struct/vector.lux84
-rw-r--r--stdlib/test/test/lux/data/struct/zipper.lux127
-rw-r--r--stdlib/test/test/lux/data/sum.lux32
-rw-r--r--stdlib/test/test/lux/data/text.lux150
-rw-r--r--stdlib/test/test/lux/data/text/format.lux22
-rw-r--r--stdlib/test/test/lux/host.lux54
-rw-r--r--stdlib/test/test/lux/lexer.lux133
-rw-r--r--stdlib/test/test/lux/macro/ast.lux31
-rw-r--r--stdlib/test/test/lux/macro/syntax.lux176
-rw-r--r--stdlib/test/test/lux/math.lux45
-rw-r--r--stdlib/test/test/lux/pipe.lux47
-rw-r--r--stdlib/test/test/lux/regex.lux200
-rw-r--r--stdlib/test/test/lux/type.lux41
-rw-r--r--stdlib/test/tests.lux84
118 files changed, 23729 insertions, 0 deletions
diff --git a/stdlib/README.md b/stdlib/README.md
new file mode 100644
index 000000000..454228d07
--- /dev/null
+++ b/stdlib/README.md
@@ -0,0 +1,15 @@
+# stdlib
+Standard library for the Lux family of programming languages.
+
+### How do I get it?
+
+Just add this to your Leiningen dependencies when building Lux programs:
+```
+[com.github.luxlang/lux-stdlib "0.3.3"]
+```
+
+You can find the Leiningen plugin for Lux over here: https://github.com/LuxLang/lux-lein
+
+### How do I use it?
+
+You can see what's available here: https://github.com/LuxLang/lux/wiki/Standard-Library
diff --git a/stdlib/license.txt b/stdlib/license.txt
new file mode 100644
index 000000000..52d135112
--- /dev/null
+++ b/stdlib/license.txt
@@ -0,0 +1,374 @@
+Mozilla Public License Version 2.0
+==================================
+
+1. Definitions
+--------------
+
+1.1. "Contributor"
+ means each individual or legal entity that creates, contributes to
+ the creation of, or owns Covered Software.
+
+1.2. "Contributor Version"
+ means the combination of the Contributions of others (if any) used
+ by a Contributor and that particular Contributor's Contribution.
+
+1.3. "Contribution"
+ means Covered Software of a particular Contributor.
+
+1.4. "Covered Software"
+ means Source Code Form to which the initial Contributor has attached
+ the notice in Exhibit A, the Executable Form of such Source Code
+ Form, and Modifications of such Source Code Form, in each case
+ including portions thereof.
+
+1.5. "Incompatible With Secondary Licenses"
+ means
+
+ (a) that the initial Contributor has attached the notice described
+ in Exhibit B to the Covered Software; or
+
+ (b) that the Covered Software was made available under the terms of
+ version 1.1 or earlier of the License, but not also under the
+ terms of a Secondary License.
+
+1.6. "Executable Form"
+ means any form of the work other than Source Code Form.
+
+1.7. "Larger Work"
+ means a work that combines Covered Software with other material, in
+ a separate file or files, that is not Covered Software.
+
+1.8. "License"
+ means this document.
+
+1.9. "Licensable"
+ means having the right to grant, to the maximum extent possible,
+ whether at the time of the initial grant or subsequently, any and
+ all of the rights conveyed by this License.
+
+1.10. "Modifications"
+ means any of the following:
+
+ (a) any file in Source Code Form that results from an addition to,
+ deletion from, or modification of the contents of Covered
+ Software; or
+
+ (b) any new file in Source Code Form that contains any Covered
+ Software.
+
+1.11. "Patent Claims" of a Contributor
+ means any patent claim(s), including without limitation, method,
+ process, and apparatus claims, in any patent Licensable by such
+ Contributor that would be infringed, but for the grant of the
+ License, by the making, using, selling, offering for sale, having
+ made, import, or transfer of either its Contributions or its
+ Contributor Version.
+
+1.12. "Secondary License"
+ means either the GNU General Public License, Version 2.0, the GNU
+ Lesser General Public License, Version 2.1, the GNU Affero General
+ Public License, Version 3.0, or any later versions of those
+ licenses.
+
+1.13. "Source Code Form"
+ means the form of the work preferred for making modifications.
+
+1.14. "You" (or "Your")
+ means an individual or a legal entity exercising rights under this
+ License. For legal entities, "You" includes any entity that
+ controls, is controlled by, or is under common control with You. For
+ purposes of this definition, "control" means (a) the power, direct
+ or indirect, to cause the direction or management of such entity,
+ whether by contract or otherwise, or (b) ownership of more than
+ fifty percent (50%) of the outstanding shares or beneficial
+ ownership of such entity.
+
+2. License Grants and Conditions
+--------------------------------
+
+2.1. Grants
+
+Each Contributor hereby grants You a world-wide, royalty-free,
+non-exclusive license:
+
+(a) under intellectual property rights (other than patent or trademark)
+ Licensable by such Contributor to use, reproduce, make available,
+ modify, display, perform, distribute, and otherwise exploit its
+ Contributions, either on an unmodified basis, with Modifications, or
+ as part of a Larger Work; and
+
+(b) under Patent Claims of such Contributor to make, use, sell, offer
+ for sale, have made, import, and otherwise transfer either its
+ Contributions or its Contributor Version.
+
+2.2. Effective Date
+
+The licenses granted in Section 2.1 with respect to any Contribution
+become effective for each Contribution on the date the Contributor first
+distributes such Contribution.
+
+2.3. Limitations on Grant Scope
+
+The licenses granted in this Section 2 are the only rights granted under
+this License. No additional rights or licenses will be implied from the
+distribution or licensing of Covered Software under this License.
+Notwithstanding Section 2.1(b) above, no patent license is granted by a
+Contributor:
+
+(a) for any code that a Contributor has removed from Covered Software;
+ or
+
+(b) for infringements caused by: (i) Your and any other third party's
+ modifications of Covered Software, or (ii) the combination of its
+ Contributions with other software (except as part of its Contributor
+ Version); or
+
+(c) under Patent Claims infringed by Covered Software in the absence of
+ its Contributions.
+
+This License does not grant any rights in the trademarks, service marks,
+or logos of any Contributor (except as may be necessary to comply with
+the notice requirements in Section 3.4).
+
+2.4. Subsequent Licenses
+
+No Contributor makes additional grants as a result of Your choice to
+distribute the Covered Software under a subsequent version of this
+License (see Section 10.2) or under the terms of a Secondary License (if
+permitted under the terms of Section 3.3).
+
+2.5. Representation
+
+Each Contributor represents that the Contributor believes its
+Contributions are its original creation(s) or it has sufficient rights
+to grant the rights to its Contributions conveyed by this License.
+
+2.6. Fair Use
+
+This License is not intended to limit any rights You have under
+applicable copyright doctrines of fair use, fair dealing, or other
+equivalents.
+
+2.7. Conditions
+
+Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted
+in Section 2.1.
+
+3. Responsibilities
+-------------------
+
+3.1. Distribution of Source Form
+
+All distribution of Covered Software in Source Code Form, including any
+Modifications that You create or to which You contribute, must be under
+the terms of this License. You must inform recipients that the Source
+Code Form of the Covered Software is governed by the terms of this
+License, and how they can obtain a copy of this License. You may not
+attempt to alter or restrict the recipients' rights in the Source Code
+Form.
+
+3.2. Distribution of Executable Form
+
+If You distribute Covered Software in Executable Form then:
+
+(a) such Covered Software must also be made available in Source Code
+ Form, as described in Section 3.1, and You must inform recipients of
+ the Executable Form how they can obtain a copy of such Source Code
+ Form by reasonable means in a timely manner, at a charge no more
+ than the cost of distribution to the recipient; and
+
+(b) You may distribute such Executable Form under the terms of this
+ License, or sublicense it under different terms, provided that the
+ license for the Executable Form does not attempt to limit or alter
+ the recipients' rights in the Source Code Form under this License.
+
+3.3. Distribution of a Larger Work
+
+You may create and distribute a Larger Work under terms of Your choice,
+provided that You also comply with the requirements of this License for
+the Covered Software. If the Larger Work is a combination of Covered
+Software with a work governed by one or more Secondary Licenses, and the
+Covered Software is not Incompatible With Secondary Licenses, this
+License permits You to additionally distribute such Covered Software
+under the terms of such Secondary License(s), so that the recipient of
+the Larger Work may, at their option, further distribute the Covered
+Software under the terms of either this License or such Secondary
+License(s).
+
+3.4. Notices
+
+You may not remove or alter the substance of any license notices
+(including copyright notices, patent notices, disclaimers of warranty,
+or limitations of liability) contained within the Source Code Form of
+the Covered Software, except that You may alter any license notices to
+the extent required to remedy known factual inaccuracies.
+
+3.5. Application of Additional Terms
+
+You may choose to offer, and to charge a fee for, warranty, support,
+indemnity or liability obligations to one or more recipients of Covered
+Software. However, You may do so only on Your own behalf, and not on
+behalf of any Contributor. You must make it absolutely clear that any
+such warranty, support, indemnity, or liability obligation is offered by
+You alone, and You hereby agree to indemnify every Contributor for any
+liability incurred by such Contributor as a result of warranty, support,
+indemnity or liability terms You offer. You may include additional
+disclaimers of warranty and limitations of liability specific to any
+jurisdiction.
+
+4. Inability to Comply Due to Statute or Regulation
+---------------------------------------------------
+
+If it is impossible for You to comply with any of the terms of this
+License with respect to some or all of the Covered Software due to
+statute, judicial order, or regulation then You must: (a) comply with
+the terms of this License to the maximum extent possible; and (b)
+describe the limitations and the code they affect. Such description must
+be placed in a text file included with all distributions of the Covered
+Software under this License. Except to the extent prohibited by statute
+or regulation, such description must be sufficiently detailed for a
+recipient of ordinary skill to be able to understand it.
+
+5. Termination
+--------------
+
+5.1. The rights granted under this License will terminate automatically
+if You fail to comply with any of its terms. However, if You become
+compliant, then the rights granted under this License from a particular
+Contributor are reinstated (a) provisionally, unless and until such
+Contributor explicitly and finally terminates Your grants, and (b) on an
+ongoing basis, if such Contributor fails to notify You of the
+non-compliance by some reasonable means prior to 60 days after You have
+come back into compliance. Moreover, Your grants from a particular
+Contributor are reinstated on an ongoing basis if such Contributor
+notifies You of the non-compliance by some reasonable means, this is the
+first time You have received notice of non-compliance with this License
+from such Contributor, and You become compliant prior to 30 days after
+Your receipt of the notice.
+
+5.2. If You initiate litigation against any entity by asserting a patent
+infringement claim (excluding declaratory judgment actions,
+counter-claims, and cross-claims) alleging that a Contributor Version
+directly or indirectly infringes any patent, then the rights granted to
+You by any and all Contributors for the Covered Software under Section
+2.1 of this License shall terminate.
+
+5.3. In the event of termination under Sections 5.1 or 5.2 above, all
+end user license agreements (excluding distributors and resellers) which
+have been validly granted by You or Your distributors under this License
+prior to termination shall survive termination.
+
+************************************************************************
+* *
+* 6. Disclaimer of Warranty *
+* ------------------------- *
+* *
+* Covered Software is provided under this License on an "as is" *
+* basis, without warranty of any kind, either expressed, implied, or *
+* statutory, including, without limitation, warranties that the *
+* Covered Software is free of defects, merchantable, fit for a *
+* particular purpose or non-infringing. The entire risk as to the *
+* quality and performance of the Covered Software is with You. *
+* Should any Covered Software prove defective in any respect, You *
+* (not any Contributor) assume the cost of any necessary servicing, *
+* repair, or correction. This disclaimer of warranty constitutes an *
+* essential part of this License. No use of any Covered Software is *
+* authorized under this License except under this disclaimer. *
+* *
+************************************************************************
+
+************************************************************************
+* *
+* 7. Limitation of Liability *
+* -------------------------- *
+* *
+* Under no circumstances and under no legal theory, whether tort *
+* (including negligence), contract, or otherwise, shall any *
+* Contributor, or anyone who distributes Covered Software as *
+* permitted above, be liable to You for any direct, indirect, *
+* special, incidental, or consequential damages of any character *
+* including, without limitation, damages for lost profits, loss of *
+* goodwill, work stoppage, computer failure or malfunction, or any *
+* and all other commercial damages or losses, even if such party *
+* shall have been informed of the possibility of such damages. This *
+* limitation of liability shall not apply to liability for death or *
+* personal injury resulting from such party's negligence to the *
+* extent applicable law prohibits such limitation. Some *
+* jurisdictions do not allow the exclusion or limitation of *
+* incidental or consequential damages, so this exclusion and *
+* limitation may not apply to You. *
+* *
+************************************************************************
+
+8. Litigation
+-------------
+
+Any litigation relating to this License may be brought only in the
+courts of a jurisdiction where the defendant maintains its principal
+place of business and such litigation shall be governed by laws of that
+jurisdiction, without reference to its conflict-of-law provisions.
+Nothing in this Section shall prevent a party's ability to bring
+cross-claims or counter-claims.
+
+9. Miscellaneous
+----------------
+
+This License represents the complete agreement concerning the subject
+matter hereof. If any provision of this License is held to be
+unenforceable, such provision shall be reformed only to the extent
+necessary to make it enforceable. Any law or regulation which provides
+that the language of a contract shall be construed against the drafter
+shall not be used to construe this License against a Contributor.
+
+10. Versions of the License
+---------------------------
+
+10.1. New Versions
+
+Mozilla Foundation is the license steward. Except as provided in Section
+10.3, no one other than the license steward has the right to modify or
+publish new versions of this License. Each version will be given a
+distinguishing version number.
+
+10.2. Effect of New Versions
+
+You may distribute the Covered Software under the terms of the version
+of the License under which You originally received the Covered Software,
+or under the terms of any subsequent version published by the license
+steward.
+
+10.3. Modified Versions
+
+If you create software not governed by this License, and you want to
+create a new license for such software, you may create and use a
+modified version of this License if you rename the license and remove
+any references to the name of the license steward (except to note that
+such modified license differs from this License).
+
+10.4. Distributing Source Code Form that is Incompatible With Secondary
+Licenses
+
+If You choose to distribute Source Code Form that is Incompatible With
+Secondary Licenses under the terms of this version of the License, the
+notice described in Exhibit B of this License must be attached.
+
+Exhibit A - Source Code Form License Notice
+-------------------------------------------
+
+ 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/.
+
+If it is not possible or desirable to put the notice in a particular
+file, then You may include the notice in a location (such as a LICENSE
+file in a relevant directory) where a recipient would be likely to look
+for such a notice.
+
+You may add additional accurate notices of copyright ownership.
+
+Exhibit B - "Incompatible With Secondary Licenses" Notice
+---------------------------------------------------------
+
+ This Source Code Form is "Incompatible With Secondary Licenses", as
+ defined by the Mozilla Public License, v. 2.0.
+
diff --git a/stdlib/project.clj b/stdlib/project.clj
new file mode 100644
index 000000000..287a2f803
--- /dev/null
+++ b/stdlib/project.clj
@@ -0,0 +1,19 @@
+(defproject com.github.luxlang/lux-stdlib "0.5.0-SNAPSHOT"
+ :description "Standard library for the Lux programming language."
+ :url "https://github.com/LuxLang/stdlib"
+ :license {:name "Mozilla Public License (Version 2.0)"
+ :url "https://www.mozilla.org/en-US/MPL/2.0/"}
+ :plugins [[com.github.luxlang/lein-luxc "0.5.0-SNAPSHOT"]]
+ :deploy-repositories [["releases" {:url "https://oss.sonatype.org/service/local/staging/deploy/maven2/"
+ :creds :gpg}]
+ ["snapshots" {:url "https://oss.sonatype.org/content/repositories/snapshots/"
+ :creds :gpg}]]
+ :pom-addition [:developers [:developer
+ [:name "Eduardo Julian"]
+ [:url "https://github.com/eduardoejp"]]]
+ :repositories [["snapshots" "https://oss.sonatype.org/content/repositories/snapshots/"]
+ ["releases" "https://oss.sonatype.org/service/local/staging/deploy/maven2/"]]
+ :source-paths ["source"]
+ :test-paths ["test"]
+ :lux {:tests "tests"}
+ )
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
new file mode 100644
index 000000000..2b66cdbe1
--- /dev/null
+++ b/stdlib/source/lux.lux
@@ -0,0 +1,5541 @@
+## 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/.
+
+## Basic types
+(_lux_def Bool
+ (+12 ["lux" "Bool"]
+ (+0 "java.lang.Boolean" (+0)))
+ (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0))))
+
+(_lux_def Nat
+ (+12 ["lux" "Nat"]
+ (+0 "#Nat" (+0)))
+ (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0))))
+
+(_lux_def Int
+ (+12 ["lux" "Int"]
+ (+0 "java.lang.Long" (+0)))
+ (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0))))
+
+(_lux_def Real
+ (+12 ["lux" "Real"]
+ (+0 "java.lang.Double" (+0)))
+ (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0))))
+
+(_lux_def Frac
+ (+12 ["lux" "Frac"]
+ (+0 "#Frac" (+0)))
+ (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0))))
+
+(_lux_def Char
+ (+12 ["lux" "Char"]
+ (+0 "java.lang.Character" (+0)))
+ (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0))))
+
+(_lux_def Text
+ (+12 ["lux" "Text"]
+ (+0 "java.lang.String" (+0)))
+ (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0))))
+
+(_lux_def Void
+ (+12 ["lux" "Void"]
+ (+1))
+ (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0))))
+
+(_lux_def Unit
+ (+12 ["lux" "Unit"]
+ (+2))
+ (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0))))
+
+(_lux_def Ident
+ (+12 ["lux" "Ident"]
+ (+4 Text Text))
+ (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+0))))
+
+## (type: (List a)
+## #Nil
+## (#Cons a (List a)))
+(_lux_def List
+ (+12 ["lux" "List"]
+ (+9 (+0)
+ (+3 ## "lux;Nil"
+ (+2)
+ ## "lux;Cons"
+ (+4 (+6 +1)
+ (+11 (+6 +0) (+6 +1))))))
+ (+1 [["lux" "type?"] (+0 true)]
+ (+1 [["lux" "export?"] (+0 true)]
+ (+1 [["lux" "tags"] (+8 (+1 (+6 "Nil") (+1 (+6 "Cons") (+0))))]
+ (+1 [["lux" "type-args"] (+8 (+1 (+6 "a") (+0)))]
+ (+0))))))
+
+## (type: (Maybe a)
+## #None
+## (#Some a))
+(_lux_def Maybe
+ (+12 ["lux" "Maybe"]
+ (+9 (+0)
+ (+3 ## "lux;None"
+ (+2)
+ ## "lux;Some"
+ (+6 +1))))
+ (#Cons [["lux" "type?"] (+0 true)]
+ (#Cons [["lux" "export?"] (+0 true)]
+ (#Cons [["lux" "tags"] (+8 (#Cons (+6 "None") (#Cons (+6 "Some") #Nil)))]
+ (#Cons [["lux" "type-args"] (+8 (#Cons (+6 "a") #Nil))]
+ #Nil)))))
+
+## (type: #rec Type
+## (#HostT Text (List Type))
+## #VoidT
+## #UnitT
+## (#SumT Type Type)
+## (#ProdT Type Type)
+## (#LambdaT Type Type)
+## (#BoundT Nat)
+## (#VarT Nat)
+## (#ExT Nat)
+## (#UnivQ (List Type) Type)
+## (#ExQ (List Type) Type)
+## (#AppT Type Type)
+## (#NamedT Ident Type)
+## )
+(_lux_def Type
+ (+12 ["lux" "Type"]
+ (_lux_case (+11 (+6 +0) (+6 +1))
+ Type
+ (_lux_case (+11 List Type)
+ TypeList
+ (_lux_case (+4 Type Type)
+ TypePair
+ (+11 (+9 (+0)
+ (+3 ## "lux;HostT"
+ (+4 Text TypeList)
+ (+3 ## "lux;VoidT"
+ (+2)
+ (+3 ## "lux;UnitT"
+ (+2)
+ (+3 ## "lux;SumT"
+ TypePair
+ (+3 ## "lux;ProdT"
+ TypePair
+ (+3 ## "lux;LambdaT"
+ TypePair
+ (+3 ## "lux;BoundT"
+ Nat
+ (+3 ## "lux;VarT"
+ Nat
+ (+3 ## "lux;ExT"
+ Nat
+ (+3 ## "lux;UnivQ"
+ (+4 TypeList Type)
+ (+3 ## "lux;ExQ"
+ (+4 TypeList Type)
+ (+3 ## "lux;AppT"
+ TypePair
+ ## "lux;NamedT"
+ (+4 Ident Type))))))))))))))
+ Void)))))
+ (#Cons [["lux" "type?"] (+0 true)]
+ (#Cons [["lux" "export?"] (+0 true)]
+ (#Cons [["lux" "tags"] (+8 (#Cons (+6 "HostT")
+ (#Cons (+6 "VoidT")
+ (#Cons (+6 "UnitT")
+ (#Cons (+6 "SumT")
+ (#Cons (+6 "ProdT")
+ (#Cons (+6 "LambdaT")
+ (#Cons (+6 "BoundT")
+ (#Cons (+6 "VarT")
+ (#Cons (+6 "ExT")
+ (#Cons (+6 "UnivQ")
+ (#Cons (+6 "ExQ")
+ (#Cons (+6 "AppT")
+ (#Cons (+6 "NamedT")
+ #Nil))))))))))))))]
+ (#Cons [["lux" "doc"] (+6 "This type represents the data-structures that are used to specify types themselves.")]
+ (#Cons [["lux" "type-rec?"] (+0 true)]
+ #Nil))))))
+
+## (type: Top
+## (Ex [a] a))
+(_lux_def Top
+ (#NamedT ["lux" "Top"]
+ (#ExQ (+0) (#BoundT +1)))
+ (#Cons [["lux" "type?"] (+0 true)]
+ (#Cons [["lux" "export?"] (+0 true)]
+ (#Cons [["lux" "doc"] (+6 "The type of things whose type doesn't matter.
+ It can be used to write functions or data-structures that can take, or return anything.")]
+ #Nil))))
+
+## (type: Bottom
+## (All [a] a))
+(_lux_def Bottom
+ (#NamedT ["lux" "Bottom"]
+ (#UnivQ (+0) (#BoundT +1)))
+ (#Cons [["lux" "type?"] (+0 true)]
+ (#Cons [["lux" "export?"] (+0 true)]
+ (#Cons [["lux" "doc"] (+6 "The type of things whose type is unknown or undefined.
+ Useful for expressions that cause errors or other \"extraordinary\" conditions.")]
+ #Nil))))
+
+## (type: #rec Ann-Value
+## (#BoolM Bool)
+## (#NatM Nat)
+## (#IntM Int)
+## (#FracM Frac)
+## (#RealM Real)
+## (#CharM Char)
+## (#TextM Text)
+## (#IdentM Ident)
+## (#ListM (List Ann-Value))
+## (#DictM (List [Text Ann-Value])))
+(_lux_def Ann-Value
+ (#NamedT ["lux" "Ann-Value"]
+ (_lux_case (#AppT (#BoundT +0) (#BoundT +1))
+ Ann-Value
+ (#AppT (#UnivQ #Nil
+ (#SumT ## #BoolM
+ Bool
+ (#SumT ## #NatM
+ Nat
+ (#SumT ## #IntM
+ Int
+ (#SumT ## #FracM
+ Frac
+ (#SumT ## #RealM
+ Real
+ (#SumT ## #CharM
+ Char
+ (#SumT ## #TextM
+ Text
+ (#SumT ## #IdentM
+ Ident
+ (#SumT ## #ListM
+ (#AppT List Ann-Value)
+ ## #DictM
+ (#AppT List (#ProdT Text Ann-Value)))))))))))
+ )
+ Void)
+ ))
+ (#Cons [["lux" "type?"] (+0 true)]
+ (#Cons [["lux" "export?"] (+0 true)]
+ (#Cons [["lux" "tags"] (+8 (#Cons (+6 "BoolM")
+ (#Cons (+6 "NatM")
+ (#Cons (+6 "IntM")
+ (#Cons (+6 "FracM")
+ (#Cons (+6 "RealM")
+ (#Cons (+6 "CharM")
+ (#Cons (+6 "TextM")
+ (#Cons (+6 "IdentM")
+ (#Cons (+6 "ListM")
+ (#Cons (+6 "DictM")
+ #Nil)))))))))))]
+ (#Cons [["lux" "type-rec?"] (+0 true)]
+ #Nil)))))
+
+## (type: Anns
+## (List [Ident Ann-Value]))
+(_lux_def Anns
+ (#NamedT ["lux" "Anns"]
+ (#AppT List (#ProdT Ident Ann-Value)))
+ (#Cons [["lux" "type?"] (#BoolM true)]
+ (#Cons [["lux" "export?"] (#BoolM true)]
+ #Nil)))
+
+(_lux_def default-def-meta-exported
+ (_lux_: Anns
+ (#Cons [["lux" "type?"] (#BoolM true)]
+ (#Cons [["lux" "export?"] (#BoolM true)]
+ #Nil)))
+ #Nil)
+
+(_lux_def default-def-meta-unexported
+ (_lux_: Anns
+ (#Cons [["lux" "type?"] (#BoolM true)]
+ #Nil))
+ #Nil)
+
+## (type: Def
+## [Type Anns Unit])
+(_lux_def Def
+ (#NamedT ["lux" "Def"]
+ (#ProdT Type (#ProdT Anns Unit)))
+ default-def-meta-exported)
+
+## (type: (Bindings k v)
+## {#counter Nat
+## #mappings (List [k v])})
+(_lux_def Bindings
+ (#NamedT ["lux" "Bindings"]
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#ProdT ## "lux;counter"
+ Nat
+ ## "lux;mappings"
+ (#AppT List
+ (#ProdT (#BoundT +3)
+ (#BoundT +1)))))))
+ (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "counter")
+ (#Cons (#TextM "mappings")
+ #Nil)))]
+ (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "k") (#Cons (#TextM "v") #;Nil)))]
+ default-def-meta-exported)))
+
+## (type: Cursor
+## {#module Text
+## #line Int
+## #column Int})
+(_lux_def Cursor
+ (#NamedT ["lux" "Cursor"]
+ (#ProdT Text (#ProdT Int Int)))
+ (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "module")
+ (#Cons (#TextM "line")
+ (#Cons (#TextM "column")
+ #Nil))))]
+ (#Cons [["lux" "doc"] (#TextM "Cursors are for specifying the location of AST nodes in Lux files during compilation.")]
+ default-def-meta-exported)))
+
+## (type: (Meta m v)
+## {#meta m
+## #datum v})
+(_lux_def Meta
+ (#NamedT ["lux" "Meta"]
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#ProdT (#BoundT +3)
+ (#BoundT +1)))))
+ (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "meta")
+ (#Cons (#TextM "datum")
+ #Nil)))]
+ (#Cons [["lux" "doc"] (#TextM "The type of things that can have meta-data of arbitrary types.")]
+ (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "m") (#Cons (#TextM "v") #;Nil)))]
+ default-def-meta-exported))))
+
+(_lux_def Analysis
+ (#NamedT ["lux" "Analysis"]
+ (#AppT (#AppT Meta
+ (#ProdT Type Cursor))
+ Void))
+ default-def-meta-exported)
+
+## (type: Scope
+## {#name (List Text)
+## #inner-closures Int
+## #locals (Bindings Text Analysis)
+## #closure (Bindings Text Analysis)})
+(_lux_def Scope
+ (#NamedT ["lux" "Scope"]
+ (#ProdT ## "lux;name"
+ (#AppT List Text)
+ (#ProdT ## "lux;inner-closures"
+ Int
+ (#ProdT ## "lux;locals"
+ (#AppT (#AppT Bindings Text) Analysis)
+ ## "lux;closure"
+ (#AppT (#AppT Bindings Text) Analysis)))))
+ (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "name")
+ (#Cons (#TextM "inner-closures")
+ (#Cons (#TextM "locals")
+ (#Cons (#TextM "closure")
+ #Nil)))))]
+ default-def-meta-exported))
+
+## (type: (AST' w)
+## (#BoolS Bool)
+## (#NatS Nat)
+## (#IntS Int)
+## (#FracS Frac)
+## (#RealS Real)
+## (#CharS Char)
+## (#TextS Text)
+## (#SymbolS Text Text)
+## (#TagS Text Text)
+## (#FormS (List (w (AST' w))))
+## (#TupleS (List (w (AST' w))))
+## (#RecordS (List [(w (AST' w)) (w (AST' w))])))
+(_lux_def AST'
+ (#NamedT ["lux" "AST'"]
+ (_lux_case (#AppT (#BoundT +1)
+ (#AppT (#BoundT +0)
+ (#BoundT +1)))
+ AST
+ (_lux_case (#AppT [List AST])
+ ASTList
+ (#UnivQ #Nil
+ (#SumT ## "lux;BoolS"
+ Bool
+ (#SumT ## "lux;NatS"
+ Nat
+ (#SumT ## "lux;IntS"
+ Int
+ (#SumT ## "lux;FracS"
+ Frac
+ (#SumT ## "lux;RealS"
+ Real
+ (#SumT ## "lux;CharS"
+ Char
+ (#SumT ## "lux;TextS"
+ Text
+ (#SumT ## "lux;SymbolS"
+ Ident
+ (#SumT ## "lux;TagS"
+ Ident
+ (#SumT ## "lux;FormS"
+ ASTList
+ (#SumT ## "lux;TupleS"
+ ASTList
+ ## "lux;RecordS"
+ (#AppT List (#ProdT AST AST))
+ )))))))))))
+ ))))
+ (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "BoolS")
+ (#Cons (#TextM "NatS")
+ (#Cons (#TextM "IntS")
+ (#Cons (#TextM "FracS")
+ (#Cons (#TextM "RealS")
+ (#Cons (#TextM "CharS")
+ (#Cons (#TextM "TextS")
+ (#Cons (#TextM "SymbolS")
+ (#Cons (#TextM "TagS")
+ (#Cons (#TextM "FormS")
+ (#Cons (#TextM "TupleS")
+ (#Cons (#TextM "RecordS")
+ #Nil)))))))))))))]
+ (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "w") #;Nil))]
+ default-def-meta-exported)))
+
+## (type: AST
+## (Meta Cursor (AST' (Meta Cursor))))
+(_lux_def AST
+ (#NamedT ["lux" "AST"]
+ (_lux_case (#AppT Meta Cursor)
+ w
+ (#AppT w (#AppT AST' w))))
+ (#Cons [["lux" "doc"] (#TextM "The type of AST nodes for Lux syntax.")]
+ default-def-meta-exported))
+
+(_lux_def ASTList
+ (#AppT List AST)
+ default-def-meta-unexported)
+
+## (type: (Either l r)
+## (#Left l)
+## (#Right r))
+(_lux_def Either
+ (#NamedT ["lux" "Either"]
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#SumT ## "lux;Left"
+ (#BoundT +3)
+ ## "lux;Right"
+ (#BoundT +1)))))
+ (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "Left")
+ (#Cons (#TextM "Right")
+ #Nil)))]
+ (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "l") (#Cons (#TextM "r") #;Nil)))]
+ default-def-meta-exported)))
+
+## (type: Source
+## (List (Meta Cursor Text)))
+(_lux_def Source
+ (#NamedT ["lux" "Source"]
+ (#AppT [List
+ (#AppT [(#AppT [Meta Cursor])
+ Text])]))
+ default-def-meta-exported)
+
+## (type: Module
+## {#module-hash Int
+## #module-aliases (List [Text Text])
+## #defs (List [Text Def])
+## #imports (List Text)
+## #tags (List [Text [Nat (List Ident) Bool Type]])
+## #types (List [Text [(List Ident) Bool Type]])}
+## #module-anns Anns
+## )
+(_lux_def Module
+ (#NamedT ["lux" "Module"]
+ (#ProdT ## "lux;module-hash"
+ Int
+ (#ProdT ## "lux;module-aliases"
+ (#AppT List (#ProdT Text Text))
+ (#ProdT ## "lux;defs"
+ (#AppT List (#ProdT Text
+ Def))
+ (#ProdT ## "lux;imports"
+ (#AppT List Text)
+ (#ProdT ## "lux;tags"
+ (#AppT List
+ (#ProdT Text
+ (#ProdT Nat
+ (#ProdT (#AppT List Ident)
+ (#ProdT Bool
+ Type)))))
+ (#ProdT ## "lux;types"
+ (#AppT List
+ (#ProdT Text
+ (#ProdT (#AppT List Ident)
+ (#ProdT Bool
+ Type))))
+ ## "lux;module-anns"
+ Anns)
+ ))))))
+ (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "module-hash")
+ (#Cons (#TextM "module-aliases")
+ (#Cons (#TextM "defs")
+ (#Cons (#TextM "imports")
+ (#Cons (#TextM "tags")
+ (#Cons (#TextM "types")
+ (#Cons (#TextM "module-anns")
+ #Nil))))))))]
+ default-def-meta-exported))
+
+## (type: CompilerMode
+## #Release
+## #Debug
+## #Eval
+## #REPL)
+(_lux_def CompilerMode
+ (#NamedT ["lux" "CompilerMode"]
+ (#SumT ## "lux;Release"
+ #UnitT
+ (#SumT ## "lux;Debug"
+ #UnitT
+ (#SumT ## "lux;Eval"
+ #UnitT
+ ## "lux;REPL"
+ #UnitT))))
+ (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "Release")
+ (#Cons (#TextM "Debug")
+ (#Cons (#TextM "Eval")
+ (#Cons (#TextM "REPL")
+ #Nil)))))]
+ default-def-meta-exported))
+
+## (type: CompilerInfo
+## {#compiler-name Text
+## #compiler-version Text
+## #compiler-mode CompilerMode})
+(_lux_def CompilerInfo
+ (#NamedT ["lux" "CompilerInfo"]
+ (#ProdT ## "lux;compiler-name"
+ Text
+ (#ProdT ## "lux;compiler-version"
+ Text
+ ## "lux;compiler-mode"
+ CompilerMode)))
+ (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "compiler-name")
+ (#Cons (#TextM "compiler-version")
+ (#Cons (#TextM "compiler-mode")
+ #Nil))))]
+ default-def-meta-exported))
+
+## (type: Compiler
+## {#info CompilerInfo
+## #source Source
+## #cursor Cursor
+## #modules (List [Text Module])
+## #scopes (List Scope)
+## #type-vars (Bindings Nat (Maybe Type))
+## #expected (Maybe Type)
+## #seed Nat
+## #scope-type-vars (List Nat)
+## #host Void})
+(_lux_def Compiler
+ (#NamedT ["lux" "Compiler"]
+ (#ProdT ## "lux;info"
+ CompilerInfo
+ (#ProdT ## "lux;source"
+ Source
+ (#ProdT ## "lux;cursor"
+ Cursor
+ (#ProdT ## "lux;modules"
+ (#AppT List (#ProdT Text
+ Module))
+ (#ProdT ## "lux;scopes"
+ (#AppT List Scope)
+ (#ProdT ## "lux;type-vars"
+ (#AppT (#AppT Bindings Nat) (#AppT Maybe Type))
+ (#ProdT ## "lux;expected"
+ (#AppT Maybe Type)
+ (#ProdT ## "lux;seed"
+ Nat
+ (#ProdT ## "lux;scope-type-vars"
+ (#AppT List Nat)
+ ## "lux;host"
+ Void))))))))))
+ (#Cons [["lux" "tags"] (#ListM (#Cons (#TextM "info")
+ (#Cons (#TextM "source")
+ (#Cons (#TextM "cursor")
+ (#Cons (#TextM "modules")
+ (#Cons (#TextM "scopes")
+ (#Cons (#TextM "type-vars")
+ (#Cons (#TextM "expected")
+ (#Cons (#TextM "seed")
+ (#Cons (#TextM "scope-type-vars")
+ (#Cons (#TextM "host")
+ #Nil)))))))))))]
+ (#Cons [["lux" "doc"] (#TextM "Represents the state of the Lux compiler during a run.
+ It's provided to macros during their invocation, so they can access compiler data.
+
+ Caveat emptor: Avoid fiddling with it, unless you know what you're doing.")]
+ default-def-meta-exported)))
+
+## (type: (Lux a)
+## (-> Compiler (Either Text [Compiler a])))
+(_lux_def Lux
+ (#NamedT ["lux" "Lux"]
+ (#UnivQ #Nil
+ (#LambdaT Compiler
+ (#AppT (#AppT Either Text)
+ (#ProdT Compiler (#BoundT +1))))))
+ (#Cons [["lux" "doc"] (#TextM "Computations that can have access to the state of the compiler.
+ Those computations may also fail, or modify the state of the compiler.")]
+ (#Cons [["lux" "type-args"] (#ListM (#Cons (#TextM "a") #;Nil))]
+ default-def-meta-exported)))
+
+## (type: Macro
+## (-> (List AST) (Lux (List AST))))
+(_lux_def Macro
+ (#NamedT ["lux" "Macro"]
+ (#LambdaT ASTList (#AppT Lux ASTList)))
+ default-def-meta-exported)
+
+## Base functions & macros
+## (def: _cursor
+## Cursor
+## ["" -1 -1])
+(_lux_def _cursor
+ (_lux_: Cursor ["" -1 -1])
+ #Nil)
+
+## (def: (_meta data)
+## (-> (AST' (Meta Cursor)) AST)
+## [["" -1 -1] data])
+(_lux_def _meta
+ (_lux_: (#LambdaT (#AppT AST'
+ (#AppT Meta Cursor))
+ AST)
+ (_lux_lambda _ data
+ [_cursor data]))
+ #Nil)
+
+## (def: (return x)
+## (All [a]
+## (-> a Compiler
+## (Either Text [Compiler a])))
+## ...)
+(_lux_def return
+ (_lux_: (#UnivQ #Nil
+ (#LambdaT (#BoundT +1)
+ (#LambdaT Compiler
+ (#AppT (#AppT Either Text)
+ (#ProdT Compiler
+ (#BoundT +1))))))
+ (_lux_lambda _ val
+ (_lux_lambda _ state
+ (#Right state val))))
+ #Nil)
+
+## (def: (fail msg)
+## (All [a]
+## (-> Text Compiler
+## (Either Text [Compiler a])))
+## ...)
+(_lux_def fail
+ (_lux_: (#UnivQ #Nil
+ (#LambdaT Text
+ (#LambdaT Compiler
+ (#AppT (#AppT Either Text)
+ (#ProdT Compiler
+ (#BoundT +1))))))
+ (_lux_lambda _ msg
+ (_lux_lambda _ state
+ (#Left msg))))
+ #Nil)
+
+(_lux_def bool$
+ (_lux_: (#LambdaT Bool AST)
+ (_lux_lambda _ value (_meta (#BoolS value))))
+ #Nil)
+
+(_lux_def nat$
+ (_lux_: (#LambdaT Nat AST)
+ (_lux_lambda _ value (_meta (#NatS value))))
+ #Nil)
+
+(_lux_def int$
+ (_lux_: (#LambdaT Int AST)
+ (_lux_lambda _ value (_meta (#IntS value))))
+ #Nil)
+
+(_lux_def frac$
+ (_lux_: (#LambdaT Frac AST)
+ (_lux_lambda _ value (_meta (#FracS value))))
+ #Nil)
+
+(_lux_def real$
+ (_lux_: (#LambdaT Real AST)
+ (_lux_lambda _ value (_meta (#RealS value))))
+ #Nil)
+
+(_lux_def char$
+ (_lux_: (#LambdaT Char AST)
+ (_lux_lambda _ value (_meta (#CharS value))))
+ #Nil)
+
+(_lux_def text$
+ (_lux_: (#LambdaT Text AST)
+ (_lux_lambda _ text (_meta (#TextS text))))
+ #Nil)
+
+(_lux_def symbol$
+ (_lux_: (#LambdaT Ident AST)
+ (_lux_lambda _ ident (_meta (#SymbolS ident))))
+ #Nil)
+
+(_lux_def tag$
+ (_lux_: (#LambdaT Ident AST)
+ (_lux_lambda _ ident (_meta (#TagS ident))))
+ #Nil)
+
+(_lux_def form$
+ (_lux_: (#LambdaT (#AppT List AST) AST)
+ (_lux_lambda _ tokens (_meta (#FormS tokens))))
+ #Nil)
+
+(_lux_def tuple$
+ (_lux_: (#LambdaT (#AppT List AST) AST)
+ (_lux_lambda _ tokens (_meta (#TupleS tokens))))
+ #Nil)
+
+(_lux_def record$
+ (_lux_: (#LambdaT (#AppT List (#ProdT AST AST)) AST)
+ (_lux_lambda _ tokens (_meta (#RecordS tokens))))
+ #Nil)
+
+(_lux_def default-macro-meta
+ (_lux_: Anns
+ (#Cons [["lux" "macro?"] (#BoolM true)]
+ #Nil))
+ #Nil)
+
+(_lux_def let''
+ (_lux_: Macro
+ (_lux_lambda _ tokens
+ (_lux_case tokens
+ (#Cons lhs (#Cons rhs (#Cons body #Nil)))
+ (return (#Cons (form$ (#Cons (symbol$ ["" "_lux_case"])
+ (#Cons rhs (#Cons lhs (#Cons body #Nil)))))
+ #Nil))
+
+ _
+ (fail "Wrong syntax for let''"))))
+ default-macro-meta)
+
+(_lux_def lambda''
+ (_lux_: Macro
+ (_lux_lambda _ tokens
+ (_lux_case tokens
+ (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil))
+ (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda"))
+ (#Cons (_meta (#SymbolS "" ""))
+ (#Cons arg
+ (#Cons (_lux_case args'
+ #Nil
+ body
+
+ _
+ (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''"))
+ (#Cons (_meta (#TupleS args'))
+ (#Cons body #Nil))))))
+ #Nil))))))
+ #Nil))
+
+ (#Cons [_ (#SymbolS "" self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)))
+ (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda"))
+ (#Cons (_meta (#SymbolS "" self))
+ (#Cons arg
+ (#Cons (_lux_case args'
+ #Nil
+ body
+
+ _
+ (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''"))
+ (#Cons (_meta (#TupleS args'))
+ (#Cons body #Nil))))))
+ #Nil))))))
+ #Nil))
+
+ _
+ (fail "Wrong syntax for lambda''"))))
+ default-macro-meta)
+
+(_lux_def export?-meta
+ (_lux_: AST
+ (tuple$ (#Cons [(tuple$ (#Cons [(text$ "lux") (#Cons [(text$ "export?") #Nil])]))
+ (#Cons [(form$ (#Cons [(tag$ ["lux" "BoolM"])
+ (#Cons [(bool$ true)
+ #Nil])]))
+ #Nil])])))
+ #Nil)
+
+(_lux_def hidden?-meta
+ (_lux_: AST
+ (tuple$ (#Cons [(tuple$ (#Cons [(text$ "lux") (#Cons [(text$ "hidden?") #Nil])]))
+ (#Cons [(form$ (#Cons [(tag$ ["lux" "BoolM"])
+ (#Cons [(bool$ true)
+ #Nil])]))
+ #Nil])])))
+ #Nil)
+
+(_lux_def macro?-meta
+ (_lux_: AST
+ (tuple$ (#Cons [(tuple$ (#Cons [(text$ "lux") (#Cons [(text$ "macro?") #Nil])]))
+ (#Cons [(form$ (#Cons [(tag$ ["lux" "BoolM"])
+ (#Cons [(bool$ true)
+ #Nil])]))
+ #Nil])])))
+ #Nil)
+
+(_lux_def with-export-meta
+ (_lux_: (#LambdaT AST AST)
+ (lambda'' [tail]
+ (form$ (#Cons (tag$ ["lux" "Cons"])
+ (#Cons export?-meta
+ (#Cons tail #Nil))))))
+ #Nil)
+
+(_lux_def with-hidden-meta
+ (_lux_: (#LambdaT AST AST)
+ (lambda'' [tail]
+ (form$ (#Cons (tag$ ["lux" "Cons"])
+ (#Cons hidden?-meta
+ (#Cons tail #Nil))))))
+ #Nil)
+
+(_lux_def with-macro-meta
+ (_lux_: (#LambdaT AST AST)
+ (lambda'' [tail]
+ (form$ (#Cons (tag$ ["lux" "Cons"])
+ (#Cons macro?-meta
+ (#Cons tail #Nil))))))
+ #Nil)
+
+(_lux_def def:''
+ (_lux_: Macro
+ (lambda'' [tokens]
+ (_lux_case tokens
+ (#Cons [[_ (#TagS ["" "export"])]
+ (#Cons [[_ (#FormS (#Cons [name args]))]
+ (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
+ (#Cons [name
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
+ (#Cons [type
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"]))
+ (#Cons [name
+ (#Cons [(_meta (#TupleS args))
+ (#Cons [body #Nil])])])])))
+ #Nil])])])))
+ (#Cons (with-export-meta meta) #Nil)])])])))
+ #Nil]))
+
+ (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
+ (#Cons [name
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
+ (#Cons [type
+ (#Cons [body
+ #Nil])])])))
+ (#Cons (with-export-meta meta) #Nil)])])])))
+ #Nil]))
+
+ (#Cons [[_ (#FormS (#Cons [name args]))]
+ (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
+ (#Cons [name
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
+ (#Cons [type
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"]))
+ (#Cons [name
+ (#Cons [(_meta (#TupleS args))
+ (#Cons [body #Nil])])])])))
+ #Nil])])])))
+ (#Cons meta #Nil)])])])))
+ #Nil]))
+
+ (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])
+ (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"]))
+ (#Cons [name
+ (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"]))
+ (#Cons [type
+ (#Cons [body
+ #Nil])])])))
+ (#Cons meta #Nil)])])])))
+ #Nil]))
+
+ _
+ (fail "Wrong syntax for def''"))
+ ))
+ default-macro-meta)
+
+(def:'' (macro:' tokens)
+ default-macro-meta
+ Macro
+ (_lux_case tokens
+ (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil))
+ (return (#Cons (form$ (#Cons (symbol$ ["lux" "def:''"])
+ (#Cons (form$ (#Cons name args))
+ (#Cons (with-macro-meta (tag$ ["lux" "Nil"]))
+ (#Cons (symbol$ ["lux" "Macro"])
+ (#Cons body
+ #Nil)))
+ )))
+ #Nil))
+
+ (#Cons [_ (#TagS ["" "export"])] (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil)))
+ (return (#Cons (form$ (#Cons (symbol$ ["lux" "def:''"])
+ (#Cons (tag$ ["" "export"])
+ (#Cons (form$ (#Cons name args))
+ (#Cons (with-macro-meta (tag$ ["lux" "Nil"]))
+ (#Cons (symbol$ ["lux" "Macro"])
+ (#Cons body
+ #Nil)))
+ ))))
+ #Nil))
+
+ (#Cons [_ (#TagS ["" "export"])] (#Cons [_ (#FormS (#Cons name args))] (#Cons meta-data (#Cons body #Nil))))
+ (return (#Cons (form$ (#Cons (symbol$ ["lux" "def:''"])
+ (#Cons (tag$ ["" "export"])
+ (#Cons (form$ (#Cons name args))
+ (#Cons (with-macro-meta meta-data)
+ (#Cons (symbol$ ["lux" "Macro"])
+ (#Cons body
+ #Nil)))
+ ))))
+ #Nil))
+
+ _
+ (fail "Wrong syntax for macro:'")))
+
+(macro:' #export (comment tokens)
+ (#Cons [["lux" "doc"] (#TextM "## Throws away any code given to it.
+ ## Great for commenting out code, while retaining syntax high-lightning and formatting in your text editor.
+ (comment 1 2 3 4)")]
+ #;Nil)
+ (return #Nil))
+
+(macro:' ($' tokens)
+ (_lux_case tokens
+ (#Cons x #Nil)
+ (return tokens)
+
+ (#Cons x (#Cons y xs))
+ (return (#Cons (form$ (#Cons (symbol$ ["lux" "$'"])
+ (#Cons (form$ (#Cons (tag$ ["lux" "AppT"])
+ (#Cons x (#Cons y #Nil))))
+ xs)))
+ #Nil))
+
+ _
+ (fail "Wrong syntax for $'")))
+
+(def:'' (map f xs)
+ #Nil
+ (#UnivQ #Nil
+ (#UnivQ #Nil
+ (#LambdaT (#LambdaT (#BoundT +3) (#BoundT +1))
+ (#LambdaT ($' List (#BoundT +3))
+ ($' List (#BoundT +1))))))
+ (_lux_case xs
+ #Nil
+ #Nil
+
+ (#Cons x xs')
+ (#Cons (f x) (map f xs'))))
+
+(def:'' RepEnv
+ #Nil
+ Type
+ ($' List (#ProdT Text AST)))
+
+(def:'' (make-env xs ys)
+ #Nil
+ (#LambdaT ($' List Text) (#LambdaT ($' List AST) RepEnv))
+ (_lux_case [xs ys]
+ [(#Cons x xs') (#Cons y ys')]
+ (#Cons [x y] (make-env xs' ys'))
+
+ _
+ #Nil))
+
+(def:'' (Text/= x y)
+ #Nil
+ (#LambdaT Text (#LambdaT Text Bool))
+ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:equals:java.lang.Object"] [x y]))
+
+(def:'' (get-rep key env)
+ #Nil
+ (#LambdaT Text (#LambdaT RepEnv ($' Maybe AST)))
+ (_lux_case env
+ #Nil
+ #None
+
+ (#Cons [k v] env')
+ (_lux_case (Text/= k key)
+ true
+ (#Some v)
+
+ false
+ (get-rep key env'))))
+
+(def:'' (replace-syntax reps syntax)
+ #Nil
+ (#LambdaT RepEnv (#LambdaT AST AST))
+ (_lux_case syntax
+ [_ (#SymbolS "" name)]
+ (_lux_case (get-rep name reps)
+ (#Some replacement)
+ replacement
+
+ #None
+ syntax)
+
+ [meta (#FormS parts)]
+ [meta (#FormS (map (replace-syntax reps) parts))]
+
+ [meta (#TupleS members)]
+ [meta (#TupleS (map (replace-syntax reps) members))]
+
+ [meta (#RecordS slots)]
+ [meta (#RecordS (map (_lux_: (#LambdaT (#ProdT AST AST) (#ProdT AST AST))
+ (lambda'' [slot]
+ (_lux_case slot
+ [k v]
+ [(replace-syntax reps k) (replace-syntax reps v)])))
+ slots))]
+
+ _
+ syntax)
+ )
+
+(def:'' (update-bounds ast)
+ #Nil
+ (#LambdaT AST AST)
+ (_lux_case ast
+ [_ (#TupleS members)]
+ (tuple$ (map update-bounds members))
+
+ [_ (#RecordS pairs)]
+ (record$ (map (_lux_: (#LambdaT (#ProdT AST AST) (#ProdT AST AST))
+ (lambda'' [pair]
+ (let'' [name val] pair
+ [name (update-bounds val)])))
+ pairs))
+
+ [_ (#FormS (#Cons [_ (#TagS "lux" "BoundT")] (#Cons [_ (#NatS idx)] #Nil)))]
+ (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (nat$ (_lux_proc ["nat" "+"] [+2 idx])) #Nil)))
+
+ [_ (#FormS members)]
+ (form$ (map update-bounds members))
+
+ _
+ ast))
+
+(def:'' (parse-quantified-args args next)
+ #Nil
+ ## (-> (List AST) (-> (List Text) (Lux (List AST))) (Lux (List AST)))
+ (#LambdaT ($' List AST)
+ (#LambdaT (#LambdaT ($' List Text) (#AppT Lux ($' List AST)))
+ (#AppT Lux ($' List AST))
+ ))
+ (_lux_case args
+ #Nil
+ (next #Nil)
+
+ (#Cons [_ (#SymbolS "" arg-name)] args')
+ (parse-quantified-args args' (lambda'' [names] (next (#Cons arg-name names))))
+
+ _
+ (fail "Expected symbol.")
+ ))
+
+(def:'' (make-bound idx)
+ #Nil
+ (#LambdaT Nat AST)
+ (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (nat$ idx) #Nil))))
+
+(def:'' (fold f init xs)
+ #Nil
+ ## (All [a b] (-> (-> b a a) a (List b) a))
+ (#UnivQ #Nil (#UnivQ #Nil (#LambdaT (#LambdaT (#BoundT +1)
+ (#LambdaT (#BoundT +3)
+ (#BoundT +3)))
+ (#LambdaT (#BoundT +3)
+ (#LambdaT ($' List (#BoundT +1))
+ (#BoundT +3))))))
+ (_lux_case xs
+ #Nil
+ init
+
+ (#Cons x xs')
+ (fold f (f x init) xs')))
+
+(def:'' (length list)
+ #Nil
+ (#UnivQ #Nil
+ (#LambdaT ($' List (#BoundT +1)) Int))
+ (fold (lambda'' [_ acc] (_lux_proc ["jvm" "ladd"] [1 acc])) 0 list))
+
+(macro:' #export (All tokens)
+ (#Cons [["lux" "doc"] (#TextM "## Universal quantification.
+ (All [a]
+ (-> a a))
+
+ ## A name can be provided, to specify a recursive type.
+ (All List [a]
+ (| Unit
+ [a (List a)]))")]
+ #;Nil)
+ (let'' [self-name tokens] (_lux_case tokens
+ (#Cons [_ (#SymbolS "" self-name)] tokens)
+ [self-name tokens]
+
+ _
+ ["" tokens])
+ (_lux_case tokens
+ (#Cons [_ (#TupleS args)] (#Cons body #Nil))
+ (parse-quantified-args args
+ (lambda'' [names]
+ (let'' body' (fold (_lux_: (#LambdaT Text (#LambdaT AST AST))
+ (lambda'' [name' body']
+ (form$ (#Cons (tag$ ["lux" "UnivQ"])
+ (#Cons (tag$ ["lux" "Nil"])
+ (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil)
+ (update-bounds body')) #Nil))))))
+ body
+ names)
+ (return (#Cons (_lux_case [(Text/= "" self-name) names]
+ [true _]
+ body'
+
+ [_ #;Nil]
+ body'
+
+ [false _]
+ (replace-syntax (#Cons [self-name (make-bound (_lux_proc ["nat" "*"]
+ [+2 (_lux_proc ["nat" "-"]
+ [(_lux_proc ["int" "to-nat"]
+ [(length names)])
+ +1])]))]
+ #Nil)
+ body'))
+ #Nil)))))
+
+ _
+ (fail "Wrong syntax for All"))
+ ))
+
+(macro:' #export (Ex tokens)
+ (#Cons [["lux" "doc"] (#TextM "## Existential quantification.
+ (Ex [a]
+ [(Codec Text a)
+ a])
+
+ ## A name can be provided, to specify a recursive type.
+ (Ex Self [a]
+ [(Codec Text a)
+ a
+ (List (Self a))])")]
+ #;Nil)
+ (let'' [self-name tokens] (_lux_case tokens
+ (#Cons [_ (#SymbolS "" self-name)] tokens)
+ [self-name tokens]
+
+ _
+ ["" tokens])
+ (_lux_case tokens
+ (#Cons [_ (#TupleS args)] (#Cons body #Nil))
+ (parse-quantified-args args
+ (lambda'' [names]
+ (let'' body' (fold (_lux_: (#LambdaT Text (#LambdaT AST AST))
+ (lambda'' [name' body']
+ (form$ (#Cons (tag$ ["lux" "ExQ"])
+ (#Cons (tag$ ["lux" "Nil"])
+ (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil)
+ (update-bounds body')) #Nil))))))
+ body
+ names)
+ (return (#Cons (_lux_case [(Text/= "" self-name) names]
+ [true _]
+ body'
+
+ [_ #;Nil]
+ body'
+
+ [false _]
+ (replace-syntax (#Cons [self-name (make-bound (_lux_proc ["nat" "*"]
+ [+2 (_lux_proc ["nat" "-"]
+ [(_lux_proc ["int" "to-nat"]
+ [(length names)])
+ +1])]))]
+ #Nil)
+ body'))
+ #Nil)))))
+
+ _
+ (fail "Wrong syntax for Ex"))
+ ))
+
+(def:'' (reverse list)
+ #Nil
+ (All [a] (#LambdaT ($' List a) ($' List a)))
+ (fold (lambda'' [head tail] (#Cons head tail))
+ #Nil
+ list))
+
+(macro:' #export (-> tokens)
+ (#Cons [["lux" "doc"] (#TextM "## Function types:
+ (-> Int Int Int)
+
+ ## This is the type of a function that takes 2 Ints and returns an Int.")]
+ #;Nil)
+ (_lux_case (reverse tokens)
+ (#Cons output inputs)
+ (return (#Cons (fold (_lux_: (#LambdaT AST (#LambdaT AST AST))
+ (lambda'' [i o] (form$ (#Cons (tag$ ["lux" "LambdaT"]) (#Cons i (#Cons o #Nil))))))
+ output
+ inputs)
+ #Nil))
+
+ _
+ (fail "Wrong syntax for ->")))
+
+(macro:' #export (list xs)
+ (#Cons [["lux" "doc"] (#TextM "## List-construction macro.
+ (list 1 2 3)")]
+ #;Nil)
+ (return (#Cons (fold (lambda'' [head tail]
+ (form$ (#Cons (tag$ ["lux" "Cons"])
+ (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])]))
+ #Nil))))
+ (tag$ ["lux" "Nil"])
+ (reverse xs))
+ #Nil)))
+
+(macro:' #export (list& xs)
+ (#Cons [["lux" "doc"] (#TextM "## List-construction macro, with the last element being a tail-list.
+ ## In other words, this macro prepends elements to another list.
+ (list& 1 2 3 (list 4 5 6))")]
+ #;Nil)
+ (_lux_case (reverse xs)
+ (#Cons last init)
+ (return (list (fold (lambda'' [head tail]
+ (form$ (list (tag$ ["lux" "Cons"])
+ (tuple$ (list head tail)))))
+ last
+ init)))
+
+ _
+ (fail "Wrong syntax for list&")))
+
+(macro:' #export (& tokens)
+ (#Cons [["lux" "doc"] (#TextM "## Tuple types:
+ (& Text Int Bool)
+
+ ## The empty tuple, a.k.a. Unit.
+ (&)")]
+ #;Nil)
+ (_lux_case (reverse tokens)
+ #Nil
+ (return (list (tag$ ["lux" "UnitT"])))
+
+ (#Cons last prevs)
+ (return (list (fold (lambda'' [left right] (form$ (list (tag$ ["lux" "ProdT"]) left right)))
+ last
+ prevs)))
+ ))
+
+(macro:' #export (| tokens)
+ (#Cons [["lux" "doc"] (#TextM "## Variant types:
+ (| Text Int Bool)
+
+ ## The empty tuple, a.k.a. Void.
+ (|)")]
+ #;Nil)
+ (_lux_case (reverse tokens)
+ #Nil
+ (return (list (tag$ ["lux" "VoidT"])))
+
+ (#Cons last prevs)
+ (return (list (fold (lambda'' [left right] (form$ (list (tag$ ["lux" "SumT"]) left right)))
+ last
+ prevs)))
+ ))
+
+(macro:' (lambda' tokens)
+ (let'' [name tokens'] (_lux_case tokens
+ (#Cons [[_ (#SymbolS ["" name])] tokens'])
+ [name tokens']
+
+ _
+ ["" tokens])
+ (_lux_case tokens'
+ (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])])
+ (_lux_case args
+ #Nil
+ (fail "lambda' requires a non-empty arguments tuple.")
+
+ (#Cons [harg targs])
+ (return (list (form$ (list (symbol$ ["" "_lux_lambda"])
+ (symbol$ ["" name])
+ harg
+ (fold (lambda'' [arg body']
+ (form$ (list (symbol$ ["" "_lux_lambda"])
+ (symbol$ ["" ""])
+ arg
+ body')))
+ body
+ (reverse targs)))))))
+
+ _
+ (fail "Wrong syntax for lambda'"))))
+
+(macro:' (def:''' tokens)
+ (_lux_case tokens
+ (#Cons [[_ (#TagS ["" "export"])]
+ (#Cons [[_ (#FormS (#Cons [name args]))]
+ (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])])
+ (return (list (form$ (list (symbol$ ["" "_lux_def"])
+ name
+ (form$ (list (symbol$ ["" "_lux_:"])
+ type
+ (form$ (list (symbol$ ["lux" "lambda'"])
+ name
+ (tuple$ args)
+ body))))
+ (with-export-meta meta)))))
+
+ (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])])
+ (return (list (form$ (list (symbol$ ["" "_lux_def"])
+ name
+ (form$ (list (symbol$ ["" "_lux_:"])
+ type
+ body))
+ (with-export-meta meta)))))
+
+ (#Cons [[_ (#FormS (#Cons [name args]))]
+ (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])
+ (return (list (form$ (list (symbol$ ["" "_lux_def"])
+ name
+ (form$ (list (symbol$ ["" "_lux_:"])
+ type
+ (form$ (list (symbol$ ["lux" "lambda'"])
+ name
+ (tuple$ args)
+ body))))
+ meta))))
+
+ (#Cons [name (#Cons [meta (#Cons [type (#Cons [body #Nil])])])])
+ (return (list (form$ (list (symbol$ ["" "_lux_def"])
+ name
+ (form$ (list (symbol$ ["" "_lux_:"]) type body))
+ meta))))
+
+ _
+ (fail "Wrong syntax for def'''")
+ ))
+
+(def:''' (as-pairs xs)
+ #Nil
+ (All [a] (-> ($' List a) ($' List (& a a))))
+ (_lux_case xs
+ (#Cons x (#Cons y xs'))
+ (#Cons [x y] (as-pairs xs'))
+
+ _
+ #Nil))
+
+(macro:' (let' tokens)
+ (_lux_case tokens
+ (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])])
+ (return (list (fold (_lux_: (-> (& AST AST) AST
+ AST)
+ (lambda' [binding body]
+ (_lux_case binding
+ [label value]
+ (form$ (list (symbol$ ["" "_lux_case"]) value label body)))))
+ body
+ (reverse (as-pairs bindings)))))
+
+ _
+ (fail "Wrong syntax for let'")))
+
+(def:''' (any? p xs)
+ #Nil
+ (All [a]
+ (-> (-> a Bool) ($' List a) Bool))
+ (_lux_case xs
+ #Nil
+ false
+
+ (#Cons x xs')
+ (_lux_case (p x)
+ true true
+ false (any? p xs'))))
+
+(def:''' (spliced? token)
+ #Nil
+ (-> AST Bool)
+ (_lux_case token
+ [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))]
+ true
+
+ _
+ false))
+
+(def:''' (wrap-meta content)
+ #Nil
+ (-> AST AST)
+ (tuple$ (list (tuple$ (list (text$ "") (int$ -1) (int$ -1)))
+ content)))
+
+(def:''' (untemplate-list tokens)
+ #Nil
+ (-> ($' List AST) AST)
+ (_lux_case tokens
+ #Nil
+ (_meta (#TagS ["lux" "Nil"]))
+
+ (#Cons [token tokens'])
+ (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) token (untemplate-list tokens'))))))
+
+(def:''' (List/append xs ys)
+ #Nil
+ (All [a] (-> ($' List a) ($' List a) ($' List a)))
+ (_lux_case xs
+ (#Cons x xs')
+ (#Cons x (List/append xs' ys))
+
+ #Nil
+ ys))
+
+(def:''' #export (splice-helper xs ys)
+ (#Cons [["lux" "hidden?"] (#BoolM true)]
+ #;Nil)
+ (-> ($' List AST) ($' List AST) ($' List AST))
+ (_lux_case xs
+ (#Cons x xs')
+ (#Cons x (splice-helper xs' ys))
+
+ #Nil
+ ys))
+
+(macro:' #export (_$ tokens)
+ (#Cons [["lux" "doc"] (#TextM "## Left-association for the application of binary functions over variadic arguments.
+ (_$ Text/append \"Hello, \" name \".\\nHow are you?\")
+
+ ## =>
+ (Text/append (Text/append \"Hello, \" name) \".\\nHow are you?\")")]
+ #;Nil)
+ (_lux_case tokens
+ (#Cons op tokens')
+ (_lux_case tokens'
+ (#Cons first nexts)
+ (return (list (fold (lambda' [a1 a2] (form$ (list op a1 a2)))
+ first
+ nexts)))
+
+ _
+ (fail "Wrong syntax for _$"))
+
+ _
+ (fail "Wrong syntax for _$")))
+
+(macro:' #export ($_ tokens)
+ (#Cons [["lux" "doc"] (#TextM "## Right-association for the application of binary functions over variadic arguments.
+ ($_ Text/append \"Hello, \" name \".\\nHow are you?\")
+
+ ## =>
+ (Text/append \"Hello, \" (Text/append name \".\\nHow are you?\"))")]
+ #;Nil)
+ (_lux_case tokens
+ (#Cons op tokens')
+ (_lux_case (reverse tokens')
+ (#Cons last prevs)
+ (return (list (fold (lambda' [a1 a2] (form$ (list op a1 a2)))
+ last
+ prevs)))
+
+ _
+ (fail "Wrong syntax for $_"))
+
+ _
+ (fail "Wrong syntax for $_")))
+
+## (sig: (Monad m)
+## (: (All [a] (-> a (m a)))
+## wrap)
+## (: (All [a b] (-> (-> a (m b)) (m a) (m b)))
+## bind))
+(def:''' Monad
+ (list& [["lux" "tags"] (#ListM (list (#TextM "wrap") (#TextM "bind")))]
+ default-def-meta-unexported)
+ Type
+ (#NamedT ["lux" "Monad"]
+ (All [m]
+ (& (All [a] (-> a ($' m a)))
+ (All [a b] (-> (-> a ($' m b))
+ ($' m a)
+ ($' m b)))))))
+
+(def:''' Monad<Maybe>
+ #Nil
+ ($' Monad Maybe)
+ {#wrap
+ (lambda' return [x]
+ (#Some x))
+
+ #bind
+ (lambda' [f ma]
+ (_lux_case ma
+ #None #None
+ (#Some a) (f a)))})
+
+(def:''' Monad<Lux>
+ #Nil
+ ($' Monad Lux)
+ {#wrap
+ (lambda' [x]
+ (lambda' [state]
+ (#Right state x)))
+
+ #bind
+ (lambda' [f ma]
+ (lambda' [state]
+ (_lux_case (ma state)
+ (#Left msg)
+ (#Left msg)
+
+ (#Right state' a)
+ (f a state'))))})
+
+(macro:' (do tokens)
+ (_lux_case tokens
+ (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil)))
+ (let' [g!wrap (symbol$ ["" "wrap"])
+ g!bind (symbol$ ["" " bind "])
+ body' (fold (_lux_: (-> (& AST AST) AST AST)
+ (lambda' [binding body']
+ (let' [[var value] binding]
+ (_lux_case var
+ [_ (#TagS "" "let")]
+ (form$ (list (symbol$ ["lux" "let'"]) value body'))
+
+ _
+ (form$ (list g!bind
+ (form$ (list (symbol$ ["" "_lux_lambda"]) (symbol$ ["" ""]) var body'))
+ value))))))
+ body
+ (reverse (as-pairs bindings)))]
+ (return (list (form$ (list (symbol$ ["" "_lux_case"])
+ monad
+ (record$ (list [(tag$ ["lux" "wrap"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind]))
+ body')))))
+
+ _
+ (fail "Wrong syntax for do")))
+
+(def:''' (mapM m f xs)
+ #Nil
+ ## (All [m a b]
+ ## (-> (Monad m) (-> a (m b)) (List a) (m (List b))))
+ (All [m a b]
+ (-> ($' Monad m)
+ (-> a ($' m b))
+ ($' List a)
+ ($' m ($' List b))))
+ (let' [{#;wrap wrap #;bind _} m]
+ (_lux_case xs
+ #Nil
+ (wrap #Nil)
+
+ (#Cons x xs')
+ (do m
+ [y (f x)
+ ys (mapM m f xs')]
+ (wrap (#Cons y ys)))
+ )))
+
+(macro:' #export (if tokens)
+ (list [["lux" "doc"] (#TextM "(if true
+ \"Oh, yeah!\"
+ \"Aw hell naw!\")")])
+ (_lux_case tokens
+ (#Cons test (#Cons then (#Cons else #Nil)))
+ (return (list (form$ (list (symbol$ ["" "_lux_case"]) test
+ (bool$ true) then
+ (bool$ false) else))))
+
+ _
+ (fail "Wrong syntax for if")))
+
+(def:''' (get k plist)
+ #Nil
+ (All [a]
+ (-> Text ($' List (& Text a)) ($' Maybe a)))
+ (_lux_case plist
+ (#Cons [[k' v] plist'])
+ (if (Text/= k k')
+ (#Some v)
+ (get k plist'))
+
+ #Nil
+ #None))
+
+(def:''' (put k v dict)
+ #Nil
+ (All [a]
+ (-> Text a ($' List (& Text a)) ($' List (& Text a))))
+ (_lux_case dict
+ #Nil
+ (list [k v])
+
+ (#Cons [[k' v'] dict'])
+ (if (Text/= k k')
+ (#Cons [[k' v] dict'])
+ (#Cons [[k' v'] (put k v dict')]))))
+
+(def:''' (Text/append x y)
+ #Nil
+ (-> Text Text Text)
+ (_lux_proc ["jvm" "invokevirtual:java.lang.String:concat:java.lang.String"] [x y]))
+
+(def:''' (Ident->Text ident)
+ #Nil
+ (-> Ident Text)
+ (let' [[module name] ident]
+ (_lux_case module
+ "" name
+ _ ($_ Text/append module ";" name))))
+
+(def:''' (get-meta tag def-meta)
+ #Nil
+ (-> Ident Anns ($' Maybe Ann-Value))
+ (let' [[prefix name] tag]
+ (_lux_case def-meta
+ (#Cons [[prefix' name'] value] def-meta')
+ (_lux_case [(Text/= prefix prefix')
+ (Text/= name name')]
+ [true true]
+ (#Some value)
+
+ _
+ (get-meta tag def-meta'))
+
+ #Nil
+ #None)))
+
+(def:''' (resolve-global-symbol ident state)
+ #Nil
+ (-> Ident ($' Lux Ident))
+ (let' [[module name] ident
+ {#info info #source source #modules modules
+ #scopes scopes #type-vars types #host host
+ #seed seed #expected expected #cursor cursor
+ #scope-type-vars scope-type-vars} state]
+ (_lux_case (get module modules)
+ (#Some {#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _})
+ (_lux_case (get name defs)
+ (#Some [def-type def-meta def-value])
+ (_lux_case (get-meta ["lux" "alias"] def-meta)
+ (#Some (#IdentM real-name))
+ (#Right [state real-name])
+
+ _
+ (#Right [state ident]))
+
+ #None
+ (#Left ($_ Text/append "Unknown definition: " (Ident->Text ident))))
+
+ #None
+ (#Left ($_ Text/append "Unknown module: " module " @ " (Ident->Text ident))))))
+
+(def:''' (splice replace? untemplate tag elems)
+ #Nil
+ (-> Bool (-> AST ($' Lux AST)) AST ($' List AST) ($' Lux AST))
+ (_lux_case replace?
+ true
+ (_lux_case (any? spliced? elems)
+ true
+ (do Monad<Lux>
+ [elems' (_lux_: ($' Lux ($' List AST))
+ (mapM Monad<Lux>
+ (_lux_: (-> AST ($' Lux AST))
+ (lambda' [elem]
+ (_lux_case elem
+ [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))]
+ (wrap spliced)
+
+ _
+ (do Monad<Lux>
+ [=elem (untemplate elem)]
+ (wrap (form$ (list (symbol$ ["" "_lux_:"])
+ (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "AST"])))))
+ (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list =elem (tag$ ["lux" "Nil"]))))))))))))
+ elems))]
+ (wrap (wrap-meta (form$ (list tag
+ (form$ (list& (symbol$ ["lux" "$_"])
+ (symbol$ ["lux" "splice-helper"])
+ elems')))))))
+
+ false
+ (do Monad<Lux>
+ [=elems (mapM Monad<Lux> untemplate elems)]
+ (wrap (wrap-meta (form$ (list tag (untemplate-list =elems)))))))
+ false
+ (do Monad<Lux>
+ [=elems (mapM Monad<Lux> untemplate elems)]
+ (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))))
+
+(def:''' (untemplate replace? subst token)
+ #Nil
+ (-> Bool Text AST ($' Lux AST))
+ (_lux_case [replace? token]
+ [_ [_ (#BoolS value)]]
+ (return (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (bool$ value)))))
+
+ [_ [_ (#NatS value)]]
+ (return (wrap-meta (form$ (list (tag$ ["lux" "NatS"]) (nat$ value)))))
+
+ [_ [_ (#IntS value)]]
+ (return (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (int$ value)))))
+
+ [_ [_ (#FracS value)]]
+ (return (wrap-meta (form$ (list (tag$ ["lux" "FracS"]) (frac$ value)))))
+
+ [_ [_ (#RealS value)]]
+ (return (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (real$ value)))))
+
+ [_ [_ (#CharS value)]]
+ (return (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (char$ value)))))
+
+ [_ [_ (#TextS value)]]
+ (return (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (text$ value)))))
+
+ [false [_ (#TagS [module name])]]
+ (return (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module) (text$ name)))))))
+
+ [true [_ (#TagS [module name])]]
+ (let' [module' (_lux_case module
+ ""
+ subst
+
+ _
+ module)]
+ (return (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))))
+
+ [true [_ (#SymbolS [module name])]]
+ (do Monad<Lux>
+ [real-name (_lux_case module
+ ""
+ (if (Text/= "" subst)
+ (wrap [module name])
+ (resolve-global-symbol [subst name]))
+
+ _
+ (wrap [module name]))
+ #let [[module name] real-name]]
+ (return (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module) (text$ name))))))))
+
+ [false [_ (#SymbolS [module name])]]
+ (return (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module) (text$ name)))))))
+
+ [_ [_ (#TupleS elems)]]
+ (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems)
+
+ [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]]
+ (return unquoted)
+
+ [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~'"])] (#Cons [keep-quoted #Nil])]))]]
+ (untemplate false subst keep-quoted)
+
+ [_ [meta (#FormS elems)]]
+ (do Monad<Lux>
+ [output (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)
+ #let [[_ form'] output]]
+ (return [meta form']))
+
+ [_ [_ (#RecordS fields)]]
+ (do Monad<Lux>
+ [=fields (mapM Monad<Lux>
+ (_lux_: (-> (& AST AST) ($' Lux AST))
+ (lambda' [kv]
+ (let' [[k v] kv]
+ (do Monad<Lux>
+ [=k (untemplate replace? subst k)
+ =v (untemplate replace? subst v)]
+ (wrap (tuple$ (list =k =v)))))))
+ fields)]
+ (wrap (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) (untemplate-list =fields))))))
+ ))
+
+(macro:' #export (host tokens)
+ (list [["lux" "doc"] (#TextM "## Macro to treat host-types as Lux-types.
+ (host java.lang.Object)
+
+ (host java.util.List [java.lang.Long])")])
+ (_lux_case tokens
+ (#Cons [_ (#SymbolS "" class-name)] #Nil)
+ (return (list (form$ (list (tag$ ["lux" "HostT"]) (text$ class-name) (tag$ ["lux" "Nil"])))))
+
+ (#Cons [_ (#SymbolS "" class-name)] (#Cons [_ (#TupleS params)] #Nil))
+ (return (list (form$ (list (tag$ ["lux" "HostT"]) (text$ class-name) (untemplate-list params)))))
+
+ _
+ (fail "Wrong syntax for host")))
+
+(def:'' (current-module-name state)
+ #Nil
+ ($' Lux Text)
+ (_lux_case state
+ {#info info #source source #modules modules
+ #scopes scopes #type-vars types #host host
+ #seed seed #expected expected #cursor cursor
+ #scope-type-vars scope-type-vars}
+ (_lux_case (reverse scopes)
+ (#Cons {#name (#;Cons module-name #Nil) #inner-closures _ #locals _ #closure _} _)
+ (#Right [state module-name])
+
+ _
+ (#Left "Can't get the module name without a module!")
+ )))
+
+(macro:' #export (` tokens)
+ (list [["lux" "doc"] (#TextM "## Hygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~@) must also be used as forms.
+ ## All unprefixed macros will receive their parent module's prefix if imported; otherwise will receive the prefix of the module on which the quasi-quote is being used.
+ (` (def: (~ name)
+ (lambda [(~@ args)]
+ (~ body))))")])
+ (_lux_case tokens
+ (#Cons template #Nil)
+ (do Monad<Lux>
+ [current-module current-module-name
+ =template (untemplate true current-module template)]
+ (wrap (list (form$ (list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template)))))
+
+ _
+ (fail "Wrong syntax for `")))
+
+(macro:' #export (`' tokens)
+ (list [["lux" "doc"] (#TextM "## Unhygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~@) must also be used as forms.
+ (`' (def: (~ name)
+ (lambda [(~@ args)]
+ (~ body))))")])
+ (_lux_case tokens
+ (#Cons template #Nil)
+ (do Monad<Lux>
+ [=template (untemplate true "" template)]
+ (wrap (list (form$ (list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template)))))
+
+ _
+ (fail "Wrong syntax for `")))
+
+(macro:' #export (' tokens)
+ (list [["lux" "doc"] (#TextM "## Quotation as a macro.
+ (' \"YOLO\")")])
+ (_lux_case tokens
+ (#Cons template #Nil)
+ (do Monad<Lux>
+ [=template (untemplate false "" template)]
+ (wrap (list (form$ (list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template)))))
+
+ _
+ (fail "Wrong syntax for '")))
+
+(macro:' #export (|> tokens)
+ (list [["lux" "doc"] (#TextM "## Piping macro.
+ (|> elems (map ->Text) (interpose \" \") (fold Text/append \"\"))
+
+ ## =>
+ (fold Text/append \"\"
+ (interpose \" \"
+ (map ->Text elems)))")])
+ (_lux_case tokens
+ (#Cons [init apps])
+ (return (list (fold (_lux_: (-> AST AST AST)
+ (lambda' [app acc]
+ (_lux_case app
+ [_ (#TupleS parts)]
+ (tuple$ (List/append parts (list acc)))
+
+ [_ (#FormS parts)]
+ (form$ (List/append parts (list acc)))
+
+ _
+ (` ((~ app) (~ acc))))))
+ init
+ apps)))
+
+ _
+ (fail "Wrong syntax for |>")))
+
+(macro:' #export (<| tokens)
+ (list [["lux" "doc"] (#TextM "## Reverse piping macro.
+ (<| (fold Text/append \"\") (interpose \" \") (map ->Text) elems)
+
+ ## =>
+ (fold Text/append \"\"
+ (interpose \" \"
+ (map ->Text elems)))")])
+ (_lux_case (reverse tokens)
+ (#Cons [init apps])
+ (return (list (fold (_lux_: (-> AST AST AST)
+ (lambda' [app acc]
+ (_lux_case app
+ [_ (#TupleS parts)]
+ (tuple$ (List/append parts (list acc)))
+
+ [_ (#FormS parts)]
+ (form$ (List/append parts (list acc)))
+
+ _
+ (` ((~ app) (~ acc))))))
+ init
+ apps)))
+
+ _
+ (fail "Wrong syntax for <|")))
+
+(def:''' #export (. f g)
+ (list [["lux" "doc"] (#TextM "Function composition.")])
+ (All [a b c]
+ (-> (-> b c) (-> a b) (-> a c)))
+ (lambda' [x] (f (g x))))
+
+(def:''' (get-ident x)
+ #Nil
+ (-> AST ($' Maybe Ident))
+ (_lux_case x
+ [_ (#SymbolS sname)]
+ (#Some sname)
+
+ _
+ #None))
+
+(def:''' (get-tag x)
+ #Nil
+ (-> AST ($' Maybe Ident))
+ (_lux_case x
+ [_ (#TagS sname)]
+ (#Some sname)
+
+ _
+ #None))
+
+(def:''' (get-name x)
+ #Nil
+ (-> AST ($' Maybe Text))
+ (_lux_case x
+ [_ (#SymbolS "" sname)]
+ (#Some sname)
+
+ _
+ #None))
+
+(def:''' (tuple->list tuple)
+ #Nil
+ (-> AST ($' Maybe ($' List AST)))
+ (_lux_case tuple
+ [_ (#TupleS members)]
+ (#Some members)
+
+ _
+ #None))
+
+(def:''' (apply-template env template)
+ #Nil
+ (-> RepEnv AST AST)
+ (_lux_case template
+ [_ (#SymbolS "" sname)]
+ (_lux_case (get-rep sname env)
+ (#Some subst)
+ subst
+
+ _
+ template)
+
+ [meta (#TupleS elems)]
+ [meta (#TupleS (map (apply-template env) elems))]
+
+ [meta (#FormS elems)]
+ [meta (#FormS (map (apply-template env) elems))]
+
+ [meta (#RecordS members)]
+ [meta (#RecordS (map (_lux_: (-> (& AST AST) (& AST AST))
+ (lambda' [kv]
+ (let' [[slot value] kv]
+ [(apply-template env slot) (apply-template env value)])))
+ members))]
+
+ _
+ template))
+
+(def:''' (join-map f xs)
+ #Nil
+ (All [a b]
+ (-> (-> a ($' List b)) ($' List a) ($' List b)))
+ (_lux_case xs
+ #Nil
+ #Nil
+
+ (#Cons [x xs'])
+ (List/append (f x) (join-map f xs'))))
+
+(def:''' (every? p xs)
+ #Nil
+ (All [a]
+ (-> (-> a Bool) ($' List a) Bool))
+ (fold (lambda' [_2 _1] (if _1 (p _2) false)) true xs))
+
+(def:''' (i= x y)
+ #Nil
+ (-> Int Int Bool)
+ (_lux_proc ["jvm" "leq"] [x y]))
+
+(def:''' (n= x y)
+ #Nil
+ (-> Nat Nat Bool)
+ (_lux_proc ["nat" "="] [x y]))
+
+(def:''' (->Text x)
+ #Nil
+ (-> (host java.lang.Object) Text)
+ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))
+
+(macro:' #export (do-template tokens)
+ (list [["lux" "doc"] (#TextM "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary.
+ (do-template [<name> <diff>]
+ [(def: #export <name>
+ (-> Int Int)
+ (+ <diff>))]
+
+ [inc 1]
+ [dec -1])")])
+ (_lux_case tokens
+ (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])])
+ (_lux_case [(mapM Monad<Maybe> get-name bindings)
+ (mapM Monad<Maybe> tuple->list data)]
+ [(#Some bindings') (#Some data')]
+ (let' [apply (_lux_: (-> RepEnv ($' List AST))
+ (lambda' [env] (map (apply-template env) templates)))
+ num-bindings (length bindings')]
+ (if (every? (i= num-bindings) (map length data'))
+ (|> data'
+ (join-map (. apply (make-env bindings')))
+ return)
+ (fail (Text/append "Irregular arguments vectors for do-template. Expected size " (->Text num-bindings)))))
+
+ _
+ (fail "Wrong syntax for do-template"))
+
+ _
+ (fail "Wrong syntax for do-template")))
+
+
+(do-template [<name> <cmp> <type>]
+ [(def:''' (<name> x y)
+ #Nil
+ (-> <type> <type> Bool)
+ (_lux_proc ["jvm" <cmp>] [x y]))]
+
+ ## [i= "leq" Int]
+ [i> "lgt" Int]
+ [i< "llt" Int]
+ )
+
+(do-template [<name> <cmp> <eq> <type>]
+ [(def:''' (<name> x y)
+ #Nil
+ (-> <type> <type> Bool)
+ (if (<cmp> x y)
+ true
+ (<eq> x y)))]
+
+ [i>= i> i= Int]
+ [i<= i< i= Int]
+ )
+
+(do-template [<name> <op> <type>]
+ [(def:''' (<name> x y)
+ #Nil
+ (-> <type> <type> <type>)
+ (_lux_proc <op> [x y]))]
+
+ [i+ ["jvm" "ladd"] Int]
+ [i- ["jvm" "lsub"] Int]
+ [i* ["jvm" "lmul"] Int]
+ [i/ ["jvm" "ldiv"] Int]
+ [i% ["jvm" "lrem"] Int]
+
+ [n+ ["nat" "+"] Nat]
+ [n- ["nat" "-"] Nat]
+ [n* ["nat" "*"] Nat]
+ [n/ ["nat" "/"] Nat]
+ [n% ["nat" "%"] Nat]
+ )
+
+(def:''' (multiple? div n)
+ #Nil
+ (-> Int Int Bool)
+ (i= 0 (i% n div)))
+
+(def:''' #export (not x)
+ #Nil
+ (-> Bool Bool)
+ (if x false true))
+
+(def:''' (find-macro' modules current-module module name)
+ #Nil
+ (-> ($' List (& Text Module))
+ Text Text Text
+ ($' Maybe Macro))
+ (do Monad<Maybe>
+ [$module (get module modules)
+ gdef (let' [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _} (_lux_: Module $module)]
+ (get name bindings))]
+ (let' [[def-type def-meta def-value] (_lux_: Def gdef)]
+ (_lux_case (get-meta ["lux" "macro?"] def-meta)
+ (#Some (#BoolM true))
+ (_lux_case (get-meta ["lux" "export?"] def-meta)
+ (#Some (#BoolM true))
+ (#Some (_lux_:! Macro def-value))
+
+ _
+ (if (Text/= module current-module)
+ (#Some (_lux_:! Macro def-value))
+ #None))
+
+ _
+ (_lux_case (get-meta ["lux" "alias"] def-meta)
+ (#Some (#IdentM [r-module r-name]))
+ (find-macro' modules current-module r-module r-name)
+
+ _
+ #None)
+ ))
+ ))
+
+(def:''' (normalize ident)
+ #Nil
+ (-> Ident ($' Lux Ident))
+ (_lux_case ident
+ ["" name]
+ (do Monad<Lux>
+ [module-name current-module-name]
+ (wrap [module-name name]))
+
+ _
+ (return ident)))
+
+(def:''' (find-macro ident)
+ #Nil
+ (-> Ident ($' Lux ($' Maybe Macro)))
+ (do Monad<Lux>
+ [current-module current-module-name]
+ (let' [[module name] ident]
+ (lambda' [state]
+ (_lux_case state
+ {#info info #source source #modules modules
+ #scopes scopes #type-vars types #host host
+ #seed seed #expected expected
+ #cursor cursor
+ #scope-type-vars scope-type-vars}
+ (#Right state (find-macro' modules current-module module name)))))))
+
+(def:''' (macro? ident)
+ #Nil
+ (-> Ident ($' Lux Bool))
+ (do Monad<Lux>
+ [ident (normalize ident)
+ output (find-macro ident)]
+ (wrap (_lux_case output
+ (#Some _) true
+ #None false))))
+
+(def:''' (List/join xs)
+ #Nil
+ (All [a]
+ (-> ($' List ($' List a)) ($' List a)))
+ (fold List/append #Nil (reverse xs)))
+
+(def:''' (interpose sep xs)
+ #Nil
+ (All [a]
+ (-> a ($' List a) ($' List a)))
+ (_lux_case xs
+ #Nil
+ xs
+
+ (#Cons [x #Nil])
+ xs
+
+ (#Cons [x xs'])
+ (list& x sep (interpose sep xs'))))
+
+(def:''' (macro-expand-once token)
+ #Nil
+ (-> AST ($' Lux ($' List AST)))
+ (_lux_case token
+ [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))]
+ (do Monad<Lux>
+ [macro-name' (normalize macro-name)
+ ?macro (find-macro macro-name')]
+ (_lux_case ?macro
+ (#Some macro)
+ (macro args)
+
+ #None
+ (return (list token))))
+
+ _
+ (return (list token))))
+
+(def:''' (macro-expand token)
+ #Nil
+ (-> AST ($' Lux ($' List AST)))
+ (_lux_case token
+ [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))]
+ (do Monad<Lux>
+ [macro-name' (normalize macro-name)
+ ?macro (find-macro macro-name')]
+ (_lux_case ?macro
+ (#Some macro)
+ (do Monad<Lux>
+ [expansion (macro args)
+ expansion' (mapM Monad<Lux> macro-expand expansion)]
+ (wrap (List/join expansion')))
+
+ #None
+ (return (list token))))
+
+ _
+ (return (list token))))
+
+(def:''' (macro-expand-all syntax)
+ #Nil
+ (-> AST ($' Lux ($' List AST)))
+ (_lux_case syntax
+ [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))]
+ (do Monad<Lux>
+ [macro-name' (normalize macro-name)
+ ?macro (find-macro macro-name')]
+ (_lux_case ?macro
+ (#Some macro)
+ (do Monad<Lux>
+ [expansion (macro args)
+ expansion' (mapM Monad<Lux> macro-expand-all expansion)]
+ (wrap (List/join expansion')))
+
+ #None
+ (do Monad<Lux>
+ [args' (mapM Monad<Lux> macro-expand-all args)]
+ (wrap (list (form$ (#Cons (symbol$ macro-name) (List/join args'))))))))
+
+ [_ (#FormS members)]
+ (do Monad<Lux>
+ [members' (mapM Monad<Lux> macro-expand-all members)]
+ (wrap (list (form$ (List/join members')))))
+
+ [_ (#TupleS members)]
+ (do Monad<Lux>
+ [members' (mapM Monad<Lux> macro-expand-all members)]
+ (wrap (list (tuple$ (List/join members')))))
+
+ [_ (#RecordS pairs)]
+ (do Monad<Lux>
+ [pairs' (mapM Monad<Lux>
+ (lambda' [kv]
+ (let' [[key val] kv]
+ (do Monad<Lux>
+ [val' (macro-expand-all val)]
+ (_lux_case val'
+ (#;Cons val'' #;Nil)
+ (return [key val''])
+
+ _
+ (fail "The value-part of a KV-pair in a record must macro-expand to a single AST.")))))
+ pairs)]
+ (wrap (list (record$ pairs'))))
+
+ _
+ (return (list syntax))))
+
+(def:''' (walk-type type)
+ #Nil
+ (-> AST AST)
+ (_lux_case type
+ [_ (#FormS (#Cons [_ (#TagS tag)] parts))]
+ (form$ (#Cons [(tag$ tag) (map walk-type parts)]))
+
+ [_ (#TupleS members)]
+ (` (& (~@ (map walk-type members))))
+
+ [_ (#FormS (#Cons type-fn args))]
+ (fold (_lux_: (-> AST AST AST)
+ (lambda' [arg type-fn] (` (#;AppT (~ type-fn) (~ arg)))))
+ (walk-type type-fn)
+ (map walk-type args))
+
+ _
+ type))
+
+(macro:' #export (type tokens)
+ (list [["lux" "doc"] (#TextM "## Takes a type expression and returns it's representation as data-structure.
+ (type (All [a] (Maybe (List a))))")])
+ (_lux_case tokens
+ (#Cons type #Nil)
+ (do Monad<Lux>
+ [type+ (macro-expand-all type)]
+ (_lux_case type+
+ (#Cons type' #Nil)
+ (wrap (list (walk-type type')))
+
+ _
+ (fail "The expansion of the type-syntax had to yield a single element.")))
+
+ _
+ (fail "Wrong syntax for type")))
+
+(macro:' #export (: tokens)
+ (list [["lux" "doc"] (#TextM "## The type-annotation macro.
+ (: (List Int) (list 1 2 3))")])
+ (_lux_case tokens
+ (#Cons type (#Cons value #Nil))
+ (return (list (` (;_lux_: (type (~ type)) (~ value)))))
+
+ _
+ (fail "Wrong syntax for :")))
+
+(macro:' #export (:! tokens)
+ (list [["lux" "doc"] (#TextM "## The type-coercion macro.
+ (:! Dinosaur (list 1 2 3))")])
+ (_lux_case tokens
+ (#Cons type (#Cons value #Nil))
+ (return (list (` (;_lux_:! (type (~ type)) (~ value)))))
+
+ _
+ (fail "Wrong syntax for :!")))
+
+(def:''' (empty? xs)
+ #Nil
+ (All [a] (-> ($' List a) Bool))
+ (_lux_case xs
+ #Nil true
+ _ false))
+
+(do-template [<name> <type> <value>]
+ [(def:''' (<name> xy)
+ #Nil
+ (All [a b] (-> (& a b) <type>))
+ (let' [[x y] xy] <value>))]
+
+ [first a x]
+ [second b y])
+
+(def:''' (unfold-type-def type-asts)
+ #Nil
+ (-> ($' List AST) ($' Lux (& AST ($' Maybe ($' List Text)))))
+ (_lux_case type-asts
+ (#Cons [_ (#RecordS pairs)] #;Nil)
+ (do Monad<Lux>
+ [members (mapM Monad<Lux>
+ (: (-> [AST AST] (Lux [Text AST]))
+ (lambda' [pair]
+ (_lux_case pair
+ [[_ (#TagS "" member-name)] member-type]
+ (return [member-name member-type])
+
+ _
+ (fail "Wrong syntax for variant case."))))
+ pairs)]
+ (return [(` (& (~@ (map second members))))
+ (#Some (map first members))]))
+
+ (#Cons type #Nil)
+ (_lux_case type
+ [_ (#TagS "" member-name)]
+ (return [(` #;UnitT) (#;Some (list member-name))])
+
+ [_ (#FormS (#Cons [_ (#TagS "" member-name)] member-types))]
+ (return [(` (& (~@ member-types))) (#;Some (list member-name))])
+
+ _
+ (return [type #None]))
+
+ (#Cons case cases)
+ (do Monad<Lux>
+ [members (mapM Monad<Lux>
+ (: (-> AST (Lux [Text AST]))
+ (lambda' [case]
+ (_lux_case case
+ [_ (#TagS "" member-name)]
+ (return [member-name (` Unit)])
+
+ [_ (#FormS (#Cons [_ (#TagS "" member-name)] (#Cons member-type #Nil)))]
+ (return [member-name member-type])
+
+ [_ (#FormS (#Cons [_ (#TagS "" member-name)] member-types))]
+ (return [member-name (` (& (~@ member-types)))])
+
+ _
+ (fail "Wrong syntax for variant case."))))
+ (list& case cases))]
+ (return [(` (| (~@ (map second members))))
+ (#Some (map first members))]))
+
+ _
+ (fail "Improper type-definition syntax")))
+
+(def:''' (gensym prefix state)
+ #Nil
+ (-> Text ($' Lux AST))
+ (_lux_case state
+ {#info info #source source #modules modules
+ #scopes scopes #type-vars types #host host
+ #seed seed #expected expected
+ #cursor cursor
+ #scope-type-vars scope-type-vars}
+ (#Right {#info info #source source #modules modules
+ #scopes scopes #type-vars types #host host
+ #seed (n+ +1 seed) #expected expected
+ #cursor cursor
+ #scope-type-vars scope-type-vars}
+ (symbol$ ["" ($_ Text/append "__gensym__" prefix (->Text seed))]))))
+
+(macro:' #export (Rec tokens)
+ (list [["lux" "doc"] (#TextM "## Parameter-less recursive types.
+ ## A name has to be given to the whole type, to use it within it's body.
+ (Rec Self
+ [Int (List Self)])")])
+ (_lux_case tokens
+ (#Cons [_ (#SymbolS "" name)] (#Cons body #Nil))
+ (let' [body' (replace-syntax (list [name (` (#AppT (~ (make-bound +0)) (~ (make-bound +1))))]) body)]
+ (return (list (` (#AppT (#UnivQ #Nil (~ body')) Void)))))
+
+ _
+ (fail "Wrong syntax for Rec")))
+
+(macro:' #export (exec tokens)
+ (list [["lux" "doc"] (#TextM "## Sequential execution of expressions (great for side-effects).
+ (exec
+ (log! \"#1\")
+ (log! \"#2\")
+ (log! \"#3\")
+ \"YOLO\")")])
+ (_lux_case (reverse tokens)
+ (#Cons value actions)
+ (let' [dummy (symbol$ ["" ""])]
+ (return (list (fold (_lux_: (-> AST AST AST)
+ (lambda' [pre post] (` (;_lux_case (~ pre) (~ dummy) (~ post)))))
+ value
+ actions))))
+
+ _
+ (fail "Wrong syntax for exec")))
+
+(macro:' (def:' tokens)
+ (let' [[export? tokens'] (_lux_case tokens
+ (#Cons [_ (#TagS "" "export")] tokens')
+ [true tokens']
+
+ _
+ [false tokens])
+ parts (: (Maybe [AST (List AST) (Maybe AST) AST])
+ (_lux_case tokens'
+ (#Cons [_ (#FormS (#Cons name args))] (#Cons type (#Cons body #Nil)))
+ (#Some name args (#Some type) body)
+
+ (#Cons name (#Cons type (#Cons body #Nil)))
+ (#Some name #Nil (#Some type) body)
+
+ (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil))
+ (#Some name args #None body)
+
+ (#Cons name (#Cons body #Nil))
+ (#Some name #Nil #None body)
+
+ _
+ #None))]
+ (_lux_case parts
+ (#Some name args ?type body)
+ (let' [body' (_lux_case args
+ #Nil
+ body
+
+ _
+ (` (lambda' (~ name) [(~@ args)] (~ body))))
+ body'' (_lux_case ?type
+ (#Some type)
+ (` (: (~ type) (~ body')))
+
+ #None
+ body')]
+ (return (list (` (;_lux_def (~ name) (~ body'')
+ (~ (if export?
+ (with-export-meta (tag$ ["lux" "Nil"]))
+ (tag$ ["lux" "Nil"]))))))))
+
+ #None
+ (fail "Wrong syntax for def'"))))
+
+(def:' (rejoin-pair pair)
+ (-> [AST AST] (List AST))
+ (let' [[left right] pair]
+ (list left right)))
+
+(def:''' (Nat->Text x)
+ #Nil
+ (-> Nat Text)
+ (_lux_proc ["nat" "encode"] [x]))
+
+(def:''' (Frac->Text x)
+ #Nil
+ (-> Frac Text)
+ (_lux_proc ["frac" "encode"] [x]))
+
+(def:' (ast-to-text ast)
+ (-> AST Text)
+ (_lux_case ast
+ [_ (#BoolS value)]
+ (->Text value)
+
+ [_ (#NatS value)]
+ (Nat->Text value)
+
+ [_ (#IntS value)]
+ (->Text value)
+
+ [_ (#FracS value)]
+ (Frac->Text value)
+
+ [_ (#RealS value)]
+ (->Text value)
+
+ [_ (#CharS value)]
+ ($_ Text/append "#" "\"" (->Text value) "\"")
+
+ [_ (#TextS value)]
+ ($_ Text/append "\"" value "\"")
+
+ [_ (#SymbolS [prefix name])]
+ (if (Text/= "" prefix)
+ name
+ ($_ Text/append prefix ";" name))
+
+ [_ (#TagS [prefix name])]
+ (if (Text/= "" prefix)
+ ($_ Text/append "#" name)
+ ($_ Text/append "#" prefix ";" name))
+
+ [_ (#FormS xs)]
+ ($_ Text/append "(" (|> xs
+ (map ast-to-text)
+ (interpose " ")
+ reverse
+ (fold Text/append "")) ")")
+
+ [_ (#TupleS xs)]
+ ($_ Text/append "[" (|> xs
+ (map ast-to-text)
+ (interpose " ")
+ reverse
+ (fold Text/append "")) "]")
+
+ [_ (#RecordS kvs)]
+ ($_ Text/append "{" (|> kvs
+ (map (lambda' [kv] (_lux_case kv [k v] ($_ Text/append (ast-to-text k) " " (ast-to-text v)))))
+ (interpose " ")
+ reverse
+ (fold Text/append "")) "}")
+ ))
+
+(def:' (expander branches)
+ (-> (List AST) (Lux (List AST)))
+ (_lux_case branches
+ (#;Cons [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))]
+ (#;Cons body
+ branches'))
+ (do Monad<Lux>
+ [??? (macro? macro-name)]
+ (if ???
+ (do Monad<Lux>
+ [init-expansion (macro-expand-once (form$ (list& (symbol$ macro-name) (form$ macro-args) body branches')))]
+ (expander init-expansion))
+ (do Monad<Lux>
+ [sub-expansion (expander branches')]
+ (wrap (list& (form$ (list& (symbol$ macro-name) macro-args))
+ body
+ sub-expansion)))))
+
+ (#;Cons pattern (#;Cons body branches'))
+ (do Monad<Lux>
+ [sub-expansion (expander branches')]
+ (wrap (list& pattern body sub-expansion)))
+
+ #;Nil
+ (do Monad<Lux> [] (wrap (list)))
+
+ _
+ (fail ($_ Text/append "\"lux;case\" expects an even number of tokens: " (|> branches
+ (map ast-to-text)
+ (interpose " ")
+ reverse
+ (fold Text/append ""))))))
+
+(macro:' #export (case tokens)
+ (list [["lux" "doc"] (#TextM "## The pattern-matching macro.
+ ## Allows the usage of macros within the patterns to provide custom syntax.
+ (case (: (List Int) (list 1 2 3))
+ (#Cons x (#Cons y (#Cons z #Nil)))
+ (#Some ($_ * x y z))
+
+ _
+ #None)")])
+ (_lux_case tokens
+ (#Cons value branches)
+ (do Monad<Lux>
+ [expansion (expander branches)]
+ (wrap (list (` (;_lux_case (~ value) (~@ expansion))))))
+
+ _
+ (fail "Wrong syntax for case")))
+
+(macro:' #export (^ tokens)
+ (list [["lux" "doc"] (#TextM "## Macro-expanding patterns.
+ ## It's a special macro meant to be used with case.
+ (case (: (List Int) (list 1 2 3))
+ (^ (list x y z))
+ (#Some ($_ * x y z))
+
+ _
+ #None)")])
+ (case tokens
+ (#Cons [_ (#FormS (#Cons pattern #Nil))] (#Cons body branches))
+ (do Monad<Lux>
+ [pattern+ (macro-expand-all pattern)]
+ (case pattern+
+ (#Cons pattern' #Nil)
+ (wrap (list& pattern' body branches))
+
+ _
+ (fail "^ can only expand to 1 pattern.")))
+
+ _
+ (fail "Wrong syntax for ^ macro")))
+
+(macro:' #export (^or tokens)
+ (list [["lux" "doc"] (#TextM "## Or-patterns.
+ ## It's a special macro meant to be used with case.
+ (type: Weekday
+ (| #Monday
+ #Tuesday
+ #Wednesday
+ #Thursday
+ #Friday
+ #Saturday
+ #Sunday))
+
+ (def: (weekend? day)
+ (-> Weekday Bool)
+ (case day
+ (^or #Saturday #Sunday)
+ true
+
+ _
+ false))")])
+ (case tokens
+ (^ (list& [_ (#FormS patterns)] body branches))
+ (case patterns
+ #Nil
+ (fail "^or can't have 0 patterns")
+
+ _
+ (let' [pairs (|> patterns
+ (map (lambda' [pattern] (list pattern body)))
+ (List/join))]
+ (return (List/append pairs branches))))
+ _
+ (fail "Wrong syntax for ^or")))
+
+(def:' (symbol? ast)
+ (-> AST Bool)
+ (case ast
+ [_ (#SymbolS _)]
+ true
+
+ _
+ false))
+
+(macro:' #export (let tokens)
+ (list [["lux" "doc"] (#TextM "## Creates local bindings.
+ ## Can (optionally) use pattern-matching macros when binding.
+ (let [x (foo bar)
+ y (baz quux)]
+ (op x y))")])
+ (case tokens
+ (^ (list [_ (#TupleS bindings)] body))
+ (if (multiple? 2 (length bindings))
+ (|> bindings as-pairs reverse
+ (fold (: (-> [AST AST] AST AST)
+ (lambda' [lr body']
+ (let' [[l r] lr]
+ (if (symbol? l)
+ (` (;_lux_case (~ r) (~ l) (~ body')))
+ (` (case (~ r) (~ l) (~ body')))))))
+ body)
+ list
+ return)
+ (fail "let requires an even number of parts"))
+
+ _
+ (fail "Wrong syntax for let")))
+
+(macro:' #export (lambda tokens)
+ (list [["lux" "doc"] (#TextM "## Syntax for creating functions.
+ ## Allows for giving the function itself a name, for the sake of recursion.
+ (: (All [a b] (-> a b a))
+ (lambda [x y] x))
+
+ (: (All [a b] (-> a b a))
+ (lambda const [x y] x))")])
+ (case (: (Maybe [Ident AST (List AST) AST])
+ (case tokens
+ (^ (list [_ (#TupleS (#Cons head tail))] body))
+ (#Some ["" ""] head tail body)
+
+ (^ (list [_ (#SymbolS ["" name])] [_ (#TupleS (#Cons head tail))] body))
+ (#Some ["" name] head tail body)
+
+ _
+ #None))
+ (#Some ident head tail body)
+ (let [g!blank (symbol$ ["" ""])
+ g!name (symbol$ ident)
+ body+ (fold (: (-> AST AST AST)
+ (lambda' [arg body']
+ (if (symbol? arg)
+ (` (;_lux_lambda (~ g!blank) (~ arg) (~ body')))
+ (` (;_lux_lambda (~ g!blank) (~ g!blank)
+ (case (~ g!blank) (~ arg) (~ body')))))))
+ body
+ (reverse tail))]
+ (return (list (if (symbol? head)
+ (` (;_lux_lambda (~ g!name) (~ head) (~ body+)))
+ (` (;_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+))))))))
+
+ #None
+ (fail "Wrong syntax for lambda")))
+
+(def:' (process-def-meta-value ast)
+ (-> AST (Lux AST))
+ (case ast
+ [_ (#BoolS value)]
+ (return (form$ (list (tag$ ["lux" "BoolM"]) (bool$ value))))
+
+ [_ (#NatS value)]
+ (return (form$ (list (tag$ ["lux" "NatM"]) (nat$ value))))
+
+ [_ (#IntS value)]
+ (return (form$ (list (tag$ ["lux" "IntM"]) (int$ value))))
+
+ [_ (#FracS value)]
+ (return (form$ (list (tag$ ["lux" "FracM"]) (frac$ value))))
+
+ [_ (#RealS value)]
+ (return (form$ (list (tag$ ["lux" "RealM"]) (real$ value))))
+
+ [_ (#CharS value)]
+ (return (form$ (list (tag$ ["lux" "CharM"]) (char$ value))))
+
+ [_ (#TextS value)]
+ (return (form$ (list (tag$ ["lux" "TextM"]) (text$ value))))
+
+ [_ (#TagS [prefix name])]
+ (return (form$ (list (tag$ ["lux" "IdentM"]) (tuple$ (list (text$ prefix) (text$ name))))))
+
+ (^or [_ (#FormS _)] [_ (#SymbolS _)])
+ (return ast)
+
+ [_ (#TupleS xs)]
+ (do Monad<Lux>
+ [=xs (mapM Monad<Lux> process-def-meta-value xs)]
+ (wrap (form$ (list (tag$ ["lux" "ListM"]) (untemplate-list =xs)))))
+
+ [_ (#RecordS kvs)]
+ (do Monad<Lux>
+ [=xs (mapM Monad<Lux>
+ (: (-> [AST AST] (Lux AST))
+ (lambda [[k v]]
+ (case k
+ [_ (#TextS =k)]
+ (do Monad<Lux>
+ [=v (process-def-meta-value v)]
+ (wrap (tuple$ (list (text$ =k) =v))))
+
+ _
+ (fail (Text/append "Wrong syntax for DictM key: " (ast-to-text k))))))
+ kvs)]
+ (wrap (form$ (list (tag$ ["lux" "DictM"]) (untemplate-list =xs)))))
+ ))
+
+(def:' (process-def-meta ast)
+ (-> AST (Lux AST))
+ (case ast
+ [_ (#RecordS kvs)]
+ (do Monad<Lux>
+ [=kvs (mapM Monad<Lux>
+ (: (-> [AST AST] (Lux AST))
+ (lambda [[k v]]
+ (case k
+ [_ (#TagS [pk nk])]
+ (do Monad<Lux>
+ [=v (process-def-meta-value v)]
+ (wrap (tuple$ (list (tuple$ (list (text$ pk) (text$ nk)))
+ =v))))
+
+ _
+ (fail (Text/append "Wrong syntax for Anns: " (ast-to-text ast))))))
+ kvs)]
+ (wrap (untemplate-list =kvs)))
+
+ _
+ (fail (Text/append "Wrong syntax for Anns: " (ast-to-text ast)))))
+
+(def:' (with-func-args args meta)
+ (-> (List AST) AST AST)
+ (case args
+ #;Nil
+ meta
+
+ _
+ (` (#;Cons [["lux" "func-args"]
+ (#;ListM (list (~@ (map (lambda [arg]
+ (` (#;TextM (~ (text$ (ast-to-text arg))))))
+ args))))]
+ (~ meta)))))
+
+(def:' (with-type-args args)
+ (-> (List AST) AST)
+ (` {#;type-args (#;ListM (list (~@ (map (lambda [arg]
+ (` (#;TextM (~ (text$ (ast-to-text arg))))))
+ args))))}))
+
+(def:' Export-Level
+ Type
+ ($' Either
+ Unit ## Exported
+ Unit ## Hidden
+ ))
+
+(def:' (export-level^ tokens)
+ (-> (List AST) [(Maybe Export-Level) (List AST)])
+ (case tokens
+ (#Cons [_ (#TagS [_ "export"])] tokens')
+ [(#;Some (#;Left [])) tokens']
+
+ (#Cons [_ (#TagS [_ "hidden"])] tokens')
+ [(#;Some (#;Right [])) tokens']
+
+ _
+ [#;None tokens]))
+
+(def:' (export-level ?el)
+ (-> (Maybe Export-Level) (List AST))
+ (case ?el
+ #;None
+ (list)
+
+ (#;Some (#;Left []))
+ (list (' #export))
+
+ (#;Some (#;Right []))
+ (list (' #hidden))))
+
+(macro:' #export (def: tokens)
+ (list [["lux" "doc"] (#TextM "## Defines global constants/functions.
+ (def: (rejoin-pair pair)
+ (-> [AST AST] (List AST))
+ (let [[left right] pair]
+ (list left right)))
+
+ (def: branching-exponent
+ Int
+ 5)")])
+ (let [[export? tokens'] (export-level^ tokens)
+ parts (: (Maybe [AST (List AST) (Maybe AST) AST AST])
+ (case tokens'
+ (^ (list [_ (#FormS (#Cons name args))] meta type body))
+ (#Some name args (#Some type) body meta)
+
+ (^ (list name meta type body))
+ (#Some name #Nil (#Some type) body meta)
+
+ (^ (list [_ (#FormS (#Cons name args))] type body))
+ (#Some name args (#Some type) body (' {}))
+
+ (^ (list name type body))
+ (#Some name #Nil (#Some type) body (' {}))
+
+ (^ (list [_ (#FormS (#Cons name args))] body))
+ (#Some name args #None body (' {}))
+
+ (^ (list name body))
+ (#Some name #Nil #None body (' {}))
+
+ _
+ #None))]
+ (case parts
+ (#Some name args ?type body meta)
+ (let [body (case args
+ #Nil
+ body
+
+ _
+ (` (lambda (~ name) [(~@ args)] (~ body))))
+ body (case ?type
+ (#Some type)
+ (` (: (~ type) (~ body)))
+
+ #None
+ body)]
+ (do Monad<Lux>
+ [=meta (process-def-meta meta)]
+ (return (list (` (;_lux_def (~ name) (~ body) (~ (with-func-args args
+ (case export?
+ #;None
+ =meta
+
+ (#;Some (#;Left []))
+ (with-export-meta =meta)
+
+ (#;Some (#;Right []))
+ (|> =meta
+ with-export-meta
+ with-hidden-meta)
+ )))))))))
+
+ #None
+ (fail "Wrong syntax for def"))))
+
+(def: (meta-ast-add addition meta)
+ (-> [AST AST] AST AST)
+ (case [addition meta]
+ [[name value] [cursor (#;RecordS pairs)]]
+ [cursor (#;RecordS (#;Cons [name value] pairs))]
+
+ _
+ meta))
+
+(def: (meta-ast-merge addition base)
+ (-> AST AST AST)
+ (case addition
+ [cursor (#;RecordS pairs)]
+ (fold meta-ast-add base pairs)
+
+ _
+ base))
+
+(macro:' #export (macro: tokens)
+ (list [["lux" "doc"] (#TextM "(macro: #export (ident-for tokens)
+ (case tokens
+ (^template [<tag>]
+ (^ (list [_ (<tag> [prefix name])]))
+ (return (list (` [(~ (text$ prefix)) (~ (text$ name))]))))
+ ([#;SymbolS] [#;TagS])
+
+ _
+ (fail \"Wrong syntax for ident-for\")))")])
+ (let [[exported? tokens] (export-level^ tokens)
+ name+args+meta+body?? (: (Maybe [Ident (List AST) AST AST])
+ (case tokens
+ (^ (list [_ (#;FormS (list& [_ (#SymbolS name)] args))] body))
+ (#Some [name args (` {}) body])
+
+ (^ (list [_ (#;SymbolS name)] body))
+ (#Some [name #Nil (` {}) body])
+
+ (^ (list [_ (#;FormS (list& [_ (#SymbolS name)] args))] [meta-rec-cursor (#;RecordS meta-rec-parts)] body))
+ (#Some [name args [meta-rec-cursor (#;RecordS meta-rec-parts)] body])
+
+ (^ (list [_ (#;SymbolS name)] [meta-rec-cursor (#;RecordS meta-rec-parts)] body))
+ (#Some [name #Nil [meta-rec-cursor (#;RecordS meta-rec-parts)] body])
+
+ _
+ #None))]
+ (case name+args+meta+body??
+ (#Some [name args meta body])
+ (let [name (symbol$ name)
+ def-sig (case args
+ #;Nil name
+ _ (` ((~ name) (~@ args))))]
+ (return (list (` (;;def: (~@ (export-level exported?))
+ (~ def-sig)
+ (~ (meta-ast-merge (` {#;macro? true})
+ meta))
+
+ ;;Macro
+ (~ body))))))
+
+
+ #None
+ (fail "Wrong syntax for macro:"))))
+
+(macro: #export (sig: tokens)
+ {#;doc "## Definition of signatures ala ML.
+ (sig: #export (Ord a)
+ (: (Eq a)
+ eq)
+ (: (-> a a Bool)
+ <)
+ (: (-> a a Bool)
+ <=)
+ (: (-> a a Bool)
+ >)
+ (: (-> a a Bool)
+ >=))"}
+ (let [[exported? tokens'] (export-level^ tokens)
+ ?parts (: (Maybe [Ident (List AST) AST (List AST)])
+ (case tokens'
+ (^ (list& [_ (#FormS (list& [_ (#SymbolS name)] args))] [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs))
+ (#Some name args [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs)
+
+ (^ (list& [_ (#SymbolS name)] [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs))
+ (#Some name #Nil [meta-rec-cursor (#;RecordS meta-rec-parts)] sigs)
+
+ (^ (list& [_ (#FormS (list& [_ (#SymbolS name)] args))] sigs))
+ (#Some name args (` {}) sigs)
+
+ (^ (list& [_ (#SymbolS name)] sigs))
+ (#Some name #Nil (` {}) sigs)
+
+ _
+ #None))]
+ (case ?parts
+ (#Some name args meta sigs)
+ (do Monad<Lux>
+ [name+ (normalize name)
+ sigs' (mapM Monad<Lux> macro-expand sigs)
+ members (: (Lux (List [Text AST]))
+ (mapM Monad<Lux>
+ (: (-> AST (Lux [Text AST]))
+ (lambda [token]
+ (case token
+ (^ [_ (#FormS (list [_ (#SymbolS _ "_lux_:")] type [_ (#SymbolS ["" name])]))])
+ (wrap [name type])
+
+ _
+ (fail "Signatures require typed members!"))))
+ (List/join sigs')))
+ #let [[_module _name] name+
+ def-name (symbol$ name)
+ sig-type (record$ (map (: (-> [Text AST] [AST AST])
+ (lambda [[m-name m-type]]
+ [(tag$ ["" m-name]) m-type]))
+ members))
+ sig-meta (meta-ast-merge (` {#;sig? true})
+ meta)
+ usage (case args
+ #;Nil
+ def-name
+
+ _
+ (` ((~ def-name) (~@ args))))]]
+ (return (list (` (;;type: (~@ (export-level exported?)) (~ usage) (~ sig-meta) (~ sig-type))))))
+
+ #None
+ (fail "Wrong syntax for sig:"))))
+
+(def: (find f xs)
+ (All [a b]
+ (-> (-> a (Maybe b)) (List a) (Maybe b)))
+ (case xs
+ #Nil
+ #None
+
+ (#Cons x xs')
+ (case (f x)
+ #None
+ (find f xs')
+
+ (#Some y)
+ (#Some y))))
+
+(def: (last-index-of part text)
+ (-> Text Text Int)
+ (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:lastIndexOf:java.lang.String"] [text part])]))
+
+(def: (index-of part text)
+ (-> Text Text Int)
+ (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:indexOf:java.lang.String"] [text part])]))
+
+(def: (substring1 idx text)
+ (-> Int Text Text)
+ (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int"] [text (_lux_proc ["jvm" "l2i"] [idx])]))
+
+(def: (substring2 idx1 idx2 text)
+ (-> Int Int Text Text)
+ (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] [text (_lux_proc ["jvm" "l2i"] [idx1]) (_lux_proc ["jvm" "l2i"] [idx2])]))
+
+(def: #export (log! message)
+ (-> Text Unit)
+ (_lux_proc ["jvm" "invokevirtual:java.io.PrintStream:println:java.lang.String"]
+ [(_lux_proc ["jvm" "getstatic:java.lang.System:out"] []) message]))
+
+(def: (split-text splitter input)
+ (-> Text Text (List Text))
+ (let [idx (index-of splitter input)]
+ (if (i< idx 0)
+ (#Cons input #Nil)
+ (#Cons (substring2 0 idx input)
+ (split-text splitter (substring1 (i+ 1 idx) input))))))
+
+(def: (split-module-contexts module)
+ (-> Text (List Text))
+ (#Cons module (let [idx (last-index-of "/" module)]
+ (if (i< idx 0)
+ #Nil
+ (split-module-contexts (substring2 0 idx module))))))
+
+(def: (split-module module)
+ (-> Text (List Text))
+ (let [idx (index-of "/" module)]
+ (if (i< idx 0)
+ (list module)
+ (list& (substring2 0 idx module) (split-module (substring1 (i+ 1 idx) module))))))
+
+(def: (at idx xs)
+ (All [a]
+ (-> Int (List a) (Maybe a)))
+ (case xs
+ #Nil
+ #None
+
+ (#Cons x xs')
+ (if (i= idx 0)
+ (#Some x)
+ (at (i- idx 1) xs')
+ )))
+
+(def: (beta-reduce env type)
+ (-> (List Type) Type Type)
+ (case type
+ (#SumT left right)
+ (#SumT (beta-reduce env left) (beta-reduce env right))
+
+ (#ProdT left right)
+ (#ProdT (beta-reduce env left) (beta-reduce env right))
+
+ (#AppT ?type-fn ?type-arg)
+ (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))
+
+ (#UnivQ ?local-env ?local-def)
+ (case ?local-env
+ #Nil
+ (#UnivQ env ?local-def)
+
+ _
+ type)
+
+ (#ExQ ?local-env ?local-def)
+ (case ?local-env
+ #Nil
+ (#ExQ env ?local-def)
+
+ _
+ type)
+
+ (#LambdaT ?input ?output)
+ (#LambdaT (beta-reduce env ?input) (beta-reduce env ?output))
+
+ (#BoundT idx)
+ (case (at (_lux_proc ["nat" "to-int"] [idx]) env)
+ (#Some bound)
+ bound
+
+ _
+ type)
+
+ (#NamedT name type)
+ (beta-reduce env type)
+
+ _
+ type
+ ))
+
+(def: (apply-type type-fn param)
+ (-> Type Type (Maybe Type))
+ (case type-fn
+ (#UnivQ env body)
+ (#Some (beta-reduce (list& type-fn param env) body))
+
+ (#ExQ env body)
+ (#Some (beta-reduce (list& type-fn param env) body))
+
+ (#AppT F A)
+ (do Monad<Maybe>
+ [type-fn* (apply-type F A)]
+ (apply-type type-fn* param))
+
+ (#NamedT name type)
+ (apply-type type param)
+
+ _
+ #None))
+
+(do-template [<name> <tag>]
+ [(def: (<name> type)
+ (-> Type (List Type))
+ (case type
+ (<tag> left right)
+ (list& left (<name> right))
+
+ _
+ (list type)))]
+
+ [flatten-sum #;SumT]
+ [flatten-prod #;ProdT]
+ [flatten-lambda #;LambdaT]
+ [flatten-app #;AppT]
+ )
+
+(def: (resolve-struct-type type)
+ (-> Type (Maybe (List Type)))
+ (case type
+ (#ProdT _)
+ (#Some (flatten-prod type))
+
+ (#AppT fun arg)
+ (do Monad<Maybe>
+ [output (apply-type fun arg)]
+ (resolve-struct-type output))
+
+ (#UnivQ _ body)
+ (resolve-struct-type body)
+
+ (#ExQ _ body)
+ (resolve-struct-type body)
+
+ (#NamedT name type)
+ (resolve-struct-type type)
+
+ (#SumT _)
+ #None
+
+ _
+ (#Some (list type))))
+
+(def: (find-module name)
+ (-> Text (Lux Module))
+ (lambda [state]
+ (let [{#info info #source source #modules modules
+ #scopes scopes #type-vars types #host host
+ #seed seed #expected expected #cursor cursor
+ #scope-type-vars scope-type-vars} state]
+ (case (get name modules)
+ (#Some module)
+ (#Right state module)
+
+ _
+ (#Left ($_ Text/append "Unknown module: " name))))))
+
+(def: get-current-module
+ (Lux Module)
+ (do Monad<Lux>
+ [module-name current-module-name]
+ (find-module module-name)))
+
+(def: (resolve-tag [module name])
+ (-> Ident (Lux [Nat (List Ident) Bool Type]))
+ (do Monad<Lux>
+ [=module (find-module module)
+ #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags-table #types types #module-anns _} =module]]
+ (case (get name tags-table)
+ (#Some output)
+ (return output)
+
+ _
+ (fail (Text/append "Unknown tag: " (Ident->Text [module name]))))))
+
+(def: (resolve-type-tags type)
+ (-> Type (Lux (Maybe [(List Ident) (List Type)])))
+ (case type
+ (#AppT fun arg)
+ (resolve-type-tags fun)
+
+ (#UnivQ env body)
+ (resolve-type-tags body)
+
+ (#ExQ env body)
+ (resolve-type-tags body)
+
+ (#NamedT [module name] _)
+ (do Monad<Lux>
+ [=module (find-module module)
+ #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _} =module]]
+ (case (get name types)
+ (#Some [tags exported? (#NamedT _ _type)])
+ (case (resolve-struct-type _type)
+ (#Some members)
+ (return (#Some [tags members]))
+
+ _
+ (return #None))
+
+ _
+ (return #None)))
+
+ _
+ (return #None)))
+
+(def: get-expected-type
+ (Lux Type)
+ (lambda [state]
+ (let [{#info info #source source #modules modules
+ #scopes scopes #type-vars types #host host
+ #seed seed #expected expected #cursor cursor
+ #scope-type-vars scope-type-vars} state]
+ (case expected
+ (#Some type)
+ (#Right state type)
+
+ #None
+ (#Left "Not expecting any type.")))))
+
+(macro: #export (struct tokens)
+ {#;doc "Not meant to be used directly. Prefer \"struct:\"."}
+ (do Monad<Lux>
+ [tokens' (mapM Monad<Lux> macro-expand tokens)
+ struct-type get-expected-type
+ tags+type (resolve-type-tags struct-type)
+ tags (: (Lux (List Ident))
+ (case tags+type
+ (#Some [tags _])
+ (return tags)
+
+ _
+ (fail "No tags available for type.")))
+ #let [tag-mappings (: (List [Text AST])
+ (map (lambda [tag] [(second tag) (tag$ tag)])
+ tags))]
+ members (mapM Monad<Lux>
+ (: (-> AST (Lux [AST AST]))
+ (lambda [token]
+ (case token
+ (^ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS "" tag-name)] value meta))])
+ (case (get tag-name tag-mappings)
+ (#Some tag)
+ (wrap [tag value])
+
+ _
+ (fail (Text/append "Unknown structure member: " tag-name)))
+
+ _
+ (fail "Invalid structure member."))))
+ (List/join tokens'))]
+ (wrap (list (record$ members)))))
+
+(def: (Text/join parts)
+ (-> (List Text) Text)
+ (|> parts reverse (fold Text/append "")))
+
+(macro: #export (struct: tokens)
+ {#;doc "## Definition of structures ala ML.
+ (struct: #export Ord<Int> (Ord Int)
+ (def: eq Eq<Int>)
+ (def: (< test subject)
+ (lux;< test subject))
+ (def: (<= test subject)
+ (or (lux;< test subject)
+ (lux;= test subject)))
+ (def: (lux;> test subject)
+ (lux;> test subject))
+ (def: (lux;>= test subject)
+ (or (lux;> test subject)
+ (lux;= test subject))))"}
+ (let [[exported? tokens'] (export-level^ tokens)
+ ?parts (: (Maybe [AST (List AST) AST AST (List AST)])
+ (case tokens'
+ (^ (list& [_ (#FormS (list& name args))] type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs))
+ (#Some name args type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs)
+
+ (^ (list& name type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs))
+ (#Some name #Nil type [meta-rec-cursor (#;RecordS meta-rec-parts)] defs)
+
+ (^ (list& [_ (#FormS (list& name args))] type defs))
+ (#Some name args type (` {}) defs)
+
+ (^ (list& name type defs))
+ (#Some name #Nil type (` {}) defs)
+
+ _
+ #None))]
+ (case ?parts
+ (#Some [name args type meta defs])
+ (case (case name
+ [_ (#;SymbolS ["" "_"])]
+ (case type
+ (^ [_ (#;FormS (list& [_ (#;SymbolS [_ sig-name])] sig-args))])
+ (case (: (Maybe (List Text))
+ (mapM Monad<Maybe>
+ (lambda [sa]
+ (case sa
+ [_ (#;SymbolS [_ arg-name])]
+ (#;Some arg-name)
+
+ _
+ #;None))
+ sig-args))
+ (^ (#;Some params))
+ (#;Some (symbol$ ["" ($_ Text/append sig-name "<" (|> params (interpose ",") Text/join) ">")]))
+
+ _
+ #;None)
+
+ _
+ #;None)
+
+ _
+ (#;Some name)
+ )
+ (#;Some name)
+ (let [usage (case args
+ #Nil
+ name
+
+ _
+ (` ((~ name) (~@ args))))]
+ (return (list (` (;;def: (~@ (export-level exported?)) (~ usage)
+ (~ (meta-ast-merge (` {#;struct? true})
+ meta))
+ (~ type)
+ (struct (~@ defs)))))))
+
+ #;None
+ (fail "Struct must have a name other than \"_\"!"))
+
+ #None
+ (fail "Wrong syntax for struct:"))))
+
+(def: #export (id x)
+ {#;doc "Identity function. Does nothing to it's argument and just returns it."}
+ (All [a] (-> a a))
+ x)
+
+(do-template [<name> <form> <message> <doc-msg>]
+ [(macro: #export (<name> tokens)
+ {#;doc <doc-msg>}
+ (case (reverse tokens)
+ (^ (list& last init))
+ (return (list (fold (: (-> AST AST AST)
+ (lambda [pre post] (` <form>)))
+ last
+ init)))
+
+ _
+ (fail <message>)))]
+
+ [and (if (~ pre) (~ post) false) "'and' requires >=1 clauses." "Short-circuiting \"and\"\n(and true false true) ## => false"]
+ [or (if (~ pre) true (~ post)) "'or' requires >=1 clauses." "Short-circuiting \"or\"\n(or true false true) ## => true"])
+
+(macro: #export (type: tokens)
+ {#;doc "## The type-definition macro.
+ (type: (List a)
+ #Nil
+ (#Cons a (List a)))"}
+ (let [[exported? tokens'] (export-level^ tokens)
+ [rec? tokens'] (case tokens'
+ (#Cons [_ (#TagS [_ "rec"])] tokens')
+ [true tokens']
+
+ _
+ [false tokens'])
+ parts (: (Maybe [Text (List AST) AST (List AST)])
+ (case tokens'
+ (^ (list [_ (#SymbolS "" name)] [meta-cursor (#;RecordS meta-parts)] [type-cursor (#;RecordS type-parts)]))
+ (#Some [name #Nil [meta-cursor (#;RecordS meta-parts)] (list [type-cursor (#;RecordS type-parts)])])
+
+ (^ (list& [_ (#SymbolS "" name)] [meta-cursor (#;RecordS meta-parts)] type-ast1 type-asts))
+ (#Some [name #Nil [meta-cursor (#;RecordS meta-parts)] (#;Cons type-ast1 type-asts)])
+
+ (^ (list& [_ (#SymbolS "" name)] type-asts))
+ (#Some [name #Nil (` {}) type-asts])
+
+ (^ (list [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] [meta-cursor (#;RecordS meta-parts)] [type-cursor (#;RecordS type-parts)]))
+ (#Some [name args [meta-cursor (#;RecordS meta-parts)] (list [type-cursor (#;RecordS type-parts)])])
+
+ (^ (list& [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] [meta-cursor (#;RecordS meta-parts)] type-ast1 type-asts))
+ (#Some [name args [meta-cursor (#;RecordS meta-parts)] (#;Cons type-ast1 type-asts)])
+
+ (^ (list& [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] type-asts))
+ (#Some [name args (` {}) type-asts])
+
+ _
+ #None))]
+ (case parts
+ (#Some name args meta type-asts)
+ (do Monad<Lux>
+ [type+tags?? (unfold-type-def type-asts)
+ module-name current-module-name]
+ (let [type-name (symbol$ ["" name])
+ [type tags??] type+tags??
+ type-meta (: AST
+ (case tags??
+ (#Some tags)
+ (` {#;tags [(~@ (map (: (-> Text AST)
+ (lambda' [tag]
+ (form$ (list (tag$ ["lux" "TextM"])
+ (text$ tag)))))
+ tags))]
+ #;type? true})
+
+ _
+ (` {#;type? true})))
+ type' (: (Maybe AST)
+ (if rec?
+ (if (empty? args)
+ (let [g!param (symbol$ ["" ""])
+ prime-name (symbol$ ["" (Text/append name "'")])
+ type+ (replace-syntax (list [name (` ((~ prime-name) (~ g!param)))]) type)]
+ (#Some (` ((All (~ prime-name) [(~ g!param)] (~ type+))
+ Void))))
+ #None)
+ (case args
+ #Nil
+ (#Some type)
+
+ _
+ (#Some (` (All (~ type-name) [(~@ args)] (~ type)))))))]
+ (case type'
+ (#Some type'')
+ (return (list (` (;;def: (~@ (export-level exported?)) (~ type-name)
+ (~ ($_ meta-ast-merge (with-type-args args)
+ (if rec? (' {#;type-rec? true}) (' {}))
+ type-meta
+ meta))
+ Type
+ (#;NamedT [(~ (text$ module-name))
+ (~ (text$ name))]
+ (type (~ type'')))))))
+
+ #None
+ (fail "Wrong syntax for type:"))))
+
+ #None
+ (fail "Wrong syntax for type:"))
+ ))
+
+(type: Referrals
+ #All
+ (#Only (List Text))
+ (#Exclude (List Text))
+ #Nothing)
+
+(type: Openings
+ [Text (List Ident)])
+
+(type: Refer
+ {#refer-defs Referrals
+ #refer-open (List Openings)})
+
+(type: Importation
+ {#import-name Text
+ #import-alias (Maybe Text)
+ #import-refer Refer})
+
+(def: (extract-defs defs)
+ (-> (List AST) (Lux (List Text)))
+ (mapM Monad<Lux>
+ (: (-> AST (Lux Text))
+ (lambda [def]
+ (case def
+ [_ (#SymbolS ["" name])]
+ (return name)
+
+ _
+ (fail "only/exclude requires symbols."))))
+ defs))
+
+(def: (parse-alias tokens)
+ (-> (List AST) (Lux [(Maybe Text) (List AST)]))
+ (case tokens
+ (^ (list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens'))
+ (return [(#Some alias) tokens'])
+
+ _
+ (return [#None tokens])))
+
+(def: (parse-referrals tokens)
+ (-> (List AST) (Lux [Referrals (List AST)]))
+ (case tokens
+ (^ (list& [_ (#TagS ["" "refer"])] referral tokens'))
+ (case referral
+ [_ (#TagS "" "all")]
+ (return [#All tokens'])
+
+ (^ [_ (#FormS (list& [_ (#TagS ["" "only"])] defs))])
+ (do Monad<Lux>
+ [defs' (extract-defs defs)]
+ (return [(#Only defs') tokens']))
+
+ (^ [_ (#FormS (list& [_ (#TagS ["" "exclude"])] defs))])
+ (do Monad<Lux>
+ [defs' (extract-defs defs)]
+ (return [(#Exclude defs') tokens']))
+
+ _
+ (fail "Incorrect syntax for referral."))
+
+ _
+ (return [#Nothing tokens])))
+
+(def: (split-with' p ys xs)
+ (All [a]
+ (-> (-> a Bool) (List a) (List a) [(List a) (List a)]))
+ (case xs
+ #Nil
+ [ys xs]
+
+ (#Cons x xs')
+ (if (p x)
+ (split-with' p (list& x ys) xs')
+ [ys xs])))
+
+(def: (split-with p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) [(List a) (List a)]))
+ (let [[ys' xs'] (split-with' p #Nil xs)]
+ [(reverse ys') xs']))
+
+(def: (parse-short-referrals tokens)
+ (-> (List AST) (Lux [Referrals (List AST)]))
+ (case tokens
+ (^ (list& [_ (#TagS "" "+")] tokens'))
+ (let [[defs tokens'] (split-with symbol? tokens')]
+ (do Monad<Lux>
+ [defs' (extract-defs defs)]
+ (return [(#Only defs') tokens'])))
+
+ (^ (list& [_ (#TagS "" "-")] tokens'))
+ (let [[defs tokens'] (split-with symbol? tokens')]
+ (do Monad<Lux>
+ [defs' (extract-defs defs)]
+ (return [(#Exclude defs') tokens'])))
+
+ (^ (list& [_ (#TagS "" "*")] tokens'))
+ (return [#All tokens'])
+
+ _
+ (return [#Nothing tokens])))
+
+(def: (extract-symbol syntax)
+ (-> AST (Lux Ident))
+ (case syntax
+ [_ (#SymbolS ident)]
+ (return ident)
+
+ _
+ (fail "Not a symbol.")))
+
+(def: (parse-openings tokens)
+ (-> (List AST) (Lux [(List Openings) (List AST)]))
+ (case tokens
+ (^ (list& [_ (#TagS "" "open")] [_ (#FormS parts)] tokens'))
+ (if (|> parts
+ (map (: (-> AST Bool)
+ (lambda [part]
+ (case part
+ (^or [_ (#TextS _)] [_ (#SymbolS _)])
+ true
+
+ _
+ false))))
+ (fold (lambda [r l] (and l r)) true))
+ (let [openings (fold (: (-> AST (List Openings) (List Openings))
+ (lambda [part openings]
+ (case part
+ [_ (#TextS prefix)]
+ (list& [prefix (list)] openings)
+
+ [_ (#SymbolS struct-name)]
+ (case openings
+ #Nil
+ (list ["" (list struct-name)])
+
+ (#Cons [prefix structs] openings')
+ (#Cons [prefix (#Cons struct-name structs)] openings'))
+
+ _
+ openings)))
+ (: (List Openings) (list))
+ parts)]
+ (return [openings tokens']))
+ (fail "Expected all parts of opening form to be of either prefix (text) or struct (symbol)."))
+
+ _
+ (return [(list) tokens])))
+
+(def: (parse-short-openings parts)
+ (-> (List AST) (Lux [(List Openings) (List AST)]))
+ (if (|> parts
+ (map (: (-> AST Bool)
+ (lambda [part]
+ (case part
+ (^or [_ (#TextS _)] [_ (#SymbolS _)])
+ true
+
+ _
+ false))))
+ (fold (lambda [r l] (and l r)) true))
+ (let [openings (fold (: (-> AST (List Openings) (List Openings))
+ (lambda [part openings]
+ (case part
+ [_ (#TextS prefix)]
+ (list& [prefix (list)] openings)
+
+ [_ (#SymbolS struct-name)]
+ (case openings
+ #Nil
+ (list ["" (list struct-name)])
+
+ (#Cons [prefix structs] openings')
+ (#Cons [prefix (#Cons struct-name structs)] openings'))
+
+ _
+ openings)))
+ (: (List Openings) (list))
+ parts)]
+ (return [openings (list)]))
+ (fail "Expected all parts of opening form to be of either prefix (text) or struct (symbol).")))
+
+(def: (decorate-sub-importations super-name)
+ (-> Text (List Importation) (List Importation))
+ (map (: (-> Importation Importation)
+ (lambda [importation]
+ (let [{#import-name _name
+ #import-alias _alias
+ #import-refer {#refer-defs _referrals
+ #refer-open _openings}} importation]
+ {#import-name ($_ Text/append super-name "/" _name)
+ #import-alias _alias
+ #import-refer {#refer-defs _referrals
+ #refer-open _openings}})))))
+
+(def: (replace pattern value template)
+ (-> Text Text Text Text)
+ (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value]))
+
+(def: (clean-module module)
+ (-> Text (Lux Text))
+ (do Monad<Lux>
+ [module-name current-module-name]
+ (case (split-module module)
+ (^ (list& "." parts))
+ (return (|> (list& module-name parts) (interpose "/") reverse (fold Text/append "")))
+
+ parts
+ (let [[ups parts'] (split-with (Text/= "..") parts)
+ num-ups (length ups)]
+ (if (i= num-ups 0)
+ (return module)
+ (case (at num-ups (split-module-contexts module-name))
+ #None
+ (fail (Text/append "Can't clean module: " module))
+
+ (#Some top-module)
+ (return (|> (list& top-module parts') (interpose "/") reverse (fold Text/append ""))))
+ )))
+ ))
+
+(def: (parse-imports imports)
+ (-> (List AST) (Lux (List Importation)))
+ (do Monad<Lux>
+ [imports' (mapM Monad<Lux>
+ (: (-> AST (Lux (List Importation)))
+ (lambda [token]
+ (case token
+ [_ (#SymbolS "" m-name)]
+ (do Monad<Lux>
+ [m-name (clean-module m-name)]
+ (wrap (list [m-name #None {#refer-defs #All #refer-open (list)}])))
+
+ (^ [_ (#FormS (list& [_ (#SymbolS "" m-name)] extra))])
+ (do Monad<Lux>
+ [m-name (clean-module m-name)
+ alias+extra (parse-alias extra)
+ #let [[alias extra] alias+extra]
+ referral+extra (parse-referrals extra)
+ #let [[referral extra] referral+extra]
+ openings+extra (parse-openings extra)
+ #let [[openings extra] openings+extra]
+ sub-imports (parse-imports extra)
+ #let [sub-imports (decorate-sub-importations m-name sub-imports)]]
+ (wrap (case [referral alias openings]
+ [#Nothing #None #Nil] sub-imports
+ _ (list& {#import-name m-name
+ #import-alias alias
+ #import-refer {#refer-defs referral
+ #refer-open openings}}
+ sub-imports))))
+
+ (^ [_ (#TupleS (list& [_ (#TextS alias)] [_ (#SymbolS "" m-name)] extra))])
+ (do Monad<Lux>
+ [m-name (clean-module m-name)
+ referral+extra (parse-short-referrals extra)
+ #let [[referral extra] referral+extra]
+ openings+extra (parse-short-openings extra)
+ #let [[openings extra] openings+extra]]
+ (wrap (list {#import-name m-name
+ #import-alias (#;Some (replace ";" m-name alias))
+ #import-refer {#refer-defs referral
+ #refer-open openings}})))
+
+ (^ [_ (#TupleS (list& [_ (#SymbolS "" m-name)] extra))])
+ (do Monad<Lux>
+ [m-name (clean-module m-name)
+ referral+extra (parse-short-referrals extra)
+ #let [[referral extra] referral+extra]
+ openings+extra (parse-short-openings extra)
+ #let [[openings extra] openings+extra]]
+ (wrap (list {#import-name m-name
+ #import-alias (#;Some m-name)
+ #import-refer {#refer-defs referral
+ #refer-open openings}})))
+
+ _
+ (do Monad<Lux>
+ [current-module current-module-name]
+ (fail (Text/append "Wrong syntax for import @ " current-module))))))
+ imports)]
+ (wrap (List/join imports'))))
+
+(def: (exported-defs module state)
+ (-> Text (Lux (List Text)))
+ (let [modules (case state
+ {#info info #source source #modules modules
+ #scopes scopes #type-vars types #host host
+ #seed seed #expected expected #cursor cursor
+ #scope-type-vars scope-type-vars}
+ modules)]
+ (case (get module modules)
+ (#Some =module)
+ (let [to-alias (map (: (-> [Text Def]
+ (List Text))
+ (lambda [[name [def-type def-meta def-value]]]
+ (case [(get-meta ["lux" "export?"] def-meta)
+ (get-meta ["lux" "hidden?"] def-meta)]
+ [(#Some (#BoolM true)) #;None]
+ (list name)
+
+ _
+ (list))))
+ (let [{#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _} =module]
+ defs))]
+ (#Right state (List/join to-alias)))
+
+ #None
+ (#Left ($_ Text/append "Unknown module: " module)))
+ ))
+
+(def: (filter p xs)
+ (All [a] (-> (-> a Bool) (List a) (List a)))
+ (case xs
+ #;Nil
+ (list)
+
+ (#;Cons x xs')
+ (if (p x)
+ (#;Cons x (filter p xs'))
+ (filter p xs'))))
+
+(def: (is-member? cases name)
+ (-> (List Text) Text Bool)
+ (let [output (fold (lambda [case prev]
+ (or prev
+ (Text/= case name)))
+ false
+ cases)]
+ output))
+
+(def: (try-both f x1 x2)
+ (All [a b]
+ (-> (-> a (Maybe b)) a a (Maybe b)))
+ (case (f x1)
+ #;None (f x2)
+ (#;Some y) (#;Some y)))
+
+(def: (find-in-env name state)
+ (-> Text Compiler (Maybe Type))
+ (case state
+ {#info info #source source #modules modules
+ #scopes scopes #type-vars types #host host
+ #seed seed #expected expected #cursor cursor
+ #scope-type-vars scope-type-vars}
+ (find (: (-> Scope (Maybe Type))
+ (lambda [env]
+ (case env
+ {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}}
+ (try-both (find (: (-> [Text Analysis] (Maybe Type))
+ (lambda [[bname [[type _] _]]]
+ (if (Text/= name bname)
+ (#Some type)
+ #None))))
+ locals
+ closure))))
+ scopes)))
+
+(def: (find-def-type name state)
+ (-> Ident Compiler (Maybe Type))
+ (let [[v-prefix v-name] name
+ {#info info #source source #modules modules
+ #scopes scopes #type-vars types #host host
+ #seed seed #expected expected #cursor cursor
+ #scope-type-vars scope-type-vars} state]
+ (case (get v-prefix modules)
+ #None
+ #None
+
+ (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _})
+ (case (get v-name defs)
+ #None
+ #None
+
+ (#Some [def-type def-meta def-value])
+ (#Some def-type)))))
+
+(def: (find-def-value name state)
+ (-> Ident (Lux [Type Unit]))
+ (let [[v-prefix v-name] name
+ {#info info #source source #modules modules
+ #scopes scopes #type-vars types #host host
+ #seed seed #expected expected #cursor cursor
+ #scope-type-vars scope-type-vars} state]
+ (case (get v-prefix modules)
+ #None
+ (#Left (Text/append "Unknown definition: " (Ident->Text name)))
+
+ (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _})
+ (case (get v-name defs)
+ #None
+ (#Left (Text/append "Unknown definition: " (Ident->Text name)))
+
+ (#Some [def-type def-meta def-value])
+ (#Right [state [def-type def-value]])))))
+
+(def: (find-type ident)
+ (-> Ident (Lux Type))
+ (do Monad<Lux>
+ [#let [[module name] ident]
+ current-module current-module-name]
+ (lambda [state]
+ (if (Text/= "" module)
+ (case (find-in-env name state)
+ (#Some struct-type)
+ (#Right state struct-type)
+
+ _
+ (case (find-def-type [current-module name] state)
+ (#Some struct-type)
+ (#Right state struct-type)
+
+ _
+ (#Left ($_ Text/append "Unknown var: " (Ident->Text ident)))))
+ (case (find-def-type ident state)
+ (#Some struct-type)
+ (#Right state struct-type)
+
+ _
+ (#Left ($_ Text/append "Unknown var: " (Ident->Text ident)))))
+ )))
+
+(def: (zip2 xs ys)
+ (All [a b] (-> (List a) (List b) (List [a b])))
+ (case xs
+ (#Cons x xs')
+ (case ys
+ (#Cons y ys')
+ (list& [x y] (zip2 xs' ys'))
+
+ _
+ (list))
+
+ _
+ (list)))
+
+(def: (use-field prefix [module name] type)
+ (-> Text Ident Type (Lux [AST AST]))
+ (do Monad<Lux>
+ [output (resolve-type-tags type)
+ pattern (: (Lux AST)
+ (case output
+ (#Some [tags members])
+ (do Monad<Lux>
+ [slots (mapM Monad<Lux>
+ (: (-> [Ident Type] (Lux [AST AST]))
+ (lambda [[sname stype]] (use-field prefix sname stype)))
+ (zip2 tags members))]
+ (return (record$ slots)))
+
+ #None
+ (return (symbol$ ["" (Text/append prefix name)]))))]
+ (return [(tag$ [module name]) pattern])))
+
+(def: (Type/show type)
+ (-> Type Text)
+ (case type
+ (#HostT name params)
+ (case params
+ #;Nil
+ name
+
+ _
+ ($_ Text/append "(" name " " (|> params (map Type/show) (interpose " ") reverse (fold Text/append "")) ")"))
+
+ #VoidT
+ "Void"
+
+ #UnitT
+ "Unit"
+
+ (#SumT _)
+ ($_ Text/append "(| " (|> (flatten-sum type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")")
+
+ (#ProdT _)
+ ($_ Text/append "[" (|> (flatten-prod type) (map Type/show) (interpose " ") reverse (fold Text/append "")) "]")
+
+ (#LambdaT _)
+ ($_ Text/append "(-> " (|> (flatten-lambda type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")")
+
+ (#BoundT id)
+ (Nat->Text id)
+
+ (#VarT id)
+ ($_ Text/append "⌈v:" (->Text id) "⌋")
+
+ (#ExT id)
+ ($_ Text/append "⟨e:" (->Text id) "⟩")
+
+ (#UnivQ env body)
+ ($_ Text/append "(All " (Type/show body) ")")
+
+ (#ExQ env body)
+ ($_ Text/append "(Ex " (Type/show body) ")")
+
+ (#AppT _)
+ ($_ Text/append "(" (|> (flatten-app type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")")
+
+ (#NamedT [prefix name] _)
+ ($_ Text/append prefix ";" name)
+ ))
+
+(macro: #hidden (^open' tokens)
+ (case tokens
+ (^ (list [_ (#SymbolS name)] [_ (#TextS prefix)] body))
+ (do Monad<Lux>
+ [struct-type (find-type name)
+ output (resolve-type-tags struct-type)]
+ (case output
+ (#Some [tags members])
+ (do Monad<Lux>
+ [slots (mapM Monad<Lux> (: (-> [Ident Type] (Lux [AST AST]))
+ (lambda [[sname stype]] (use-field prefix sname stype)))
+ (zip2 tags members))
+ #let [pattern (record$ slots)]]
+ (return (list (` (;_lux_case (~ (symbol$ name)) (~ pattern) (~ body))))))
+
+ _
+ (fail (Text/append "Can only \"open\" structs: " (Type/show struct-type)))))
+
+ _
+ (fail "Wrong syntax for ^open")))
+
+(macro: #export (^open tokens)
+ {#;doc "## Same as the \"open\" macro, but meant to be used as a pattern-matching macro for generating local bindings.
+ ## Can optionally take a \"prefix\" text for the generated local bindings.
+ (def: #export (range (^open) from to)
+ (All [a] (-> (Enum a) a a (List a)))
+ (range' <= succ from to))"}
+ (case tokens
+ (^ (list& [_ (#FormS (list [_ (#TextS prefix)]))] body branches))
+ (do Monad<Lux>
+ [g!temp (gensym "temp")]
+ (return (list& g!temp (` (^open' (~ g!temp) (~ (text$ prefix)) (~ body))) branches)))
+
+ (^ (list& [_ (#FormS (list))] body branches))
+ (return (list& (` (;;^open "")) body branches))
+
+ _
+ (fail "Wrong syntax for ^open")))
+
+(macro: #export (cond tokens)
+ {#;doc "## Branching structures with multiple test conditions.
+ (cond (even? num) \"even\"
+ (odd? num) \"odd\"
+ ## else-branch
+ \"???\")"}
+ (if (i= 0 (i% (length tokens) 2))
+ (fail "cond requires an even number of arguments.")
+ (case (reverse tokens)
+ (^ (list& else branches'))
+ (return (list (fold (: (-> [AST AST] AST AST)
+ (lambda [branch else]
+ (let [[right left] branch]
+ (` (if (~ left) (~ right) (~ else))))))
+ else
+ (as-pairs branches'))))
+
+ _
+ (fail "Wrong syntax for cond"))))
+
+(def: (enumerate' idx xs)
+ (All [a] (-> Nat (List a) (List [Nat a])))
+ (case xs
+ (#Cons x xs')
+ (#Cons [idx x] (enumerate' (n+ +1 idx) xs'))
+
+ #Nil
+ #Nil))
+
+(def: (enumerate xs)
+ (All [a] (-> (List a) (List [Nat a])))
+ (enumerate' +0 xs))
+
+(macro: #export (get@ tokens)
+ {#;doc "## Accesses the value of a record at a given tag.
+ (get@ #field my-record)
+
+ ## Can also work with multiple levels of nesting:
+ (get@ [#foo #bar #baz] my-record)
+
+ ## And, if only the slot/path is given, generates an
+ ## accessor function:
+ (let [getter (get@ [#foo #bar #baz])]
+ (getter my-record))"}
+ (case tokens
+ (^ (list [_ (#TagS slot')] record))
+ (do Monad<Lux>
+ [slot (normalize slot')
+ output (resolve-tag slot)
+ #let [[idx tags exported? type] output]
+ g!_ (gensym "_")
+ g!output (gensym "")]
+ (case (resolve-struct-type type)
+ (#Some members)
+ (let [pattern (record$ (map (: (-> [Ident [Nat Type]] [AST AST])
+ (lambda [[[r-prefix r-name] [r-idx r-type]]]
+ [(tag$ [r-prefix r-name]) (if (n= idx r-idx)
+ g!output
+ g!_)]))
+ (zip2 tags (enumerate members))))]
+ (return (list (` (;_lux_case (~ record) (~ pattern) (~ g!output))))))
+
+ _
+ (fail "get@ can only use records.")))
+
+ (^ (list [_ (#TupleS slots)] record))
+ (return (list (fold (: (-> AST AST AST)
+ (lambda [slot inner]
+ (` (;;get@ (~ slot) (~ inner)))))
+ record
+ slots)))
+
+ (^ (list selector))
+ (do Monad<Lux>
+ [g!record (gensym "record")]
+ (wrap (list (` (lambda [(~ g!record)] (;;get@ (~ selector) (~ g!record)))))))
+
+ _
+ (fail "Wrong syntax for get@")))
+
+(def: (open-field prefix [module name] source type)
+ (-> Text Ident AST Type (Lux (List AST)))
+ (do Monad<Lux>
+ [output (resolve-type-tags type)
+ #let [source+ (` (get@ (~ (tag$ [module name])) (~ source)))]]
+ (case output
+ (#Some [tags members])
+ (do Monad<Lux>
+ [decls' (mapM Monad<Lux>
+ (: (-> [Ident Type] (Lux (List AST)))
+ (lambda [[sname stype]] (open-field prefix sname source+ stype)))
+ (zip2 tags members))]
+ (return (List/join decls')))
+
+ _
+ (return (list (` (;_lux_def (~ (symbol$ ["" (Text/append prefix name)])) (~ source+)
+ #Nil)))))))
+
+(macro: #export (open tokens)
+ {#;doc "## Opens a structure and generates a definition for each of its members (including nested members).
+ ## For example:
+ (open Number<Int> \"i:\")
+ ## Will generate:
+ (def: i:+ (:: Number<Int> +))
+ (def: i:- (:: Number<Int> -))
+ (def: i:* (:: Number<Int> *))
+ ..."}
+ (case tokens
+ (^ (list& [_ (#SymbolS struct-name)] tokens'))
+ (do Monad<Lux>
+ [@module current-module-name
+ #let [prefix (case tokens'
+ (^ (list [_ (#TextS prefix)]))
+ prefix
+
+ _
+ "")]
+ struct-type (find-type struct-name)
+ output (resolve-type-tags struct-type)
+ #let [source (symbol$ struct-name)]]
+ (case output
+ (#Some [tags members])
+ (do Monad<Lux>
+ [decls' (mapM Monad<Lux> (: (-> [Ident Type] (Lux (List AST)))
+ (lambda [[sname stype]] (open-field prefix sname source stype)))
+ (zip2 tags members))]
+ (return (List/join decls')))
+
+ _
+ (fail (Text/append "Can only \"open\" structs: " (Type/show struct-type)))))
+
+ _
+ (fail "Wrong syntax for open")))
+
+(macro: #export (|>. tokens)
+ {#;doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it.
+ (|> (map ->Text) (interpose \" \") (fold Text/append \"\"))
+ ## =>
+ (lambda [<something>]
+ (fold Text/append \"\"
+ (interpose \" \"
+ (map ->Text <something>))))"}
+ (do Monad<Lux>
+ [g!arg (gensym "arg")]
+ (return (list (` (lambda [(~ g!arg)] (|> (~ g!arg) (~@ tokens))))))))
+
+(def: (imported-by? import-name module-name)
+ (-> Text Text (Lux Bool))
+ (do Monad<Lux>
+ [module (find-module module-name)
+ #let [{#module-hash _ #module-aliases _ #defs _ #imports imports #tags _ #types _ #module-anns _} module]]
+ (wrap (is-member? imports import-name))))
+
+(macro: #export (default tokens state)
+ {#;doc "## Allows you to provide a default value that will be used
+ ## if a (Maybe x) value turns out to be #;Some.
+ (default 20 (#;Some 10)) => 10
+
+ (default 20 #;None) => 20"}
+ (case tokens
+ (^ (list else maybe))
+ (let [g!temp (: AST [["" -1 -1] (#;SymbolS ["" ""])])
+ code (` (case (~ maybe)
+ (#;Some (~ g!temp))
+ (~ g!temp)
+
+ #;None
+ (~ else)))]
+ (#;Right [state (list code)]))
+
+ _
+ (#;Left "Wrong syntax for ?")))
+
+(def: (read-refer module-name options)
+ (-> Text (List AST) (Lux Refer))
+ (do Monad<Lux>
+ [referral+options (parse-referrals options)
+ #let [[referral options] referral+options]
+ openings+options (parse-openings options)
+ #let [[openings options] openings+options]
+ current-module current-module-name
+ #let [test-referrals (: (-> Text (List Text) (List Text) (Lux (List Unit)))
+ (lambda [module-name all-defs referred-defs]
+ (mapM Monad<Lux>
+ (: (-> Text (Lux Unit))
+ (lambda [_def]
+ (if (is-member? all-defs _def)
+ (return [])
+ (fail ($_ Text/append _def " is not defined in module " module-name " @ " current-module)))))
+ referred-defs)))]]
+ (case options
+ #;Nil
+ (wrap {#refer-defs referral
+ #refer-open openings})
+
+ _
+ (fail ($_ Text/append "Wrong syntax for refer @ " current-module
+ "\n" (|> options
+ (map ast-to-text)
+ (interpose " ")
+ (fold Text/append "")))))))
+
+(def: (write-refer module-name [r-defs r-opens])
+ (-> Text Refer (Lux (List AST)))
+ (do Monad<Lux>
+ [current-module current-module-name
+ #let [test-referrals (: (-> Text (List Text) (List Text) (Lux (List Unit)))
+ (lambda [module-name all-defs referred-defs]
+ (mapM Monad<Lux>
+ (: (-> Text (Lux Unit))
+ (lambda [_def]
+ (if (is-member? all-defs _def)
+ (return [])
+ (fail ($_ Text/append _def " is not defined in module " module-name " @ " current-module)))))
+ referred-defs)))]
+ defs' (case r-defs
+ #All
+ (exported-defs module-name)
+
+ (#Only +defs)
+ (do Monad<Lux>
+ [*defs (exported-defs module-name)
+ _ (test-referrals module-name *defs +defs)]
+ (wrap +defs))
+
+ (#Exclude -defs)
+ (do Monad<Lux>
+ [*defs (exported-defs module-name)
+ _ (test-referrals module-name *defs -defs)]
+ (wrap (filter (|>. (is-member? -defs) not) *defs)))
+
+ #Nothing
+ (wrap (list)))
+ #let [defs (map (: (-> Text AST)
+ (lambda [def]
+ (` (;_lux_def (~ (symbol$ ["" def]))
+ (~ (symbol$ [module-name def]))
+ (#Cons [["lux" "alias"] (#IdentM [(~ (text$ module-name)) (~ (text$ def))])]
+ #Nil)))))
+ defs')
+ openings (join-map (: (-> Openings (List AST))
+ (lambda [[prefix structs]]
+ (map (lambda [[_ name]] (` (open (~ (symbol$ [module-name name])) (~ (text$ prefix)))))
+ structs)))
+ r-opens)]]
+ (wrap (List/append defs openings))
+ ))
+
+(macro: #export (refer tokens)
+ (case tokens
+ (^ (list& [_ (#TextS module-name)] options))
+ (do Monad<Lux>
+ [=refer (read-refer module-name options)]
+ (write-refer module-name =refer))
+
+ _
+ (fail "Wrong syntax for refer")))
+
+(def: (refer-to-ast module-name [r-defs r-opens])
+ (-> Text Refer AST)
+ (let [=defs (: (List AST)
+ (case r-defs
+ #All
+ (list (' #refer) (' #all))
+
+ (#Only defs)
+ (list (' #refer) (`' (#only (~@ (map (|>. [""] symbol$)
+ defs)))))
+
+ (#Exclude defs)
+ (list (' #refer) (`' (#exclude (~@ (map (|>. [""] symbol$)
+ defs)))))
+
+ #Nothing
+ (list)))
+ =opens (join-map (lambda [[prefix structs]]
+ (list& (text$ prefix) (map symbol$ structs)))
+ r-opens)]
+ (` (;;refer (~ (text$ module-name))
+ (~@ =defs)
+ (~' #open) ((~@ =opens))))))
+
+(macro: #export (module: tokens)
+ {#;doc "## Examples
+ (;module: {#;doc \"Some documentation...\"}
+ lux
+ (lux (control (monad #as M #refer #all))
+ (data (text #open (\"Text/\" Monoid<Text>))
+ (struct (list #open (\"List/\" Monad<List>)))
+ maybe
+ (ident #open (\"Ident/\" Codec<Text,Ident>)))
+ meta
+ (macro ast))
+ (.. (type #open (\"\" Eq<Type>))))
+
+ (;module: {#;doc \"Some documentation...\"}
+ lux
+ (lux (control [\"M\" monad #*])
+ (data [text \"Text/\" Monoid<Text>]
+ (struct [list \"List/\" Monad<List>])
+ maybe
+ [ident \"Ident/\" Codec<Text,Ident>])
+ meta
+ (macro ast))
+ (.. [type \"\" Eq<Type>]))"}
+ (do Monad<Lux>
+ [#let [[_meta _imports] (: [(List [AST AST]) (List AST)]
+ (case tokens
+ (^ (list& [_ (#RecordS _meta)] _imports))
+ [_meta _imports]
+
+ _
+ [(list) tokens]))]
+ imports (parse-imports _imports)
+ #let [=imports (map (: (-> Importation AST)
+ (lambda [[m-name m-alias =refer]]
+ (` [(~ (text$ m-name)) (~ (text$ (default "" m-alias)))])))
+ imports)
+ =refers (map (: (-> Importation AST)
+ (lambda [[m-name m-alias =refer]]
+ (refer-to-ast m-name =refer)))
+ imports)]
+ =meta (process-def-meta (record$ (list& [(` #;imports) (` [(~@ =imports)])]
+ _meta)))
+ #let [=module (` (;_lux_module (~ =meta)))]]
+ (wrap (#;Cons =module =refers))))
+
+(macro: #export (:: tokens)
+ {#;doc "## Allows accessing the value of a structure's member.
+ (:: Codec<Text,Int> encode)
+
+ ## Also allows using that value as a function.
+ (:: Codec<Text,Int> encode 123)"}
+ (case tokens
+ (^ (list struct [_ (#SymbolS member)]))
+ (return (list (` (let [(^open) (~ struct)] (~ (symbol$ member))))))
+
+ (^ (list& struct [_ (#SymbolS member)] args))
+ (return (list (` ((let [(^open) (~ struct)] (~ (symbol$ member))) (~@ args)))))
+
+ _
+ (fail "Wrong syntax for ::")))
+
+(macro: #export (set@ tokens)
+ {#;doc "## Sets the value of a record at a given tag.
+ (set@ #name \"Lux\" lang)
+
+ ## Can also work with multiple levels of nesting:
+ (set@ [#foo #bar #baz] value my-record)
+
+ ## And, if only the slot/path and (optionally) the value are given, generates a
+ ## mutator function:
+ (let [setter (set@ [#foo #bar #baz] value)]
+ (setter my-record))
+
+ (let [setter (set@ [#foo #bar #baz])]
+ (setter value my-record))"}
+ (case tokens
+ (^ (list [_ (#TagS slot')] value record))
+ (do Monad<Lux>
+ [slot (normalize slot')
+ output (resolve-tag slot)
+ #let [[idx tags exported? type] output]]
+ (case (resolve-struct-type type)
+ (#Some members)
+ (do Monad<Lux>
+ [pattern' (mapM Monad<Lux>
+ (: (-> [Ident [Nat Type]] (Lux [Ident Nat AST]))
+ (lambda [[r-slot-name [r-idx r-type]]]
+ (do Monad<Lux>
+ [g!slot (gensym "")]
+ (return [r-slot-name r-idx g!slot]))))
+ (zip2 tags (enumerate members)))]
+ (let [pattern (record$ (map (: (-> [Ident Nat AST] [AST AST])
+ (lambda [[r-slot-name r-idx r-var]]
+ [(tag$ r-slot-name) r-var]))
+ pattern'))
+ output (record$ (map (: (-> [Ident Nat AST] [AST AST])
+ (lambda [[r-slot-name r-idx r-var]]
+ [(tag$ r-slot-name) (if (n= idx r-idx)
+ value
+ r-var)]))
+ pattern'))]
+ (return (list (` (;_lux_case (~ record) (~ pattern) (~ output)))))))
+
+ _
+ (fail "set@ can only use records.")))
+
+ (^ (list [_ (#TupleS slots)] value record))
+ (case slots
+ #;Nil
+ (fail "Wrong syntax for set@")
+
+ _
+ (do Monad<Lux>
+ [bindings (mapM Monad<Lux>
+ (: (-> AST (Lux AST))
+ (lambda [_] (gensym "temp")))
+ slots)
+ #let [pairs (zip2 slots bindings)
+ update-expr (fold (: (-> [AST AST] AST AST)
+ (lambda [[s b] v]
+ (` (;;set@ (~ s) (~ v) (~ b)))))
+ value
+ (reverse pairs))
+ [_ accesses'] (fold (: (-> [AST AST] [AST (List (List AST))] [AST (List (List AST))])
+ (lambda [[new-slot new-binding] [old-record accesses']]
+ [(` (get@ (~ new-slot) (~ new-binding)))
+ (#;Cons (list new-binding old-record) accesses')]))
+ [record (: (List (List AST)) #;Nil)]
+ pairs)
+ accesses (List/join (reverse accesses'))]]
+ (wrap (list (` (let [(~@ accesses)]
+ (~ update-expr)))))))
+
+ (^ (list selector value))
+ (do Monad<Lux>
+ [g!record (gensym "record")]
+ (wrap (list (` (lambda [(~ g!record)] (;;set@ (~ selector) (~ value) (~ g!record)))))))
+
+ (^ (list selector))
+ (do Monad<Lux>
+ [g!value (gensym "value")
+ g!record (gensym "record")]
+ (wrap (list (` (lambda [(~ g!value) (~ g!record)] (;;set@ (~ selector) (~ g!value) (~ g!record)))))))
+
+ _
+ (fail "Wrong syntax for set@")))
+
+(macro: #export (update@ tokens)
+ {#;doc "## Modifies the value of a record at a given tag, based on some function.
+ (update@ #age inc person)
+
+ ## Can also work with multiple levels of nesting:
+ (update@ [#foo #bar #baz] func my-record)
+
+ ## And, if only the slot/path and (optionally) the value are given, generates a
+ ## mutator function:
+ (let [updater (update@ [#foo #bar #baz] func)]
+ (updater my-record))
+
+ (let [updater (update@ [#foo #bar #baz])]
+ (updater func my-record))"}
+ (case tokens
+ (^ (list [_ (#TagS slot')] fun record))
+ (do Monad<Lux>
+ [slot (normalize slot')
+ output (resolve-tag slot)
+ #let [[idx tags exported? type] output]]
+ (case (resolve-struct-type type)
+ (#Some members)
+ (do Monad<Lux>
+ [pattern' (mapM Monad<Lux>
+ (: (-> [Ident [Nat Type]] (Lux [Ident Nat AST]))
+ (lambda [[r-slot-name [r-idx r-type]]]
+ (do Monad<Lux>
+ [g!slot (gensym "")]
+ (return [r-slot-name r-idx g!slot]))))
+ (zip2 tags (enumerate members)))]
+ (let [pattern (record$ (map (: (-> [Ident Nat AST] [AST AST])
+ (lambda [[r-slot-name r-idx r-var]]
+ [(tag$ r-slot-name) r-var]))
+ pattern'))
+ output (record$ (map (: (-> [Ident Nat AST] [AST AST])
+ (lambda [[r-slot-name r-idx r-var]]
+ [(tag$ r-slot-name) (if (n= idx r-idx)
+ (` ((~ fun) (~ r-var)))
+ r-var)]))
+ pattern'))]
+ (return (list (` (;_lux_case (~ record) (~ pattern) (~ output)))))))
+
+ _
+ (fail "update@ can only use records.")))
+
+ (^ (list [_ (#TupleS slots)] fun record))
+ (case slots
+ #;Nil
+ (fail "Wrong syntax for update@")
+
+ _
+ (do Monad<Lux>
+ [g!record (gensym "record")
+ g!temp (gensym "temp")]
+ (wrap (list (` (let [(~ g!record) (~ record)
+ (~ g!temp) (get@ [(~@ slots)] (~ g!record))]
+ (set@ [(~@ slots)] ((~ fun) (~ g!temp)) (~ g!record))))))))
+
+ (^ (list selector fun))
+ (do Monad<Lux>
+ [g!record (gensym "record")]
+ (wrap (list (` (lambda [(~ g!record)] (;;update@ (~ selector) (~ fun) (~ g!record)))))))
+
+ (^ (list selector))
+ (do Monad<Lux>
+ [g!fun (gensym "fun")
+ g!record (gensym "record")]
+ (wrap (list (` (lambda [(~ g!fun) (~ g!record)] (;;update@ (~ selector) (~ g!fun) (~ g!record)))))))
+
+ _
+ (fail "Wrong syntax for update@")))
+
+(macro: #export (^template tokens)
+ {#;doc "## It's similar to do-template, but meant to be used during pattern-matching.
+ (def: (beta-reduce env type)
+ (-> (List Type) Type Type)
+ (case type
+ (#;HostT name params)
+ (#;HostT name (List/map (beta-reduce env) params))
+
+ (^template [<tag>]
+ (<tag> left right)
+ (<tag> (beta-reduce env left) (beta-reduce env right)))
+ ([#;SumT] [#;ProdT])
+
+ (^template [<tag>]
+ (<tag> left right)
+ (<tag> (beta-reduce env left) (beta-reduce env right)))
+ ([#;LambdaT]
+ [#;AppT])
+
+ (^template [<tag>]
+ (<tag> old-env def)
+ (case old-env
+ #;Nil
+ (<tag> env def)
+
+ _
+ type))
+ ([#;UnivQ]
+ [#;ExQ])
+
+ (#;BoundT idx)
+ (default type (list;at idx env))
+
+ (#;NamedT name type)
+ (beta-reduce env type)
+
+ _
+ type
+ ))"}
+ (case tokens
+ (^ (list& [_ (#FormS (list& [_ (#TupleS bindings)] templates))]
+ [_ (#FormS data)]
+ branches))
+ (case (: (Maybe (List AST))
+ (do Monad<Maybe>
+ [bindings' (mapM Monad<Maybe> get-name bindings)
+ data' (mapM Monad<Maybe> tuple->list data)]
+ (if (every? (i= (length bindings')) (map length data'))
+ (let [apply (: (-> RepEnv (List AST))
+ (lambda [env] (map (apply-template env) templates)))]
+ (|> data'
+ (join-map (. apply (make-env bindings')))
+ wrap))
+ #;None)))
+ (#Some output)
+ (return (List/append output branches))
+
+ #None
+ (fail "Wrong syntax for ^template"))
+
+ _
+ (fail "Wrong syntax for ^template")))
+
+(do-template [<name> <from> <to> <converter>]
+ [(def: #export (<name> n)
+ (-> <from> <to>)
+ (_lux_proc ["jvm" <converter>] [n]))]
+
+ [real-to-int Real Int "d2l"]
+ [int-to-real Int Real "l2d"]
+ )
+
+(do-template [<type> <category> <=-name> <=> <lt-name> <lte-name> <lt> <gt-name> <gte-name>
+ <eq-doc> <<-doc> <<=-doc> <>-doc> <>=-doc>]
+ [(def: #export (<=-name> test subject)
+ {#;doc <eq-doc>}
+ (-> <type> <type> Bool)
+ (_lux_proc [<category> <=>] [subject test]))
+
+ (def: #export (<lt-name> test subject)
+ {#;doc <<-doc>}
+ (-> <type> <type> Bool)
+ (_lux_proc [<category> <lt>] [subject test]))
+
+ (def: #export (<lte-name> test subject)
+ {#;doc <<=-doc>}
+ (-> <type> <type> Bool)
+ (or (_lux_proc [<category> <lt>] [subject test])
+ (_lux_proc [<category> <=>] [subject test])))
+
+ (def: #export (<gt-name> test subject)
+ {#;doc <>-doc>}
+ (-> <type> <type> Bool)
+ (_lux_proc [<category> <lt>] [test subject]))
+
+ (def: #export (<gte-name> test subject)
+ {#;doc <>=-doc>}
+ (-> <type> <type> Bool)
+ (or (_lux_proc [<category> <lt>] [test subject])
+ (_lux_proc [<category> <=>] [subject test])))]
+
+ [ Nat "nat" =+ "=" <+ <=+ "<" >+ >=+
+ "Natural equality." "Natural less-than." "Natural less-than-equal." "Natural greater-than." "Natural greater-than-equal."]
+
+ [ Int "jvm" = "leq" < <= "llt" > >=
+ "Integer equality." "Integer less-than." "Integer less-than-equal." "Integer greater-than." "Integer greater-than-equal."]
+
+ [Frac "frac" =.. "=" <.. <=.. "<" >.. >=..
+ "Fractional equality." "Fractional less-than." "Fractional less-than-equal." "Fractional greater-than." "Fractional greater-than-equal."]
+
+ [Real "jvm" =. "deq" <. <=. "dlt" >. >=.
+ "Real equality." "Real less-than." "Real less-than-equal." "Real greater-than." "Real greater-than-equal."]
+ )
+
+(do-template [<type> <name> <op> <doc>]
+ [(def: #export (<name> param subject)
+ {#;doc <doc>}
+ (-> <type> <type> <type>)
+ (_lux_proc <op> [subject param]))]
+
+ [ Nat ++ ["nat" "+"] "Nat(ural) addition."]
+ [ Nat -+ ["nat" "-"] "Nat(ural) substraction."]
+ [ Nat *+ ["nat" "*"] "Nat(ural) multiplication."]
+ [ Nat /+ ["nat" "/"] "Nat(ural) division."]
+ [ Nat %+ ["nat" "%"] "Nat(ural) remainder."]
+
+ [ Int + ["jvm" "ladd"] "Int(eger) addition."]
+ [ Int - ["jvm" "lsub"] "Int(eger) substraction."]
+ [ Int * ["jvm" "lmul"] "Int(eger) multiplication."]
+ [ Int / ["jvm" "ldiv"] "Int(eger) division."]
+ [ Int % ["jvm" "lrem"] "Int(eger) remainder."]
+
+ [Frac +.. ["frac" "+"] "Frac(tional) addition."]
+ [Frac -.. ["frac" "-"] "Frac(tional) substraction."]
+ [Frac *.. ["frac" "*"] "Frac(tional) multiplication."]
+ [Frac /.. ["frac" "/"] "Frac(tional) division."]
+ [Frac %.. ["frac" "%"] "Frac(tional) remainder."]
+
+ [Real +. ["jvm" "dadd"] "Real addition."]
+ [Real -. ["jvm" "dsub"] "Real substraction."]
+ [Real *. ["jvm" "dmul"] "Real multiplication."]
+ [Real /. ["jvm" "ddiv"] "Real division."]
+ [Real %. ["jvm" "drem"] "Real remainder."]
+ )
+
+(do-template [<name> <type> <test> <doc>]
+ [(def: #export (<name> left right)
+ {#;doc <doc>}
+ (-> <type> <type> <type>)
+ (if (<test> right left)
+ left
+ right))]
+
+ [min+ Nat <+ "Nat(ural) minimum."]
+ [max+ Nat >+ "Nat(ural) maximum."]
+
+ [min Int < "Int(eger) minimum."]
+ [max Int > "Int(eger) maximum."]
+
+ [min.. Frac <.. "Frac(tional) minimum."]
+ [max.. Frac >.. "Frac(tional) maximum."]
+
+ [min. Real <. "Real minimum."]
+ [max. Real >. "Real minimum."]
+ )
+
+(def: (find-baseline-column ast)
+ (-> AST Int)
+ (case ast
+ (^template [<tag>]
+ [[_ _ column] (<tag> _)]
+ column)
+ ([#BoolS]
+ [#NatS]
+ [#IntS]
+ [#FracS]
+ [#RealS]
+ [#CharS]
+ [#TextS]
+ [#SymbolS]
+ [#TagS])
+
+ (^template [<tag>]
+ [[_ _ column] (<tag> parts)]
+ (fold min column (map find-baseline-column parts)))
+ ([#FormS]
+ [#TupleS])
+
+ [[_ _ column] (#RecordS pairs)]
+ (fold min column
+ (List/append (map (. find-baseline-column first) pairs)
+ (map (. find-baseline-column second) pairs)))
+ ))
+
+(type: Doc-Fragment
+ (#Doc-Comment Text)
+ (#Doc-Example AST))
+
+(def: (identify-doc-fragment ast)
+ (-> AST Doc-Fragment)
+ (case ast
+ [_ (#;TextS comment)]
+ (#Doc-Comment comment)
+
+ _
+ (#Doc-Example ast)))
+
+(def: (Char/encode x)
+ (-> Char Text)
+ (let [as-text (case x
+ #"\t" "\\t"
+ #"\b" "\\b"
+ #"\n" "\\n"
+ #"\r" "\\r"
+ #"\f" "\\f"
+ #"\"" "\\\""
+ #"\\" "\\\\"
+ _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))]
+ ($_ Text/append "#\"" as-text "\"")))
+
+(def: (Text/encode original)
+ (-> Text Text)
+ (let [escaped (|> original
+ (replace "\t" "\\t")
+ (replace "\b" "\\b")
+ (replace "\n" "\\n")
+ (replace "\r" "\\r")
+ (replace "\f" "\\f")
+ (replace "\"" "\\\"")
+ (replace "\\" "\\\\")
+ )]
+ ($_ Text/append "\"" escaped "\"")))
+
+(do-template [<name> <diff>]
+ [(def: #export <name>
+ (-> Int Int)
+ (i+ <diff>))]
+
+ [inc 1]
+ [dec -1])
+
+(def: tag->Text
+ (-> Ident Text)
+ (. (Text/append "#") Ident->Text))
+
+(def: (repeat n x)
+ (All [a] (-> Int a (List a)))
+ (if (i> n 0)
+ (#;Cons x (repeat (i+ -1 n) x))
+ #;Nil))
+
+(def: (cursor-padding baseline [_ old-line old-column] [_ new-line new-column])
+ (-> Int Cursor Cursor Text)
+ (if (i= old-line new-line)
+ (Text/join (repeat (i- new-column old-column) " "))
+ (let [extra-lines (Text/join (repeat (i- new-line old-line) "\n"))
+ space-padding (Text/join (repeat (i- new-column baseline) " "))]
+ (Text/append extra-lines space-padding))))
+
+(def: (Text/size x)
+ (-> Text Int)
+ (_lux_proc ["jvm" "i2l"]
+ [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])]))
+
+(def: (Text/trim x)
+ (-> Text Text)
+ (_lux_proc ["jvm" "invokevirtual:java.lang.String:trim:"] [x]))
+
+(def: (update-cursor [file line column] ast-text)
+ (-> Cursor Text Cursor)
+ [file line (i+ column (Text/size ast-text))])
+
+(def: (delim-update-cursor [file line column])
+ (-> Cursor Cursor)
+ [file line (inc column)])
+
+(def: rejoin-all-pairs
+ (-> (List [AST AST]) (List AST))
+ (. List/join (map rejoin-pair)))
+
+(def: (doc-example->Text prev-cursor baseline example)
+ (-> Cursor Int AST [Cursor Text])
+ (case example
+ (^template [<tag> <show>]
+ [new-cursor (<tag> value)]
+ (let [as-text (<show> value)]
+ [(update-cursor new-cursor as-text)
+ (Text/append (cursor-padding baseline prev-cursor new-cursor)
+ as-text)]))
+ ([#BoolS ->Text]
+ [#NatS Nat->Text]
+ [#IntS ->Text]
+ [#FracS Frac->Text]
+ [#RealS ->Text]
+ [#CharS Char/encode]
+ [#TextS Text/encode]
+ [#SymbolS Ident->Text]
+ [#TagS tag->Text])
+
+ (^template [<tag> <open> <close> <prep>]
+ [group-cursor (<tag> parts)]
+ (let [[group-cursor' parts-text] (fold (lambda [part [last-cursor text-accum]]
+ (let [[part-cursor part-text] (doc-example->Text last-cursor baseline part)]
+ [part-cursor (Text/append text-accum part-text)]))
+ [(delim-update-cursor group-cursor) ""]
+ (<prep> parts))]
+ [(delim-update-cursor group-cursor')
+ ($_ Text/append (cursor-padding baseline prev-cursor group-cursor)
+ <open>
+ parts-text
+ <close>)]))
+ ([#FormS "(" ")" id]
+ [#TupleS "[" "]" id]
+ [#RecordS "{" "}" rejoin-all-pairs])
+ ))
+
+(def: (with-baseline baseline [file line column])
+ (-> Int Cursor Cursor)
+ [file line baseline])
+
+(def: (doc-fragment->Text fragment)
+ (-> Doc-Fragment Text)
+ (case fragment
+ (#Doc-Comment comment)
+ (|> comment
+ (split-text "\n")
+ (map (lambda [line] ($_ Text/append "## " line "\n")))
+ Text/join)
+
+ (#Doc-Example example)
+ (let [baseline (find-baseline-column example)
+ [cursor _] example
+ [_ text] (doc-example->Text (with-baseline baseline cursor) baseline example)]
+ (Text/append text "\n\n"))))
+
+(macro: #export (doc tokens)
+ {#;doc "Creates code documentation, embedding text as comments and properly formatting the forms it's being given.
+
+ ## For Example:
+ (doc
+ \"Allows arbitrary looping, using the \\\"recur\\\" form to re-start the loop.
+ Can be used in monadic code to create monadic loops.\"
+ (loop [count 0
+ x init]
+ (if (< 10 count)
+ (recur (inc count) (f x))
+ x)))"}
+ (return (list (` (#;TextM (~ (|> tokens
+ (map (. doc-fragment->Text identify-doc-fragment))
+ Text/join
+ Text/trim
+ text$)))))))
+
+(def: (interleave xs ys)
+ (All [a] (-> (List a) (List a) (List a)))
+ (case xs
+ #Nil
+ #Nil
+
+ (#Cons x xs')
+ (case ys
+ #Nil
+ #Nil
+
+ (#Cons y ys')
+ (list& x y (interleave xs' ys')))))
+
+(def: (type->ast type)
+ (-> Type AST)
+ (case type
+ (#HostT name params)
+ (` (#HostT (~ (text$ name)) (~ (untemplate-list (map type->ast params)))))
+
+ #VoidT
+ (` #VoidT)
+
+ #UnitT
+ (` #UnitT)
+
+ (^template [<tag>]
+ (<tag> left right)
+ (` (<tag> (~ (type->ast left)) (~ (type->ast right)))))
+ ([#SumT] [#ProdT])
+
+ (#LambdaT in out)
+ (` (#LambdaT (~ (type->ast in)) (~ (type->ast out))))
+
+ (#BoundT idx)
+ (` (#BoundT (~ (nat$ idx))))
+
+ (#VarT id)
+ (` (#VarT (~ (nat$ id))))
+
+ (#ExT id)
+ (` (#ExT (~ (nat$ id))))
+
+ (#UnivQ env type)
+ (let [env' (untemplate-list (map type->ast env))]
+ (` (#UnivQ (~ env') (~ (type->ast type)))))
+
+ (#ExQ env type)
+ (let [env' (untemplate-list (map type->ast env))]
+ (` (#ExQ (~ env') (~ (type->ast type)))))
+
+ (#AppT fun arg)
+ (` (#AppT (~ (type->ast fun)) (~ (type->ast arg))))
+
+ (#NamedT [module name] type)
+ (` (#NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->ast type))))
+ ))
+
+(macro: #export (loop tokens)
+ {#;doc (doc "Allows arbitrary looping, using the \"recur\" form to re-start the loop."
+ "Can be used in monadic code to create monadic loops."
+ (loop [count 0
+ x init]
+ (if (< 10 count)
+ (recur (inc count) (f x))
+ x)))}
+ (case tokens
+ (^ (list [_ (#TupleS bindings)] body))
+ (let [pairs (as-pairs bindings)
+ vars (map first pairs)
+ inits (map second pairs)]
+ (if (every? symbol? inits)
+ (do Monad<Lux>
+ [inits' (: (Lux (List Ident))
+ (case (mapM Monad<Maybe> get-ident inits)
+ (#Some inits') (return inits')
+ #None (fail "Wrong syntax for loop")))
+ init-types (mapM Monad<Lux> find-type inits')
+ expected get-expected-type]
+ (return (list (` ((;_lux_: (-> (~@ (map type->ast init-types))
+ (~ (type->ast expected)))
+ (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)]
+ (~ body)))
+ (~@ inits))))))
+ (do Monad<Lux>
+ [aliases (mapM Monad<Lux>
+ (: (-> AST (Lux AST))
+ (lambda [_] (gensym "")))
+ inits)]
+ (return (list (` (let [(~@ (interleave aliases inits))]
+ (;loop [(~@ (interleave vars aliases))]
+ (~ body)))))))))
+
+ _
+ (fail "Wrong syntax for loop")))
+
+(macro: #export (^slots tokens)
+ {#;doc (doc "Allows you to extract record members as local variables with the same names."
+ "For example:"
+ (let [(^slots [#foo #bar #baz]) quux]
+ (f foo bar baz)))}
+ (case tokens
+ (^ (list& [_ (#FormS (list [_ (#TupleS (list& hslot' tslots'))]))] body branches))
+ (do Monad<Lux>
+ [slots (: (Lux [Ident (List Ident)])
+ (case (: (Maybe [Ident (List Ident)])
+ (do Monad<Maybe>
+ [hslot (get-tag hslot')
+ tslots (mapM Monad<Maybe> get-tag tslots')]
+ (wrap [hslot tslots])))
+ (#Some slots)
+ (return slots)
+
+ #None
+ (fail "Wrong syntax for ^slots")))
+ #let [[hslot tslots] slots]
+ hslot (normalize hslot)
+ tslots (mapM Monad<Lux> normalize tslots)
+ output (resolve-tag hslot)
+ g!_ (gensym "_")
+ #let [[idx tags exported? type] output
+ slot-pairings (map (: (-> Ident [Text AST])
+ (lambda [[module name]] [name (symbol$ ["" name])]))
+ (list& hslot tslots))
+ pattern (record$ (map (: (-> Ident [AST AST])
+ (lambda [[module name]]
+ (let [tag (tag$ [module name])]
+ (case (get name slot-pairings)
+ (#Some binding) [tag binding]
+ #None [tag g!_]))))
+ tags))]]
+ (return (list& pattern body branches)))
+
+ _
+ (fail "Wrong syntax for ^slots")))
+
+(def: (place-tokens label tokens target)
+ (-> Text (List AST) AST (Maybe (List AST)))
+ (case target
+ (^or [_ (#BoolS _)] [_ (#NatS _)] [_ (#IntS _)] [_ (#FracS _)] [_ (#RealS _)] [_ (#CharS _)] [_ (#TextS _)] [_ (#TagS _)])
+ (#Some (list target))
+
+ [_ (#SymbolS [prefix name])]
+ (if (and (Text/= "" prefix)
+ (Text/= label name))
+ (#Some tokens)
+ (#Some (list target)))
+
+ (^template [<tag> <ctor>]
+ [_ (<tag> elems)]
+ (do Monad<Maybe>
+ [placements (mapM Monad<Maybe> (place-tokens label tokens) elems)]
+ (wrap (list (<ctor> (List/join placements))))))
+ ([#TupleS tuple$]
+ [#FormS form$])
+
+ [_ (#RecordS pairs)]
+ (do Monad<Maybe>
+ [=pairs (mapM Monad<Maybe>
+ (: (-> [AST AST] (Maybe [AST AST]))
+ (lambda [[slot value]]
+ (do Monad<Maybe>
+ [slot' (place-tokens label tokens slot)
+ value' (place-tokens label tokens value)]
+ (case [slot' value']
+ (^ [(list =slot) (list =value)])
+ (wrap [=slot =value])
+
+ _
+ #None))))
+ pairs)]
+ (wrap (list (record$ =pairs))))
+ ))
+
+(macro: #export (let% tokens)
+ {#;doc (doc "Controlled macro-expansion."
+ "Bind an arbitraty number of ASTs resulting from macro-expansion to local bindings."
+ "Wherever a binding appears, the bound ASTs will be spliced in there."
+ (test: "AST operations & structures"
+ (let% [<tests> (do-template [<expr> <text> <pattern>]
+ [(compare <pattern> <expr>)
+ (compare <text> (:: AST/Show show <expr>))
+ (compare true (:: Eq<AST> = <expr> <expr>))]
+
+ [(bool true) "true" [["" -1 -1] (#;BoolS true)]]
+ [(bool false) "false" [_ (#;BoolS false)]]
+ [(int 123) "123" [_ (#;IntS 123)]]
+ [(real 123.0) "123.0" [_ (#;RealS 123.0)]]
+ [(char #"\n") "#\"\\n\"" [_ (#;CharS #"\n")]]
+ [(text "\n") "\"\\n\"" [_ (#;TextS "\n")]]
+ [(tag ["yolo" "lol"]) "#yolo;lol" [_ (#;TagS ["yolo" "lol"])]]
+ [(symbol ["yolo" "lol"]) "yolo;lol" [_ (#;SymbolS ["yolo" "lol"])]]
+ [(form (list (bool true) (int 123))) "(true 123)" (^ [_ (#;FormS (list [_ (#;BoolS true)] [_ (#;IntS 123)]))])]
+ [(tuple (list (bool true) (int 123))) "[true 123]" (^ [_ (#;TupleS (list [_ (#;BoolS true)] [_ (#;IntS 123)]))])]
+ [(record (list [(bool true) (int 123)])) "{true 123}" (^ [_ (#;RecordS (list [[_ (#;BoolS true)] [_ (#;IntS 123)]]))])]
+ [(local-tag "lol") "#lol" [_ (#;TagS ["" "lol"])]]
+ [(local-symbol "lol") "lol" [_ (#;SymbolS ["" "lol"])]]
+ )]
+ (test-all <tests>))))}
+ (case tokens
+ (^ (list& [_ (#TupleS bindings)] bodies))
+ (case bindings
+ (^ (list& [_ (#SymbolS ["" var-name])] macro-expr bindings'))
+ (do Monad<Lux>
+ [expansion (macro-expand-once macro-expr)]
+ (case (place-tokens var-name expansion (` (;let% [(~@ bindings')] (~@ bodies))))
+ (#Some output)
+ (wrap output)
+
+ _
+ (fail "[let%] Improper macro expansion.")))
+
+ #Nil
+ (return bodies)
+
+ _
+ (fail "Wrong syntax for let%"))
+
+ _
+ (fail "Wrong syntax for let%")))
+
+(def: (flatten-alias type)
+ (-> Type Type)
+ (case type
+ (^template [<name>]
+ (#NamedT ["lux" <name>] _)
+ type)
+ (["Bool"]
+ ["Nat"]
+ ["Int"]
+ ["Frac"]
+ ["Real"]
+ ["Char"]
+ ["Text"])
+
+ (#NamedT _ type')
+ type'
+
+ _
+ type))
+
+(def: (anti-quote-def name)
+ (-> Ident (Lux AST))
+ (do Monad<Lux>
+ [type+value (find-def-value name)
+ #let [[type value] type+value]]
+ (case (flatten-alias type)
+ (^template [<name> <type> <wrapper>]
+ (#NamedT ["lux" <name>] _)
+ (wrap (<wrapper> (:! <type> value))))
+ (["Bool" Bool bool$]
+ ["Nat" Nat nat$]
+ ["Int" Int int$]
+ ["Frac" Frac frac$]
+ ["Real" Real real$]
+ ["Char" Char char$]
+ ["Text" Text text$])
+
+ _
+ (fail (Text/append "Can't anti-quote type: " (Ident->Text name))))))
+
+(def: (anti-quote token)
+ (-> AST (Lux AST))
+ (case token
+ [_ (#SymbolS [def-prefix def-name])]
+ (if (Text/= "" def-prefix)
+ (:: Monad<Lux> return token)
+ (anti-quote-def [def-prefix def-name]))
+
+ (^template [<tag>]
+ [meta (<tag> parts)]
+ (do Monad<Lux>
+ [=parts (mapM Monad<Lux> anti-quote parts)]
+ (wrap [meta (<tag> =parts)])))
+ ([#FormS]
+ [#TupleS])
+
+ [meta (#RecordS pairs)]
+ (do Monad<Lux>
+ [=pairs (mapM Monad<Lux>
+ (: (-> [AST AST] (Lux [AST AST]))
+ (lambda [[slot value]]
+ (do Monad<Lux>
+ [=value (anti-quote value)]
+ (wrap [slot =value]))))
+ pairs)]
+ (wrap [meta (#RecordS =pairs)]))
+
+ _
+ (:: Monad<Lux> return token)
+ ))
+
+(macro: #export (^~ tokens)
+ {#;doc (doc "Use global defs with simple values, such as text, int, real, bool and char, in place of literals in patterns."
+ "The definitions must be properly-qualified (though you may use one of the short-cuts Lux provides)."
+ (def: (empty?' node)
+ (All [K V] (-> (Node K V) Bool))
+ (case node
+ (^~ (#Base ;;clean-bitmap _))
+ true
+
+ _
+ false)))}
+ (case tokens
+ (^ (list& [_ (#FormS (list pattern))] body branches))
+ (do Monad<Lux>
+ [module-name current-module-name
+ pattern+ (macro-expand-all pattern)]
+ (case pattern+
+ (^ (list pattern'))
+ (do Monad<Lux>
+ [pattern'' (anti-quote pattern')]
+ (wrap (list& pattern'' body branches)))
+
+ _
+ (fail "^~ can only expand to 1 pattern.")))
+
+ _
+ (fail "Wrong syntax for ^~")))
+
+(type: MultiLevelCase
+ [AST (List [AST AST])])
+
+(def: (case-level^ level)
+ (-> AST (Lux [AST AST]))
+ (case level
+ (^ [_ (#;RecordS (list [expr binding]))])
+ (return [expr binding])
+
+ _
+ (return [level (` true)])
+ ))
+
+(def: (multi-level-case^ levels)
+ (-> (List AST) (Lux MultiLevelCase))
+ (case levels
+ #;Nil
+ (fail "Multi-level patterns can't be empty.")
+
+ (#;Cons init extras)
+ (do Monad<Lux>
+ [extras' (mapM Monad<Lux> case-level^ extras)]
+ (wrap [init extras']))))
+
+(def: (multi-level-case$ g!_ [[init-pattern levels] body])
+ (-> AST [MultiLevelCase AST] (List AST))
+ (let [inner-pattern-body (fold (lambda [[calculation pattern] success]
+ (` (case (~ calculation)
+ (~ pattern)
+ (~ success)
+
+ (~ g!_)
+ #;None)))
+ (` (#;Some (~ body)))
+ (: (List [AST AST]) (reverse levels)))]
+ (list init-pattern inner-pattern-body)))
+
+(macro: #export (^=> tokens)
+ {#;doc (doc "Multi-level pattern matching."
+ "Useful in situations where the result of a branch depends on further refinements on the values being matched."
+ "For example:"
+ (case (split (size static) uri)
+ (^=> (#;Some [chunk uri']) {(Text/= static chunk) true})
+ (match-uri endpoint? parts' uri')
+
+ _
+ (#;Left (format "Static part " (%t static) " doesn't match URI: " uri)))
+
+ "Short-cuts can be taken when using boolean tests."
+ "The example above can be rewritten as..."
+ (case (split (size static) uri)
+ (^=> (#;Some [chunk uri']) (Text/= static chunk))
+ (match-uri endpoint? parts' uri')
+
+ _
+ (#;Left (format "Static part " (%t static) " doesn't match URI: " uri))))}
+ (case tokens
+ (^ (list& [_meta (#;FormS levels)] body next-branches))
+ (do Monad<Lux>
+ [mlc (multi-level-case^ levels)
+ expected get-expected-type
+ g!temp (gensym "temp")]
+ (let [output (list g!temp
+ (` (;_lux_case (;_lux_: (#;AppT Maybe (~ (type->ast expected)))
+ (case (~ g!temp)
+ (~@ (multi-level-case$ g!temp [mlc body]))
+
+ (~ g!temp)
+ #;None))
+ (#;Some (~ g!temp))
+ (~ g!temp)
+
+ #;None
+ (case (~ g!temp)
+ (~@ next-branches)))))]
+ (wrap output)))
+
+ _
+ (fail "Wrong syntax for ^=>")))
+
+(macro: #export (ident-for tokens)
+ {#;doc (doc "Given a symbol or a tag, gives back a 2 tuple with the prefix and name parts, both as Text."
+ (ident-for #;doc)
+ "=>"
+ ["lux" "doc"])}
+ (case tokens
+ (^template [<tag>]
+ (^ (list [_ (<tag> [prefix name])]))
+ (return (list (` [(~ (text$ prefix)) (~ (text$ name))]))))
+ ([#;SymbolS] [#;TagS])
+
+ _
+ (fail "Wrong syntax for ident-for")))
+
+(do-template [<type> <even> <odd> <%> <=> <0> <2>]
+ [(def: #export (<even> n)
+ (-> <type> Bool)
+ (<=> <0> (<%> n <2>)))
+
+ (def: #export (<odd> n)
+ (-> <type> Bool)
+ (not (<even> n)))]
+
+ [Nat even?+ odd?+ n% n= +0 +2]
+ [Int even? odd? i% i= 0 2])
+
+(def: (get-scope-type-vars state)
+ (Lux (List Nat))
+ (case state
+ {#info info #source source #modules modules
+ #scopes scopes #type-vars types #host host
+ #seed seed #expected expected #cursor cursor
+ #scope-type-vars scope-type-vars}
+ (#Right state scope-type-vars)
+ ))
+
+(def: (list-at idx xs)
+ (All [a] (-> Int (List a) (Maybe a)))
+ (case xs
+ #;Nil
+ #;None
+
+ (#;Cons x xs')
+ (if (i= 0 idx)
+ (#;Some x)
+ (list-at (dec idx) xs'))))
+
+(macro: #export ($ tokens)
+ (case tokens
+ (^ (list [_ (#IntS idx)]))
+ (do Monad<Lux>
+ [stvs get-scope-type-vars]
+ (case (list-at idx (reverse stvs))
+ (#;Some var-id)
+ (wrap (list (` (#ExT (~ (nat$ var-id))))))
+
+ #;None
+ (fail (Text/append "Indexed-type doesn't exist: " (->Text idx)))))
+
+ _
+ (fail "Wrong syntax for $")))
+
+(def: #export (== left right)
+ {#;doc (doc "Tests whether the 2 values are identical (not just \"equal\")."
+ "This one should succeed:"
+ (let [value 5]
+ (== 5 5))
+
+ "This one should fail:"
+ (== 5 (+ 2 3)))}
+ (All [a] (-> a a Bool))
+ (_lux_proc ["lux" "=="] [left right]))
+
+(macro: #export (^@ tokens)
+ {#;doc (doc "Allows you to simultaneously bind and de-structure a value."
+ (def: (hash (^@ set [a/Hash _]))
+ (List/fold (lambda [elem acc] (+ (:: a/Hash hash elem) acc))
+ 0
+ (->List set))))}
+ (case tokens
+ (^ (list& [_meta (#;FormS (list [_ (#;SymbolS ["" name])] pattern))] body branches))
+ (let [g!whole (symbol$ ["" name])]
+ (return (list& g!whole
+ (` (case (~ g!whole) (~ pattern) (~ body)))
+ branches)))
+
+ _
+ (fail "Wrong syntax for ^@")))
+
+(macro: #export (^|> tokens)
+ (case tokens
+ (^ (list& [_meta (#;FormS (list [_ (#;SymbolS ["" name])] [_ (#;TupleS steps)]))] body branches))
+ (let [g!name (symbol$ ["" name])]
+ (return (list& g!name
+ (` (let [(~ g!name) (|> (~ g!name) (~@ steps))]
+ (~ body)))
+ branches)))
+
+ _
+ (fail "Wrong syntax for ^|>")))
+
+(macro: #export (:!! tokens)
+ {#;doc (doc "Coerces the given expression to the type of whatever is expected."
+ (: Dinosaur (:!! (list 1 2 3))))}
+ (case tokens
+ (^ (list expr))
+ (do Monad<Lux>
+ [type get-expected-type]
+ (wrap (list (` (;_lux_:! (~ (type->ast type)) (~ expr))))))
+
+ _
+ (fail "Wrong syntax for :!!")))
+
+(def: #export (error! message)
+ {#;doc (doc "Causes an error, with the given error message."
+ (error! "OH NO!"))}
+ (-> Text Bottom)
+ (_lux_proc ["jvm" "throw"] [(_lux_proc ["jvm" "new:java.lang.Error:java.lang.String"] [message])]))
+
+(def: #hidden hack_Text/append
+ (-> Text Text Text)
+ Text/append)
+
+(def: get-cursor
+ (Lux Cursor)
+ (lambda [state]
+ (let [{#;info info #;source source #;modules modules #;scopes scopes
+ #;type-vars types #;host host #;seed seed
+ #;expected expected #;cursor cursor
+ #;scope-type-vars scope-type-vars} state]
+ (#;Right [state cursor]))))
+
+(macro: #export (with-cursor tokens)
+ {#;doc (doc "Given some text, appends to it a prefix for identifying where the text comes from."
+ "For example:"
+ (with-cursor (format "User: " user-id))
+ "Would be the same as:"
+ (format "[the-module,the-line,the-column] " (format "User: " user-id)))}
+ (case tokens
+ (^ (list message))
+ (do Monad<Lux>
+ [cursor get-cursor]
+ (let [[module line column] cursor
+ cursor-prefix ($_ hack_Text/append "[" module "," (->Text line) "," (->Text column) "] ")]
+ (wrap (list (` (hack_Text/append (~ (text$ cursor-prefix)) (~ message)))))))
+
+ _
+ (fail "Wrong syntax for @")))
+
+(macro: #export (undefined tokens)
+ {#;doc (doc "Meant to be used as a stand-in for functions with undefined implementations."
+ (def: (square x)
+ (-> Int Int)
+ (undefined)))}
+ (case tokens
+ #;Nil
+ (return (list (` (error! (with-cursor "Undefined behavior.")))))
+
+ _
+ (fail "Wrong syntax for undefined")))
+
+(macro: #export (@pre tokens)
+ (case tokens
+ (^ (list test expr))
+ (return (list (` (if (~ test)
+ (~ expr)
+ (error! (with-cursor (~ (text$ (Text/append "Pre-condition failed: " (ast-to-text test))))))))))
+
+ _
+ (fail "Wrong syntax for @pre")))
+
+(macro: #export (@post tokens)
+ (case tokens
+ (^ (list test pattern expr))
+ (do Monad<Lux>
+ [g!output (gensym "")
+ exp-type get-expected-type]
+ (wrap (list (` (let [(~ g!output) (: (~ (type->ast exp-type)) (~ expr))
+ (~ pattern) (~ g!output)]
+ (if (~ test)
+ (~ g!output)
+ (error! (with-cursor (~ (text$ (Text/append "Post-condition failed: " (ast-to-text test))))))))))))
+
+ _
+ (fail "Wrong syntax for @post")))
+
+(do-template [<name> <op> <from> <to>]
+ [(def: #export (<name> input)
+ (-> <from> <to>)
+ (_lux_proc <op> [input]))]
+
+ [int-to-nat ["int" "to-nat"] Int Nat]
+ [nat-to-int ["nat" "to-int"] Nat Int]
+
+ [real-to-frac ["real" "to-frac"] Real Frac]
+ [frac-to-real ["frac" "to-real"] Frac Real]
+ )
+
+(do-template [<name> <op>]
+ [(def: #export <name>
+ (-> Nat Nat)
+ (<op> +1))]
+
+ [inc+ ++]
+ [dec+ -+])
diff --git a/stdlib/source/lux/cli.lux b/stdlib/source/lux/cli.lux
new file mode 100644
index 000000000..d9039df13
--- /dev/null
+++ b/stdlib/source/lux/cli.lux
@@ -0,0 +1,271 @@
+## 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/.
+
+(;module:
+ [lux #- not]
+ (lux (control functor
+ applicative
+ monad)
+ (data (struct (list #as list #open ("List/" Monoid<List> Monad<List>)))
+ (text #as text #open ("Text/" Monoid<Text>))
+ error
+ (sum #as sum))
+ (codata [io])
+ [compiler #+ with-gensyms Functor<Lux> Monad<Lux>]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax])))
+
+## [Types]
+(type: #export (CLI a)
+ (-> (List Text) (Error [(List Text) a])))
+
+## [Utils]
+(def: (run' opt inputs)
+ (All [a] (-> (CLI a) (List Text) (Error [(List Text) a])))
+ (opt inputs))
+
+## [Structures]
+(struct: #export _ (Functor CLI)
+ (def: (map f ma inputs)
+ (case (ma inputs)
+ (#;Left msg) (#;Left msg)
+ (#;Right [inputs' datum]) (#;Right [inputs' (f datum)]))))
+
+(struct: #export _ (Applicative CLI)
+ (def: functor Functor<CLI>)
+
+ (def: (wrap a inputs)
+ (#;Right [inputs a]))
+
+ (def: (apply ff fa inputs)
+ (case (ff inputs)
+ (#;Right [inputs' f])
+ (case (fa inputs')
+ (#;Right [inputs'' a])
+ (#;Right [inputs'' (f a)])
+
+ (#;Left msg)
+ (#;Left msg))
+
+ (#;Left msg)
+ (#;Left msg))
+ ))
+
+(struct: #export _ (Monad CLI)
+ (def: applicative Applicative<CLI>)
+
+ (def: (join mma inputs)
+ (case (mma inputs)
+ (#;Left msg) (#;Left msg)
+ (#;Right [inputs' ma]) (ma inputs'))))
+
+## [Combinators]
+(def: #export any
+ {#;doc "Just returns the next input without applying any logic."}
+ (CLI Text)
+ (lambda [inputs]
+ (case inputs
+ (#;Cons arg inputs')
+ (#;Right [inputs' arg])
+
+ _
+ (#;Left "Can't extract from empty arguments."))))
+
+(def: #export (parse parser option)
+ {#;doc "Parses the next input with a parsing function."}
+ (All [a] (-> (-> Text (Error a)) (CLI Text) (CLI a)))
+ (lambda [inputs]
+ (case (option inputs)
+ (#;Right [inputs' input])
+ (case (parser input)
+ (#;Right value)
+ (#;Right [inputs' value])
+
+ (#;Left parser-error)
+ (#;Left parser-error))
+
+ (#;Left option-error)
+ (#;Left option-error)
+ )))
+
+(def: #export (option names)
+ {#;doc "Checks that a given option (with multiple possible names) has a value."}
+ (-> (List Text) (CLI Text))
+ (lambda [inputs]
+ (let [[pre post] (list;split-with (. ;not (list;member? text;Eq<Text> names)) inputs)]
+ (case post
+ #;Nil
+ (#;Left ($_ Text/append "Missing option (" (text;join-with " " names) ")"))
+
+ (^ (list& _ value post'))
+ (#;Right [(List/append pre post') value])
+
+ _
+ (#;Left ($_ Text/append "Option lacks value (" (text;join-with " " names) ")"))
+ ))))
+
+(def: #export (flag names)
+ {#;doc "Checks that a given flag (with multiple possible names) is set."}
+ (-> (List Text) (CLI Bool))
+ (lambda [inputs]
+ (let [[pre post] (list;split-with (. ;not (list;member? text;Eq<Text> names)) inputs)]
+ (case post
+ #;Nil
+ (#;Right [pre false])
+
+ (#;Cons _ post')
+ (#;Right [(List/append pre post') true])))))
+
+(def: #export end
+ {#;doc "Ensures there are no more inputs."}
+ (CLI Unit)
+ (lambda [inputs]
+ (case inputs
+ #;Nil (#;Right [inputs []])
+ _ (#;Left (Text/append "Unknown parameters: " (text;join-with " " inputs))))))
+
+(def: #export (assert test message)
+ (-> Bool Text (CLI Unit))
+ (lambda [inputs]
+ (if test
+ (#;Right [inputs []])
+ (#;Left message))))
+
+(def: #export (opt opt)
+ {#;doc "Optionality combinator."}
+ (All [a]
+ (-> (CLI a) (CLI (Maybe a))))
+ (lambda [inputs]
+ (case (opt inputs)
+ (#;Left _) (#;Right [inputs #;None])
+ (#;Right [inputs' x]) (#;Right [inputs' (#;Some x)]))))
+
+(def: #export (seq optL optR)
+ {#;doc "Sequencing combinator."}
+ (All [a b] (-> (CLI a) (CLI b) (CLI [a b])))
+ (do Monad<CLI>
+ [l optL
+ r optR]
+ (wrap [l r])))
+
+(def: #export (alt optL optR)
+ {#;doc "Heterogeneous alternative combinator."}
+ (All [a b] (-> (CLI a) (CLI b) (CLI (| a b))))
+ (lambda [inputs]
+ (case (optL inputs)
+ (#;Left msg)
+ (case (optR inputs)
+ (#;Left _)
+ (#;Left msg)
+
+ (#;Right [inputs' r])
+ (#;Right [inputs' (sum;right r)]))
+
+ (#;Right [inputs' l])
+ (#;Right [inputs' (sum;left l)]))))
+
+(def: #export (not opt)
+ (All [a] (-> (CLI a) (CLI Unit)))
+ (lambda [inputs]
+ (case (opt inputs)
+ (#;Left msg)
+ (#;Right [inputs []])
+
+ _
+ (#;Left "Expected to fail; yet succeeded."))))
+
+(def: #export (some opt)
+ {#;doc "0-or-more combinator."}
+ (All [a]
+ (-> (CLI a) (CLI (List a))))
+ (lambda [inputs]
+ (case (opt inputs)
+ (#;Left _) (#;Right [inputs (list)])
+ (#;Right [inputs' x]) (run' (do Monad<CLI>
+ [xs (some opt)]
+ (wrap (list& x xs)))
+ inputs'))))
+
+(def: #export (many opt)
+ {#;doc "1-or-more combinator."}
+ (All [a]
+ (-> (CLI a) (CLI (List a))))
+ (do Monad<CLI>
+ [x opt
+ xs (some opt)]
+ (wrap (list& x xs))))
+
+(def: #export (either pl pr)
+ {#;doc "Homogeneous alternative combinator."}
+ (All [a]
+ (-> (CLI a) (CLI a) (CLI a)))
+ (lambda [inputs]
+ (case (pl inputs)
+ (#;Left _) (pr inputs)
+ output output)))
+
+(def: #export (run opt inputs)
+ (All [a] (-> (CLI a) (List Text) (Error a)))
+ (case (opt inputs)
+ (#;Left msg)
+ (#;Left msg)
+
+ (#;Right [_ value])
+ (#;Right value)))
+
+## [Syntax]
+(type: Program-Args
+ (#Raw-Program-Args Text)
+ (#Parsed-Program-Args (List [Text AST])))
+
+(def: program-args^
+ (Syntax Program-Args)
+ (s;alt s;local-symbol
+ (s;form (s;some (s;either (do s;Monad<Syntax>
+ [name s;local-symbol]
+ (wrap [name (` any)]))
+ (s;record (s;seq s;local-symbol s;any)))))))
+
+(syntax: #export (program: {args program-args^} body)
+ {#;doc (doc "Defines the entry-point to a program (similar to the \"main\" function/method in other programming languages)."
+ "Can take a list of all the input parameters to the program, or can destructure them using CLI-option combinators from the lux/cli module."
+ (program: all-args
+ (do Monad<IO>
+ [foo init-program
+ bar (do-something all-args)]
+ (wrap [])))
+
+ (program: (name)
+ (io (log! (Text/append "Hello, " name))))
+
+ (program: ([config config^])
+ (do Monad<IO>
+ [data (init-program config)]
+ (do-something data))))}
+ (case args
+ (#Raw-Program-Args args)
+ (wrap (list (` (;_lux_program (~ (ast;symbol ["" args]))
+ (~ body)))))
+
+ (#Parsed-Program-Args args)
+ (with-gensyms [g!args g!_ g!output g!message]
+ (wrap (list (` (;_lux_program (~ g!args)
+ (case ((: (CLI (io;IO Unit))
+ (do Monad<CLI>
+ [(~@ (|> args
+ (List/map (lambda [[name parser]]
+ (list (ast;symbol ["" name]) parser)))
+ List/join))
+ (~ g!_) end]
+ ((~' wrap) (~ body))))
+ (~ g!args))
+ (#;Right [(~ g!_) (~ g!output)])
+ (~ g!output)
+
+ (#;Left (~ g!message))
+ (error! (~ g!message))
+ )))
+ )))
+ ))
diff --git a/stdlib/source/lux/codata/cont.lux b/stdlib/source/lux/codata/cont.lux
new file mode 100644
index 000000000..b851d417c
--- /dev/null
+++ b/stdlib/source/lux/codata/cont.lux
@@ -0,0 +1,64 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (macro (ast #as ast))
+ (control (functor #as F #refer #all)
+ (applicative #as A #refer #all)
+ (monad #as M #refer #all))
+ (data (struct list)))
+ (.. function))
+
+## [Types]
+(type: #export (Cont a)
+ (All [b]
+ (-> (-> a b) b)))
+
+## [Syntax]
+(macro: #export (@lazy tokens state)
+ {#;doc (doc "Delays the evaluation of an expression, by wrapping it in a continuation 'thunk'."
+ (@lazy (some-computation some-input)))}
+ (case tokens
+ (^ (list value))
+ (let [blank (ast;symbol ["" ""])]
+ (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))]))
+
+ _
+ (#;Left "Wrong syntax for @lazy")))
+
+## [Functions]
+(def: #export (call/cc f)
+ {#;doc "Call with current continuation."}
+ (All [a b c] (Cont (-> a (Cont b c)) (Cont a c)))
+ (lambda [k]
+ (f (lambda [a _]
+ (k a))
+ k)))
+
+(def: #export (run thunk)
+ {#;doc "Forces a continuation thunk to be evaluated."}
+ (All [a]
+ (-> (Cont a) a))
+ (thunk id))
+
+## [Structs]
+(struct: #export _ (Functor Cont)
+ (def: (map f ma)
+ (lambda [k] (ma (. k f)))))
+
+(struct: #export _ (Applicative Cont)
+ (def: functor Functor<Cont>)
+
+ (def: (wrap a)
+ (@lazy a))
+
+ (def: (apply ff fa)
+ (@lazy ((run ff) (run fa)))))
+
+(struct: #export _ (Monad Cont)
+ (def: applicative Applicative<Cont>)
+
+ (def: join run))
diff --git a/stdlib/source/lux/codata/env.lux b/stdlib/source/lux/codata/env.lux
new file mode 100644
index 000000000..8883b4a66
--- /dev/null
+++ b/stdlib/source/lux/codata/env.lux
@@ -0,0 +1,65 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control functor
+ applicative
+ ["M" monad #*])))
+
+## [Types]
+(type: #export (Env r a)
+ (-> r a))
+
+## [Structures]
+(struct: #export Functor<Env> (All [r] (Functor (Env r)))
+ (def: (map f fa)
+ (lambda [env]
+ (f (fa env)))))
+
+(struct: #export Applicative<Env> (All [r] (Applicative (Env r)))
+ (def: functor Functor<Env>)
+
+ (def: (wrap x)
+ (lambda [env] x))
+
+ (def: (apply ff fa)
+ (lambda [env]
+ ((ff env) (fa env)))))
+
+(struct: #export Monad<Env> (All [r] (Monad (Env r)))
+ (def: applicative Applicative<Env>)
+
+ (def: (join mma)
+ (lambda [env]
+ (mma env env))))
+
+## [Values]
+(def: #export ask
+ {#;doc "Get the value of the environment."}
+ (All [r] (Env r r))
+ (lambda [env] env))
+
+(def: #export (local change env-proc)
+ {#;doc "Run computation with a locally-modified environment."}
+ (All [r a] (-> (-> r r) (Env r a) (Env r a)))
+ (|>. change env-proc))
+
+(def: #export (run env env-proc)
+ (All [r a] (-> r (Env r a) a))
+ (env-proc env))
+
+(struct: #export (EnvT Monad<M>)
+ (All [M e] (-> (Monad M) (Monad (All [a] (Env e (M a))))))
+ (def: applicative (compA Applicative<Env> (get@ #M;applicative Monad<M>)))
+ (def: (join eMeMa)
+ (lambda [env]
+ (do Monad<M>
+ [eMa (run env eMeMa)]
+ (run env eMa)))))
+
+(def: #export lift-env
+ (All [M e a] (-> (M a) (Env e (M a))))
+ (:: Monad<Env> wrap))
diff --git a/stdlib/source/lux/codata/function.lux b/stdlib/source/lux/codata/function.lux
new file mode 100644
index 000000000..fba5528a8
--- /dev/null
+++ b/stdlib/source/lux/codata/function.lux
@@ -0,0 +1,23 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monoid)))
+
+## [Functions]
+(def: #export (const x y)
+ (All [a b] (-> a (-> b a)))
+ x)
+
+(def: #export (flip f)
+ (All [a b c]
+ (-> (-> a b c) (-> b a c)))
+ (lambda [x y] (f y x)))
+
+## [Structures]
+(struct: #export Monoid<Function> (Monoid (All [a] (-> a a)))
+ (def: unit id)
+ (def: append .))
diff --git a/stdlib/source/lux/codata/io.lux b/stdlib/source/lux/codata/io.lux
new file mode 100644
index 000000000..1398dfae5
--- /dev/null
+++ b/stdlib/source/lux/codata/io.lux
@@ -0,0 +1,56 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control functor
+ applicative
+ monad)
+ (data (struct list))))
+
+## [Types]
+(type: #export (IO a)
+ (-> Void a))
+
+## [Syntax]
+(macro: #export (io tokens state)
+ {#;doc (doc
+ "Delays the evaluation of an expression, by wrapping it in an IO 'thunk'."
+ "Great for wrapping side-effecting computations (which won't be performed until the IO is \"run\")."
+ (io (exec
+ (log! msg)
+ "Some value...")))}
+ (case tokens
+ (^ (list value))
+ (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])]
+ (#;Right [state (list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))]))
+
+ _
+ (#;Left "Wrong syntax for io")))
+
+## [Structures]
+(struct: #export _ (Functor IO)
+ (def: (map f ma)
+ (io (f (ma (:! Void []))))))
+
+(struct: #export _ (Applicative IO)
+ (def: functor Functor<IO>)
+
+ (def: (wrap x)
+ (io x))
+
+ (def: (apply ff fa)
+ (io ((ff (:! Void [])) (fa (:! Void []))))))
+
+(struct: #export _ (Monad IO)
+ (def: applicative Applicative<IO>)
+
+ (def: (join mma)
+ (io ((mma (:! Void [])) (:! Void [])))))
+
+## [Functions]
+(def: #export (run action)
+ (All [a] (-> (IO a) a))
+ (action (:! Void [])))
diff --git a/stdlib/source/lux/codata/state.lux b/stdlib/source/lux/codata/state.lux
new file mode 100644
index 000000000..82e9b40fd
--- /dev/null
+++ b/stdlib/source/lux/codata/state.lux
@@ -0,0 +1,114 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control functor
+ ["A" applicative #*]
+ ["M" monad #*])))
+
+## [Types]
+(type: #export (State s a)
+ (-> s [s a]))
+
+## [Structures]
+(struct: #export Functor<State> (All [s] (Functor (State s)))
+ (def: (map f ma)
+ (lambda [state]
+ (let [[state' a] (ma state)]
+ [state' (f a)]))))
+
+(struct: #export Applicative<State> (All [s] (Applicative (State s)))
+ (def: functor Functor<State>)
+
+ (def: (wrap a)
+ (lambda [state]
+ [state a]))
+
+ (def: (apply ff fa)
+ (lambda [state]
+ (let [[state' f] (ff state)
+ [state'' a] (fa state')]
+ [state'' (f a)]))))
+
+(struct: #export Monad<State> (All [s] (Monad (State s)))
+ (def: applicative Applicative<State>)
+
+ (def: (join mma)
+ (lambda [state]
+ (let [[state' ma] (mma state)]
+ (ma state')))))
+
+## [Values]
+(def: #export get
+ (All [s] (State s s))
+ (lambda [state]
+ [state state]))
+
+(def: #export (put new-state)
+ (All [s] (-> s (State s Unit)))
+ (lambda [state]
+ [new-state []]))
+
+(def: #export (update change)
+ (All [s] (-> (-> s s) (State s Unit)))
+ (lambda [state]
+ [(change state) []]))
+
+(def: #export (use user)
+ {#;doc "Run function on current state."}
+ (All [s a] (-> (-> s a) (State s a)))
+ (lambda [state]
+ [state (user state)]))
+
+(def: #export (local change action)
+ {#;doc "Run computation with a locally-modified state."}
+ (All [s a] (-> (-> s s) (State s a) (State s a)))
+ (lambda [state]
+ (let [[state' output] (action (change state))]
+ [state output])))
+
+(def: #export (run state action)
+ (All [s a] (-> s (State s a) [s a]))
+ (action state))
+
+(struct: (Functor<StateT> Functor<M>)
+ (All [M s] (-> (Functor M) (Functor (All [a] (-> s (M [s a]))))))
+ (def: (map f sfa)
+ (lambda [state]
+ (:: Functor<M> map (lambda [[s a]] [s (f a)])
+ (sfa state)))))
+
+(struct: (Applicative<StateT> Monad<M>)
+ (All [M s] (-> (Monad M) (Applicative (All [a] (-> s (M [s a]))))))
+ (def: functor (Functor<StateT> (get@ [#M;applicative #A;functor]
+ Monad<M>)))
+
+ (def: (wrap a)
+ (lambda [state]
+ (:: Monad<M> wrap [state a])))
+
+ (def: (apply sFf sFa)
+ (lambda [state]
+ (do Monad<M>
+ [[state f] (sFf state)
+ [state a] (sFa state)]
+ (wrap [state (f a)])))))
+
+(struct: #export (StateT Monad<M>)
+ (All [M s] (-> (Monad M) (Monad (All [a] (-> s (M [s a]))))))
+ (def: applicative (Applicative<StateT> Monad<M>))
+ (def: (join sMsMa)
+ (lambda [state]
+ (do Monad<M>
+ [[state' sMa] (sMsMa state)]
+ (sMa state')))))
+
+(def: #export (lift-state Monad<M> ma)
+ (All [M s a] (-> (Monad M) (M a) (-> s (M [s a]))))
+ (lambda [state]
+ (do Monad<M>
+ [a ma]
+ (wrap [state a]))))
diff --git a/stdlib/source/lux/codata/struct/stream.lux b/stdlib/source/lux/codata/struct/stream.lux
new file mode 100644
index 000000000..8814ec460
--- /dev/null
+++ b/stdlib/source/lux/codata/struct/stream.lux
@@ -0,0 +1,135 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control functor
+ monad
+ comonad)
+ [compiler #+ with-gensyms]
+ (macro ["s" syntax #+ syntax: Syntax])
+ (data (struct [list "List/" Monad<List>])
+ bool)
+ (codata [cont #+ @lazy Cont])))
+
+## [Types]
+(type: #export (Stream a)
+ (Cont [a (Stream a)]))
+
+## [Utils]
+(def: (cycle' x xs init full)
+ (All [a]
+ (-> a (List a) a (List a) (Stream a)))
+ (case xs
+ #;Nil (@lazy [x (cycle' init full init full)])
+ (#;Cons x' xs') (@lazy [x (cycle' x' xs' init full)])))
+
+## [Functions]
+(def: #export (iterate f x)
+ (All [a]
+ (-> (-> a a) a (Stream a)))
+ (@lazy [x (iterate f (f x))]))
+
+(def: #export (repeat x)
+ (All [a]
+ (-> a (Stream a)))
+ (@lazy [x (repeat x)]))
+
+(def: #export (cycle xs)
+ (All [a]
+ (-> (List a) (Maybe (Stream a))))
+ (case xs
+ #;Nil #;None
+ (#;Cons x xs') (#;Some (cycle' x xs' x xs'))))
+
+(do-template [<name> <return> <part>]
+ [(def: #export (<name> s)
+ (All [a] (-> (Stream a) <return>))
+ (let [[h t] (cont;run s)]
+ <part>))]
+
+ [head a h]
+ [tail (Stream a) t])
+
+(def: #export (at idx s)
+ (All [a] (-> Nat (Stream a) a))
+ (let [[h t] (cont;run s)]
+ (if (>+ +0 idx)
+ (at (dec+ idx) t)
+ h)))
+
+(do-template [<taker> <dropper> <splitter> <pred-type> <pred-test> <pred-step>]
+ [(def: #export (<taker> pred xs)
+ (All [a]
+ (-> <pred-type> (Stream a) (List a)))
+ (let [[x xs'] (cont;run xs)]
+ (if <pred-test>
+ (list& x (<taker> <pred-step> xs'))
+ (list))))
+
+ (def: #export (<dropper> pred xs)
+ (All [a]
+ (-> <pred-type> (Stream a) (Stream a)))
+ (let [[x xs'] (cont;run xs)]
+ (if <pred-test>
+ (<dropper> <pred-step> xs')
+ xs)))
+
+ (def: #export (<splitter> pred xs)
+ (All [a]
+ (-> <pred-type> (Stream a) [(List a) (Stream a)]))
+ (let [[x xs'] (cont;run xs)]
+ (if <pred-test>
+ (let [[tail next] (<splitter> <pred-step> xs')]
+ [(#;Cons [x tail]) next])
+ [(list) xs])))]
+
+ [take-while drop-while split-with (-> a Bool) (pred x) pred]
+ [take drop split Nat (>+ +0 pred) (dec+ pred)]
+ )
+
+(def: #export (unfold step init)
+ (All [a b]
+ (-> (-> a [a b]) a (Stream b)))
+ (let [[next x] (step init)]
+ (@lazy [x (unfold step next)])))
+
+(def: #export (filter p xs)
+ (All [a] (-> (-> a Bool) (Stream a) (Stream a)))
+ (let [[x xs'] (cont;run xs)]
+ (if (p x)
+ (@lazy [x (filter p xs')])
+ (filter p xs'))))
+
+(def: #export (partition p xs)
+ (All [a] (-> (-> a Bool) (Stream a) [(Stream a) (Stream a)]))
+ [(filter p xs) (filter (complement p) xs)])
+
+## [Structures]
+(struct: #export _ (Functor Stream)
+ (def: (map f fa)
+ (let [[h t] (cont;run fa)]
+ (@lazy [(f h) (map f t)]))))
+
+(struct: #export _ (CoMonad Stream)
+ (def: functor Functor<Stream>)
+ (def: unwrap head)
+ (def: (split wa)
+ (let [[head tail] (cont;run wa)]
+ (@lazy [wa (split tail)]))))
+
+## [Pattern-matching]
+(syntax: #export (^stream& {patterns (s;form (s;many s;any))} body {branches (s;some s;any)})
+ {#;doc (doc "Allows destructuring of streams in pattern-matching expressions."
+ "Caveat emptor: Only use it for destructuring, and not for testing values within the streams."
+ (let [(^stream& x y z _tail) (some-stream-func 1 2 3)]
+ (func x y z)))}
+ (with-gensyms [g!s]
+ (let [body+ (` (let [(~@ (List/join (List/map (lambda [pattern]
+ (list (` [(~ pattern) (~ g!s)])
+ (` (cont;run (~ g!s)))))
+ patterns)))]
+ (~ body)))]
+ (wrap (list& g!s body+ branches)))))
diff --git a/stdlib/source/lux/compiler.lux b/stdlib/source/lux/compiler.lux
new file mode 100644
index 000000000..d7b072a56
--- /dev/null
+++ b/stdlib/source/lux/compiler.lux
@@ -0,0 +1,559 @@
+## 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/.
+
+(;module: {#;doc "Functions for extracting information from the state of the compiler."}
+ lux
+ (lux (macro [ast])
+ (control functor
+ applicative
+ monad)
+ (data (struct [list #* "List/" Monoid<List> Monad<List>])
+ [number]
+ [text "Text/" Monoid<Text> Eq<Text>]
+ [product]
+ [ident "Ident/" Codec<Text,Ident>]
+ maybe
+ error)))
+
+## (type: (Lux a)
+## (-> Compiler (Error [Compiler a])))
+
+(struct: #export _ (Functor Lux)
+ (def: (map f fa)
+ (lambda [state]
+ (case (fa state)
+ (#;Left msg)
+ (#;Left msg)
+
+ (#;Right [state' a])
+ (#;Right [state' (f a)])))))
+
+(struct: #export _ (Applicative Lux)
+ (def: functor Functor<Lux>)
+
+ (def: (wrap x)
+ (lambda [state]
+ (#;Right [state x])))
+
+ (def: (apply ff fa)
+ (lambda [state]
+ (case (ff state)
+ (#;Right [state' f])
+ (case (fa state')
+ (#;Right [state'' a])
+ (#;Right [state'' (f a)])
+
+ (#;Left msg)
+ (#;Left msg))
+
+ (#;Left msg)
+ (#;Left msg)))))
+
+(struct: #export _ (Monad Lux)
+ (def: applicative Applicative<Lux>)
+
+ (def: (join mma)
+ (lambda [state]
+ (case (mma state)
+ (#;Left msg)
+ (#;Left msg)
+
+ (#;Right [state' ma])
+ (ma state')))))
+
+(def: (get k plist)
+ (All [a]
+ (-> Text (List [Text a]) (Maybe a)))
+ (case plist
+ #;Nil
+ #;None
+
+ (#;Cons [k' v] plist')
+ (if (Text/= k k')
+ (#;Some v)
+ (get k plist'))))
+
+(def: #export (run' compiler action)
+ (All [a] (-> Compiler (Lux a) (Error [Compiler a])))
+ (action compiler))
+
+(def: #export (run compiler action)
+ (All [a] (-> Compiler (Lux a) (Error a)))
+ (case (action compiler)
+ (#;Left error)
+ (#;Left error)
+
+ (#;Right [_ output])
+ (#;Right output)))
+
+(def: #export (either left right)
+ (All [a] (-> (Lux a) (Lux a) (Lux a)))
+ (lambda [compiler]
+ (case (left compiler)
+ (#;Left error)
+ (right compiler)
+
+ (#;Right [compiler' output])
+ (#;Right [compiler' output]))))
+
+(def: #export (assert test message)
+ (-> Bool Text (Lux Unit))
+ (lambda [compiler]
+ (if test
+ (#;Right [compiler []])
+ (#;Left message))))
+
+(def: #export (fail msg)
+ (All [a]
+ (-> Text (Lux a)))
+ (lambda [_]
+ (#;Left msg)))
+
+(def: #export (find-module name)
+ (-> Text (Lux Module))
+ (lambda [state]
+ (case (get name (get@ #;modules state))
+ (#;Some module)
+ (#;Right [state module])
+
+ _
+ (#;Left ($_ Text/append "Unknown module: " name)))))
+
+(def: #export current-module-name
+ (Lux Text)
+ (lambda [state]
+ (case (list;last (get@ #;scopes state))
+ (#;Some scope)
+ (case (get@ #;name scope)
+ (#;Cons m-name #;Nil)
+ (#;Right [state m-name])
+
+ _
+ (#;Left "Improper name for scope."))
+
+ _
+ (#;Left "Empty environment!")
+ )))
+
+(def: #export current-module
+ (Lux Module)
+ (do Monad<Lux>
+ [this-module-name current-module-name]
+ (find-module this-module-name)))
+
+(def: #export (get-ann tag meta)
+ (-> Ident Anns (Maybe Ann-Value))
+ (let [[p n] tag]
+ (case meta
+ (#;Cons [[p' n'] dmv] meta')
+ (if (and (Text/= p p')
+ (Text/= n n'))
+ (#;Some dmv)
+ (get-ann tag meta'))
+
+ #;Nil
+ #;None)))
+
+(do-template [<name> <tag> <type>]
+ [(def: #export (<name> tag meta)
+ (-> Ident Anns (Maybe <type>))
+ (case (get-ann tag meta)
+ (#;Some (<tag> value))
+ (#;Some value)
+
+ _
+ #;None))]
+
+ [get-bool-ann #;BoolM Bool]
+ [get-int-ann #;IntM Int]
+ [get-real-ann #;RealM Real]
+ [get-char-ann #;CharM Char]
+ [get-text-ann #;TextM Text]
+ [get-ident-ann #;IdentM Ident]
+ [get-list-ann #;ListM (List Ann-Value)]
+ [get-dict-ann #;DictM (List [Text Ann-Value])]
+ )
+
+(def: #export (get-doc meta)
+ (-> Anns (Maybe Text))
+ (get-text-ann ["lux" "doc"] meta))
+
+(def: #export (flag-set? flag-name meta)
+ (-> Ident Anns Bool)
+ (case (get-ann flag-name meta)
+ (#;Some (#;BoolM true))
+ true
+
+ _
+ false))
+
+(do-template [<name> <tag>]
+ [(def: #export <name>
+ (-> Anns Bool)
+ (flag-set? (ident-for <tag>)))]
+
+ [export? #;export?]
+ [hidden? #;hidden?]
+ [macro? #;macro?]
+ [type? #;type?]
+ [struct? #;struct?]
+ [type-rec? #;type-rec?]
+ [sig? #;sig?]
+ )
+
+(do-template [<name> <tag> <type>]
+ [(def: (<name> dmv)
+ (-> Ann-Value (Maybe <type>))
+ (case dmv
+ (<tag> actual-value)
+ (#;Some actual-value)
+
+ _
+ #;None))]
+
+ [try-mlist #;ListM (List Ann-Value)]
+ [try-mtext #;TextM Text]
+ )
+
+(do-template [<name> <tag>]
+ [(def: #export (<name> meta)
+ (-> Anns (List Text))
+ (default (list)
+ (do Monad<Maybe>
+ [_args (get-ann (ident-for <tag>) meta)
+ args (try-mlist _args)]
+ (mapM @ try-mtext args))))]
+
+ [func-args #;func-args]
+ [type-args #;type-args]
+ )
+
+(def: (find-macro' modules this-module module name)
+ (-> (List [Text Module]) Text Text Text
+ (Maybe Macro))
+ (do Monad<Maybe>
+ [$module (get module modules)
+ [def-type def-anns def-value] (: (Maybe Def) (|> (: Module $module) (get@ #;defs) (get name)))]
+ (if (and (macro? def-anns)
+ (or (export? def-anns) (Text/= module this-module)))
+ (#;Some (:! Macro def-value))
+ (case (get-ann ["lux" "alias"] def-anns)
+ (#;Some (#;IdentM [r-module r-name]))
+ (find-macro' modules this-module r-module r-name)
+
+ _
+ #;None))))
+
+(def: #export (find-macro ident)
+ (-> Ident (Lux (Maybe Macro)))
+ (do Monad<Lux>
+ [this-module current-module-name]
+ (let [[module name] ident]
+ (: (Lux (Maybe Macro))
+ (lambda [state]
+ (#;Right [state (find-macro' (get@ #;modules state) this-module module name)]))))))
+
+(def: #export (normalize ident)
+ (-> Ident (Lux Ident))
+ (case ident
+ ["" name]
+ (do Monad<Lux>
+ [module-name current-module-name]
+ (wrap [module-name name]))
+
+ _
+ (:: Monad<Lux> wrap ident)))
+
+(def: #export (macro-expand-once syntax)
+ (-> AST (Lux (List AST)))
+ (case syntax
+ [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))]
+ (do Monad<Lux>
+ [macro-name' (normalize macro-name)
+ ?macro (find-macro macro-name')]
+ (case ?macro
+ (#;Some macro)
+ (macro args)
+
+ #;None
+ (:: Monad<Lux> wrap (list syntax))))
+
+ _
+ (:: Monad<Lux> wrap (list syntax))))
+
+(def: #export (macro-expand syntax)
+ (-> AST (Lux (List AST)))
+ (case syntax
+ [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))]
+ (do Monad<Lux>
+ [macro-name' (normalize macro-name)
+ ?macro (find-macro macro-name')]
+ (case ?macro
+ (#;Some macro)
+ (do Monad<Lux>
+ [expansion (macro args)
+ expansion' (mapM Monad<Lux> macro-expand expansion)]
+ (wrap (:: Monad<List> join expansion')))
+
+ #;None
+ (:: Monad<Lux> wrap (list syntax))))
+
+ _
+ (:: Monad<Lux> wrap (list syntax))))
+
+(def: #export (macro-expand-all syntax)
+ (-> AST (Lux (List AST)))
+ (case syntax
+ [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))]
+ (do Monad<Lux>
+ [macro-name' (normalize macro-name)
+ ?macro (find-macro macro-name')]
+ (case ?macro
+ (#;Some macro)
+ (do Monad<Lux>
+ [expansion (macro args)
+ expansion' (mapM Monad<Lux> macro-expand-all expansion)]
+ (wrap (:: Monad<List> join expansion')))
+
+ #;None
+ (do Monad<Lux>
+ [parts' (mapM Monad<Lux> macro-expand-all (list& (ast;symbol macro-name) args))]
+ (wrap (list (ast;form (:: Monad<List> join parts')))))))
+
+ [_ (#;FormS (#;Cons [harg targs]))]
+ (do Monad<Lux>
+ [harg+ (macro-expand-all harg)
+ targs+ (mapM Monad<Lux> macro-expand-all targs)]
+ (wrap (list (ast;form (List/append harg+ (:: Monad<List> join (: (List (List AST)) targs+)))))))
+
+ [_ (#;TupleS members)]
+ (do Monad<Lux>
+ [members' (mapM Monad<Lux> macro-expand-all members)]
+ (wrap (list (ast;tuple (:: Monad<List> join members')))))
+
+ _
+ (:: Monad<Lux> wrap (list syntax))))
+
+(def: #export (gensym prefix)
+ (-> Text (Lux AST))
+ (lambda [state]
+ (#;Right [(update@ #;seed inc+ state)
+ (ast;symbol ["" ($_ Text/append "__gensym__" prefix (:: number;Codec<Text,Nat> encode (get@ #;seed state)))])])))
+
+(def: (get-local-symbol ast)
+ (-> AST (Lux Text))
+ (case ast
+ [_ (#;SymbolS [_ name])]
+ (:: Monad<Lux> wrap name)
+
+ _
+ (fail (Text/append "AST is not a local symbol: " (ast;ast-to-text ast)))))
+
+(macro: #export (with-gensyms tokens)
+ {#;doc (doc "Creates new symbols and offers them to the body expression."
+ (syntax: #export (synchronized lock body)
+ (with-gensyms [g!lock g!body g!_]
+ (wrap (list (` (let [(~ g!lock) (~ lock)
+ (~ g!_) (;_jvm_monitorenter (~ g!lock))
+ (~ g!body) (~ body)
+ (~ g!_) (;_jvm_monitorexit (~ g!lock))]
+ (~ g!body)))))
+ )))}
+ (case tokens
+ (^ (list [_ (#;TupleS symbols)] body))
+ (do Monad<Lux>
+ [symbol-names (mapM @ get-local-symbol symbols)
+ #let [symbol-defs (List/join (List/map (: (-> Text (List AST))
+ (lambda [name] (list (ast;symbol ["" name]) (` (gensym (~ (ast;text name)))))))
+ symbol-names))]]
+ (wrap (list (` (do Monad<Lux>
+ [(~@ symbol-defs)]
+ (~ body))))))
+
+ _
+ (fail "Wrong syntax for with-gensyms")))
+
+(def: #export (macro-expand-1 token)
+ (-> AST (Lux AST))
+ (do Monad<Lux>
+ [token+ (macro-expand token)]
+ (case token+
+ (^ (list token'))
+ (wrap token')
+
+ _
+ (fail "Macro expanded to more than 1 element."))))
+
+(def: #export (module-exists? module)
+ (-> Text (Lux Bool))
+ (lambda [state]
+ (#;Right [state (case (get module (get@ #;modules state))
+ (#;Some _)
+ true
+
+ #;None
+ false)])))
+
+(def: (try-both f x1 x2)
+ (All [a b]
+ (-> (-> a (Maybe b)) a a (Maybe b)))
+ (case (f x1)
+ #;None (f x2)
+ (#;Some y) (#;Some y)))
+
+(def: #export (find-var-type name)
+ (-> Text (Lux Type))
+ (lambda [state]
+ (let [test (: (-> [Text Analysis] Bool)
+ (|>. product;left (Text/= name)))]
+ (case (do Monad<Maybe>
+ [scope (find (lambda [env]
+ (or (any? test (get@ [#;locals #;mappings] env))
+ (any? test (get@ [#;closure #;mappings] env))))
+ (get@ #;scopes state))
+ [_ [[type _] _]] (try-both (find test)
+ (get@ [#;locals #;mappings] scope)
+ (get@ [#;closure #;mappings] scope))]
+ (wrap type))
+ (#;Some var-type)
+ (#;Right [state var-type])
+
+ #;None
+ (#;Left ($_ Text/append "Unknown variable: " name))))))
+
+(def: #export (find-def name)
+ (-> Ident (Lux Def))
+ (lambda [state]
+ (case (: (Maybe Def)
+ (do Monad<Maybe>
+ [#let [[v-prefix v-name] name]
+ (^slots [#;defs]) (get v-prefix (get@ #;modules state))]
+ (get v-name defs)))
+ (#;Some _meta)
+ (#;Right [state _meta])
+
+ _
+ (#;Left ($_ Text/append "Unknown definition: " (Ident/encode name))))))
+
+(def: #export (find-def-type name)
+ (-> Ident (Lux Type))
+ (do Monad<Lux>
+ [[def-type def-data def-value] (find-def name)]
+ (wrap def-type)))
+
+(def: #export (find-type name)
+ (-> Ident (Lux Type))
+ (do Monad<Lux>
+ [#let [[_ _name] name]]
+ (either (find-var-type _name)
+ (do @
+ [name (normalize name)]
+ (find-def-type name)))))
+
+(def: #export (find-type-def name)
+ (-> Ident (Lux Type))
+ (do Monad<Lux>
+ [[def-type def-data def-value] (find-def name)]
+ (wrap (:! Type def-value))))
+
+(def: #export (defs module-name)
+ (-> Text (Lux (List [Text Def])))
+ (lambda [state]
+ (case (get module-name (get@ #;modules state))
+ #;None (#;Left ($_ Text/append "Unknown module: " module-name))
+ (#;Some module) (#;Right [state (get@ #;defs module)])
+ )))
+
+(def: #export (exports module-name)
+ (-> Text (Lux (List [Text Def])))
+ (do Monad<Lux>
+ [defs (defs module-name)]
+ (wrap (filter (lambda [[name [def-type def-anns def-value]]]
+ (and (export? def-anns)
+ (not (hidden? def-anns))))
+ defs))))
+
+(def: #export modules
+ (Lux (List Text))
+ (lambda [state]
+ (|> state
+ (get@ #;modules)
+ (List/map product;left)
+ [state]
+ #;Right)))
+
+(def: #export (tags-of type-name)
+ (-> Ident (Lux (List Ident)))
+ (do Monad<Lux>
+ [#let [[module name] type-name]
+ module (find-module module)]
+ (case (get name (get@ #;types module))
+ (#;Some [tags _])
+ (wrap tags)
+
+ _
+ (wrap (list)))))
+
+(def: #export cursor
+ (Lux Cursor)
+ (lambda [state]
+ (#;Right [state (get@ #;cursor state)])))
+
+(def: #export expected-type
+ (Lux Type)
+ (lambda [state]
+ (case (get@ #;expected state)
+ (#;Some type)
+ (#;Right [state type])
+
+ #;None
+ (#;Left "Not expecting any type."))))
+
+(def: #export (imported-modules module-name)
+ (-> Text (Lux (List Text)))
+ (do Monad<Lux>
+ [(^slots [#;imports]) (find-module module-name)]
+ (wrap imports)))
+
+(def: #export (resolve-tag (^@ tag [module name]))
+ (-> Ident (Lux [Nat (List Ident) Type]))
+ (do Monad<Lux>
+ [=module (find-module module)
+ this-module-name current-module-name]
+ (case (get name (get@ #;tags =module))
+ (#;Some [idx tag-list exported? type])
+ (if (or exported?
+ (Text/= this-module-name module))
+ (wrap [idx tag-list type])
+ (fail ($_ Text/append "Can't access tag: " (Ident/encode tag) " from module " this-module-name)))
+
+ _
+ (fail ($_ Text/append "Unknown tag: " (Ident/encode tag))))))
+
+(def: #export locals
+ (Lux (List (List [Text Type])))
+ (lambda [state]
+ (case (list;inits (get@ #;scopes state))
+ #;None
+ (#;Left "No local environment")
+
+ (#;Some scopes)
+ (#;Right [state
+ (List/map (|>. (get@ [#;locals #;mappings])
+ (List/map (lambda [[name [[type cursor] analysis]]]
+ [name type])))
+ scopes)]))))
+
+(def: #export (un-alias def-name)
+ (-> Ident (Lux Ident))
+ (do Monad<Lux>
+ [def-name (normalize def-name)
+ [_ def-anns _] (find-def def-name)]
+ (case (get-ann (ident-for #;alias) def-anns)
+ (#;Some (#;IdentM real-def-name))
+ (wrap real-def-name)
+
+ _
+ (wrap def-name))))
diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux
new file mode 100644
index 000000000..1eb3cee21
--- /dev/null
+++ b/stdlib/source/lux/concurrency/actor.lux
@@ -0,0 +1,278 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monad)
+ (codata [io #- run]
+ function)
+ (data error
+ text/format
+ (struct [list "List/" Monoid<List> Monad<List>])
+ [product]
+ [number "Nat/" Codec<Text,Nat>])
+ [compiler #+ with-gensyms]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax]
+ (syntax [common]))
+ [type])
+ (.. [promise #+ Monad<Promise>]
+ [stm #+ Monad<STM>]
+ [frp]))
+
+## [Types]
+(type: #export (Actor s m)
+ {#mailbox (stm;Var m)
+ #kill-signal (promise;Promise Unit)
+ #obituary (promise;Promise [(Maybe Text) s (List m)])})
+
+(type: #export (Proc s m)
+ {#step (-> (Actor s m) (-> m s (promise;Promise (Error s))))
+ #end (-> (Maybe Text) s (promise;Promise Unit))})
+
+## [Values]
+(def: #export (spawn init [proc on-death])
+ {#;doc "Given a procedure and initial state, launches an actor and returns it."}
+ (All [s m] (-> s (Proc s m) (IO (Actor s m))))
+ (io (let [mailbox (stm;var (:! ($ 1) []))
+ kill-signal (promise;promise Unit)
+ obituary (promise;promise [(Maybe Text) ($ 0) (List ($ 1))])
+ self {#mailbox mailbox
+ #kill-signal kill-signal
+ #obituary obituary}
+ mailbox-chan (io;run (stm;follow "\tmailbox\t" mailbox))
+ proc (proc self)
+ |mailbox| (stm;var mailbox-chan)
+ _ (:: Monad<Promise> map
+ (lambda [_]
+ (io;run (do Monad<IO>
+ [mb (stm;read! |mailbox|)]
+ (frp;close mb))))
+ kill-signal)
+ process (loop [state init
+ messages mailbox-chan]
+ (do Monad<Promise>
+ [?messages+ messages]
+ (case ?messages+
+ ## No kill-signal so far, so I may proceed...
+ (#;Some [message messages'])
+ (do Monad<Promise>
+ [#let [_ (io;run (stm;write! messages' |mailbox|))]
+ ?state' (proc message state)]
+ (case ?state'
+ (#;Left error)
+ (do @
+ [#let [_ (io;run (promise;resolve [] kill-signal))
+ _ (io;run (frp;close messages'))
+ death-message (#;Some error)]
+ _ (on-death death-message state)
+ remaining-messages (frp;consume messages')]
+ (wrap [death-message state (#;Cons message remaining-messages)]))
+
+ (#;Right state')
+ (recur state' messages')))
+
+ ## Otherwise, clean-up and return current state.
+ #;None
+ (do Monad<Promise>
+ [#let [_ (io;run (frp;close messages))
+ death-message #;None]
+ _ (on-death death-message state)]
+ (wrap [death-message state (list)])))))]
+ self)))
+
+(def: #export poison
+ {#;doc "Immediately kills the given actor (if it's not already dead)."}
+ (All [s m] (-> (Actor s m) (io;IO Bool)))
+ (|>. (get@ #kill-signal) (promise;resolve [])))
+
+(def: #export (alive? actor)
+ (All [s m] (-> (Actor s m) Bool))
+ (case [(promise;poll (get@ #kill-signal actor))
+ (promise;poll (get@ #obituary actor))]
+ [#;None #;None]
+ true
+
+ _
+ false))
+
+(def: #export (send message actor)
+ (All [s m] (-> m (Actor s m) (promise;Promise Bool)))
+ (if (alive? actor)
+ (exec (io;run (stm;write! message (get@ #mailbox actor)))
+ (:: Monad<Promise> wrap true))
+ (:: Monad<Promise> wrap false)))
+
+(def: #export (keep-alive init proc)
+ {#;doc "Given initial-state and a procedure, launches and actor that will reboot if it dies of errors.
+ However, it can still be killed."}
+ (All [s m] (-> s (Proc s m) (IO (Actor s m))))
+ (io (let [ka-actor (: (Actor (Actor ($ 0) ($ 1)) ($ 1))
+ (io;run (spawn (io;run (spawn init proc))
+ {#step (lambda [*self* message server]
+ (do Monad<Promise>
+ [was-sent? (send message server)]
+ (if was-sent?
+ (wrap (#;Right server))
+ (do @
+ [[?cause state unprocessed-messages] (get@ #obituary server)]
+ (exec (log! (format "ACTOR DIED:\n" (default "" ?cause) "\n RESTARTING"))
+ (do @
+ [#let [new-server (io;run (spawn state proc))
+ mailbox (get@ #mailbox new-server)]
+ _ (promise;future (mapM io;Monad<IO> ((flip stm;write!) mailbox) (#;Cons message unprocessed-messages)))]
+ (wrap (#;Right new-server))))
+ ))))
+ #end (lambda [_ server] (exec (io;run (poison server))
+ (:: Monad<Promise> wrap [])))})))]
+ (update@ #obituary (: (-> (promise;Promise [(Maybe Text) (Actor ($ 0) ($ 1)) (List ($ 1))])
+ (promise;Promise [(Maybe Text) ($ 0) (List ($ 1))]))
+ (lambda [process]
+ (do Monad<Promise>
+ [[_ server unprocessed-messages-0] process
+ [cause state unprocessed-messages-1] (get@ #obituary server)]
+ (wrap [cause state (List/append unprocessed-messages-0 unprocessed-messages-1)]))))
+ ka-actor))))
+
+## [Syntax]
+(type: Method
+ {#name Text
+ #vars (List Text)
+ #args (List [Text AST])
+ #return AST
+ #body AST})
+
+(def: method^
+ (Syntax Method)
+ (s;form (do s;Monad<Syntax>
+ [_ (s;symbol! ["" "method:"])
+ vars (s;default (list) (s;tuple (s;some s;local-symbol)))
+ [name args] (s;form ($_ s;seq
+ s;local-symbol
+ (s;many common;typed-arg)
+ ))
+ return s;any
+ body s;any]
+ (wrap {#name name
+ #vars vars
+ #args args
+ #return return
+ #body body}))))
+
+(def: stop^
+ (Syntax AST)
+ (s;form (do s;Monad<Syntax>
+ [_ (s;symbol! ["" "stop:"])]
+ s;any)))
+
+(def: actor-decl^
+ (Syntax [(List Text) Text (List [Text AST])])
+ (s;seq (s;default (list) (s;tuple (s;some s;local-symbol)))
+ (s;either (s;form (s;seq s;local-symbol (s;many common;typed-arg)))
+ (s;seq s;local-symbol (:: s;Monad<Syntax> wrap (list))))))
+
+(def: (actor-def-decl [_vars _name _args] return-type)
+ (-> [(List Text) Text (List [Text AST])] AST (List AST))
+ (let [decl (` ((~ (ast;symbol ["" (format _name "//new")])) (~@ (List/map (|>. product;left [""] ast;symbol) _args))))
+ base-type (` (-> (~@ (List/map product;right _args))
+ (~ return-type)))
+ type (case _vars
+ #;Nil
+ base-type
+
+ _
+ (` (All [(~@ (List/map (|>. [""] ast;symbol) _vars))]
+ (~ base-type))))]
+ (list decl
+ type)))
+
+(syntax: #export (actor: {_ex-lev common;export-level}
+ {(^@ decl [_vars _name _args]) actor-decl^}
+ state-type
+ {methods (s;many method^)}
+ {?stop (s;opt stop^)})
+ {#;doc (doc "Allows defining an actor, with a set of methods that can be called on it."
+ "The methods can return promisehronous outputs."
+ "The methods can access the actor's state through the *state* variable."
+ "The methods can also access the actor itself through the *self* variable."
+
+ (actor: #export Adder
+ Int
+
+ (method: (count! {to-add Int})
+ [Int Int]
+ (if (>= 0 to-add)
+ (do Monad<Promise>
+ [#let [new-state (+ to-add *state*)]]
+ (wrap (#;Right [new-state [*state* new-state]])))
+ (do Monad<Promise>
+ []
+ (wrap (#;Left "Can't add negative numbers!")))))
+ ))}
+ (with-gensyms [g!message g!error g!return g!error g!output]
+ (let [g!state-name (ast;symbol ["" (format _name "//STATE")])
+ g!protocol-name (ast;symbol ["" (format _name "//PROTOCOL")])
+ g!self (ast;symbol ["" "*self*"])
+ g!state (ast;symbol ["" "*state*"])
+ g!cause (ast;symbol ["" "*cause*"])
+ g!stop-body (default (` (:: promise;Monad<Promise> (~' wrap) [])) ?stop)
+ protocol (List/map (lambda [(^slots [#name #vars #args #return #body])]
+ (` ((~ (ast;tag ["" name])) [(~@ (List/map product;right args))] (promise;Promise (~ return)))))
+ methods)
+ protocol-pm (List/map (: (-> Method [AST AST])
+ (lambda [(^slots [#name #vars #args #return #body])]
+ (let [arg-names (|> (list;size args) (list;range+ +1) (List/map (|>. Nat/encode [""] ast;symbol)))
+ body-func (` (: (-> (~ g!state-name) (~@ (List/map product;right args)) (promise;Promise (Error [(~ g!state-name) (~ return)])))
+ (lambda (~ (ast;symbol ["" _name])) [(~ g!state) (~@ (List/map (|>. product;left [""] ast;symbol) args))]
+ (do promise;Monad<Promise>
+ []
+ (~ body)))))]
+ [(` [[(~@ arg-names)] (~ g!return)])
+ (` (do promise;Monad<Promise>
+ [(~ g!output) ((~ body-func) (~ g!state) (~@ arg-names))]
+ (case (~ g!output)
+ (#;Right [(~ g!state) (~ g!output)])
+ (exec (io;run (promise;resolve (~ g!output) (~ g!return)))
+ ((~' wrap) (#;Right (~ g!state))))
+
+ (#;Left (~ g!error))
+ ((~' wrap) (#;Left (~ g!error))))
+ ))])))
+ methods)
+ g!proc (` {#step (lambda [(~ g!self) (~ g!message) (~ g!state)]
+ (case (~ g!message)
+ (~@ (if (=+ +1 (list;size protocol-pm))
+ (List/join (List/map (lambda [[pattern clause]]
+ (list pattern clause))
+ protocol-pm))
+ (List/join (List/map (lambda [[method [pattern clause]]]
+ (list (` ((~ (ast;tag ["" (get@ #name method)])) (~ pattern)))
+ clause))
+ (list;zip2 methods protocol-pm)))))
+ ))
+ #end (lambda [(~ g!cause) (~ g!state)]
+ (do promise;Monad<Promise>
+ []
+ (~ g!stop-body)))})
+ g!actor-name (ast;symbol ["" _name])
+ g!methods (List/map (: (-> Method AST)
+ (lambda [(^slots [#name #vars #args #return #body])]
+ (let [arg-names (|> (list;size args) (list;range+ +1) (List/map (|>. Nat/encode [""] ast;symbol)))
+ type (` (-> (~@ (List/map product;right args))
+ (~ g!actor-name)
+ (promise;Promise (~ return))))]
+ (` (def: (~@ (common;gen-export-level _ex-lev)) ((~ (ast;symbol ["" name])) (~@ arg-names) (~ g!self))
+ (~ type)
+ (let [(~ g!output) (promise;promise (~ return))]
+ (exec (send ((~ (ast;tag ["" name])) [[(~@ arg-names)] (~ g!output)]) (~ g!self))
+ (~ g!output))))))))
+ methods)]
+ (wrap (list& (` (type: (~@ (common;gen-export-level _ex-lev)) (~ g!state-name) (~ state-type)))
+ (` (type: (~@ (common;gen-export-level _ex-lev)) (~ g!protocol-name) (~@ protocol)))
+ (` (type: (~@ (common;gen-export-level _ex-lev)) (~ g!actor-name) (Actor (~ g!state-name) (~ g!protocol-name))))
+ (` (def: (~@ (common;gen-export-level _ex-lev)) (~@ (actor-def-decl decl (` (Proc (~ g!state-name) (~ g!protocol-name)))))
+ (~ g!proc)))
+ g!methods))
+ )))
diff --git a/stdlib/source/lux/concurrency/atom.lux b/stdlib/source/lux/concurrency/atom.lux
new file mode 100644
index 000000000..3905ee7ca
--- /dev/null
+++ b/stdlib/source/lux/concurrency/atom.lux
@@ -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/.
+
+(;module:
+ lux
+ (lux (codata [io #- run])
+ host)
+ )
+
+(jvm-import (java.util.concurrent.atomic.AtomicReference V)
+ (new [V])
+ (compareAndSet [V V] boolean)
+ (get [] V))
+
+(type: #export (Atom a)
+ (AtomicReference a))
+
+(def: #export (atom value)
+ (All [a] (-> a (Atom a)))
+ (AtomicReference.new [value]))
+
+(def: #export (get atom)
+ (All [a] (-> (Atom a) (IO a)))
+ (io (AtomicReference.get [] atom)))
+
+(def: #export (compare-and-swap old new atom)
+ (All [a] (-> a a (Atom a) (IO Bool)))
+ (io (AtomicReference.compareAndSet [old new] atom)))
+
+(def: #export (update f atom)
+ (All [a] (-> (-> a a) (Atom a) (IO Unit)))
+ (io (let [old (AtomicReference.get [] atom)]
+ (if (AtomicReference.compareAndSet [old (f old)] atom)
+ []
+ (io;run (update f atom))))))
+
+(def: #export (set value atom)
+ (All [a] (-> a (Atom a) (IO Unit)))
+ (update (lambda [_] value) atom))
diff --git a/stdlib/source/lux/concurrency/frp.lux b/stdlib/source/lux/concurrency/frp.lux
new file mode 100644
index 000000000..0efa9f837
--- /dev/null
+++ b/stdlib/source/lux/concurrency/frp.lux
@@ -0,0 +1,194 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control functor
+ applicative
+ monad
+ eq)
+ (codata [io #- run]
+ function)
+ (data (struct [list])
+ text/format)
+ [compiler]
+ (macro ["s" syntax #+ syntax: Syntax]))
+ (.. ["&" promise]))
+
+## [Types]
+(type: #export (Chan a)
+ (&;Promise (Maybe [a (Chan a)])))
+
+## [Syntax]
+(syntax: #export (chan {?type (s;opt s;any)})
+ {#;doc (doc "Makes an uninitialized Chan (in this case, of Unit)."
+ (chan Unit))}
+ (case ?type
+ (#;Some type)
+ (wrap (list (` (: (Chan (~ type))
+ (&;promise)))))
+
+ #;None
+ (wrap (list (` (&;promise))))))
+
+## [Values]
+(def: #export (filter p xs)
+ (All [a] (-> (-> a Bool) (Chan a) (Chan a)))
+ (do &;Monad<Promise>
+ [?x+xs xs]
+ (case ?x+xs
+ #;None (wrap #;None)
+ (#;Some [x xs']) (if (p x)
+ (wrap (#;Some [x (filter p xs')]))
+ (filter p xs')))))
+
+(def: #export (write value chan)
+ (All [a] (-> a (Chan a) (IO (Maybe (Chan a)))))
+ (case (&;poll chan)
+ (^template [<case> <chan-to-write>]
+ <case>
+ (do Monad<IO>
+ [#let [new-tail (&;promise)]
+ done? (&;resolve (#;Some [value new-tail]) <chan-to-write>)]
+ (if done?
+ (wrap (#;Some new-tail))
+ (write value <chan-to-write>))))
+ ([#;None chan]
+ [(#;Some (#;Some [_ chan'])) chan'])
+
+ _
+ (:: Monad<IO> wrap #;None)
+ ))
+
+(def: #export (close chan)
+ (All [a] (-> (Chan a) (IO Bool)))
+ (case (&;poll chan)
+ (^template [<case> <chan-to-write>]
+ <case>
+ (do Monad<IO>
+ [done? (&;resolve #;None <chan-to-write>)]
+ (if done?
+ (wrap true)
+ (close <chan-to-write>))))
+ ([#;None chan]
+ [(#;Some (#;Some [_ chan'])) chan'])
+
+ _
+ (:: Monad<IO> wrap false)
+ ))
+
+(def: (pipe' input output)
+ (All [a] (-> (Chan a) (Chan a) (&;Promise Unit)))
+ (do &;Monad<Promise>
+ [?x+xs input]
+ (case ?x+xs
+ #;None (wrap [])
+ (#;Some [x input']) (case (io;run (write x output))
+ #;None
+ (wrap [])
+
+ (#;Some output')
+ (pipe' input' output')))))
+
+(def: #export (pipe input output)
+ (All [a] (-> (Chan a) (Chan a) (&;Promise Unit)))
+ (do &;Monad<Promise>
+ [_ (pipe' input output)]
+ (exec (io;run (close output))
+ (wrap []))))
+
+(def: #export (merge xss)
+ (All [a] (-> (List (Chan a)) (Chan a)))
+ (let [output (chan ($ 0))]
+ (exec (do &;Monad<Promise>
+ [_ (mapM @ (lambda [input] (pipe' input output)) xss)]
+ (exec (io;run (close output))
+ (wrap [])))
+ output)))
+
+(def: #export (fold f init xs)
+ (All [a b] (-> (-> b a (&;Promise a)) a (Chan b) (&;Promise a)))
+ (do &;Monad<Promise>
+ [?x+xs xs]
+ (case ?x+xs
+ #;None (wrap init)
+ (#;Some [x xs']) (do @
+ [init' (f x init)]
+ (fold f init' xs')))))
+
+(def: (no-dups' eq last-one xs)
+ (All [a] (-> (Eq a) a (Chan a) (Chan a)))
+ (let [(^open) eq]
+ (do &;Monad<Promise>
+ [?x+xs xs]
+ (case ?x+xs
+ #;None (wrap #;None)
+ (#;Some [x xs']) (if (= x last-one)
+ (no-dups' eq last-one xs')
+ (wrap (#;Some [x (no-dups' eq x xs')])))))))
+
+(def: #export (no-dups eq xs)
+ {#;doc "Multiple consecutive equal values in the input channel will just be single values in the output channel."}
+ (All [a] (-> (Eq a) (Chan a) (Chan a)))
+ (let [(^open) eq]
+ (do &;Monad<Promise>
+ [?x+xs xs]
+ (case ?x+xs
+ #;None (wrap #;None)
+ (#;Some [x xs']) (wrap (#;Some [x (no-dups' eq x xs')]))))))
+
+(def: #export (consume xs)
+ (All [a] (-> (Chan a) (&;Promise (List a))))
+ (do &;Monad<Promise>
+ [?x+xs' xs]
+ (case ?x+xs'
+ #;None
+ (wrap #;Nil)
+
+ (#;Some [x xs'])
+ (do @
+ [=xs (consume xs')]
+ (wrap (#;Cons x =xs))))))
+
+(def: #export (as-chan !x)
+ (All [a] (-> (&;Promise a) (Chan a)))
+ (do &;Monad<Promise>
+ [x !x]
+ (wrap (#;Some [x (wrap #;None)]))))
+
+## [Structures]
+(struct: #export _ (Functor Chan)
+ (def: (map f xs)
+ (:: &;Functor<Promise> map
+ (lambda [?x+xs]
+ (case ?x+xs
+ #;None #;None
+ (#;Some [x xs']) (#;Some [(f x) (map f xs')])))
+ xs)))
+
+(struct: #export _ (Applicative Chan)
+ (def: functor Functor<Chan>)
+
+ (def: (wrap a)
+ (let [(^open) &;Monad<Promise>]
+ (wrap (#;Some [a (wrap #;None)]))))
+
+ (def: (apply ff fa)
+ (let [fb (chan ($ 1))]
+ (exec (let [(^open) Functor<Chan>]
+ (map (lambda [f] (pipe (map f fa) fb))
+ ff))
+ fb))))
+
+(struct: #export _ (Monad Chan)
+ (def: applicative Applicative<Chan>)
+
+ (def: (join mma)
+ (let [output (chan ($ 0))]
+ (exec (let [(^open) Functor<Chan>]
+ (map (lambda [ma]
+ (pipe ma output))
+ mma))
+ output))))
diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux
new file mode 100644
index 000000000..b765acc4d
--- /dev/null
+++ b/stdlib/source/lux/concurrency/promise.lux
@@ -0,0 +1,233 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (data (struct [list #* "" Functor<List>])
+ number
+ text/format
+ error)
+ (codata [io #- run]
+ function)
+ (control functor
+ applicative
+ monad)
+ [compiler]
+ (macro ["s" syntax #+ syntax: Syntax])
+ (concurrency [atom #+ Atom atom])
+ host
+ ))
+
+(jvm-import java.lang.Runtime
+ (#static getRuntime [] Runtime)
+ (availableProcessors [] int))
+
+(jvm-import java.lang.Runnable)
+
+(jvm-import java.lang.Thread
+ (new [Runnable])
+ (start [] void))
+
+(jvm-import java.util.concurrent.Executor
+ (execute [Runnable] void))
+
+(jvm-import java.util.concurrent.TimeUnit
+ (#enum MILLISECONDS))
+
+(jvm-import (java.util.concurrent.ScheduledFuture a))
+
+(jvm-import java.util.concurrent.ScheduledThreadPoolExecutor
+ (new [int])
+ (schedule [Runnable long TimeUnit] (ScheduledFuture Object)))
+
+(def: #export concurrency-level
+ Nat
+ (|> (Runtime.getRuntime [])
+ (Runtime.availableProcessors [])
+ int-to-nat))
+
+(def: executor
+ ScheduledThreadPoolExecutor
+ (ScheduledThreadPoolExecutor.new [(nat-to-int concurrency-level)]))
+
+(syntax: (runnable expr)
+ (wrap (list (`' (object [java.lang.Runnable]
+ []
+ (java.lang.Runnable (run) void
+ (exec (~ expr)
+ [])))))))
+
+(type: (Promise-State a)
+ {#value (Maybe a)
+ #observers (List (-> a (IO Unit)))})
+
+(type: #export (Promise a)
+ {#;doc "Represents values produced by promisehronous computations (unlike IO, which is synchronous)."}
+ (Atom (Promise-State a)))
+
+(def: #hidden (promise' ?value)
+ (All [a] (-> (Maybe a) (Promise a)))
+ (atom {#value ?value
+ #observers (list)}))
+
+(syntax: #export (promise {?type (s;opt s;any)})
+ {#;doc (doc "Makes an uninitialized Promise (in this example, of Unit)."
+ (promise Unit))}
+ (case ?type
+ (#;Some type)
+ (wrap (list (` (: (Promise (~ type))
+ (promise' #;None)))))
+
+ #;None
+ (wrap (list (` (promise' #;None))))))
+
+(def: #export (poll promise)
+ {#;doc "Checks whether an Promise's value has already been resolved."}
+ (All [a] (-> (Promise a) (Maybe a)))
+ (|> (atom;get promise)
+ io;run
+ (get@ #value)))
+
+(def: #export (resolve value promise)
+ {#;doc "Sets an Promise's value if it hasn't been done yet."}
+ (All [a] (-> a (Promise a) (IO Bool)))
+ (do Monad<IO>
+ [old (atom;get promise)]
+ (case (get@ #value old)
+ (#;Some _)
+ (wrap false)
+
+ #;None
+ (do @
+ [#let [new (set@ #value (#;Some value) old)]
+ succeeded? (atom;compare-and-swap old new promise)]
+ (if succeeded?
+ (do @
+ [_ (mapM @ (lambda [f] (f value))
+ (get@ #observers old))]
+ (wrap true))
+ (resolve value promise))))))
+
+(def: (await f promise)
+ (All [a] (-> (-> a (IO Unit)) (Promise a) Unit))
+ (let [old (io;run (atom;get promise))]
+ (case (get@ #value old)
+ (#;Some value)
+ (io;run (f value))
+
+ #;None
+ (let [new (update@ #observers (|>. (#;Cons f)) old)]
+ (if (io;run (atom;compare-and-swap old new promise))
+ []
+ (await f promise))))))
+
+(struct: #export _ (Functor Promise)
+ (def: (map f fa)
+ (let [fb (promise ($ 1))]
+ (exec (await (lambda [a] (do Monad<IO>
+ [_ (resolve (f a) fb)]
+ (wrap [])))
+ fa)
+ fb))))
+
+(struct: #export _ (Applicative Promise)
+ (def: functor Functor<Promise>)
+
+ (def: (wrap a)
+ (atom {#value (#;Some a)
+ #observers (list)}))
+
+ (def: (apply ff fa)
+ (let [fb (promise ($ 1))]
+ (exec (await (lambda [f]
+ (io (await (lambda [a] (do Monad<IO>
+ [_ (resolve (f a) fb)]
+ (wrap [])))
+ fa)))
+ ff)
+ fb))
+ ))
+
+(struct: #export _ (Monad Promise)
+ (def: applicative Applicative<Promise>)
+
+ (def: (join mma)
+ (let [ma (promise ($ 0))]
+ (exec (await (lambda [ma']
+ (io (await (lambda [a']
+ (do Monad<IO>
+ [_ (resolve a' ma)]
+ (wrap [])))
+ ma')))
+ mma)
+ ma))))
+
+(def: #export (seq left right)
+ {#;doc "Sequencing combinator."}
+ (All [a b] (-> (Promise a) (Promise b) (Promise [a b])))
+ (do Monad<Promise>
+ [a left
+ b right]
+ (wrap [a b])))
+
+(def: #export (alt left right)
+ {#;doc "Heterogeneous alternative combinator."}
+ (All [a b] (-> (Promise a) (Promise b) (Promise (| a b))))
+ (let [a|b (promise (Either ($ 0) ($ 1)))]
+ (let% [<sides> (do-template [<promise> <tag>]
+ [(await (lambda [value]
+ (do Monad<IO>
+ [_ (resolve (<tag> value) a|b)]
+ (wrap [])))
+ <promise>)]
+
+ [left #;Left]
+ [right #;Right]
+ )]
+ (exec <sides>
+ a|b))))
+
+(def: #export (either left right)
+ {#;doc "Homogeneous alternative combinator."}
+ (All [a] (-> (Promise a) (Promise a) (Promise a)))
+ (let [left||right (promise ($ 0))]
+ (let% [<sides> (do-template [<promise>]
+ [(await [(lambda [value]
+ (do Monad<IO>
+ [_ (resolve value left||right)]
+ (wrap [])))]
+ <promise>)]
+
+ [left]
+ [right]
+ )]
+ (exec <sides>
+ left||right))))
+
+(def: #export (future computation)
+ {#;doc "Runs computation on it's own process and returns an Promise that will eventually host it's result."}
+ (All [a] (-> (IO a) (Promise a)))
+ (let [!out (promise ($ 0))]
+ (exec (Thread.start [] (Thread.new [(runnable (io;run (resolve (io;run computation)
+ !out)))]))
+ !out)))
+
+(def: #export (wait time)
+ (-> Nat (Promise Unit))
+ (let [!out (promise Unit)]
+ (exec (ScheduledThreadPoolExecutor.schedule [(runnable (io;run (resolve [] !out)))
+ (nat-to-int time)
+ TimeUnit.MILLISECONDS]
+ executor)
+ !out)))
+
+(def: #export (time-out time promise)
+ (All [a] (-> Nat (Promise a) (Promise (Maybe a))))
+ (alt (wait time) promise))
+
+(def: #export (delay time value)
+ {#;doc "Delivers a value after a certain period has passed."}
+ (All [a] (-> Nat a (Promise a)))
+ (:: Functor<Promise> map (const value) (wait time)))
diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux
new file mode 100644
index 000000000..80633a41e
--- /dev/null
+++ b/stdlib/source/lux/concurrency/stm.lux
@@ -0,0 +1,237 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control functor
+ applicative
+ monad)
+ (codata [io #- run])
+ (data (struct [list #* "List/" Functor<List>]
+ [dict #+ Dict])
+ [product]
+ [text]
+ text/format)
+ host
+ [compiler]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax])
+ (concurrency [atom #+ Atom atom]
+ [promise #+ Promise "Promise/" Monad<Promise>]
+ [frp])
+ ))
+
+(type: (Var-State a)
+ {#value a
+ #observers (Dict Text (-> a (IO Unit)))})
+
+(type: #export (Var a)
+ (Atom (Var-State a)))
+
+(type: (Tx-Frame a)
+ {#var (Var a)
+ #original a
+ #current a})
+
+(type: Tx
+ (List (Ex [a] (Tx-Frame a))))
+
+(type: #export (STM a)
+ (-> Tx [Tx a]))
+
+(def: #export (var value)
+ (All [a] (-> a (Var a)))
+ (atom;atom {#value value
+ #observers (dict;new text;Hash<Text>)}))
+
+(def: raw-read
+ (All [a] (-> (Var a) a))
+ (|>. atom;get io;run (get@ #value)))
+
+(def: (find-var-value var tx)
+ (All [a] (-> (Var a) Tx (Maybe a)))
+ (:! (Maybe ($ 0))
+ (find (: (-> (Ex [a] (Tx-Frame a))
+ (Maybe Unit))
+ (lambda [[_var _original _current]]
+ (:! (Maybe Unit)
+ (if (== (:! (Var Unit) var)
+ (:! (Var Unit) _var))
+ (#;Some _current)
+ #;None))))
+ tx)))
+
+(def: #export (read var)
+ (All [a] (-> (Var a) (STM a)))
+ (lambda [tx]
+ (case (find-var-value var tx)
+ (#;Some value)
+ [tx value]
+
+ #;None
+ (let [value (raw-read var)]
+ [(#;Cons [var value value] tx)
+ value]))))
+
+(def: #export (read! var)
+ {#;doc "Reads var immediately, without going through a transaction."}
+ (All [a] (-> (Var a) (IO a)))
+ (|> var
+ atom;get
+ (:: Functor<IO> map (get@ #value))))
+
+(def: (update-tx-value var value tx)
+ (All [a] (-> (Var a) a Tx Tx))
+ (case tx
+ #;Nil
+ #;Nil
+
+ (#;Cons [_var _original _current] tx')
+ (if (== (:! (Var ($ 0)) var)
+ (:! (Var ($ 0)) _var))
+ (#;Cons [(:! (Var ($ 0)) _var)
+ (:! ($ 0) _original)
+ (:! ($ 0) _current)]
+ tx')
+ (#;Cons [_var _original _current]
+ (update-tx-value var value tx')))
+ ))
+
+(def: #export (write value var)
+ (All [a] (-> a (Var a) (STM Unit)))
+ (lambda [tx]
+ (case (find-var-value var tx)
+ (#;Some _)
+ [(update-tx-value var value tx)
+ []]
+
+ #;None
+ [(#;Cons [var (raw-read var) value] tx)
+ []])))
+
+(def: #export (write! new-value var)
+ {#;doc "Writes value to var immediately, without going through a transaction."}
+ (All [a] (-> a (Var a) (IO Unit)))
+ (do Monad<IO>
+ [old (atom;get var)
+ #let [old-value (get@ #value old)
+ new (set@ #value new-value old)]
+ succeeded? (atom;compare-and-swap old new var)]
+ (if succeeded?
+ (do @
+ [_ (|> old
+ (get@ #observers)
+ dict;values
+ (mapM @ (lambda [f] (f new-value))))]
+ (wrap []))
+ (write! new-value var))))
+
+(def: #export (unfollow label target)
+ (All [a] (-> Text (Var a) (IO Unit)))
+ (do Monad<IO>
+ [[value observers] (atom;get target)]
+ (atom;set [value (dict;remove label observers)]
+ target)))
+
+(def: #export (follow label target)
+ {#;doc "Creates a channel (identified by a given text) that will receive all changes to the value of the given var."}
+ (All [a] (-> Text (Var a) (IO (frp;Chan a))))
+ (let [head (frp;chan ($ 0))
+ chan-var (var head)
+ observer (lambda [value]
+ (case (io;run (|> chan-var raw-read (frp;write value)))
+ #;None
+ ## By closing the output Chan, the
+ ## observer becomes obsolete.
+ (unfollow label chan-var)
+
+ (#;Some tail')
+ (write! tail' chan-var)))]
+ (do Monad<IO>
+ [_ (atom;update (lambda [[value observers]]
+ [value (dict;put label observer observers)])
+ target)]
+ (wrap head))))
+
+(struct: #export _ (Functor STM)
+ (def: (map f fa)
+ (lambda [tx]
+ (let [[tx' a] (fa tx)]
+ [tx' (f a)]))))
+
+(struct: #export _ (Applicative STM)
+ (def: functor Functor<STM>)
+
+ (def: (wrap a)
+ (lambda [tx] [tx a]))
+
+ (def: (apply ff fa)
+ (lambda [tx]
+ (let [[tx' f] (ff tx)
+ [tx'' a] (fa tx')]
+ [tx'' (f a)]))))
+
+(struct: #export _ (Monad STM)
+ (def: applicative Applicative<STM>)
+
+ (def: (join mma)
+ (lambda [tx]
+ (let [[tx' ma] (mma tx)]
+ (ma tx')))))
+
+(def: #export (update! f var)
+ (All [a] (-> (-> a a) (Var a) (Promise [a a])))
+ (promise;future (io (loop [_ []]
+ (let [(^@ state [value observers]) (io;run (atom;get var))
+ value' (f value)]
+ (if (io;run (atom;compare-and-swap state
+ [value' observers]
+ var))
+ [value value']
+ (recur [])))))))
+
+(def: #export (update f var)
+ (All [a] (-> (-> a a) (Var a) (STM [a a])))
+ (do Monad<STM>
+ [a (read var)
+ #let [a' (f a)]
+ _ (write a' var)]
+ (wrap [a a'])))
+
+(def: (can-commit? tx)
+ (-> Tx Bool)
+ (every? (lambda [[_var _original _current]]
+ (== _original (raw-read _var)))
+ tx))
+
+(def: (commit-var [_var _original _current])
+ (-> (Ex [a] (Tx-Frame a)) Unit)
+ (if (== _original _current)
+ []
+ (io;run (write! _current _var))))
+
+(def: fresh-tx Tx (list))
+
+(def: (commit' output stm-proc)
+ (All [a] (-> (Promise a) (STM a) (Promise Unit)))
+ (promise;future (io (let [[finished-tx value] (stm-proc fresh-tx)]
+ (if (can-commit? finished-tx)
+ (exec (List/map commit-var finished-tx)
+ (io;run (promise;resolve value output))
+ [])
+ (exec (commit' output stm-proc)
+ []))
+ ))))
+
+(def: #export (commit stm-proc)
+ {#;doc "Commits a transaction and returns its result (asynchronously).
+
+ Note that a transaction may be re-run an indeterminate number of times if other transactions involving the same variables successfully commit first.
+
+ For this reason, it's important to note that transactions must be free from side-effects, such as I/O."}
+ (All [a] (-> (STM a) (Promise a)))
+ (let [output (promise;promise)]
+ (exec (commit' output stm-proc)
+ output)))
diff --git a/stdlib/source/lux/control/applicative.lux b/stdlib/source/lux/control/applicative.lux
new file mode 100644
index 000000000..5d4cad0c0
--- /dev/null
+++ b/stdlib/source/lux/control/applicative.lux
@@ -0,0 +1,33 @@
+## 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/.
+
+(;module:
+ lux
+ (.. ["F" functor]))
+
+(sig: #export (Applicative f)
+ (: (F;Functor f)
+ functor)
+ (: (All [a]
+ (-> a (f a)))
+ wrap)
+ (: (All [a b]
+ (-> (f (-> a b)) (f a) (f b)))
+ apply))
+
+(def: #export (compA Applicative<F> Applicative<G>)
+ (All [F G] (-> (Applicative F) (Applicative G) (Applicative (All [a] (F (G a))))))
+ (struct (def: functor (F;compF (get@ #functor Applicative<F>)
+ (get@ #functor Applicative<G>)))
+ (def: wrap
+ (|>. (:: Applicative<G> wrap) (:: Applicative<F> wrap)))
+ (def: (apply fgf fgx)
+ (let [applyF (:: Applicative<F> apply)
+ applyG (:: Applicative<G> apply)]
+ ($_ applyF
+ (:: Applicative<F> wrap applyG)
+ fgf
+ fgx)))
+ ))
diff --git a/stdlib/source/lux/control/bounded.lux b/stdlib/source/lux/control/bounded.lux
new file mode 100644
index 000000000..291c4d8b6
--- /dev/null
+++ b/stdlib/source/lux/control/bounded.lux
@@ -0,0 +1,14 @@
+## 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/.
+
+(;module: lux)
+
+## Signatures
+(sig: #export (Bounded a)
+ (: a
+ top)
+
+ (: a
+ bottom))
diff --git a/stdlib/source/lux/control/codec.lux b/stdlib/source/lux/control/codec.lux
new file mode 100644
index 000000000..e9833ccc9
--- /dev/null
+++ b/stdlib/source/lux/control/codec.lux
@@ -0,0 +1,28 @@
+## 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/.
+
+(;module:
+ lux
+ (lux control/monad
+ data/error))
+
+## [Signatures]
+(sig: #export (Codec m a)
+ (: (-> a m)
+ encode)
+ (: (-> m (Error a))
+ decode))
+
+## [Values]
+(def: #export (<.> (^open "bc:") (^open "ab:"))
+ (All [a b c] (-> (Codec c b) (Codec b a) (Codec c a)))
+ (struct
+ (def: encode (|>. ab:encode bc:encode))
+
+ (def: (decode cy)
+ (do Monad<Error>
+ [by (bc:decode cy)]
+ (ab:decode by)))
+ ))
diff --git a/stdlib/source/lux/control/comonad.lux b/stdlib/source/lux/control/comonad.lux
new file mode 100644
index 000000000..801dbb479
--- /dev/null
+++ b/stdlib/source/lux/control/comonad.lux
@@ -0,0 +1,54 @@
+## 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/.
+
+(;module:
+ lux
+ ["F" ../functor]
+ [lux/data/struct/list #* "" Fold<List>])
+
+## [Signatures]
+(sig: #export (CoMonad w)
+ (: (F;Functor w)
+ functor)
+ (: (All [a]
+ (-> (w a) a))
+ unwrap)
+ (: (All [a]
+ (-> (w a) (w (w a))))
+ split))
+
+## [Syntax]
+(macro: #export (be tokens state)
+ {#;doc (doc "A co-monadic parallel to the \"do\" macro."
+ (let [square (lambda [n] (* n n))]
+ (be CoMonad<Stream>
+ [inputs (iterate inc 2)]
+ (square (head inputs)))))}
+ (case tokens
+ (#;Cons comonad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil)))
+ (let [g!@ (: AST [["" -1 -1] (#;SymbolS ["" "@"])])
+ g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])])
+ g!split (: AST [["" -1 -1] (#;SymbolS ["" " split "])])
+ body' (fold (: (-> [AST AST] AST AST)
+ (lambda [binding body']
+ (let [[var value] binding]
+ (case var
+ [_ (#;TagS ["" "let"])]
+ (` (let (~ value) (~ body')))
+
+ _
+ (` (|> (~ value) (~ g!split) ((~ g!map) (lambda [(~ var)] (~ body')))))
+ ))))
+ body
+ (reverse (as-pairs bindings)))]
+ (#;Right [state (#;Cons (` (;_lux_case (~ comonad)
+ (~ g!@)
+ (;_lux_case (~ g!@)
+ {#functor {#F;map (~ g!map)} #unwrap (~' unwrap) #split (~ g!split)}
+ (~ body'))))
+ #;Nil)]))
+
+ _
+ (#;Left "Wrong syntax for be")))
diff --git a/stdlib/source/lux/control/effect.lux b/stdlib/source/lux/control/effect.lux
new file mode 100644
index 000000000..cbd24c7f9
--- /dev/null
+++ b/stdlib/source/lux/control/effect.lux
@@ -0,0 +1,315 @@
+## 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/.
+
+(;module: lux
+ (lux (control ["F" functor]
+ applicative
+ monad)
+ (codata [io #- run])
+ (data (struct [list "List/" Monad<List>])
+ [number "Nat/" Codec<Text,Nat>]
+ text/format
+ error)
+ [compiler]
+ [macro]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax]
+ (syntax [common]))
+ [type]
+ (type ["tc" check])))
+
+## [Type]
+(type: #export (Eff F a)
+ (#Pure a)
+ (#Effect (F (Eff F a))))
+
+(sig: #export (Handler E M)
+ (: (All [a] (-> (Eff E a) (M a)))
+ handle))
+
+## [Values]
+(struct: #export (Functor<Eff> dsl)
+ (All [F] (-> (F;Functor F) (F;Functor (Eff F))))
+ (def: (map f ea)
+ (case ea
+ (#Pure a)
+ (#Pure (f a))
+
+ (#Effect value)
+ (#Effect (:: dsl map (map f) value)))))
+
+(struct: #export (Applicative<Eff> dsl)
+ (All [F] (-> (F;Functor F) (Applicative (Eff F))))
+ (def: functor (Functor<Eff> dsl))
+
+ (def: (wrap a)
+ (#Pure a))
+
+ (def: (apply ef ea)
+ (case [ef ea]
+ [(#Pure f) (#Pure a)]
+ (#Pure (f a))
+
+ [(#Pure f) (#Effect fa)]
+ (#Effect (:: dsl map
+ (:: (Functor<Eff> dsl) map f)
+ fa))
+
+ [(#Effect ff) _]
+ (#Effect (:: dsl map
+ (lambda [f] (apply f ea))
+ ff))
+ )))
+
+(struct: #export (Monad<Eff> dsl)
+ (All [F] (-> (F;Functor F) (Monad (Eff F))))
+ (def: applicative (Applicative<Eff> dsl))
+
+ (def: (join efefa)
+ (case efefa
+ (#Pure efa)
+ (case efa
+ (#Pure a)
+ (#Pure a)
+
+ (#Effect fa)
+ (#Effect fa))
+
+ (#Effect fefa)
+ (#Effect (:: dsl map
+ (:: (Monad<Eff> dsl) join)
+ fefa))
+ )))
+
+(type: (@| L R)
+ (All [a] (| (L a) (R a))))
+
+(def: #export (combine-functors left right)
+ (All [L R]
+ (-> (F;Functor L) (F;Functor R)
+ (F;Functor (@| L R))))
+ (struct
+ (def: (map f l|r)
+ (case l|r
+ (+0 l) (+0 (:: left map f l))
+ (+1 r) (+1 (:: right map f r)))
+ )))
+
+(def: #export (combine-handlers Monad<M> left right)
+ (All [L R M]
+ (-> (Monad M)
+ (Handler L M) (Handler R M)
+ (Handler (@| L R) M)))
+ (struct
+ (def: (handle el|r)
+ (case el|r
+ (#Pure x)
+ (:: Monad<M> wrap x)
+
+ (#Effect l|r)
+ (case l|r
+ (#;Left l) (:: left handle (#Effect l))
+ (#;Right r) (:: right handle (#Effect r))
+ ))
+ )))
+
+## [Syntax]
+(syntax: #export (||E {effects (s;some s;any)})
+ (do @
+ [g!a (compiler;gensym "g!a")
+ #let [effects@a (List/map (lambda [eff] (` ((~ eff) (~ g!a))))
+ effects)]]
+ (wrap (list (` (All [(~ g!a)]
+ (| (~@ effects@a))))
+ ))))
+
+(syntax: #export (||F {functors (s;many s;any)})
+ (wrap (list (` ($_ ;;combine-functors (~@ functors))))))
+
+(syntax: #export (||H monad {handlers (s;many s;any)})
+ (do @
+ [g!combiner (compiler;gensym "")]
+ (wrap (list (` (let [(~ g!combiner) (;;combine-handlers (~ monad))]
+ ($_ (~ g!combiner) (~@ handlers))))))))
+
+(type: Op
+ {#name Text
+ #inputs (List AST)
+ #output AST})
+
+(def: op^
+ (Syntax Op)
+ (s;form (s;either ($_ s;seq
+ s;local-symbol
+ (s;tuple (s;some s;any))
+ s;any)
+ ($_ s;seq
+ s;local-symbol
+ (:: s;Monad<Syntax> wrap (list))
+ s;any))))
+
+(syntax: #export (effect: {exp-lvl common;export-level}
+ {name s;local-symbol}
+ {ops (s;many op^)})
+ (do @
+ [g!output (compiler;gensym "g!output")
+ #let [op-types (List/map (lambda [op]
+ (let [g!tag (ast;tag ["" (get@ #name op)])
+ g!inputs (` [(~@ (get@ #inputs op))])
+ g!output (` (-> (~ (get@ #output op)) (~ g!output)))]
+ (` ((~ g!tag) (~ g!inputs) (~ g!output)))))
+ ops)
+ type-name (ast;symbol ["" name])
+ type-def (` (type: (~@ (common;gen-export-level exp-lvl))
+ ((~ type-name) (~ g!output))
+ (~@ op-types)))
+ op-tags (List/map (|>. (get@ #name) [""] ast;tag (list) ast;tuple)
+ ops)
+ functor-def (` (struct: (~@ (common;gen-export-level exp-lvl)) (~' _) (F;Functor (~ type-name))
+ (def: ((~' map) (~' f) (~' fa))
+ (case (~' fa)
+ (^template [(~' <tag>)]
+ ((~' <tag>) (~' params) (~' cont))
+ ((~' <tag>) (~' params) (. (~' f) (~' cont))))
+ ((~@ op-tags))))
+ ))
+ function-defs (List/map (lambda [op]
+ (let [g!name (ast;symbol ["" (get@ #name op)])
+ g!tag (ast;tag ["" (get@ #name op)])
+ g!params (: (List AST)
+ (case (list;size (get@ #inputs op))
+ +0 (list)
+ s (|> (list;range+ +0 (dec+ s))
+ (List/map (|>. Nat/encode
+ (format "_")
+ [""]
+ ast;symbol)))))]
+ (` (def: (~@ (common;gen-export-level exp-lvl)) ((~ g!name) (~@ g!params))
+ (-> (~@ (get@ #inputs op))
+ ((~ type-name) (~ (get@ #output op))))
+ ((~ g!tag) [(~@ g!params)] ;id)))))
+ ops)]]
+ (wrap (list& type-def
+ functor-def
+ function-defs))))
+
+(type: Translation
+ {#effect Ident
+ #base AST
+ #monad AST})
+
+(def: translation^
+ (Syntax Translation)
+ (s;form (do s;Monad<Syntax>
+ [_ (s;symbol! ["" "=>"])]
+ (s;seq s;symbol
+ (s;tuple (s;seq s;any
+ s;any))))))
+
+(syntax: #export (handler: {exp-lvl common;export-level}
+ {name s;local-symbol}
+ {[effect base monad] translation^}
+ {defs (s;many (common;def *compiler*))})
+ (do @
+ [(^@ effect [e-module _]) (compiler;un-alias effect)
+ g!input (compiler;gensym "g!input")
+ g!cont (compiler;gensym "g!cont")
+ g!value (compiler;gensym "value")
+ #let [g!cases (|> defs
+ (List/map (lambda [def]
+ (let [g!tag (ast;tag [e-module (get@ #common;def-name def)])
+ g!args (List/map (|>. [""] ast;symbol)
+ (get@ #common;def-args def))
+ eff-calc (case (get@ #common;def-type def)
+ #;None
+ (get@ #common;def-value def)
+
+ (#;Some type)
+ (` (: (~ type) (~ (get@ #common;def-value def)))))
+ invocation (case g!args
+ #;Nil
+ eff-calc
+
+ _
+ (` ((~ eff-calc) (~@ g!args))))]
+ (list (` ((~ g!tag) [(~@ g!args)] (~ g!cont)))
+ (` (do (~ monad)
+ [(~ g!value) (~ invocation)]
+ ((~' handle) ((~ g!cont) (~ g!value)))))
+ ))))
+ List/join)]]
+ (wrap (list (` (struct: (~@ (common;gen-export-level exp-lvl)) (~ (ast;symbol ["" name]))
+ (;;Handler (~ (ast;symbol effect)) (~ base))
+ (def: ((~' handle) (~ g!input))
+ (case (~ g!input)
+ (#Pure (~ g!input))
+ (:: (~ monad) (~' wrap) (~ g!input))
+
+ (#Effect (~ g!input))
+ (case (~ g!input)
+ (~@ g!cases))))))))))
+
+(syntax: #export (with-handler handler body)
+ (wrap (list (` (:: (~ handler) (~' handle) (~ body))))))
+
+(def: (un-apply type-app)
+ (-> Type Type)
+ (case type-app
+ (#;AppT effect value)
+ effect
+
+ _
+ (error! (format "Wrong type format: " (type;type-to-text type-app)))))
+
+(def: (clean-effect effect)
+ (-> Type Type)
+ (case effect
+ (#;UnivQ env body)
+ (#;UnivQ (list) body)
+
+ _
+ (error! (format "Wrong effect format: " (type;type-to-text effect)))))
+
+(def: g!functor AST (ast;symbol ["" "%E"]))
+
+(syntax: #export (doE functor {bindings (s;tuple (s;some s;any))} body)
+ (do @
+ [g!output (compiler;gensym "")]
+ (wrap (list (` (let [(~ g!functor) (~ functor)]
+ (do (Monad<Eff> (~ g!functor))
+ [(~@ bindings)
+ (~ g!output) (~ body)]
+ ((~' wrap) (~ g!output)))))))))
+
+(syntax: #export (lift {value (s;alt s;symbol
+ s;any)})
+ (case value
+ (#;Left var)
+ (do @
+ [input (compiler;find-type var)
+ output compiler;expected-type]
+ (case [input output]
+ (^=> [(#;AppT eff0 _) (#;AppT stackT0 recT0)]
+ {(type;apply-type stackT0 recT0) (#;Some unfoldT0)}
+ {stackT0 (^ (#;AppT (#;NamedT (ident-for ;;Eff) _)
+ stackT1))}
+ {(type;apply-type stackT1 recT0) (#;Some unfoldT1)}
+ {(list;find (lambda [[idx effect]]
+ (if (tc;checks? (clean-effect effect) eff0)
+ (#;Some idx)
+ #;None))
+ (|> unfoldT1 type;flatten-sum (List/map un-apply) list;enumerate))
+ (#;Some idx)})
+ (wrap (list (` (#;;Effect (:: (~ g!functor) (~' map) (~' wrap) ((~ (ast;int (nat-to-int idx)))
+ (~ (ast;symbol var))))))))
+
+ _
+ (compiler;fail (format "Invalid type to lift: " (type;type-to-text output)))))
+
+ (#;Right node)
+ (do @
+ [g!value (compiler;gensym "")]
+ (wrap (list (` (let [(~ g!value) (~ node)]
+ (;;lift (~ g!value)))))))))
diff --git a/stdlib/source/lux/control/enum.lux b/stdlib/source/lux/control/enum.lux
new file mode 100644
index 000000000..63c041f95
--- /dev/null
+++ b/stdlib/source/lux/control/enum.lux
@@ -0,0 +1,24 @@
+## 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/.
+
+(;module: lux
+ (lux/control [ord]))
+
+## [Signatures]
+(sig: #export (Enum e)
+ (: (ord;Ord e) ord)
+ (: (-> e e) succ)
+ (: (-> e e) pred))
+
+## [Functions]
+(def: (range' <= succ from to)
+ (All [a] (-> (-> a a Bool) (-> a a) a a (List a)))
+ (if (<= to from)
+ (#;Cons from (range' <= succ (succ from) to))
+ #;Nil))
+
+(def: #export (range (^open) from to)
+ (All [a] (-> (Enum a) a a (List a)))
+ (range' <= succ from to))
diff --git a/stdlib/source/lux/control/eq.lux b/stdlib/source/lux/control/eq.lux
new file mode 100644
index 000000000..357780fcd
--- /dev/null
+++ b/stdlib/source/lux/control/eq.lux
@@ -0,0 +1,29 @@
+## 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/.
+
+(;module: lux)
+
+(sig: #export (Eq a)
+ (: (-> a a Bool)
+ =))
+
+(def: #export (conj left right)
+ (All [l r] (-> (Eq l) (Eq r) (Eq [l r])))
+ (struct (def: (= [a b] [x y])
+ (and (:: left = a x)
+ (:: right = b y)))))
+
+(def: #export (disj left right)
+ (All [l r] (-> (Eq l) (Eq r) (Eq (| l r))))
+ (struct (def: (= a|b x|y)
+ (case [a|b x|y]
+ [(+0 a) (+0 x)]
+ (:: left = a x)
+
+ [(+1 b) (+1 y)]
+ (:: right = b y)
+
+ _
+ false))))
diff --git a/stdlib/source/lux/control/fold.lux b/stdlib/source/lux/control/fold.lux
new file mode 100644
index 000000000..6e56dacee
--- /dev/null
+++ b/stdlib/source/lux/control/fold.lux
@@ -0,0 +1,12 @@
+## 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/.
+
+(;module: lux)
+
+## [Signatures]
+(sig: #export (Fold F)
+ (: (All [a b]
+ (-> (-> b a a) a (F b) a))
+ fold))
diff --git a/stdlib/source/lux/control/functor.lux b/stdlib/source/lux/control/functor.lux
new file mode 100644
index 000000000..711c5ae16
--- /dev/null
+++ b/stdlib/source/lux/control/functor.lux
@@ -0,0 +1,16 @@
+## 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/.
+
+(;module: lux)
+
+(sig: #export (Functor f)
+ (: (All [a b]
+ (-> (-> a b) (f a) (f b)))
+ map))
+
+(def: #export (compF Functor<F> Functor<G>)
+ (All [F G] (-> (Functor F) (Functor G) (Functor (All [a] (F (G a))))))
+ (struct (def: (map f fga)
+ (:: Functor<F> map (:: Functor<G> map f) fga))))
diff --git a/stdlib/source/lux/control/hash.lux b/stdlib/source/lux/control/hash.lux
new file mode 100644
index 000000000..d8ae926ad
--- /dev/null
+++ b/stdlib/source/lux/control/hash.lux
@@ -0,0 +1,15 @@
+## 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/.
+
+(;module:
+ lux
+ (.. eq))
+
+## [Signatures]
+(sig: #export (Hash a)
+ (: (Eq a)
+ eq)
+ (: (-> a Nat)
+ hash))
diff --git a/stdlib/source/lux/control/monad.lux b/stdlib/source/lux/control/monad.lux
new file mode 100644
index 000000000..71a873704
--- /dev/null
+++ b/stdlib/source/lux/control/monad.lux
@@ -0,0 +1,142 @@
+## 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/.
+
+(;module:
+ lux
+ (.. (functor #as F)
+ (applicative #as A)))
+
+## [Utils]
+(def: (fold f init xs)
+ (All [a b]
+ (-> (-> b a a) a (List b) a))
+ (case xs
+ #;Nil
+ init
+
+ (#;Cons x xs')
+ (fold f (f x init) xs')))
+
+(def: (map f xs)
+ (All [a b]
+ (-> (-> a b) (List a) (List b)))
+ (case xs
+ #;Nil
+ #;Nil
+
+ (#;Cons x xs')
+ (#;Cons (f x) (map f xs'))))
+
+(def: (reverse xs)
+ (All [a]
+ (-> (List a) (List a)))
+ (fold (lambda [head tail] (#;Cons head tail))
+ #;Nil
+ xs))
+
+(def: (as-pairs xs)
+ (All [a] (-> (List a) (List [a a])))
+ (case xs
+ (#;Cons x1 (#;Cons x2 xs'))
+ (#;Cons [x1 x2] (as-pairs xs'))
+
+ _
+ #;Nil))
+
+## [Signatures]
+(sig: #export (Monad m)
+ (: (A;Applicative m)
+ applicative)
+ (: (All [a]
+ (-> (m (m a)) (m a)))
+ join))
+
+## [Syntax]
+(macro: #export (do tokens state)
+ {#;doc (doc "Macro for easy concatenation of monadic operations."
+ (do Monad<Maybe>
+ [y (f1 x)
+ z (f2 z)]
+ (wrap (f3 z))))}
+ (case tokens
+ (#;Cons monad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil)))
+ (let [g!@ (: AST [["" -1 -1] (#;SymbolS ["" "@"])])
+ g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])])
+ g!join (: AST [["" -1 -1] (#;SymbolS ["" " join "])])
+ g!apply (: AST [["" -1 -1] (#;SymbolS ["" " apply "])])
+ body' (fold (: (-> [AST AST] AST AST)
+ (lambda [binding body']
+ (let [[var value] binding]
+ (case var
+ [_ (#;TagS ["" "let"])]
+ (` (let (~ value) (~ body')))
+
+ _
+ (` (|> (~ value) ((~ g!map) (lambda [(~ var)] (~ body'))) (~ g!join)))
+ ))))
+ body
+ (reverse (as-pairs bindings)))]
+ (#;Right [state (#;Cons (` (;_lux_case (~ monad)
+ (~ g!@)
+ (;_lux_case (~ g!@)
+ {#applicative {#A;functor {#F;map (~ g!map)}
+ #A;wrap (~' wrap)
+ #A;apply (~ g!apply)}
+ #join (~ g!join)}
+ (~ body'))))
+ #;Nil)]))
+
+ _
+ (#;Left "Wrong syntax for do")))
+
+## [Functions]
+(def: #export (seqM monad xs)
+ (All [M a]
+ (-> (Monad M) (List (M a)) (M (List a))))
+ (case xs
+ #;Nil
+ (:: monad wrap #;Nil)
+
+ (#;Cons x xs')
+ (do monad
+ [_x x
+ _xs (seqM monad xs')]
+ (wrap (#;Cons _x _xs)))
+ ))
+
+(def: #export (mapM monad f xs)
+ (All [M a b]
+ (-> (Monad M) (-> a (M b)) (List a) (M (List b))))
+ (case xs
+ #;Nil
+ (:: monad wrap #;Nil)
+
+ (#;Cons x xs')
+ (do monad
+ [_x (f x)
+ _xs (mapM monad f xs')]
+ (wrap (#;Cons _x _xs)))
+ ))
+
+(def: #export (foldM monad f init xs)
+ (All [M a b]
+ (-> (Monad M) (-> b a (M a)) a (List b)
+ (M a)))
+ (case xs
+ #;Nil
+ (:: monad wrap init)
+
+ (#;Cons x xs')
+ (do monad
+ [init' (f x init)]
+ (foldM monad f init' xs'))))
+
+(def: #export (liftM Monad<M> f)
+ (All [M a b]
+ (-> (Monad M) (-> a b) (-> (M a) (M b))))
+ (lambda [ma]
+ (do Monad<M>
+ [a ma]
+ (wrap (f a)))))
diff --git a/stdlib/source/lux/control/monoid.lux b/stdlib/source/lux/control/monoid.lux
new file mode 100644
index 000000000..67f6d868c
--- /dev/null
+++ b/stdlib/source/lux/control/monoid.lux
@@ -0,0 +1,13 @@
+## 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/.
+
+(;module: lux)
+
+## Signatures
+(sig: #export (Monoid a)
+ (: a
+ unit)
+ (: (-> a a a)
+ append))
diff --git a/stdlib/source/lux/control/number.lux b/stdlib/source/lux/control/number.lux
new file mode 100644
index 000000000..d6e9a42b6
--- /dev/null
+++ b/stdlib/source/lux/control/number.lux
@@ -0,0 +1,22 @@
+## 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/.
+
+(;module:
+ lux
+ (lux/control [ord]))
+
+## [Signatures]
+(sig: #export (Number n)
+ (: (ord;Ord n)
+ ord)
+
+ (do-template [<name>]
+ [(: (-> n n n) <name>)]
+ [+] [-] [*] [/] [%])
+
+ (do-template [<name>]
+ [(: (-> n n) <name>)]
+ [negate] [signum] [abs])
+ )
diff --git a/stdlib/source/lux/control/ord.lux b/stdlib/source/lux/control/ord.lux
new file mode 100644
index 000000000..0021cbe1b
--- /dev/null
+++ b/stdlib/source/lux/control/ord.lux
@@ -0,0 +1,44 @@
+## 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/.
+
+(;module:
+ [lux #- min max]
+ (.. eq)
+ lux/codata/function)
+
+## [Signatures]
+(sig: #export (Ord a)
+ (: (Eq a)
+ eq)
+
+ (do-template [<name>]
+ [(: (-> a a Bool) <name>)]
+
+ [<] [<=] [>] [>=]))
+
+## [Values]
+(def: #export (ord eq <)
+ (All [a]
+ (-> (Eq a) (-> a a Bool) (Ord a)))
+ (let [> (flip <)]
+ (struct
+ (def: eq eq)
+ (def: < <)
+ (def: (<= test subject)
+ (or (< test subject)
+ (:: eq = test subject)))
+ (def: > >)
+ (def: (>= test subject)
+ (or (> test subject)
+ (:: eq = test subject))))))
+
+(do-template [<name> <op>]
+ [(def: #export (<name> ord x y)
+ (All [a]
+ (-> (Ord a) a a a))
+ (if (:: ord <op> y x) x y))]
+
+ [max >]
+ [min <])
diff --git a/stdlib/source/lux/data/bit.lux b/stdlib/source/lux/data/bit.lux
new file mode 100644
index 000000000..72a92507c
--- /dev/null
+++ b/stdlib/source/lux/data/bit.lux
@@ -0,0 +1,66 @@
+## 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/.
+
+(;module: [lux #- & | ^])
+
+## [Values]
+(do-template [<short-name> <op> <doc> <type>]
+ [(def: #export (<short-name> param subject)
+ {#;doc <doc>}
+ (-> Nat <type> <type>)
+ (_lux_proc ["bit" <op>] [subject param]))]
+
+ [& "and" "Bit and." Nat]
+ [| "or" "Bit or." Nat]
+ [^ "xor" "Bit xor." Nat]
+ [<< "shift-left" "Bit shift-left." Nat]
+ [>> "shift-right" "Bit shift-right." Int]
+ [>>> "unsigned-shift-right" "Bit unsigned-shift-right." Nat]
+ )
+
+(def: #export (count subject)
+ {#;doc "Count the number of 1s in a bit-map."}
+ (-> Nat Nat)
+ (_lux_proc ["bit" "count"] [subject]))
+
+(def: mask Nat (int-to-nat -1))
+
+(def: #export ~
+ {#;doc "Bit negation."}
+ (-> Nat Nat)
+ (^ mask))
+
+(def: #export (clear idx input)
+ {#;doc "Clear bit at given index."}
+ (-> Nat Nat Nat)
+ (& (~ (<< idx +1)) input))
+
+(do-template [<name> <op> <doc>]
+ [(def: #export (<name> idx input)
+ {#;doc <doc>}
+ (-> Nat Nat Nat)
+ (<op> (<< idx +1) input))]
+
+ [set | "Set bit at given index."]
+ [flip ^ "Flip bit at given index."]
+ )
+
+(def: #export (set? idx input)
+ (-> Nat Nat Bool)
+ (|> input (& (<< idx +1)) (=+ +0) not))
+
+(def: rot-top Nat +64)
+
+(do-template [<name> <main> <comp>]
+ [(def: #export (<name> distance input)
+ (-> Nat Nat Nat)
+ (| (<main> distance input)
+ (<comp> (-+ (%+ rot-top distance)
+ rot-top)
+ input)))]
+
+ [rotate-left << >>>]
+ [rotate-right >>> <<]
+ )
diff --git a/stdlib/source/lux/data/bool.lux b/stdlib/source/lux/data/bool.lux
new file mode 100644
index 000000000..15dc349ef
--- /dev/null
+++ b/stdlib/source/lux/data/bool.lux
@@ -0,0 +1,47 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monoid
+ eq
+ codec)
+ (codata function)))
+
+## [Structures]
+(struct: #export _ (Eq Bool)
+ (def: (= x y)
+ (if x
+ y
+ (not y))))
+
+(do-template [<name> <unit> <op>]
+ [(struct: #export <name> (Monoid Bool)
+ (def: unit <unit>)
+ (def: (append x y)
+ (<op> x y)))]
+
+ [ Or@Monoid<Bool> false or]
+ [And@Monoid<Bool> true and]
+ )
+
+(struct: #export _ (Codec Text Bool)
+ (def: (encode x)
+ (if x
+ "true"
+ "false"))
+
+ (def: (decode input)
+ (case input
+ "true" (#;Right true)
+ "false" (#;Right false)
+ _ (#;Left "Wrong syntax for Bool."))))
+
+## [Values]
+(def: #export complement
+ {#;doc "Generates the complement of a predicate.
+ That is a predicate that returns the oposite of the original predicate."}
+ (All [a] (-> (-> a Bool) (-> a Bool)))
+ (. not))
diff --git a/stdlib/source/lux/data/char.lux b/stdlib/source/lux/data/char.lux
new file mode 100644
index 000000000..6af987408
--- /dev/null
+++ b/stdlib/source/lux/data/char.lux
@@ -0,0 +1,107 @@
+## 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/.
+
+(;module:
+ lux
+ (lux/control eq
+ [ord]
+ codec
+ hash)
+ (.. [text "Text/" Monoid<Text>]))
+
+## [Structures]
+(struct: #export _ (Eq Char)
+ (def: (= x y)
+ (_lux_proc ["jvm" "ceq"] [x y])))
+
+(struct: #export _ (Hash Char)
+ (def: eq Eq<Char>)
+ (def: hash
+ (|>. []
+ (_lux_proc ["jvm" "c2i"])
+ []
+ (_lux_proc ["jvm" "i2l"])
+ int-to-nat)))
+
+(struct: #export _ (ord;Ord Char)
+ (def: eq Eq<Char>)
+
+ (do-template [<name> <op>]
+ [(def: (<name> test subject)
+ (_lux_proc ["jvm" <op>] [subject test]))]
+
+ [< "clt"]
+ [> "cgt"]
+ )
+
+ (do-template [<name> <op>]
+ [(def: (<name> test subject)
+ (or (_lux_proc ["jvm" "ceq"] [subject test])
+ (_lux_proc ["jvm" <op>] [subject test])))]
+
+ [<= "clt"]
+ [>= "cgt"]
+ ))
+
+(struct: #export _ (Codec Text Char)
+ (def: (encode x)
+ (let [as-text (case x
+ #"\t" "\\t"
+ #"\b" "\\b"
+ #"\n" "\\n"
+ #"\r" "\\r"
+ #"\f" "\\f"
+ #"\"" "\\\""
+ #"\\" "\\\\"
+ _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))]
+ ($_ Text/append "#\"" as-text "\"")))
+
+ (def: (decode y)
+ (let [size (text;size y)]
+ (if (and (text;starts-with? "#\"" y)
+ (text;ends-with? "\"" y)
+ (or (=+ +4 size)
+ (=+ +5 size)))
+ (if (=+ +4 size)
+ (case (text;at +2 y)
+ #;None
+ (#;Left (Text/append "Wrong syntax for Char: " y))
+
+ (#;Some char)
+ (#;Right char))
+ (case [(text;at +2 y) (text;at +3 y)]
+ [(#;Some #"\\") (#;Some char)]
+ (case char
+ #"t" (#;Right #"\t")
+ #"b" (#;Right #"\b")
+ #"n" (#;Right #"\n")
+ #"r" (#;Right #"\r")
+ #"f" (#;Right #"\f")
+ #"\"" (#;Right #"\"")
+ #"\\" (#;Right #"\\")
+ #"t" (#;Right #"\t")
+ _ (#;Left (Text/append "Wrong syntax for Char: " y)))
+
+ _
+ (#;Left (Text/append "Wrong syntax for Char: " y))))
+ (#;Left (Text/append "Wrong syntax for Char: " y))))))
+
+## [Values]
+(def: #export (space? x)
+ {#;doc "Checks whether the character is white-space."}
+ (-> Char Bool)
+ (_lux_proc ["jvm" "invokestatic:java.lang.Character:isWhitespace:char"] [x]))
+
+(def: #export (as-text x)
+ (-> Char Text)
+ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))
+
+(def: #export (char x)
+ (-> Nat Char)
+ (_lux_proc ["nat" "to-char"] [x]))
+
+(def: #export (code x)
+ (-> Char Nat)
+ (_lux_proc ["char" "to-nat"] [x]))
diff --git a/stdlib/source/lux/data/error.lux b/stdlib/source/lux/data/error.lux
new file mode 100644
index 000000000..ce2f529b9
--- /dev/null
+++ b/stdlib/source/lux/data/error.lux
@@ -0,0 +1,66 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control functor
+ applicative
+ ["M" monad #*])))
+
+## [Types]
+(type: #export (Error a)
+ (Either Text a))
+
+## [Structures]
+(struct: #export _ (Functor Error)
+ (def: (map f ma)
+ (case ma
+ (#;Left msg) (#;Left msg)
+ (#;Right datum) (#;Right (f datum)))))
+
+(struct: #export _ (Applicative Error)
+ (def: functor Functor<Error>)
+
+ (def: (wrap a)
+ (#;Right a))
+
+ (def: (apply ff fa)
+ (case ff
+ (#;Right f)
+ (case fa
+ (#;Right a)
+ (#;Right (f a))
+
+ (#;Left msg)
+ (#;Left msg))
+
+ (#;Left msg)
+ (#;Left msg))
+ ))
+
+(struct: #export _ (Monad Error)
+ (def: applicative Applicative<Error>)
+
+ (def: (join mma)
+ (case mma
+ (#;Left msg) (#;Left msg)
+ (#;Right ma) ma)))
+
+(struct: #export (ErrorT Monad<M>)
+ (All [M] (-> (Monad M) (Monad (All [a] (M (Error a))))))
+ (def: applicative (compA (get@ #M;applicative Monad<M>) Applicative<Error>))
+ (def: (join MeMea)
+ (do Monad<M>
+ [eMea MeMea]
+ (case eMea
+ (#;Left error)
+ (wrap (#;Left error))
+
+ (#;Right Mea)
+ (join Mea)))))
+
+(def: #export (lift-error Monad<M>)
+ (All [M a] (-> (Monad M) (-> (M a) (M (Error a)))))
+ (liftM Monad<M> (:: Monad<Error> wrap)))
diff --git a/stdlib/source/lux/data/error/exception.lux b/stdlib/source/lux/data/error/exception.lux
new file mode 100644
index 000000000..be9a09327
--- /dev/null
+++ b/stdlib/source/lux/data/error/exception.lux
@@ -0,0 +1,62 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monad)
+ (data error
+ [text])
+ [compiler]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax]
+ (syntax [common]))))
+
+## [Types]
+(type: #export Exception
+ (-> Text Text))
+
+## [Values]
+(def: #hidden _Text/append_
+ (-> Text Text Text)
+ (:: text;Monoid<Text> append))
+
+(def: #export (catch exception then try)
+ (All [a]
+ (-> Exception (-> Text a) (Error a)
+ (Error a)))
+ (case try
+ (#;Right output)
+ (#;Right output)
+
+ (#;Left error)
+ (if (text;starts-with? (exception "") error)
+ (#;Right (then error))
+ (#;Left error))))
+
+(def: #export (else to-do try)
+ (All [a]
+ (-> (-> Text a) (Error a) a))
+ (case try
+ (#;Right output)
+ output
+
+ (#;Left error)
+ (to-do error)))
+
+(def: #export (return value)
+ (All [a] (-> a (Error a)))
+ (#;Right value))
+
+(def: #export (throw exception message)
+ (All [a] (-> Exception Text (Error a)))
+ (#;Left (exception message)))
+
+(syntax: #export (exception: {_ex-lev common;export-level} {name s;local-symbol})
+ (do @
+ [current-module compiler;current-module-name
+ #let [g!message (ast;symbol ["" "message"])]]
+ (wrap (list (` (def: (~@ (common;gen-export-level _ex-lev)) ((~ (ast;symbol ["" name])) (~ g!message))
+ Exception
+ ($_ _Text/append_ "[" (~ (ast;text current-module)) ";" (~ (ast;text name)) "]\t" (~ g!message))))))))
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
new file mode 100644
index 000000000..c51e4b04c
--- /dev/null
+++ b/stdlib/source/lux/data/format/json.lux
@@ -0,0 +1,1031 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control functor
+ applicative
+ monad
+ eq
+ codec)
+ (data [bool]
+ [text "Text/" Eq<Text> Monoid<Text>]
+ text/format
+ [number #* "Real/" Codec<Text,Real>]
+ maybe
+ [char "Char/" Eq<Char> Codec<Text,Char>]
+ error
+ [sum]
+ [product]
+ (struct [list "" Fold<List> "List/" Monad<List>]
+ [vector #+ Vector vector "Vector/" Monad<Vector>]
+ [dict #+ Dict]))
+ (codata [function])
+ [compiler #+ Monad<Lux> with-gensyms]
+ (macro [syntax #+ syntax:]
+ [ast]
+ [poly #+ poly:])
+ [type]
+ [lexer #+ Lexer Monad<Lexer>]))
+
+## [Types]
+(do-template [<name> <type>]
+ [(type: #export <name> <type>)]
+
+ [Null Unit]
+ [Boolean Bool]
+ [Number Real]
+ [String Text]
+ )
+
+(type: #export #rec JSON
+ (#Null Null)
+ (#Boolean Boolean)
+ (#Number Number)
+ (#String String)
+ (#Array (Vector JSON))
+ (#Object (Dict String JSON)))
+
+(do-template [<name> <type>]
+ [(type: #export <name> <type>)]
+
+ [Array (Vector JSON)]
+ [Object (Dict String JSON)]
+ )
+
+(type: #export (Parser a)
+ (-> JSON (Error a)))
+
+(type: #export (Gen a)
+ (-> a JSON))
+
+## [Syntax]
+(syntax: #export (json token)
+ (let [(^open) Monad<Lux>
+ wrapper (lambda [x] (` (;;json (~ x))))]
+ (case token
+ (^template [<ast-tag> <ctor> <json-tag>]
+ [_ (<ast-tag> value)]
+ (wrap (list (` (: JSON (<json-tag> (~ (<ctor> value))))))))
+ ([#;BoolS ast;bool #Boolean]
+ [#;IntS (|>. int-to-real ast;real) #Number]
+ [#;RealS ast;real #Number]
+ [#;TextS ast;text #String])
+
+ [_ (#;TagS ["" "null"])]
+ (wrap (list (` (: JSON #Null))))
+
+ [_ (#;TupleS members)]
+ (wrap (list (` (: JSON (#Array (vector (~@ (List/map wrapper members))))))))
+
+ [_ (#;RecordS pairs)]
+ (do Monad<Lux>
+ [pairs' (mapM @
+ (lambda [[slot value]]
+ (case slot
+ [_ (#;TextS key-name)]
+ (wrap (` [(~ (ast;text key-name)) (~ (wrapper value))]))
+
+ _
+ (compiler;fail "Wrong syntax for JSON object.")))
+ pairs)]
+ (wrap (list (` (: JSON (#Object (dict;from-list text;Hash<Text> (list (~@ pairs')))))))))
+
+ _
+ (wrap (list token))
+ )))
+
+## [Values]
+(def: #hidden (show-null _) (-> Null Text) "null")
+(do-template [<name> <type> <codec>]
+ [(def: <name> (-> <type> Text) (:: <codec> encode))]
+
+ [show-boolean Boolean bool;Codec<Text,Bool>]
+ [show-number Number number;Codec<Text,Real>]
+ [show-string String text;Codec<Text,Text>])
+
+(def: (show-array show-json elems)
+ (-> (-> JSON Text) (-> Array Text))
+ (format "["
+ (|> elems (Vector/map show-json) vector;vector-to-list (text;join-with ","))
+ "]"))
+
+(def: (show-object show-json object)
+ (-> (-> JSON Text) (-> Object Text))
+ (format "{"
+ (|> object
+ dict;entries
+ (List/map (lambda [[key value]] (format (:: text;Codec<Text,Text> encode key) ":" (show-json value))))
+ (text;join-with ","))
+ "}"))
+
+(def: (show-json json)
+ (-> JSON Text)
+ (case json
+ (^template [<tag> <show>]
+ (<tag> value)
+ (<show> value))
+ ([#Null show-null]
+ [#Boolean show-boolean]
+ [#Number show-number]
+ [#String show-string]
+ [#Array (show-array show-json)]
+ [#Object (show-object show-json)])
+ ))
+
+(def: #export null
+ JSON
+ #Null)
+
+(def: #export (keys json)
+ (-> JSON (Error (List String)))
+ (case json
+ (#Object obj)
+ (#;Right (dict;keys obj))
+
+ _
+ (#;Left (format "Can't get keys of a non-object."))))
+
+(def: #export (get key json)
+ (-> String JSON (Error JSON))
+ (case json
+ (#Object obj)
+ (case (dict;get key obj)
+ (#;Some value)
+ (#;Right value)
+
+ #;None
+ (#;Left (format "Missing field " (show-string key) " on object.")))
+
+ _
+ (#;Left (format "Can't get field " (show-string key) " of a non-object."))))
+
+(def: #export (set key value json)
+ (-> String JSON JSON (Error JSON))
+ (case json
+ (#Object obj)
+ (#;Right (#Object (dict;put key value obj)))
+
+ _
+ (#;Left (format "Can't set field " (show-string key) " of a non-object."))))
+
+(do-template [<name> <tag> <type>]
+ [(def: #export (<name> key json)
+ (-> Text JSON (Error <type>))
+ (case (get key json)
+ (#;Right (<tag> value))
+ (#;Right value)
+
+ (#;Right _)
+ (#;Left (format "Wrong value type at key " (show-string key)))
+
+ (#;Left error)
+ (#;Left error)))]
+
+ [get-boolean #Boolean Boolean]
+ [get-number #Number Number]
+ [get-string #String String]
+ [get-array #Array Array]
+ [get-object #Object Object]
+ )
+
+(do-template [<name> <type> <tag>]
+ [(def: #export (<name> value)
+ (Gen <type>)
+ (<tag> value))]
+
+ [gen-boolean Boolean #Boolean]
+ [gen-number Number #Number]
+ [gen-string String #String]
+ [gen-array Array #Array]
+ [gen-object Object #Object]
+ )
+
+(def: #export (gen-nullable gen)
+ (All [a] (-> (Gen a) (Gen (Maybe a))))
+ (lambda [elem]
+ (case elem
+ #;None #Null
+ (#;Some value) (gen value))))
+
+## Lexers
+(def: space~
+ (Lexer Text)
+ (lexer;some' lexer;space))
+
+(def: data-sep
+ (Lexer [Text Char Text])
+ ($_ lexer;seq space~ (lexer;this-char #",") space~))
+
+(def: null~
+ (Lexer Null)
+ (do Monad<Lexer>
+ [_ (lexer;this "null")]
+ (wrap [])))
+
+(do-template [<name> <token> <value>]
+ [(def: <name>
+ (Lexer Boolean)
+ (do Monad<Lexer>
+ [_ (lexer;this <token>)]
+ (wrap <value>)))]
+
+ [t~ "true" true]
+ [f~ "false" false]
+ )
+
+(def: boolean~
+ (Lexer Boolean)
+ (lexer;either t~ f~))
+
+(def: number~
+ (Lexer Number)
+ (do Monad<Lexer>
+ [?sign (: (Lexer (Maybe Text))
+ (lexer;opt (lexer;this "-")))
+ digits (: (Lexer Text)
+ (lexer;many' lexer;digit))
+ ?decimals (: (Lexer (Maybe Text))
+ (lexer;opt (do @
+ [_ (lexer;this ".")]
+ (lexer;many' lexer;digit))))]
+ (case (: (Error Real)
+ (Real/decode (format (default "" ?sign)
+ digits "."
+ (default "0" ?decimals))))
+ (#;Left message)
+ (lexer;fail message)
+
+ (#;Right value)
+ (wrap value))))
+
+(def: (un-escape escaped)
+ (-> Char Text)
+ (case escaped
+ #"t" "\t"
+ #"b" "\b"
+ #"n" "\n"
+ #"r" "\r"
+ #"f" "\f"
+ #"\"" "\""
+ #"\\" "\\"
+ _ ""))
+
+(def: string-body~
+ (Lexer Text)
+ (loop [_ []]
+ (do Monad<Lexer>
+ [chars (lexer;some' (lexer;none-of "\\\""))
+ stop-char lexer;peek]
+ (if (Char/= #"\\" stop-char)
+ (do @
+ [_ lexer;any
+ escaped lexer;any
+ next-chars (recur [])]
+ (wrap (format chars (un-escape escaped) next-chars)))
+ (wrap chars)))))
+
+(def: string~
+ (Lexer String)
+ (do Monad<Lexer>
+ [_ (lexer;this "\"")
+ string-body string-body~
+ _ (lexer;this "\"")]
+ (wrap string-body)))
+
+(def: (kv~ json~)
+ (-> (-> Unit (Lexer JSON)) (Lexer [String JSON]))
+ (do Monad<Lexer>
+ [key string~
+ _ space~
+ _ (lexer;this-char #":")
+ _ space~
+ value (json~ [])]
+ (wrap [key value])))
+
+(do-template [<name> <type> <open> <close> <elem-parser> <prep>]
+ [(def: (<name> json~)
+ (-> (-> Unit (Lexer JSON)) (Lexer <type>))
+ (do Monad<Lexer>
+ [_ (lexer;this-char <open>)
+ _ space~
+ elems (lexer;sep-by data-sep <elem-parser>)
+ _ space~
+ _ (lexer;this-char <close>)]
+ (wrap (<prep> elems))))]
+
+ [array~ Array #"[" #"]" (json~ []) vector;list-to-vector]
+ [object~ Object #"{" #"}" (kv~ json~) (dict;from-list text;Hash<Text>)]
+ )
+
+(def: (json~' _)
+ (-> Unit (Lexer JSON))
+ ($_ lexer;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~')))
+
+## [Structures]
+(struct: #export _ (Functor Parser)
+ (def: (map f ma)
+ (lambda [json]
+ (case (ma json)
+ (#;Left msg)
+ (#;Left msg)
+
+ (#;Right a)
+ (#;Right (f a))))))
+
+(struct: #export _ (Applicative Parser)
+ (def: functor Functor<Parser>)
+
+ (def: (wrap x json)
+ (#;Right x))
+
+ (def: (apply ff fa)
+ (lambda [json]
+ (case (ff json)
+ (#;Right f)
+ (case (fa json)
+ (#;Right a)
+ (#;Right (f a))
+
+ (#;Left msg)
+ (#;Left msg))
+
+ (#;Left msg)
+ (#;Left msg)))))
+
+(struct: #export _ (Monad Parser)
+ (def: applicative Applicative<Parser>)
+
+ (def: (join mma)
+ (lambda [json]
+ (case (mma json)
+ (#;Left msg)
+ (#;Left msg)
+
+ (#;Right ma)
+ (ma json)))))
+
+## [Values]
+## Syntax
+(do-template [<name> <type> <tag> <desc> <pre>]
+ [(def: #export (<name> json)
+ (Parser <type>)
+ (case json
+ (<tag> value)
+ (#;Right (<pre> value))
+
+ _
+ (#;Left (format "JSON value is not a " <desc> ": " (show-json json)))))]
+
+ [unit Unit #Null "null" id]
+ [bool Bool #Boolean "boolean" id]
+ [int Int #Number "number" real-to-int]
+ [real Real #Number "number" id]
+ [text Text #String "string" id]
+ )
+
+(do-template [<test> <check> <type> <eq> <codec> <tag> <desc> <pre>]
+ [(def: #export (<test> test json)
+ (-> <type> (Parser Bool))
+ (case json
+ (<tag> value)
+ (#;Right (:: <eq> = test (<pre> value)))
+
+ _
+ (#;Left (format "JSON value is not a " <desc> ": " (show-json json)))))
+
+ (def: #export (<check> test json)
+ (-> <type> (Parser Unit))
+ (case json
+ (<tag> value)
+ (let [value (<pre> value)]
+ (if (:: <eq> = test value)
+ (#;Right [])
+ (#;Left (format "Value mismatch: "
+ (:: <codec> encode test) "=/=" (:: <codec> encode value)))))
+
+ _
+ (#;Left (format "JSON value is not a " <desc> ": " (show-json json)))))]
+
+ [bool? bool! Bool bool;Eq<Bool> bool;Codec<Text,Bool> #Boolean "boolean" id]
+ [int? int! Int number;Eq<Int> number;Codec<Text,Int> #Number "number" real-to-int]
+ [real? real! Real number;Eq<Real> number;Codec<Text,Real> #Number "number" id]
+ [text? text! Text text;Eq<Text> text;Codec<Text,Text> #String "string" id]
+ )
+
+(def: #export (char json)
+ (Parser Char)
+ (case json
+ (#String input)
+ (case (Char/decode (format "#\"" input "\""))
+ (#;Right value)
+ (#;Right value)
+
+ (#;Left _)
+ (#;Left (format "Invalid format for char: " input)))
+
+ _
+ (#;Left (format "JSON value is not a " "string" ": " (show-json json)))))
+
+(def: #export (char? test json)
+ (-> Char (Parser Bool))
+ (case json
+ (#String input)
+ (case (Char/decode (format "#\"" input "\""))
+ (#;Right value)
+ (if (:: char;Eq<Char> = test value)
+ (#;Right true)
+ (#;Left (format "Value mismatch: "
+ (:: char;Codec<Text,Char> encode test) "=/=" (:: char;Codec<Text,Char> encode value))))
+
+ (#;Left _)
+ (#;Left (format "Invalid format for char: " input)))
+
+ _
+ (#;Left (format "JSON value is not a " "string" ": " (show-json json)))))
+
+(def: #export (char! test json)
+ (-> Char (Parser Unit))
+ (case json
+ (#String input)
+ (case (Char/decode (format "#\"" input "\""))
+ (#;Right value)
+ (if (:: char;Eq<Char> = test value)
+ (#;Right [])
+ (#;Left (format "Value mismatch: "
+ (:: char;Codec<Text,Char> encode test) "=/=" (:: char;Codec<Text,Char> encode value))))
+
+ (#;Left _)
+ (#;Left (format "Invalid format for char: " input)))
+
+ _
+ (#;Left (format "JSON value is not a " "string" ": " (show-json json)))))
+
+(def: #export (nullable parser)
+ (All [a] (-> (Parser a) (Parser (Maybe a))))
+ (lambda [json]
+ (case json
+ #Null
+ (#;Right #;None)
+
+ _
+ (case (parser json)
+ (#;Left error)
+ (#;Left error)
+
+ (#;Right value)
+ (#;Right (#;Some value)))
+ )))
+
+(def: #export (array parser)
+ (All [a] (-> (Parser a) (Parser (List a))))
+ (lambda [json]
+ (case json
+ (#Array values)
+ (do Monad<Error>
+ [elems (mapM @ parser (vector;vector-to-list values))]
+ (wrap elems))
+
+ _
+ (#;Left (format "JSON value is not an array: " (show-json json))))))
+
+(def: #export (object parser)
+ (All [a] (-> (Parser a) (Parser (Dict String a))))
+ (lambda [json]
+ (case json
+ (#Object fields)
+ (do Monad<Error>
+ [kvs (mapM @
+ (lambda [[key val']]
+ (do @
+ [val (parser val')]
+ (wrap [key val])))
+ (dict;entries fields))]
+ (wrap (dict;from-list text;Hash<Text> kvs)))
+
+ _
+ (#;Left (format "JSON value is not an object: " (show-json json))))))
+
+(def: #export (at idx parser)
+ (All [a] (-> Nat (Parser a) (Parser a)))
+ (lambda [json]
+ (case json
+ (#Array values)
+ (case (vector;at idx values)
+ (#;Some value)
+ (case (parser value)
+ (#;Right output)
+ (#;Right output)
+
+ (#;Left error)
+ (#;Left (format "JSON array index [" (%n idx) "]: (" error ") @ " (show-json json))))
+
+ #;None
+ (#;Left (format "JSON array does not have index " (%n idx) " @ " (show-json json))))
+
+ _
+ (#;Left (format "JSON value is not an array: " (show-json json))))))
+
+(def: #export (field field-name parser)
+ (All [a] (-> Text (Parser a) (Parser a)))
+ (lambda [json]
+ (case (get field-name json)
+ (#;Some value)
+ (case (parser value)
+ (#;Right output)
+ (#;Right output)
+
+ (#;Left error)
+ (#;Left (format "Failed to get JSON object field " (show-string field-name) ": (" error ") @ " (show-json json))))
+
+ (#;Left _)
+ (#;Left (format "JSON object does not have field " (show-string field-name) " @ " (show-json json))))))
+
+(def: #export any
+ (Parser JSON)
+ (lambda [json]
+ (#;Right json)))
+
+(def: #export (seq pa pb)
+ (All [a b] (-> (Parser a) (Parser b) (Parser [a b])))
+ (do Monad<Parser>
+ [=a pa
+ =b pb]
+ (wrap [=a =b])))
+
+(def: #export (alt pa pb json)
+ (All [a b] (-> (Parser a) (Parser b) (Parser (| a b))))
+ (case (pa json)
+ (#;Right a)
+ (sum;right (sum;left a))
+
+ (#;Left message0)
+ (case (pb json)
+ (#;Right b)
+ (sum;right (sum;right b))
+
+ (#;Left message1)
+ (#;Left message0))))
+
+(def: #export (either pl pr json)
+ (All [a] (-> (Parser a) (Parser a) (Parser a)))
+ (case (pl json)
+ (#;Right x)
+ (#;Right x)
+
+ _
+ (pr json)))
+
+(def: #export (opt p json)
+ (All [a]
+ (-> (Parser a) (Parser (Maybe a))))
+ (case (p json)
+ (#;Left _) (#;Right #;None)
+ (#;Right x) (#;Right (#;Some x))))
+
+(def: #export (run parser json)
+ (All [a] (-> (Parser a) JSON (Error a)))
+ (parser json))
+
+(def: #export (ensure test parser json)
+ (All [a] (-> (Parser Unit) (Parser a) (Parser a)))
+ (case (test json)
+ (#;Right _)
+ (parser json)
+
+ (#;Left error)
+ (#;Left error)))
+
+(def: #export (array-size! array-size json)
+ (-> Nat (Parser Unit))
+ (case json
+ (#Array parts)
+ (if (=+ array-size (vector;size parts))
+ (#;Right [])
+ (#;Left (format "JSON array does no have size " (%n array-size) " " (show-json json))))
+
+ _
+ (#;Left (format "JSON value is not an array: " (show-json json)))))
+
+(def: #export (object-fields! wanted-fields json)
+ (-> (List String) (Parser Unit))
+ (case json
+ (#Object kvs)
+ (let [actual-fields (dict;keys kvs)]
+ (if (and (=+ (list;size wanted-fields) (list;size actual-fields))
+ (list;every? (list;member? text;Eq<Text> wanted-fields)
+ actual-fields))
+ (#;Right [])
+ (#;Left (format "JSON object has wrong field-set. Expected: [" (text;join-with ", " wanted-fields) "]. Actual: [" (text;join-with ", " actual-fields) "]"))))
+
+ _
+ (#;Left (format "JSON value is not an object: " (show-json json)))))
+
+## [Structures]
+(struct: #export _ (Eq JSON)
+ (def: (= x y)
+ (case [x y]
+ [#Null #Null]
+ true
+
+ (^template [<tag> <struct>]
+ [(<tag> x') (<tag> y')]
+ (:: <struct> = x' y'))
+ ([#Boolean bool;Eq<Bool>]
+ [#Number number;Eq<Real>]
+ [#String text;Eq<Text>])
+
+ [(#Array xs) (#Array ys)]
+ (and (=+ (vector;size xs) (vector;size ys))
+ (fold (lambda [idx prev]
+ (and prev
+ (default false
+ (do Monad<Maybe>
+ [x' (vector;at idx xs)
+ y' (vector;at idx ys)]
+ (wrap (= x' y'))))))
+ true
+ (list;indices (vector;size xs))))
+
+ [(#Object xs) (#Object ys)]
+ (and (=+ (dict;size xs) (dict;size ys))
+ (fold (lambda [[xk xv] prev]
+ (and prev
+ (case (dict;get xk ys)
+ #;None false
+ (#;Some yv) (= xv yv))))
+ true
+ (dict;entries xs)))
+
+ _
+ false)))
+
+(struct: #export _ (Codec Text JSON)
+ (def: encode show-json)
+ (def: decode (lexer;run (json~' []))))
+
+## [Syntax]
+(type: Shape
+ (#ArrayShape (List AST))
+ (#ObjectShape (List [Text AST])))
+
+(def: _shape^
+ (syntax;Syntax Shape)
+ (syntax;alt (syntax;tuple (syntax;some syntax;any))
+ (syntax;record (syntax;some (syntax;seq syntax;text syntax;any)))))
+
+(syntax: #export (shape^ {shape _shape^})
+ (case shape
+ (#ArrayShape parts)
+ (let [array-size (list;size parts)
+ parsers (|> parts
+ (list;zip2 (list;indices array-size))
+ (List/map (lambda [[idx parser]]
+ (` (at (~ (ast;nat idx)) (~ parser))))))]
+ (wrap (list (` ($_ seq (~@ parsers))))))
+
+ (#ObjectShape kvs)
+ (let [fields (List/map product;left kvs)
+ parsers (List/map (lambda [[field-name parser]]
+ (` (field (~ (ast;text field-name)) (~ parser))))
+ kvs)]
+ (wrap (list (` ($_ seq (~@ parsers))))))
+ ))
+
+(syntax: #export (shape!^ {shape _shape^})
+ (case shape
+ (#ArrayShape parts)
+ (let [array-size (list;size parts)
+ parsers (|> parts
+ (list;zip2 (list;indices array-size))
+ (List/map (lambda [[idx parser]]
+ (` (at (~ (ast;nat idx)) (~ parser))))))]
+ (wrap (list (` (ensure (array-size! (~ (ast;nat array-size)))
+ ($_ seq (~@ parsers)))))))
+
+ (#ObjectShape kvs)
+ (let [fields (List/map product;left kvs)
+ parsers (List/map (lambda [[field-name parser]]
+ (` (field (~ (ast;text field-name)) (~ parser))))
+ kvs)]
+ (wrap (list (` (ensure (object-fields! (list (~@ (List/map ast;text fields))))
+ ($_ seq (~@ parsers)))))))
+ ))
+
+## [Polytypism]
+(def: #hidden _map_
+ (All [a b] (-> (-> a b) (List a) (List b)))
+ List/map)
+
+(poly: #export (|Codec@JSON//encode| *env* :x:)
+ (let [->Codec//encode (: (-> AST AST)
+ (lambda [.type.] (` (-> (~ .type.) JSON))))]
+ (let% [<basic> (do-template [<type> <matcher> <encoder>]
+ [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//encode (` <type>))) <encoder>))))]
+
+ [Unit poly;unit (lambda [(~ (ast;symbol ["" "0"]))] #Null)]
+ [Bool poly;bool ;;boolean]
+ [Int poly;int (|>. int-to-real ;;number)]
+ [Real poly;real ;;number]
+ [Char poly;char (|>. char;->Text ;;string)]
+ [Text poly;text ;;string])]
+ ($_ compiler;either
+ <basic>
+ (with-gensyms [g!type-fun g!case g!input g!key g!val]
+ (do @
+ [:sub: (poly;list :x:)
+ [g!vars members] (poly;tuple :sub:)
+ :val: (case members
+ (^ (list :key: :val:))
+ (do @ [_ (poly;text :key:)]
+ (wrap :val:))
+
+ _
+ (compiler;fail ""))
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ .val. (|Codec@JSON//encode| new-*env* :val:)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//encode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//encode g!vars))
+ (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+ (wrap (` (: (~ :x:+)
+ (lambda [(~@ g!vars) (~ g!input)]
+ (|> (~ g!input)
+ (_map_ (: (-> [Text (~ (type;type-to-ast :val:))]
+ [Text JSON])
+ (lambda [[(~ g!key) (~ g!val)]]
+ [(~ g!key)
+ ((~ .val.) (~ g!val))])))
+ ;;object))
+ )))
+ ))
+ (do @
+ [:sub: (poly;maybe :x:)
+ .sub. (|Codec@JSON//encode| *env* :sub:)]
+ (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:)))
+ (;;nullable (~ .sub.))))))
+ (do @
+ [:sub: (poly;list :x:)
+ .sub. (|Codec@JSON//encode| *env* :sub:)]
+ (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:)))
+ (|>. (_map_ (~ .sub.)) vector;list-to-vector ;;array)))))
+ (with-gensyms [g!type-fun g!case g!input]
+ (do @
+ [[g!vars cases] (poly;variant :x:)
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ pattern-matching (mapM @
+ (lambda [[name :case:]]
+ (do @
+ [#let [tag (ast;tag name)]
+ encoder (|Codec@JSON//encode| new-*env* :case:)]
+ (wrap (list (` ((~ tag) (~ g!case)))
+ (` (;;json [(~ (ast;text (product;right name)))
+ ((~ encoder) (~ g!case))]))))))
+ cases)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//encode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//encode g!vars))
+ (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+ (wrap (` (: (~ :x:+)
+ (lambda [(~@ g!vars) (~ g!input)]
+ (case (~ g!input)
+ (~@ (List/join pattern-matching))))
+ )))))
+ (with-gensyms [g!type-fun g!case g!input]
+ (do @
+ [[g!vars slots] (poly;record :x:)
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ synthesis (mapM @
+ (lambda [[name :slot:]]
+ (do @
+ [encoder (|Codec@JSON//encode| new-*env* :slot:)]
+ (wrap [(` (~ (ast;text (product;right name))))
+ (` ((~ encoder) (get@ (~ (ast;tag name)) (~ g!input))))])))
+ slots)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//encode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//encode g!vars))
+ (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+ (wrap (` (: (~ :x:+)
+ (lambda [(~@ g!vars) (~ g!input)]
+ (;;json (~ (ast;record synthesis))))
+ )))))
+ (with-gensyms [g!type-fun g!case g!input]
+ (do @
+ [[g!vars members] (poly;tuple :x:)
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ pattern-matching (mapM @
+ (lambda [:member:]
+ (do @
+ [g!member (compiler;gensym "g!member")
+ encoder (|Codec@JSON//encode| new-*env* :member:)]
+ (wrap [g!member encoder])))
+ members)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//encode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//encode g!vars))
+ (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]
+ #let [.tuple. (` [(~@ (List/map product;left pattern-matching))])]]
+ (wrap (` (: (~ :x:+)
+ (lambda [(~@ g!vars) (~ g!input)]
+ (case (~ g!input)
+ (~ .tuple.)
+ (;;array (list (~@ (List/map (lambda [[g!member g!encoder]]
+ (` ((~ g!encoder) (~ g!member))))
+ pattern-matching))))))
+ )))
+ ))
+ (do @
+ [[:func: :args:] (poly;apply :x:)
+ .func. (|Codec@JSON//encode| *env* :func:)
+ .args. (mapM @ (|Codec@JSON//encode| *env*) :args:)]
+ (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:)))
+ ((~ .func.) (~@ .args.))))))
+ (poly;bound *env* :x:)
+ (compiler;fail (format "Can't create JSON encoder for: " (type;type-to-text :x:)))
+ ))))
+
+(poly: #export (Codec<JSON,?>//decode *env* :x:)
+ (let [->Codec//decode (: (-> AST AST)
+ (lambda [.type.] (` (-> JSON (Error (~ .type.))))))]
+ (let% [<basic> (do-template [<type> <matcher> <decoder>]
+ [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//decode (` <type>))) <decoder>))))]
+
+ [Unit poly;unit ;;null]
+ [Bool poly;bool ;;bool]
+ [Int poly;int ;;int]
+ [Real poly;real ;;real]
+ [Char poly;char ;;char]
+ [Text poly;text ;;text])
+ <complex> (do-template [<type> <matcher> <decoder>]
+ [(do @
+ [:sub: (<matcher> :x:)
+ .sub. (Codec<JSON,?>//decode *env* :sub:)]
+ (wrap (` (: (~ (->Codec//decode (type;type-to-ast :x:)))
+ (<decoder> (~ .sub.))))))]
+
+ [Maybe poly;maybe ;;nullable]
+ [List poly;list ;;array])]
+ ($_ compiler;either
+ <basic>
+ (with-gensyms [g!type-fun g!case g!input g!key g!val]
+ (do @
+ [:sub: (poly;list :x:)
+ [g!vars members] (poly;tuple :sub:)
+ :val: (case members
+ (^ (list :key: :val:))
+ (do @ [_ (poly;text :key:)]
+ (wrap :val:))
+
+ _
+ (compiler;fail ""))
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ .val. (Codec<JSON,?>//decode new-*env* :val:)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//decode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//decode g!vars))
+ (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+ (wrap (` (: (~ :x:+)
+ (lambda [(~@ g!vars) (~ g!input)]
+ (do Monad<Error>
+ [(~ g!key) (;;keys (~ g!input))]
+ (mapM (~ (' %))
+ (lambda [(~ g!key)]
+ (do Monad<Error>
+ [(~ g!val) (;;get (~ g!key) (~ g!input))
+ (~ g!val) (;;run (~ .val.) (~ g!val))]
+ ((~ (' wrap)) [(~ g!key) (~ g!val)])))
+ (~ g!key))))
+ )))
+ ))
+ <complex>
+ (with-gensyms [g!type-fun g!_]
+ (do @
+ [[g!vars cases] (poly;variant :x:)
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ pattern-matching (mapM @
+ (lambda [[name :case:]]
+ (do @
+ [#let [tag (ast;tag name)]
+ decoder (Codec<JSON,?>//decode new-*env* :case:)]
+ (wrap (list (` (do Monad<Parser>
+ [(~ g!_) (;;at 0 (;;text! (~ (ast;text (product;right name)))))
+ (~ g!_) (;;at 1 (~ decoder))]
+ ((~ (' wrap)) ((~ tag) (~ g!_)))))))))
+ cases)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//decode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//decode g!vars))
+ (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))
+ base-parser (` ($_ ;;either
+ (~@ (List/join pattern-matching))))
+ parser (case g!vars
+ #;Nil
+ base-parser
+
+ _
+ (` (lambda [(~@ g!vars)] (~ base-parser))))]]
+ (wrap (` (: (~ :x:+) (~ parser))))
+ ))
+ (with-gensyms [g!type-fun g!case g!input]
+ (do @
+ [[g!vars slots] (poly;record :x:)
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ extraction (mapM @
+ (lambda [[name :slot:]]
+ (do @
+ [#let [g!member (ast;symbol ["" (product;right name)])]
+ decoder (Codec<JSON,?>//decode new-*env* :slot:)]
+ (wrap (list g!member
+ (` (;;get (~ (ast;text (product;right name))) (~ g!input)))
+ g!member
+ (` ((~ decoder) (~ g!member)))))))
+ slots)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//decode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//decode g!vars))
+ (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+ (wrap (` (: (~ :x:+)
+ (lambda [(~@ g!vars) (~ g!input)]
+ (do Monad<Error>
+ [(~@ (List/join extraction))]
+ ((~ (' wrap)) (~ (ast;record (List/map (lambda [[name :slot:]]
+ [(ast;tag name) (ast;symbol ["" (product;right name)])])
+ slots))))))
+ )))))
+ (with-gensyms [g!type-fun g!case g!input]
+ (do @
+ [[g!vars members] (poly;tuple :x:)
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ pattern-matching (mapM @
+ (lambda [:member:]
+ (do @
+ [g!member (compiler;gensym "g!member")
+ decoder (Codec<JSON,?>//decode new-*env* :member:)]
+ (wrap [g!member decoder])))
+ members)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//decode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//decode g!vars))
+ (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]
+ #let [.decoder. (case g!vars
+ #;Nil
+ (` (;;shape^ [(~@ (List/map product;right pattern-matching))]))
+
+ _
+ (` (lambda [(~@ g!vars)]
+ (;;shape^ [(~@ (List/map product;right pattern-matching))]))))]]
+ (wrap (` (: (~ :x:+) (~ .decoder.))))
+ ))
+ (do @
+ [[:func: :args:] (poly;apply :x:)
+ .func. (Codec<JSON,?>//decode *env* :func:)
+ .args. (mapM @ (Codec<JSON,?>//decode *env*) :args:)]
+ (wrap (` (: (~ (->Codec//decode (type;type-to-ast :x:)))
+ ((~ .func.) (~@ .args.))))))
+ (do @
+ [g!bound (poly;bound *env* :x:)]
+ (wrap g!bound))
+ (compiler;fail (format "Can't create JSON decoder for: " (type;type-to-text :x:)))
+ ))))
+
+(syntax: #export (Codec<JSON,?> :x:)
+ (wrap (list (` (: (Codec JSON (~ :x:))
+ (struct
+ (def: (~ (' encode)) (|Codec@JSON//encode| (~ :x:)))
+ (def: (~ (' decode)) (Codec<JSON,?>//decode (~ :x:)))
+ ))))))
diff --git a/stdlib/source/lux/data/ident.lux b/stdlib/source/lux/data/ident.lux
new file mode 100644
index 000000000..4f85da77d
--- /dev/null
+++ b/stdlib/source/lux/data/ident.lux
@@ -0,0 +1,57 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control eq
+ codec
+ hash)
+ (data [text "Text/" Monoid<Text> Eq<Text>])))
+
+## [Types]
+## (type: Ident
+## [Text Text])
+
+## [Functions]
+(do-template [<name> <side>]
+ [(def: #export (<name> [module name])
+ (-> Ident Text)
+ <side>)]
+
+ [module module]
+ [name name]
+ )
+
+## [Structures]
+(struct: #export _ (Eq Ident)
+ (def: (= [xmodule xname] [ymodule yname])
+ (and (Text/= xmodule ymodule)
+ (Text/= xname yname))))
+
+(struct: #export _ (Codec Text Ident)
+ (def: (encode [module name])
+ (case module
+ "" name
+ _ ($_ Text/append module ";" name)))
+
+ (def: (decode input)
+ (if (Text/= "" input)
+ (#;Left (Text/append "Invalid format for Ident: " input))
+ (case (text;split-all-with ";" input)
+ (^ (list name))
+ (#;Right ["" name])
+
+ (^ (list module name))
+ (#;Right [module name])
+
+ _
+ (#;Left (Text/append "Invalid format for Ident: " input))))))
+
+(struct: #export _ (Hash Ident)
+ (def: eq Eq<Ident>)
+
+ (def: (hash [module name])
+ (let [(^open) text;Hash<Text>]
+ (*+ (hash module) (hash name)))))
diff --git a/stdlib/source/lux/data/identity.lux b/stdlib/source/lux/data/identity.lux
new file mode 100644
index 000000000..c986db0c0
--- /dev/null
+++ b/stdlib/source/lux/data/identity.lux
@@ -0,0 +1,37 @@
+## 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/.
+
+(;module:
+ lux
+ (lux/control (functor #as F #refer #all)
+ (applicative #as A #refer #all)
+ (monad #as M #refer #all)
+ (comonad #as CM #refer #all)))
+
+## [Types]
+(type: #export (Identity a)
+ a)
+
+## [Structures]
+(struct: #export _ (Functor Identity)
+ (def: map id))
+
+(struct: #export _ (Applicative Identity)
+ (def: functor Functor<Identity>)
+
+ (def: wrap id)
+
+ (def: (apply ff fa)
+ (ff fa)))
+
+(struct: #export _ (Monad Identity)
+ (def: applicative Applicative<Identity>)
+
+ (def: join id))
+
+(struct: #export _ (CoMonad Identity)
+ (def: functor Functor<Identity>)
+ (def: unwrap id)
+ (def: split id))
diff --git a/stdlib/source/lux/data/log.lux b/stdlib/source/lux/data/log.lux
new file mode 100644
index 000000000..9e6be6d56
--- /dev/null
+++ b/stdlib/source/lux/data/log.lux
@@ -0,0 +1,62 @@
+## 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/.
+
+(;module:
+ lux
+ (lux/control monoid
+ ["A" applicative #*]
+ functor
+ ["M" monad #*]))
+
+(type: #export (Log l a)
+ [l a])
+
+(struct: #export Functor<Log> (All [l]
+ (Functor (Log l)))
+ (def: (map f fa)
+ (let [[log datum] fa]
+ [log (f datum)])))
+
+(struct: #export (Applicative<Log> mon) (All [l]
+ (-> (Monoid l) (Applicative (Log l))))
+ (def: functor Functor<Log>)
+
+ (def: (wrap x)
+ [(:: mon unit) x])
+
+ (def: (apply ff fa)
+ (let [[log1 f] ff
+ [log2 a] fa]
+ [(:: mon append log1 log2) (f a)])))
+
+(struct: #export (Monad<Log> mon) (All [l]
+ (-> (Monoid l) (Monad (Log l))))
+ (def: applicative (Applicative<Log> mon))
+
+ (def: (join mma)
+ (let [[log1 [log2 a]] mma]
+ [(:: mon append log1 log2) a])))
+
+(def: #export (log l)
+ (All [l] (-> l (Log l Unit)))
+ [l []])
+
+(struct: #export (LogT Monoid<l> Monad<M>)
+ (All [l M] (-> (Monoid l) (Monad M) (Monad (All [a] (M (Log l a))))))
+ (def: applicative (A;compA (get@ #M;applicative Monad<M>) (Applicative<Log> Monoid<l>)))
+ (def: (join MlMla)
+ (do Monad<M>
+ [[l1 Mla] (: (($ 1) (Log ($ 0) (($ 1) (Log ($ 0) ($ 2)))))
+ MlMla)
+ [l2 a] (: (($ 1) (Log ($ 0) ($ 2)))
+ Mla)]
+ (wrap [(:: Monoid<l> append l1 l2) a]))))
+
+(def: #export (lift-log Monoid<l> Monad<M>)
+ (All [l M a] (-> (Monoid l) (Monad M) (-> (M a) (M (Log l a)))))
+ (lambda [ma]
+ (do Monad<M>
+ [a ma]
+ (wrap [(:: Monoid<l> unit) a]))))
diff --git a/stdlib/source/lux/data/maybe.lux b/stdlib/source/lux/data/maybe.lux
new file mode 100644
index 000000000..16aa9e30a
--- /dev/null
+++ b/stdlib/source/lux/data/maybe.lux
@@ -0,0 +1,82 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control (monoid #as m #refer #all)
+ (functor #as F #refer #all)
+ (applicative #as A #refer #all)
+ (monad #as M #refer #all)
+ eq)))
+
+## [Types]
+## (type: (Maybe a)
+## #;None
+## (#;Some a))
+
+## [Structures]
+(struct: #export Monoid<Maybe> (All [a] (Monoid (Maybe a)))
+ (def: unit #;None)
+ (def: (append xs ys)
+ (case xs
+ #;None ys
+ (#;Some x) (#;Some x))))
+
+(struct: #export _ (Functor Maybe)
+ (def: (map f ma)
+ (case ma
+ #;None #;None
+ (#;Some a) (#;Some (f a)))))
+
+(struct: #export _ (Applicative Maybe)
+ (def: functor Functor<Maybe>)
+
+ (def: (wrap x)
+ (#;Some x))
+
+ (def: (apply ff fa)
+ (case [ff fa]
+ [(#;Some f) (#;Some a)]
+ (#;Some (f a))
+
+ _
+ #;None)))
+
+(struct: #export _ (Monad Maybe)
+ (def: applicative Applicative<Maybe>)
+
+ (def: (join mma)
+ (case mma
+ #;None #;None
+ (#;Some xs) xs)))
+
+(struct: #export (Eq<Maybe> Eq<a>) (All [a] (-> (Eq a) (Eq (Maybe a))))
+ (def: (= mx my)
+ (case [mx my]
+ [#;None #;None]
+ true
+
+ [(#;Some x) (#;Some y)]
+ (:: Eq<a> = x y)
+
+ _
+ false)))
+
+(struct: #export (MaybeT Monad<M>)
+ (All [M] (-> (Monad M) (Monad (All [a] (M (Maybe a))))))
+ (def: applicative (A;compA (get@ #M;applicative Monad<M>) Applicative<Maybe>))
+ (def: (join MmMma)
+ (do Monad<M>
+ [mMma MmMma]
+ (case mMma
+ #;None
+ (wrap #;None)
+
+ (#;Some Mma)
+ (join Mma)))))
+
+(def: #export (lift-maybe Monad<M>)
+ (All [M a] (-> (Monad M) (-> (M a) (M (Maybe a)))))
+ (liftM Monad<M> (:: Monad<Maybe> wrap)))
diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux
new file mode 100644
index 000000000..41c75402e
--- /dev/null
+++ b/stdlib/source/lux/data/number.lux
@@ -0,0 +1,222 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control number
+ monoid
+ eq
+ hash
+ [ord]
+ enum
+ bounded
+ codec)
+ (data error)))
+
+## [Structures]
+(do-template [<type> <test>]
+ [(struct: #export _ (Eq <type>)
+ (def: = <test>))]
+
+ [ Nat =+]
+ [ Int =]
+ [Frac =..]
+ [Real =.]
+ )
+
+(do-template [<type> <eq> <lt> <lte> <gt> <gte>]
+ [(struct: #export _ (ord;Ord <type>)
+ (def: eq <eq>)
+ (def: < <lt>)
+ (def: <= <lte>)
+ (def: > <gt>)
+ (def: >= <gte>))]
+
+ [ Nat Eq<Nat> <+ <=+ >+ >=+]
+ [ Int Eq<Int> < <= > >=]
+ [Frac Eq<Frac> <.. <=.. >.. >=..]
+ [Real Eq<Real> <. <=. >. >=.]
+ )
+
+(struct: #export _ (Number Nat)
+ (def: ord Ord<Nat>)
+ (def: + ++)
+ (def: - -+)
+ (def: * *+)
+ (def: / /+)
+ (def: % %+)
+ (def: negate id)
+ (def: abs id)
+ (def: (signum x)
+ (case x
+ +0 +0
+ _ +1))
+ )
+
+(do-template [<type> <ord> <+> <-> <*> </> <%> <=> <<> <0> <1> <-1>]
+ [(struct: #export _ (Number <type>)
+ (def: ord <ord>)
+ (def: + <+>)
+ (def: - <->)
+ (def: * <*>)
+ (def: / </>)
+ (def: % <%>)
+ (def: negate (<*> <-1>))
+ (def: (abs x)
+ (if (<<> <0> x)
+ (<*> <-1> x)
+ x))
+ (def: (signum x)
+ (cond (<=> <0> x) <0>
+ (<<> <0> x) <-1>
+ ## else
+ <1>))
+ )]
+
+ [ Int Ord<Int> + - * / % = < 0 1 -1]
+ [Real Ord<Real> +. -. *. /. %. =. <. 0.0 1.0 -1.0]
+ )
+
+(do-template [<type> <ord> <succ> <pred>]
+ [(struct: #export _ (Enum <type>)
+ (def: ord <ord>)
+ (def: succ <succ>)
+ (def: pred <pred>))]
+
+ [Nat Ord<Nat> (++ +1) (-+ +1)]
+ [Int Ord<Int> inc dec]
+ )
+
+(do-template [<type> <top> <bottom>]
+ [(struct: #export _ (Bounded <type>)
+ (def: top <top>)
+ (def: bottom <bottom>))]
+
+ [ Nat (_lux_proc ["nat" "max-value"] []) (_lux_proc ["nat" "min-value"] [])]
+ [ Int (_lux_proc ["jvm" "getstatic:java.lang.Long:MAX_VALUE"] []) (_lux_proc ["jvm" "getstatic:java.lang.Long:MIN_VALUE"] [])]
+ [Real (_lux_proc ["jvm" "getstatic:java.lang.Double:MAX_VALUE"] []) (_lux_proc ["jvm" "getstatic:java.lang.Double:MIN_VALUE"] [])])
+
+(do-template [<name> <type> <unit> <append>]
+ [(struct: #export <name> (Monoid <type>)
+ (def: unit <unit>)
+ (def: (append x y) (<append> x y)))]
+
+ [ Add@Monoid<Nat> Nat +0 ++]
+ [ Mul@Monoid<Nat> Nat +1 *+]
+ [ Max@Monoid<Nat> Nat (:: Bounded<Nat> bottom) max+]
+ [ Min@Monoid<Nat> Nat (:: Bounded<Nat> top) min+]
+ [ Add@Monoid<Int> Int 0 +]
+ [ Mul@Monoid<Int> Int 1 *]
+ [ Max@Monoid<Int> Int (:: Bounded<Int> bottom) max]
+ [ Min@Monoid<Int> Int (:: Bounded<Int> top) min]
+ [Add@Monoid<Real> Real 0.0 +.]
+ [Mul@Monoid<Real> Real 1.0 *.]
+ [Max@Monoid<Real> Real (:: Bounded<Real> bottom) max.]
+ [Min@Monoid<Real> Real (:: Bounded<Real> top) min.]
+ )
+
+(def: (text.replace pattern value template)
+ (-> Text Text Text Text)
+ (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value]))
+
+(do-template [<type> <encoder> <decoder> <error>]
+ [(struct: #export _ (Codec Text <type>)
+ (def: (encode x)
+ (_lux_proc <encoder> [x]))
+
+ (def: (decode input)
+ (case (_lux_proc <decoder> [input])
+ (#;Some value)
+ (#;Right value)
+
+ #;None
+ (#;Left <error>))))]
+
+ [Nat ["nat" "encode"] ["nat" "decode"] "Couldn't decode Nat"]
+ [Frac ["frac" "encode"] ["frac" "decode"] "Couldn't decode Frac"]
+ )
+
+(def: clean-number
+ (-> Text Text)
+ (|>. (text.replace "," "")
+ (text.replace "_" "")))
+
+(do-template [<type> <encode> <decode> <error>]
+ [(struct: #export _ (Codec Text <type>)
+ (def: (encode x)
+ (_lux_proc ["jvm" <encode>] [x]))
+
+ (def: (decode input)
+ (_lux_proc ["jvm" "try"]
+ [(#;Right (_lux_proc ["jvm" <decode>] [(clean-number input)]))
+ (lambda [e] (#;Left <error>))])))]
+
+ [ Int "invokevirtual:java.lang.Object:toString:" "invokestatic:java.lang.Long:parseLong:java.lang.String" "Couldn't parse Int"]
+ [Real "invokevirtual:java.lang.Object:toString:" "invokestatic:java.lang.Double:parseDouble:java.lang.String" "Couldn't parse Real"]
+ )
+
+(struct: #export _ (Hash Nat)
+ (def: eq Eq<Nat>)
+ (def: hash id))
+
+(struct: #export _ (Hash Int)
+ (def: eq Eq<Int>)
+ (def: hash int-to-nat))
+
+(struct: #export _ (Hash Real)
+ (def: eq Eq<Real>)
+
+ (def: hash
+ (|>. (:: Codec<Text,Real> encode)
+ []
+ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:hashCode:"])
+ []
+ (_lux_proc ["jvm" "i2l"])
+ int-to-nat)))
+
+## [Values & Syntax]
+(do-template [<struct> <to-proc> <radix> <macro> <error> <doc>]
+ [(struct: #export <struct> (Codec Text Nat)
+ (def: (encode value)
+ (_lux_proc ["jvm" <to-proc>] [(nat-to-int value)]))
+
+ (def: (decode repr)
+ (_lux_proc ["jvm" "try"]
+ [(#;Right (int-to-nat (_lux_proc ["jvm" "invokestatic:java.lang.Long:valueOf:java.lang.String,int"] [repr (_lux_proc ["jvm" "l2i"] [<radix>])])))
+ (lambda [ex] (#;Left <error>))])))
+
+ (macro: #export (<macro> tokens state)
+ {#;doc <doc>}
+ (case tokens
+ (#;Cons [meta (#;TextS repr)] #;Nil)
+ (case (:: <struct> decode repr)
+ (#;Right value)
+ (#;Right [state (list [meta (#;NatS value)])])
+
+ (#;Left error)
+ (#;Left error))
+
+ _
+ (#;Left <error>)))]
+
+ [Binary@Codec<Text,Nat> "invokestatic:java.lang.Long:toBinaryString:long" 2 bin "Invalid binary syntax."
+ (doc "Given syntax for a binary number, generates a Nat."
+ (bin "11001001"))]
+ [Octal@Codec<Text,Nat> "invokestatic:java.lang.Long:toOctalString:long" 8 oct "Invalid octal syntax."
+ (doc "Given syntax for an octal number, generates a Nat."
+ (oct "0615243"))]
+ [Hex@Codec<Text,Nat> "invokestatic:java.lang.Long:toHexString:long" 16 hex "Invalid hexadecimal syntax."
+ (doc "Given syntax for a hexadecimal number, generates a Nat."
+ (hex "deadBEEF"))]
+ )
+
+(do-template [<name> <field>]
+ [(def: #export <name> Real
+ (_lux_proc ["jvm" <field>] []))]
+
+ [nan "getstatic:java.lang.Double:NaN"]
+ [+inf "getstatic:java.lang.Double:POSITIVE_INFINITY"]
+ [-inf "getstatic:java.lang.Double:NEGATIVE_INFINITY"]
+ )
diff --git a/stdlib/source/lux/data/product.lux b/stdlib/source/lux/data/product.lux
new file mode 100644
index 000000000..f542d7a38
--- /dev/null
+++ b/stdlib/source/lux/data/product.lux
@@ -0,0 +1,35 @@
+## 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/.
+
+(;module: lux)
+
+## [Functions]
+(do-template [<name> <type> <output>]
+ [(def: #export (<name> xy)
+ (All [a b] (-> [a b] <type>))
+ (let [[x y] xy]
+ <output>))]
+
+ [left a x]
+ [right b y])
+
+(def: #export (curry f)
+ (All [a b c]
+ (-> (-> [a b] c)
+ (-> a b c)))
+ (lambda [x y]
+ (f [x y])))
+
+(def: #export (uncurry f)
+ (All [a b c]
+ (-> (-> a b c) (-> [a b] c)))
+ (lambda [xy]
+ (let [[x y] xy]
+ (f x y))))
+
+(def: #export (swap xy)
+ (All [a b] (-> [a b] [b a]))
+ (let [[x y] xy]
+ [y x]))
diff --git a/stdlib/source/lux/data/struct/array.lux b/stdlib/source/lux/data/struct/array.lux
new file mode 100644
index 000000000..6c81683d3
--- /dev/null
+++ b/stdlib/source/lux/data/struct/array.lux
@@ -0,0 +1,224 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monoid
+ functor
+ applicative
+ monad
+ eq
+ fold)
+ (data error
+ (struct [list "List/" Fold<List>])
+ [product])
+ ))
+
+## [Types]
+(type: #export (Array a)
+ (#;HostT "#Array" (#;Cons a #;Nil)))
+
+## [Functions]
+(def: #export (new size)
+ (All [a] (-> Nat (Array a)))
+ (_lux_proc ["array" "new"] [size]))
+
+(def: #export (size xs)
+ (All [a] (-> (Array a) Nat))
+ (_lux_proc ["array" "size"] [xs]))
+
+(def: #export (get i xs)
+ (All [a]
+ (-> Nat (Array a) (Maybe a)))
+ (_lux_proc ["array" "get"] [xs i]))
+
+(def: #export (put i x xs)
+ (All [a]
+ (-> Nat a (Array a) (Array a)))
+ (_lux_proc ["array" "put"] [xs i x]))
+
+(def: #export (remove i xs)
+ (All [a]
+ (-> Nat (Array a) (Array a)))
+ (_lux_proc ["array" "remove"] [xs i]))
+
+(def: #export (copy length src-start src-array dest-start dest-array)
+ (All [a] (-> Nat Nat (Array a) Nat (Array a)
+ (Array a)))
+ (if (=+ +0 length)
+ dest-array
+ (List/fold (lambda [offset target]
+ (case (get (++ offset src-start) src-array)
+ #;None
+ target
+
+ (#;Some value)
+ (put (++ offset dest-start) value target)))
+ dest-array
+ (list;range+ +0 (dec+ length)))))
+
+(def: #export (occupied array)
+ {#;doc "Finds out how many cells in an array are occupied."}
+ (All [a] (-> (Array a) Nat))
+ (List/fold (lambda [idx count]
+ (case (get idx array)
+ #;None
+ count
+
+ (#;Some _)
+ (inc+ count)))
+ +0
+ (list;indices (size array))))
+
+(def: #export (vacant array)
+ {#;doc "Finds out how many cells in an array are vacant."}
+ (All [a] (-> (Array a) Nat))
+ (-+ (occupied array) (size array)))
+
+(def: #export (filter p xs)
+ (All [a]
+ (-> (-> a Bool) (Array a) (Array a)))
+ (List/fold (: (-> Nat (Array ($ 0)) (Array ($ 0)))
+ (lambda [idx xs']
+ (case (get idx xs)
+ #;None
+ xs'
+
+ (#;Some x)
+ (if (p x)
+ xs'
+ (remove idx xs')))))
+ xs
+ (list;indices (size xs))))
+
+(def: #export (find p xs)
+ (All [a]
+ (-> (-> a Bool) (Array a) (Maybe a)))
+ (let [arr-size (size xs)]
+ (loop [idx +0]
+ (if (<+ arr-size idx)
+ (case (get idx xs)
+ #;None
+ (recur (inc+ idx))
+
+ (#;Some x)
+ (if (p x)
+ (#;Some x)
+ (recur (inc+ idx))))
+ #;None))))
+
+(def: #export (find+ p xs)
+ {#;doc "Just like 'find', but with access to the index of each value."}
+ (All [a]
+ (-> (-> Nat a Bool) (Array a) (Maybe [Nat a])))
+ (let [arr-size (size xs)]
+ (loop [idx +0]
+ (if (<+ arr-size idx)
+ (case (get idx xs)
+ #;None
+ (recur (inc+ idx))
+
+ (#;Some x)
+ (if (p idx x)
+ (#;Some [idx x])
+ (recur (inc+ idx))))
+ #;None))))
+
+(def: #export (clone xs)
+ (All [a] (-> (Array a) (Array a)))
+ (let [arr-size (size xs)]
+ (List/fold (lambda [idx ys]
+ (case (get idx xs)
+ #;None
+ ys
+
+ (#;Some x)
+ (put idx x ys)))
+ (new arr-size)
+ (list;indices arr-size))))
+
+(def: #export (from-list xs)
+ (All [a] (-> (List a) (Array a)))
+ (product;right (List/fold (lambda [x [idx arr]]
+ [(inc+ idx) (put idx x arr)])
+ [+0 (new (list;size xs))]
+ xs)))
+
+(def: #export (to-list array)
+ (All [a] (-> (Array a) (List a)))
+ (let [_size (size array)]
+ (product;right (List/fold (lambda [_ [idx tail]]
+ (case (get idx array)
+ (#;Some head)
+ [(dec+ idx) (#;Cons head tail)]
+
+ #;None
+ [(dec+ idx) tail]))
+ [(dec+ _size) #;Nil]
+ (list;repeat _size [])
+ ))))
+
+## [Structures]
+(struct: #export (Eq<Array> (^open "a:"))
+ (All [a] (-> (Eq a) (Eq (Array a))))
+ (def: (= xs ys)
+ (let [sxs (size xs)
+ sxy (size ys)]
+ (and (lux;=+ sxy sxs)
+ (List/fold (lambda [idx prev]
+ (and prev
+ (case [(get idx xs) (get idx ys)]
+ [#;None #;None]
+ true
+
+ [(#;Some x) (#;Some y)]
+ (a:= x y)
+
+ _
+ false)))
+ true
+ (list;range+ +0 (dec+ sxs)))))
+ ))
+
+(struct: #export Monoid<Array> (All [a]
+ (Monoid (Array a)))
+ (def: unit (new +0))
+
+ (def: (append xs ys)
+ (let [sxs (size xs)
+ sxy (size ys)]
+ (|> (new (++ sxy sxs))
+ (copy sxs +0 xs +0)
+ (copy sxy +0 ys sxs)))))
+
+(struct: #export _ (Functor Array)
+ (def: (map f ma)
+ (let [arr-size (size ma)]
+ (if (=+ +0 arr-size)
+ (new arr-size)
+ (List/fold (: (-> Nat (Array ($ 1)) (Array ($ 1)))
+ (lambda [idx mb]
+ (case (get idx ma)
+ #;None
+ mb
+
+ (#;Some x)
+ (put idx (f x) mb))))
+ (new arr-size)
+ (list;range+ +0 (dec+ arr-size)))))))
+
+(struct: #export _ (Fold Array)
+ (def: (fold f init xs)
+ (let [arr-size (size xs)]
+ (loop [so-far init
+ idx +0]
+ (if (<+ arr-size idx)
+ (case (get idx xs)
+ #;None
+ (recur so-far (inc+ idx))
+
+ (#;Some value)
+ (recur (f value so-far) (inc+ idx)))
+ so-far)))))
diff --git a/stdlib/source/lux/data/struct/dict.lux b/stdlib/source/lux/data/struct/dict.lux
new file mode 100644
index 000000000..a10e30dca
--- /dev/null
+++ b/stdlib/source/lux/data/struct/dict.lux
@@ -0,0 +1,675 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control hash
+ eq)
+ (data maybe
+ (struct [list "List/" Fold<List> Functor<List> Monoid<List>]
+ [array #+ Array "Array/" Functor<Array> Fold<Array>])
+ [bit]
+ [product]
+ text/format
+ [number])
+ ))
+
+## This implementation of Hash Array Mapped Trie (HAMT) is based on
+## Clojure's PersistentHashMap implementation.
+## That one is further based on Phil Bagwell's Hash Array Mapped Trie.
+
+## [Utils]
+## Bitmaps are used to figure out which branches on a #Base node are
+## populated. The number of bits that are 1s in a bitmap signal the
+## size of the #Base node.
+(type: BitMap Nat)
+
+## Represents the position of a node in a BitMap.
+## It's meant to be a single bit set on a 32-bit word.
+## The position of the bit reflects whether an entry in an analogous
+## position exists within a #Base, as reflected in it's BitMap.
+(type: BitPosition Nat)
+
+## An index into an array.
+(type: Index Nat)
+
+## A hash-code derived from a key during tree-traversal.
+(type: Hash-Code Nat)
+
+## Represents the nesting level of a leaf or node, when looking-it-up
+## while exploring the tree.
+## Changes in levels are done by right-shifting the hashes of keys by
+## the appropriate multiple of the branching-exponent.
+## A shift of 0 means root level.
+## A shift of (* branching-exponent 1) means level 2.
+## A shift of (* branching-exponent N) means level N+1.
+(type: Level Nat)
+
+## Nodes for the tree data-structure that organizes the data inside
+## Dicts.
+(type: (Node k v)
+ (#Hierarchy Nat (Array (Node k v)))
+ (#Base BitMap
+ (Array (Either (Node k v)
+ [k v])))
+ (#Collisions Hash-Code (Array [k v])))
+
+## #Hierarchy nodes are meant to point down only to lower-level nodes.
+(type: (Hierarchy k v)
+ [Nat (Array (Node k v))])
+
+## #Base nodes may point down to other nodes, but also to leaves,
+## which are KV pairs.
+(type: (Base k v)
+ (Array (Either (Node k v)
+ [k v])))
+
+## #Collisions are collections of KV-pairs for which the key is
+## different on each case, but their hashes are all the same (thus
+## causing a collision).
+(type: (Collisions k v)
+ (Array [k v]))
+
+## That bitmap for an empty #Base is 0.
+## Which is the same as 0000 0000 0000 0000 0000 0000 0000 0000.
+## Or 0x00000000.
+## Which is 32 zeroes, since the branching factor is 32.
+(def: clean-bitmap
+ BitMap
+ +0)
+
+## Bitmap position (while looking inside #Base nodes) is determined by
+## getting 5 bits from a hash of the key being looked up and using
+## them as an index into the array inside #Base.
+## Since the data-structure can have multiple levels (and the hash has
+## more than 5 bits), the binary-representation of the hash is shifted
+## by 5 positions on each step (2^5 = 32, which is the branching
+## factor).
+## The initial shifting level, though, is 0 (which corresponds to the
+## shift in the shallowest node on the tree, which is the root node).
+(def: root-level
+ Level
+ +0)
+
+## The exponent to which 2 must be elevated, to reach the branching
+## factor of the data-structure.
+(def: branching-exponent
+ Nat
+ +5)
+
+## The threshold on which #Hierarchy nodes are demoted to #Base nodes,
+## which is 1/4 of the branching factor (or a left-shift 2).
+(def: demotion-threshold
+ Nat
+ (bit;<< (-+ +2 branching-exponent) +1))
+
+## The threshold on which #Base nodes are promoted to #Hierarchy nodes,
+## which is 1/2 of the branching factor (or a left-shift 1).
+(def: promotion-threshold
+ Nat
+ (bit;<< (-+ +1 branching-exponent) +1))
+
+## The size of hierarchy-nodes, which is 2^(branching-exponent).
+(def: hierarchy-nodes-size
+ Nat
+ (bit;<< branching-exponent +1))
+
+## The cannonical empty node, which is just an empty #Base node.
+(def: empty
+ Node
+ (#Base clean-bitmap (array;new +0)))
+
+## Expands a copy of the array, to have 1 extra slot, which is used
+## for storing the value.
+(def: (insert! idx value old-array)
+ (All [a] (-> Index a (Array a) (Array a)))
+ (let [old-size (array;size old-array)]
+ (|> (: (Array ($ 0))
+ (array;new (inc+ old-size)))
+ (array;copy idx +0 old-array +0)
+ (array;put idx value)
+ (array;copy (-+ idx old-size) idx old-array (inc+ idx)))))
+
+## Creates a copy of an array with an index set to a particular value.
+(def: (update! idx value array)
+ (All [a] (-> Index a (Array a) (Array a)))
+ (|> array array;clone (array;put idx value)))
+
+## Creates a clone of the array, with an empty position at index.
+(def: (vacant! idx array)
+ (All [a] (-> Index (Array a) (Array a)))
+ (|> array array;clone (array;remove idx)))
+
+## Shrinks a copy of the array by removing the space at index.
+(def: (remove! idx array)
+ (All [a] (-> Index (Array a) (Array a)))
+ (let [new-size (dec+ (array;size array))]
+ (|> (array;new new-size)
+ (array;copy idx +0 array +0)
+ (array;copy (-+ idx new-size) (inc+ idx) array idx))))
+
+## Given a top-limit for indices, produces all indices in [0, R).
+(def: indices-for
+ (-> Nat (List Index))
+ (|>. dec+ (list;range+ +0)))
+
+## Increases the level-shift by the branching-exponent, to explore
+## levels further down the tree.
+(def: level-up
+ (-> Level Level)
+ (++ branching-exponent))
+
+(def: hierarchy-mask BitMap (dec+ hierarchy-nodes-size))
+
+## Gets the branching-factor sized section of the hash corresponding
+## to a particular level, and uses that as an index into the array.
+(def: (level-index level hash)
+ (-> Level Hash-Code Index)
+ (bit;& hierarchy-mask
+ (bit;>>> level hash)))
+
+## A mechanism to go from indices to bit-positions.
+(def: (->bit-position index)
+ (-> Index BitPosition)
+ (bit;<< index +1))
+
+## The bit-position within a base that a given hash-code would have.
+(def: (bit-position level hash)
+ (-> Level Hash-Code BitPosition)
+ (->bit-position (level-index level hash)))
+
+(def: (bit-position-is-set? bit bitmap)
+ (-> BitPosition BitMap Bool)
+ (not (=+ clean-bitmap (bit;& bit bitmap))))
+
+## Figures out whether a bitmap only contains a single bit-position.
+(def: only-bit-position?
+ (-> BitPosition BitMap Bool)
+ =+)
+
+(def: (set-bit-position bit bitmap)
+ (-> BitPosition BitMap BitMap)
+ (bit;| bit bitmap))
+
+(def: unset-bit-position
+ (-> BitPosition BitMap BitMap)
+ bit;^)
+
+## Figures out the size of a bitmap-indexed array by counting all the
+## 1s within the bitmap.
+(def: bitmap-size
+ (-> BitMap Nat)
+ bit;count)
+
+## A mask that, for a given bit position, only allows all the 1s prior
+## to it, which would indicate the bitmap-size (and, thus, index)
+## associated with it.
+(def: bit-position-mask
+ (-> BitPosition BitMap)
+ dec+)
+
+## The index on the base array, based on it's bit-position.
+(def: (base-index bit-position bitmap)
+ (-> BitPosition BitMap Index)
+ (bitmap-size (bit;& (bit-position-mask bit-position)
+ bitmap)))
+
+## Produces the index of a KV-pair within a #Collisions node.
+(def: (collision-index Hash<K> key colls)
+ (All [K V] (-> (Hash K) K (Collisions K V) (Maybe Index)))
+ (:: Monad<Maybe> map product;left
+ (array;find+ (lambda [idx [key' val']]
+ (:: Hash<K> = key key'))
+ colls)))
+
+## When #Hierarchy nodes grow too small, they're demoted to #Base
+## nodes to save space.
+(def: (demote-hierarchy except-idx [h-size h-array])
+ (All [k v] (-> Index (Hierarchy k v) [BitMap (Base k v)]))
+ (List/fold (lambda [idx (^@ node [bitmap base])]
+ (case (array;get idx h-array)
+ #;None node
+ (#;Some sub-node) (if (=+ except-idx idx)
+ node
+ [(set-bit-position (->bit-position idx) bitmap)
+ (array;put idx (#;Left sub-node) base)])
+ ))
+ [clean-bitmap
+ (: (Base ($ 0) ($ 1))
+ (array;new (dec+ h-size)))]
+ (list;indices (array;size h-array))))
+
+## When #Base nodes grow too large, they're promoted to #Hierarchy to
+## add some depth to the tree and help keep it's balance.
+(def: (promote-base put' Hash<K> level bitmap base)
+ (All [K V]
+ (-> (-> Level Hash-Code K V (Hash K) (Node K V) (Node K V))
+ (Hash K) Level
+ BitMap (Base K V)
+ (Array (Node K V))))
+ (product;right (List/fold (lambda [hierarchy-idx (^@ default [base-idx h-array])]
+ (if (bit-position-is-set? (->bit-position hierarchy-idx)
+ bitmap)
+ [(inc+ base-idx)
+ (case (array;get base-idx base)
+ (#;Some (#;Left sub-node))
+ (array;put hierarchy-idx sub-node h-array)
+
+ (#;Some (#;Right [key' val']))
+ (array;put hierarchy-idx
+ (put' (level-up level) (:: Hash<K> hash key') key' val' Hash<K> empty)
+ h-array)
+
+ #;None
+ (undefined))]
+ default))
+ [+0
+ (: (Array (Node ($ 0) ($ 1)))
+ (array;new hierarchy-nodes-size))]
+ (indices-for hierarchy-nodes-size))))
+
+## All empty nodes look the same (a #Base node with clean bitmap is
+## used).
+## So, this test is introduced to detect them.
+(def: (empty?' node)
+ (All [K V] (-> (Node K V) Bool))
+ (case node
+ (^~ (#Base ;;clean-bitmap _))
+ true
+
+ _
+ false))
+
+(def: (put' level hash key val Hash<K> node)
+ (All [K V] (-> Level Hash-Code K V (Hash K) (Node K V) (Node K V)))
+ (case node
+ ## For #Hierarchy nodes, I check whether I can add the element to
+ ## a sub-node. If impossible, I introduced a new singleton sub-node.
+ (#Hierarchy _size hierarchy)
+ (let [idx (level-index level hash)
+ [_size' sub-node] (: [Nat (Node ($ 0) ($ 1))]
+ (case (array;get idx hierarchy)
+ (#;Some sub-node)
+ [_size sub-node]
+
+ _
+ [(inc+ _size) empty]))]
+ (#Hierarchy _size'
+ (update! idx (put' (level-up level) hash key val Hash<K> sub-node)
+ hierarchy)))
+
+ ## For #Base nodes, I check if the corresponding BitPosition has
+ ## already been used.
+ (#Base bitmap base)
+ (let [bit (bit-position level hash)]
+ (if (bit-position-is-set? bit bitmap)
+ ## If so...
+ (let [idx (base-index bit bitmap)]
+ (case (array;get idx base)
+ #;None
+ (undefined)
+
+ ## If it's being used by a node, I add the KV to it.
+ (#;Some (#;Left sub-node))
+ (let [sub-node' (put' (level-up level) hash key val Hash<K> sub-node)]
+ (#Base bitmap (update! idx (#;Left sub-node') base)))
+
+ ## Otherwise, if it's being used by a KV, I compare the keys.
+ (#;Some (#;Right key' val'))
+ (if (:: Hash<K> = key key')
+ ## If the same key is found, I replace the value.
+ (#Base bitmap (update! idx (#;Right key val) base))
+ ## Otherwise, I compare the hashes of the keys.
+ (#Base bitmap (update! idx
+ (#;Left (let [hash' (:: Hash<K> hash key')]
+ (if (=+ hash hash')
+ ## If the hashes are
+ ## the same, a new
+ ## #Collisions node
+ ## is added.
+ (#Collisions hash (|> (: (Array [($ 0) ($ 1)])
+ (array;new +2))
+ (array;put +0 [key' val'])
+ (array;put +1 [key val])))
+ ## Otherwise, I can
+ ## just keep using
+ ## #Base nodes, so I
+ ## add both KV pairs
+ ## to the empty one.
+ (let [next-level (level-up level)]
+ (|> empty
+ (put' next-level hash' key' val' Hash<K>)
+ (put' next-level hash key val Hash<K>))))))
+ base)))))
+ ## However, if the BitPosition has not been used yet, I check
+ ## whether this #Base node is ready for a promotion.
+ (let [base-count (bitmap-size bitmap)]
+ (if (>=+ promotion-threshold base-count)
+ ## If so, I promote it to a #Hierarchy node, and add the new
+ ## KV-pair as a singleton node to it.
+ (#Hierarchy (inc+ base-count)
+ (|> (promote-base put' Hash<K> level bitmap base)
+ (array;put (level-index level hash)
+ (put' (level-up level) hash key val Hash<K> empty))))
+ ## Otherwise, I just resize the #Base node to accommodate the
+ ## new KV-pair.
+ (#Base (set-bit-position bit bitmap)
+ (insert! (base-index bit bitmap) (#;Right [key val]) base))))))
+
+ ## For #Collisions nodes, I compare the hashes.
+ (#Collisions _hash _colls)
+ (if (=+ hash _hash)
+ ## If they're equal, that means the new KV contributes to the
+ ## collisions.
+ (case (collision-index Hash<K> key _colls)
+ ## If the key was already present in the collisions-list, it's
+ ## value gets updated.
+ (#;Some coll-idx)
+ (#Collisions _hash (update! coll-idx [key val] _colls))
+
+ ## Otherwise, the KV-pair is added to the collisions-list.
+ #;None
+ (#Collisions _hash (insert! (array;size _colls) [key val] _colls)))
+ ## If the hashes are not equal, I create a new #Base node that
+ ## contains the old #Collisions node, plus the new KV-pair.
+ (|> (#Base (bit-position level _hash)
+ (|> (: (Base ($ 0) ($ 1))
+ (array;new +1))
+ (array;put +0 (#;Left node))))
+ (put' level hash key val Hash<K>)))
+ ))
+
+(def: (remove' level hash key Hash<K> node)
+ (All [K V] (-> Level Hash-Code K (Hash K) (Node K V) (Node K V)))
+ (case node
+ ## For #Hierarchy nodes, find out if there's a valid sub-node for
+ ## the Hash-Code.
+ (#Hierarchy h-size h-array)
+ (let [idx (level-index level hash)]
+ (case (array;get idx h-array)
+ ## If not, there's nothing to remove.
+ #;None
+ node
+
+ ## But if there is, try to remove the key from the sub-node.
+ (#;Some sub-node)
+ (let [sub-node' (remove' (level-up level) hash key Hash<K> sub-node)]
+ ## Then check if a removal was actually done.
+ (if (== sub-node sub-node')
+ ## If not, then there's nothing to change here either.
+ node
+ ## But if the sub-removal yielded an empty sub-node...
+ (if (empty?' sub-node')
+ ## Check if it's due time for a demotion.
+ (if (<=+ demotion-threshold h-size)
+ ## If so, perform it.
+ (#Base (demote-hierarchy idx [h-size h-array]))
+ ## Otherwise, just clear the space.
+ (#Hierarchy (dec+ h-size) (vacant! idx h-array)))
+ ## But if the sub-removal yielded a non-empty node, then
+ ## just update the hiearchy branch.
+ (#Hierarchy h-size (update! idx sub-node' h-array)))))))
+
+ ## For #Base nodes, check whether the BitPosition is set.
+ (#Base bitmap base)
+ (let [bit (bit-position level hash)]
+ (if (bit-position-is-set? bit bitmap)
+ (let [idx (base-index bit bitmap)]
+ (case (array;get idx base)
+ #;None
+ (undefined)
+
+ ## If set, check if it's a sub-node, and remove the KV
+ ## from it.
+ (#;Some (#;Left sub-node))
+ (let [sub-node' (remove' (level-up level) hash key Hash<K> sub-node)]
+ ## Verify that it was removed.
+ (if (== sub-node sub-node')
+ ## If not, there's also nothing to change here.
+ node
+ ## But if it came out empty...
+ (if (empty?' sub-node')
+ ### ... figure out whether that's the only position left.
+ (if (only-bit-position? bit bitmap)
+ ## If so, removing it leaves this node empty too.
+ empty
+ ## But if not, then just unset the position and
+ ## remove the node.
+ (#Base (unset-bit-position bit bitmap)
+ (remove! idx base)))
+ ## But, if it didn't come out empty, then the
+ ## position is kept, and the node gets updated.
+ (#Base bitmap
+ (update! idx (#;Left sub-node') base)))))
+
+ ## If, however, there was a KV pair instead of a sub-node.
+ (#;Some (#;Right [key' val']))
+ ## Check if the keys match.
+ (if (:: Hash<K> = key key')
+ ## If so, remove the KV pair and unset the BitPosition.
+ (#Base (unset-bit-position bit bitmap)
+ (remove! idx base))
+ ## Otherwise, there's nothing to remove.
+ node)))
+ ## If the BitPosition is not set, there's nothing to remove.
+ node))
+
+ ## For #Collisions nodes, It need to find out if the key already existst.
+ (#Collisions _hash _colls)
+ (case (collision-index Hash<K> key _colls)
+ ## If not, then there's nothing to remove.
+ #;None
+ node
+
+ ## But if so, then check the size of the collisions list.
+ (#;Some idx)
+ (if (=+ +1 (array;size _colls))
+ ## If there's only one left, then removing it leaves us with
+ ## an empty node.
+ empty
+ ## Otherwise, just shrink the array by removing the KV pair.
+ (#Collisions _hash (remove! idx _colls))))
+ ))
+
+(def: (get' level hash key Hash<K> node)
+ (All [K V] (-> Level Hash-Code K (Hash K) (Node K V) (Maybe V)))
+ (case node
+ ## For #Hierarchy nodes, just look-up the key on its children.
+ (#Hierarchy _size hierarchy)
+ (case (array;get (level-index level hash) hierarchy)
+ #;None #;None
+ (#;Some sub-node) (get' (level-up level) hash key Hash<K> sub-node))
+
+ ## For #Base nodes, check the leaves, and recursively check the branches.
+ (#Base bitmap base)
+ (let [bit (bit-position level hash)]
+ (if (bit-position-is-set? bit bitmap)
+ (case (array;get (base-index bit bitmap) base)
+ #;None
+ (undefined)
+
+ (#;Some (#;Left sub-node))
+ (get' (level-up level) hash key Hash<K> sub-node)
+
+ (#;Some (#;Right [key' val']))
+ (if (:: Hash<K> = key key')
+ (#;Some val')
+ #;None))
+ #;None))
+
+ ## For #Collisions nodes, do a linear scan of all the known KV-pairs.
+ (#Collisions _hash _colls)
+ (:: Monad<Maybe> map product;right
+ (array;find (|>. product;left (:: Hash<K> = key))
+ _colls))
+ ))
+
+(def: (size' node)
+ (All [K V] (-> (Node K V) Nat))
+ (case node
+ (#Hierarchy _size hierarchy)
+ (Array/fold ++ +0 (Array/map size' hierarchy))
+
+ (#Base _ base)
+ (Array/fold ++ +0 (Array/map (lambda [sub-node']
+ (case sub-node'
+ (#;Left sub-node) (size' sub-node)
+ (#;Right _) +1))
+ base))
+
+ (#Collisions hash colls)
+ (array;size colls)
+ ))
+
+(def: (entries' node)
+ (All [K V] (-> (Node K V) (List [K V])))
+ (case node
+ (#Hierarchy _size hierarchy)
+ (Array/fold (lambda [sub-node tail] (List/append (entries' sub-node) tail))
+ #;Nil
+ hierarchy)
+
+ (#Base bitmap base)
+ (Array/fold (lambda [branch tail]
+ (case branch
+ (#;Left sub-node)
+ (List/append (entries' sub-node) tail)
+
+ (#;Right [key' val'])
+ (#;Cons [key' val'] tail)))
+ #;Nil
+ base)
+
+ (#Collisions hash colls)
+ (Array/fold (lambda [[key' val'] tail] (#;Cons [key' val'] tail))
+ #;Nil
+ colls)))
+
+## [Exports]
+(type: #export (Dict k v)
+ {#;doc "A dictionary implemented as a Hash-Array Mapped Trie (HAMT)."}
+ {#hash (Hash k)
+ #root (Node k v)})
+
+(def: #export (new Hash<K>)
+ (All [K V] (-> (Hash K) (Dict K V)))
+ {#hash Hash<K>
+ #root empty})
+
+(def: #export (put key val [Hash<K> node])
+ (All [K V] (-> K V (Dict K V) (Dict K V)))
+ [Hash<K> (put' root-level (:: Hash<K> hash key) key val Hash<K> node)])
+
+(def: #export (remove key [Hash<K> node])
+ (All [K V] (-> K (Dict K V) (Dict K V)))
+ [Hash<K> (remove' root-level (:: Hash<K> hash key) key Hash<K> node)])
+
+(def: #export (get key [Hash<K> node])
+ (All [K V] (-> K (Dict K V) (Maybe V)))
+ (get' root-level (:: Hash<K> hash key) key Hash<K> node))
+
+(def: #export (contains? key table)
+ (All [K V] (-> K (Dict K V) Bool))
+ (case (get key table)
+ #;None false
+ (#;Some _) true))
+
+(def: #export (put~ key val table)
+ {#;doc "Only puts the KV-pair if the key is not already present."}
+ (All [K V] (-> K V (Dict K V) (Dict K V)))
+ (if (contains? key table)
+ table
+ (put key val table)))
+
+(def: #export (update key f table)
+ {#;doc "Transforms the value located at key (if available), using the given function."}
+ (All [K V] (-> K (-> V V) (Dict K V) (Dict K V)))
+ (case (get key table)
+ #;None
+ table
+
+ (#;Some val)
+ (put key (f val) table)))
+
+(def: #export size
+ (All [K V] (-> (Dict K V) Nat))
+ (|>. product;right size'))
+
+(def: #export empty?
+ (All [K V] (-> (Dict K V) Bool))
+ (|>. size (=+ +0)))
+
+(def: #export (entries dict)
+ (All [K V] (-> (Dict K V) (List [K V])))
+ (entries' (product;right dict)))
+
+(def: #export (from-list Hash<K> kvs)
+ (All [K V] (-> (Hash K) (List [K V]) (Dict K V)))
+ (List/fold (lambda [[k v] dict]
+ (put k v dict))
+ (new Hash<K>)
+ kvs))
+
+(do-template [<name> <elem-type> <side>]
+ [(def: #export <name>
+ (All [K V] (-> (Dict K V) (List <elem-type>)))
+ (|>. entries (List/map <side>)))]
+
+ [keys K product;left]
+ [values V product;right]
+ )
+
+(def: #export (merge dict2 dict1)
+ (All [K V] (-> (Dict K V) (Dict K V) (Dict K V)))
+ (List/fold (lambda [[key val] dict] (put key val dict))
+ dict1
+ (entries dict2)))
+
+(def: #export (merge-with f dict1 dict2)
+ (All [K V] (-> (-> V V V) (Dict K V) (Dict K V) (Dict K V)))
+ (List/fold (lambda [[key val] dict]
+ (case (get key dict)
+ #;None
+ (put key val dict)
+
+ (#;Some val')
+ (put key (f val' val) dict)))
+ dict1
+ (entries dict2)))
+
+(def: #export (re-bind from-key to-key dict)
+ (All [K V] (-> K K (Dict K V) (Dict K V)))
+ (case (get from-key dict)
+ #;None
+ dict
+
+ (#;Some val)
+ (|> dict
+ (remove from-key)
+ (put to-key val))))
+
+(def: #export (select keys (^@ old-dict [Hash<K> _]))
+ {#;doc "Creates a sub-set of the given dict, with only the specified keys."}
+ (All [K V] (-> (List K) (Dict K V) (Dict K V)))
+ (List/fold (lambda [key new-dict]
+ (case (get key old-dict)
+ #;None new-dict
+ (#;Some val) (put key val new-dict)))
+ (new Hash<K>)
+ keys))
+
+## [Structures]
+(struct: #export (Eq<Dict> Eq<v>) (All [k v] (-> (Eq v) (Eq (Dict k v))))
+ (def: (= test subject)
+ (and (=+ (size test)
+ (size subject))
+ (list;every? (lambda [k]
+ (case [(get k test) (get k subject)]
+ [(#;Some tk) (#;Some sk)]
+ (:: Eq<v> = tk sk)
+
+ _
+ false))
+ (keys test)))))
diff --git a/stdlib/source/lux/data/struct/list.lux b/stdlib/source/lux/data/struct/list.lux
new file mode 100644
index 000000000..7d71e4faa
--- /dev/null
+++ b/stdlib/source/lux/data/struct/list.lux
@@ -0,0 +1,487 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monoid
+ functor
+ applicative
+ ["M" monad #*]
+ eq
+ [fold])
+ (data [number "Int/" Number<Int> Codec<Text,Int>]
+ bool
+ [product])
+ codata/function))
+
+## [Types]
+## (type: (List a)
+## #Nil
+## (#Cons a (List a)))
+
+## [Functions]
+(struct: #export _ (fold;Fold List)
+ (def: (fold f init xs)
+ (case xs
+ #;Nil
+ init
+
+ (#;Cons [x xs'])
+ (fold f (f x init) xs'))))
+
+(open Fold<List>)
+
+(def: #export (reverse xs)
+ (All [a]
+ (-> (List a) (List a)))
+ (fold (lambda [head tail] (#;Cons head tail))
+ #;Nil
+ xs))
+
+(def: #export (filter p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) (List a)))
+ (case xs
+ #;Nil
+ #;Nil
+
+ (#;Cons [x xs'])
+ (if (p x)
+ (#;Cons [x (filter p xs')])
+ (filter p xs'))))
+
+(def: #export (partition p xs)
+ (All [a] (-> (-> a Bool) (List a) [(List a) (List a)]))
+ [(filter p xs) (filter (complement p) xs)])
+
+(def: #export (as-pairs xs)
+ (All [a] (-> (List a) (List [a a])))
+ (case xs
+ (^ (#;Cons [x1 (#;Cons [x2 xs'])]))
+ (#;Cons [[x1 x2] (as-pairs xs')])
+
+ _
+ #;Nil))
+
+(do-template [<name> <then> <else>]
+ [(def: #export (<name> n xs)
+ (All [a]
+ (-> Nat (List a) (List a)))
+ (if (>+ +0 n)
+ (case xs
+ #;Nil
+ #;Nil
+
+ (#;Cons [x xs'])
+ <then>)
+ <else>))]
+
+ [take (#;Cons [x (take (-+ +1 n) xs')]) #;Nil]
+ [drop (drop (-+ +1 n) xs') xs]
+ )
+
+(do-template [<name> <then> <else>]
+ [(def: #export (<name> p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) (List a)))
+ (case xs
+ #;Nil
+ #;Nil
+
+ (#;Cons [x xs'])
+ (if (p x)
+ <then>
+ <else>)))]
+
+ [take-while (#;Cons [x (take-while p xs')]) #;Nil]
+ [drop-while (drop-while p xs') xs]
+ )
+
+(def: #export (split n xs)
+ (All [a]
+ (-> Nat (List a) [(List a) (List a)]))
+ (if (>+ +0 n)
+ (case xs
+ #;Nil
+ [#;Nil #;Nil]
+
+ (#;Cons [x xs'])
+ (let [[tail rest] (split (-+ +1 n) xs')]
+ [(#;Cons [x tail]) rest]))
+ [#;Nil xs]))
+
+(def: (split-with' p ys xs)
+ (All [a]
+ (-> (-> a Bool) (List a) (List a) [(List a) (List a)]))
+ (case xs
+ #;Nil
+ [ys xs]
+
+ (#;Cons [x xs'])
+ (if (p x)
+ (split-with' p (#;Cons [x ys]) xs')
+ [ys xs])))
+
+(def: #export (split-with p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) [(List a) (List a)]))
+ (let [[ys' xs'] (split-with' p #;Nil xs)]
+ [(reverse ys') xs']))
+
+(def: #export (split-all n xs)
+ (All [a] (-> Nat (List a) (List (List a))))
+ (case xs
+ #;Nil
+ (list)
+
+ _
+ (let [[pre post] (split n xs)]
+ (#;Cons pre (split-all n post)))))
+
+(def: #export (repeat n x)
+ (All [a]
+ (-> Nat a (List a)))
+ (if (>+ +0 n)
+ (#;Cons [x (repeat (dec+ n) x)])
+ #;Nil))
+
+(def: (iterate' f x)
+ (All [a]
+ (-> (-> a (Maybe a)) a (List a)))
+ (case (f x)
+ (#;Some x')
+ (list& x (iterate' f x'))
+
+ #;None
+ (list)))
+
+(def: #export (iterate f x)
+ (All [a]
+ (-> (-> a (Maybe a)) a (List a)))
+ (case (f x)
+ (#;Some x')
+ (list& x (iterate' f x'))
+
+ #;None
+ (list x)))
+
+(def: #export (find p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) (Maybe a)))
+ (case xs
+ #;Nil
+ #;None
+
+ (#;Cons [x xs'])
+ (if (p x)
+ (#;Some x)
+ (find p xs'))))
+
+(def: #export (interpose sep xs)
+ (All [a]
+ (-> a (List a) (List a)))
+ (case xs
+ #;Nil
+ xs
+
+ (#;Cons [x #;Nil])
+ xs
+
+ (#;Cons [x xs'])
+ (#;Cons [x (#;Cons [sep (interpose sep xs')])])))
+
+(def: #export (size list)
+ (All [a] (-> (List a) Nat))
+ (fold (lambda [_ acc] (++ +1 acc)) +0 list))
+
+(do-template [<name> <init> <op>]
+ [(def: #export (<name> p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) Bool))
+ (fold (lambda [_2 _1] (<op> _1 (p _2))) <init> xs))]
+
+ [every? true and]
+ [any? false or])
+
+(def: #export (at i xs)
+ (All [a]
+ (-> Nat (List a) (Maybe a)))
+ (case xs
+ #;Nil
+ #;None
+
+ (#;Cons [x xs'])
+ (if (=+ +0 i)
+ (#;Some x)
+ (at (-+ +1 i) xs'))))
+
+## [Structures]
+(struct: #export (Eq<List> (^open "a:"))
+ (All [a] (-> (Eq a) (Eq (List a))))
+ (def: (= xs ys)
+ (case [xs ys]
+ [#;Nil #;Nil]
+ true
+
+ [(#;Cons x xs') (#;Cons y ys')]
+ (and (a:= x y)
+ (= xs' ys'))
+
+ [_ _]
+ false
+ )))
+
+(struct: #export Monoid<List> (All [a]
+ (Monoid (List a)))
+ (def: unit #;Nil)
+ (def: (append xs ys)
+ (case xs
+ #;Nil ys
+ (#;Cons x xs') (#;Cons x (append xs' ys)))))
+
+(open Monoid<List>)
+
+(struct: #export _ (Functor List)
+ (def: (map f ma)
+ (case ma
+ #;Nil #;Nil
+ (#;Cons a ma') (#;Cons (f a) (map f ma')))))
+
+(open Functor<List>)
+
+(struct: #export _ (Applicative List)
+ (def: functor Functor<List>)
+
+ (def: (wrap a)
+ (#;Cons a #;Nil))
+
+ (def: (apply ff fa)
+ (case ff
+ #;Nil
+ #;Nil
+
+ (#;Cons f ff')
+ (append (map f fa) (apply ff' fa)))))
+
+(struct: #export _ (Monad List)
+ (def: applicative Applicative<List>)
+
+ (def: join (|>. reverse (fold append unit))))
+
+## [Functions]
+(def: #export (sort < xs)
+ (All [a] (-> (-> a a Bool) (List a) (List a)))
+ (case xs
+ #;Nil
+ (list)
+
+ (#;Cons x xs')
+ (let [[pre post] (fold (lambda [x' [pre post]]
+ (if (< x x')
+ [(#;Cons x' pre) post]
+ [pre (#;Cons x' post)]))
+ [(list) (list)]
+ xs')]
+ ($_ append (sort < pre) (list x) (sort < post)))))
+
+(do-template [<name> <type> <comp> <inc>]
+ [(def: #export (<name> from to)
+ (-> <type> <type> (List <type>))
+ (if (<comp> to from)
+ (list& from (<name> (<inc> from) to))
+ (list)))]
+
+ [range Int <= inc]
+ [range+ Nat <=+ inc+]
+ )
+
+(def: #export (empty? xs)
+ (All [a] (-> (List a) Bool))
+ (case xs
+ #;Nil true
+ _ false))
+
+(def: #export (member? eq xs x)
+ (All [a] (-> (Eq a) (List a) a Bool))
+ (case xs
+ #;Nil false
+ (#;Cons x' xs') (or (:: eq = x x')
+ (member? eq xs' x))))
+
+(do-template [<name> <output> <side>]
+ [(def: #export (<name> xs)
+ (All [a] (-> (List a) (Maybe <output>)))
+ (case xs
+ #;Nil
+ #;None
+
+ (#;Cons x xs')
+ (#;Some <side>)))]
+
+ [head a x]
+ [tail (List a) xs']
+ )
+
+## [Syntax]
+(def: (symbol$ name)
+ (-> Text AST)
+ [["" -1 -1] (#;SymbolS "" name)])
+
+(macro: #export (zip tokens state)
+ {#;doc (doc "Create list zippers with the specified number of input lists."
+ (def: #export zip2 (zip 2))
+ (def: #export zip3 (zip 3))
+ ((zip 3) xs ys zs))}
+ (case tokens
+ (^ (list [_ (#;IntS num-lists)]))
+ (if (> 0 num-lists)
+ (let [(^open) Functor<List>
+ indices (range 0 (dec num-lists))
+ type-vars (: (List AST) (map (. symbol$ Int/encode) indices))
+ zip-type (` (All [(~@ type-vars)]
+ (-> (~@ (map (: (-> AST AST) (lambda [var] (` (List (~ var)))))
+ type-vars))
+ (List [(~@ type-vars)]))))
+ vars+lists (|> indices
+ (map inc)
+ (map (lambda [idx]
+ [(symbol$ (Int/encode idx))
+ (symbol$ (Int/encode (Int/negate idx)))])))
+ pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs))))
+ vars+lists))])
+ g!step (symbol$ "\tstep\t")
+ g!blank (symbol$ "\t_\t")
+ list-vars (map product;right vars+lists)
+ code (` (: (~ zip-type)
+ (lambda (~ g!step) [(~@ list-vars)]
+ (case [(~@ list-vars)]
+ (~ pattern)
+ (#;Cons [(~@ (map product;left vars+lists))]
+ ((~ g!step) (~@ list-vars)))
+
+ (~ g!blank)
+ #;Nil))))]
+ (#;Right [state (list code)]))
+ (#;Left "Can't zip 0 lists."))
+
+ _
+ (#;Left "Wrong syntax for zip")))
+
+(def: #export zip2 (zip 2))
+(def: #export zip3 (zip 3))
+
+(macro: #export (zip-with tokens state)
+ {#;doc (doc "Create list zip-with`s with the specified number of input lists."
+ (def: #export zip2-with (zip-with 2))
+ (def: #export zip3-with (zip-with 3))
+ ((zip-with 2) + xs ys))}
+ (case tokens
+ (^ (list [_ (#;IntS num-lists)]))
+ (if (> 0 num-lists)
+ (let [(^open) Functor<List>
+ indices (range 0 (dec num-lists))
+ g!return-type (symbol$ "\treturn-type\t")
+ g!func (symbol$ "\tfunc\t")
+ type-vars (: (List AST) (map (. symbol$ Int/encode) indices))
+ zip-type (` (All [(~@ type-vars) (~ g!return-type)]
+ (-> (-> (~@ type-vars) (~ g!return-type))
+ (~@ (map (: (-> AST AST) (lambda [var] (` (List (~ var)))))
+ type-vars))
+ (List (~ g!return-type)))))
+ vars+lists (|> indices
+ (map inc)
+ (map (lambda [idx]
+ [(symbol$ (Int/encode idx))
+ (symbol$ (Int/encode (Int/negate idx)))])))
+ pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs))))
+ vars+lists))])
+ g!step (symbol$ "\tstep\t")
+ g!blank (symbol$ "\t_\t")
+ list-vars (map product;right vars+lists)
+ code (` (: (~ zip-type)
+ (lambda (~ g!step) [(~ g!func) (~@ list-vars)]
+ (case [(~@ list-vars)]
+ (~ pattern)
+ (#;Cons ((~ g!func) (~@ (map product;left vars+lists)))
+ ((~ g!step) (~ g!func) (~@ list-vars)))
+
+ (~ g!blank)
+ #;Nil))))]
+ (#;Right [state (list code)]))
+ (#;Left "Can't zip-with 0 lists."))
+
+ _
+ (#;Left "Wrong syntax for zip-with")))
+
+(def: #export zip2-with (zip-with 2))
+(def: #export zip3-with (zip-with 3))
+
+(def: #export (last xs)
+ (All [a] (-> (List a) (Maybe a)))
+ (case xs
+ #;Nil
+ #;None
+
+ (#;Cons x #;Nil)
+ (#;Some x)
+
+ (#;Cons x xs')
+ (last xs')))
+
+(def: #export (inits xs)
+ (All [a] (-> (List a) (Maybe (List a))))
+ (case xs
+ #;Nil
+ #;None
+
+ (#;Cons x #;Nil)
+ (#;Some #;Nil)
+
+ (#;Cons x xs')
+ (case (inits xs')
+ #;None
+ (undefined)
+
+ (#;Some tail)
+ (#;Some (#;Cons x tail)))
+ ))
+
+(def: #export (concat xss)
+ (All [a] (-> (List (List a)) (List a)))
+ (:: Monad<List> join xss))
+
+(struct: #export (ListT Monad<M>)
+ (All [M] (-> (Monad M) (Monad (All [a] (M (List a))))))
+ (def: applicative (compA (get@ #M;applicative Monad<M>) Applicative<List>))
+ (def: (join MlMla)
+ (do Monad<M>
+ [lMla MlMla
+ lla (: (($ 0) (List (List ($ 1))))
+ (mapM @ join lMla))]
+ (wrap (concat lla)))))
+
+(def: #export (lift-list Monad<M>)
+ (All [M a] (-> (Monad M) (-> (M a) (M (List a)))))
+ (liftM Monad<M> (:: Monad<List> wrap)))
+
+(def: (enumerate' idx xs)
+ (All [a] (-> Nat (List a) (List [Nat a])))
+ (case xs
+ #;Nil
+ #;Nil
+
+ (#;Cons x xs')
+ (#;Cons [idx x] (enumerate' (inc+ idx) xs'))))
+
+(def: #export (enumerate xs)
+ (All [a] (-> (List a) (List [Nat a])))
+ (enumerate' +0 xs))
+
+(def: #export (indices size)
+ {#;doc "Produces all the valid indices for a given size."}
+ (All [a] (-> Nat (List Nat)))
+ (if (=+ +0 size)
+ (list)
+ (|> size dec+ (range+ +0))))
diff --git a/stdlib/source/lux/data/struct/queue.lux b/stdlib/source/lux/data/struct/queue.lux
new file mode 100644
index 000000000..61b97c9cd
--- /dev/null
+++ b/stdlib/source/lux/data/struct/queue.lux
@@ -0,0 +1,79 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control eq)
+ (data (struct [list "List/" Monoid<List>]))))
+
+## [Types]
+(type: #export (Queue a)
+ {#front (List a)
+ #rear (List a)})
+
+## [Values]
+(def: #export empty
+ Queue
+ {#front (list)
+ #rear (list)})
+
+(def: #export (from-list entries)
+ (All [a] (-> (List a) (Queue a)))
+ {#front entries
+ #rear (list)})
+
+(def: #export (to-list queue)
+ (All [a] (-> (Queue a) (List a)))
+ (let [(^slots [#front #rear]) queue]
+ (List/append front (list;reverse rear))))
+
+(def: #export peek
+ (All [a] (-> (Queue a) (Maybe a)))
+ (|>. (get@ #front) list;head))
+
+(def: #export (size queue)
+ (All [a] (-> (Queue a) Nat))
+ (let [(^slots [#front #rear]) queue]
+ (++ (list;size front)
+ (list;size rear))))
+
+(def: #export empty?
+ (All [a] (-> (Queue a) Bool))
+ (|>. (get@ [#front]) list;empty?))
+
+(def: #export (enqueued? a/Eq queue member)
+ (All [a] (-> (Eq a) (Queue a) a Bool))
+ (let [(^slots [#front #rear]) queue]
+ (or (list;member? a/Eq front member)
+ (list;member? a/Eq rear member))))
+
+(def: #export (dequeue queue)
+ (All [a] (-> (Queue a) (Queue a)))
+ (case (get@ #front queue)
+ (^ (list)) ## Empty...
+ queue
+
+ (^ (list _)) ## Front has dried up...
+ (|> queue
+ (set@ #front (list;reverse (get@ #rear queue)))
+ (set@ #rear (list)))
+
+ (^ (list& _ front')) ## Consume front!
+ (|> queue
+ (set@ #front front'))))
+
+(def: #export (enqueue val queue)
+ (All [a] (-> a (Queue a) (Queue a)))
+ (case (get@ #front queue)
+ #;Nil
+ (set@ #front (list val) queue)
+
+ _
+ (update@ #rear (|>. (#;Cons val)) queue)))
+
+## [Structures]
+(struct: #export (Eq<Queue> Eq<a>) (All [a] (-> (Eq a) (Eq (Queue a))))
+ (def: (= qx qy)
+ (:: (list;Eq<List> Eq<a>) = (to-list qx) (to-list qy))))
diff --git a/stdlib/source/lux/data/struct/set.lux b/stdlib/source/lux/data/struct/set.lux
new file mode 100644
index 000000000..085c0f047
--- /dev/null
+++ b/stdlib/source/lux/data/struct/set.lux
@@ -0,0 +1,85 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control functor
+ applicative
+ monad
+ eq
+ [hash #*])
+ (data (struct [dict]
+ [list "List/" Fold<List> Functor<List>]))
+ (codata function)))
+
+## [Types]
+(type: #export (Set a)
+ (dict;Dict a a))
+
+## [Values]
+(def: #export (new Hash<a>)
+ (All [a] (-> (Hash a) (Set a)))
+ (dict;new Hash<a>))
+
+(def: #export (add elem set)
+ (All [a] (-> a (Set a) (Set a)))
+ (dict;put elem elem set))
+
+(def: #export (remove elem set)
+ (All [a] (-> a (Set a) (Set a)))
+ (dict;remove elem set))
+
+(def: #export (member? set elem)
+ (All [a] (-> (Set a) a Bool))
+ (dict;contains? elem set))
+
+(def: #export (union xs yx)
+ (All [a] (-> (Set a) (Set a) (Set a)))
+ (dict;merge xs yx))
+
+(def: #export (difference subs base)
+ (All [a] (-> (Set a) (Set a) (Set a)))
+ (List/fold remove base (dict;keys subs)))
+
+(def: #export (intersection filter base)
+ (All [a] (-> (Set a) (Set a) (Set a)))
+ (dict;select (dict;keys filter) base))
+
+(def: #export (size set)
+ (All [a] (-> (Set a) Nat))
+ (dict;size set))
+
+(def: #export (empty? set)
+ (All [a] (-> (Set a) Bool))
+ (=+ +0 (dict;size set)))
+
+(def: #export to-list
+ (All [a] (-> (Set a) (List a)))
+ dict;keys)
+
+(def: #export (from-list Hash<a> xs)
+ (All [a] (-> (Hash a) (List a) (Set a)))
+ (List/fold add (new Hash<a>) xs))
+
+(def: #export (sub? super sub)
+ (All [a] (-> (Set a) (Set a) Bool))
+ (list;every? (member? super) (to-list sub)))
+
+(def: #export (super? sub super)
+ (All [a] (-> (Set a) (Set a) Bool))
+ (sub? super sub))
+
+## [Structures]
+(struct: #export Eq<Set> (All [a] (Eq (Set a)))
+ (def: (= (^@ test [Hash<a> _]) subject)
+ (:: (list;Eq<List> (get@ #hash;eq Hash<a>)) = (to-list test) (to-list subject))))
+
+(struct: #export Hash<Set> (All [a] (Hash (Set a)))
+ (def: eq Eq<Set>)
+
+ (def: (hash (^@ set [Hash<a> _]))
+ (List/fold (lambda [elem acc] (++ (:: Hash<a> hash elem) acc))
+ +0
+ (to-list set))))
diff --git a/stdlib/source/lux/data/struct/stack.lux b/stdlib/source/lux/data/struct/stack.lux
new file mode 100644
index 000000000..e62a74590
--- /dev/null
+++ b/stdlib/source/lux/data/struct/stack.lux
@@ -0,0 +1,47 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (data (struct [list]))))
+
+## [Types]
+(type: #export (Stack a)
+ (List a))
+
+## [Values]
+(def: #export empty
+ Stack
+ (list))
+
+(def: #export (size stack)
+ (All [a] (-> (Stack a) Nat))
+ (list;size stack))
+
+(def: #export (empty? stack)
+ (All [a] (-> (Stack a) Bool))
+ (list;empty? stack))
+
+(def: #export (peek stack)
+ (All [a] (-> (Stack a) (Maybe a)))
+ (case stack
+ #;Nil
+ #;None
+
+ (#;Cons value _)
+ (#;Some value)))
+
+(def: #export (pop stack)
+ (All [a] (-> (Stack a) (Stack a)))
+ (case stack
+ #;Nil
+ #;Nil
+
+ (#;Cons _ stack')
+ stack'))
+
+(def: #export (push value stack)
+ (All [a] (-> a (Stack a) (Stack a)))
+ (#;Cons value stack))
diff --git a/stdlib/source/lux/data/struct/tree.lux b/stdlib/source/lux/data/struct/tree.lux
new file mode 100644
index 000000000..7b7828d73
--- /dev/null
+++ b/stdlib/source/lux/data/struct/tree.lux
@@ -0,0 +1,54 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monad
+ eq)
+ (data (struct [list "" Monad<List>]))
+ [compiler]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax])))
+
+## [Types]
+(type: #export (Tree a)
+ {#value a
+ #children (List (Tree a))})
+
+## [Values]
+(def: #export (flatten tree)
+ (All [a] (-> (Tree a) (List a)))
+ (#;Cons (get@ #value tree)
+ (join (map flatten (get@ #children tree)))))
+
+(def: #export (leaf value)
+ (All [a] (-> a (Tree a)))
+ {#value value
+ #children (list)})
+
+(def: #export (branch value children)
+ (All [a] (-> a (List (Tree a)) (Tree a)))
+ {#value value
+ #children children})
+
+## [Syntax]
+(type: #rec Tree-AST
+ [AST (List Tree-AST)])
+
+(def: (tree^ _)
+ (-> Unit (Syntax Tree-AST))
+ (s;record (s;seq s;any (s;tuple (s;some (lambda [state] ((tree^ []) state)))))))
+
+(syntax: #export (tree type {root (tree^ [])})
+ (wrap (list (` (: (Tree (~ type))
+ (~ (loop [[value children] root]
+ (` {#value (~ value)
+ #children (list (~@ (map recur children)))}))))))))
+
+## [Structs]
+(struct: #export (Eq<Tree> Eq<a>) (All [a] (-> (Eq a) (Eq (Tree a))))
+ (def: (= tx ty)
+ (and (:: Eq<a> = (get@ #value tx) (get@ #value ty))
+ (:: (list;Eq<List> (Eq<Tree> Eq<a>)) = (get@ #children tx) (get@ #children ty)))))
diff --git a/stdlib/source/lux/data/struct/vector.lux b/stdlib/source/lux/data/struct/vector.lux
new file mode 100644
index 000000000..bb31063a4
--- /dev/null
+++ b/stdlib/source/lux/data/struct/vector.lux
@@ -0,0 +1,428 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control functor
+ applicative
+ monad
+ eq
+ monoid
+ fold)
+ (data maybe
+ (struct [list "List/" Fold<List> Functor<List> Monoid<List>]
+ [array #+ Array "Array/" Functor<Array> Fold<Array>])
+ [bit]
+ [number "Int/" Number<Int>]
+ [product])
+ [compiler #+ with-gensyms]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax])
+ [pipe]
+ ))
+
+## This implementation of vectors is based on Clojure's
+## PersistentVector implementation.
+
+## [Utils]
+(type: (Node a)
+ (#Base (Array a))
+ (#Hierarchy (Array (Node a))))
+
+(type: (Base a) (Array a))
+(type: (Hierarchy a) (Array (Node a)))
+
+(type: Level Nat)
+
+(type: Index Nat)
+
+(def: branching-exponent
+ Nat
+ +5)
+
+(def: root-level
+ Level
+ +0)
+
+(do-template [<name> <op>]
+ [(def: <name>
+ (-> Level Level)
+ (<op> branching-exponent))]
+
+ [level-up ++]
+ [level-down -+]
+ )
+
+(def: full-node-size
+ Nat
+ (bit;<< branching-exponent +1))
+
+(def: branch-idx-mask
+ Nat
+ (dec+ full-node-size))
+
+(def: branch-idx
+ (-> Index Index)
+ (bit;& branch-idx-mask))
+
+(def: (new-hierarchy _)
+ (All [a] (-> Top (Hierarchy a)))
+ (array;new full-node-size))
+
+(def: (tail-off vec-size)
+ (-> Nat Nat)
+ (if (<+ full-node-size vec-size)
+ +0
+ (|> (dec+ vec-size)
+ (bit;>>> branching-exponent)
+ (bit;<< branching-exponent))))
+
+(def: (new-path level tail)
+ (All [a] (-> Level (Base a) (Node a)))
+ (if (=+ +0 level)
+ (#Base tail)
+ (|> (: (Hierarchy ($ 0))
+ (new-hierarchy []))
+ (array;put +0 (new-path (level-down level) tail))
+ #Hierarchy)))
+
+(def: (new-tail singleton)
+ (All [a] (-> a (Base a)))
+ (|> (: (Base ($ 0))
+ (array;new +1))
+ (array;put +0 singleton)))
+
+(def: (push-tail size level tail parent)
+ (All [a] (-> Nat Level (Base a) (Hierarchy a) (Hierarchy a)))
+ (let [sub-idx (branch-idx (bit;>>> level (dec+ size)))
+ ## If we're currently on a bottom node
+ sub-node (if (=+ branching-exponent level)
+ ## Just add the tail to it
+ (#Base tail)
+ ## Otherwise, check whether there's a vacant spot
+ (case (array;get sub-idx parent)
+ ## If so, set the path to the tail
+ #;None
+ (new-path (level-down level) tail)
+ ## If not, push the tail onto the sub-node.
+ (#;Some (#Hierarchy sub-node))
+ (#Hierarchy (push-tail size (level-down level) tail sub-node))
+
+ _
+ (undefined))
+ )]
+ (|> (array;clone parent)
+ (array;put sub-idx sub-node))))
+
+(def: (expand-tail val tail)
+ (All [a] (-> a (Base a) (Base a)))
+ (let [tail-size (array;size tail)]
+ (|> (: (Base ($ 0))
+ (array;new (inc+ tail-size)))
+ (array;copy tail-size +0 tail +0)
+ (array;put tail-size val)
+ )))
+
+(def: (put' level idx val hierarchy)
+ (All [a] (-> Level Index a (Hierarchy a) (Hierarchy a)))
+ (let [sub-idx (branch-idx (bit;>>> level idx))]
+ (case (array;get sub-idx hierarchy)
+ (#;Some (#Hierarchy sub-node))
+ (|> (array;clone hierarchy)
+ (array;put sub-idx (#Hierarchy (put' (level-down level) idx val sub-node))))
+
+ (^=> (#;Some (#Base base))
+ (=+ +0 (level-down level)))
+ (|> (array;clone hierarchy)
+ (array;put sub-idx (|> (array;clone base)
+ (array;put (branch-idx idx) val)
+ #Base)))
+
+ _
+ (undefined))))
+
+(def: (pop-tail size level hierarchy)
+ (All [a] (-> Nat Level (Hierarchy a) (Maybe (Hierarchy a))))
+ (let [sub-idx (branch-idx (bit;>>> level (-+ +2 size)))]
+ (cond (=+ +0 sub-idx)
+ #;None
+
+ (>+ branching-exponent level)
+ (do Monad<Maybe>
+ [base|hierarchy (array;get sub-idx hierarchy)
+ sub (case base|hierarchy
+ (#Hierarchy sub)
+ (pop-tail size (level-down level) sub)
+
+ (#Base _)
+ (undefined))]
+ (|> (array;clone hierarchy)
+ (array;put sub-idx (#Hierarchy sub))
+ #;Some))
+
+ ## Else...
+ (|> (array;clone hierarchy)
+ (array;remove sub-idx)
+ #;Some)
+ )))
+
+(def: (to-list' node)
+ (All [a] (-> (Node a) (List a)))
+ (case node
+ (#Base base)
+ (array;to-list base)
+
+ (#Hierarchy hierarchy)
+ (|> hierarchy
+ array;to-list
+ list;reverse
+ (List/fold (lambda [sub acc] (List/append (to-list' sub) acc))
+ #;Nil))))
+
+## [Types]
+(type: #export (Vector a)
+ {#level Level
+ #size Nat
+ #root (Hierarchy a)
+ #tail (Base a)})
+
+## [Exports]
+(def: #export empty
+ Vector
+ {#level (level-up root-level)
+ #size +0
+ #root (array;new full-node-size)
+ #tail (array;new +0)})
+
+(def: #export (size vector)
+ (All [a] (-> (Vector a) Nat))
+ (get@ #size vector))
+
+(def: #export (add val vec)
+ (All [a] (-> a (Vector a) (Vector a)))
+ ## Check if there is room in the tail.
+ (let [vec-size (get@ #size vec)]
+ (if (|> vec-size (-+ (tail-off vec-size)) (<+ full-node-size))
+ ## If so, append to it.
+ (|> vec
+ (update@ #size inc+)
+ (update@ #tail (expand-tail val)))
+ ## Otherwise, push tail into the tree
+ ## --------------------------------------------------------
+ ## Will the root experience an overflow with this addition?
+ (|> (if (>+ (bit;<< (get@ #level vec) +1)
+ (bit;>>> branching-exponent vec-size))
+ ## If so, a brand-new root must be established, that is
+ ## 1-level taller.
+ (|> vec
+ (set@ #root (|> (: (Hierarchy ($ 0))
+ (new-hierarchy []))
+ (array;put +0 (#Hierarchy (get@ #root vec)))
+ (array;put +1 (new-path (get@ #level vec) (get@ #tail vec)))))
+ (update@ #level level-up))
+ ## Otherwise, just push the current tail onto the root.
+ (|> vec
+ (update@ #root (push-tail vec-size (get@ #level vec) (get@ #tail vec)))))
+ ## Finally, update the size of the Vector and grow a new
+ ## tail with the new element as it's sole member.
+ (update@ #size inc+)
+ (set@ #tail (new-tail val)))
+ )))
+
+(def: (base-for idx vec)
+ (All [a] (-> Index (Vector a) (Maybe (Base a))))
+ (let [vec-size (get@ #size vec)]
+ (if (and (>=+ +0 idx)
+ (<+ vec-size idx))
+ (if (>=+ (tail-off vec-size) idx)
+ (#;Some (get@ #tail vec))
+ (loop [level (get@ #level vec)
+ hierarchy (get@ #root vec)]
+ (case [(>+ branching-exponent level)
+ (array;get (branch-idx (bit;>>> level idx)) hierarchy)]
+ [true (#;Some (#Hierarchy sub))]
+ (recur (level-down level) sub)
+
+ [false (#;Some (#Base base))]
+ (#;Some base)
+
+ [_ #;None]
+ #;None
+
+ _
+ (error! "Incorrect vector structure."))))
+ #;None)))
+
+(def: #export (at idx vec)
+ (All [a] (-> Nat (Vector a) (Maybe a)))
+ (do Monad<Maybe>
+ [base (base-for idx vec)]
+ (array;get (branch-idx idx) base)))
+
+(def: #export (put idx val vec)
+ (All [a] (-> Nat a (Vector a) (Vector a)))
+ (let [vec-size (get@ #size vec)]
+ (if (and (>=+ +0 idx)
+ (<+ vec-size idx))
+ (if (>=+ (tail-off vec-size) idx)
+ (|> vec
+ (update@ #tail (: (-> (Base ($ 0)) (Base ($ 0)))
+ (|>. array;clone (array;put (branch-idx idx) val)))))
+ (|> vec
+ (update@ #root (put' (get@ #level vec) idx val))))
+ vec)))
+
+(def: #export (update idx f vec)
+ (All [a] (-> Nat (-> a a) (Vector a) (Vector a)))
+ (case (at idx vec)
+ (#;Some val)
+ (put idx (f val) vec)
+
+ #;None
+ vec))
+
+(def: #export (pop vec)
+ (All [a] (-> (Vector a) (Vector a)))
+ (case (get@ #size vec)
+ +0
+ empty
+
+ +1
+ empty
+
+ vec-size
+ (if (|> vec-size (-+ (tail-off vec-size)) (>+ +1))
+ (let [old-tail (get@ #tail vec)
+ new-tail-size (dec+ (array;size old-tail))]
+ (|> vec
+ (update@ #size dec+)
+ (set@ #tail (|> (array;new new-tail-size)
+ (array;copy new-tail-size +0 old-tail +0)))))
+ (default (undefined)
+ (do Monad<Maybe>
+ [new-tail (base-for (-+ +2 vec-size) vec)
+ #let [[level' root'] (: [Level (Hierarchy ($ 0))]
+ (let [init-level (get@ #level vec)]
+ (loop [level init-level
+ root (: (Hierarchy ($ 0))
+ (default (new-hierarchy [])
+ (pop-tail vec-size init-level (get@ #root vec))))]
+ (if (>+ branching-exponent level)
+ (case [(array;get +1 root) (array;get +0 root)]
+ [#;None (#;Some (#Hierarchy sub-node))]
+ (recur (level-down level) sub-node)
+
+ [#;None (#;Some (#Base _))]
+ (undefined)
+
+ _
+ [level root])
+ [level root]))))]]
+ (wrap (|> vec
+ (update@ #size dec+)
+ (set@ #level level')
+ (set@ #root root')
+ (set@ #tail new-tail))))))
+ ))
+
+(def: #export (to-list vec)
+ (All [a] (-> (Vector a) (List a)))
+ (List/append (to-list' (#Hierarchy (get@ #root vec)))
+ (to-list' (#Base (get@ #tail vec)))))
+
+(def: #export (from-list list)
+ (All [a] (-> (List a) (Vector a)))
+ (List/fold add
+ (: (Vector ($ 0))
+ empty)
+ list))
+
+(def: #export (member? a/Eq vec val)
+ (All [a] (-> (Eq a) (Vector a) a Bool))
+ (list;member? a/Eq (to-list vec) val))
+
+(def: #export empty?
+ (All [a] (-> (Vector a) Bool))
+ (|>. (get@ #size) (=+ +0)))
+
+## [Syntax]
+(syntax: #export (vector {elems (s;some s;any)})
+ (wrap (list (` (from-list (list (~@ elems)))))))
+
+## [Structures]
+(struct: #export (Eq<Vector> Eq<a>) (All [a] (-> (Eq a) (Eq (Vector a))))
+ (def: (= v1 v2)
+ (:: (list;Eq<List> Eq<a>) = (to-list v1) (to-list v2))))
+
+(struct: _ (Fold Node)
+ (def: (fold f init xs)
+ (case xs
+ (#Base base)
+ (Array/fold f init base)
+
+ (#Hierarchy hierarchy)
+ (Array/fold (lambda [node init'] (fold f init' node))
+ init
+ hierarchy))
+ ))
+
+(struct: #export _ (Fold Vector)
+ (def: (fold f init xs)
+ (let [(^open) Fold<Node>]
+ (fold f
+ (fold f
+ init
+ (#Hierarchy (get@ #root xs)))
+ (#Base (get@ #tail xs))))
+ ))
+
+(struct: #export Monoid<Vector> (All [a]
+ (Monoid (Vector a)))
+ (def: unit empty)
+ (def: (append xs ys)
+ (List/fold add xs (to-list ys))))
+
+(struct: _ (Functor Node)
+ (def: (map f xs)
+ (case xs
+ (#Base base)
+ (#Base (Array/map f base))
+
+ (#Hierarchy hierarchy)
+ (#Hierarchy (Array/map (map f) hierarchy)))
+ ))
+
+(struct: #export _ (Functor Vector)
+ (def: (map f xs)
+ {#level (get@ #level xs)
+ #size (get@ #size xs)
+ #root (|> xs (get@ #root) (Array/map (:: Functor<Node> map f)))
+ #tail (|> xs (get@ #tail) (Array/map f))
+ }))
+
+(struct: #export _ (Applicative Vector)
+ (def: functor Functor<Vector>)
+
+ (def: (wrap x)
+ (vector x))
+
+ (def: (apply ff fa)
+ (let [(^open) Functor<Vector>
+ (^open) Fold<Vector>
+ (^open) Monoid<Vector>
+ results (map (lambda [f] (map f fa))
+ ff)]
+ (fold append unit results)))
+ )
+
+(struct: #export _ (Monad Vector)
+ (def: applicative Applicative<Vector>)
+
+ (def: (join ffa)
+ (let [(^open) Functor<Vector>
+ (^open) Fold<Vector>
+ (^open) Monoid<Vector>]
+ (fold append unit ffa)))
+ )
diff --git a/stdlib/source/lux/data/struct/zipper.lux b/stdlib/source/lux/data/struct/zipper.lux
new file mode 100644
index 000000000..eb98409b4
--- /dev/null
+++ b/stdlib/source/lux/data/struct/zipper.lux
@@ -0,0 +1,196 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (data (struct [list "" Monad<List> Fold<List> "List/" Monoid<List>]
+ [tree #+ Tree]
+ [stack #+ Stack]))
+ [compiler]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax])))
+
+## Adapted from the clojure.zip namespace in the Clojure standard library.
+
+## [Types]
+(type: #export (Zipper a)
+ {#parent (Maybe (Zipper a))
+ #lefts (Stack (Tree a))
+ #rights (Stack (Tree a))
+ #node (Tree a)})
+
+## [Values]
+(def: #export (from-tree tree)
+ (All [a] (-> (Tree a) (Zipper a)))
+ {#parent #;None
+ #lefts stack;empty
+ #rights stack;empty
+ #node tree})
+
+(def: #export (to-tree zipper)
+ (All [a] (-> (Zipper a) (Tree a)))
+ (get@ #node zipper))
+
+(def: #export (value zipper)
+ (All [a] (-> (Zipper a) a))
+ (|> zipper (get@ #node) (get@ #tree;value)))
+
+(def: #export (children zipper)
+ (All [a] (-> (Zipper a) (List (Tree a))))
+ (|> zipper (get@ #node) (get@ #tree;children)))
+
+(def: #export (branch? zipper)
+ (All [a] (-> (Zipper a) Bool))
+ (|> zipper children list;empty? not))
+
+(def: #export (leaf? zipper)
+ (All [a] (-> (Zipper a) Bool))
+ (|> zipper branch? not))
+
+(def: #export (parent zipper)
+ (All [a] (-> (Zipper a) (Maybe (Zipper a))))
+ (get@ #parent zipper))
+
+(def: #export (down zipper)
+ (All [a] (-> (Zipper a) (Zipper a)))
+ (case (children zipper)
+ #;Nil
+ zipper
+
+ (#;Cons chead ctail)
+ {#parent (#;Some zipper)
+ #lefts stack;empty
+ #rights ctail
+ #node chead}))
+
+(def: #export (up zipper)
+ (All [a] (-> (Zipper a) (Zipper a)))
+ (case (get@ #parent zipper)
+ #;None
+ zipper
+
+ (#;Some parent)
+ (|> parent
+ (update@ #node (: (-> (Tree ($ 0)) (Tree ($ 0)))
+ (lambda [node]
+ (set@ #tree;children (List/append (list;reverse (get@ #lefts zipper))
+ (#;Cons (get@ #node zipper)
+ (get@ #rights zipper)))
+ node)))))))
+
+(def: #export (root zipper)
+ (All [a] (-> (Zipper a) (Zipper a)))
+ (loop [zipper zipper]
+ (case (get@ #parent zipper)
+ #;None zipper
+ (#;Some _) (recur (up zipper)))))
+
+(do-template [<one-name> <all-name> <side> <op-side>]
+ [(def: #export (<one-name> zipper)
+ (All [a] (-> (Zipper a) (Zipper a)))
+ (case (get@ <side> zipper)
+ #;Nil
+ zipper
+
+ (#;Cons next side')
+ (|> zipper
+ (update@ <op-side> (lambda [op-side]
+ (#;Cons (get@ #node zipper) op-side)))
+ (set@ <side> side')
+ (set@ #node next))))
+
+ (def: #export (<all-name> zipper)
+ (All [a] (-> (Zipper a) (Zipper a)))
+ (fold (lambda [_] <one-name>) zipper (get@ <side> zipper)))]
+
+ [right rightmost #rights #lefts]
+ [left leftmost #lefts #rights]
+ )
+
+(def: #export (set value zipper)
+ (All [a] (-> a (Zipper a) (Zipper a)))
+ (set@ [#node #tree;value] value zipper))
+
+(def: #export (update f zipper)
+ (All [a] (-> (-> a a) (Zipper a) (Zipper a)))
+ (update@ [#node #tree;value] f zipper))
+
+(def: #export (prepend-child value zipper)
+ (All [a] (-> a (Zipper a) (Zipper a)))
+ (update@ [#node #tree;children]
+ (lambda [children]
+ (#;Cons (tree;tree ($ 0) {value []})
+ children))
+ zipper))
+
+(def: #export (append-child value zipper)
+ (All [a] (-> a (Zipper a) (Zipper a)))
+ (update@ [#node #tree;children]
+ (lambda [children]
+ (List/append children
+ (list (tree;tree ($ 0) {value []}))))
+ zipper))
+
+(def: #export (remove zipper)
+ (All [a] (-> (Zipper a) (Maybe (Zipper a))))
+ (case (get@ #lefts zipper)
+ #;Nil
+ (case (get@ #parent zipper)
+ #;None
+ #;None
+
+ (#;Some next)
+ (#;Some (|> next
+ (update@ [#node #tree;children] (|>. list;tail (default (list)))))))
+
+ (#;Cons next side)
+ (#;Some (|> zipper
+ (set@ #lefts side)
+ (set@ #node next)))))
+
+(do-template [<name> <side>]
+ [(def: #export (<name> value zipper)
+ (All [a] (-> a (Zipper a) (Maybe (Zipper a))))
+ (case (get@ #parent zipper)
+ #;None
+ #;None
+
+ _
+ (#;Some (|> zipper
+ (update@ <side> (lambda [side]
+ (#;Cons (tree;tree ($ 0) {value []})
+ side)))))))]
+
+ [insert-left #lefts]
+ [insert-right #rights]
+ )
+
+(do-template [<name> <h-side> <h-op> <v-op>]
+ [(def: #export (<name> zipper)
+ (All [a] (-> (Zipper a) (Zipper a)))
+ (case (get@ <h-side> zipper)
+ #;Nil
+ (<v-op> zipper)
+
+ _
+ (<h-op> zipper)))]
+
+ [next #rights right down]
+ [prev #lefts left up]
+ )
+
+(def: #export (end? zipper)
+ (All [a] (-> (Zipper a) Bool))
+ (and (list;empty? (get@ #rights zipper))
+ (list;empty? (children zipper))))
+
+(def: #export (root? zipper)
+ (All [a] (-> (Zipper a) Bool))
+ (case (get@ #parent zipper)
+ #;None
+ true
+
+ _
+ false))
diff --git a/stdlib/source/lux/data/sum.lux b/stdlib/source/lux/data/sum.lux
new file mode 100644
index 000000000..f01d88727
--- /dev/null
+++ b/stdlib/source/lux/data/sum.lux
@@ -0,0 +1,45 @@
+## 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/.
+
+(;module: lux)
+
+## [Values]
+(do-template [<name> <type> <index>]
+ [(def: #export (<name> value)
+ (All [a b] (-> <type> (| a b)))
+ (<index> value))]
+
+ [left a +0]
+ [right b +1])
+
+(def: #export (either f g s)
+ (All [a b c] (-> (-> a c) (-> b c) (| a b) c))
+ (case s
+ (+0 x) (f x)
+ (+1 x) (g x)))
+
+(do-template [<name> <side> <tag>]
+ [(def: #export (<name> es)
+ (All [a b] (-> (List (| a b)) (List <side>)))
+ (case es
+ #;Nil #;Nil
+ (#;Cons (<tag> x) es') (#;Cons [x (<name> es')])
+ (#;Cons _ es') (<name> es')))]
+
+ [lefts a +0]
+ [rights b +1]
+ )
+
+(def: #export (partition xs)
+ (All [a b] (-> (List (| a b)) [(List a) (List b)]))
+ (case xs
+ #;Nil
+ [#;Nil #;Nil]
+
+ (#;Cons x xs')
+ (let [[lefts rights] (partition xs')]
+ (case x
+ (+0 x') [(#;Cons x' lefts) rights]
+ (+1 x') [lefts (#;Cons x' rights)]))))
diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux
new file mode 100644
index 000000000..97507ba3b
--- /dev/null
+++ b/stdlib/source/lux/data/text.lux
@@ -0,0 +1,223 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monoid
+ eq
+ [ord]
+ monad
+ codec
+ hash)
+ (data (struct [list])
+ maybe)))
+
+## [Functions]
+(def: #export (size x)
+ (-> Text Nat)
+ (int-to-nat (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])])))
+
+(def: #export (at idx x)
+ (-> Nat Text (Maybe Char))
+ (if (<+ (size x) idx)
+ (#;Some (_lux_proc ["jvm" "invokevirtual:java.lang.String:charAt:int"] [x (_lux_proc ["jvm" "l2i"] [(nat-to-int idx)])]))
+ #;None))
+
+(def: #export (contains? sub text)
+ (-> Text Text Bool)
+ (_lux_proc ["jvm" "invokevirtual:java.lang.String:contains:java.lang.CharSequence"] [text sub]))
+
+(do-template [<name> <proc>]
+ [(def: #export (<name> x)
+ (-> Text Text)
+ (_lux_proc ["jvm" <proc>] [x]))]
+ [lower-case "invokevirtual:java.lang.String:toLowerCase:"]
+ [upper-case "invokevirtual:java.lang.String:toUpperCase:"]
+ [trim "invokevirtual:java.lang.String:trim:"]
+ )
+
+(def: #export (sub from to x)
+ (-> Nat Nat Text (Maybe Text))
+ (if (and (<+ to from)
+ (<=+ (size x) to))
+ (#;Some (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"]
+ [x
+ (_lux_proc ["jvm" "l2i"] [(nat-to-int from)])
+ (_lux_proc ["jvm" "l2i"] [(nat-to-int to)])]))
+ #;None))
+
+(def: #export (sub' from x)
+ (-> Nat Text (Maybe Text))
+ (sub from (size x) x))
+
+(def: #export (replace pattern value template)
+ (-> Text Text Text Text)
+ (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value]))
+
+(do-template [<common> <common-proc> <general> <general-proc>]
+ [(def: #export (<common> pattern x)
+ (-> Text Text (Maybe Nat))
+ (case (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" <common-proc>] [x pattern])])
+ -1 #;None
+ idx (#;Some (int-to-nat idx))))
+
+ (def: #export (<general> pattern from x)
+ (-> Text Nat Text (Maybe Nat))
+ (if (<+ (size x) from)
+ (case (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" <general-proc>] [x pattern (_lux_proc ["jvm" "l2i"] [(nat-to-int from)])])])
+ -1 #;None
+ idx (#;Some (int-to-nat idx)))
+ #;None))]
+
+ [index-of "invokevirtual:java.lang.String:indexOf:java.lang.String" index-of' "invokevirtual:java.lang.String:indexOf:java.lang.String,int"]
+ [last-index-of "invokevirtual:java.lang.String:lastIndexOf:java.lang.String" last-index-of' "invokevirtual:java.lang.String:lastIndexOf:java.lang.String,int"]
+ )
+
+(def: #export (starts-with? prefix x)
+ (-> Text Text Bool)
+ (case (index-of prefix x)
+ (#;Some +0)
+ true
+
+ _
+ false))
+
+(def: #export (ends-with? postfix x)
+ (-> Text Text Bool)
+ (case (last-index-of postfix x)
+ (#;Some n)
+ (=+ (size x)
+ (++ (size postfix) n))
+
+ _
+ false))
+
+(def: #export (split at x)
+ (-> Nat Text (Maybe [Text Text]))
+ (if (<=+ (size x) at)
+ (let [pre (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] [x (_lux_proc ["jvm" "l2i"] [0]) (_lux_proc ["jvm" "l2i"] [(nat-to-int at)])])
+ post (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int"] [x (_lux_proc ["jvm" "l2i"] [(nat-to-int at)])])]
+ (#;Some [pre post]))
+ #;None))
+
+(def: #export (split-with token sample)
+ (-> Text Text (Maybe [Text Text]))
+ (do Monad<Maybe>
+ [index (index-of token sample)
+ [pre post'] (split index sample)
+ [_ post] (split (size token) post')]
+ (wrap [pre post])))
+
+(def: #export (split-all-with token sample)
+ (-> Text Text (List Text))
+ (case (split-with token sample)
+ (#;Some [pre post])
+ (#;Cons pre (split-all-with token post))
+
+ #;None
+ (#;Cons sample #;Nil)))
+
+(def: #export split-lines
+ (split-all-with "\n"))
+
+## [Structures]
+(struct: #export _ (Eq Text)
+ (def: (= test subject)
+ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:equals:java.lang.Object"] [subject test])))
+
+(struct: #export _ (ord;Ord Text)
+ (def: eq Eq<Text>)
+
+ (do-template [<name> <op>]
+ [(def: (<name> test subject)
+ (<op> 0
+ (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:compareTo:java.lang.String"] [subject test])])))]
+
+ [< ;<]
+ [<= ;<=]
+ [> ;>]
+ [>= ;>=]))
+
+(struct: #export _ (Monoid Text)
+ (def: unit "")
+ (def: (append x y)
+ (_lux_proc ["jvm" "invokevirtual:java.lang.String:concat:java.lang.String"] [x y])))
+
+(open Monoid<Text>)
+
+(struct: #export _ (Codec Text Text)
+ (def: (encode original)
+ (let [escaped (|> original
+ (replace "\\" "\\\\")
+ (replace "\t" "\\t")
+ (replace "\b" "\\b")
+ (replace "\n" "\\n")
+ (replace "\r" "\\r")
+ (replace "\f" "\\f")
+ (replace "\"" "\\\"")
+ )]
+ ($_ append "\"" escaped "\"")))
+
+ (def: (decode input)
+ (if (and (starts-with? "\"" input)
+ (ends-with? "\"" input))
+ (case (sub +1 (dec+ (size input)) input)
+ (#;Some input')
+ (|> input'
+ (replace "\\\\" "\\")
+ (replace "\\t" "\t")
+ (replace "\\b" "\b")
+ (replace "\\n" "\n")
+ (replace "\\r" "\r")
+ (replace "\\f" "\f")
+ (replace "\\\"" "\"")
+ #;Some)
+
+ #;None
+ (#;Left "Couldn't decode text"))
+ (#;Left "Couldn't decode text"))))
+
+(struct: #export _ (Hash Text)
+ (def: eq Eq<Text>)
+
+ (def: hash
+ (|>. []
+ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:hashCode:"])
+ []
+ (_lux_proc ["jvm" "i2l"])
+ int-to-nat)))
+
+(def: #export concat
+ (-> (List Text) Text)
+ (let [(^open) list;Fold<List>
+ (^open) Monoid<Text>]
+ (|>. list;reverse (fold append unit))))
+
+(def: #export (join-with sep texts)
+ (-> Text (List Text) Text)
+ (|> texts (list;interpose sep) concat))
+
+(def: #export (empty? text)
+ (-> Text Bool)
+ (case text
+ "" true
+ _ false))
+
+(def: #export (replace-once pattern value template)
+ (-> Text Text Text Text)
+ (default template
+ (do Monad<Maybe>
+ [[pre post] (split-with pattern template)]
+ (let [(^open) Monoid<Text>]
+ (wrap ($_ append pre value post))))))
+
+(def: #export (enclose [left right] content)
+ (-> [Text Text] Text Text)
+ (let [(^open) Monoid<Text>]
+ ($_ append left content right)))
+
+(def: #export (enclose' boundary content)
+ (-> Text Text Text)
+ (enclose [boundary boundary] content))
diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux
new file mode 100644
index 000000000..a8b289fe3
--- /dev/null
+++ b/stdlib/source/lux/data/text/format.lux
@@ -0,0 +1,54 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monad)
+ (data [bool]
+ [char]
+ [number]
+ [text]
+ [ident]
+ (struct [list "" Monad<List>]))
+ [type]
+ [compiler]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax])))
+
+## [Syntax]
+(def: #hidden _append_
+ (-> Text Text Text)
+ (:: text;Monoid<Text> append))
+
+(syntax: #export (format {fragments (s;many s;any)})
+ {#;doc (doc "Text interpolation as a macro."
+ (format "Static part " (%t static) " doesn't match URI: " uri))}
+ (wrap (list (` ($_ _append_ (~@ fragments))))))
+
+## [Formatters]
+(type: (Formatter a)
+ (-> a Text))
+
+(do-template [<name> <type> <formatter>]
+ [(def: #export <name>
+ (Formatter <type>)
+ <formatter>)]
+
+ [%b Bool (:: bool;Codec<Text,Bool> encode)]
+ [%n Nat (:: number;Codec<Text,Nat> encode)]
+ [%i Int (:: number;Codec<Text,Int> encode)]
+ [%f Frac (:: number;Codec<Text,Frac> encode)]
+ [%r Real (:: number;Codec<Text,Real> encode)]
+ [%c Char (:: char;Codec<Text,Char> encode)]
+ [%t Text (:: text;Codec<Text,Text> encode)]
+ [%ident Ident (:: ident;Codec<Text,Ident> encode)]
+ [%ast AST ast;ast-to-text]
+ [%type Type type;type-to-text]
+ )
+
+(def: #export (%list formatter)
+ (All [a] (-> (Formatter a) (Formatter (List a))))
+ (lambda [values]
+ (format "(list " (text;join-with " " (map formatter values)) ")")))
diff --git a/stdlib/source/lux/host.lux b/stdlib/source/lux/host.lux
new file mode 100644
index 000000000..ecc33227a
--- /dev/null
+++ b/stdlib/source/lux/host.lux
@@ -0,0 +1,2137 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monad
+ [enum])
+ (codata function
+ [io #+ IO Monad<IO> io])
+ (data (struct [list #* "" Functor<List> Fold<List> "List/" Monad<List> Monoid<List>]
+ [array #+ Array])
+ number
+ maybe
+ [product]
+ [text "Text/" Eq<Text>]
+ text/format
+ [bool "Bool/" Codec<Text,Bool>])
+ [compiler #+ with-gensyms Functor<Lux> Monad<Lux>]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax])
+ [type]
+ ))
+
+(do-template [<name> <op> <from> <to>]
+ [(def: #export (<name> value)
+ {#;doc (doc "Type converter."
+ "From:"
+ <from>
+ "To:"
+ <to>)}
+ (-> (host <from>) (host <to>))
+ (_lux_proc ["jvm" <op>] [value]))]
+
+ [b2l "b2l" java.lang.Byte java.lang.Long]
+
+ [s2l "s2l" java.lang.Short java.lang.Long]
+
+ [d2i "d2i" java.lang.Double java.lang.Integer]
+ [d2l "d2l" java.lang.Double java.lang.Long]
+ [d2f "d2f" java.lang.Double java.lang.Float]
+
+ [f2i "f2i" java.lang.Float java.lang.Integer]
+ [f2l "f2l" java.lang.Float java.lang.Long]
+ [f2d "f2d" java.lang.Float java.lang.Double]
+
+ [i2b "i2b" java.lang.Integer java.lang.Byte]
+ [i2s "i2s" java.lang.Integer java.lang.Short]
+ [i2l "i2l" java.lang.Integer java.lang.Long]
+ [i2f "i2f" java.lang.Integer java.lang.Float]
+ [i2d "i2d" java.lang.Integer java.lang.Double]
+ [i2c "i2c" java.lang.Integer java.lang.Character]
+
+ [l2b "l2b" java.lang.Long java.lang.Byte]
+ [l2s "l2s" java.lang.Long java.lang.Short]
+ [l2i "l2i" java.lang.Long java.lang.Integer]
+ [l2f "l2f" java.lang.Long java.lang.Float]
+ [l2d "l2d" java.lang.Long java.lang.Double]
+
+ [c2b "c2b" java.lang.Character java.lang.Byte]
+ [c2s "c2s" java.lang.Character java.lang.Short]
+ [c2i "c2i" java.lang.Character java.lang.Integer]
+ [c2l "c2l" java.lang.Character java.lang.Long]
+ )
+
+## [Utils]
+(def: array-type-name "#Array")
+(def: constructor-method-name "<init>")
+(def: member-separator ".")
+
+## Types
+(do-template [<class> <name>]
+ [(type: #export <name>
+ (#;HostT <class> #;Nil))]
+
+ ["[Z" BooleanArray]
+ ["[B" ByteArray]
+ ["[S" ShortArray]
+ ["[I" IntArray]
+ ["[J" LongArray]
+ ["[F" FloatArray]
+ ["[D" DoubleArray]
+ ["[C" CharArray]
+ )
+
+(type: Code Text)
+
+(type: BoundKind
+ #UpperBound
+ #LowerBound)
+
+(type: #rec GenericType
+ (#GenericTypeVar Text)
+ (#GenericClass [Text (List GenericType)])
+ (#GenericArray GenericType)
+ (#GenericWildcard (Maybe [BoundKind GenericType])))
+
+(type: TypeParam
+ [Text (List GenericType)])
+
+(type: Primitive-Mode
+ #ManualPrM
+ #AutoPrM)
+
+(type: PrivacyModifier
+ #PublicPM
+ #PrivatePM
+ #ProtectedPM
+ #DefaultPM)
+
+(type: StateModifier
+ #VolatileSM
+ #FinalSM
+ #DefaultSM)
+
+(type: InheritanceModifier
+ #FinalIM
+ #AbstractIM
+ #DefaultIM)
+
+(type: ClassKind
+ #Class
+ #Interface)
+
+(type: ClassDecl
+ {#class-name Text
+ #class-params (List TypeParam)})
+
+(type: StackFrame (host java.lang.StackTraceElement))
+(type: StackTrace (Array StackFrame))
+
+(type: SuperClassDecl
+ {#super-class-name Text
+ #super-class-params (List GenericType)})
+
+(type: AnnotationParam
+ [Text AST])
+
+(type: Annotation
+ {#ann-name Text
+ #ann-params (List AnnotationParam)})
+
+(type: MemberDecl
+ {#member-name Text
+ #member-privacy PrivacyModifier
+ #member-anns (List Annotation)})
+
+(type: FieldDecl
+ (#ConstantField GenericType AST)
+ (#VariableField StateModifier GenericType))
+
+(type: MethodDecl
+ {#method-tvars (List TypeParam)
+ #method-inputs (List GenericType)
+ #method-output GenericType
+ #method-exs (List GenericType)})
+
+(type: ArgDecl
+ {#arg-name Text
+ #arg-type GenericType})
+
+(type: ConstructorArg
+ [GenericType AST])
+
+(type: MethodDef
+ (#ConstructorMethod [Bool
+ (List TypeParam)
+ (List ArgDecl)
+ (List ConstructorArg)
+ AST
+ (List GenericType)])
+ (#VirtualMethod [Bool
+ Bool
+ (List TypeParam)
+ (List ArgDecl)
+ GenericType
+ AST
+ (List GenericType)])
+ (#OverridenMethod [Bool
+ ClassDecl
+ (List TypeParam)
+ (List ArgDecl)
+ GenericType
+ AST
+ (List GenericType)])
+ (#StaticMethod [Bool
+ (List TypeParam)
+ (List ArgDecl)
+ GenericType
+ AST
+ (List GenericType)])
+ (#AbstractMethod [(List TypeParam)
+ (List ArgDecl)
+ GenericType
+ (List GenericType)])
+ (#NativeMethod [(List TypeParam)
+ (List ArgDecl)
+ GenericType
+ (List GenericType)]))
+
+(type: PartialCall
+ {#pc-method AST
+ #pc-args AST})
+
+(type: ImportMethodKind
+ #StaticIMK
+ #VirtualIMK)
+
+(type: ImportMethodCommons
+ {#import-member-mode Primitive-Mode
+ #import-member-alias Text
+ #import-member-kind ImportMethodKind
+ #import-member-tvars (List TypeParam)
+ #import-member-args (List [Bool GenericType])
+ #import-member-maybe? Bool
+ #import-member-try? Bool
+ #import-member-io? Bool})
+
+(type: ImportConstructorDecl
+ {})
+
+(type: ImportMethodDecl
+ {#import-method-name Text
+ #import-method-return GenericType})
+
+(type: ImportFieldDecl
+ {#import-field-mode Primitive-Mode
+ #import-field-name Text
+ #import-field-static? Bool
+ #import-field-maybe? Bool
+ #import-field-setter? Bool
+ #import-field-type GenericType})
+
+(type: ImportMemberDecl
+ (#EnumDecl (List Text))
+ (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl])
+ (#MethodDecl [ImportMethodCommons ImportMethodDecl])
+ (#FieldAccessDecl ImportFieldDecl))
+
+(type: ClassImports
+ (List [Text Text]))
+
+## Utils
+(def: (short-class-name name)
+ (-> Text Text)
+ (case (reverse (text;split-all-with "." name))
+ (#;Cons short-name _)
+ short-name
+
+ #;Nil
+ name))
+
+(def: (manual-primitive-to-type class)
+ (-> Text (Maybe AST))
+ (case class
+ (^template [<prim> <type>]
+ <prim>
+ (#;Some (' <type>)))
+ (["boolean" (;^ java.lang.Boolean)]
+ ["byte" (;^ java.lang.Byte)]
+ ["short" (;^ java.lang.Short)]
+ ["int" (;^ java.lang.Integer)]
+ ["long" (;^ java.lang.Long)]
+ ["float" (;^ java.lang.Float)]
+ ["double" (;^ java.lang.Double)]
+ ["char" (;^ java.lang.Character)]
+ ["void" ;Unit])
+
+ _
+ #;None))
+
+(def: (auto-primitive-to-type class)
+ (-> Text (Maybe AST))
+ (case class
+ (^template [<prim> <type>]
+ <prim>
+ (#;Some (' <type>)))
+ (["boolean" ;Bool]
+ ["byte" ;Int]
+ ["short" ;Int]
+ ["int" ;Int]
+ ["long" ;Int]
+ ["float" ;Real]
+ ["double" ;Real]
+ ["char" ;Char]
+ ["void" ;Unit])
+
+ _
+ #;None))
+
+(def: (generic-class->type' mode type-params in-array? name+params
+ class->type')
+ (-> Primitive-Mode (List TypeParam) Bool [Text (List GenericType)]
+ (-> Primitive-Mode (List TypeParam) Bool GenericType AST)
+ AST)
+ (case [name+params mode in-array?]
+ (^=> [[prim #;Nil] #ManualPrM false]
+ {(manual-primitive-to-type prim) (#;Some output)})
+ output
+
+ (^=> [[prim #;Nil] #AutoPrM false]
+ {(auto-primitive-to-type prim) (#;Some output)})
+ output
+
+ [[name params] _ _]
+ (let [=params (map (class->type' mode type-params in-array?) params)]
+ (` (host (~ (ast;symbol ["" name])) [(~@ =params)])))))
+
+(def: (class->type' mode type-params in-array? class)
+ (-> Primitive-Mode (List TypeParam) Bool GenericType AST)
+ (case class
+ (#GenericTypeVar name)
+ (case (find (lambda [[pname pbounds]]
+ (and (Text/= name pname)
+ (not (list;empty? pbounds))))
+ type-params)
+ #;None
+ (ast;symbol ["" name])
+
+ (#;Some [pname pbounds])
+ (class->type' mode type-params in-array? (default (undefined) (list;head pbounds))))
+
+ (#GenericClass name+params)
+ (generic-class->type' mode type-params in-array? name+params
+ class->type')
+
+ (#GenericArray param)
+ (let [=param (class->type' mode type-params true param)]
+ (` (host (~ (ast;symbol ["" array-type-name])) [(~ =param)])))
+
+ (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _])))
+ (' (;Ex [*] *))
+
+ (#GenericWildcard (#;Some [#UpperBound upper-bound]))
+ (class->type' mode type-params in-array? upper-bound)
+ ))
+
+(def: (class->type mode type-params class)
+ (-> Primitive-Mode (List TypeParam) GenericType AST)
+ (class->type' mode type-params false class))
+
+(def: (type-param-type$ [name bounds])
+ (-> TypeParam AST)
+ (ast;symbol ["" name]))
+
+(def: (class-decl-type$ (^slots [#class-name #class-params]))
+ (-> ClassDecl AST)
+ (let [=params (map (: (-> TypeParam AST)
+ (lambda [[pname pbounds]]
+ (case pbounds
+ #;Nil
+ (ast;symbol ["" pname])
+
+ (#;Cons bound1 _)
+ (class->type #ManualPrM class-params bound1))))
+ class-params)]
+ (` (host (~ (ast;symbol ["" class-name])) [(~@ =params)]))))
+
+(def: (stack-trace->text trace)
+ (-> StackTrace Text)
+ (let [size (_lux_proc ["jvm" "arraylength"] [trace])
+ idxs (list;range+ +0 (dec+ size))]
+ (|> idxs
+ (map (: (-> Nat Text)
+ (lambda [idx]
+ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"]
+ [(_lux_proc ["jvm" "aaload"] [trace idx])]))))
+ reverse
+ (text;join-with "\n")
+ )))
+
+(def: (get-stack-trace t)
+ (-> (host java.lang.Throwable) StackTrace)
+ (_lux_proc ["jvm" "invokevirtual:java.lang.Throwable:getStackTrace:"] [t]))
+
+(def: #export (throwable->text t)
+ (All [a] (-> (host java.lang.Throwable) (Either Text a)))
+ (#;Left (format (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [t])
+ "\n"
+ (|> t get-stack-trace stack-trace->text))))
+
+(def: empty-imports
+ ClassImports
+ (list))
+
+(def: (get-import name imports)
+ (-> Text ClassImports (Maybe Text))
+ (:: Functor<Maybe> map product;right
+ (find (|>. product;left (Text/= name))
+ imports)))
+
+(def: (add-import short+full imports)
+ (-> [Text Text] ClassImports ClassImports)
+ (#;Cons short+full imports))
+
+(def: (class-imports compiler)
+ (-> Compiler ClassImports)
+ (case (compiler;run compiler
+ (: (Lux ClassImports)
+ (do Monad<Lux>
+ [current-module compiler;current-module-name
+ defs (compiler;defs current-module)]
+ (wrap (fold (: (-> [Text Def] ClassImports ClassImports)
+ (lambda [[short-name [_ meta _]] imports]
+ (case (compiler;get-text-ann (ident-for #;;jvm-class) meta)
+ (#;Some full-class-name)
+ (add-import [short-name full-class-name] imports)
+
+ _
+ imports)))
+ empty-imports
+ defs)))))
+ (#;Left _) (list)
+ (#;Right imports) imports))
+
+(def: java.lang-classes
+ (List Text)
+ (list ## Interfaces
+ "Appendable"
+ "AutoCloseable"
+ "CharSequence"
+ "Cloneable"
+ "Comparable"
+ "Iterable"
+ "Readable"
+ "Runnable"
+
+ ## Classes
+ "Boolean"
+ "Byte"
+ "Character"
+ "Class"
+ "ClassLoader"
+ "ClassValue"
+ "Compiler"
+ "Double"
+ "Enum"
+ "Float"
+ "InheritableThreadLocal"
+ "Integer"
+ "Long"
+ "Math"
+ "Number"
+ "Object"
+ "Package"
+ "Process"
+ "ProcessBuilder"
+ "Runtime"
+ "RuntimePermission"
+ "SecurityManager"
+ "Short"
+ "StackTraceElement"
+ "StrictMath"
+ "String"
+ "StringBuffer"
+ "StringBuilder"
+ "System"
+ "Thread"
+ "ThreadGroup"
+ "ThreadLocal"
+ "Throwable"
+ "Void"
+
+ ## Exceptions
+ "ArithmeticException"
+ "ArrayIndexOutOfBoundsException"
+ "ArrayStoreException"
+ "ClassCastException"
+ "ClassNotFoundException"
+ "CloneNotSupportedException"
+ "EnumConstantNotPresentException"
+ "Exception"
+ "IllegalAccessException"
+ "IllegalArgumentException"
+ "IllegalMonitorStateException"
+ "IllegalStateException"
+ "IllegalThreadStateException"
+ "IndexOutOfBoundsException"
+ "InstantiationException"
+ "InterruptedException"
+ "NegativeArraySizeException"
+ "NoSuchFieldException"
+ "NoSuchMethodException"
+ "NullPointerException"
+ "NumberFormatException"
+ "ReflectiveOperationException"
+ "RuntimeException"
+ "SecurityException"
+ "StringIndexOutOfBoundsException"
+ "TypeNotPresentException"
+ "UnsupportedOperationException"
+
+ ## Annotations
+ "Deprecated"
+ "Override"
+ "SafeVarargs"
+ "SuppressWarnings"))
+
+(def: (fully-qualified-class-name? name)
+ (-> Text Bool)
+ (text;contains? "." name))
+
+(def: (fully-qualify-class-name imports name)
+ (-> ClassImports Text Text)
+ (cond (fully-qualified-class-name? name)
+ name
+
+ (member? text;Eq<Text> java.lang-classes name)
+ (format "java.lang." name)
+
+ ## else
+ (default name (get-import name imports))))
+
+(def: type-var-class Text "java.lang.Object")
+
+(def: (simple-class$ params class)
+ (-> (List TypeParam) GenericType Text)
+ (case class
+ (#GenericTypeVar name)
+ (case (find (lambda [[pname pbounds]]
+ (and (Text/= name pname)
+ (not (list;empty? pbounds))))
+ params)
+ #;None
+ type-var-class
+
+ (#;Some [pname pbounds])
+ (simple-class$ params (default (undefined) (list;head pbounds))))
+
+ (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _])))
+ type-var-class
+
+ (#GenericWildcard (#;Some [#UpperBound upper-bound]))
+ (simple-class$ params upper-bound)
+
+ (#GenericClass name params)
+ name
+
+ (#GenericArray param')
+ (case param'
+ (#GenericArray param)
+ (format "[" (simple-class$ params param))
+
+ (^template [<prim> <class>]
+ (#GenericClass <prim> #;Nil)
+ <class>)
+ (["boolean" "[Z"]
+ ["byte" "[B"]
+ ["short" "[S"]
+ ["int" "[I"]
+ ["long" "[J"]
+ ["float" "[F"]
+ ["double" "[D"]
+ ["char" "[C"])
+
+ param
+ (format "[L" (simple-class$ params param) ";"))
+ ))
+
+(def: (make-get-const-parser class-name field-name)
+ (-> Text Text (Syntax AST))
+ (do s;Monad<Syntax>
+ [#let [dotted-name (format "." field-name)]
+ _ (s;symbol! ["" dotted-name])]
+ (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" class-name ":" field-name)))] [])))))
+
+(def: (make-get-var-parser class-name field-name)
+ (-> Text Text (Syntax AST))
+ (do s;Monad<Syntax>
+ [#let [dotted-name (format "." field-name)]
+ _ (s;symbol! ["" dotted-name])]
+ (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getfield" ":" class-name ":" field-name)))] [_jvm_this])))))
+
+(def: (make-put-var-parser class-name field-name)
+ (-> Text Text (Syntax AST))
+ (do s;Monad<Syntax>
+ [#let [dotted-name (format "." field-name)]
+ [_ _ value] (: (Syntax [Unit Unit AST])
+ (s;form ($_ s;seq (s;symbol! ["" ":="]) (s;symbol! ["" dotted-name]) s;any)))]
+ (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "putfield" ":" class-name ":" field-name)))] [_jvm_this (~ value)])))))
+
+(def: (pre-walk-replace f input)
+ (-> (-> AST AST) AST AST)
+ (case (f input)
+ (^template [<tag>]
+ [meta (<tag> parts)]
+ [meta (<tag> (map (pre-walk-replace f) parts))])
+ ([#;FormS]
+ [#;TupleS])
+
+ [meta (#;RecordS pairs)]
+ [meta (#;RecordS (map (: (-> [AST AST] [AST AST])
+ (lambda [[key val]]
+ [(pre-walk-replace f key) (pre-walk-replace f val)]))
+ pairs))]
+
+ ast'
+ ast'))
+
+(def: (parser->replacer p ast)
+ (-> (Syntax AST) (-> AST AST))
+ (case (s;run (list ast) p)
+ (#;Right [#;Nil ast'])
+ ast'
+
+ _
+ ast
+ ))
+
+(def: (field->parser class-name [[field-name _ _] field])
+ (-> Text [MemberDecl FieldDecl] (Syntax AST))
+ (case field
+ (#ConstantField _)
+ (make-get-const-parser class-name field-name)
+
+ (#VariableField _)
+ (s;either (make-get-var-parser class-name field-name)
+ (make-put-var-parser class-name field-name))))
+
+(def: (make-constructor-parser params class-name arg-decls)
+ (-> (List TypeParam) Text (List ArgDecl) (Syntax AST))
+ (do s;Monad<Syntax>
+ [[_ args] (: (Syntax [Unit (List AST)])
+ (s;form ($_ s;seq (s;symbol! ["" ".new!"]) (s;tuple (s;exactly (list;size arg-decls) s;any)))))
+ #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]]
+ (wrap (` (;_lux_proc ["jvm" (~ (ast;text (format "new" ":" class-name ":" (text;join-with "," arg-decls'))))]
+ [(~@ args)])))))
+
+(def: (make-static-method-parser params class-name method-name arg-decls)
+ (-> (List TypeParam) Text Text (List ArgDecl) (Syntax AST))
+ (do s;Monad<Syntax>
+ [#let [dotted-name (format "." method-name "!")]
+ [_ args] (: (Syntax [Unit (List AST)])
+ (s;form ($_ s;seq (s;symbol! ["" dotted-name]) (s;tuple (s;exactly (list;size arg-decls) s;any)))))
+ #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]]
+ (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format "invokestatic" ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))]
+ [(~@ args)])))))
+
+(do-template [<name> <jvm-op>]
+ [(def: (<name> params class-name method-name arg-decls)
+ (-> (List TypeParam) Text Text (List ArgDecl) (Syntax AST))
+ (do s;Monad<Syntax>
+ [#let [dotted-name (format "." method-name "!")]
+ [_ args] (: (Syntax [Unit (List AST)])
+ (s;form ($_ s;seq (s;symbol! ["" dotted-name]) (s;tuple (s;exactly (list;size arg-decls) s;any)))))
+ #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]]
+ (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format <jvm-op> ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))]
+ [(~' _jvm_this) (~@ args)])))))]
+
+ [make-special-method-parser "invokespecial"]
+ [make-virtual-method-parser "invokevirtual"]
+ )
+
+(def: (method->parser params class-name [[method-name _ _] meth-def])
+ (-> (List TypeParam) Text [MemberDecl MethodDef] (Syntax AST))
+ (case meth-def
+ (#ConstructorMethod strict? type-vars args constructor-args return-expr exs)
+ (make-constructor-parser params class-name args)
+
+ (#StaticMethod strict? type-vars args return-type return-expr exs)
+ (make-static-method-parser params class-name method-name args)
+
+ (^or (#VirtualMethod final? strict? type-vars args return-type return-expr exs) (#OverridenMethod strict? owner-class type-vars args return-type return-expr exs))
+ (make-special-method-parser params class-name method-name args)
+
+ (#AbstractMethod type-vars args return-type exs)
+ (make-virtual-method-parser params class-name method-name args)
+
+ (#NativeMethod type-vars args return-type exs)
+ (make-virtual-method-parser params class-name method-name args)))
+
+## Syntaxs
+(def: (full-class-name^ imports)
+ (-> ClassImports (Syntax Text))
+ (do s;Monad<Syntax>
+ [name s;local-symbol]
+ (wrap (fully-qualify-class-name imports name))))
+
+(def: privacy-modifier^
+ (Syntax PrivacyModifier)
+ (let [(^open) s;Monad<Syntax>]
+ ($_ s;alt
+ (s;tag! ["" "public"])
+ (s;tag! ["" "private"])
+ (s;tag! ["" "protected"])
+ (wrap []))))
+
+(def: inheritance-modifier^
+ (Syntax InheritanceModifier)
+ (let [(^open) s;Monad<Syntax>]
+ ($_ s;alt
+ (s;tag! ["" "final"])
+ (s;tag! ["" "abstract"])
+ (wrap []))))
+
+(def: bound-kind^
+ (Syntax BoundKind)
+ (s;alt (s;symbol! ["" "<"])
+ (s;symbol! ["" ">"])))
+
+(def: (generic-type^ imports type-vars)
+ (-> ClassImports (List TypeParam) (Syntax GenericType))
+ ($_ s;either
+ (do s;Monad<Syntax>
+ [_ (s;symbol! ["" "?"])]
+ (wrap (#GenericWildcard #;None)))
+ (s;tuple (do s;Monad<Syntax>
+ [_ (s;symbol! ["" "?"])
+ bound-kind bound-kind^
+ bound (generic-type^ imports type-vars)]
+ (wrap (#GenericWildcard (#;Some [bound-kind bound])))))
+ (do s;Monad<Syntax>
+ [name (full-class-name^ imports)]
+ (let% [<branches> (do-template [<class> <name>]
+ [(Text/= <name> name)
+ (wrap (#GenericClass <class> (list)))]
+
+ ["[Z" "BooleanArray"]
+ ["[B" "ByteArray"]
+ ["[S" "ShortArray"]
+ ["[I" "IntArray"]
+ ["[J" "LongArray"]
+ ["[F" "FloatArray"]
+ ["[D" "DoubleArray"]
+ ["[C" "CharArray"])]
+ (cond (member? text;Eq<Text> (map product;left type-vars) name)
+ (wrap (#GenericTypeVar name))
+
+ <branches>
+
+ ## else
+ (wrap (#GenericClass name (list))))))
+ (s;form (do s;Monad<Syntax>
+ [name (s;symbol! ["" "Array"])
+ component (generic-type^ imports type-vars)]
+ (case component
+ (^template [<class> <name>]
+ (#GenericClass <name> #;Nil)
+ (wrap (#GenericClass <class> (list))))
+ (["[Z" "boolean"]
+ ["[B" "byte"]
+ ["[S" "short"]
+ ["[I" "int"]
+ ["[J" "long"]
+ ["[F" "float"]
+ ["[D" "double"]
+ ["[C" "char"])
+
+ _
+ (wrap (#GenericArray component)))))
+ (s;form (do s;Monad<Syntax>
+ [name (full-class-name^ imports)
+ params (s;some (generic-type^ imports type-vars))
+ _ (s;assert (not (member? text;Eq<Text> (map product;left type-vars) name))
+ (format name " can't be a type-parameter!"))]
+ (wrap (#GenericClass name params))))
+ ))
+
+(def: (type-param^ imports)
+ (-> ClassImports (Syntax TypeParam))
+ (s;either (do s;Monad<Syntax>
+ [param-name s;local-symbol]
+ (wrap [param-name (list)]))
+ (s;tuple (do s;Monad<Syntax>
+ [param-name s;local-symbol
+ _ (s;symbol! ["" "<"])
+ bounds (s;many (generic-type^ imports (list)))]
+ (wrap [param-name bounds])))))
+
+(def: (type-params^ imports)
+ (-> ClassImports (Syntax (List TypeParam)))
+ (s;tuple (s;some (type-param^ imports))))
+
+(def: (class-decl^ imports)
+ (-> ClassImports (Syntax ClassDecl))
+ (s;either (do s;Monad<Syntax>
+ [name (full-class-name^ imports)]
+ (wrap [name (list)]))
+ (s;form (do s;Monad<Syntax>
+ [name (full-class-name^ imports)
+ params (s;some (type-param^ imports))]
+ (wrap [name params])))
+ ))
+
+(def: (super-class-decl^ imports type-vars)
+ (-> ClassImports (List TypeParam) (Syntax SuperClassDecl))
+ (s;either (do s;Monad<Syntax>
+ [name (full-class-name^ imports)]
+ (wrap [name (list)]))
+ (s;form (do s;Monad<Syntax>
+ [name (full-class-name^ imports)
+ params (s;some (generic-type^ imports type-vars))]
+ (wrap [name params])))))
+
+(def: annotation-params^
+ (Syntax (List AnnotationParam))
+ (s;record (s;some (s;seq s;local-tag s;any))))
+
+(def: (annotation^ imports)
+ (-> ClassImports (Syntax Annotation))
+ (s;either (do s;Monad<Syntax>
+ [ann-name (full-class-name^ imports)]
+ (wrap [ann-name (list)]))
+ (s;form (s;seq (full-class-name^ imports)
+ annotation-params^))))
+
+(def: (annotations^' imports)
+ (-> ClassImports (Syntax (List Annotation)))
+ (do s;Monad<Syntax>
+ [_ (s;tag! ["" "ann"])]
+ (s;tuple (s;some (annotation^ imports)))))
+
+(def: (annotations^ imports)
+ (-> ClassImports (Syntax (List Annotation)))
+ (do s;Monad<Syntax>
+ [anns?? (s;opt (annotations^' imports))]
+ (wrap (default (list) anns??))))
+
+(def: (throws-decl'^ imports type-vars)
+ (-> ClassImports (List TypeParam) (Syntax (List GenericType)))
+ (do s;Monad<Syntax>
+ [_ (s;tag! ["" "throws"])]
+ (s;tuple (s;some (generic-type^ imports type-vars)))))
+
+(def: (throws-decl^ imports type-vars)
+ (-> ClassImports (List TypeParam) (Syntax (List GenericType)))
+ (do s;Monad<Syntax>
+ [exs? (s;opt (throws-decl'^ imports type-vars))]
+ (wrap (default (list) exs?))))
+
+(def: (method-decl^ imports type-vars)
+ (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDecl]))
+ (s;form (do s;Monad<Syntax>
+ [tvars (s;default (list) (type-params^ imports))
+ name s;local-symbol
+ anns (annotations^ imports)
+ inputs (s;tuple (s;some (generic-type^ imports type-vars)))
+ output (generic-type^ imports type-vars)
+ exs (throws-decl^ imports type-vars)]
+ (wrap [[name #PublicPM anns] {#method-tvars tvars
+ #method-inputs inputs
+ #method-output output
+ #method-exs exs}]))))
+
+(def: state-modifier^
+ (Syntax StateModifier)
+ ($_ s;alt
+ (s;tag! ["" "volatile"])
+ (s;tag! ["" "final"])
+ (:: s;Monad<Syntax> wrap [])))
+
+(def: (field-decl^ imports type-vars)
+ (-> ClassImports (List TypeParam) (Syntax [MemberDecl FieldDecl]))
+ (s;either (s;form (do s;Monad<Syntax>
+ [_ (s;tag! ["" "const"])
+ name s;local-symbol
+ anns (annotations^ imports)
+ type (generic-type^ imports type-vars)
+ body s;any]
+ (wrap [[name #PublicPM anns] (#ConstantField [type body])])))
+ (s;form (do s;Monad<Syntax>
+ [pm privacy-modifier^
+ sm state-modifier^
+ name s;local-symbol
+ anns (annotations^ imports)
+ type (generic-type^ imports type-vars)]
+ (wrap [[name pm anns] (#VariableField [sm type])])))))
+
+(def: (arg-decl^ imports type-vars)
+ (-> ClassImports (List TypeParam) (Syntax ArgDecl))
+ (s;record (s;seq s;local-symbol
+ (generic-type^ imports type-vars))))
+
+(def: (arg-decls^ imports type-vars)
+ (-> ClassImports (List TypeParam) (Syntax (List ArgDecl)))
+ (s;some (arg-decl^ imports type-vars)))
+
+(def: (constructor-arg^ imports type-vars)
+ (-> ClassImports (List TypeParam) (Syntax ConstructorArg))
+ (s;tuple (s;seq (generic-type^ imports type-vars) s;any)))
+
+(def: (constructor-args^ imports type-vars)
+ (-> ClassImports (List TypeParam) (Syntax (List ConstructorArg)))
+ (s;tuple (s;some (constructor-arg^ imports type-vars))))
+
+(def: (constructor-method^ imports class-vars)
+ (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef]))
+ (s;form (do s;Monad<Syntax>
+ [pm privacy-modifier^
+ strict-fp? (s;tag? ["" "strict"])
+ method-vars (s;default (list) (type-params^ imports))
+ #let [total-vars (List/append class-vars method-vars)]
+ [_ arg-decls] (s;form (s;seq (s;symbol! ["" "new"])
+ (arg-decls^ imports total-vars)))
+ constructor-args (constructor-args^ imports total-vars)
+ exs (throws-decl^ imports total-vars)
+ annotations (annotations^ imports)
+ body s;any]
+ (wrap [{#member-name constructor-method-name
+ #member-privacy pm
+ #member-anns annotations}
+ (#ConstructorMethod strict-fp? method-vars arg-decls constructor-args body exs)]))))
+
+(def: (virtual-method-def^ imports class-vars)
+ (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef]))
+ (s;form (do s;Monad<Syntax>
+ [pm privacy-modifier^
+ strict-fp? (s;tag? ["" "strict"])
+ final? (s;tag? ["" "final"])
+ method-vars (s;default (list) (type-params^ imports))
+ #let [total-vars (List/append class-vars method-vars)]
+ [name arg-decls] (s;form (s;seq s;local-symbol
+ (arg-decls^ imports total-vars)))
+ return-type (generic-type^ imports total-vars)
+ exs (throws-decl^ imports total-vars)
+ annotations (annotations^ imports)
+ body s;any]
+ (wrap [{#member-name name
+ #member-privacy pm
+ #member-anns annotations}
+ (#VirtualMethod final? strict-fp? method-vars arg-decls return-type body exs)]))))
+
+(def: (overriden-method-def^ imports)
+ (-> ClassImports (Syntax [MemberDecl MethodDef]))
+ (s;form (do s;Monad<Syntax>
+ [strict-fp? (s;tag? ["" "strict"])
+ owner-class (class-decl^ imports)
+ method-vars (s;default (list) (type-params^ imports))
+ #let [total-vars (List/append (product;right owner-class) method-vars)]
+ [name arg-decls] (s;form (s;seq s;local-symbol
+ (arg-decls^ imports total-vars)))
+ return-type (generic-type^ imports total-vars)
+ exs (throws-decl^ imports total-vars)
+ annotations (annotations^ imports)
+ body s;any]
+ (wrap [{#member-name name
+ #member-privacy #PublicPM
+ #member-anns annotations}
+ (#OverridenMethod strict-fp? owner-class method-vars arg-decls return-type body exs)]))))
+
+(def: (static-method-def^ imports)
+ (-> ClassImports (Syntax [MemberDecl MethodDef]))
+ (s;form (do s;Monad<Syntax>
+ [pm privacy-modifier^
+ strict-fp? (s;tag? ["" "strict"])
+ _ (s;tag! ["" "static"])
+ method-vars (s;default (list) (type-params^ imports))
+ #let [total-vars method-vars]
+ [name arg-decls] (s;form (s;seq s;local-symbol
+ (arg-decls^ imports total-vars)))
+ return-type (generic-type^ imports total-vars)
+ exs (throws-decl^ imports total-vars)
+ annotations (annotations^ imports)
+ body s;any]
+ (wrap [{#member-name name
+ #member-privacy pm
+ #member-anns annotations}
+ (#StaticMethod strict-fp? method-vars arg-decls return-type body exs)]))))
+
+(def: (abstract-method-def^ imports)
+ (-> ClassImports (Syntax [MemberDecl MethodDef]))
+ (s;form (do s;Monad<Syntax>
+ [pm privacy-modifier^
+ _ (s;tag! ["" "abstract"])
+ method-vars (s;default (list) (type-params^ imports))
+ #let [total-vars method-vars]
+ [name arg-decls] (s;form (s;seq s;local-symbol
+ (arg-decls^ imports total-vars)))
+ return-type (generic-type^ imports total-vars)
+ exs (throws-decl^ imports total-vars)
+ annotations (annotations^ imports)]
+ (wrap [{#member-name name
+ #member-privacy pm
+ #member-anns annotations}
+ (#AbstractMethod method-vars arg-decls return-type exs)]))))
+
+(def: (native-method-def^ imports)
+ (-> ClassImports (Syntax [MemberDecl MethodDef]))
+ (s;form (do s;Monad<Syntax>
+ [pm privacy-modifier^
+ _ (s;tag! ["" "native"])
+ method-vars (s;default (list) (type-params^ imports))
+ #let [total-vars method-vars]
+ [name arg-decls] (s;form (s;seq s;local-symbol
+ (arg-decls^ imports total-vars)))
+ return-type (generic-type^ imports total-vars)
+ exs (throws-decl^ imports total-vars)
+ annotations (annotations^ imports)]
+ (wrap [{#member-name name
+ #member-privacy pm
+ #member-anns annotations}
+ (#NativeMethod method-vars arg-decls return-type exs)]))))
+
+(def: (method-def^ imports class-vars)
+ (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef]))
+ ($_ s;either
+ (constructor-method^ imports class-vars)
+ (virtual-method-def^ imports class-vars)
+ (overriden-method-def^ imports)
+ (static-method-def^ imports)
+ (abstract-method-def^ imports)
+ (native-method-def^ imports)))
+
+(def: partial-call^
+ (Syntax PartialCall)
+ (s;form (s;seq s;any s;any)))
+
+(def: class-kind^
+ (Syntax ClassKind)
+ (s;either (do s;Monad<Syntax>
+ [_ (s;tag! ["" "class"])]
+ (wrap #Class))
+ (do s;Monad<Syntax>
+ [_ (s;tag! ["" "interface"])]
+ (wrap #Interface))
+ ))
+
+(def: import-member-alias^
+ (Syntax (Maybe Text))
+ (s;opt (do s;Monad<Syntax>
+ [_ (s;tag! ["" "as"])]
+ s;local-symbol)))
+
+(def: (import-member-args^ imports type-vars)
+ (-> ClassImports (List TypeParam) (Syntax (List [Bool GenericType])))
+ (s;tuple (s;some (s;seq (s;tag? ["" "?"]) (generic-type^ imports type-vars)))))
+
+(def: import-member-return-flags^
+ (Syntax [Bool Bool Bool])
+ ($_ s;seq (s;tag? ["" "io"]) (s;tag? ["" "try"]) (s;tag? ["" "?"])))
+
+(def: primitive-mode^
+ (Syntax Primitive-Mode)
+ (s;alt (s;tag! ["" "manual"])
+ (s;tag! ["" "auto"])))
+
+(def: (import-member-decl^ imports owner-vars)
+ (-> ClassImports (List TypeParam) (Syntax ImportMemberDecl))
+ ($_ s;either
+ (s;form (do s;Monad<Syntax>
+ [_ (s;tag! ["" "enum"])
+ enum-members (s;some s;local-symbol)]
+ (wrap (#EnumDecl enum-members))))
+ (s;form (do s;Monad<Syntax>
+ [tvars (s;default (list) (type-params^ imports))
+ _ (s;symbol! ["" "new"])
+ ?alias import-member-alias^
+ #let [total-vars (List/append owner-vars tvars)]
+ ?prim-mode (s;opt primitive-mode^)
+ args (import-member-args^ imports total-vars)
+ [io? try? maybe?] import-member-return-flags^]
+ (wrap (#ConstructorDecl [{#import-member-mode (default #AutoPrM ?prim-mode)
+ #import-member-alias (default "new" ?alias)
+ #import-member-kind #VirtualIMK
+ #import-member-tvars tvars
+ #import-member-args args
+ #import-member-maybe? maybe?
+ #import-member-try? try?
+ #import-member-io? io?}
+ {}]))
+ ))
+ (s;form (do s;Monad<Syntax>
+ [kind (: (Syntax ImportMethodKind)
+ (s;alt (s;tag! ["" "static"])
+ (wrap [])))
+ tvars (s;default (list) (type-params^ imports))
+ name s;local-symbol
+ ?alias import-member-alias^
+ #let [total-vars (List/append owner-vars tvars)]
+ ?prim-mode (s;opt primitive-mode^)
+ args (import-member-args^ imports total-vars)
+ [io? try? maybe?] import-member-return-flags^
+ return (generic-type^ imports total-vars)]
+ (wrap (#MethodDecl [{#import-member-mode (default #AutoPrM ?prim-mode)
+ #import-member-alias (default name ?alias)
+ #import-member-kind kind
+ #import-member-tvars tvars
+ #import-member-args args
+ #import-member-maybe? maybe?
+ #import-member-try? try?
+ #import-member-io? io?}
+ {#import-method-name name
+ #import-method-return return
+ }]))))
+ (s;form (do s;Monad<Syntax>
+ [static? (s;tag? ["" "static"])
+ name s;local-symbol
+ ?prim-mode (s;opt primitive-mode^)
+ gtype (generic-type^ imports owner-vars)
+ maybe? (s;tag? ["" "?"])
+ setter? (s;tag? ["" "!"])]
+ (wrap (#FieldAccessDecl {#import-field-mode (default #AutoPrM ?prim-mode)
+ #import-field-name name
+ #import-field-static? static?
+ #import-field-maybe? maybe?
+ #import-field-setter? setter?
+ #import-field-type gtype}))))
+ ))
+
+## Generators
+(def: with-parens
+ (-> Code Code)
+ (text;enclose ["(" ")"]))
+
+(def: with-brackets
+ (-> Code Code)
+ (text;enclose ["[" "]"]))
+
+(def: spaced
+ (-> (List Code) Code)
+ (text;join-with " "))
+
+(def: (privacy-modifier$ pm)
+ (-> PrivacyModifier Code)
+ (case pm
+ #PublicPM "public"
+ #PrivatePM "private"
+ #ProtectedPM "protected"
+ #DefaultPM "default"))
+
+(def: (inheritance-modifier$ im)
+ (-> InheritanceModifier Code)
+ (case im
+ #FinalIM "final"
+ #AbstractIM "abstract"
+ #DefaultIM "default"))
+
+(def: (annotation-param$ [name value])
+ (-> AnnotationParam Code)
+ (format name "=" (ast;ast-to-text value)))
+
+(def: (annotation$ [name params])
+ (-> Annotation Code)
+ (format "(" name " " "{" (text;join-with "\t" (map annotation-param$ params)) "}" ")"))
+
+(def: (bound-kind$ kind)
+ (-> BoundKind Code)
+ (case kind
+ #UpperBound "<"
+ #LowerBound ">"))
+
+(def: (generic-type$ gtype)
+ (-> GenericType Code)
+ (case gtype
+ (#GenericTypeVar name)
+ name
+
+ (#GenericClass name params)
+ (format "(" name " " (spaced (map generic-type$ params)) ")")
+
+ (#GenericArray param)
+ (format "(" array-type-name " " (generic-type$ param) ")")
+
+ (#GenericWildcard #;None)
+ "?"
+
+ (#GenericWildcard (#;Some [bound-kind bound]))
+ (format (bound-kind$ bound-kind) (generic-type$ bound))))
+
+(def: (type-param$ [name bounds])
+ (-> TypeParam Code)
+ (format "(" name " " (spaced (map generic-type$ bounds)) ")"))
+
+(def: (class-decl$ (^open))
+ (-> ClassDecl Code)
+ (format "(" class-name " " (spaced (map type-param$ class-params)) ")"))
+
+(def: (super-class-decl$ (^slots [#super-class-name #super-class-params]))
+ (-> SuperClassDecl Code)
+ (format "(" super-class-name " " (spaced (map generic-type$ super-class-params)) ")"))
+
+(def: (method-decl$ [[name pm anns] method-decl])
+ (-> [MemberDecl MethodDecl] Code)
+ (let [(^slots [#method-tvars #method-inputs #method-output #method-exs]) method-decl]
+ (with-parens
+ (spaced (list name
+ (with-brackets (spaced (map annotation$ anns)))
+ (with-brackets (spaced (map type-param$ method-tvars)))
+ (with-brackets (spaced (map generic-type$ method-exs)))
+ (with-brackets (spaced (map generic-type$ method-inputs)))
+ (generic-type$ method-output))
+ ))))
+
+(def: (state-modifier$ sm)
+ (-> StateModifier Code)
+ (case sm
+ #VolatileSM "volatile"
+ #FinalSM "final"
+ #DefaultSM "default"))
+
+(def: (field-decl$ [[name pm anns] field])
+ (-> [MemberDecl FieldDecl] Code)
+ (case field
+ (#ConstantField class value)
+ (with-parens
+ (spaced (list "constant" name
+ (with-brackets (spaced (map annotation$ anns)))
+ (generic-type$ class)
+ (ast;ast-to-text value))
+ ))
+
+ (#VariableField sm class)
+ (with-parens
+ (spaced (list "variable" name
+ (privacy-modifier$ pm)
+ (state-modifier$ sm)
+ (with-brackets (spaced (map annotation$ anns)))
+ (generic-type$ class))
+ ))
+ ))
+
+(def: (arg-decl$ [name type])
+ (-> ArgDecl Code)
+ (with-parens
+ (spaced (list name (generic-type$ type)))))
+
+(def: (constructor-arg$ [class term])
+ (-> ConstructorArg Code)
+ (with-brackets
+ (spaced (list (generic-type$ class) (ast;ast-to-text term)))))
+
+(def: (method-def$ replacer super-class [[name pm anns] method-def])
+ (-> (-> AST AST) SuperClassDecl [MemberDecl MethodDef] Code)
+ (case method-def
+ (#ConstructorMethod strict-fp? type-vars arg-decls constructor-args body exs)
+ (with-parens
+ (spaced (list "init"
+ (privacy-modifier$ pm)
+ (Bool/encode strict-fp?)
+ (with-brackets (spaced (map annotation$ anns)))
+ (with-brackets (spaced (map type-param$ type-vars)))
+ (with-brackets (spaced (map generic-type$ exs)))
+ (with-brackets (spaced (map arg-decl$ arg-decls)))
+ (with-brackets (spaced (map constructor-arg$ constructor-args)))
+ (ast;ast-to-text (pre-walk-replace replacer body))
+ )))
+
+ (#VirtualMethod final? strict-fp? type-vars arg-decls return-type body exs)
+ (with-parens
+ (spaced (list "virtual"
+ name
+ (privacy-modifier$ pm)
+ (Bool/encode final?)
+ (Bool/encode strict-fp?)
+ (with-brackets (spaced (map annotation$ anns)))
+ (with-brackets (spaced (map type-param$ type-vars)))
+ (with-brackets (spaced (map generic-type$ exs)))
+ (with-brackets (spaced (map arg-decl$ arg-decls)))
+ (generic-type$ return-type)
+ (ast;ast-to-text (pre-walk-replace replacer body)))))
+
+ (#OverridenMethod strict-fp? class-decl type-vars arg-decls return-type body exs)
+ (let [super-replacer (parser->replacer (s;form (do s;Monad<Syntax>
+ [_ (s;symbol! ["" ".super!"])
+ args (s;tuple (s;exactly (list;size arg-decls) s;any))
+ #let [arg-decls' (: (List Text) (map (. (simple-class$ (list)) product;right)
+ arg-decls))]]
+ (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format "invokespecial" ":" (get@ #super-class-name super-class) ":" name ":" (text;join-with "," arg-decls'))))]
+ [(~' _jvm_this) (~@ args)]))))))]
+ (with-parens
+ (spaced (list "override"
+ (class-decl$ class-decl)
+ name
+ (Bool/encode strict-fp?)
+ (with-brackets (spaced (map annotation$ anns)))
+ (with-brackets (spaced (map type-param$ type-vars)))
+ (with-brackets (spaced (map generic-type$ exs)))
+ (with-brackets (spaced (map arg-decl$ arg-decls)))
+ (generic-type$ return-type)
+ (|> body
+ (pre-walk-replace replacer)
+ (pre-walk-replace super-replacer)
+ (ast;ast-to-text))
+ ))))
+
+ (#StaticMethod strict-fp? type-vars arg-decls return-type body exs)
+ (with-parens
+ (spaced (list "static"
+ name
+ (privacy-modifier$ pm)
+ (Bool/encode strict-fp?)
+ (with-brackets (spaced (map annotation$ anns)))
+ (with-brackets (spaced (map type-param$ type-vars)))
+ (with-brackets (spaced (map generic-type$ exs)))
+ (with-brackets (spaced (map arg-decl$ arg-decls)))
+ (generic-type$ return-type)
+ (ast;ast-to-text (pre-walk-replace replacer body)))))
+
+ (#AbstractMethod type-vars arg-decls return-type exs)
+ (with-parens
+ (spaced (list "abstract"
+ name
+ (privacy-modifier$ pm)
+ (with-brackets (spaced (map annotation$ anns)))
+ (with-brackets (spaced (map type-param$ type-vars)))
+ (with-brackets (spaced (map generic-type$ exs)))
+ (with-brackets (spaced (map arg-decl$ arg-decls)))
+ (generic-type$ return-type))))
+
+ (#NativeMethod type-vars arg-decls return-type exs)
+ (with-parens
+ (spaced (list "native"
+ name
+ (privacy-modifier$ pm)
+ (with-brackets (spaced (map annotation$ anns)))
+ (with-brackets (spaced (map type-param$ type-vars)))
+ (with-brackets (spaced (map generic-type$ exs)))
+ (with-brackets (spaced (map arg-decl$ arg-decls)))
+ (generic-type$ return-type))))
+ ))
+
+(def: (complete-call$ obj [method args])
+ (-> AST PartialCall AST)
+ (` ((~ method) (~ args) (~ obj))))
+
+## [Syntax]
+(def: object-super-class
+ SuperClassDecl
+ {#super-class-name "java.lang.Object"
+ #super-class-params (list)})
+
+(syntax: #export (class: {#let [imports (class-imports *compiler*)]}
+ {im inheritance-modifier^}
+ {class-decl (class-decl^ imports)}
+ {#let [full-class-name (product;left class-decl)
+ imports (add-import [(short-class-name full-class-name) full-class-name]
+ (class-imports *compiler*))]}
+ {#let [class-vars (product;right class-decl)]}
+ {super (s;opt (super-class-decl^ imports class-vars))}
+ {interfaces (s;tuple (s;some (super-class-decl^ imports class-vars)))}
+ {annotations (annotations^ imports)}
+ {fields (s;some (field-decl^ imports class-vars))}
+ {methods (s;some (method-def^ imports class-vars))})
+ {#;doc (doc "Allows defining JVM classes in Lux code."
+ "For example:"
+ (class: #final (JvmPromise A) []
+ ## Fields
+ (#private resolved boolean)
+ (#private datum A)
+ (#private waitingList (java.util.List lux.Function))
+ ## Methods
+ (#public new [] [] []
+ (exec (:= .resolved false)
+ (:= .waitingList (ArrayList.new []))
+ []))
+ (#public resolve [] [{value A}] boolean
+ (let [container (.new! [])]
+ (synchronized _jvm_this
+ (if .resolved
+ false
+ (exec (:= .datum value)
+ (:= .resolved true)
+ (let [sleepers .waitingList
+ sleepers-count (java.util.List.size [] sleepers)]
+ (map (lambda [idx]
+ (let [sleeper (java.util.List.get [(l2i idx)] sleepers)]
+ (Executor.execute [(@runnable (lux.Function.apply [(:! Object value)] sleeper))]
+ executor)))
+ (range 0 (dec (i2l sleepers-count)))))
+ (:= .waitingList (null))
+ true)))))
+ (#public poll [] [] A
+ .datum)
+ (#public wasResolved [] [] boolean
+ (synchronized _jvm_this
+ .resolved))
+ (#public waitOn [] [{callback lux.Function}] void
+ (synchronized _jvm_this
+ (exec (if .resolved
+ (lux.Function.apply [(:! Object .datum)] callback)
+ (:! Object (java.util.List.add [callback] .waitingList)))
+ [])))
+ (#public #static make [A] [{value A}] (lux.concurrency.promise.JvmPromise A)
+ (let [container (.new! [])]
+ (exec (.resolve! (:! (host lux.concurrency.promise.JvmPromise [Unit]) container) [(:! Unit value)])
+ container))))
+
+ "The vector corresponds to parent interfaces."
+ "An optional super-class can be specified before the vector. If not specified, java.lang.Object will be assumed."
+ "Fields and methods defined in the class can be used with special syntax."
+ "For example:"
+ ".resolved, for accessing the \"resolved\" field."
+ "(:= .resolved true) for modifying it."
+ "(.new! []) for calling the class's constructor."
+ "(.resolve! container [value]) for calling the \"resolve\" method."
+ )}
+ (do Monad<Lux>
+ [current-module compiler;current-module-name
+ #let [fully-qualified-class-name (format (text;replace "/" "." current-module) "." full-class-name)
+ field-parsers (map (field->parser fully-qualified-class-name) fields)
+ method-parsers (map (method->parser (product;right class-decl) fully-qualified-class-name) methods)
+ replacer (parser->replacer (fold s;either
+ (s;fail "")
+ (List/append field-parsers method-parsers)))
+ super-class (default object-super-class super)
+ def-code (format "class:"
+ (spaced (list (class-decl$ class-decl)
+ (super-class-decl$ super-class)
+ (with-brackets (spaced (map super-class-decl$ interfaces)))
+ (inheritance-modifier$ im)
+ (with-brackets (spaced (map annotation$ annotations)))
+ (with-brackets (spaced (map field-decl$ fields)))
+ (with-brackets (spaced (map (method-def$ replacer super-class) methods))))))]]
+ (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] []))))))
+
+(syntax: #export (interface: {#let [imports (class-imports *compiler*)]}
+ {class-decl (class-decl^ imports)}
+ {#let [full-class-name (product;left class-decl)
+ imports (add-import [(short-class-name full-class-name) full-class-name]
+ (class-imports *compiler*))]}
+ {#let [class-vars (product;right class-decl)]}
+ {supers (s;tuple (s;some (super-class-decl^ imports class-vars)))}
+ {annotations (annotations^ imports)}
+ {members (s;some (method-decl^ imports class-vars))})
+ (let [def-code (format "interface:"
+ (spaced (list (class-decl$ class-decl)
+ (with-brackets (spaced (map super-class-decl$ supers)))
+ (with-brackets (spaced (map annotation$ annotations)))
+ (spaced (map method-decl$ members)))))]
+ (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] []))))
+ ))
+
+(syntax: #export (object {#let [imports (class-imports *compiler*)]}
+ {#let [class-vars (list)]}
+ {super (s;opt (super-class-decl^ imports class-vars))}
+ {interfaces (s;tuple (s;some (super-class-decl^ imports class-vars)))}
+ {constructor-args (constructor-args^ imports class-vars)}
+ {methods (s;some (overriden-method-def^ imports))})
+ {#;doc (doc "Allows defining anonymous classes."
+ "The 1st vector corresponds to parent interfaces."
+ "The 2nd vector corresponds to arguments to the super class constructor."
+ "An optional super-class can be specified before the 1st vector. If not specified, java.lang.Object will be assumed."
+ (object [java.lang.Runnable]
+ []
+ (java.lang.Runnable run [] [] void
+ (exec (do-something some-input)
+ [])))
+ )}
+ (let [super-class (default object-super-class super)
+ def-code (format "anon-class:"
+ (spaced (list (super-class-decl$ super-class)
+ (with-brackets (spaced (map super-class-decl$ interfaces)))
+ (with-brackets (spaced (map constructor-arg$ constructor-args)))
+ (with-brackets (spaced (map (method-def$ id super-class) methods))))))]
+ (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] []))))))
+
+(syntax: #export (null)
+ {#;doc (doc "Null object pointer."
+ (null))}
+ (wrap (list (` (;_lux_proc ["jvm" "null"] [])))))
+
+(def: #export (null? obj)
+ {#;doc (doc "Test for null object pointer."
+ (null? (null))
+ "=>"
+ true
+ (null? "YOLO")
+ "=>"
+ false)}
+ (-> (host java.lang.Object) Bool)
+ (;_lux_proc ["jvm" "null?"] [obj]))
+
+(syntax: #export (??? expr)
+ {#;doc (doc "Takes a (potentially null) object pointer and creates a (Maybe ObjectType) for it."
+ (??? (: java.lang.Thread (null)))
+ "=>"
+ #;None
+ (??? "YOLO")
+ "=>"
+ (#;Some "YOLO"))}
+ (with-gensyms [g!temp]
+ (wrap (list (` (let [(~ g!temp) (~ expr)]
+ (if (;_lux_proc ["jvm" "null?"] [(~ g!temp)])
+ #;None
+ (#;Some (~ g!temp)))))))))
+
+(syntax: #export (!!! expr)
+ {#;doc (doc "Takes a (Maybe ObjectType) and return a ObjectType."
+ "A #;None would gets translated in to a (null)."
+ "Takes a (potentially null) object pointer and creates a (Maybe ObjectType) for it."
+ (!!! (??? (: java.lang.Thread (null))))
+ "=>"
+ (null)
+ (!!! (??? "YOLO"))
+ "=>"
+ "YOLO")}
+ (with-gensyms [g!value]
+ (wrap (list (` (;_lux_case (~ expr)
+ (#;Some (~ g!value))
+ (~ g!value)
+
+ #;None
+ (;_lux_proc ["jvm" "null"] [])))))))
+
+(syntax: #export (try expr)
+ {#;doc (doc "Covers the expression in a try-catch block."
+ "If it succeeds, you get (#;Right result)."
+ "If it fails, you get (#;Left error+stack-traces-as-text)."
+ (try (risky-computation input)))}
+ (wrap (list (`' (_lux_proc ["jvm" "try"]
+ [(#;Right (~ expr))
+ ;;throwable->text])))))
+
+(syntax: #export (instance? {#let [imports (class-imports *compiler*)]}
+ {class (generic-type^ imports (list))}
+ obj)
+ {#;doc (doc "Checks whether an object is an instance of a particular class."
+ "Caveat emptor: Can't check for polymorphism, so avoid using parameterized classes."
+ (instance? String "YOLO"))}
+ (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ obj)])))))
+
+(syntax: #export (synchronized lock body)
+ {#;doc (doc "Evaluates body, while holding a lock on a given object."
+ (synchronized object-to-be-locked
+ (exec (do-something ...)
+ (do-something-else ...)
+ (finish-the-computation ...))))}
+ (wrap (list (` (;_lux_proc ["jvm" "synchronized"] [(~ lock) (~ body)]))))
+ ## (with-gensyms [g!lock g!body g!_ g!e]
+ ## (wrap (list (` (let [(~ g!lock) (~ lock)
+ ## (~ g!_) (;_lux_proc ["jvm" "monitorenter"] [(~ g!lock)])
+ ## (~ g!body) (~ body)
+ ## (~ g!_) (;_lux_proc ["jvm" "monitorexit"] [(~ g!lock)])]
+ ## (~ g!body)))))
+ ## )
+ )
+
+(syntax: #export (do-to obj {methods (s;some partial-call^)})
+ {#;doc (doc "Call a variety of methods on an object; then return the object."
+ (do-to vreq
+ (HttpServerRequest.setExpectMultipart [true])
+ (ReadStream.handler [(object [(Handler Buffer)]
+ []
+ ((Handler A) handle [] [(buffer A)] void
+ (io;run (do Monad<IO>
+ [_ (write (Buffer.getBytes [] buffer) body)]
+ (wrap []))))
+ )])
+ (ReadStream.endHandler [[(object [(Handler Void)]
+ []
+ ((Handler A) handle [] [(_ A)] void
+ (exec (do Monad<Promise>
+ [#let [_ (io;run (close body))]
+ response (handler (request$ vreq body))]
+ (respond! response vreq))
+ []))
+ )]])))}
+ (with-gensyms [g!obj]
+ (wrap (list (` (let [(~ g!obj) (~ obj)]
+ (exec (~@ (map (complete-call$ g!obj) methods))
+ (~ g!obj))))))))
+
+(def: (class-import$ long-name? [full-name params])
+ (-> Bool ClassDecl AST)
+ (let [def-name (if long-name?
+ full-name
+ (short-class-name full-name))]
+ (case params
+ #;Nil
+ (` (def: (~ (ast;symbol ["" def-name]))
+ {#;type? true
+ #;;jvm-class (~ (ast;text full-name))}
+ Type
+ (host (~ (ast;symbol ["" full-name])))))
+
+ (#;Cons _)
+ (let [params' (map (lambda [[p _]] (ast;symbol ["" p])) params)]
+ (` (def: (~ (ast;symbol ["" def-name]))
+ {#;type? true
+ #;;jvm-class (~ (ast;text full-name))}
+ Type
+ (All [(~@ params')]
+ (host (~ (ast;symbol ["" full-name]))
+ [(~@ params')]))))))))
+
+(def: (member-type-vars class-tvars member)
+ (-> (List TypeParam) ImportMemberDecl (List TypeParam))
+ (case member
+ (#ConstructorDecl [commons _])
+ (List/append class-tvars (get@ #import-member-tvars commons))
+
+ (#MethodDecl [commons _])
+ (case (get@ #import-member-kind commons)
+ #StaticIMK
+ (get@ #import-member-tvars commons)
+
+ _
+ (List/append class-tvars (get@ #import-member-tvars commons)))
+
+ _
+ class-tvars))
+
+(def: (member-def-arg-bindings type-params class member)
+ (-> (List TypeParam) ClassDecl ImportMemberDecl (Lux [(List AST) (List AST) (List Text) (List AST)]))
+ (case member
+ (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
+ (let [(^slots [#import-member-tvars #import-member-args]) commons]
+ (do Monad<Lux>
+ [arg-inputs (mapM @
+ (: (-> [Bool GenericType] (Lux [AST AST]))
+ (lambda [[maybe? _]]
+ (with-gensyms [arg-name]
+ (wrap [arg-name (if maybe?
+ (` (!!! (~ arg-name)))
+ arg-name)]))))
+ import-member-args)
+ #let [arg-classes (: (List Text)
+ (map (. (simple-class$ (List/append type-params import-member-tvars)) product;right)
+ import-member-args))
+ arg-types (map (: (-> [Bool GenericType] AST)
+ (lambda [[maybe? arg]]
+ (let [arg-type (class->type (get@ #import-member-mode commons) type-params arg)]
+ (if maybe?
+ (` (Maybe (~ arg-type)))
+ arg-type))))
+ import-member-args)
+ arg-lambda-inputs (map product;left arg-inputs)
+ arg-method-inputs (map product;right arg-inputs)]]
+ (wrap [arg-lambda-inputs arg-method-inputs arg-classes arg-types])))
+
+ _
+ (:: Monad<Lux> wrap [(list) (list) (list) (list)])))
+
+(def: (member-def-return mode type-params class member)
+ (-> Primitive-Mode (List TypeParam) ClassDecl ImportMemberDecl (Lux AST))
+ (case member
+ (#ConstructorDecl _)
+ (:: Monad<Lux> wrap (class-decl-type$ class))
+
+ (#MethodDecl [_ method])
+ (:: Monad<Lux> wrap (class->type mode type-params (get@ #import-method-return method)))
+
+ _
+ (compiler;fail "Only methods have return values.")))
+
+(def: (decorate-return-maybe member [return-type return-term])
+ (-> ImportMemberDecl [AST AST] [AST AST])
+ (case member
+ (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
+ (if (get@ #import-member-maybe? commons)
+ [(` (Maybe (~ return-type)))
+ (` (??? (~ return-term)))]
+ [return-type
+ (let [g!temp (ast;symbol ["" "Ω"])]
+ (` (let [(~ g!temp) (~ return-term)]
+ (if (null? (:! (host (~' java.lang.Object))
+ (~ g!temp)))
+ (error! "Can't produce null pointers from method calls.")
+ (~ g!temp)))))])
+
+ _
+ [return-type return-term]))
+
+(do-template [<name> <tag> <type-trans> <term-trans>]
+ [(def: (<name> member [return-type return-term])
+ (-> ImportMemberDecl [AST AST] [AST AST])
+ (case member
+ (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
+ (if (get@ <tag> commons)
+ [<type-trans> <term-trans>]
+ [return-type return-term])
+
+ _
+ [return-type return-term]))]
+
+ [decorate-return-try #import-member-try? (` (Either Text (~ return-type))) (` (try (~ return-term)))]
+ [decorate-return-io #import-member-io? (` (IO (~ return-type))) (` (io (~ return-term)))]
+ )
+
+(def: (free-type-param? [name bounds])
+ (-> TypeParam Bool)
+ (case bounds
+ #;Nil true
+ _ false))
+
+(def: (type-param->type-arg [name _])
+ (-> TypeParam AST)
+ (ast;symbol ["" name]))
+
+(def: (with-mode-output mode output-type body)
+ (-> Primitive-Mode GenericType AST AST)
+ (case mode
+ #ManualPrM
+ body
+
+ #AutoPrM
+ (case output-type
+ (#GenericClass ["byte" _])
+ (` (b2l (~ body)))
+
+ (#GenericClass ["short" _])
+ (` (s2l (~ body)))
+
+ (#GenericClass ["int" _])
+ (` (i2l (~ body)))
+
+ (#GenericClass ["float" _])
+ (` (f2d (~ body)))
+
+ _
+ body)))
+
+(def: (auto-conv-class? class)
+ (-> Text Bool)
+ (case class
+ (^or "byte" "short" "int" "float")
+ true
+
+ _
+ false))
+
+(def: (auto-conv [class var])
+ (-> [Text AST] (List AST))
+ (case class
+ "byte" (list var (` (l2b (~ var))))
+ "short" (list var (` (l2s (~ var))))
+ "int" (list var (` (l2i (~ var))))
+ "float" (list var (` (d2f (~ var))))
+ _ (list)))
+
+(def: (with-mode-inputs mode inputs body)
+ (-> Primitive-Mode (List [Text AST]) AST AST)
+ (case mode
+ #ManualPrM
+ body
+
+ #AutoPrM
+ (` (let [(~@ (|> inputs
+ (List/map auto-conv)
+ List/join))]
+ (~ body)))))
+
+(def: (with-mode-field-get mode class output)
+ (-> Primitive-Mode GenericType AST AST)
+ (case mode
+ #ManualPrM
+ output
+
+ #AutoPrM
+ (case (simple-class$ (list) class)
+ "byte" (` (b2l (~ output)))
+ "short" (` (s2l (~ output)))
+ "int" (` (i2l (~ output)))
+ "float" (` (f2d (~ output)))
+ _ output)))
+
+(def: (with-mode-field-set mode class input)
+ (-> Primitive-Mode GenericType AST AST)
+ (case mode
+ #ManualPrM
+ input
+
+ #AutoPrM
+ (case (simple-class$ (list) class)
+ "byte" (` (l2b (~ input)))
+ "short" (` (l2s (~ input)))
+ "int" (` (l2i (~ input)))
+ "float" (` (d2f (~ input)))
+ _ input)))
+
+(def: (member-def-interop type-params kind class [arg-lambda-inputs arg-method-inputs arg-classes arg-types] member method-prefix)
+ (-> (List TypeParam) ClassKind ClassDecl [(List AST) (List AST) (List Text) (List AST)] ImportMemberDecl Text (Lux (List AST)))
+ (let [[full-name class-tvars] class
+ all-params (|> (member-type-vars class-tvars member)
+ (filter free-type-param?)
+ (map type-param->type-arg))]
+ (case member
+ (#EnumDecl enum-members)
+ (do Monad<Lux>
+ [#let [enum-type (: AST
+ (case class-tvars
+ #;Nil
+ (` (host (~ (ast;symbol ["" full-name]))))
+
+ _
+ (let [=class-tvars (|> class-tvars
+ (filter free-type-param?)
+ (map type-param->type-arg))]
+ (` (All [(~@ =class-tvars)] (host (~ (ast;symbol ["" full-name])) [(~@ =class-tvars)]))))))
+ getter-interop (: (-> Text AST)
+ (lambda [name]
+ (let [getter-name (ast;symbol ["" (format method-prefix member-separator name)])]
+ (` (def: (~ getter-name)
+ (~ enum-type)
+ (;_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" full-name ":" name)))] []))))))]]
+ (wrap (map getter-interop enum-members)))
+
+ (#ConstructorDecl [commons _])
+ (do Monad<Lux>
+ [return-type (member-def-return (get@ #import-member-mode commons) type-params class member)
+ #let [def-name (ast;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))])
+ def-params (list (ast;tuple arg-lambda-inputs))
+ jvm-interop (|> (` (;_lux_proc ["jvm" (~ (ast;text (format "new" ":" full-name ":" (text;join-with "," arg-classes))))]
+ [(~@ arg-method-inputs)]))
+ (with-mode-inputs (get@ #import-member-mode commons)
+ (list;zip2 arg-classes arg-lambda-inputs)))
+ [return-type jvm-interop] (|> [return-type jvm-interop]
+ (decorate-return-maybe member)
+ (decorate-return-try member)
+ (decorate-return-io member))]]
+ (wrap (list (` (def: ((~ def-name) (~@ def-params))
+ (All [(~@ all-params)] (-> [(~@ arg-types)] (~ return-type)))
+ (~ jvm-interop))))))
+
+ (#MethodDecl [commons method])
+ (with-gensyms [g!obj]
+ (do @
+ [return-type (member-def-return (get@ #import-member-mode commons) type-params class member)
+ #let [def-name (ast;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))])
+ (^slots [#import-member-kind]) commons
+ (^slots [#import-method-name]) method
+ [jvm-op obj-ast class-ast] (: [Text (List AST) (List AST)]
+ (case import-member-kind
+ #StaticIMK
+ ["invokestatic"
+ (list)
+ (list)]
+
+ #VirtualIMK
+ (case kind
+ #Class
+ ["invokevirtual"
+ (list g!obj)
+ (list (class-decl-type$ class))]
+
+ #Interface
+ ["invokeinterface"
+ (list g!obj)
+ (list (class-decl-type$ class))]
+ )))
+ def-params (#;Cons (ast;tuple arg-lambda-inputs) obj-ast)
+ def-param-types (#;Cons (` [(~@ arg-types)]) class-ast)
+ jvm-interop (|> (` (;_lux_proc ["jvm" (~ (ast;text (format jvm-op ":" full-name ":" import-method-name
+ ":" (text;join-with "," arg-classes))))]
+ [(~@ obj-ast) (~@ arg-method-inputs)]))
+ (with-mode-output (get@ #import-member-mode commons)
+ (get@ #import-method-return method))
+ (with-mode-inputs (get@ #import-member-mode commons)
+ (list;zip2 arg-classes arg-lambda-inputs)))
+ [return-type jvm-interop] (|> [return-type jvm-interop]
+ (decorate-return-maybe member)
+ (decorate-return-try member)
+ (decorate-return-io member))]]
+ (wrap (list (` (def: ((~ def-name) (~@ def-params))
+ (All [(~@ all-params)] (-> (~@ def-param-types) (~ return-type)))
+ (~ jvm-interop)))))))
+
+ (#FieldAccessDecl fad)
+ (do Monad<Lux>
+ [#let [(^open) fad
+ base-gtype (class->type import-field-mode type-params import-field-type)
+ g!class (class-decl-type$ class)
+ g!type (if import-field-maybe?
+ (` (Maybe (~ base-gtype)))
+ base-gtype)
+ tvar-asts (: (List AST)
+ (|> class-tvars
+ (filter free-type-param?)
+ (map type-param->type-arg)))
+ getter-name (ast;symbol ["" (format method-prefix member-separator import-field-name)])
+ setter-name (ast;symbol ["" (format method-prefix member-separator import-field-name "!")])]
+ getter-interop (with-gensyms [g!obj]
+ (let [getter-call (if import-field-static?
+ getter-name
+ (` ((~ getter-name) (~ g!obj))))
+ getter-type (if import-field-setter?
+ (` (IO (~ g!type)))
+ g!type)
+ getter-type (if import-field-static?
+ getter-type
+ (` (-> (~ g!class) (~ getter-type))))
+ getter-type (` (All [(~@ tvar-asts)] (~ getter-type)))
+ getter-body (if import-field-static?
+ (with-mode-field-get import-field-mode import-field-type
+ (` (;_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" full-name ":" import-field-name)))] [])))
+ (with-mode-field-get import-field-mode import-field-type
+ (` (;_lux_proc ["jvm" (~ (ast;text (format "getfield" ":" full-name ":" import-field-name)))] [(~ g!obj)]))))
+ getter-body (if import-field-maybe?
+ (` (??? (~ getter-body)))
+ getter-body)
+ getter-body (if import-field-setter?
+ (` (io (~ getter-body)))
+ getter-body)]
+ (wrap (` (def: (~ getter-call)
+ (~ getter-type)
+ (~ getter-body))))))
+ setter-interop (if import-field-setter?
+ (with-gensyms [g!obj g!value]
+ (let [setter-call (if import-field-static?
+ (` ((~ setter-name) (~ g!value)))
+ (` ((~ setter-name) (~ g!value) (~ g!obj))))
+ setter-type (if import-field-static?
+ (` (All [(~@ tvar-asts)] (-> (~ g!type) (IO Unit))))
+ (` (All [(~@ tvar-asts)] (-> (~ g!type) (~ g!class) (IO Unit)))))
+ setter-value (with-mode-field-set import-field-mode import-field-type g!value)
+ setter-value (if import-field-maybe?
+ (` (!!! (~ setter-value)))
+ setter-value)
+ setter-command (format (if import-field-static? "putstatic" "putfield")
+ ":" full-name ":" import-field-name)]
+ (wrap (: (List AST)
+ (list (` (def: (~ setter-call)
+ (~ setter-type)
+ (io (;_lux_proc ["jvm" (~ (ast;text setter-command))]
+ [(~ setter-value)])))))))))
+ (wrap (list)))]
+ (wrap (list& getter-interop setter-interop)))
+ )))
+
+(def: (member-import$ type-params long-name? kind class member)
+ (-> (List TypeParam) Bool ClassKind ClassDecl ImportMemberDecl (Lux (List AST)))
+ (let [[full-name _] class
+ method-prefix (if long-name?
+ full-name
+ (short-class-name full-name))]
+ (do Monad<Lux>
+ [=args (member-def-arg-bindings type-params class member)]
+ (member-def-interop type-params kind class =args member method-prefix))))
+
+(def: (interface? class)
+ (All [a] (-> (host java.lang.Class [a]) Bool))
+ (_lux_proc ["jvm" "invokevirtual:java.lang.Class:isInterface:"] [class]))
+
+(def: (load-class class-name)
+ (-> Text (Either Text (host java.lang.Class [(Ex [a] a)])))
+ (try (_lux_proc ["jvm" "invokestatic:java.lang.Class:forName:java.lang.String"] [class-name])))
+
+(def: (class-kind [class-name _])
+ (-> ClassDecl (Lux ClassKind))
+ (case (load-class class-name)
+ (#;Right class)
+ (:: Monad<Lux> wrap (if (interface? class)
+ #Interface
+ #Class))
+
+ (#;Left _)
+ (compiler;fail (format "Unknown class: " class-name))))
+
+(syntax: #export (jvm-import {#let [imports (class-imports *compiler*)]}
+ {long-name? (s;tag? ["" "long"])}
+ {class-decl (class-decl^ imports)}
+ {#let [full-class-name (product;left class-decl)
+ imports (add-import [(short-class-name full-class-name) full-class-name]
+ (class-imports *compiler*))]}
+ {members (s;some (import-member-decl^ imports (product;right class-decl)))})
+ {#;doc (doc "Allows importing JVM classes, and using them as types."
+ "Their methods, fields and enum options can also be imported."
+ "Also, classes which get imported into a module can also be referred-to with their short names in other macros that require JVM classes."
+ "Examples:"
+ (jvm-import java.lang.Object
+ (new [] [])
+ (equals [] [Object] boolean)
+ (wait [] [int] #io #try void))
+ "Special options can also be given for the return values."
+ "#? means that the values will be returned inside a Maybe type. That way, null becomes #;None."
+ "#try means that the computation might throw an exception, and the return value will be wrapped by the Error type."
+ "#io means the computation has side effects, and will be wrapped by the IO type."
+ "These options must show up in the following order [#io #try #?] (although, each option can be used independently)."
+ (jvm-import java.lang.String
+ (new [] [(Array byte)])
+ (#static valueOf [] [char] String)
+ (#static valueOf #as int-valueOf [] [int] String))
+
+ (jvm-import #long (java.util.List e)
+ (size [] [] int)
+ (get [] [int] e))
+
+ (jvm-import (java.util.ArrayList a)
+ (toArray [T] [(Array T)] (Array T)))
+ "#long makes it so the class-type that is generated is of the fully-qualified name."
+ "In this case, it avoids a clash between the java.util.List type, and Lux's own List type."
+ (jvm-import java.lang.Character$UnicodeScript
+ (#enum ARABIC CYRILLIC LATIN))
+ "All enum options to be imported must be specified."
+
+ (jvm-import #long (lux.concurrency.promise.JvmPromise A)
+ (resolve [] [A] boolean)
+ (poll [] [] A)
+ (wasResolved [] [] boolean)
+ (waitOn [] [lux.Function] void)
+ (#static make [A] [A] (JvmPromise A)))
+ "It should also be noted, the only types that may show up in method arguments or return values may be Java classes, arrays, primitives, void or type-parameters."
+ "Lux types, such as Maybe can't be named (otherwise, they'd be confused for Java classes)."
+
+ "Also, the names of the imported members will look like ClassName.MemberName."
+ "E.g.:"
+ (Object.new [])
+ (Object.equals [other-object] my-object)
+ (java.util.List.size [] my-list)
+ Character$UnicodeScript.LATIN
+ )}
+ (do Monad<Lux>
+ [kind (class-kind class-decl)
+ =members (mapM @ (member-import$ (product;right class-decl) long-name? kind class-decl) members)]
+ (wrap (list& (class-import$ long-name? class-decl) (List/join =members)))))
+
+(syntax: #export (array {#let [imports (class-imports *compiler*)]}
+ {type (generic-type^ imports (list))}
+ size)
+ {#;doc (doc "Create an array of the given type, with the given size."
+ (array Object +10))}
+ (case type
+ (^template [<type> <array-op>]
+ (^ (#GenericClass <type> (list)))
+ (wrap (list (` (;_lux_proc ["jvm" <array-op>] [(~ size)])))))
+ (["boolean" "znewarray"]
+ ["byte" "bnewarray"]
+ ["short" "snewarray"]
+ ["int" "inewarray"]
+ ["long" "lnewarray"]
+ ["float" "fnewarray"]
+ ["double" "dnewarray"]
+ ["char" "cnewarray"])
+
+ _
+ (wrap (list (` (;_lux_proc ["jvm" "anewarray"] [(~ (ast;text (generic-type$ type))) (~ size)]))))))
+
+(syntax: #export (array-length array)
+ {#;doc (doc "Gives the length of an array."
+ (array-length my-array))}
+ (wrap (list (` (;_lux_proc ["jvm" "arraylength"] [(~ array)])))))
+
+(def: (type->class-name type)
+ (-> Type (Lux Text))
+ (case type
+ (#;HostT name params)
+ (:: Monad<Lux> wrap name)
+
+ (#;AppT F A)
+ (case (type;apply-type F A)
+ #;None
+ (compiler;fail (format "Can't apply type: " (type;type-to-text F) " to " (type;type-to-text A)))
+
+ (#;Some type')
+ (type->class-name type'))
+
+ (#;NamedT _ type')
+ (type->class-name type')
+
+ #;UnitT
+ (:: Monad<Lux> wrap "java.lang.Object")
+
+ (^or #;VoidT (#;VarT _) (#;ExT _) (#;BoundT _) (#;SumT _) (#;ProdT _) (#;LambdaT _) (#;UnivQ _) (#;ExQ _))
+ (compiler;fail (format "Can't convert to JvmType: " (type;type-to-text type)))
+ ))
+
+(syntax: #export (array-load idx array)
+ {#;doc (doc "Loads an element from an array."
+ (array-load 10 my-array))}
+ (case array
+ [_ (#;SymbolS array-name)]
+ (do Monad<Lux>
+ [array-type (compiler;find-type array-name)
+ array-jvm-type (type->class-name array-type)]
+ (case array-jvm-type
+ (^template [<type> <array-op>]
+ <type>
+ (wrap (list (` (;_lux_proc ["jvm" <array-op>] [(~ array) (~ idx)])))))
+ (["[Z" "zaload"]
+ ["[B" "baload"]
+ ["[S" "saload"]
+ ["[I" "iaload"]
+ ["[J" "jaload"]
+ ["[F" "faload"]
+ ["[D" "daload"]
+ ["[C" "caload"])
+
+ _
+ (wrap (list (` (;_lux_proc ["jvm" "aaload"] [(~ array) (~ idx)]))))))
+
+ _
+ (with-gensyms [g!array]
+ (wrap (list (` (let [(~ g!array) (~ array)]
+ (;;array-load (~ g!array) (~ idx)))))))))
+
+(syntax: #export (array-store idx value array)
+ {#;doc (doc "Stores an element into an array."
+ (array-store 10 my-object my-array))}
+ (case array
+ [_ (#;SymbolS array-name)]
+ (do Monad<Lux>
+ [array-type (compiler;find-type array-name)
+ array-jvm-type (type->class-name array-type)]
+ (case array-jvm-type
+ (^template [<type> <array-op>]
+ <type>
+ (wrap (list (` (;_lux_proc ["jvm" <array-op>] [(~ array) (~ idx) (~ value)])))))
+ (["[Z" "zastore"]
+ ["[B" "bastore"]
+ ["[S" "sastore"]
+ ["[I" "iastore"]
+ ["[J" "jastore"]
+ ["[F" "fastore"]
+ ["[D" "dastore"]
+ ["[C" "castore"])
+
+ _
+ (wrap (list (` (;_lux_proc ["jvm" "aastore"] [(~ array) (~ idx) (~ value)]))))))
+
+ _
+ (with-gensyms [g!array]
+ (wrap (list (` (let [(~ g!array) (~ array)]
+ (;;array-store (~ g!array) (~ idx) (~ value)))))))))
+
+(def: simple-bindings^
+ (Syntax (List [Text AST]))
+ (s;tuple (s;some (s;seq s;local-symbol s;any))))
+
+(syntax: #export (with-open {bindings simple-bindings^} body)
+ {#;doc (doc "Creates a local-binding with the desired resources, and runs the body (assumed to be in the IO type)."
+ "Afterwards, closes all resources (assumed to be subclasses of java.io.Closeable), and returns the value resulting from running the body."
+ (with-open [my-res1 (res1-constructor ...)
+ my-res2 (res1-constructor ...)]
+ (do Monad<IO>
+ [foo (do-something my-res1)
+ bar (do-something-else my-res2)]
+ (do-one-last-thing foo bar))))}
+ (with-gensyms [g!output g!_]
+ (let [inits (List/join (List/map (lambda [[res-name res-ctor]]
+ (list (ast;symbol ["" res-name]) res-ctor))
+ bindings))
+ closes (List/map (lambda [res]
+ (` (try (;_lux_proc ["jvm" "invokevirtual:java.io.Closeable:close:"]
+ [(~ (ast;symbol ["" (product;left res)]))]))))
+ bindings)]
+ (wrap (list (` (do Monad<IO>
+ [(~@ inits)
+ (~ g!output) (~ body)
+ (~' #let) [(~ g!_) (exec (~@ (reverse closes)) [])]]
+ ((~' wrap) (~ g!output)))))))))
+
+(syntax: #export (class-for {#let [imports (class-imports *compiler*)]}
+ {type (generic-type^ imports (list))})
+ {#;doc (doc "Loads the class a a Class object."
+ (class-for java.lang.String))}
+ (wrap (list (` (;_lux_proc ["jvm" "load-class"] [(~ (ast;text (simple-class$ (list) type)))])))))
diff --git a/stdlib/source/lux/lexer.lux b/stdlib/source/lux/lexer.lux
new file mode 100644
index 000000000..654259d8d
--- /dev/null
+++ b/stdlib/source/lux/lexer.lux
@@ -0,0 +1,439 @@
+## 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/.
+
+(;module:
+ [lux #- not]
+ (lux (control functor
+ applicative
+ monad
+ codec)
+ (data [text "Text/" Eq<Text>]
+ text/format
+ [number "Int/" Codec<Text,Int>]
+ [product]
+ [char "Char/" Ord<Char>]
+ maybe
+ error
+ (struct [list "" Functor<List>]))
+ host))
+
+## [Types]
+(type: #export (Lexer a)
+ (-> Text (Error [Text a])))
+
+## [Structures]
+(struct: #export _ (Functor Lexer)
+ (def: (map f fa)
+ (lambda [input]
+ (case (fa input)
+ (#;Left msg) (#;Left msg)
+ (#;Right [input' output]) (#;Right [input' (f output)])))))
+
+(struct: #export _ (Applicative Lexer)
+ (def: functor Functor<Lexer>)
+
+ (def: (wrap a)
+ (lambda [input]
+ (#;Right [input a])))
+
+ (def: (apply ff fa)
+ (lambda [input]
+ (case (ff input)
+ (#;Right [input' f])
+ (case (fa input')
+ (#;Right [input'' a])
+ (#;Right [input'' (f a)])
+
+ (#;Left msg)
+ (#;Left msg))
+
+ (#;Left msg)
+ (#;Left msg)))))
+
+(struct: #export _ (Monad Lexer)
+ (def: applicative Applicative<Lexer>)
+
+ (def: (join mma)
+ (lambda [input]
+ (case (mma input)
+ (#;Left msg) (#;Left msg)
+ (#;Right [input' ma]) (ma input'))))
+ )
+
+## [Values]
+## Runner
+(def: #export (run' lexer input)
+ (All [a] (-> (Lexer a) Text (Error [Text a])))
+ (lexer input))
+
+(def: #export (run lexer input)
+ (All [a] (-> (Lexer a) Text (Error a)))
+ (case (lexer input)
+ (#;Left msg)
+ (#;Left msg)
+
+ (#;Right [input' output])
+ (#;Right output)
+ ))
+
+## Combinators
+(def: #export (fail message)
+ (All [a] (-> Text (Lexer a)))
+ (lambda [input]
+ (#;Left message)))
+
+(def: #export any
+ (Lexer Char)
+ (lambda [input]
+ (case [(text;at +0 input) (text;split +1 input)]
+ [(#;Some output) (#;Some [_ input'])]
+ (#;Right [input' output])
+
+ _
+ (#;Left "Can't parse character from empty text."))
+ ))
+
+(def: #export (seq left right)
+ (All [a b] (-> (Lexer a) (Lexer b) (Lexer [a b])))
+ (do Monad<Lexer>
+ [=left left
+ =right right]
+ (wrap [=left =right])))
+
+(def: #export (alt left right)
+ (All [a b] (-> (Lexer a) (Lexer b) (Lexer (| a b))))
+ (lambda [input]
+ (case (left input)
+ (#;Left msg)
+ (case (right input)
+ (#;Left msg)
+ (#;Left msg)
+
+ (#;Right [input' output])
+ (#;Right [input' (+1 output)]))
+
+ (#;Right [input' output])
+ (#;Right [input' (+0 output)]))))
+
+(def: #export (not! p)
+ (All [a] (-> (Lexer a) (Lexer Unit)))
+ (lambda [input]
+ (case (p input)
+ (#;Left msg)
+ (#;Right [input []])
+
+ _
+ (#;Left "Expected to fail; yet succeeded."))))
+
+(def: #export (not p)
+ (All [a] (-> (Lexer a) (Lexer Char)))
+ (lambda [input]
+ (case (p input)
+ (#;Left msg)
+ (any input)
+
+ _
+ (#;Left "Expected to fail; yet succeeded."))))
+
+(def: #export (either left right)
+ (All [a] (-> (Lexer a) (Lexer a) (Lexer a)))
+ (lambda [input]
+ (case (left input)
+ (#;Left msg)
+ (right input)
+
+ output
+ output)))
+
+(def: #export (assert test message)
+ (-> Bool Text (Lexer Unit))
+ (lambda [input]
+ (if test
+ (#;Right [input []])
+ (#;Left message))))
+
+(def: #export (some p)
+ (All [a] (-> (Lexer a) (Lexer (List a))))
+ (lambda [input]
+ (case (p input)
+ (#;Left msg)
+ (#;Right [input (list)])
+
+ (#;Right [input' x])
+ (run' (do Monad<Lexer>
+ [xs (some p)]
+ (wrap (#;Cons x xs)))
+ input'))
+ ))
+
+(def: #export (many p)
+ (All [a] (-> (Lexer a) (Lexer (List a))))
+ (do Monad<Lexer>
+ [x p
+ xs (some p)]
+ (wrap (#;Cons x xs))))
+
+(def: #export (exactly n p)
+ (All [a] (-> Nat (Lexer a) (Lexer (List a))))
+ (if (>+ +0 n)
+ (do Monad<Lexer>
+ [x p
+ xs (exactly (dec+ n) p)]
+ (wrap (#;Cons x xs)))
+ (:: Monad<Lexer> wrap (list))))
+
+(def: #export (at-most n p)
+ (All [a] (-> Nat (Lexer a) (Lexer (List a))))
+ (if (>+ +0 n)
+ (lambda [input]
+ (case (p input)
+ (#;Left msg)
+ (#;Right [input (list)])
+
+ (#;Right [input' x])
+ (run' (do Monad<Lexer>
+ [xs (at-most (dec+ n) p)]
+ (wrap (#;Cons x xs)))
+ input')
+ ))
+ (:: Monad<Lexer> wrap (list))))
+
+(def: #export (at-least n p)
+ (All [a] (-> Nat (Lexer a) (Lexer (List a))))
+ (do Monad<Lexer>
+ [min-xs (exactly n p)
+ extras (some p)]
+ (wrap (list;concat (list min-xs extras)))))
+
+(def: #export (between from to p)
+ (All [a] (-> Nat Nat (Lexer a) (Lexer (List a))))
+ (do Monad<Lexer>
+ [min-xs (exactly from p)
+ max-xs (at-most (-+ from to) p)]
+ (wrap (list;concat (list min-xs max-xs)))))
+
+(def: #export (opt p)
+ (All [a] (-> (Lexer a) (Lexer (Maybe a))))
+ (lambda [input]
+ (case (p input)
+ (#;Left msg)
+ (#;Right [input #;None])
+
+ (#;Right [input value])
+ (#;Right [input (#;Some value)])
+ )))
+
+(def: #export (this text)
+ (-> Text (Lexer Text))
+ (lambda [input]
+ (if (text;starts-with? text input)
+ (case (text;split (text;size text) input)
+ #;None (#;Left "")
+ (#;Some [_ input']) (#;Right [input' text]))
+ (#;Left (format "Invalid match: " text " @ " (:: text;Codec<Text,Text> encode input))))
+ ))
+
+(def: #export (sep-by sep p)
+ (All [a b] (-> (Lexer b) (Lexer a) (Lexer (List a))))
+ (do Monad<Lexer>
+ [?x (opt p)]
+ (case ?x
+ #;None
+ (wrap #;Nil)
+
+ (#;Some x)
+ (do @
+ [xs' (some (seq sep p))]
+ (wrap (#;Cons x (map product;right xs'))))
+ )))
+
+(def: #export end
+ (Lexer Unit)
+ (lambda [input]
+ (case input
+ "" (#;Right [input []])
+ _ (#;Left (format "The text input has not been fully consumed @ " (:: text;Codec<Text,Text> encode input)))
+ )))
+
+(def: #export peek
+ (Lexer Char)
+ (lambda [input]
+ (case (text;at +0 input)
+ (#;Some output)
+ (#;Right [input output])
+
+ _
+ (#;Left "Can't peek character from empty text."))
+ ))
+
+(def: #export (this-char char)
+ (-> Char (Lexer Char))
+ (lambda [input]
+ (case [(text;at +0 input) (text;split +1 input)]
+ [(#;Some char') (#;Some [_ input'])]
+ (if (Char/= char char')
+ (#;Right [input' char])
+ (#;Left (format "Expected " (:: char;Codec<Text,Char> encode char) " @ " (:: text;Codec<Text,Text> encode input)
+ " " (Int/encode (c2l char))" " (Int/encode (c2l [char'])))))
+
+ _
+ (#;Left "Can't parse character from empty text."))
+ ))
+
+(def: #export get-input
+ (Lexer Text)
+ (lambda [input]
+ (#;Right [input input])))
+
+(def: #export (char-range bottom top)
+ (-> Char Char (Lexer Char))
+ (do Monad<Lexer>
+ [input get-input
+ char any
+ _ (assert (and (Char/>= bottom char)
+ (Char/<= top char))
+ (format "Character is not within range: " (:: char;Codec<Text,Char> encode bottom) "-" (:: char;Codec<Text,Char> encode top) " @ " (:: text;Codec<Text,Text> encode input)))]
+ (wrap char)))
+
+(do-template [<name> <bottom> <top>]
+ [(def: #export <name>
+ (Lexer Char)
+ (char-range <bottom> <top>))]
+
+ [upper #"A" #"Z"]
+ [lower #"a" #"z"]
+ [digit #"0" #"9"]
+ [oct-digit #"0" #"7"]
+ )
+
+(def: #export alpha
+ (Lexer Char)
+ (either lower upper))
+
+(def: #export alpha-num
+ (Lexer Char)
+ (either alpha digit))
+
+(def: #export hex-digit
+ (Lexer Char)
+ ($_ either
+ digit
+ (char-range #"a" #"f")
+ (char-range #"A" #"F")))
+
+(def: #export (one-of options)
+ (-> Text (Lexer Char))
+ (lambda [input]
+ (case (text;split +1 input)
+ (#;Some [init input'])
+ (if (text;contains? init options)
+ (case (text;at +0 init)
+ (#;Some output)
+ (#;Right [input' output])
+
+ _
+ (#;Left ""))
+ (#;Left (format "Character (" init ") is not one of: " options " @ " (:: text;Codec<Text,Text> encode input))))
+
+ _
+ (#;Left "Can't parse character from empty text."))))
+
+(def: #export (none-of options)
+ (-> Text (Lexer Char))
+ (lambda [input]
+ (case (text;split +1 input)
+ (#;Some [init input'])
+ (if (;not (text;contains? init options))
+ (case (text;at +0 init)
+ (#;Some output)
+ (#;Right [input' output])
+
+ _
+ (#;Left ""))
+ (#;Left (format "Character (" init ") is one of: " options " @ " (:: text;Codec<Text,Text> encode input))))
+
+ _
+ (#;Left "Can't parse character from empty text."))))
+
+(def: #export (satisfies p)
+ (-> (-> Char Bool) (Lexer Char))
+ (lambda [input]
+ (case (: (Maybe [Text Char])
+ (do Monad<Maybe>
+ [[init input'] (text;split +1 input)
+ output (text;at +0 init)]
+ (wrap [input' output])))
+ (#;Some [input' output])
+ (if (p output)
+ (#;Right [input' output])
+ (#;Left (format "Character does not satisfy predicate: " (:: text;Codec<Text,Text> encode input))))
+
+ _
+ (#;Left "Can't parse character from empty text."))))
+
+(def: #export space
+ (Lexer Char)
+ (satisfies char;space?))
+
+(def: #export (some' p)
+ (-> (Lexer Char) (Lexer Text))
+ (do Monad<Lexer>
+ [cs (some p)]
+ (wrap (text;concat (map char;as-text cs)))))
+
+(def: #export (many' p)
+ (-> (Lexer Char) (Lexer Text))
+ (do Monad<Lexer>
+ [cs (many p)]
+ (wrap (text;concat (map char;as-text cs)))))
+
+(def: #export end?
+ (Lexer Bool)
+ (lambda [input]
+ (#;Right [input (text;empty? input)])))
+
+(def: #export (_& left right)
+ (All [a b] (-> (Lexer a) (Lexer b) (Lexer b)))
+ (do Monad<Lexer>
+ [_ left]
+ right))
+
+(def: #export (&_ left right)
+ (All [a b] (-> (Lexer a) (Lexer b) (Lexer a)))
+ (do Monad<Lexer>
+ [output left
+ _ right]
+ (wrap output)))
+
+(def: #export (default value lexer)
+ (All [a] (-> a (Lexer a) (Lexer a)))
+ (lambda [input]
+ (case (lexer input)
+ (#;Left error)
+ (#;Right [input value])
+
+ (#;Right input'+value)
+ (#;Right input'+value))))
+
+(def: #export (codec codec lexer)
+ (All [a] (-> (Codec Text a) (Lexer Text) (Lexer a)))
+ (lambda [input]
+ (case (lexer input)
+ (#;Left error)
+ (#;Left error)
+
+ (#;Right [input' to-decode])
+ (case (:: codec decode to-decode)
+ (#;Left error)
+ (#;Left error)
+
+ (#;Right value)
+ (#;Right [input' value])))))
+
+(def: #export (enclosed [start end] lexer)
+ (All [a] (-> [Text Text] (Lexer a) (Lexer a)))
+ (_& (this start)
+ (&_ lexer
+ (this end))))
diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux
new file mode 100644
index 000000000..7c192cb2b
--- /dev/null
+++ b/stdlib/source/lux/macro.lux
@@ -0,0 +1,31 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monad)
+ (data (struct [list "List/" Monad<List>])
+ text/format)
+ [compiler]
+ (macro ["s" syntax #+ syntax: Syntax])))
+
+(def: omit^
+ (Syntax Bool)
+ (s;tag? ["" "omit"]))
+
+(do-template [<macro> <func>]
+ [(syntax: #export (<macro> {? omit^} token)
+ (do @
+ [output (<func> token)
+ #let [_ (List/map (. log! %ast)
+ output)]]
+ (if ?
+ (wrap (list))
+ (wrap output))))]
+
+ [expand compiler;macro-expand]
+ [expand-all compiler;macro-expand-all]
+ [expand-once compiler;macro-expand-once]
+ )
diff --git a/stdlib/source/lux/macro/ast.lux b/stdlib/source/lux/macro/ast.lux
new file mode 100644
index 000000000..cc1cffa5f
--- /dev/null
+++ b/stdlib/source/lux/macro/ast.lux
@@ -0,0 +1,149 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control eq)
+ (data bool
+ number
+ [char]
+ [text #+ Eq<Text> "Text/" Monoid<Text>]
+ ident
+ (struct [list #* "" Functor<List> Fold<List>])
+ )))
+
+## [Types]
+## (type: (AST' w)
+## (#;BoolS Bool)
+## (#;NatS Nat)
+## (#;IntS Int)
+## (#;RealS Real)
+## (#;CharS Char)
+## (#;TextS Text)
+## (#;SymbolS Text Text)
+## (#;TagS Text Text)
+## (#;FormS (List (w (AST' w))))
+## (#;TupleS (List (w (AST' w))))
+## (#;RecordS (List [(w (AST' w)) (w (AST' w))])))
+
+## (type: AST
+## (Meta Cursor (AST' (Meta Cursor))))
+
+## [Utils]
+(def: _cursor Cursor ["" -1 -1])
+
+## [Functions]
+(do-template [<name> <type> <tag>]
+ [(def: #export (<name> x)
+ (-> <type> AST)
+ [_cursor (<tag> x)])]
+
+ [bool Bool #;BoolS]
+ [nat Nat #;NatS]
+ [int Int #;IntS]
+ [frac Frac #;FracS]
+ [real Real #;RealS]
+ [char Char #;CharS]
+ [text Text #;TextS]
+ [symbol Ident #;SymbolS]
+ [tag Ident #;TagS]
+ [form (List AST) #;FormS]
+ [tuple (List AST) #;TupleS]
+ [record (List [AST AST]) #;RecordS]
+ )
+
+(do-template [<name> <tag>]
+ [(def: #export (<name> name)
+ (-> Text AST)
+ [_cursor (<tag> ["" name])])]
+
+ [local-symbol #;SymbolS]
+ [local-tag #;TagS])
+
+## [Structures]
+(struct: #export _ (Eq AST)
+ (def: (= x y)
+ (case [x y]
+ (^template [<tag> <eq>]
+ [[_ (<tag> x')] [_ (<tag> y')]]
+ (:: <eq> = x' y'))
+ ([#;BoolS Eq<Bool>]
+ [#;NatS Eq<Nat>]
+ [#;IntS Eq<Int>]
+ [#;FracS Eq<Frac>]
+ [#;RealS Eq<Real>]
+ [#;CharS char;Eq<Char>]
+ [#;TextS Eq<Text>]
+ [#;SymbolS Eq<Ident>]
+ [#;TagS Eq<Ident>])
+
+ (^template [<tag>]
+ [[_ (<tag> xs')] [_ (<tag> ys')]]
+ (and (:: Eq<Nat> = (size xs') (size ys'))
+ (fold (lambda [[x' y'] old]
+ (and old (= x' y')))
+ true
+ (zip2 xs' ys'))))
+ ([#;FormS]
+ [#;TupleS])
+
+ [[_ (#;RecordS xs')] [_ (#;RecordS ys')]]
+ (and (:: Eq<Nat> = (size xs') (size ys'))
+ (fold (lambda [[[xl' xr'] [yl' yr']] old]
+ (and old (= xl' yl') (= xr' yr')))
+ true
+ (zip2 xs' ys')))
+
+ _
+ false)))
+
+## [Values]
+(def: #export (ast-to-text ast)
+ (-> AST Text)
+ (case ast
+ (^template [<tag> <struct>]
+ [_ (<tag> value)]
+ (:: <struct> encode value))
+ ([#;BoolS Codec<Text,Bool>]
+ [#;NatS Codec<Text,Nat>]
+ [#;IntS Codec<Text,Int>]
+ [#;FracS Codec<Text,Frac>]
+ [#;RealS Codec<Text,Real>]
+ [#;CharS char;Codec<Text,Char>]
+ [#;TextS text;Codec<Text,Text>]
+ [#;SymbolS Codec<Text,Ident>])
+
+ [_ (#;TagS ident)]
+ (Text/append "#" (:: Codec<Text,Ident> encode ident))
+
+ (^template [<tag> <open> <close>]
+ [_ (<tag> members)]
+ ($_ Text/append <open> (|> members (map ast-to-text) (interpose " ") (text;join-with "")) <close>))
+ ([#;FormS "(" ")"]
+ [#;TupleS "[" "]"])
+
+ [_ (#;RecordS pairs)]
+ ($_ Text/append "{" (|> pairs (map (lambda [[left right]] ($_ Text/append (ast-to-text left) " " (ast-to-text right)))) (interpose " ") (text;join-with "")) "}")
+ ))
+
+(def: #export (replace source target ast)
+ (-> AST AST AST AST)
+ (if (:: Eq<AST> = source ast)
+ target
+ (case ast
+ (^template [<tag>]
+ [cursor (<tag> parts)]
+ [cursor (<tag> (map (replace source target) parts))])
+ ([#;FormS]
+ [#;TupleS])
+
+ [cursor (#;RecordS parts)]
+ [cursor (#;RecordS (map (lambda [[left right]]
+ [(replace source target left)
+ (replace source target right)])
+ parts))]
+
+ _
+ ast)))
diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux
new file mode 100644
index 000000000..ac7043f26
--- /dev/null
+++ b/stdlib/source/lux/macro/poly.lux
@@ -0,0 +1,364 @@
+## 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/.
+
+(;module:
+ [lux #- list]
+ (lux (control monad
+ [eq])
+ (data [text]
+ text/format
+ (struct [list "List/" Monad<List>]
+ [dict #+ Dict])
+ [number]
+ [product]
+ [bool]
+ [char]
+ [maybe])
+ [compiler #+ Monad<Lux> with-gensyms]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax]
+ (syntax [common]))
+ [type]
+ ))
+
+## [Types]
+(type: #export (Matcher a)
+ (-> Type (Lux a)))
+
+(type: #export Env (Dict Nat AST))
+
+## [Combinators]
+(do-template [<combinator> <name>]
+ [(def: #export <combinator>
+ (Matcher Unit)
+ (lambda [:type:]
+ (case (type;un-alias :type:)
+ (#;NamedT ["lux" <name>] _)
+ (:: compiler;Monad<Lux> wrap [])
+
+ _
+ (compiler;fail (format "Not " <name> " type: " (type;type-to-text :type:))))))]
+
+ [unit "Unit"]
+ [bool "Bool"]
+ [nat "Nat"]
+ [int "Int"]
+ [frac "Frac"]
+ [real "Real"]
+ [char "Char"]
+ [text "Text"]
+ )
+
+(def: #export primitive
+ (Matcher Type)
+ (lambda [:type:]
+ (let% [<primitives> (do-template [<parser> <type>]
+ [(do Monad<Lux>
+ [_ (<parser> :type:)]
+ (wrap <type>))]
+
+ [bool Bool]
+ [nat Nat]
+ [int Int]
+ [frac Frac]
+ [real Real]
+ [char Char]
+ [text Text])]
+ ($_ compiler;either
+ <primitives>))))
+
+(syntax: ($AST$ ast)
+ (wrap (;list (ast;text (ast;ast-to-text ast)))))
+
+(do-template [<single> <multi> <flattener> <tag>]
+ [(def: #export <single>
+ (Matcher [Type Type])
+ (lambda [:type:]
+ (case (type;un-name :type:)
+ (<tag> :left: :right:)
+ (:: compiler;Monad<Lux> wrap [:left: :right:])
+
+ _
+ (compiler;fail (format "Not a " ($AST$ <tag>) " type: " (type;type-to-text :type:))))))
+
+ (def: #export <multi>
+ (Matcher (List Type))
+ (lambda [:type:]
+ (let [members (<flattener> (type;un-name :type:))]
+ (if (>+ +1 (list;size members))
+ (:: compiler;Monad<Lux> wrap members)
+ (compiler;fail (format "Not a " ($AST$ <tag>) " type: " (type;type-to-text :type:)))))))]
+
+ [sum sum+ type;flatten-sum #;SumT]
+ [prod prod+ type;flatten-prod #;ProdT]
+ )
+
+(def: #export func
+ (Matcher [Type Type])
+ (lambda [:type:]
+ (case (type;un-name :type:)
+ (#;LambdaT :left: :right:)
+ (:: compiler;Monad<Lux> wrap [:left: :right:])
+
+ _
+ (compiler;fail (format "Not a LambdaT type: " (type;type-to-text :type:))))))
+
+(def: #export func+
+ (Matcher [(List Type) Type])
+ (lambda [:type:]
+ (let [[ins out] (type;flatten-function (type;un-name :type:))]
+ (if (>+ +0 (list;size ins))
+ (:: compiler;Monad<Lux> wrap [ins out])
+ (compiler;fail (format "Not a LambdaT type: " (type;type-to-text :type:)))))))
+
+(def: #export tagged
+ (Matcher [(List Ident) Type])
+ (lambda [:type:]
+ (case (type;un-alias :type:)
+ (#;NamedT type-name :def:)
+ (do compiler;Monad<Lux>
+ [tags (compiler;tags-of type-name)]
+ (wrap [tags :def:]))
+
+ _
+ (compiler;fail (format "Unnamed types can't have tags: " (type;type-to-text :type:))))))
+
+(def: #export polymorphic
+ (Matcher [(List AST) Type])
+ (lambda [:type:]
+ (loop [:type: (type;un-name :type:)]
+ (case :type:
+ (#;UnivQ _ :type:')
+ (do compiler;Monad<Lux>
+ [[g!tail :type:''] (recur :type:')
+ g!head (compiler;gensym "type-var")]
+ (wrap [(list& g!head g!tail)
+ :type:'']))
+
+ _
+ (:: compiler;Monad<Lux> wrap [(;list) :type:])))))
+
+(do-template [<combinator> <sub-comb>]
+ [(def: #export <combinator>
+ (Matcher [(List AST) (List [Ident Type])])
+ (lambda [:type:]
+ (do compiler;Monad<Lux>
+ [[tags :type:] (tagged :type:)
+ _ (compiler;assert (>+ +0 (list;size tags)) "Records and variants must have tags.")
+ [vars :type:] (polymorphic :type:)
+ members (<sub-comb> :type:)]
+ (wrap [vars (list;zip2 tags members)]))))]
+
+ [variant sum+]
+ [record prod+]
+ )
+
+(def: #export tuple
+ (Matcher [(List AST) (List Type)])
+ (lambda [:type:]
+ (do compiler;Monad<Lux>
+ [[vars :type:] (polymorphic :type:)
+ members (prod+ :type:)]
+ (wrap [vars members]))))
+
+(def: #export function
+ (Matcher [(List AST) [(List Type) Type]])
+ (lambda [:type:]
+ (do compiler;Monad<Lux>
+ [[vars :type:] (polymorphic :type:)
+ ins+out (func+ :type:)]
+ (wrap [vars ins+out]))))
+
+(def: #export apply
+ (Matcher [Type (List Type)])
+ (lambda [:type:]
+ (do compiler;Monad<Lux>
+ [#let [[:func: :args:] (loop [:type: (type;un-name :type:)]
+ (case :type:
+ (#;AppT :func: :arg:)
+ (let [[:func:' :args:] (recur :func:)]
+ [:func:' (list& :arg: :args:)])
+
+ _
+ [:type: (;list)]))]]
+ (case :args:
+ #;Nil
+ (compiler;fail "Not a type application.")
+
+ _
+ (wrap [:func: (list;reverse :args:)])))))
+
+(do-template [<combinator> <name>]
+ [(def: #export <combinator>
+ (Matcher Type)
+ (lambda [:type:]
+ (case (type;un-name :type:)
+ (^=> (#;AppT :quant: :arg:)
+ {(type;un-alias :quant:) (#;NamedT ["lux" <name>] _)})
+ (:: compiler;Monad<Lux> wrap :arg:)
+
+ _
+ (compiler;fail (format "Not " <name> " type: " (type;type-to-text :type:))))))]
+
+ [maybe "Maybe"]
+ [list "List"]
+ )
+
+(def: (adjusted-idx env idx)
+ (-> Env Nat Nat)
+ (let [env-level (/+ +2 (dict;size env))
+ bound-level (/+ +2 idx)
+ bound-idx (%+ +2 idx)]
+ (|> env-level dec+ (-+ bound-level) (*+ +2) (++ bound-idx))))
+
+(def: #export (bound env)
+ (-> Env (Matcher AST))
+ (lambda [:type:]
+ (case :type:
+ (#;BoundT idx)
+ (case (dict;get (adjusted-idx env idx) env)
+ (#;Some poly-val)
+ (:: compiler;Monad<Lux> wrap poly-val)
+
+ #;None
+ (compiler;fail (format "Unknown bound type: " (type;type-to-text :type:))))
+
+ _
+ (compiler;fail (format "Not a bound type: " (type;type-to-text :type:))))))
+
+(def: #export (var env var-id)
+ (-> Env Nat (Matcher Unit))
+ (lambda [:type:]
+ (case :type:
+ (^=> (#;BoundT idx)
+ (=+ var-id (adjusted-idx env idx)))
+ (:: compiler;Monad<Lux> wrap [])
+
+ _
+ (compiler;fail (format "Not a bound type: " (type;type-to-text :type:))))))
+
+(def: #export (recur env)
+ (-> Env (Matcher Unit))
+ (lambda [:type:]
+ (do Monad<Lux>
+ [[t-fun t-args] (apply :type:)]
+ (loop [base +0
+ :parts: (list& t-fun t-args)]
+ (case :parts:
+ #;Nil
+ (wrap [])
+
+ (^=> (#;Cons (#;BoundT idx) :parts:')
+ {(adjusted-idx env idx)
+ idx'}
+ (=+ base idx'))
+ (recur (inc+ base) :parts:')
+
+ _
+ (compiler;fail (format "Type is not a recursive instance: " (type;type-to-text :type:)))))
+ )))
+
+## [Syntax]
+(def: #export (extend-env type-func type-vars env)
+ (-> AST (List AST) Env Env)
+ (case type-vars
+ #;Nil
+ env
+
+ (#;Cons tvar type-vars')
+ (let [current-size (dict;size env)]
+ (|> env
+ (dict;put current-size type-func)
+ (dict;put (inc+ current-size) tvar)
+ (extend-env (` (#;AppT (~ type-func) (~ tvar))) type-vars')
+ ))))
+
+(syntax: #export (poly: {_ex-lev common;export-level}
+ {[name env inputs] (s;form ($_ s;seq
+ s;local-symbol
+ s;local-symbol
+ (s;many s;local-symbol)))}
+ body)
+ (with-gensyms [g!body]
+ (let [g!inputs (List/map (|>. [""] ast;symbol) inputs)
+ g!name (ast;symbol ["" name])
+ g!env (ast;symbol ["" env])]
+ (wrap (;list (` (syntax: (~@ (common;gen-export-level _ex-lev)) ((~ g!name) (~@ (List/map (lambda [g!input] (` {(~ g!input) s;symbol}))
+ g!inputs)))
+ (do Monad<Lux>
+ [(~@ (List/join (List/map (lambda [g!input] (;list g!input (` (compiler;find-type-def (~ g!input)))))
+ g!inputs)))
+ (~' #let) [(~ g!env) (: Env (dict;new number;Hash<Nat>))]
+ (~ g!body) (: (Lux AST)
+ (loop [(~ g!env) (~ g!env)
+ (~@ (List/join (List/map (lambda [g!input] (;list g!input g!input))
+ g!inputs)))]
+ (let [(~ g!name) (~' recur)]
+ (~ body))))]
+ ((~' wrap) (;list (~ g!body)))))))))))
+
+(def: (common-poly-name? poly-func)
+ (-> Text Bool)
+ (and (text;starts-with? "|" poly-func)
+ (text;ends-with? "|" poly-func)))
+
+(def: (derivation-name poly args)
+ (-> Text (List Text) (Maybe Text))
+ (if (common-poly-name? poly)
+ (case (text;sub +1 (dec+ (text;size poly)) poly)
+ (#;Some clean-poly)
+ (case (list;reverse args)
+ #;Nil
+ #;None
+
+ (#;Cons type #;Nil)
+ (#;Some (format type "/" clean-poly))
+
+ (#;Cons type args)
+ (#;Some (format type "/" clean-poly "@" (|> args list;reverse (text;join-with ",")))))
+
+ #;None
+ #;None)
+ #;None))
+
+(syntax: #export (derived: {_ex-lev common;export-level}
+ {?name (s;opt s;local-symbol)}
+ {[poly-func poly-args] (s;either (s;form (s;seq s;symbol (s;many s;symbol)))
+ (s;seq s;symbol (:: @ wrap (;list))))}
+ {?custom-impl (s;opt s;any)})
+ (do @
+ [name (case ?name
+ (#;Some name)
+ (wrap name)
+
+ (^=> #;None
+ {(derivation-name (product;right poly-func) (List/map product;right poly-args))
+ (#;Some derived-name)})
+ (wrap derived-name)
+
+ _
+ (compiler;fail "derived: was given no explicit name, and can't generate one from given information."))
+ #let [impl (case ?custom-impl
+ (#;Some custom-impl)
+ custom-impl
+
+ #;None
+ (` ((~ (ast;symbol poly-func)) (~@ (List/map ast;symbol poly-args)))))]]
+ (wrap (;list (` (def: (~@ (common;gen-export-level _ex-lev))
+ (~ (ast;symbol ["" name]))
+ (~ impl)))))))
+
+## [Derivers]
+(def: #export (gen-type converter type-fun tvars type)
+ (-> (-> AST AST) AST (List AST) Type AST)
+ (let [type' (type;type-to-ast type)]
+ (case tvars
+ #;Nil
+ (converter type')
+
+ _
+ (` (All (~ type-fun) [(~@ tvars)]
+ (-> (~@ (List/map converter tvars))
+ (~ (converter (` ((~ type') (~@ tvars)))))))))))
diff --git a/stdlib/source/lux/macro/poly/eq.lux b/stdlib/source/lux/macro/poly/eq.lux
new file mode 100644
index 000000000..b0506c5ed
--- /dev/null
+++ b/stdlib/source/lux/macro/poly/eq.lux
@@ -0,0 +1,103 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monad
+ [eq])
+ (data [text]
+ text/format
+ (struct [list "List/" Monad<List>]
+ [dict #+ Dict])
+ [number]
+ [product]
+ [bool]
+ [char]
+ [maybe])
+ [compiler #+ Monad<Lux> with-gensyms]
+ (macro [ast]
+ [syntax #+ syntax: Syntax]
+ (syntax [common])
+ [poly #+ poly:])
+ [type]
+ ))
+
+## [Derivers]
+(poly: #export (|Eq| env :x:)
+ (let [->Eq (: (-> AST AST)
+ (lambda [.type.] (` (eq;Eq (~ .type.)))))]
+ (let% [<basic> (do-template [<type> <matcher> <eq>]
+ [(do @
+ [_ (<matcher> :x:)]
+ (wrap (` (: (~ (->Eq (` <type>)))
+ <eq>))))]
+
+ [Unit poly;unit (lambda [(~' test) (~' input)] true)]
+ [Bool poly;bool bool;Eq<Bool>]
+ [Nat poly;nat number;Eq<Nat>]
+ [Int poly;int number;Eq<Int>]
+ [Frac poly;frac number;Eq<Frac>]
+ [Real poly;real number;Eq<Real>]
+ [Char poly;char char;Eq<Char>]
+ [Text poly;text text;Eq<Text>])]
+ ($_ compiler;either
+ ## Primitive types
+ <basic>
+ ## Variants
+ (with-gensyms [g!type-fun g!left g!right]
+ (do @
+ [[g!vars cases] (poly;variant :x:)
+ #let [new-env (poly;extend-env g!type-fun g!vars env)]
+ pattern-matching (mapM @
+ (lambda [[name :case:]]
+ (do @
+ [encoder (|Eq| new-env :case:)]
+ (wrap (list (` [((~ (ast;tag name)) (~ g!left))
+ ((~ (ast;tag name)) (~ g!right))])
+ (` ((~ encoder) (~ g!left) (~ g!right)))))))
+ cases)]
+ (wrap (` (: (~ (poly;gen-type ->Eq g!type-fun g!vars :x:))
+ (lambda [(~@ g!vars)]
+ (lambda [(~ g!left) (~ g!right)]
+ (case [(~ g!left) (~ g!right)]
+ (~@ (List/join pattern-matching)))))
+ )))))
+ ## Tuples
+ (with-gensyms [g!type-fun g!left g!right]
+ (do @
+ [[g!vars members] (poly;tuple :x:)
+ #let [new-env (poly;extend-env g!type-fun g!vars env)]
+ pattern-matching (mapM @
+ (lambda [:member:]
+ (do @
+ [g!left (compiler;gensym "g!left")
+ g!right (compiler;gensym "g!right")
+ encoder (|Eq| new-env :member:)]
+ (wrap [g!left g!right encoder])))
+ members)
+ #let [.left. (` [(~@ (List/map product;left pattern-matching))])
+ .right. (` [(~@ (List/map (|>. product;right product;left) pattern-matching))])]]
+ (wrap (` (: (~ (poly;gen-type ->Eq g!type-fun g!vars :x:))
+ (lambda [(~@ g!vars)]
+ (lambda [(~ g!left) (~ g!right)]
+ (case [(~ g!left) (~ g!right)]
+ [(~ .left.) (~ .right.)]
+ (;;array (list (~@ (List/map (lambda [[g!left g!right g!encoder]]
+ (` ((~ g!encoder) (~ g!left) (~ g!right))))
+ pattern-matching)))))))
+ )))
+ ))
+ ## Type applications
+ (do @
+ [[:func: :args:] (poly;apply :x:)
+ .func. (|Eq| env :func:)
+ .args. (mapM @ (|Eq| env) :args:)]
+ (wrap (` (: (~ (->Eq (type;type-to-ast :x:)))
+ ((~ .func.) (~@ .args.))))))
+ ## Bound type-vars
+ (poly;bound env :x:)
+ ## If all else fails...
+ (compiler;fail (format "Can't create Eq for: " (type;type-to-text :x:)))
+ ))))
diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux
new file mode 100644
index 000000000..78b668f2c
--- /dev/null
+++ b/stdlib/source/lux/macro/poly/functor.lux
@@ -0,0 +1,126 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monad
+ [functor])
+ (data [text]
+ text/format
+ (struct [list "List/" Monad<List>]
+ [dict #+ Dict])
+ [number]
+ [product]
+ [bool]
+ [char]
+ [maybe]
+ [ident "Ident/" Codec<Text,Ident>]
+ error)
+ [compiler #+ Monad<Lux> with-gensyms]
+ (macro [ast]
+ [syntax #+ syntax: Syntax]
+ (syntax [common])
+ [poly #+ poly:])
+ [type]
+ ))
+
+## [Derivers]
+(poly: #export (|Functor| env :x:)
+ (with-gensyms [g!type-fun g!func g!input]
+ (do @
+ [#let [g!map (' map)]
+ [g!vars _] (poly;polymorphic :x:)
+ #let [num-vars (list;size g!vars)
+ new-env (poly;extend-env g!type-fun g!vars env)]
+ _ (compiler;assert (>+ +0 num-vars)
+ "Functors must have at least 1 type-variable.")]
+ (let [->Functor (: (-> AST AST)
+ (lambda [.type.] (` (functor;Functor (~ .type.)))))
+ |elem| (: (-> AST (poly;Matcher AST))
+ (lambda |elem| [value :type:]
+ ($_ compiler;either
+ ## Nothing to do.
+ (do @
+ [_ (poly;primitive :type:)]
+ (wrap value))
+ ## Type-var
+ (do @
+ [_ (poly;var new-env (dec+ num-vars) :type:)]
+ (wrap (` ((~ g!func) (~ value)))))
+ ## Tuples/records
+ (do @
+ [[g!vars members] (poly;tuple :x:)
+ pm (mapM @
+ (lambda [:slot:]
+ (do @
+ [g!slot (compiler;gensym "g!slot")
+ body (|elem| g!slot :slot:)]
+ (wrap [g!slot body])))
+ members)]
+ (wrap (` (case (~ g!input)
+ [(~@ (List/map product;left pm))]
+ [(~@ (List/map product;right pm))])
+ )))
+ ## Recursion
+ (do @
+ [_ (poly;recur new-env :type:)]
+ (wrap (` ((~ g!map) (~ g!func) (~ value)))))
+ )))]
+ ($_ compiler;either
+ ## Variants
+ (do @
+ [[g!vars cases] (poly;variant :x:)
+ pattern-matching (mapM @
+ (lambda [[name :case:]]
+ (do @
+ [#let [analysis (` ((~ (ast;tag name)) (~ g!input)))]
+ synthesis (|elem| g!input :case:)]
+ (wrap (list analysis
+ synthesis))))
+ cases)]
+ (wrap (` (: (~ (->Functor (type;type-to-ast :x:)))
+ (struct (def: ((~ g!map) (~ g!func) (~ g!input))
+ (case (~ g!input)
+ (~@ (List/join pattern-matching)))))
+ ))))
+ ## Tuples/Records
+ (do @
+ [[g!vars members] (poly;tuple :x:)
+ pm (mapM @
+ (lambda [:slot:]
+ (do @
+ [g!slot (compiler;gensym "g!slot")
+ body (|elem| g!slot :slot:)]
+ (wrap [g!slot body])))
+ members)]
+ (wrap (` (: (~ (->Functor (type;type-to-ast :x:)))
+ (struct (def: ((~ g!map) (~ g!func) (~ g!input))
+ (case (~ g!input)
+ [(~@ (List/map product;left pm))]
+ [(~@ (List/map product;right pm))])))
+ ))))
+ ## Functions
+ (with-gensyms [g!out]
+ (do @
+ [[g!vars [:ins: :out:]] (poly;function :x:)
+ .out. (|elem| g!out :out:)
+ g!ins (seqM @
+ (list;repeat (list;size :ins:)
+ (compiler;gensym "g!arg")))]
+ (wrap (` (: (~ (->Functor (type;type-to-ast :x:)))
+ (struct (def: ((~ g!map) (~ g!func) (~ g!input))
+ (lambda [(~@ g!ins)]
+ (let [(~ g!out) ((~ g!input) (~@ g!ins))]
+ (~ .out.))))))))))
+ ## No structure (as you'd expect from Identity)
+ (do @
+ [_ (poly;var new-env (dec+ num-vars) :x:)]
+ (wrap (` (: (~ (->Functor (type;type-to-ast :x:)))
+ (struct (def: ((~ g!map) (~ g!func) (~ g!input))
+ ((~ g!func) (~ g!input))))))))
+ ## Failure...
+ (compiler;fail (format "Can't create Functor for: " (type;type-to-text :x:)))
+ ))
+ )))
diff --git a/stdlib/source/lux/macro/poly/text-encoder.lux b/stdlib/source/lux/macro/poly/text-encoder.lux
new file mode 100644
index 000000000..49d06daf4
--- /dev/null
+++ b/stdlib/source/lux/macro/poly/text-encoder.lux
@@ -0,0 +1,126 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monad
+ [codec])
+ (data [text]
+ text/format
+ (struct [list "List/" Monad<List>]
+ [dict #+ Dict])
+ [number]
+ [product]
+ [bool]
+ [char]
+ [maybe]
+ [ident "Ident/" Codec<Text,Ident>]
+ error)
+ [compiler #+ Monad<Lux> with-gensyms]
+ (macro [ast]
+ [syntax #+ syntax: Syntax]
+ (syntax [common])
+ [poly #+ poly:])
+ [type]
+ ))
+
+## [Derivers]
+(poly: #export (|Codec@Text//encode| env :x:)
+ (let [->Codec//encode (: (-> AST AST)
+ (lambda [.type.] (` (-> (~ .type.) Text))))]
+ (let% [<basic> (do-template [<type> <matcher> <encoder>]
+ [(do @
+ [_ (<matcher> :x:)]
+ (wrap (` (: (~ (->Codec//encode (` <type>)))
+ (~' <encoder>)))))]
+
+ [Unit poly;unit (lambda [_0] "[]")]
+ [Bool poly;bool (:: bool;Codec<Text,Bool> encode)]
+ [Nat poly;nat (:: number;Codec<Text,Nat> encode)]
+ [Int poly;int (:: number;Codec<Text,Int> encode)]
+ [Frac poly;frac (:: number;Codec<Text,Frac> encode)]
+ [Real poly;real (:: number;Codec<Text,Real> encode)]
+ [Char poly;char (:: char;Codec<Text,Char> encode)]
+ [Text poly;text (:: text;Codec<Text,Text> encode)])]
+ ($_ compiler;either
+ ## Primitives
+ <basic>
+ ## Variants
+ (with-gensyms [g!type-fun g!case g!input]
+ (do @
+ [[g!vars cases] (poly;variant :x:)
+ #let [new-env (poly;extend-env g!type-fun g!vars env)]
+ pattern-matching (mapM @
+ (lambda [[name :case:]]
+ (do @
+ [encoder (|Codec@Text//encode| new-env :case:)]
+ (wrap (list (` ((~ (ast;tag name)) (~ g!case)))
+ (` (format "(#"
+ (~ (ast;text (Ident/encode name)))
+ " "
+ ((~ encoder) (~ g!case))
+ ")"))))))
+ cases)]
+ (wrap (` (: (~ (poly;gen-type ->Codec//encode g!type-fun g!vars :x:))
+ (lambda [(~@ g!vars)]
+ (lambda [(~ g!input)]
+ (case (~ g!input)
+ (~@ (List/join pattern-matching)))))
+ )))))
+ ## Records
+ (with-gensyms [g!type-fun g!case g!input]
+ (do @
+ [[g!vars slots] (poly;record :x:)
+ #let [new-env (poly;extend-env g!type-fun g!vars env)]
+ synthesis (mapM @
+ (lambda [[name :slot:]]
+ (do @
+ [encoder (|Codec@Text//encode| new-env :slot:)]
+ (wrap (` (format "#"
+ (~ (ast;text (Ident/encode name)))
+ " "
+ ((~ encoder) (get@ (~ (ast;tag name)) (~ g!input))))))))
+ slots)]
+ (wrap (` (: (~ (poly;gen-type ->Codec//encode g!type-fun g!vars :x:))
+ (lambda [(~@ g!vars)]
+ (lambda [(~ g!input)]
+ (format "{" (~@ (list;interpose (' " ") synthesis)) "}")))
+ )))))
+ ## Tuples
+ (with-gensyms [g!type-fun g!case g!input]
+ (do @
+ [[g!vars members] (poly;tuple :x:)
+ #let [new-env (poly;extend-env g!type-fun g!vars env)]
+ parts (mapM @
+ (lambda [:member:]
+ (do @
+ [g!member (compiler;gensym "g!member")
+ encoder (|Codec@Text//encode| new-env :member:)]
+ (wrap [g!member encoder])))
+ members)
+ #let [analysis (` [(~@ (List/map product;left parts))])
+ synthesis (List/map (lambda [[g!member g!encoder]]
+ (` ((~ g!encoder) (~ g!member))))
+ parts)]]
+ (wrap (` (: (~ (poly;gen-type ->Codec//encode g!type-fun g!vars :x:))
+ (lambda [(~@ g!vars)]
+ (lambda [(~ g!input)]
+ (case (~ g!input)
+ (~ analysis)
+ (format "[" (~@ (list;interpose (' " ") synthesis)) "]"))))
+ )))
+ ))
+ ## Type applications
+ (do @
+ [[:func: :args:] (poly;apply :x:)
+ .func. (|Codec@Text//encode| env :func:)
+ .args. (mapM @ (|Codec@Text//encode| env) :args:)]
+ (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:)))
+ ((~ .func.) (~@ .args.))))))
+ ## Bound type-variables
+ (poly;bound env :x:)
+ ## Failure...
+ (compiler;fail (format "Can't create Text encoder for: " (type;type-to-text :x:)))
+ ))))
diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux
new file mode 100644
index 000000000..367dc10b6
--- /dev/null
+++ b/stdlib/source/lux/macro/syntax.lux
@@ -0,0 +1,472 @@
+## 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/.
+
+(;module:
+ [lux #- not default]
+ (lux [compiler #+ Monad<Lux> with-gensyms]
+ (control functor
+ applicative
+ monad
+ eq)
+ (data [bool]
+ [char]
+ [number]
+ [text "Text/" Monoid<Text>]
+ [ident]
+ (struct [list #* "" Functor<List> Fold<List> "List/" Monoid<List>])
+ [product]
+ error))
+ (.. [ast]))
+
+## [Utils]
+(def: (join-pairs pairs)
+ (All [a] (-> (List [a a]) (List a)))
+ (case pairs
+ #;Nil #;Nil
+ (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs'))))
+
+## [Types]
+(type: #export (Syntax a)
+ (-> (List AST) (Error [(List AST) a])))
+
+## [Structures]
+(struct: #export _ (Functor Syntax)
+ (def: (map f ma)
+ (lambda [tokens]
+ (case (ma tokens)
+ (#;Left msg)
+ (#;Left msg)
+
+ (#;Right [tokens' a])
+ (#;Right [tokens' (f a)])))))
+
+(struct: #export _ (Applicative Syntax)
+ (def: functor Functor<Syntax>)
+
+ (def: (wrap x tokens)
+ (#;Right [tokens x]))
+
+ (def: (apply ff fa)
+ (lambda [tokens]
+ (case (ff tokens)
+ (#;Right [tokens' f])
+ (case (fa tokens')
+ (#;Right [tokens'' a])
+ (#;Right [tokens'' (f a)])
+
+ (#;Left msg)
+ (#;Left msg))
+
+ (#;Left msg)
+ (#;Left msg)))))
+
+(struct: #export _ (Monad Syntax)
+ (def: applicative Applicative<Syntax>)
+
+ (def: (join mma)
+ (lambda [tokens]
+ (case (mma tokens)
+ (#;Left msg)
+ (#;Left msg)
+
+ (#;Right [tokens' ma])
+ (ma tokens')))))
+
+## [Utils]
+(def: (remaining-inputs asts)
+ (-> (List AST) Text)
+ ($_ Text/append " | Remaining input: "
+ (|> asts (map ast;ast-to-text) (interpose " ") (text;join-with ""))))
+
+## [Syntaxs]
+(def: #export any
+ {#;doc "Just returns the next input without applying any logic."}
+ (Syntax AST)
+ (lambda [tokens]
+ (case tokens
+ #;Nil (#;Left "There are no tokens to parse!")
+ (#;Cons [t tokens']) (#;Right [tokens' t]))))
+
+(do-template [<get-name> <ask-name> <demand-name> <type> <tag> <eq> <desc>]
+ [(def: #export <get-name>
+ (Syntax <type>)
+ (lambda [tokens]
+ (case tokens
+ (#;Cons [[_ (<tag> x)] tokens'])
+ (#;Right [tokens' x])
+
+ _
+ (#;Left ($_ Text/append "Can't parse " <desc> (remaining-inputs tokens))))))
+
+ (def: #export (<ask-name> v)
+ (-> <type> (Syntax Bool))
+ (lambda [tokens]
+ (case tokens
+ (#;Cons [[_ (<tag> x)] tokens'])
+ (let [is-it? (:: <eq> = v x)
+ remaining (if is-it?
+ tokens'
+ tokens)]
+ (#;Right [remaining is-it?]))
+
+ _
+ (#;Right [tokens false]))))
+
+ (def: #export (<demand-name> v)
+ (-> <type> (Syntax Unit))
+ (lambda [tokens]
+ (case tokens
+ (#;Cons [[_ (<tag> x)] tokens'])
+ (if (:: <eq> = v x)
+ (#;Right [tokens' []])
+ (#;Left ($_ Text/append "Expected a " <desc> " but instead got " (ast;ast-to-text [_ (<tag> x)]) (remaining-inputs tokens))))
+
+ _
+ (#;Left ($_ Text/append "Can't parse " <desc> (remaining-inputs tokens))))))]
+
+ [ bool bool? bool! Bool #;BoolS bool;Eq<Bool> "bool"]
+ [ nat nat? nat! Nat #;NatS number;Eq<Nat> "nat"]
+ [ int int? int! Int #;IntS number;Eq<Int> "int"]
+ [ real real? real! Real #;RealS number;Eq<Real> "real"]
+ [ char char? char! Char #;CharS char;Eq<Char> "char"]
+ [ text text? text! Text #;TextS text;Eq<Text> "text"]
+ [symbol symbol? symbol! Ident #;SymbolS ident;Eq<Ident> "symbol"]
+ [ tag tag? tag! Ident #;TagS ident;Eq<Ident> "tag"]
+ )
+
+(def: #export (assert v message)
+ (-> Bool Text (Syntax Unit))
+ (lambda [tokens]
+ (if v
+ (#;Right [tokens []])
+ (#;Left ($_ Text/append message (remaining-inputs tokens))))))
+
+(do-template [<name> <comp> <error>]
+ [(def: #export <name>
+ (Syntax Int)
+ (do Monad<Syntax>
+ [n int
+ _ (assert (<comp> 0 n) <error>)]
+ (wrap n)))]
+
+ [pos-int > "Expected a positive integer: N > 0"]
+ [neg-int < "Expected a negative integer: N < 0"]
+ )
+
+(do-template [<name> <tag> <desc>]
+ [(def: #export <name>
+ (Syntax Text)
+ (lambda [tokens]
+ (case tokens
+ (#;Cons [[_ (<tag> ["" x])] tokens'])
+ (#;Right [tokens' x])
+
+ _
+ (#;Left ($_ Text/append "Can't parse " <desc> (remaining-inputs tokens))))))]
+
+ [local-symbol #;SymbolS "local symbol"]
+ [ local-tag #;TagS "local tag"]
+ )
+
+(do-template [<name> <tag> <desc>]
+ [(def: #export (<name> p)
+ (All [a]
+ (-> (Syntax a) (Syntax a)))
+ (lambda [tokens]
+ (case tokens
+ (#;Cons [[_ (<tag> members)] tokens'])
+ (case (p members)
+ (#;Right [#;Nil x]) (#;Right [tokens' x])
+ _ (#;Left ($_ Text/append "Syntax was expected to fully consume " <desc> (remaining-inputs tokens))))
+
+ _
+ (#;Left ($_ Text/append "Can't parse " <desc> (remaining-inputs tokens))))))]
+
+ [ form #;FormS "form"]
+ [tuple #;TupleS "tuple"]
+ )
+
+(def: #export (record p)
+ (All [a]
+ (-> (Syntax a) (Syntax a)))
+ (lambda [tokens]
+ (case tokens
+ (#;Cons [[_ (#;RecordS pairs)] tokens'])
+ (case (p (join-pairs pairs))
+ (#;Right [#;Nil x]) (#;Right [tokens' x])
+ _ (#;Left ($_ Text/append "Syntax was expected to fully consume record" (remaining-inputs tokens))))
+
+ _
+ (#;Left ($_ Text/append "Can't parse record" (remaining-inputs tokens))))))
+
+(def: #export (opt p)
+ {#;doc "Optionality combinator."}
+ (All [a]
+ (-> (Syntax a) (Syntax (Maybe a))))
+ (lambda [tokens]
+ (case (p tokens)
+ (#;Left _) (#;Right [tokens #;None])
+ (#;Right [tokens' x]) (#;Right [tokens' (#;Some x)]))))
+
+(def: #export (run tokens p)
+ (All [a]
+ (-> (List AST) (Syntax a) (Error [(List AST) a])))
+ (p tokens))
+
+(def: #export (some p)
+ {#;doc "0-or-more combinator."}
+ (All [a]
+ (-> (Syntax a) (Syntax (List a))))
+ (lambda [tokens]
+ (case (p tokens)
+ (#;Left _) (#;Right [tokens (list)])
+ (#;Right [tokens' x]) (run tokens'
+ (do Monad<Syntax>
+ [xs (some p)]
+ (wrap (list& x xs)))
+ ))))
+
+(def: #export (many p)
+ {#;doc "1-or-more combinator."}
+ (All [a]
+ (-> (Syntax a) (Syntax (List a))))
+ (do Monad<Syntax>
+ [x p
+ xs (some p)]
+ (wrap (list& x xs))))
+
+(def: #export (seq p1 p2)
+ {#;doc "Sequencing combinator."}
+ (All [a b]
+ (-> (Syntax a) (Syntax b) (Syntax [a b])))
+ (do Monad<Syntax>
+ [x1 p1
+ x2 p2]
+ (wrap [x1 x2])))
+
+(def: #export (alt p1 p2)
+ {#;doc "Heterogeneous alternative combinator."}
+ (All [a b]
+ (-> (Syntax a) (Syntax b) (Syntax (| a b))))
+ (lambda [tokens]
+ (case (p1 tokens)
+ (#;Right [tokens' x1]) (#;Right [tokens' (+0 x1)])
+ (#;Left _) (run tokens
+ (do Monad<Syntax>
+ [x2 p2]
+ (wrap (+1 x2))))
+ )))
+
+(def: #export (either pl pr)
+ {#;doc "Homogeneous alternative combinator."}
+ (All [a]
+ (-> (Syntax a) (Syntax a) (Syntax a)))
+ (lambda [tokens]
+ (case (pl tokens)
+ (#;Left _) (pr tokens)
+ output output
+ )))
+
+(def: #export end
+ {#;doc "Ensures there are no more inputs."}
+ (Syntax Unit)
+ (lambda [tokens]
+ (case tokens
+ #;Nil (#;Right [tokens []])
+ _ (#;Left ($_ Text/append "Expected list of tokens to be empty!" (remaining-inputs tokens))))))
+
+(def: #export end?
+ {#;doc "Checks whether there are no more inputs."}
+ (Syntax Bool)
+ (lambda [tokens]
+ (case tokens
+ #;Nil (#;Right [tokens true])
+ _ (#;Right [tokens false]))))
+
+(def: #export (exactly n p)
+ (All [a] (-> Nat (Syntax a) (Syntax (List a))))
+ (if (>+ +0 n)
+ (do Monad<Syntax>
+ [x p
+ xs (exactly (dec+ n) p)]
+ (wrap (#;Cons x xs)))
+ (:: Monad<Syntax> wrap (list))))
+
+(def: #export (at-least n p)
+ (All [a] (-> Nat (Syntax a) (Syntax (List a))))
+ (do Monad<Syntax>
+ [min (exactly n p)
+ extra (some p)]
+ (wrap (List/append min extra))))
+
+(def: #export (at-most n p)
+ (All [a] (-> Nat (Syntax a) (Syntax (List a))))
+ (if (>+ +0 n)
+ (lambda [input]
+ (case (p input)
+ (#;Left msg)
+ (#;Right [input (list)])
+
+ (#;Right [input' x])
+ (run input'
+ (do Monad<Syntax>
+ [xs (at-most (dec+ n) p)]
+ (wrap (#;Cons x xs))))
+ ))
+ (:: Monad<Syntax> wrap (list))))
+
+(def: #export (between from to p)
+ (All [a] (-> Nat Nat (Syntax a) (Syntax (List a))))
+ (do Monad<Syntax>
+ [min-xs (exactly from p)
+ max-xs (at-most (-+ from to) p)]
+ (wrap (:: Monad<List> join (list min-xs max-xs)))))
+
+(def: #export (sep-by sep p)
+ {#;doc "Parsers instances of 'p' that are separated by instances of 'sep'."}
+ (All [a b] (-> (Syntax b) (Syntax a) (Syntax (List a))))
+ (do Monad<Syntax>
+ [?x (opt p)]
+ (case ?x
+ #;None
+ (wrap #;Nil)
+
+ (#;Some x)
+ (do @
+ [xs' (some (seq sep p))]
+ (wrap (#;Cons x (map product;right xs'))))
+ )))
+
+(def: #export (not p)
+ (All [a] (-> (Syntax a) (Syntax Unit)))
+ (lambda [input]
+ (case (p input)
+ (#;Left msg)
+ (#;Right [input []])
+
+ _
+ (#;Left "Expected to fail; yet succeeded."))))
+
+(def: #export (fail message)
+ (All [a] (-> Text (Syntax a)))
+ (lambda [input]
+ (#;Left message)))
+
+(def: #export (default value parser)
+ {#;doc "If the given parser fails, returns the default value."}
+ (All [a] (-> a (Syntax a) (Syntax a)))
+ (lambda [input]
+ (case (parser input)
+ (#;Left error)
+ (#;Right [input value])
+
+ (#;Right [input' output])
+ (#;Right [input' output]))))
+
+(def: #export (on compiler meta)
+ (All [a] (-> Compiler (Lux a) (Syntax a)))
+ (lambda [input]
+ (case (meta compiler)
+ (#;Left error)
+ (#;Left error)
+
+ (#;Right [_ value])
+ (#;Right [input value])
+ )))
+
+(def: #export (local local-inputs syntax)
+ (All [a] (-> (List AST) (Syntax a) (Syntax a)))
+ (lambda [real-inputs]
+ (case (syntax local-inputs)
+ (#;Left error)
+ (#;Left error)
+
+ (#;Right [unconsume-inputs value])
+ (case unconsume-inputs
+ #;Nil
+ (#;Right [real-inputs value])
+
+ _
+ (#;Left "Unconsumed inputs.")))))
+
+## [Syntax]
+(def: #hidden text.join-with text;join-with)
+
+(macro: #export (syntax: tokens)
+ {#;doc (doc "A more advanced way to define macros than macro:."
+ "The inputs to the macro can be parsed in complex ways through the use of syntax parsers."
+ "The macro body is also (implicitly) run in the Monad<Lux>, to save some typing."
+ "Also, the compiler state can be accessed through the *compiler* binding."
+ (syntax: #export (object [#let [imports (class-imports *compiler*)]]
+ [#let [class-vars (list)]]
+ [super (opt (super-class-decl^ imports class-vars))]
+ [interfaces (tuple (some (super-class-decl^ imports class-vars)))]
+ [constructor-args (constructor-args^ imports class-vars)]
+ [methods (some (overriden-method-def^ imports))])
+ (let [def-code ($_ Text/append "anon-class:"
+ (spaced (list (super-class-decl$ (;default object-super-class super))
+ (with-brackets (spaced (map super-class-decl$ interfaces)))
+ (with-brackets (spaced (map constructor-arg$ constructor-args)))
+ (with-brackets (spaced (map (method-def$ id) methods))))))]
+ (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))))))}
+ (let [[exported? tokens] (case tokens
+ (^ (list& [_ (#;TagS ["" "export"])] tokens'))
+ [true tokens']
+
+ _
+ [false tokens])
+ ?parts (: (Maybe [Text (List AST) AST AST])
+ (case tokens
+ (^ (list [_ (#;FormS (list& [_ (#;SymbolS ["" name])] args))]
+ body))
+ (#;Some name args (` {}) body)
+
+ (^ (list [_ (#;FormS (list& [_ (#;SymbolS ["" name])] args))]
+ meta-data
+ body))
+ (#;Some name args meta-data body)
+
+ _
+ #;None))]
+ (case ?parts
+ (#;Some [name args meta body])
+ (with-gensyms [g!tokens g!body g!msg]
+ (do Monad<Lux>
+ [vars+parsers (mapM Monad<Lux>
+ (: (-> AST (Lux [AST AST]))
+ (lambda [arg]
+ (case arg
+ (^ [_ (#;RecordS (list [var parser]))])
+ (wrap [var parser])
+
+ [_ (#;SymbolS var-name)]
+ (wrap [(ast;symbol var-name) (` any)])
+
+ _
+ (compiler;fail "Syntax pattern expects records or symbols."))))
+ args)
+ #let [g!state (ast;symbol ["" "*compiler*"])
+ g!end (ast;symbol ["" ""])
+ error-msg (ast;text (Text/append "Wrong syntax for " name))
+ export-ast (: (List AST) (if exported? (list (' #export)) (list)))]]
+ (wrap (list (` (macro: (~@ export-ast) ((~ (ast;symbol ["" name])) (~ g!tokens))
+ (~ meta)
+ (lambda [(~ g!state)]
+ (;_lux_case (run (~ g!tokens)
+ (: (Syntax (Lux (List AST)))
+ (do Monad<Syntax>
+ [(~@ (join-pairs vars+parsers))
+ (~ g!end) end]
+ ((~' wrap) (do Monad<Lux>
+ []
+ (~ body))))))
+ (#;Right [(~ g!tokens) (~ g!body)])
+ ((~ g!body) (~ g!state))
+
+ (#;Left (~ g!msg))
+ (#;Left (text.join-with ": " (list (~ error-msg) (~ g!msg))))))))))))
+
+ _
+ (compiler;fail "Wrong syntax for syntax:"))))
diff --git a/stdlib/source/lux/macro/syntax/common.lux b/stdlib/source/lux/macro/syntax/common.lux
new file mode 100644
index 000000000..743768fe6
--- /dev/null
+++ b/stdlib/source/lux/macro/syntax/common.lux
@@ -0,0 +1,164 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monad)
+ (data (struct [list])
+ text/format)
+ [compiler]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax])))
+
+## Exports
+(type: #export Export-Level
+ #Exported
+ #Hidden)
+
+(def: #export export-level
+ (Syntax (Maybe Export-Level))
+ (s;opt (s;alt (s;tag! ["" "export"])
+ (s;tag! ["" "hidden"]))))
+
+(def: #export (gen-export-level ?el)
+ (-> (Maybe Export-Level) (List AST))
+ (case ?el
+ #;None
+ (list)
+
+ (#;Some #Exported)
+ (list (' #export))
+
+ (#;Some #Hidden)
+ (list (' #hidden))))
+
+## Declarations
+(type: #export Decl
+ {#decl-name Text
+ #decl-args (List Text)})
+
+(def: #export decl
+ (s;either (s;seq s;local-symbol
+ (:: s;Monad<Syntax> wrap (list)))
+ (s;form (s;seq s;local-symbol
+ (s;many s;local-symbol)))))
+
+## Definitions
+(type: #export Def-Syntax
+ {#def-name Text
+ #def-type (Maybe AST)
+ #def-value AST
+ #def-meta (List [Ident AST])
+ #def-args (List Text)
+ })
+
+(def: check^
+ (Syntax [(Maybe AST) AST])
+ (s;either (s;form (do s;Monad<Syntax>
+ [_ (s;symbol! ["lux" "_lux_:"])
+ type s;any
+ value s;any]
+ (wrap [(#;Some type) value])))
+ (s;seq (:: s;Monad<Syntax> wrap #;None)
+ s;any)))
+
+(def: _def-meta-tag^
+ (Syntax Ident)
+ (s;tuple (s;seq s;text s;text)))
+
+(def: (_def-meta^ _)
+ (-> Top (Syntax (List [Ident AST])))
+ (s;alt (s;tag! ["lux" "Nil"])
+ (s;form (do s;Monad<Syntax>
+ [_ (s;tag! ["lux" "Cons"])
+ [head tail] (s;seq (s;tuple (s;seq _def-meta-tag^ s;any))
+ (_def-meta^ []))]
+ (wrap [head tail])))
+ ))
+
+(def: (flat-list^ _)
+ (-> Top (Syntax (List AST)))
+ (s;either (do s;Monad<Syntax>
+ [_ (s;tag! ["lux" "Nil"])]
+ (wrap (list)))
+ (s;form (do s;Monad<Syntax>
+ [_ (s;tag! ["lux" "Cons"])
+ [head tail] (s;tuple (s;seq s;any s;any))
+ tail (s;local (list tail) (flat-list^ []))]
+ (wrap (#;Cons head tail))))))
+
+(def: list-meta^
+ (Syntax (List AST))
+ (s;form (do s;Monad<Syntax>
+ [_ (s;tag! ["lux" "ListM"])]
+ (flat-list^ []))))
+
+(def: text-meta^
+ (Syntax Text)
+ (s;form (do s;Monad<Syntax>
+ [_ (s;tag! ["lux" "TextM"])]
+ s;text)))
+
+(def: (find-def-args meta-data)
+ (-> (List [Ident AST]) (List Text))
+ (default (list)
+ (list;find (lambda [[tag value]]
+ (case tag
+ (^=> ["lux" "func-args"]
+ {(s;run (list value) list-meta^)
+ (#;Right [_ args])}
+ {(s;run args (s;some text-meta^))
+ (#;Right [_ args])})
+ (#;Some args)
+
+ _
+ #;None))
+ meta-data)))
+
+(def: #export (def compiler)
+ (-> Compiler (Syntax Def-Syntax))
+ (do s;Monad<Syntax>
+ [def-raw s;any
+ me-def-raw (s;on compiler
+ (compiler;macro-expand-all def-raw))]
+ (s;local me-def-raw
+ (s;form (do @
+ [_ (s;symbol! ["lux" "_lux_def"])
+ def-name s;local-symbol
+ [?def-type def-value] check^
+ def-meta s;any
+ def-meta (s;local (list def-meta)
+ (_def-meta^ []))
+ #let [def-args (find-def-args def-meta)]]
+ (wrap {#def-name def-name
+ #def-type ?def-type
+ #def-meta def-meta
+ #def-value def-value
+ #def-args def-args}))))))
+
+(def: #export (typed-de compiler)
+ (-> Compiler (Syntax Def-Syntax))
+ (do s;Monad<Syntax>
+ [_def (def compiler)
+ _ (case (get@ #def-type _def)
+ (#;Some _)
+ (wrap [])
+
+ #;None
+ (s;fail "Typed def must have a type!")
+ )]
+ (wrap _def)))
+
+(def: #export def-meta
+ (Syntax (List [Ident AST]))
+ (s;record (s;some (s;seq s;tag s;any))))
+
+(def: #export typed-arg
+ (Syntax [Text AST])
+ (s;record (s;seq s;local-symbol s;any)))
+
+(def: #export type-params
+ (Syntax (List Text))
+ (s;tuple (s;some s;local-symbol)))
diff --git a/stdlib/source/lux/macro/template.lux b/stdlib/source/lux/macro/template.lux
new file mode 100644
index 000000000..0288f05cf
--- /dev/null
+++ b/stdlib/source/lux/macro/template.lux
@@ -0,0 +1,54 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monad)
+ (data (struct [list "" Monad<List> Fold<List>]
+ [dict #+ Dict])
+ [text])
+ [compiler]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax]
+ (syntax [common]))))
+
+## [Syntax]
+(def: decl^
+ (Syntax [Text (List Text)])
+ (s;form (s;seq s;local-symbol (s;many s;local-symbol))))
+
+(def: (prepare bindings template)
+ (-> (Dict Text AST) AST AST)
+ (case template
+ (^=> [_ (#;SymbolS "" name)]
+ {(dict;get name bindings) (#;Some found)})
+ found
+
+ (^template [<tag>]
+ [meta (<tag> parts)]
+ [meta (<tag> (map (prepare bindings ) parts))])
+ ([#;FormS]
+ [#;TupleS])
+
+
+ [meta (#;RecordS pairs)]
+ [meta (#;RecordS (map (lambda [[slot value]]
+ [(prepare bindings slot)
+ (prepare bindings value)])
+ pairs))]
+
+ _
+ template
+ ))
+
+(syntax: #export (template: {_ex-lev common;export-level} {[name args] decl^} template)
+ (let [bindings (fold (lambda [arg bindings]
+ (dict;put arg (` ((~' ~) (~ (ast;symbol ["" arg])))) bindings))
+ (: (Dict Text AST) (dict;new text;Hash<Text>))
+ args)]
+ (wrap (list (` (syntax: (~@ (common;gen-export-level _ex-lev)) ((~ (ast;symbol ["" name]))
+ (~@ (map (|>. [""] ast;symbol) args)))
+ ((~' wrap) (list (` (~ (prepare bindings template)))))))))
+ ))
diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux
new file mode 100644
index 000000000..ffc13818f
--- /dev/null
+++ b/stdlib/source/lux/math.lux
@@ -0,0 +1,158 @@
+## 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/.
+
+(;module: {#;doc "Common numerical operations."}
+ lux
+ (lux (control monad)
+ (data (struct [list "" Fold<List>])
+ [number "Int/" Number<Int>]
+ [product]
+ text/format)
+ host
+ [compiler]
+ (macro ["s" syntax #+ syntax: Syntax "Syntax/" Functor<Syntax>]
+ [ast])))
+
+## [Values]
+(do-template [<name> <value>]
+ [(def: #export <name>
+ Real
+ (_lux_proc ["jvm" <value>] []))]
+
+ [e "getstatic:java.lang.Math:E"]
+ [pi "getstatic:java.lang.Math:PI"]
+ )
+
+(def: #export tau Real 6.28318530717958647692)
+
+(do-template [<name> <method>]
+ [(def: #export (<name> n)
+ (-> Real Real)
+ (_lux_proc ["jvm" <method>] [n]))]
+
+ [cos "invokestatic:java.lang.Math:cos:double"]
+ [sin "invokestatic:java.lang.Math:sin:double"]
+ [tan "invokestatic:java.lang.Math:tan:double"]
+
+ [acos "invokestatic:java.lang.Math:acos:double"]
+ [asin "invokestatic:java.lang.Math:asin:double"]
+ [atan "invokestatic:java.lang.Math:atan:double"]
+
+ [cosh "invokestatic:java.lang.Math:cosh:double"]
+ [sinh "invokestatic:java.lang.Math:sinh:double"]
+ [tanh "invokestatic:java.lang.Math:tanh:double"]
+
+ [exp "invokestatic:java.lang.Math:exp:double"]
+ [log "invokestatic:java.lang.Math:log:double"]
+
+ [cbrt "invokestatic:java.lang.Math:cbrt:double"]
+ [sqrt "invokestatic:java.lang.Math:sqrt:double"]
+
+ [degrees "invokestatic:java.lang.Math:toDegrees:double"]
+ [radians "invokestatic:java.lang.Math:toRadians:double"]
+ )
+
+(do-template [<name> <method>]
+ [(def: #export (<name> n)
+ (-> Real Real)
+ (_lux_proc ["jvm" <method>] [n]))]
+
+ [ceil "invokestatic:java.lang.Math:ceil:double"]
+ [floor "invokestatic:java.lang.Math:floor:double"]
+ )
+
+(def: #export (round n)
+ (-> Real Real)
+ (int-to-real (_lux_proc ["jvm" "invokestatic:java.lang.Math:round:double"] [n])))
+
+(do-template [<name> <method>]
+ [(def: #export (<name> param subject)
+ (-> Real Real Real)
+ (_lux_proc ["jvm" <method>] [subject param]))]
+
+ [atan2 "invokestatic:java.lang.Math:atan2:double,double"]
+ [pow "invokestatic:java.lang.Math:pow:double,double"]
+ )
+
+(def: (gcd' a b)
+ (-> Int Int Int)
+ (case b
+ 0 a
+ _ (gcd' b (% b a))))
+
+(def: #export (gcd a b)
+ {#;doc "Greatest Common Divisor."}
+ (-> Int Int Int)
+ (gcd' (Int/abs a) (Int/abs b)))
+
+(def: #export (lcm x y)
+ {#;doc "Least Common Multiple."}
+ (-> Int Int Int)
+ (case [x y]
+ (^or [_ 0] [0 _])
+ 0
+
+ _
+ (|> x (/ (gcd x y)) (* y) Int/abs)
+ ))
+
+## [Syntax]
+(type: #rec Infix
+ (#Const AST)
+ (#Call (List AST))
+ (#Infix Infix AST Infix))
+
+(def: (infix^ _)
+ (-> Unit (Syntax Infix))
+ ($_ s;alt
+ ($_ s;either
+ (Syntax/map ast;bool s;bool)
+ (Syntax/map ast;int s;int)
+ (Syntax/map ast;real s;real)
+ (Syntax/map ast;char s;char)
+ (Syntax/map ast;text s;text)
+ (Syntax/map ast;symbol s;symbol)
+ (Syntax/map ast;tag s;tag))
+ (s;form (s;many s;any))
+ (s;tuple (s;either (do s;Monad<Syntax>
+ [_ (s;tag! ["" "and"])
+ init-subject (infix^ [])
+ init-op s;any
+ init-param (infix^ [])
+ steps (s;some (s;seq s;any (infix^ [])))]
+ (wrap (product;right (fold (lambda [[op param] [subject [_subject _op _param]]]
+ [param [(#Infix _subject _op _param)
+ (` and)
+ (#Infix subject op param)]])
+ [init-param [init-subject init-op init-param]]
+ steps))))
+ (do s;Monad<Syntax>
+ [_ (wrap [])
+ init-subject (infix^ [])
+ init-op s;any
+ init-param (infix^ [])
+ steps (s;some (s;seq s;any (infix^ [])))]
+ (wrap (fold (lambda [[op param] [_subject _op _param]]
+ [(#Infix _subject _op _param) op param])
+ [init-subject init-op init-param]
+ steps)))
+ ))
+ ))
+
+(def: (infix-to-prefix infix)
+ (-> Infix AST)
+ (case infix
+ (#Const value)
+ value
+
+ (#Call parts)
+ (ast;form parts)
+
+ (#Infix left op right)
+ (` ((~ op) (~ (infix-to-prefix right)) (~ (infix-to-prefix left))))
+ ))
+
+(syntax: #export (infix {expr (infix^ [])})
+ (wrap (list (infix-to-prefix expr))))
diff --git a/stdlib/source/lux/math/complex.lux b/stdlib/source/lux/math/complex.lux
new file mode 100644
index 000000000..eb7796bb2
--- /dev/null
+++ b/stdlib/source/lux/math/complex.lux
@@ -0,0 +1,291 @@
+## 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/.
+
+(;module:
+ lux
+ (lux [math]
+ (control eq
+ [ord]
+ number
+ codec
+ monad)
+ (data [number "r:" Number<Real> Codec<Text,Real>]
+ [text "Text/" Monoid<Text>]
+ error
+ maybe
+ (struct [list "List/" Monad<List>]))
+ [compiler]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax])))
+
+## Based on org.apache.commons.math4.complex.Complex
+
+(type: #export Complex
+ {#real Real
+ #imaginary Real})
+
+(syntax: #export (complex real {?imaginary (s;opt s;any)})
+ (wrap (list (` {#;;real (~ real)
+ #;;imaginary (~ (default (` 0.0)
+ ?imaginary))}))))
+
+(def: #export i Complex (complex 0.0 1.0))
+
+(def: #export one Complex (complex 1.0 0.0))
+
+(def: #export zero Complex (complex 0.0 0.0))
+
+(def: #export (c= param input)
+ (-> Complex Complex Bool)
+ (and (=. (get@ #real param)
+ (get@ #real input))
+ (=. (get@ #imaginary param)
+ (get@ #imaginary input))))
+
+(do-template [<name> <op>]
+ [(def: #export (<name> param input)
+ (-> Complex Complex Complex)
+ {#real (<op> (get@ #real param)
+ (get@ #real input))
+ #imaginary (<op> (get@ #imaginary param)
+ (get@ #imaginary input))})]
+
+ [c+ +.]
+ [c- -.]
+ )
+
+(struct: #export _ (Eq Complex)
+ (def: = c=))
+
+(def: #export negate
+ (-> Complex Complex)
+ (|>. (update@ #real r:negate)
+ (update@ #imaginary r:negate)))
+
+(def: #export signum
+ (-> Complex Complex)
+ (|>. (update@ #real r:signum)
+ (update@ #imaginary r:signum)))
+
+(def: #export conjugate
+ (-> Complex Complex)
+ (update@ #imaginary r:negate))
+
+(def: #export (c*' param input)
+ (-> Real Complex Complex)
+ {#real (*. param
+ (get@ #real input))
+ #imaginary (*. param
+ (get@ #imaginary input))})
+
+(def: #export (c* param input)
+ (-> Complex Complex Complex)
+ {#real (-. (*. (get@ #imaginary param)
+ (get@ #imaginary input))
+ (*. (get@ #real param)
+ (get@ #real input)))
+ #imaginary (+. (*. (get@ #real param)
+ (get@ #imaginary input))
+ (*. (get@ #imaginary param)
+ (get@ #real input)))})
+
+(def: #export (c/ (^slots [#real #imaginary]) input)
+ (-> Complex Complex Complex)
+ (if (<. (r:abs imaginary)
+ (r:abs real))
+ (let [quot (/. imaginary real)
+ denom (|> real (*. quot) (+. imaginary))]
+ {#real (|> (get@ #real input) (*. quot) (+. (get@ #imaginary input)) (/. denom))
+ #imaginary (|> (get@ #imaginary input) (*. quot) (-. (get@ #real input)) (/. denom))})
+ (let [quot (/. real imaginary)
+ denom (|> imaginary (*. quot) (+. real))]
+ {#real (|> (get@ #imaginary input) (*. quot) (+. (get@ #real input)) (/. denom))
+ #imaginary (|> (get@ #imaginary input) (-. (*. quot (get@ #real input))) (/. denom))})))
+
+(def: #export (c/' param (^slots [#real #imaginary]))
+ (-> Real Complex Complex)
+ {#real (/. param real)
+ #imaginary (/. param imaginary)})
+
+(def: #export (cos (^slots [#real #imaginary]))
+ (-> Complex Complex)
+ {#real (*. (math;cosh imaginary)
+ (math;cos real))
+ #imaginary (*. (math;sinh imaginary)
+ (r:negate (math;sin real)))})
+
+(def: #export (cosh (^slots [#real #imaginary]))
+ (-> Complex Complex)
+ {#real (*. (math;cos imaginary)
+ (math;cosh real))
+ #imaginary (*. (math;sin imaginary)
+ (math;sinh real))})
+
+(def: #export (sin (^slots [#real #imaginary]))
+ (-> Complex Complex)
+ {#real (*. (math;cosh imaginary)
+ (math;sin real))
+ #imaginary (*. (math;sinh imaginary)
+ (math;cos real))})
+
+(def: #export (sinh (^slots [#real #imaginary]))
+ (-> Complex Complex)
+ {#real (*. (math;cos imaginary)
+ (math;sinh real))
+ #imaginary (*. (math;sin imaginary)
+ (math;cosh real))})
+
+(def: #export (tan (^slots [#real #imaginary]))
+ (-> Complex Complex)
+ (let [r2 (*. 2.0 real)
+ i2 (*. 2.0 imaginary)
+ d (+. (math;cos r2) (math;cosh i2))]
+ {#real (/. d (math;sin r2))
+ #imaginary (/. d (math;sinh i2))}))
+
+(def: #export (tanh (^slots [#real #imaginary]))
+ (-> Complex Complex)
+ (let [r2 (*. 2.0 real)
+ i2 (*. 2.0 imaginary)
+ d (+. (math;cosh r2) (math;cos i2))]
+ {#real (/. d (math;sinh r2))
+ #imaginary (/. d (math;sin i2))}))
+
+(def: #export (abs (^slots [#real #imaginary]))
+ (-> Complex Real)
+ (if (<. (r:abs imaginary)
+ (r:abs real))
+ (if (=. 0.0 imaginary)
+ (r:abs real)
+ (let [q (/. imaginary real)]
+ (*. (math;sqrt (+. 1.0 (*. q q)))
+ (r:abs imaginary))))
+ (if (=. 0.0 real)
+ (r:abs imaginary)
+ (let [q (/. real imaginary)]
+ (*. (math;sqrt (+. 1.0 (*. q q)))
+ (r:abs real))))
+ ))
+
+(def: #export (exp (^slots [#real #imaginary]))
+ (-> Complex Complex)
+ (let [r-exp (math;exp real)]
+ {#real (*. r-exp (math;cos imaginary))
+ #imaginary (*. r-exp (math;sin imaginary))}))
+
+(def: #export (log (^@ input (^slots [#real #imaginary])))
+ (-> Complex Complex)
+ {#real (math;log (abs input))
+ #imaginary (math;atan2 real imaginary)})
+
+(do-template [<name> <type> <op>]
+ [(def: #export (<name> param input)
+ (-> <type> Complex Complex)
+ (|> input log (<op> param) exp))]
+
+ [pow Complex c*]
+ [pow' Real c*']
+ )
+
+(def: (copy-sign sign magnitude)
+ (-> Real Real Real)
+ (*. (r:signum sign) magnitude))
+
+(def: #export (sqrt (^@ input (^slots [#real #imaginary])))
+ (-> Complex Complex)
+ (let [t (|> input abs (+. (r:abs real)) (/. 2.0) math;sqrt)]
+ (if (>=. 0.0 real)
+ {#real t
+ #imaginary (/. (*. 2.0 t)
+ imaginary)}
+ {#real (/. (*. 2.0 t)
+ (r:abs imaginary))
+ #imaginary (*. t (copy-sign imaginary 1.0))})))
+
+(def: #export (sqrt-1z input)
+ (-> Complex Complex)
+ (|> (complex 1.0) (c- (c* input input)) sqrt))
+
+(def: #export (reciprocal (^slots [#real #imaginary]))
+ (-> Complex Complex)
+ (if (<. (r:abs imaginary)
+ (r:abs real))
+ (let [q (/. imaginary real)
+ scale (/. (|> real (*. q) (+. imaginary))
+ 1.0)]
+ {#real (*. q scale)
+ #imaginary (r:negate scale)})
+ (let [q (/. real imaginary)
+ scale (/. (|> imaginary (*. q) (+. real))
+ 1.0)]
+ {#real scale
+ #imaginary (|> scale r:negate (*. q))})))
+
+(def: #export (acos input)
+ (-> Complex Complex)
+ (|> input
+ (c+ (|> input sqrt-1z (c* i)))
+ log
+ (c* (negate i))))
+
+(def: #export (asin input)
+ (-> Complex Complex)
+ (|> input
+ sqrt-1z
+ (c+ (c* i input))
+ log
+ (c* (negate i))))
+
+(def: #export (atan input)
+ (-> Complex Complex)
+ (|> input
+ (c+ i)
+ (c/ (c- input i))
+ log
+ (c* (c/ (complex 2.0) i))))
+
+(def: #export (argument (^slots [#real #imaginary]))
+ (-> Complex Real)
+ (math;atan2 real imaginary))
+
+(def: #export (nth-root nth input)
+ (-> Nat Complex (List Complex))
+ (if (=+ +0 nth)
+ (list)
+ (let [r-nth (|> nth nat-to-int int-to-real)
+ nth-root-of-abs (math;pow (/. r-nth 1.0)
+ (abs input))
+ nth-phi (|> input argument (/. r-nth))
+ slice (|> math;pi (*. 2.0) (/. r-nth))]
+ (|> (list;range+ +0 (dec+ nth))
+ (List/map (lambda [nth']
+ (let [inner (|> nth' nat-to-int int-to-real
+ (*. slice)
+ (+. nth-phi))
+ real (*. nth-root-of-abs
+ (math;cos inner))
+ imaginary (*. nth-root-of-abs
+ (math;sin inner))]
+ {#real real
+ #imaginary imaginary})))))))
+
+(struct: #export _ (Codec Text Complex)
+ (def: (encode (^slots [#real #imaginary]))
+ ($_ Text/append "(" (r:encode real) ", " (r:encode imaginary) ")"))
+
+ (def: (decode input)
+ (case (do Monad<Maybe>
+ [input' (text;sub +1 (-+ +1 (text;size input)) input)]
+ (text;split-with "," input'))
+ #;None
+ (#;Left (Text/append "Wrong syntax for complex numbers: " input))
+
+ (#;Some [r' i'])
+ (do Monad<Error>
+ [r (r:decode (text;trim r'))
+ i (r:decode (text;trim i'))]
+ (wrap {#real r
+ #imaginary i}))
+ )))
diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux
new file mode 100644
index 000000000..aee5674ad
--- /dev/null
+++ b/stdlib/source/lux/math/random.lux
@@ -0,0 +1,283 @@
+## 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/.
+
+(;module:
+ [lux #- list]
+ (lux (control functor
+ applicative
+ monad
+ hash)
+ (data [bit]
+ [char]
+ [text "Text/" Monoid<Text>]
+ text/format
+ [product]
+ [number]
+ (struct [list "List/" Fold<List>]
+ ["A" array]
+ ["D" dict]
+ ["Q" queue]
+ ["S" set]
+ ["ST" stack]
+ ["V" vector]))
+ (math ["r" ratio]
+ ["c" complex])))
+
+## [Exports]
+(type: #export #rec PRNG
+ (-> Unit [PRNG Nat]))
+
+(type: #export (Random a)
+ (-> PRNG [PRNG a]))
+
+(struct: #export _ (Functor Random)
+ (def: (map f fa)
+ (lambda [state]
+ (let [[state' a] (fa state)]
+ [state' (f a)]))))
+
+(struct: #export _ (Applicative Random)
+ (def: functor Functor<Random>)
+
+ (def: (wrap a)
+ (lambda [state]
+ [state a]))
+
+ (def: (apply ff fa)
+ (lambda [state]
+ (let [[state' f] (ff state)
+ [state'' a] (fa state')]
+ [state'' (f a)]))))
+
+(struct: #export _ (Monad Random)
+ (def: applicative Applicative<Random>)
+
+ (def: (join ffa)
+ (lambda [state]
+ (let [[state' fa] (ffa state)]
+ (fa state')))))
+
+(def: #export nat
+ (Random Nat)
+ (lambda [prng]
+ (let [[prng left] (prng [])
+ [prng right] (prng [])]
+ [prng (++ (bit;<< +32 left)
+ right)])))
+
+(def: #export int
+ (Random Int)
+ (lambda [prng]
+ (let [[prng left] (prng [])
+ [prng right] (prng [])]
+ [prng (nat-to-int (++ (bit;<< +32 left)
+ right))])))
+
+(def: #export bool
+ (Random Bool)
+ (lambda [prng]
+ (let [[prng output] (prng [])]
+ [prng (|> output (bit;& +1) (=+ +1))])))
+
+(def: (bits n)
+ (-> Nat (Random Nat))
+ (lambda [prng]
+ (let [[prng output] (prng [])]
+ [prng (bit;>>> (-+ n +64) output)])))
+
+(def: #export real
+ (Random Real)
+ (do Monad<Random>
+ [left (bits +26)
+ right (bits +27)]
+ (wrap (|> right
+ (++ (bit;<< +27 left))
+ nat-to-int
+ int-to-real
+ (/. (|> +1 (bit;<< +53) nat-to-int int-to-real))))))
+
+(def: #export frac
+ (Random Frac)
+ (:: Monad<Random> map real-to-frac real))
+
+(def: #export char
+ (Random Char)
+ (do Monad<Random>
+ [base nat]
+ (wrap (char;char base))))
+
+(def: #export (text' char-gen size)
+ (-> (Random Char) Nat (Random Text))
+ (if (=+ +0 size)
+ (:: Monad<Random> wrap "")
+ (do Monad<Random>
+ [x char-gen
+ xs (text' char-gen (dec+ size))]
+ (wrap (Text/append (char;as-text x) xs)))))
+
+(def: #export (text size)
+ (-> Nat (Random Text))
+ (text' char size))
+
+(do-template [<name> <type> <ctor> <gen>]
+ [(def: #export <name>
+ (Random <type>)
+ (do Monad<Random>
+ [left <gen>
+ right <gen>]
+ (wrap (<ctor> left right))))]
+
+ [ratio r;Ratio r;ratio int]
+ [complex c;Complex c;complex real]
+ )
+
+(def: #export (seq left right)
+ (All [a b] (-> (Random a) (Random b) (Random [a b])))
+ (do Monad<Random>
+ [=left left
+ =right right]
+ (wrap [=left =right])))
+
+(def: #export (alt left right)
+ (All [a b] (-> (Random a) (Random b) (Random (| a b))))
+ (do Monad<Random>
+ [? bool]
+ (if ?
+ (do @
+ [=left left]
+ (wrap (+0 =left)))
+ (do @
+ [=right right]
+ (wrap (+1 =right))))))
+
+(def: #export (either left right)
+ (All [a] (-> (Random a) (Random a) (Random a)))
+ (do Monad<Random>
+ [? bool]
+ (if ?
+ left
+ right)))
+
+(def: #export (rec gen)
+ (All [a] (-> (-> (Random a) (Random a)) (Random a)))
+ (lambda [state]
+ (let [gen' (gen (rec gen))]
+ (gen' state))))
+
+(def: #export (filter pred gen)
+ (All [a] (-> (-> a Bool) (Random a) (Random a)))
+ (do Monad<Random>
+ [sample gen]
+ (if (pred sample)
+ (wrap sample)
+ (filter pred gen))))
+
+(do-template [<name> <type> <zero> <plus>]
+ [(def: #export (<name> size value-gen)
+ (All [a] (-> Nat (Random a) (Random (<type> a))))
+ (if (>+ +0 size)
+ (do Monad<Random>
+ [x value-gen
+ xs (<name> (dec+ size) value-gen)]
+ (wrap (<plus> x xs)))
+ (:: Monad<Random> wrap <zero>)))]
+
+ [list List (;list) #;Cons]
+ [vector V;Vector V;empty V;add]
+ )
+
+(do-template [<name> <type> <ctor>]
+ [(def: #export (<name> size value-gen)
+ (All [a] (-> Nat (Random a) (Random (<type> a))))
+ (do Monad<Random>
+ [values (list size value-gen)]
+ (wrap (|> values <ctor>))))]
+
+ [array A;Array A;from-list]
+ [queue Q;Queue Q;from-list]
+ [stack ST;Stack (List/fold ST;push ST;empty)]
+ )
+
+(def: #export (set a/Hash size value-gen)
+ (All [a] (-> (Hash a) Nat (Random a) (Random (S;Set a))))
+ (if (>+ +0 size)
+ (do Monad<Random>
+ [xs (set a/Hash (dec+ size) value-gen)]
+ (loop [_ []]
+ (do @
+ [x value-gen
+ #let [xs+ (S;add x xs)]]
+ (if (=+ size (S;size xs+))
+ (wrap xs+)
+ (recur [])))))
+ (:: Monad<Random> wrap (S;new a/Hash))))
+
+(def: #export (dict a/Hash size key-gen value-gen)
+ (All [k v] (-> (Hash k) Nat (Random k) (Random v) (Random (D;Dict k v))))
+ (if (>+ +0 size)
+ (do Monad<Random>
+ [kv (dict a/Hash (dec+ size) key-gen value-gen)]
+ (loop [_ []]
+ (do @
+ [k key-gen
+ v value-gen
+ #let [kv+ (D;put k v kv)]]
+ (if (=+ size (D;size kv+))
+ (wrap kv+)
+ (recur [])))))
+ (:: Monad<Random> wrap (D;new a/Hash))))
+
+(def: #export (run prng calc)
+ (All [a] (-> PRNG (Random a) [PRNG a]))
+ (calc prng))
+
+## [PRNGs]
+## PCG32 http://www.pcg-random.org/
+## Based on this Java implementation: https://github.com/alexeyr/pcg-java
+
+(def: pcg-32-magic-mult Nat +6364136223846793005)
+
+(def: #export (pcg-32 [inc seed])
+ (-> [Nat Nat] PRNG)
+ (lambda [_]
+ (let [seed' (|> seed (*+ pcg-32-magic-mult) (++ inc))
+ xor-shifted (|> seed (bit;>>> +18) (bit;^ seed) (bit;>>> +27))
+ rot (|> seed (bit;>>> +59))]
+ [(pcg-32 [inc seed']) (bit;rotate-right rot xor-shifted)]
+ )))
+
+## Xoroshiro128+ http://xoroshiro.di.unimi.it/
+(def: #export (xoroshiro-128+ [s0 s1])
+ (-> [Nat Nat] PRNG)
+ (lambda [_]
+ (let [result (++ s0 s1)
+ s01 (bit;^ s0 s1)
+ s0' (|> (bit;rotate-left +55 s0)
+ (bit;^ s01)
+ (bit;^ (bit;<< +14 s01)))
+ s1' (bit;rotate-left +36 s01)]
+ [(xoroshiro-128+ [s0' s1']) result])
+ ))
+
+## [Values]
+(def: (swap from to vec)
+ (All [a] (-> Nat Nat (V;Vector a) (V;Vector a)))
+ (V;put to (default (undefined)
+ (V;at from vec))
+ vec))
+
+(def: #export (shuffle seed vector)
+ (All [a] (-> Nat (V;Vector a) (V;Vector a)))
+ (let [_size (V;size vector)
+ _shuffle (foldM Monad<Random>
+ (lambda [idx vec]
+ (do Monad<Random>
+ [rand nat]
+ (wrap (swap idx (%+ _size rand) vec))))
+ vector
+ (list;range+ +0 (dec+ _size)))]
+ (|> _shuffle
+ (run (pcg-32 [+123 seed]))
+ product;right)))
diff --git a/stdlib/source/lux/math/ratio.lux b/stdlib/source/lux/math/ratio.lux
new file mode 100644
index 000000000..89d93aa5d
--- /dev/null
+++ b/stdlib/source/lux/math/ratio.lux
@@ -0,0 +1,141 @@
+## 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/.
+
+(;module:
+ lux
+ (lux [math]
+ (control eq
+ [ord]
+ number
+ codec
+ monad)
+ (data [number "i:" Number<Int> Codec<Text,Int>]
+ [text "Text/" Monoid<Text>]
+ error)
+ [compiler]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax])))
+
+(type: #export Ratio
+ {#numerator Int
+ #denominator Int})
+
+(def: #hidden (normalize (^slots [#numerator #denominator]))
+ (-> Ratio Ratio)
+ (let [common (math;gcd numerator denominator)
+ numerator (/ common numerator)
+ denominator (/ common denominator)]
+ {#numerator (if (and (< 0 numerator)
+ (< 0 denominator))
+ (i:abs numerator)
+ numerator)
+ #denominator (i:abs denominator)}))
+
+(def: #export (r* param input)
+ (-> Ratio Ratio Ratio)
+ (normalize [(* (get@ #numerator param)
+ (get@ #numerator input))
+ (* (get@ #denominator param)
+ (get@ #denominator input))]))
+
+(def: #export (r/ param input)
+ (-> Ratio Ratio Ratio)
+ (normalize [(* (get@ #denominator param)
+ (get@ #numerator input))
+ (* (get@ #numerator param)
+ (get@ #denominator input))]))
+
+(def: #export (r+ param input)
+ (-> Ratio Ratio Ratio)
+ (normalize [(+ (* (get@ #denominator input)
+ (get@ #numerator param))
+ (* (get@ #denominator param)
+ (get@ #numerator input)))
+ (* (get@ #denominator param)
+ (get@ #denominator input))]))
+
+(def: #export (r- param input)
+ (-> Ratio Ratio Ratio)
+ (normalize [(- (* (get@ #denominator input)
+ (get@ #numerator param))
+ (* (get@ #denominator param)
+ (get@ #numerator input)))
+ (* (get@ #denominator param)
+ (get@ #denominator input))]))
+
+(def: #export (r% param input)
+ (-> Ratio Ratio Ratio)
+ (let [quot (/ (* (get@ #denominator input)
+ (get@ #numerator param))
+ (* (get@ #denominator param)
+ (get@ #numerator input)))]
+ (r- (update@ #numerator (* quot) param)
+ input)))
+
+(def: #export (r= param input)
+ (-> Ratio Ratio Bool)
+ (and (= (get@ #numerator param)
+ (get@ #numerator input))
+ (= (get@ #denominator param)
+ (get@ #denominator input))))
+
+(do-template [<name> <op>]
+ [(def: #export (<name> param input)
+ (-> Ratio Ratio Bool)
+ (and (<op> (* (get@ #denominator input)
+ (get@ #numerator param))
+ (* (get@ #denominator param)
+ (get@ #numerator input)))))]
+
+ [r< <]
+ [r<= <=]
+ [r> >]
+ [r>= >=]
+ )
+
+(struct: #export _ (Eq Ratio)
+ (def: = r=))
+
+(struct: #export _ (ord;Ord Ratio)
+ (def: eq Eq<Ratio>)
+ (def: < r<)
+ (def: <= r<=)
+ (def: > r>)
+ (def: >= r>=))
+
+(struct: #export _ (Number Ratio)
+ (def: ord Ord<Ratio>)
+ (def: + r+)
+ (def: - r-)
+ (def: * r*)
+ (def: / r/)
+ (def: % r%)
+ (def: negate (|>. (update@ #numerator i:negate) normalize))
+ (def: abs (|>. (update@ #numerator i:abs) (update@ #denominator i:abs)))
+ (def: (signum x)
+ {#numerator (i:signum (get@ #numerator x))
+ #denominator 1}))
+
+(def: separator Text ":")
+
+(struct: #export _ (Codec Text Ratio)
+ (def: (encode (^slots [#numerator #denominator]))
+ ($_ Text/append (i:encode numerator) separator (i:encode denominator)))
+
+ (def: (decode input)
+ (case (text;split-with separator input)
+ (#;Some [num denom])
+ (do Monad<Error>
+ [numerator (i:decode num)
+ denominator (i:decode denom)]
+ (wrap (normalize {#numerator numerator
+ #denominator denominator})))
+
+ #;None
+ (#;Left (Text/append "Invalid syntax for ratio: " input)))))
+
+(syntax: #export (ratio numerator denominator)
+ (wrap (list (` (normalize {#;;numerator (~ numerator)
+ #;;denominator (~ denominator)})))))
diff --git a/stdlib/source/lux/pipe.lux b/stdlib/source/lux/pipe.lux
new file mode 100644
index 000000000..b1316f238
--- /dev/null
+++ b/stdlib/source/lux/pipe.lux
@@ -0,0 +1,147 @@
+## 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/.
+
+(;module: {#;doc "Composable extensions to the piping macro |> that enhance it with various abilities."}
+ lux
+ (lux (control monad)
+ (data (struct [list #+ Monad<List> "" Fold<List> "List/" Monad<List>])
+ maybe)
+ [compiler #+ with-gensyms Monad<Lux>]
+ (macro ["s" syntax #+ syntax: Syntax]
+ [ast])
+ ))
+
+## [Syntax]
+(def: body^
+ (Syntax (List AST))
+ (s;tuple (s;many s;any)))
+
+(syntax: #export (_> {tokens (s;at-least +2 s;any)})
+ {#;doc (doc "Ignores the piped argument, and begins a new pipe."
+ (|> 20
+ (* 3)
+ (+ 4)
+ (_> 0 inc)))}
+ (case (list;reverse tokens)
+ (^ (list& _ r-body))
+ (wrap (list (` (|> (~@ (list;reverse r-body))))))
+
+ _
+ (undefined)))
+
+(syntax: #export (@> {body body^}
+ prev)
+ {#;doc (doc "Gives the name '@' to the piped-argument, within the given expression."
+ (|> 5
+ (@> [(+ @ @)])))}
+ (wrap (list (fold (lambda [next prev]
+ (` (let% [(~' @) (~ prev)]
+ (~ next))))
+ prev
+ body))))
+
+(syntax: #export (?> {branches (s;many (s;seq body^ body^))}
+ {?else (s;opt body^)}
+ prev)
+ {#;doc (doc "Branching for pipes."
+ "Both the tests and the bodies are piped-code, and must be given inside a tuple."
+ "If a last else-pipe isn't given, the piped-argument will be used instead."
+ (|> 5
+ (?> [even?] [(* 2)]
+ [odd?] [(* 3)]
+ [(_> -1)])))}
+ (with-gensyms [g!temp]
+ (wrap (list (` (let% [(~ g!temp) (~ prev)]
+ (cond (~@ (do Monad<List>
+ [[test then] branches]
+ (list (` (|> (~ g!temp) (~@ test)))
+ (` (|> (~ g!temp) (~@ then))))))
+ (~ (case ?else
+ (#;Some else)
+ (` (|> (~ g!temp) (~@ else)))
+
+ _
+ g!temp)))))))))
+
+(syntax: #export (!> {test body^} {then body^} prev)
+ {#;doc (doc
+ "Loops for pipes."
+ "Both the testing and calculating steps are pipes and must be given inside tuples."
+ (|> 1
+ (!> [(< 10)]
+ [inc])))}
+ (with-gensyms [g!temp]
+ (wrap (list (` (loop [(~ g!temp) (~ prev)]
+ (if (|> (~ g!temp) (~@ test))
+ ((~' recur) (|> (~ g!temp) (~@ then)))
+ (~ g!temp))))))))
+
+(syntax: #export (%> monad {steps (s;some body^)} prev)
+ {#;doc (doc "Monadic pipes."
+ "Each steps in the monadic computation is a pipe and must be given inside a tuple."
+ (|> 5
+ (%> Id/Monad
+ [(* 3)]
+ [(+ 4)]
+ [inc])))}
+ (with-gensyms [g!temp]
+ (case (list;reverse steps)
+ (^ (list& last-step prev-steps))
+ (let [step-bindings (do Monad<List>
+ [step (list;reverse prev-steps)]
+ (list g!temp (` (|> (~ g!temp) (~@ step)))))]
+ (wrap (list (` (do (~ monad)
+ [(~ g!temp) (~ prev)
+ (~@ step-bindings)]
+ (|> (~ g!temp) (~@ last-step)))))))
+
+ _
+ (wrap (list prev)))))
+
+(syntax: #export (~> {body body^} prev)
+ {#;doc (doc "Non-updating pipes."
+ "Will generate piped computations, but their results won't be used in the larger scope."
+ (|> 5
+ (~> [int-to-nat %n log!])
+ (* 10)))}
+ (do @
+ [g!temp (compiler;gensym "")]
+ (wrap (list (` (let [(~ g!temp) (~ prev)]
+ (exec (|> (~ g!temp) (~@ body))
+ (~ g!temp))))))))
+
+(syntax: #export (&> {paths (s;many body^)} prev)
+ {#;doc (doc "Parallel branching for pipes."
+ "Allows to run multiple pipelines for a value and gives you a tuple of the outputs."
+ (|> 5
+ (&> [(* 10)]
+ [dec (/ 2)]
+ [Int/encode]))
+ "Will become: [50 2 \"5\"]")}
+ (do @
+ [g!temp (compiler;gensym "")]
+ (wrap (list (` (let [(~ g!temp) (~ prev)]
+ [(~@ (List/map (lambda [body] (` (|> (~ g!temp) (~@ body))))
+ paths))]))))))
+
+(syntax: #export (case> {branches (s;many (s;seq s;any s;any))} prev)
+ {#;doc (doc "Pattern-matching for pipes."
+ "The bodies of each branch are NOT pipes; just regular values."
+ (|> 5
+ (case> 0 "zero"
+ 1 "one"
+ 2 "two"
+ 3 "three"
+ 4 "four"
+ 5 "five"
+ 6 "six"
+ 7 "seven"
+ 8 "eight"
+ 9 "nine"
+ _ "???")))}
+ (let [(^open "List/") Monad<List>]
+ (wrap (list (` (case (~ prev)
+ (~@ (List/join (List/map (lambda [[pattern body]] (list pattern body))
+ branches)))))))))
diff --git a/stdlib/source/lux/regex.lux b/stdlib/source/lux/regex.lux
new file mode 100644
index 000000000..1d98d6bf5
--- /dev/null
+++ b/stdlib/source/lux/regex.lux
@@ -0,0 +1,432 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monad)
+ (data [char]
+ [text]
+ text/format
+ [number "Int/" Codec<Text,Int>]
+ [product]
+ (struct [list "" Fold<List> "List/" Monad<List>]))
+ [compiler #- run]
+ (macro [ast]
+ [syntax #+ syntax:])
+ ["&" lexer #+ Lexer Monad<Lexer>]))
+
+## [Utils]
+(def: #hidden (->Text lexer^)
+ (-> (Lexer Char) (Lexer Text))
+ (do Monad<Lexer>
+ [output lexer^]
+ (wrap (char;as-text output))))
+
+(def: regex-char^
+ (Lexer Char)
+ (&;none-of "\\.|&()[]{}"))
+
+(def: escaped-char^
+ (Lexer Char)
+ (do Monad<Lexer>
+ [? (&;opt (&;this-char #"\\"))
+ char (case ?
+ (#;Some _) &;any
+ #;None regex-char^)]
+ (wrap char)))
+
+(def: (local^ state lexer)
+ (All [a] (-> Text (Lexer a) (Lexer a)))
+ (lambda [old-state]
+ (case (lexer state)
+ (#;Left error)
+ (#;Left error)
+
+ (#;Right [_ value])
+ (#;Right [old-state value]))))
+
+(def: #hidden (refine^ refinement^ base^)
+ (All [a] (-> (Lexer a) (Lexer Text) (Lexer Text)))
+ (do Monad<Lexer>
+ [output base^
+ _ (local^ output refinement^)]
+ (wrap output)))
+
+(def: #hidden word^
+ (Lexer Char)
+ (&;either &;alpha-num
+ (&;this-char #"_")))
+
+(def: #hidden (join-text^ part^)
+ (-> (Lexer (List Text)) (Lexer Text))
+ (do Monad<Lexer>
+ [parts part^]
+ (wrap (text;join-with "" parts))))
+
+(def: identifier-char^
+ (Lexer Char)
+ (&;none-of "[]{}()s\"#;<>"))
+
+(def: identifier-part^
+ (Lexer Text)
+ (do Monad<Lexer>
+ [head (refine^ (&;not &;digit)
+ (->Text identifier-char^))
+ tail (&;some' identifier-char^)]
+ (wrap (format head tail))))
+
+(def: (identifier^ current-module)
+ (-> Text (Lexer Ident))
+ (do Monad<Lexer>
+ []
+ ($_ &;either
+ (&;seq (wrap current-module) (&;_& (&;this ";;") identifier-part^))
+ (&;seq identifier-part^ (&;_& (&;this ";") identifier-part^))
+ (&;seq (wrap "lux") (&;_& (&;this ";") identifier-part^))
+ (&;seq (wrap "") identifier-part^))))
+
+(def: (re-var^ current-module)
+ (-> Text (Lexer AST))
+ (do Monad<Lexer>
+ [ident (&;enclosed ["\\@<" ">"] (identifier^ current-module))]
+ (wrap (` (: (Lexer Text) (~ (ast;symbol ident)))))))
+
+(def: re-char-range^
+ (Lexer AST)
+ (do Monad<Lexer>
+ [from regex-char^
+ _ (&;this-char #"-")
+ to regex-char^]
+ (wrap (` (&;char-range (~ (ast;char from)) (~ (ast;char to)))))))
+
+(def: re-char^
+ (Lexer AST)
+ (do Monad<Lexer>
+ [char escaped-char^]
+ (wrap (` (&;this-char (~ (ast;char char)))))))
+
+(def: re-char+^
+ (Lexer AST)
+ (do Monad<Lexer>
+ [base re-char^]
+ (wrap (` (->Text (~ base))))))
+
+(def: re-char-options^
+ (Lexer AST)
+ (do Monad<Lexer>
+ [options (&;many' escaped-char^)]
+ (wrap (` (&;one-of (~ (ast;text options)))))))
+
+(def: re-user-class^'
+ (Lexer AST)
+ (do Monad<Lexer>
+ [negate? (&;opt (&;this-char #"^"))
+ parts (&;many ($_ &;either
+ re-char-range^
+ re-char-options^))]
+ (wrap (case negate?
+ (#;Some _) (` (->Text (&;not ($_ &;either (~@ parts)))))
+ #;None (` (->Text ($_ &;either (~@ parts))))))))
+
+(def: re-user-class^
+ (Lexer AST)
+ (do Monad<Lexer>
+ [_ (wrap [])
+ init re-user-class^'
+ rest (&;some (&;_& (&;this "&&") (&;enclosed ["[" "]"] re-user-class^')))]
+ (wrap (fold (lambda [refinement base]
+ (` (refine^ (~ refinement) (~ base))))
+ init
+ rest))))
+
+(def: #hidden blank^
+ (Lexer Char)
+ (&;one-of " \t"))
+
+(def: #hidden ascii^
+ (Lexer Char)
+ (&;char-range #"\u0000" #"\u007F"))
+
+(def: #hidden control^
+ (Lexer Char)
+ (&;either (&;char-range #"\u0000" #"\u001F")
+ (&;this-char #"\u007F")))
+
+(def: #hidden punct^
+ (Lexer Char)
+ (&;one-of "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~"))
+
+(def: #hidden graph^
+ (Lexer Char)
+ (&;either punct^ &;alpha-num))
+
+(def: #hidden print^
+ (Lexer Char)
+ (&;either graph^
+ (&;this-char #"\u0020")))
+
+(def: re-system-class^
+ (Lexer AST)
+ (do Monad<Lexer>
+ []
+ ($_ &;either
+ (&;_& (&;this-char #".") (wrap (` (->Text &;any))))
+ (&;_& (&;this "\\d") (wrap (` (->Text &;digit))))
+ (&;_& (&;this "\\D") (wrap (` (->Text (&;not &;digit)))))
+ (&;_& (&;this "\\s") (wrap (` (->Text &;space))))
+ (&;_& (&;this "\\S") (wrap (` (->Text (&;not &;space)))))
+ (&;_& (&;this "\\w") (wrap (` (->Text word^))))
+ (&;_& (&;this "\\W") (wrap (` (->Text (&;not word^)))))
+ (&;_& (&;this "\\d") (wrap (` (->Text &;digit))))
+
+ (&;_& (&;this "\\p{Lower}") (wrap (` (->Text &;lower))))
+ (&;_& (&;this "\\p{Upper}") (wrap (` (->Text &;upper))))
+ (&;_& (&;this "\\p{Alpha}") (wrap (` (->Text &;alpha))))
+ (&;_& (&;this "\\p{Digit}") (wrap (` (->Text &;digit))))
+ (&;_& (&;this "\\p{Alnum}") (wrap (` (->Text &;alpha-num))))
+ (&;_& (&;this "\\p{Space}") (wrap (` (->Text &;space))))
+ (&;_& (&;this "\\p{HexDigit}") (wrap (` (->Text &;hex-digit))))
+ (&;_& (&;this "\\p{OctDigit}") (wrap (` (->Text &;oct-digit))))
+ (&;_& (&;this "\\p{Blank}") (wrap (` (->Text blank^))))
+ (&;_& (&;this "\\p{ASCII}") (wrap (` (->Text ascii^))))
+ (&;_& (&;this "\\p{Contrl}") (wrap (` (->Text control^))))
+ (&;_& (&;this "\\p{Punct}") (wrap (` (->Text punct^))))
+ (&;_& (&;this "\\p{Graph}") (wrap (` (->Text graph^))))
+ (&;_& (&;this "\\p{Print}") (wrap (` (->Text print^))))
+ )))
+
+(def: re-class^
+ (Lexer AST)
+ (&;either re-system-class^
+ (&;enclosed ["[" "]"] re-user-class^)))
+
+(def: int^
+ (Lexer Int)
+ (&;codec number;Codec<Text,Int> (&;many' &;digit)))
+
+(def: re-back-reference^
+ (Lexer AST)
+ (&;either (do Monad<Lexer>
+ [_ (&;this-char #"\\")
+ id int^]
+ (wrap (` (&;this (~ (ast;symbol ["" (Int/encode id)]))))))
+ (do Monad<Lexer>
+ [_ (&;this "\\k<")
+ captured-name identifier-part^
+ _ (&;this ">")]
+ (wrap (` (&;this (~ (ast;symbol ["" captured-name]))))))))
+
+(def: (re-simple^ current-module)
+ (-> Text (Lexer AST))
+ ($_ &;either
+ re-class^
+ (re-var^ current-module)
+ re-back-reference^
+ re-char+^
+ ))
+
+(def: (re-simple-quantified^ current-module)
+ (-> Text (Lexer AST))
+ (do Monad<Lexer>
+ [base (re-simple^ current-module)
+ quantifier (&;one-of "?*+")]
+ (case quantifier
+ #"?"
+ (wrap (` (&;default "" (~ base))))
+
+ #"*"
+ (wrap (` (join-text^ (&;some (~ base)))))
+
+ _
+ (wrap (` (join-text^ (&;many (~ base)))))
+ )))
+
+(def: (re-counted-quantified^ current-module)
+ (-> Text (Lexer AST))
+ (do Monad<Lexer>
+ [base (re-simple^ current-module)]
+ (&;enclosed ["{" "}"]
+ ($_ &;either
+ (do @
+ [[from to] (&;seq int^ (&;_& (&;this-char #",") int^))]
+ (wrap (` (join-text^ (&;between (~ (ast;nat (int-to-nat from)))
+ (~ (ast;nat (int-to-nat to)))
+ (~ base))))))
+ (do @
+ [limit (&;_& (&;this-char #",") int^)]
+ (wrap (` (join-text^ (&;at-most (~ (ast;nat (int-to-nat limit))) (~ base))))))
+ (do @
+ [limit (&;&_ int^ (&;this-char #","))]
+ (wrap (` (join-text^ (&;at-least (~ (ast;nat (int-to-nat limit))) (~ base))))))
+ (do @
+ [limit int^]
+ (wrap (` (join-text^ (&;exactly (~ (ast;nat (int-to-nat limit))) (~ base))))))))))
+
+(def: (re-quantified^ current-module)
+ (-> Text (Lexer AST))
+ (&;either (re-simple-quantified^ current-module)
+ (re-counted-quantified^ current-module)))
+
+(def: (re-complex^ current-module)
+ (-> Text (Lexer AST))
+ ($_ &;either
+ (re-quantified^ current-module)
+ (re-simple^ current-module)))
+
+(def: #hidden _Text/append_
+ (-> Text Text Text)
+ (:: text;Monoid<Text> append))
+
+(type: Re-Group
+ #Non-Capturing
+ (#Capturing [(Maybe Text) Nat]))
+
+(def: (re-sequential^ capturing? re-scoped^ current-module)
+ (-> Bool
+ (-> Text (Lexer [Re-Group AST]))
+ Text
+ (Lexer [Nat AST]))
+ (do Monad<Lexer>
+ [parts (&;many (&;alt (re-complex^ current-module)
+ (re-scoped^ current-module)))
+ #let [g!total (ast;symbol ["" "0total"])
+ g!temp (ast;symbol ["" "0temp"])
+ [_ names steps] (fold (: (-> (Either AST [Re-Group AST])
+ [Int (List AST) (List (List AST))]
+ [Int (List AST) (List (List AST))])
+ (lambda [part [idx names steps]]
+ (case part
+ (^or (#;Left complex) (#;Right [#Non-Capturing complex]))
+ [idx
+ names
+ (list& (list g!temp complex
+ (' #let) (` [(~ g!total) (_Text/append_ (~ g!total) (~ g!temp))]))
+ steps)]
+
+ (#;Right [(#Capturing [?name num-captures]) scoped])
+ (let [[idx! name!] (case ?name
+ (#;Some _name)
+ [idx (ast;symbol ["" _name])]
+
+ #;None
+ [(inc idx) (ast;symbol ["" (Int/encode idx)])])
+ access (if (>+ +0 num-captures)
+ (` (product;left (~ name!)))
+ name!)]
+ [idx!
+ (list& name! names)
+ (list& (list name! scoped
+ (' #let) (` [(~ g!total) (_Text/append_ (~ g!total) (~ access))]))
+ steps)])
+ )))
+ [0
+ (: (List AST) (list))
+ (: (List (List AST)) (list))]
+ parts)]]
+ (wrap [(if capturing?
+ (list;size names)
+ +0)
+ (` (do Monad<Lexer>
+ [(~ (' #let)) [(~ g!total) ""]
+ (~@ (|> steps list;reverse List/join))]
+ ((~ (' wrap)) [(~ g!total) (~@ (list;reverse names))])))])
+ ))
+
+(def: #hidden (unflatten^ lexer)
+ (-> (Lexer Text) (Lexer [Text Unit]))
+ (&;seq lexer (:: Monad<Lexer> wrap [])))
+
+(def: #hidden (|||^ left right)
+ (All [l r] (-> (Lexer [Text l]) (Lexer [Text r]) (Lexer [Text (| l r)])))
+ (lambda [input]
+ (case (left input)
+ (#;Right [input' [lt lv]])
+ (#;Right [input' [lt (+0 lv)]])
+
+ (#;Left _)
+ (case (right input)
+ (#;Right [input' [rt rv]])
+ (#;Right [input' [rt (+1 rv)]])
+
+ (#;Left error)
+ (#;Left error)))))
+
+(def: #hidden (|||_^ left right)
+ (All [l r] (-> (Lexer [Text l]) (Lexer [Text r]) (Lexer Text)))
+ (lambda [input]
+ (case (left input)
+ (#;Right [input' [lt lv]])
+ (#;Right [input' lt])
+
+ (#;Left _)
+ (case (right input)
+ (#;Right [input' [rt rv]])
+ (#;Right [input' rt])
+
+ (#;Left error)
+ (#;Left error)))))
+
+(def: (prep-alternative [num-captures alt])
+ (-> [Nat AST] AST)
+ (if (>+ +0 num-captures)
+ alt
+ (` (unflatten^ (~ alt)))))
+
+(def: (re-alternative^ capturing? re-scoped^ current-module)
+ (-> Bool
+ (-> Text (Lexer [Re-Group AST]))
+ Text
+ (Lexer [Nat AST]))
+ (do Monad<Lexer>
+ [#let [sub^ (re-sequential^ capturing? re-scoped^ current-module)]
+ head sub^
+ tail (&;some (&;_& (&;this-char #"|") sub^))
+ #let [g!op (if capturing?
+ (` |||^)
+ (` |||_^))]]
+ (if (list;empty? tail)
+ (wrap head)
+ (wrap [(fold max+ (product;left head) (List/map product;left tail))
+ (` ($_ (~ g!op) (~ (prep-alternative head)) (~@ (List/map prep-alternative tail))))]))))
+
+(def: (re-scoped^ current-module)
+ (-> Text (Lexer [Re-Group AST]))
+ ($_ &;either
+ (do Monad<Lexer>
+ [_ (&;this "(?:")
+ [_ scoped] (re-alternative^ false re-scoped^ current-module)
+ _ (&;this-char #")")]
+ (wrap [#Non-Capturing scoped]))
+ (do Monad<Lexer>
+ [complex (re-complex^ current-module)]
+ (wrap [#Non-Capturing complex]))
+ (do Monad<Lexer>
+ [_ (&;this "(?<")
+ captured-name identifier-part^
+ _ (&;this ">")
+ [num-captures pattern] (re-alternative^ true re-scoped^ current-module)
+ _ (&;this-char #")")]
+ (wrap [(#Capturing [(#;Some captured-name) num-captures]) pattern]))
+ (do Monad<Lexer>
+ [_ (&;this-char #"(")
+ [num-captures pattern] (re-alternative^ true re-scoped^ current-module)
+ _ (&;this-char #")")]
+ (wrap [(#Capturing [#;None num-captures]) pattern]))))
+
+(def: (regex^ current-module)
+ (-> Text (Lexer AST))
+ (:: Monad<Lexer> map product;right (re-alternative^ true re-scoped^ current-module)))
+
+## [Syntax]
+(syntax: #export (regex {pattern syntax;text})
+ (do @
+ [current-module compiler;current-module-name]
+ (case (&;run (&;&_ (regex^ current-module) &;end) pattern)
+ (#;Left error)
+ (compiler;fail error)
+
+ (#;Right regex)
+ (wrap (list regex))
+ )))
diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux
new file mode 100644
index 000000000..eba8034f9
--- /dev/null
+++ b/stdlib/source/lux/test.lux
@@ -0,0 +1,330 @@
+## 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/.
+
+(;module:
+ lux
+ (lux [compiler #+ Monad<Lux> with-gensyms]
+ (macro ["s" syntax #+ syntax: Syntax]
+ [ast])
+ (control functor
+ applicative
+ monad)
+ (concurrency [promise #* "Promise/" Monad<Promise>])
+ (data (struct [list "List/" Monad<List>])
+ [product]
+ [text]
+ text/format
+ [error #* "Error/" Monad<Error>])
+ (codata [io #- run])
+ (math ["R" random])
+ [host #- try]))
+
+## [Host]
+(jvm-import java.lang.System
+ (#static exit [int] #io void)
+ (#static currentTimeMillis [] #io long))
+
+(def: #hidden exit
+ (IO Unit)
+ (System.exit 0))
+
+## [Types]
+(type: #export (Test a)
+ (Promise (Error a)))
+
+## [Structs]
+(struct: #export _ (Functor Test)
+ (def: (map f fa)
+ (Promise/map (Error/map f) fa)))
+
+(struct: #export _ (Applicative Test)
+ (def: functor Functor<Test>)
+
+ (def: (wrap a)
+ (Promise/wrap (#;Right a)))
+
+ (def: (apply ff fa)
+ (do Monad<Promise>
+ [f' ff
+ a' fa]
+ (case [f' a']
+ [(#;Right f) (#;Right a)]
+ (wrap (#;Right (f a)))
+
+ (^or [(#;Left msg) _] [_ (#;Left msg)])
+ (wrap (#;Left msg))))
+ ))
+
+(struct: #export _ (Monad Test)
+ (def: applicative Applicative<Test>)
+
+ (def: (join mma)
+ (Promise/join (Promise/map (lambda [mma']
+ (case mma'
+ (#;Left msg)
+ (Promise/wrap (#;Left msg))
+
+ (#;Right ma)
+ ma))
+ mma)))
+ )
+
+## [Values]
+(def: #export (fail message)
+ (All [a] (-> Text (Test a)))
+ (:: Monad<Promise> wrap (#;Left message)))
+
+(def: #export (assert message test)
+ (-> Text Bool (Test Unit))
+ (if test
+ (:: Monad<Test> wrap [])
+ (fail message)))
+
+(def: #export (from-promise promise)
+ (All [a] (-> (Promise a) (Test a)))
+ (do Monad<Promise>
+ [output promise]
+ (wrap (#;Right output))))
+
+(def: #hidden (run' tests)
+ (-> (List [Text (IO (Test Unit)) Text]) (Promise Unit))
+ (do Monad<Promise>
+ [printings (mapM @
+ (: (-> [Text (IO (Test Unit)) Text] (Promise Unit))
+ (lambda [[module test description]]
+ (do @
+ [#let [pre (io;run (System.currentTimeMillis []))]
+ outcome (io;run test)
+ #let [post (io;run (System.currentTimeMillis []))]]
+ (case outcome
+ (#;Left error)
+ (wrap (log! (format "Error: " (:: text;Codec<Text,Text> encode description) " @ " module "\n" error "\n\n")))
+
+ _
+ (exec (log! (format "Success: " (:: text;Codec<Text,Text> encode description) " @ " module
+ " in " (%i (- pre post)) "ms"))
+ (wrap []))))))
+ tests)]
+ (wrap [])))
+
+(def: pcg-32-magic-inc Nat +12345)
+
+(type: #export Seed Nat)
+
+(def: #export (try seed random-test)
+ (-> Seed (R;Random (Test Unit)) (Test Seed))
+ (let [[prng [new-seed test]] (R;run (R;pcg-32 [pcg-32-magic-inc seed])
+ (do R;Monad<Random>
+ [test random-test
+ next-seed R;nat]
+ (wrap [next-seed test])))]
+ (do Monad<Test>
+ [_ test]
+ (wrap new-seed))))
+
+(def: (repeat' seed times random-test)
+ (-> Seed Nat (R;Random (Test Unit)) (Test Seed))
+ (case times
+ +0
+ (fail "Can't try a test 0 times.")
+
+ +1
+ (try seed random-test)
+
+ _
+ (do Monad<Promise>
+ [output (try seed random-test)]
+ (case output
+ (#;Left error)
+ (fail (format "Test failed with this seed: " (%n seed) "\n" error))
+
+ (#;Right seed')
+ (repeat' seed' (dec+ times) random-test)))))
+
+(def: #export (repeat times random-test)
+ (-> Nat (R;Random (Test Unit)) (Test Unit))
+ (do Monad<Test>
+ [_ (repeat' (int-to-nat (io;run (System.currentTimeMillis [])))
+ times
+ random-test)]
+ (wrap [])))
+
+## [Syntax]
+(type: Property-Test
+ {#seed (Maybe (Either Nat Ident))
+ #bindings (List [AST AST])
+ #body AST})
+
+(type: Test-Kind
+ (#Property Property-Test)
+ (#Simple AST))
+
+(def: propery-test^
+ (Syntax Property-Test)
+ ($_ s;seq
+ (s;opt (s;alt s;nat
+ s;symbol))
+ (s;tuple (s;some (s;seq s;any s;any)))
+ s;any))
+
+(def: test^
+ (Syntax Test-Kind)
+ (s;alt propery-test^
+ s;any))
+
+(def: (pair-to-list [x y])
+ (All [a] (-> [a a] (List a)))
+ (list x y))
+
+(syntax: #export (test: description {body test^})
+ {#;doc (doc "Macro for definint tests."
+ (test: "lux/pipe exports"
+ (all (match 1 (|> 20
+ (* 3)
+ (+ 4)
+ (_> 0 inc)))
+ (match 10 (|> 5
+ (@> (+ @ @))))
+ (match 15 (|> 5
+ (?> [even?] [(* 2)]
+ [odd?] [(* 3)]
+ [(_> -1)])))
+ )))}
+ (let [body (case body
+ (#Property seed bindings body)
+ (let [seed' (case seed
+ #;None
+ (' +100)
+
+ (#;Some (#;Left value))
+ (ast;nat value)
+
+ (#;Some (#;Right var))
+ (ast;symbol var))
+ bindings' (|> bindings (List/map pair-to-list) List/join)]
+ (` (repeat (~ seed')
+ (do R;Monad<Random>
+ [(~@ bindings')]
+ ((~' wrap) (~ body))))))
+
+ (#Simple body)
+ body)]
+ (with-gensyms [g!test]
+ (wrap (list (` (def: #export (~ g!test)
+ {#;;test (#;TextM (~ description))}
+ (IO (Test Unit))
+ (io (~ body)))))))))
+
+(def: (exported-tests module-name)
+ (-> Text (Lux (List [Text Text Text])))
+ (do Monad<Lux>
+ [defs (compiler;exports module-name)]
+ (wrap (|> defs
+ (List/map (lambda [[def-name [_ def-anns _]]]
+ (case (compiler;get-text-ann (ident-for #;;test) def-anns)
+ (#;Some description)
+ [true module-name def-name description]
+
+ _
+ [false module-name def-name ""])))
+ (list;filter product;left)
+ (List/map product;right)))))
+
+(syntax: #export (match pattern expression)
+ {#;doc (doc "Runs an expression and pattern-matches against it using the given pattern."
+ "If the pattern-matching succeeds, the test succeeds."
+ (match 15 (|> 5
+ (?> [even?] [(* 2)]
+ [odd?] [(* 3)]))))}
+ (with-gensyms [g!_]
+ (wrap (list (` (: (Test Unit)
+ (case (~ expression)
+ (~ pattern)
+ (~' (:: Monad<Test> wrap []))
+
+ (~ g!_)
+ (fail (~ (ast;text (format "Pattern was not matched: " (ast;ast-to-text pattern)
+ "\n\n" "From expression: " (ast;ast-to-text expression))))))))))))
+
+(def: #hidden (should-pass' veredict expr-repr)
+ (All [a] (-> (Error a) Text (Test a)))
+ (case veredict
+ (#;Left message) (fail (format "'" message "' @ " expr-repr))
+ (#;Right value) (:: Monad<Test> wrap value)))
+
+(def: #hidden (should-fail' veredict expr-repr)
+ (All [a] (-> (Error a) Text (Test Unit)))
+ (case veredict
+ (#;Left message) (:: Monad<Test> wrap [])
+ (#;Right value) (fail (format "Should have failed: " expr-repr))))
+
+(do-template [<macro-name> <func-name> <doc>]
+ [(syntax: #export (<macro-name> expr)
+ {#;doc <doc>}
+ (wrap (list (` (<func-name> (~ expr) (~ (ast;text (ast;ast-to-text expr))))))))]
+
+ [should-pass should-pass' "Verifies that a (Error a) computation succeeds/passes."]
+ [should-fail should-fail' "Verifies that a (Error a) computation fails."]
+ )
+
+(syntax: #export (match+ pattern source)
+ {#;doc (doc "Same as \"match\", but the expression/source is expected to be of type (Test a)."
+ "That is, it's asynchronous and it may fail."
+ "If, however, it succeeds, it's value will be pattern-matched against."
+ (match+ 5 (commit (do Monad<STM>
+ [_ (write 5 _var)
+ value (read _var)]
+ (wrap (#;Right value))))))}
+ (with-gensyms [g!temp]
+ (wrap (list (` (: (Test Unit)
+ (do Monad<Test>
+ [(~ g!temp) (~ source)]
+ (match (~ pattern) (~ g!temp)))))))))
+
+(syntax: #export (run)
+ {#;doc (doc "Runs all the tests defined on the current module, and in all imported modules."
+ (run))}
+ (with-gensyms [g!_]
+ (do @
+ [current-module compiler;current-module-name
+ modules (compiler;imported-modules current-module)
+ tests (: (Lux (List [Text Text Text]))
+ (:: @ map List/join (mapM @ exported-tests (#;Cons current-module modules))))
+ #let [tests+ (List/map (lambda [[module-name test desc]]
+ (` [(~ (ast;text module-name)) (~ (ast;symbol [module-name test])) (~ (ast;text desc))]))
+ tests)
+ groups (list;split-all (|> (list;size tests+) (/+ concurrency-level) (++ +1) (min+ +16))
+ tests+)]]
+ (wrap (list (` (: (IO Unit)
+ (io (exec (do Monad<Promise>
+ [(~@ (List/join (List/map (lambda [group]
+ (list g!_ (` (run' (list (~@ group))))))
+ groups)))]
+ (exec (log! "Test-suite finished!")
+ (future exit)))
+ [])))))))))
+
+(syntax: #export (all {tests (s;some s;any)})
+ {#;doc (doc "Given a sequence of tests, runs them all sequentially, and succeeds if the all succeed."
+ (test: "lux/pipe exports"
+ (all (match 1 (|> 20
+ (* 3)
+ (+ 4)
+ (_> 0 inc)))
+ (match 10 (|> 5
+ (@> (+ @ @))))
+ (match 15 (|> 5
+ (?> [even?] [(* 2)]
+ [odd?] [(* 3)]
+ [(_> -1)])))
+ )))}
+ (with-gensyms [g!_]
+ (let [pairs (|> tests
+ (List/map (: (-> AST (List AST)) (lambda [test] (list g!_ test))))
+ List/join)]
+ (wrap (list (` (: (Test Unit)
+ (do Monad<Test>
+ [(~@ pairs)]
+ ((~' wrap) [])))))))))
diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux
new file mode 100644
index 000000000..4a84582c4
--- /dev/null
+++ b/stdlib/source/lux/type.lux
@@ -0,0 +1,275 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control eq
+ monad)
+ (data [text "Text/" Monoid<Text> Eq<Text>]
+ [number "Nat/" Codec<Text,Nat>]
+ maybe
+ (struct [list #+ "List/" Monad<List> Monoid<List> Fold<List>]))
+ (macro [ast])
+ ))
+
+## [Utils]
+(def: (beta-reduce env type)
+ (-> (List Type) Type Type)
+ (case type
+ (#;HostT name params)
+ (#;HostT name (List/map (beta-reduce env) params))
+
+ (^template [<tag>]
+ (<tag> left right)
+ (<tag> (beta-reduce env left) (beta-reduce env right)))
+ ([#;SumT] [#;ProdT])
+
+ (^template [<tag>]
+ (<tag> left right)
+ (<tag> (beta-reduce env left) (beta-reduce env right)))
+ ([#;LambdaT]
+ [#;AppT])
+
+ (^template [<tag>]
+ (<tag> old-env def)
+ (case old-env
+ #;Nil
+ (<tag> env def)
+
+ _
+ type))
+ ([#;UnivQ]
+ [#;ExQ])
+
+ (#;BoundT idx)
+ (default type (list;at idx env))
+
+ (#;NamedT name type)
+ (beta-reduce env type)
+
+ _
+ type
+ ))
+
+## [Structures]
+(struct: #export _ (Eq Type)
+ (def: (= x y)
+ (case [x y]
+ [(#;HostT xname xparams) (#;HostT yname yparams)]
+ (and (Text/= xname yname)
+ (=+ (list;size yparams) (list;size xparams))
+ (List/fold (lambda [[x y] prev] (and prev (= x y)))
+ true
+ (list;zip2 xparams yparams)))
+
+ (^template [<tag>]
+ [<tag> <tag>]
+ true)
+ ([#;VoidT] [#;UnitT])
+
+ (^template [<tag>]
+ [(<tag> xid) (<tag> yid)]
+ (=+ yid xid))
+ ([#;VarT] [#;ExT] [#;BoundT])
+
+ (^or [(#;LambdaT xleft xright) (#;LambdaT yleft yright)]
+ [(#;AppT xleft xright) (#;AppT yleft yright)])
+ (and (= xleft yleft)
+ (= xright yright))
+
+ [(#;NamedT [xmodule xname] xtype) (#;NamedT [ymodule yname] ytype)]
+ (and (Text/= xmodule ymodule)
+ (Text/= xname yname)
+ (= xtype ytype))
+
+ (^template [<tag>]
+ [(<tag> xL xR) (<tag> yL yR)]
+ (and (= xL yL) (= xR yR)))
+ ([#;SumT] [#;ProdT])
+
+ (^or [(#;UnivQ xenv xbody) (#;UnivQ yenv ybody)]
+ [(#;ExQ xenv xbody) (#;ExQ yenv ybody)])
+ (and (=+ (list;size yenv) (list;size xenv))
+ (= xbody ybody)
+ (List/fold (lambda [[x y] prev] (and prev (= x y)))
+ true
+ (list;zip2 xenv yenv)))
+
+ _
+ false
+ )))
+
+## [Values]
+(def: #export (flatten-function type)
+ (-> Type [(List Type) Type])
+ (case type
+ (#;LambdaT in out')
+ (let [[ins out] (flatten-function out')]
+ [(list& in ins) out])
+
+ _
+ [(list) type]))
+
+(def: #export (flatten-apply type)
+ (-> Type [Type (List Type)])
+ (case type
+ (#;AppT left' right)
+ (let [[left rights] (flatten-apply left')]
+ [left (List/append rights (list right))])
+
+ _
+ [type (list)]))
+
+(do-template [<name> <tag>]
+ [(def: #export (<name> type)
+ (-> Type (List Type))
+ (case type
+ (<tag> left right)
+ (list& left (<name> right))
+
+ _
+ (list type)))]
+
+ [flatten-sum #;SumT]
+ [flatten-prod #;ProdT]
+ )
+
+(def: #export (apply-type type-fun param)
+ (-> Type Type (Maybe Type))
+ (case type-fun
+ (^template [<tag>]
+ (<tag> env body)
+ (#;Some (beta-reduce (list& type-fun param env) body)))
+ ([#;UnivQ] [#;ExQ])
+
+ (#;AppT F A)
+ (do Monad<Maybe>
+ [type-fn* (apply-type F A)]
+ (apply-type type-fn* param))
+
+ (#;NamedT name type)
+ (apply-type type param)
+
+ _
+ #;None))
+
+(def: #export (type-to-ast type)
+ (-> Type AST)
+ (case type
+ (#;HostT name params)
+ (` (#;HostT (~ (ast;text name))
+ (list (~@ (List/map type-to-ast params)))))
+
+ (^template [<tag>]
+ <tag>
+ (` <tag>))
+ ([#;VoidT] [#;UnitT])
+
+ (^template [<tag>]
+ (<tag> idx)
+ (` (<tag> (~ (ast;nat idx)))))
+ ([#;VarT] [#;ExT] [#;BoundT])
+
+ (^template [<tag>]
+ (<tag> left right)
+ (` (<tag> (~ (type-to-ast left))
+ (~ (type-to-ast right)))))
+ ([#;LambdaT] [#;AppT])
+
+ (^template [<tag> <macro> <flattener>]
+ (<tag> left right)
+ (` (<macro> (~@ (List/map type-to-ast (<flattener> type))))))
+ ([#;SumT | flatten-sum]
+ [#;ProdT & flatten-prod])
+
+ (#;NamedT name sub-type)
+ (ast;symbol name)
+
+ (^template [<tag>]
+ (<tag> env body)
+ (` (<tag> (list (~@ (List/map type-to-ast env)))
+ (~ (type-to-ast body)))))
+ ([#;UnivQ] [#;ExQ])
+ ))
+
+(def: #export (type-to-text type)
+ (-> Type Text)
+ (case type
+ (#;HostT name params)
+ (case params
+ #;Nil
+ ($_ Text/append "(^ " name ")")
+
+ _
+ ($_ Text/append "(^ " name " " (|> params (List/map type-to-text) list;reverse (list;interpose " ") (List/fold Text/append "")) ")"))
+
+ #;VoidT
+ "Void"
+
+ #;UnitT
+ "Unit"
+
+ (^template [<tag> <open> <close> <flatten>]
+ (<tag> _)
+ ($_ Text/append <open>
+ (|> (<flatten> type)
+ (List/map type-to-text)
+ list;reverse
+ (list;interpose " ")
+ (List/fold Text/append ""))
+ <close>))
+ ([#;SumT "(| " ")" flatten-sum]
+ [#;ProdT "[" "]" flatten-prod])
+
+ (#;LambdaT input output)
+ (let [[ins out] (flatten-function type)]
+ ($_ Text/append "(-> "
+ (|> ins
+ (List/map type-to-text)
+ list;reverse
+ (list;interpose " ")
+ (List/fold Text/append ""))
+ " " (type-to-text out) ")"))
+
+ (#;BoundT idx)
+ (Nat/encode idx)
+
+ (#;VarT id)
+ ($_ Text/append "⌈v:" (Nat/encode id) "⌋")
+
+ (#;ExT id)
+ ($_ Text/append "⟨e:" (Nat/encode id) "⟩")
+
+ (#;AppT fun param)
+ (let [[type-fun type-args] (flatten-apply type)]
+ ($_ Text/append "(" (type-to-text type-fun) " " (|> type-args (List/map type-to-text) list;reverse (list;interpose " ") (List/fold Text/append "")) ")"))
+
+ (#;UnivQ env body)
+ ($_ Text/append "(All " (type-to-text body) ")")
+
+ (#;ExQ env body)
+ ($_ Text/append "(Ex " (type-to-text body) ")")
+
+ (#;NamedT [module name] type)
+ ($_ Text/append module ";" name)
+ ))
+
+(def: #export (un-alias type)
+ (-> Type Type)
+ (case type
+ (#;NamedT _ (#;NamedT ident type'))
+ (un-alias (#;NamedT ident type'))
+
+ _
+ type))
+
+(def: #export (un-name type)
+ (-> Type Type)
+ (case type
+ (#;NamedT ident type')
+ (un-name type')
+
+ _
+ type))
diff --git a/stdlib/source/lux/type/auto.lux b/stdlib/source/lux/type/auto.lux
new file mode 100644
index 000000000..a1a795c80
--- /dev/null
+++ b/stdlib/source/lux/type/auto.lux
@@ -0,0 +1,211 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monad)
+ (data [text]
+ text/format
+ [number]
+ (struct [list "List/" Monad<List> Fold<List>]
+ [dict])
+ [bool]
+ [product])
+ [compiler #+ Monad<Lux>]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax])
+ [type]
+ (type ["tc" check #+ Check Monad<Check>])
+ ))
+
+(def: (find-member-type idx sig-type)
+ (-> Nat Type (Check Type))
+ (case sig-type
+ (#;NamedT _ sig-type')
+ (find-member-type idx sig-type')
+
+ (#;AppT func arg)
+ (case (type;apply-type func arg)
+ #;None
+ (tc;fail (format "Can't apply type " (%type func) " to type " (%type arg)))
+
+ (#;Some sig-type')
+ (find-member-type idx sig-type'))
+
+ (#;ProdT left right)
+ (if (=+ +0 idx)
+ (:: Monad<Check> wrap left)
+ (find-member-type (dec+ idx) right))
+
+ _
+ (if (=+ +0 idx)
+ (:: Monad<Check> wrap sig-type)
+ (tc;fail (format "Can't find member type " (%n idx) " for " (%type sig-type))))))
+
+(def: (resolve-member member)
+ (-> Ident (Lux [Nat Type]))
+ (do Monad<Lux>
+ [member (compiler;normalize member)
+ [idx tag-list sig-type] (compiler;resolve-tag member)]
+ (wrap [idx sig-type])))
+
+(def: (prepare-defs this-module-name defs)
+ (-> Text (List [Text Def]) (List [Ident Type]))
+ (|> defs
+ (list;filter (lambda [[name [def-type def-anns def-value]]]
+ (compiler;struct? def-anns)))
+ (List/map (lambda [[name [def-type def-anns def-value]]]
+ [[this-module-name name] def-type]))))
+
+(def: local-env
+ (Lux (List [Ident Type]))
+ (do Monad<Lux>
+ [local-batches compiler;locals
+ #let [total-locals (List/fold (lambda [[name type] table]
+ (dict;put~ name type table))
+ (: (dict;Dict Text Type)
+ (dict;new text;Hash<Text>))
+ (List/join local-batches))]]
+ (wrap (|> total-locals
+ dict;entries
+ (List/map (lambda [[name type]] [["" name] type]))))))
+
+(def: local-structs
+ (Lux (List [Ident Type]))
+ (do Monad<Lux>
+ [this-module-name compiler;current-module-name
+ defs (compiler;defs this-module-name)]
+ (wrap (prepare-defs this-module-name defs))))
+
+(def: import-structs
+ (Lux (List [Ident Type]))
+ (do Monad<Lux>
+ [this-module-name compiler;current-module-name
+ imp-mods (compiler;imported-modules this-module-name)
+ export-batches (mapM @ compiler;exports imp-mods)]
+ (wrap (prepare-defs this-module-name (List/join export-batches)))))
+
+(def: (apply-function-type func arg)
+ (-> Type Type (Check Type))
+ (case func
+ (#;NamedT _ func')
+ (apply-function-type func' arg)
+
+ (#;UnivQ _)
+ (do Monad<Check>
+ [[id var] tc;create-var]
+ (apply-function-type (default (undefined)
+ (type;apply-type func var))
+ arg))
+
+ (#;LambdaT input output)
+ (do Monad<Check>
+ [_ (tc;check input arg)]
+ (wrap output))
+
+ _
+ (tc;fail (format "Invalid function type: " (%type func)))))
+
+(def: (check-apply member-type input-types output-type)
+ (-> Type (List Type) Type (Check []))
+ (do Monad<Check>
+ [member-type' (foldM Monad<Check>
+ (lambda [input member]
+ (apply-function-type member input))
+ member-type
+ input-types)]
+ (tc;check output-type member-type')))
+
+(def: compiler-type-context
+ (Lux tc;Context)
+ (lambda [compiler]
+ (let [type-vars (get@ #;type-vars compiler)
+ context (|> tc;fresh-context
+ (set@ #tc;var-id (get@ #;counter type-vars))
+ (set@ #tc;bindings (dict;from-list number;Hash<Nat> (get@ #;mappings type-vars))))]
+ (#;Right [compiler context]))))
+
+(def: (test-alternatives sig-type member-idx input-types output-type alts)
+ (-> Type Nat (List Type) Type (List [Ident Type]) (Lux (List Ident)))
+ (do Monad<Lux>
+ [context compiler-type-context]
+ (case (|> alts
+ (list;filter (lambda [[alt-name alt-type]]
+ (case (tc;run context
+ (do Monad<Check>
+ [_ (tc;check sig-type alt-type)
+ member-type (find-member-type member-idx alt-type)]
+ (check-apply member-type input-types output-type)))
+ (#;Left error)
+ false
+
+ (#;Right _)
+ true)))
+ (List/map product;left))
+ #;Nil
+ (compiler;fail "No alternatives.")
+
+ found
+ (wrap found))))
+
+(def: (find-alternatives sig-type member-idx input-types output-type)
+ (-> Type Nat (List Type) Type (Lux (List Ident)))
+ (let [test (test-alternatives sig-type member-idx input-types output-type)]
+ ($_ compiler;either
+ (do Monad<Lux> [alts local-env] (test alts))
+ (do Monad<Lux> [alts local-structs] (test alts))
+ (do Monad<Lux> [alts import-structs] (test alts)))))
+
+(def: (var? input)
+ (-> AST Bool)
+ (case input
+ [_ (#;SymbolS _)]
+ true
+
+ _
+ false))
+
+(def: (join-pair [l r])
+ (All [a] (-> [a a] (List a)))
+ (list l r))
+
+(syntax: #export (::: {member s;symbol}
+ {args (s;alt (s;some s;symbol)
+ (s;some s;any))})
+ (case args
+ (#;Left args)
+ (do @
+ [[member-idx sig-type] (resolve-member member)
+ input-types (mapM @ compiler;find-type args)
+ output-type compiler;expected-type
+ chosen-ones (find-alternatives sig-type member-idx input-types output-type)]
+ (case chosen-ones
+ #;Nil
+ (compiler;fail (format "No structure option could be found for member " (%ident member)))
+
+ (#;Cons chosen #;Nil)
+ (wrap (list (` (:: (~ (ast;symbol chosen))
+ (~ (ast;symbol member))
+ (~@ (List/map ast;symbol args))))))
+
+ _
+ (compiler;fail (format "Too many available options: "
+ (|> chosen-ones
+ (List/map %ident)
+ (text;join-with ", ")
+ )))))
+
+ (#;Right args)
+ (do @
+ [#let [args-to-bind (list;filter (bool;complement var?) args)]
+ labels (seqM @ (list;repeat (list;size args-to-bind)
+ (compiler;gensym "")))
+ #let [retry (` (let [(~@ (|> (list;zip2 labels args-to-bind) (List/map join-pair) List/join))]
+ (;;::: (~ (ast;symbol member)) (~@ labels))))]]
+ (wrap (list retry)))))
+
+(comment
+ (::: map inc (list 0 1 2 3 4))
+ )
diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux
new file mode 100644
index 000000000..9eb72cbcb
--- /dev/null
+++ b/stdlib/source/lux/type/check.lux
@@ -0,0 +1,518 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control functor
+ applicative
+ monad)
+ (data [text "Text/" Monoid<Text> Eq<Text>]
+ text/format
+ [number]
+ maybe
+ (struct [list]
+ [dict])
+ error)
+ [type "Type/" Eq<Type>]
+ ))
+
+(type: #export Id Nat)
+
+(type: #export Fixpoints (List [[Type Type] Bool]))
+
+(type: #export Context
+ {#var-id Id
+ #ex-id Id
+ #bindings (dict;Dict Id (Maybe Type))
+ #fixpoints Fixpoints
+ })
+
+(type: #export (Check a)
+ (-> Context (Error [Context a])))
+
+(struct: #export _ (Functor Check)
+ (def: (map f fa)
+ (lambda [context]
+ (case (fa context)
+ (#;Left error)
+ (#;Left error)
+
+ (#;Right [context' output])
+ (#;Right [context' (f output)])
+ ))))
+
+(struct: #export _ (Applicative Check)
+ (def: functor Functor<Check>)
+
+ (def: (wrap x)
+ (lambda [context]
+ (#;Right [context x])))
+
+ (def: (apply ff fa)
+ (lambda [context]
+ (case (ff context)
+ (#;Right [context' f])
+ (case (fa context')
+ (#;Right [context'' a])
+ (#;Right [context'' (f a)])
+
+ (#;Left error)
+ (#;Left error))
+
+ (#;Left error)
+ (#;Left error)
+ )))
+ )
+
+(struct: #export _ (Monad Check)
+ (def: applicative Applicative<Check>)
+
+ (def: (join ffa)
+ (lambda [context]
+ (case (ffa context)
+ (#;Right [context' fa])
+ (case (fa context')
+ (#;Right [context'' a])
+ (#;Right [context'' a])
+
+ (#;Left error)
+ (#;Left error))
+
+ (#;Left error)
+ (#;Left error)
+ )))
+ )
+
+(open Monad<Check> "Check/")
+
+## [[Logic]]
+(def: #export (run context proc)
+ (All [a] (-> Context (Check a) (Error a)))
+ (case (proc context)
+ (#;Left error)
+ (#;Left error)
+
+ (#;Right [context' output])
+ (#;Right output)))
+
+(def: (apply-type! t-func t-arg)
+ (-> Type Type (Check Type))
+ (lambda [context]
+ (case (type;apply-type t-func t-arg)
+ #;None
+ (#;Left (format "Invalid type application: " (type;type-to-text t-func) " on " (type;type-to-text t-arg)))
+
+ (#;Some output)
+ (#;Right [context output]))))
+
+(def: #export existential
+ (Check [Id Type])
+ (lambda [context]
+ (let [id (get@ #ex-id context)]
+ (#;Right [(update@ #ex-id inc+ context)
+ [id (#;ExT id)]]))))
+
+(def: (bound? id)
+ (-> Id (Check Bool))
+ (lambda [context]
+ (case (|> context (get@ #bindings) (dict;get id))
+ (#;Some (#;Some _))
+ (#;Right [context true])
+
+ (#;Some #;None)
+ (#;Right [context false])
+
+ #;None
+ (#;Left (format "Unknown type-var: " (%n id))))))
+
+(def: (deref id)
+ (-> Id (Check Type))
+ (lambda [context]
+ (case (|> context (get@ #bindings) (dict;get id))
+ (#;Some (#;Some type))
+ (#;Right [context type])
+
+ (#;Some #;None)
+ (#;Left (format "Unbound type-var: " (%n id)))
+
+ #;None
+ (#;Left (format "Unknown type-var: " (%n id))))))
+
+(def: (set-var id type)
+ (-> Id Type (Check []))
+ (lambda [context]
+ (case (|> context (get@ #bindings) (dict;get id))
+ (#;Some (#;Some bound))
+ (#;Left (format "Can't rebind type-var: " (%n id) " | Current type: " (type;type-to-text bound)))
+
+ (#;Some #;None)
+ (#;Right [(update@ #bindings (dict;put id (#;Some type)) context)
+ []])
+
+ #;None
+ (#;Left (format "Unknown type-var: " (%n id))))))
+
+(def: (reset-var id type)
+ (-> Id Type (Check []))
+ (lambda [context]
+ (case (|> context (get@ #bindings) (dict;get id))
+ (#;Some _)
+ (#;Right [(update@ #bindings (dict;put id (#;Some type)) context)
+ []])
+
+ #;None
+ (#;Left (format "Unknown type-var: " (%n id))))))
+
+(def: (unset-var id)
+ (-> Id (Check []))
+ (lambda [context]
+ (case (|> context (get@ #bindings) (dict;get id))
+ (#;Some _)
+ (#;Right [(update@ #bindings (dict;put id #;None) context)
+ []])
+
+ #;None
+ (#;Left (format "Unknown type-var: " (%n id))))))
+
+(def: (clean t-id type)
+ (-> Id Type (Check Type))
+ (case type
+ (#;VarT id)
+ (if (=+ t-id id)
+ (do Monad<Check>
+ [? (bound? id)]
+ (if ?
+ (deref id)
+ (wrap type)))
+ (do Monad<Check>
+ [? (bound? id)]
+ (if ?
+ (do Monad<Check>
+ [=type (deref id)
+ ==type (clean t-id =type)]
+ (case ==type
+ (#;VarT =id)
+ (if (=+ t-id =id)
+ (do Monad<Check>
+ [_ (unset-var id)]
+ (wrap type))
+ (do Monad<Check>
+ [_ (reset-var id ==type)]
+ (wrap type)))
+
+ _
+ (do Monad<Check>
+ [_ (reset-var id ==type)]
+ (wrap type))))
+ (wrap type))))
+
+ (#;HostT name params)
+ (do Monad<Check>
+ [=params (mapM @ (clean t-id) params)]
+ (wrap (#;HostT name =params)))
+
+ (^template [<tag>]
+ (<tag> left right)
+ (do Monad<Check>
+ [=left (clean t-id left)
+ =right (clean t-id right)]
+ (wrap (<tag> =left =right))))
+ ([#;LambdaT]
+ [#;AppT]
+ [#;ProdT]
+ [#;SumT])
+
+ (^template [<tag>]
+ (<tag> env body)
+ (do Monad<Check>
+ [=env (mapM @ (clean t-id) env)
+ =body (clean t-id body)] ## TODO: DON'T CLEAN THE BODY
+ (wrap (<tag> =env =body))))
+ ([#;UnivQ]
+ [#;ExQ])
+
+ _
+ (:: Monad<Check> wrap type)
+ ))
+
+(def: #export create-var
+ (Check [Id Type])
+ (lambda [context]
+ (let [id (get@ #var-id context)]
+ (#;Right [(|> context
+ (update@ #var-id inc+)
+ (update@ #bindings (dict;put id #;None)))
+ [id (#;VarT id)]]))))
+
+(do-template [<get> <set> <tag> <type>]
+ [(def: <get>
+ (Check <type>)
+ (lambda [context]
+ (#;Right [context
+ (get@ <tag> context)])))
+
+ (def: (<set> value)
+ (-> <type> (Check []))
+ (lambda [context]
+ (#;Right [(set@ <tag> value context)
+ []])))]
+
+ [get-bindings set-bindings #bindings (dict;Dict Id (Maybe Type))]
+ [get-fixpoints set-fixpoints #fixpoints Fixpoints]
+ )
+
+(def: #export (delete-var id)
+ (-> Id (Check []))
+ (do Monad<Check>
+ [? (bound? id)
+ _ (if ?
+ (wrap [])
+ (do Monad<Check>
+ [[ex-id ex] existential]
+ (set-var id ex)))
+ bindings get-bindings
+ bindings' (mapM @
+ (lambda [(^@ binding [b-id b-type])]
+ (if (=+ id b-id)
+ (wrap binding)
+ (case b-type
+ #;None
+ (wrap binding)
+
+ (#;Some b-type')
+ (case b-type'
+ (#;VarT t-id)
+ (if (=+ id t-id)
+ (wrap [b-id #;None])
+ (wrap binding))
+
+ _
+ (do Monad<Check>
+ [b-type'' (clean id b-type')]
+ (wrap [b-id (#;Some b-type'')])))
+ )))
+ (dict;entries bindings))]
+ (set-bindings (|> bindings' (dict;from-list number;Hash<Nat>) (dict;remove id)))))
+
+(def: #export (with-var k)
+ (All [a] (-> (-> [Id Type] (Check a)) (Check a)))
+ (do Monad<Check>
+ [[id var] create-var
+ output (k [id var])
+ _ (delete-var id)]
+ (wrap output)))
+
+(def: #export fresh-context
+ Context
+ {#var-id +0
+ #ex-id +0
+ #bindings (dict;new number;Hash<Nat>)
+ #fixpoints (list)
+ })
+
+(def: (attempt op)
+ (All [a] (-> (Check a) (Check (Maybe a))))
+ (lambda [context]
+ (case (op context)
+ (#;Right [context' output])
+ (#;Right [context' (#;Some output)])
+
+ (#;Left _)
+ (#;Right [context #;None]))))
+
+(def: #export (fail message)
+ (All [a] (-> Text (Check a)))
+ (lambda [context]
+ (#;Left message)))
+
+(def: (fail-check expected actual)
+ (-> Type Type (Check []))
+ (fail (format "Expected: " (type;type-to-text expected) "\n\n"
+ "Actual: " (type;type-to-text actual))))
+
+(def: success (Check []) (Check/wrap []))
+
+(def: (|| left right)
+ (All [a] (-> (Check a) (Check a) (Check a)))
+ (lambda [context]
+ (case (left context)
+ (#;Right [context' output])
+ (#;Right [context' output])
+
+ (#;Left _)
+ (right context))))
+
+(def: (fp-get [e a] fixpoints)
+ (-> [Type Type] Fixpoints (Maybe Bool))
+ (list;find (lambda [[[fe fa] status]]
+ (if (and (Type/= e fe)
+ (Type/= a fa))
+ (#;Some status)
+ #;None))
+ fixpoints))
+
+(def: (fp-put ea status fixpoints)
+ (-> [Type Type] Bool Fixpoints Fixpoints)
+ (#;Cons [ea status] fixpoints))
+
+(def: #export (check expected actual)
+ (-> Type Type (Check []))
+ (if (== expected actual)
+ success
+ (case [expected actual]
+ [(#;VarT e-id) (#;VarT a-id)]
+ (if (=+ e-id a-id)
+ success
+ (do Monad<Check>
+ [ebound (attempt (deref e-id))
+ abound (attempt (deref a-id))]
+ (case [ebound abound]
+ [#;None #;None]
+ (set-var e-id actual)
+
+ [(#;Some etype) #;None]
+ (check etype actual)
+
+ [#;None (#;Some atype)]
+ (check expected atype)
+
+ [(#;Some etype) (#;Some atype)]
+ (check etype atype))))
+
+ [(#;VarT id) _]
+ (|| (set-var id actual)
+ (do Monad<Check>
+ [bound (deref id)]
+ (check bound actual)))
+
+ [_ (#;VarT id)]
+ (|| (set-var id expected)
+ (do Monad<Check>
+ [bound (deref id)]
+ (check expected bound)))
+
+ [(#;AppT (#;ExT eid) eA) (#;AppT (#;ExT aid) aA)]
+ (if (=+ eid aid)
+ (check eA aA)
+ (fail-check expected actual))
+
+ [(#;AppT (#;VarT id) A1) (#;AppT F2 A2)]
+ (|| (do Monad<Check>
+ [F1 (deref id)]
+ (check (#;AppT F1 A1) actual))
+ (do Monad<Check>
+ [_ (check (#;VarT id) F2)
+ e' (apply-type! F2 A1)
+ a' (apply-type! F2 A2)]
+ (check e' a')))
+
+ [(#;AppT F1 A1) (#;AppT (#;VarT id) A2)]
+ (|| (do Monad<Check>
+ [F2 (deref id)]
+ (check expected (#;AppT F2 A2)))
+ (do Monad<Check>
+ [_ (check F1 (#;VarT id))
+ e' (apply-type! F1 A1)
+ a' (apply-type! F1 A2)]
+ (check e' a')))
+
+ [(#;AppT F A) _]
+ (do Monad<Check>
+ [#let [fp-pair [expected actual]]
+ fixpoints get-fixpoints]
+ (case (fp-get fp-pair fixpoints)
+ (#;Some ?)
+ (if ?
+ success
+ (fail-check expected actual))
+
+ #;None
+ (do Monad<Check>
+ [expected' (apply-type! F A)
+ _ (set-fixpoints (fp-put fp-pair true fixpoints))]
+ (check expected' actual))))
+
+ [_ (#;AppT F A)]
+ (do Monad<Check>
+ [actual' (apply-type! F A)]
+ (check expected actual'))
+
+ [(#;UnivQ _) _]
+ (do Monad<Check>
+ [[ex-id ex] existential
+ expected' (apply-type! expected ex)]
+ (check expected' actual))
+
+ [_ (#;UnivQ _)]
+ (with-var
+ (lambda [[var-id var]]
+ (do Monad<Check>
+ [actual' (apply-type! actual var)
+ =output (check expected actual')
+ _ (clean var-id expected)]
+ success)))
+
+ [(#;ExQ e!env e!def) _]
+ (with-var
+ (lambda [[var-id var]]
+ (do Monad<Check>
+ [expected' (apply-type! expected var)
+ =output (check expected' actual)
+ _ (clean var-id actual)]
+ success)))
+
+ [_ (#;ExQ a!env a!def)]
+ (do Monad<Check>
+ [[ex-id ex] existential
+ actual' (apply-type! actual ex)]
+ (check expected actual'))
+
+ [(#;HostT e-name e-params) (#;HostT a-name a-params)]
+ (if (Text/= e-name a-name)
+ (do Monad<Check>
+ [_ (mapM Monad<Check>
+ (lambda [[e a]] (check e a))
+ (list;zip2 e-params a-params))]
+ success)
+ (fail-check expected actual))
+
+ (^template [<unit> <append>]
+ [<unit> <unit>]
+ success
+
+ [(<append> eL eR) (<append> aL aR)]
+ (do Monad<Check>
+ [_ (check eL aL)]
+ (check eR aR)))
+ ([#;VoidT #;SumT]
+ [#;UnitT #;ProdT])
+
+ [(#;LambdaT eI eO) (#;LambdaT aI aO)]
+ (do Monad<Check>
+ [_ (check aI eI)]
+ (check eO aO))
+
+ [(#;ExT e!id) (#;ExT a!id)]
+ (if (=+ e!id a!id)
+ success
+ (fail-check expected actual))
+
+ [(#;NamedT _ ?etype) _]
+ (check ?etype actual)
+
+ [_ (#;NamedT _ ?atype)]
+ (check expected ?atype)
+
+ _
+ (fail-check expected actual))))
+
+(def: #export (checks? expected actual)
+ (-> Type Type Bool)
+ (case (run fresh-context (check expected actual))
+ (#;Left error)
+ false
+
+ (#;Right _)
+ true))
diff --git a/stdlib/test/test/lux.lux b/stdlib/test/test/lux.lux
new file mode 100644
index 000000000..947ec5b6f
--- /dev/null
+++ b/stdlib/test/test/lux.lux
@@ -0,0 +1,164 @@
+## 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/.
+
+(;module:
+ lux
+ lux/test
+ (lux (control monad)
+ (codata [io])
+ [math]
+ (math ["R" random])
+ (data text/format)
+ [compiler]
+ (macro ["s" syntax #+ syntax:])))
+
+(test: "Every value is identical to itself, and the 'id' function doesn't change values in any way."
+ [value R;int]
+ (assert "" (and (== value value)
+ (== value (id value)))))
+
+(test: "Values created separately can't be identical."
+ [x R;int
+ y R;int]
+ (match false (== x y)))
+
+(do-template [category rand-gen inc dec even? odd? = < >]
+ [(test: (format "[" category "] " "Moving up-down or down-up should result in same value.")
+ [value rand-gen]
+ (assert "" (and (|> value inc dec (= value))
+ (|> value dec inc (= value)))))
+
+ (test: (format "[" category "] " "(x+1) > x && (x-1) < x")
+ [value rand-gen]
+ (assert "" (and (|> value inc (> value))
+ (|> value dec (< value)))))
+
+ (test: (format "[" category "] " "Every odd/even number is surrounded by two of the other kind.")
+ [value rand-gen]
+ (assert ""
+ (if (even? value)
+ (and (|> value inc odd?)
+ (|> value dec odd?))
+ (and (|> value inc even?)
+ (|> value dec even?)))))]
+
+ ["Nat" R;nat inc+ dec+ even?+ odd?+ =+ <+ >+]
+ ["Int" R;int inc dec even? odd? = < >]
+ )
+
+(do-template [category rand-gen = < > <= >= min max]
+ [(test: (format "[" category "] " "The symmetry of numerical comparisons.")
+ [x rand-gen
+ y rand-gen]
+ (assert ""
+ (or (= x y)
+ (if (< y x)
+ (> x y)
+ (< x y)))))
+
+ (test: (format "[" category "] " "Minimums and maximums.")
+ [x rand-gen
+ y rand-gen]
+ (assert ""
+ (and (and (<= x (min x y))
+ (<= y (min x y)))
+ (and (>= x (max x y))
+ (>= y (max x y)))
+ )))]
+
+ ["Int" R;int = < > <= >= min max]
+ ["Nat" R;nat =+ <+ >+ <=+ >=+ min+ max+]
+ ["Real" R;real =. <. >. <=. >=. min. max.]
+ ["Frac" R;frac =.. <.. >.. <=.. >=.. min.. max..]
+ )
+
+(do-template [category rand-gen = + - * / <%> > <0> <1> <10> %x <cap> <prep>]
+ [(test: (format "[" category "] " "Additive identity")
+ [x rand-gen]
+ (assert ""
+ (and (|> x (+ <0>) (= x))
+ (|> x (- <0>) (= x)))))
+
+ (test: (format "[" category "] " "Addition & Substraction")
+ [x (:: @ map <prep> rand-gen)
+ y (:: @ map <prep> rand-gen)
+ #let [x (* <10> x)
+ y (* <10> y)
+ cond (and (|> x (- y) (+ y) (= x))
+ (|> x (+ y) (- y) (= x)))
+ _ (if cond
+ []
+ (exec
+ (log! "+- SAMPLE")
+ (log! (format (%x x) " -+ " (%x y) " = " (%x (|> x (- y) (+ y)))))
+ (log! (format (%x x) " +- " (%x y) " = " (%x (|> x (+ y) (- y)))))))
+ ]]
+ (assert ""
+ (and (|> x (- y) (+ y) (= x))
+ (|> x (+ y) (- y) (= x)))))
+
+ (test: (format "[" category "] " "Multiplicative identity")
+ [x rand-gen]
+ (assert ""
+ (and (|> x (* <1>) (= x))
+ (|> x (/ <1>) (= x)))))
+
+ (test: (format "[" category "] " "Multiplication & Division")
+ [x (:: @ map <cap> rand-gen)
+ y (|> rand-gen
+ (:: @ map <cap>)
+ (R;filter (|>. (= <0>) not)))
+ #let [r (<%> y x)
+ x' (- r x)]]
+ (assert ""
+ (or (> x' y)
+ (|> x' (/ y) (* y) (= x')))
+ ))]
+
+ ["Nat" R;nat =+ ++ -+ *+ /+ ;%+ >+ +0 +1 +1000000 %n (;%+ +1000) id]
+ ["Int" R;int = + - * / ;% > 0 1 1000000 %i (;% 1000) id]
+ ["Real" R;real =. +. -. *. /. ;%. >. 0.0 1.0 1000000.0 %r id math;floor]
+ )
+
+(do-template [category rand-gen -> <- = <cap> %a %z]
+ [(test: (format "[" category "] " "Numeric conversions")
+ [value rand-gen
+ #let [value (<cap> value)]]
+ (assert ""
+ (|> value -> <- (= value))))]
+
+ ["Int->Nat" R;int int-to-nat nat-to-int = (;% 1000000) %i %n]
+ ["Nat->Int" R;nat nat-to-int int-to-nat =+ (;%+ +1000000) %n %i]
+ ["Int->Real" R;int int-to-real real-to-int = (;% 1000000) %i %r]
+ ["Real->Int" R;real real-to-int int-to-real =. math;floor %r %i]
+ ## [R;real real-to-frac frac-to-real =. (;%. 1.0) %r %f]
+ )
+
+(test: "Simple macros and constructs"
+ (all (match ["lux" "yolo"] (ident-for ;yolo))
+ (match ["test/lux" "yolo"] (ident-for ;;yolo))
+ (match ["" "yolo"] (ident-for yolo))
+ (match ["lux/test" "yolo"] (ident-for lux/test;yolo))
+ (match ["lux" "yolo"] (ident-for #;yolo))
+ (match ["test/lux" "yolo"] (ident-for #;;yolo))
+ (match ["" "yolo"] (ident-for #yolo))
+ (match ["lux/test" "yolo"] (ident-for #lux/test;yolo))
+
+ (match 1000 (loop [counter 0
+ value 1]
+ (if (< 3 counter)
+ (recur (inc counter) (* 10 value))
+ value)))
+
+ (match (^ (list 1 2 3))
+ (list 1 2 3))
+ (match (^ (list 1 2 3 4 5 6))
+ (list& 1 2 3 (list 4 5 6)))
+
+ (match "yolo" (default "yolo"
+ #;None))
+ (match "lol" (default "yolo"
+ (#;Some "lol")))
+ ))
diff --git a/stdlib/test/test/lux/cli.lux b/stdlib/test/test/lux/cli.lux
new file mode 100644
index 000000000..c95ec9e9c
--- /dev/null
+++ b/stdlib/test/test/lux/cli.lux
@@ -0,0 +1,84 @@
+(;module:
+ [lux #- not]
+ (lux (codata [io])
+ (control monad)
+ (data text/format
+ [number]
+ [product]
+ [sum])
+ (codata function)
+ [cli #- run])
+ [lux/test #- assert])
+
+(test: "lux/cli exports"
+ (test-all (match (#;Right "foo")
+ (cli;run any (list "foo" "bar" "baz")))
+ (match (#;Left _)
+ (cli;run any (list)))
+ (match (#;Right 123)
+ (cli;run (parse (:: number;Codec<Text,Int> decode) any) (list "123")))
+ (match (#;Left _)
+ (cli;run (option (list "-p" "--port")) (list)))
+ (match (#;Left _)
+ (cli;run (option (list "-p" "--port")) (list "yolo")))
+ (match (#;Right "123")
+ (cli;run (option (list "-p" "--port")) (list "-p" "123")))
+ (match (#;Right "123")
+ (cli;run (option (list "-p" "--port")) (list "--port" "123")))
+ (match (#;Right false)
+ (cli;run (flag (list "-h" "--help")) (list)))
+ (match (#;Right false)
+ (cli;run (flag (list "-h" "--help")) (list "yolo")))
+ (match (#;Right true)
+ (cli;run (flag (list "-h" "--help")) (list "-h")))
+ (match (#;Right true)
+ (cli;run (flag (list "-h" "--help")) (list "--help")))
+ (match (#;Right [])
+ (cli;run end (list)))
+ (match (#;Left _)
+ (cli;run end (list "yolo")))
+ (match (#;Left "YOLO")
+ (cli;run (assert false "YOLO") (list "yolo")))
+ (match (#;Right [])
+ (cli;run (assert true "YOLO") (list "yolo")))
+ (match (#;Right #;None)
+ (cli;run (opt any) (list)))
+ (match (#;Right (#;Some "yolo"))
+ (cli;run (opt any) (list "yolo")))
+ (match (#;Right ["foo" "bar"])
+ (cli;run (seq any any) (list "foo" "bar" "baz")))
+ (match (#;Right ["foo" "bar"])
+ (cli;run (seq any any) (list "foo" "bar")))
+ (match (#;Left _)
+ (cli;run (seq any any) (list "foo")))
+ ## (match (#;Right (#;Left 123))
+ ## (cli;run (alt (parse (:: number;Codec<Text,Int> decode) any)
+ ## any)
+ ## (list "123" "foo")))
+ ## (match (#;Right (#;Right "foo"))
+ ## (cli;run (alt (parse (:: number;Codec<Text,Int> decode) any)
+ ## any)
+ ## (list "foo")))
+ (match (#;Left _)
+ (cli;run (alt (parse (:: number;Codec<Text,Int> decode) any)
+ (parse (:: number;Codec<Text,Real> decode) any))
+ (list "foo")))
+ (match (#;Left _)
+ (cli;run (not (parse (:: number;Codec<Text,Int> decode) any))
+ (list "123")))
+ (match (#;Right [])
+ (cli;run (not (parse (:: number;Codec<Text,Int> decode) any))
+ (list "yolo")))
+ (match (^ (#;Right (list "foo" "bar" "baz")))
+ (cli;run (some any) (list "foo" "bar" "baz")))
+ (match (^ (#;Right (list)))
+ (cli;run (some any) (list)))
+ (match (^ (#;Right (list "foo" "bar" "baz")))
+ (cli;run (many any) (list "foo" "bar" "baz")))
+ (match (#;Left _)
+ (cli;run (many any) (list)))
+ (match (#;Right "yolo")
+ (cli;run (either (parse sum;right any)
+ any)
+ (list "yolo")))
+ ))
diff --git a/stdlib/test/test/lux/codata/env.lux b/stdlib/test/test/lux/codata/env.lux
new file mode 100644
index 000000000..7a374cd4d
--- /dev/null
+++ b/stdlib/test/test/lux/codata/env.lux
@@ -0,0 +1,23 @@
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data [text "Text/" Monoid<Text>]
+ text/format
+ [number])
+ (codata function
+ env))
+ lux/test)
+
+(test: "lux/codata/env exports"
+ (test-all (match 123 (run 123 ask))
+ (match 246 (run 123 (local (* 2) ask)))
+ (match 134 (run 123 (:: Functor<Env> map inc (+ 10))))
+ (match 10 (run 123 (:: Applicative<Env> wrap 10)))
+ (match 30 (run 123 (let [(^open) Applicative<Env>]
+ (apply (wrap (+ 10)) (wrap 20)))))
+ (match 30 (run 123 (do Monad<Env>
+ [f (wrap +)
+ x (wrap 10)
+ y (wrap 20)]
+ (wrap (f x y)))))))
diff --git a/stdlib/test/test/lux/codata/io.lux b/stdlib/test/test/lux/codata/io.lux
new file mode 100644
index 000000000..5d521faff
--- /dev/null
+++ b/stdlib/test/test/lux/codata/io.lux
@@ -0,0 +1,21 @@
+(;module:
+ lux
+ (lux (control monad)
+ (data [text "Text/" Monoid<Text>]
+ text/format
+ [number])
+ (codata function
+ io))
+ lux/test)
+
+(test: "lux/codata/io exports"
+ (test-all (match "YOLO" (run (io "YOLO")))
+ (match 11 (run (:: Functor<IO> map inc (io 10))))
+ (match 10 (run (:: Applicative<IO> wrap 10)))
+ (match 30 (run (let [(^open) Applicative<IO>]
+ (apply (wrap (+ 10)) (wrap 20)))))
+ (match 30 (run (do Monad<IO>
+ [f (wrap +)
+ x (wrap 10)
+ y (wrap 20)]
+ (wrap (f x y)))))))
diff --git a/stdlib/test/test/lux/codata/state.lux b/stdlib/test/test/lux/codata/state.lux
new file mode 100644
index 000000000..054b59d45
--- /dev/null
+++ b/stdlib/test/test/lux/codata/state.lux
@@ -0,0 +1,34 @@
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data [text "Text/" Monoid<Text>]
+ text/format
+ [number]
+ [product])
+ (codata function
+ state))
+ lux/test)
+
+(test: "lux/codata/state exports"
+ (test-all (match 123 (product;right (run 123 get)))
+ (match 321 (product;right (run 123 (do Monad<State>
+ [_ (put 321)]
+ get))))
+ (match 369 (product;right (run 123 (do Monad<State>
+ [_ (update (* 3))]
+ get))))
+ (match 124 (product;right (run 123 (use inc))))
+ (match 246 (product;right (run 123 (local (* 2) get))))
+ (match 124 (product;right (run 123 (:: Functor<State> map inc get))))
+ (match 10 (product;right (run 123 (:: Applicative<State> wrap 10))))
+ (match 30 (product;right (run 123 (let [(^open) Applicative<State>]
+ (apply (wrap (+ 10)) (wrap 20))))))
+ (match 30 (product;right (run 123 (: (State Int Int)
+ (do Monad<State>
+ [f (wrap +)
+ x (wrap 10)
+ y (wrap 20)]
+
+ (wrap (f x y)))))))
+ ))
diff --git a/stdlib/test/test/lux/codata/struct/stream.lux b/stdlib/test/test/lux/codata/struct/stream.lux
new file mode 100644
index 000000000..28292a405
--- /dev/null
+++ b/stdlib/test/test/lux/codata/struct/stream.lux
@@ -0,0 +1,68 @@
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad
+ comonad)
+ (data [text "Text/" Monoid<Text>]
+ text/format
+ [number "Int/" Codec<Text,Int>])
+ (codata function
+ [cont]
+ (struct stream)))
+ lux/test)
+
+(test: "lux/codata/stream exports"
+ (let% [<take+drop+split> (do-template [<take> <drop> <split> <arg>]
+ [(match (^ (list 0 1 2))
+ (<take> <arg> (iterate inc 0)))
+ (match (^=> (^stream& w x y z ...)
+ {[w x y z] [3 4 5 6]})
+ (<drop> <arg> (iterate inc 0)))
+ (match (^=> (^ [(list 0 1 2) _stream_])
+ {_stream_ (^stream& w x y z ...)}
+ {[w x y z] [3 4 5 6]})
+ (<split> <arg> (iterate inc 0)))]
+
+ [take drop split +3]
+ [take-while drop-while split-with (< 3)])
+ ]
+ (test-all (match (^=> (^stream& w x y z ...)
+ {[w x y z] [0 1 2 3]})
+ (iterate inc 0))
+ (match (^=> (^stream& w x y z ...)
+ {[w x y z] [0 0 0 0]})
+ (repeat 0))
+ (match (^=> (#;Some the-stream)
+ {the-stream (^stream& w x y z ...)}
+ {[w x y z] [0 1 0 1]})
+ (cycle (list 0 1)))
+ (match 0 (head (iterate inc 0)))
+ (match (^=> (^stream& w x y z ...)
+ {[w x y z] [1 2 3 4]})
+ (tail (iterate inc 0)))
+ (match 9 (at +9 (iterate inc 0)))
+ (match 0 (at +0 (iterate inc 0)))
+ <take+drop+split>
+ (match (^=> (^stream& w x y z ...)
+ {[w x y z] ["0" "1" "2" "3"]})
+ (unfold (lambda [n] [(inc n) (Int/encode n)])
+ 0))
+ (match (^=> (^stream& w x y z ...)
+ {[w x y z] [0 2 4 6]})
+ (filter even? (iterate inc 0)))
+ (match (^=> [e_stream o_stream]
+ {e_stream (^stream& w x y z ...)}
+ {o_stream (^stream& a b c d ...)}
+ {[w x y z a b c d] [0 2 4 6 1 3 5 7]})
+ (partition even? (iterate inc 0)))
+ (match (^=> (^stream& w x y z ...)
+ {[w x y z] [0 1 4 9]})
+ (let [square (lambda [n] (* n n))]
+ (:: Functor<Stream> map square (iterate inc 0))))
+ (match (^=> (^stream& w x y z ...)
+ {[w x y z] [4 9 16 25]})
+ (let [square (lambda [n] (* n n))]
+ (be CoMonad<Stream>
+ [inputs (iterate inc 2)]
+ (square (head inputs)))))
+ )))
diff --git a/stdlib/test/test/lux/concurrency/actor.lux b/stdlib/test/test/lux/concurrency/actor.lux
new file mode 100644
index 000000000..e9a19e8ea
--- /dev/null
+++ b/stdlib/test/test/lux/concurrency/actor.lux
@@ -0,0 +1,70 @@
+(;module:
+ lux
+ (lux (control monad)
+ (data [number]
+ text/format
+ error)
+ (concurrency [promise #+ Promise Monad<Promise> "Promise/" Monad<Promise>]
+ actor)
+ (codata function
+ [io #- run]))
+ lux/test)
+
+(actor: Adder
+ Int
+
+ (method: (add! {offset Int})
+ [Int Int]
+ (let [*state*' (+ offset *state*)]
+ (wrap (#;Right [*state*' [*state* *state*']]))))
+
+ (stop:
+ (exec (log! (format "Cause of death: " (default "???" *cause*)))
+ (log! (format "Current state: " (%i *state*)))
+ (wrap []))))
+
+(test: "lux/concurrency/actor exports"
+ (let [counter-proc (: (Proc Int (Promise Int))
+ [(lambda [self output state]
+ (let [state' (inc state)]
+ (exec (io;run (promise;resolve state' output))
+ (Promise/wrap (#;Right state')))))
+ (lambda [?error state] (Promise/wrap []))])]
+ (test-all (match true
+ (let [counter (: (Actor Int (Promise Int))
+ (io;run (spawn 0 counter-proc)))]
+ (alive? counter)))
+ (match [true false]
+ (let [counter (: (Actor Int (Promise Int))
+ (io;run (spawn 0 counter-proc)))]
+ [(io;run (poison counter))
+ (alive? counter)]))
+ (match [true false]
+ (let [counter (: (Actor Int (Promise Int))
+ (io;run (spawn 0 counter-proc)))]
+ [(io;run (poison counter))
+ (io;run (poison counter))]))
+ (match+ [1 2 3]
+ (do Monad<Promise>
+ [#let [counter (: (Actor Int (Promise Int))
+ (io;run (spawn 0 counter-proc)))
+ output-1 (: (Promise Int) (promise;promise))
+ output-2 (: (Promise Int) (promise;promise))
+ output-3 (: (Promise Int) (promise;promise))]
+ ?1 (send output-1 counter)
+ ?2 (send output-2 counter)
+ ?3 (send output-3 counter)]
+ (if (and ?1 ?2 ?3)
+ (from-promise ($_ promise;seq output-1 output-2 output-3))
+ (wrap (#;Left "Uh, oh...")))))
+ (match+ [[0 1] [1 3] [3 6]]
+ (do Monad<Promise>
+ [#let [adder (: Adder
+ (io;run (spawn 0 Adder//new)))]
+ t1 (add! 1 adder)
+ t2 (add! 2 adder)
+ t3 (add! 3 adder)
+ #let [? (io;run (poison adder))]]
+ (wrap (#;Right [t1 t2 t3]))
+ ))
+ )))
diff --git a/stdlib/test/test/lux/concurrency/frp.lux b/stdlib/test/test/lux/concurrency/frp.lux
new file mode 100644
index 000000000..62ca0b57d
--- /dev/null
+++ b/stdlib/test/test/lux/concurrency/frp.lux
@@ -0,0 +1,54 @@
+(;module:
+ lux
+ (lux (control monad)
+ (data [number]
+ text/format
+ error)
+ (concurrency [promise #+ Promise Monad<Promise> "Promise/" Monad<Promise>]
+ frp)
+ (codata function
+ io))
+ lux/test)
+
+(def: (List->Chan values)
+ (-> (List Int) (Chan Int))
+ (let [_chan (: (Chan Int) (chan))]
+ (run (do Monad<IO>
+ [_ (mapM Monad<IO>
+ (lambda [value]
+ (write value _chan))
+ values)
+ _ (close _chan)]
+ (wrap _chan)))))
+
+(test: "lux/concurrency/frp exports"
+ (test-all (match+ (^ (list 0 1 2 3 4 5))
+ (from-promise (consume (List->Chan (list 0 1 2 3 4 5)))))
+ (match+ (^ (list 0 1 2 3 4 5))
+ (from-promise (consume (let [input (List->Chan (list 0 1 2 3 4 5))
+ output (: (Chan Int) (chan))]
+ (exec (pipe input output)
+ output)))))
+ (match+ (^ (list 0 2 4))
+ (from-promise (consume (filter even? (List->Chan (list 0 1 2 3 4 5))))))
+ (match+ (^ (list 0 1 2 3 4 5 0 -1 -2 -3 -4 -5))
+ (from-promise (consume (merge (list (List->Chan (list 0 1 2 3 4 5))
+ (List->Chan (list 0 -1 -2 -3 -4 -5)))))))
+ (match+ 15 (from-promise (fold (lambda [base input] (Promise/wrap (+ input base))) 0 (List->Chan (list 0 1 2 3 4 5)))))
+ (match+ (^ (list 0 1 2 3 4 5))
+ (from-promise (consume (no-dups number;Eq<Int> (List->Chan (list 0 0 0 1 2 2 3 3 3 3 4 4 4 5 5))))))
+ (match+ (^ (list 12345))
+ (from-promise (consume (as-chan (:: promise;Monad<Promise> wrap 12345)))))
+ (match+ (^ (list 1 2 3 4 5 6))
+ (from-promise (consume (:: Functor<Chan> map inc (List->Chan (list 0 1 2 3 4 5))))))
+ (match+ (^ (list 12345))
+ (from-promise (consume (:: Applicative<Chan> wrap 12345))))
+ (match+ (^ (list 12346))
+ (from-promise (consume (let [(^open) Applicative<Chan>]
+ (apply (wrap inc) (wrap 12345))))))
+ (match+ (^ (list 12346))
+ (from-promise (consume (do Monad<Chan>
+ [f (wrap inc)
+ a (wrap 12345)]
+ (wrap (f a))))))
+ ))
diff --git a/stdlib/test/test/lux/concurrency/promise.lux b/stdlib/test/test/lux/concurrency/promise.lux
new file mode 100644
index 000000000..77e5a0aed
--- /dev/null
+++ b/stdlib/test/test/lux/concurrency/promise.lux
@@ -0,0 +1,31 @@
+(;module:
+ lux
+ (lux (control monad)
+ (data [number]
+ text/format
+ error)
+ (concurrency promise)
+ (codata function
+ [io #*]))
+ lux/test)
+
+(test: "lux/concurrency/promise exports"
+ (test-all (match+ true (from-promise (future (io true))))
+ (match+ [] (from-promise (wait +500)))
+ (match+ [true false] (from-promise (seq (future (io true))
+ (future (io false)))))
+ (match+ (#;Left true) (from-promise (alt (delay +100 true)
+ (delay +200 false))))
+ (match+ (#;Right false) (from-promise (alt (delay +200 true)
+ (delay +100 false))))
+ (match+ true (from-promise (either (delay +100 true)
+ (delay +200 false))))
+ (match+ false (from-promise (either (delay +200 true)
+ (delay +100 false))))
+ (match (#;Some true) (poll (:: Monad<Promise> wrap true)))
+ (match #;None (poll (delay +200 true)))
+ (match false (io;run (resolve false (:: Monad<Promise> wrap true))))
+ (match true (io;run (resolve true (: (Promise Bool) (promise)))))
+ (match+ #;None (from-promise (time-out +100 (delay +200 true))))
+ (match+ (#;Some true) (from-promise (time-out +200 (delay +100 true))))
+ ))
diff --git a/stdlib/test/test/lux/concurrency/stm.lux b/stdlib/test/test/lux/concurrency/stm.lux
new file mode 100644
index 000000000..e29a5294b
--- /dev/null
+++ b/stdlib/test/test/lux/concurrency/stm.lux
@@ -0,0 +1,57 @@
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data [number]
+ (struct [list "" Functor<List>])
+ text/format)
+ (concurrency stm
+ [promise])
+ (codata function))
+ lux/test)
+
+(def: vars Int 5)
+(def: processes/vars Int 5)
+(def: iterations/processes Int 100)
+
+(test: "lux/concurrency/stm exports"
+ (let [_var (var 0)
+ changes (io;run (follow "test" _var))
+ tests (: (List (Test Int))
+ (map (lambda [_]
+ (let [_concurrency-var (var 0)]
+ (from-promise (do promise;Monad<Promise>
+ [_ (seqM @
+ (map (lambda [_]
+ (mapM @ (lambda [_] (commit (update inc _concurrency-var)))
+ (list;range 1 iterations/processes)))
+ (list;range 1 processes/vars)))]
+ (commit (read _concurrency-var))))))
+ (list;range 1 vars)))]
+ (test-all (match+ 0 (commit (do Monad<STM>
+ [value (read _var)]
+ (wrap (#;Right value)))))
+ (match+ 5 (commit (do Monad<STM>
+ [_ (write 5 _var)
+ value (read _var)]
+ (wrap (#;Right value)))))
+ (match+ 5 (commit (do Monad<STM>
+ [value (read _var)]
+ (wrap (#;Right value)))))
+ (match+ 15 (commit (do Monad<STM>
+ [_ (update (* 3) _var)
+ value (read _var)]
+ (wrap (#;Right value)))))
+ (match+ 15 (commit (do Monad<STM>
+ [value (read _var)]
+ (wrap (#;Right value)))))
+ (match+ [5 15] (do promise;Monad<Promise>
+ [?c1+changes' changes
+ #let [[c1 changes'] (default [-1 changes] ?c1+changes')]
+ ?c2+changes' changes'
+ #let [[c2 changes'] (default [-1 changes] ?c2+changes')]]
+ (wrap (#;Right [c1 c2]))))
+ ## Temporarily commented-out due to type-checking bug in
+ ## compiler...
+ ## (match+ _ (seqM Monad<Test> tests))
+ )))
diff --git a/stdlib/test/test/lux/data/bit.lux b/stdlib/test/test/lux/data/bit.lux
new file mode 100644
index 000000000..e20027818
--- /dev/null
+++ b/stdlib/test/test/lux/data/bit.lux
@@ -0,0 +1,65 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control [monad])
+ (codata [io])
+ (data ["&" bit]
+ number)
+ (math ["R" random]))
+ lux/test)
+
+(def: width Nat +64)
+
+(test: "Bitwise operations."
+ [pattern R;nat
+ idx (:: @ map (%+ width) R;nat)]
+ (all (assert "" (and (<+ (&;count (&;set idx pattern))
+ (&;count (&;clear idx pattern)))
+ (<=+ (&;count pattern)
+ (&;count (&;clear idx pattern)))
+ (>=+ (&;count pattern)
+ (&;count (&;set idx pattern)))
+
+ (or (and (&;set? idx pattern)
+ (not (&;set? idx (&;clear idx pattern))))
+ (and (not (&;set? idx pattern))
+ (&;set? idx (&;set idx pattern))))
+
+ (or (and (&;set? idx pattern)
+ (not (&;set? idx (&;flip idx pattern))))
+ (and (not (&;set? idx pattern))
+ (&;set? idx (&;flip idx pattern))))
+
+ (=+ width
+ (++ (&;count pattern)
+ (&;count (&;~ pattern))))
+
+ (=+ +0
+ (&;& pattern
+ (&;~ pattern)))
+ (=+ (&;~ +0)
+ (&;| pattern
+ (&;~ pattern)))
+ (=+ (&;~ +0)
+ (&;^ pattern
+ (&;~ pattern)))
+ (=+ +0
+ (&;^ pattern
+ pattern))
+
+ (|> pattern (&;rotate-left idx) (&;rotate-right idx) (=+ pattern))
+ (|> pattern (&;rotate-right idx) (&;rotate-left idx) (=+ pattern))
+ (|> pattern (&;rotate-left idx) (&;rotate-left (-+ idx width)) (=+ pattern))
+ (|> pattern (&;rotate-right idx) (&;rotate-right (-+ idx width)) (=+ pattern))
+ ))
+
+ (assert "Shift right respect the sign of ints."
+ (let [value (nat-to-int pattern)]
+ (if (< 0 value)
+ (< 0 (&;>> idx value))
+ (>= 0 (&;>> idx value)))))
+ ))
diff --git a/stdlib/test/test/lux/data/bool.lux b/stdlib/test/test/lux/data/bool.lux
new file mode 100644
index 000000000..218846e2e
--- /dev/null
+++ b/stdlib/test/test/lux/data/bool.lux
@@ -0,0 +1,38 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control [monad])
+ (codata [io])
+ (data bool)
+ (math ["R" random]))
+ lux/test)
+
+(test: "Boolean operations."
+ [value R;bool]
+ (assert "" (and (not (and value (not value)))
+ (or value (not value))
+
+ (not (:: Or@Monoid<Bool> unit))
+ (:: Or@Monoid<Bool> append value (not value))
+ (:: And@Monoid<Bool> unit)
+ (not (:: And@Monoid<Bool> append value (not value)))
+
+ (:: Eq<Bool> = value (not (not value)))
+ (not (:: Eq<Bool> = value (not value)))
+
+ (not (:: Eq<Bool> = value ((complement id) value)))
+ (:: Eq<Bool> = value ((complement not) value))
+
+ (case (|> value
+ (:: Codec<Text,Bool> encode)
+ (:: Codec<Text,Bool> decode))
+ (#;Right dec-value)
+ (:: Eq<Bool> = value dec-value)
+
+ (#;Left _)
+ false)
+ )))
diff --git a/stdlib/test/test/lux/data/char.lux b/stdlib/test/test/lux/data/char.lux
new file mode 100644
index 000000000..ab2e84d59
--- /dev/null
+++ b/stdlib/test/test/lux/data/char.lux
@@ -0,0 +1,47 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control [monad])
+ (codata [io])
+ (data char
+ [text])
+ (math ["R" random])
+ pipe
+ [host #- try])
+ lux/test)
+
+(test: "Char operations"
+ [value R;char]
+ (assert "" (and (:: Eq<Char> = value value)
+ (|> value code char (:: Eq<Char> = value))
+ (|> value
+ (:: Codec<Text,Char> encode)
+ (:: Codec<Text,Char> decode)
+ (case> (#;Right dec-value)
+ (:: Eq<Char> = value dec-value)
+
+ (#;Left _)
+ false))
+ (|> value as-text
+ (text;at +0) (default (undefined))
+ (:: Eq<Char> = value))
+ (|> value as-text text;upper-case
+ (text;at +0) (default (undefined))
+ (:: Ord<Char> <= value))
+ (|> value as-text text;lower-case
+ (text;at +0) (default (undefined))
+ (:: Ord<Char> >= value))
+ )))
+
+(test: "Special cases"
+ (all (assert "" (space? #" "))
+ (assert "" (space? #"\n"))
+ (assert "" (space? #"\t"))
+ (assert "" (space? #"\r"))
+ (assert "" (space? #"\f"))
+ (assert "" (not (space? #"a")))
+ ))
diff --git a/stdlib/test/test/lux/data/error.lux b/stdlib/test/test/lux/data/error.lux
new file mode 100644
index 000000000..a1d2cb6ff
--- /dev/null
+++ b/stdlib/test/test/lux/data/error.lux
@@ -0,0 +1,42 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data error))
+ lux/test)
+
+(test: "lux/data/error exports"
+ (all (match (#;Right 11)
+ (:: Functor<Error> map inc (: (Error Int)
+ (#;Right 10))))
+ (match (#;Left "YOLO")
+ (:: Functor<Error> map inc (: (Error Int)
+ (#;Left "YOLO"))))
+
+ (match (#;Right 20)
+ (:: Applicative<Error> wrap 20))
+ (match (#;Right 11)
+ (let [(^open) Applicative<Error>]
+ (apply (wrap inc) (wrap 10))))
+ (match (#;Left "YOLO")
+ (let [(^open) Applicative<Error>]
+ (apply (wrap inc) (#;Left "YOLO"))))
+
+ (match (#;Right 30)
+ (do Monad<Error>
+ [f (wrap +)
+ a (wrap 10)
+ b (wrap 20)]
+ (wrap (f a b))))
+ (match (#;Left "YOLO")
+ (do Monad<Error>
+ [f (wrap +)
+ a (#;Left "YOLO")
+ b (wrap 20)]
+ (wrap (f a b))))
+ ))
diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux
new file mode 100644
index 000000000..78b0b1a76
--- /dev/null
+++ b/stdlib/test/test/lux/data/format/json.lux
@@ -0,0 +1,314 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data [text "Text/" Monoid<Text>]
+ text/format
+ error
+ (format [json #* "JSON/" Eq<JSON> Codec<Text,JSON>])
+ (struct [vector #+ vector]
+ [dict]))
+ [compiler #+ with-gensyms]
+ (macro [ast]
+ [syntax #+ syntax:]
+ [poly #+ derived:])
+ [pipe]
+ test)
+ )
+
+## [Utils]
+(syntax: (reads-to-itself expr)
+ (with-gensyms [g!json g!parsed g!message]
+ (wrap (list (` (: (Test Unit)
+ (let [(~ g!json) (~ expr)]
+ (case (|> (~ g!json) JSON/encode JSON/decode)
+ (#;Left (~ g!message))
+ (fail (~ g!message))
+
+ (#;Right (~ g!parsed))
+ (if (JSON/= (~ g!json) (~ g!parsed))
+ (~ (' (:: Monad<Test> wrap [])))
+ (fail (format "Expression does not parse to itself: " (~ (ast;text (ast;ast-to-text expr)))
+ "\n\nWhich is: " (|> (~ g!json) JSON/encode)
+ "\n\nInstead, it parsed to: " (JSON/encode (~ g!parsed))))
+ ))))
+ )))))
+
+## [Tests]
+## (derived: (Codec<JSON,?> ;Bool))
+## (derived: (Codec<JSON,?> ;Int))
+## (derived: (Codec<JSON,?> ;Real))
+## (derived: (Codec<JSON,?> ;Char))
+## (derived: (Codec<JSON,?> ;Text))
+
+## (type: Int-List (List Int))
+## (derived: (Codec<JSON,?> ;;Int-List))
+
+## (type: Int-Maybe (Maybe Int))
+## (derived: (Codec<JSON,?> ;;Int-Maybe))
+
+## (type: Triple [Bool Int Text])
+## (derived: (Codec<JSON,?> ;;Triple))
+
+## (type: User
+## {#alive? Bool
+## #age Int
+## #name Text})
+## (derived: (Codec<JSON,?> ;;User))
+
+## (type: Options
+## (#One Bool)
+## (#Two Int)
+## (#Three Text))
+## (derived: (Codec<JSON,?> ;;Options))
+
+## (test: "Auto-generated codecs"
+## (let% [<tests> (do-template [<input> <output> <codec>]
+## [(match <output>
+## (|> <input>
+## (:: <codec> encode)
+## JSON/encode))
+## (match+ <input>
+## (should-pass (|> (JSON/decode <output>)
+## (pipe;%> Error/Monad
+## [(:: <codec> decode)]))))]
+
+## [true "true" Codec<JSON,Bool>]
+## [123 "123.0" Codec<JSON,Int>]
+## [123.45 "123.45" Codec<JSON,Real>]
+## [#"a" "\"a\"" Codec<JSON,Char>]
+## ["yolo" "\"yolo\"" Codec<JSON,Text>]
+
+## [(#;Cons 1 (#;Cons 2 (#;Cons 3 #;Nil))) "[1.0,2.0,3.0]" Codec<JSON,Int-List>]
+## [#;Nil "[]" Codec<JSON,Int-List>]
+## [(#;Some 1) "1.0" Codec<JSON,Int-Maybe>]
+## [#;None "null" Codec<JSON,Int-Maybe>]
+## [[false 456 "lol"] "[false,456.0,\"lol\"]" Codec<JSON,Triple>]
+## [{#alive? true #age 25 #name "Eduardo Julian"}
+## "{\"alive?\":true,\"age\":25.0,\"name\":\"Eduardo Julian\"}"
+## Codec<JSON,User>]
+## [(#One true) "[\"One\",true]" Codec<JSON,Options>]
+## [(#Two 123) "[\"Two\",123.0]" Codec<JSON,Options>]
+## [(#Three "yolo") "[\"Three\",\"yolo\"]" Codec<JSON,Options>]
+## )]
+## (test-all <tests>
+## )))
+
+(test: "Basics"
+ (test-all (match #json;Null
+ null)
+
+ (match (#json;Boolean true)
+ (gen-boolean true))
+
+ (match (#json;Boolean false)
+ (gen-boolean false))
+
+ (match (#json;Number 123.45)
+ (gen-number 123.45))
+
+ (match (#json;String "YOLO")
+ (gen-string "YOLO"))
+
+ ## (match (^ (#json;Array (list (#json;Boolean true) (#json;Number 123.45) (#json;String "YOLO"))))
+ ## (json [(gen-boolean true) (gen-number 123.45) (gen-string "YOLO")]))
+
+ ## (match (^ (#json;Object (list ["yolo" (#json;Boolean true)]
+ ## ["lol" (#json;Number 123.45)])))
+ ## (json {"yolo" (gen-boolean true)
+ ## "lol" (gen-number 123.45)}))
+
+ (match (#;Some (#json;Boolean true))
+ (get "yolo" (json {"yolo" true
+ "lol" 123.45})))
+
+ (match (#;Left _)
+ (get "yolo" (json {})))
+
+ ## (match (^ (#;Some (#json;Object (list ["lol" (#json;Number 123.45)]
+ ## ["yolo" (#json;Boolean true)]))))
+ ## (|> (json {"yolo" (gen-boolean true)})
+ ## (set "lol" (gen-number 123.45))))
+
+ (match (#;Right true)
+ (get-boolean "value" (json {"value" true})))
+
+ (match (#;Right 123.45)
+ (get-number "value" (json {"value" 123.45})))
+
+ (match (#;Right "YOLO")
+ (get-string "value" (json {"value" "YOLO"})))
+
+ ## (match (^ (#;Right (list (#json;Boolean true) (#json;Number 123.45) (#json;String "YOLO"))))
+ ## (get-array "value" (json {"value" (json [(gen-boolean true)
+ ## (gen-number 123.45)
+ ## (gen-string "YOLO")])})))
+
+ ## (match (^ (#;Right (list ["yolo" (#json;Boolean true)]
+ ## ["lol" (#json;Number 123.45)])))
+ ## (get-object "value" (json {"value" (json {"yolo" (gen-boolean true)
+ ## "lol" (gen-number 123.45)})})))
+
+ (match (#;Left _)
+ (get-array "value" (json {})))
+
+ (match (#;Left _)
+ (get-array "value" (gen-boolean true)))
+ ))
+
+(test: "Encoding"
+ (test-all (match "null"
+ (JSON/encode (json #null)))
+
+ (match "123.0"
+ (JSON/encode (json 123)))
+
+ (match "123.46"
+ (JSON/encode (json 123.46)))
+
+ (match "true"
+ (JSON/encode (json true)))
+
+ (match "false"
+ (JSON/encode (json false)))
+
+ (match "\"YOLO\""
+ (JSON/encode (json "YOLO")))
+
+ (match "[null,123.46,true,\"YOLO\",[\"nyan\",\"cat\"]]"
+ (JSON/encode (json [#null 123.46 true "YOLO" ["nyan" "cat"]])))
+
+ (match "{\"foo\":\"bar\",\"baz\":null,\"quux\":[\"nyan\",{\"cat\":\"meme\"}]}"
+ (JSON/encode (json {"foo" "bar"
+ "baz" #null
+ "quux" ["nyan" {"cat" "meme"}]})))
+ ))
+
+(test: "Decoding"
+ (test-all (reads-to-itself (json #null))
+ (reads-to-itself (json 123))
+ (reads-to-itself (json 123.46))
+ (reads-to-itself (json true))
+ (reads-to-itself (json false))
+ (reads-to-itself (json "\tY\"OLO\n"))
+ (reads-to-itself (json [#null 123.46 true "YOLO" ["nyan" "cat"]]))
+ (reads-to-itself (json {"foo" "bar"
+ "baz" #null
+ "quux" ["nyan" {"cat" "meme"}]}))
+ ))
+
+(test: "Parser"
+ (test-all (should-pass (run unit
+ (json #null)))
+ (should-fail (run unit
+ (json 123)))
+
+ (match+ 123.45
+ (should-pass (run real
+ (json 123.45))))
+ (should-fail (run real
+ (json #null)))
+
+ (match+ 123
+ (should-pass (run int
+ (json 123))))
+ (should-fail (run int
+ (json #null)))
+
+ (match+ true
+ (should-pass (run bool
+ (json true))))
+ (should-fail (run bool
+ (json 123)))
+
+ (match+ "YOLO"
+ (should-pass (run text
+ (json "YOLO"))))
+ (should-fail (run text
+ (json 123)))
+
+ (match+ (^ (list "YOLO" "LOL" "MEME"))
+ (should-pass (run (array text)
+ (json ["YOLO" "LOL" "MEME"]))))
+ (should-fail (run (array text)
+ (json 123)))
+
+ (match+ "LOL"
+ (should-pass (run (at +1 text)
+ (json ["YOLO" "LOL" "MEME"]))))
+ (should-fail (run (array text)
+ (json 123)))
+
+ (match+ "MEME"
+ (should-pass (run (field "baz" text)
+ (json {"foo" "YOLO"
+ "bar" "LOL"
+ "baz" "MEME"}))))
+ (should-fail (run (field "baz" text)
+ (json 123)))
+
+ (match+ (#json;Number 123.0)
+ (should-pass (run any
+ (json 123))))
+
+ (match+ ["YOLO" "MEME"]
+ (should-pass (run (seq (field "foo" text)
+ (field "baz" text))
+ (json {"foo" "YOLO"
+ "bar" "LOL"
+ "baz" "MEME"}))))
+ (should-fail (run (seq (field "foo" text)
+ (field "baz" text))
+ (json {"foo" "YOLO"
+ "bar" "LOL"})))
+
+ (match+ (#;Left "YOLO")
+ (should-pass (run (alt (field "foo" text)
+ (field "baz" text))
+ (json {"foo" "YOLO"
+ "bar" "LOL"
+ "baz" "MEME"}))))
+ (match+ (#;Right "MEME")
+ (should-pass (run (alt (field "fool" text)
+ (field "baz" text))
+ (json {"foo" "YOLO"
+ "bar" "LOL"
+ "baz" "MEME"}))))
+ (should-fail (run (alt (field "fool" text)
+ (field "baz" text))
+ (json {"foo" "YOLO"
+ "bar" "LOL"})))
+
+ (match+ "YOLO"
+ (should-pass (run (either (field "foo" text)
+ (field "baz" text))
+ (json {"foo" "YOLO"
+ "bar" "LOL"
+ "baz" "MEME"}))))
+ (match+ "MEME"
+ (should-pass (run (either (field "fool" text)
+ (field "baz" text))
+ (json {"foo" "YOLO"
+ "bar" "LOL"
+ "baz" "MEME"}))))
+ (should-fail (run (either (field "fool" text)
+ (field "baz" text))
+ (json {"foo" "YOLO"
+ "bar" "LOL"})))
+
+ (match+ (#;Some "YOLO")
+ (should-pass (run (opt (field "foo" text))
+ (json {"foo" "YOLO"
+ "bar" "LOL"
+ "baz" "MEME"}))))
+ (match+ #;None
+ (should-pass (run (opt (field "fool" text))
+ (json {"foo" "YOLO"
+ "bar" "LOL"
+ "baz" "MEME"}))))
+ ))
diff --git a/stdlib/test/test/lux/data/ident.lux b/stdlib/test/test/lux/data/ident.lux
new file mode 100644
index 000000000..8cb85175f
--- /dev/null
+++ b/stdlib/test/test/lux/data/ident.lux
@@ -0,0 +1,53 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data ["&" ident]
+ [text "Text/" Eq<Text>])
+ (math ["R" random])
+ pipe)
+ lux/test)
+
+(test: "Idents"
+ [## First Ident
+ sizeM1 (|> R;nat (:: @ map (%+ +100)))
+ sizeN1 (|> R;nat (:: @ map (%+ +100)))
+ module1 (R;text sizeM1)
+ name1 (R;text sizeN1)
+ #let [ident1 [module1 name1]]
+ ## Second Ident
+ sizeM2 (|> R;nat (:: @ map (%+ +100)))
+ sizeN2 (|> R;nat (:: @ map (%+ +100)))
+ module2 (R;text sizeM2)
+ name2 (R;text sizeN2)
+ #let [ident2 [module2 name2]]
+ #let [(^open "&/") &;Eq<Ident>
+ (^open "&/") &;Codec<Text,Ident>]]
+ (all (assert "Can get the module & name parts of an ident."
+ (and (== module1 (&;module ident1))
+ (== name1 (&;name ident1))))
+
+ (assert "Can compare idents for equality."
+ (and (&/= ident1 ident1)
+ (if (&/= ident1 ident2)
+ (and (Text/= module1 module2)
+ (Text/= name1 name2))
+ (or (not (Text/= module1 module2))
+ (not (Text/= name1 name2))))))
+
+ (assert "Can encode idents as text."
+ (|> ident1
+ &/encode &/decode
+ (case> (#;Right dec-ident) (&/= ident1 dec-ident)
+ _ false)))
+
+ (assert "Encoding an ident without a module component results in text equal to the name of the ident."
+ (if (text;empty? module1)
+ (Text/= name1 (&/encode ident1))
+ true))
+ ))
diff --git a/stdlib/test/test/lux/data/identity.lux b/stdlib/test/test/lux/data/identity.lux
new file mode 100644
index 000000000..f492a801e
--- /dev/null
+++ b/stdlib/test/test/lux/data/identity.lux
@@ -0,0 +1,36 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad
+ comonad)
+ (data identity
+ [text "Text/" Monoid<Text>]))
+ lux/test)
+
+(test: "lux/data/identity exports"
+ (all (match "yololol" (:: Functor<Identity> map (Text/append "yolo") "lol"))
+
+ (match "yolo" (:: Applicative<Identity> wrap "yolo"))
+ (match "yololol" (let [(^open) Applicative<Identity>]
+ (apply (wrap (Text/append "yolo")) (wrap "lol"))))
+
+ (match "yololol"
+ (do Monad<Identity>
+ [f (wrap Text/append)
+ a (wrap "yolo")
+ b (wrap "lol")]
+ (wrap (f a b))))
+
+ (match "yololol" (:: CoMonad<Identity> unwrap "yololol"))
+ (match "yololol"
+ (be CoMonad<Identity>
+ [f Text/append
+ a "yolo"
+ b "lol"]
+ (f a b)))
+ ))
diff --git a/stdlib/test/test/lux/data/log.lux b/stdlib/test/test/lux/data/log.lux
new file mode 100644
index 000000000..c052a29da
--- /dev/null
+++ b/stdlib/test/test/lux/data/log.lux
@@ -0,0 +1,32 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data log
+ [text "Text/" Monoid<Text>]
+ [number])
+ (codata function))
+ lux/test)
+
+(test: "lux/data/log exports"
+ (all (match ["" 11]
+ (:: Functor<Log> map inc ["" 10]))
+ (match ["" 20]
+ (:: (Applicative<Log> text;Monoid<Text>) wrap 20))
+ (match ["" 30]
+ (let [(^open) (Applicative<Log> text;Monoid<Text>)]
+ (apply (wrap (+ 10)) (wrap 20))))
+ (match ["" 30]
+ (do (Monad<Log> text;Monoid<Text>)
+ [f (wrap +)
+ a (wrap 10)
+ b (wrap 20)]
+ (wrap (f a b))))
+ (match ["YOLO" []]
+ (log "YOLO"))
+ ))
diff --git a/stdlib/test/test/lux/data/maybe.lux b/stdlib/test/test/lux/data/maybe.lux
new file mode 100644
index 000000000..bd44593d7
--- /dev/null
+++ b/stdlib/test/test/lux/data/maybe.lux
@@ -0,0 +1,49 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data maybe
+ [text "Text/" Monoid<Text>]
+ [number]))
+ lux/test)
+
+(test: "lux/data/maybe exports"
+ (all (match #;None (:: Monoid<Maybe> unit))
+ (match (#;Some "yolo") (:: Monoid<Maybe> append (#;Some "yolo") (#;Some "lol")))
+ (match (#;Some "yolo") (:: Monoid<Maybe> append (#;Some "yolo") #;None))
+ (match (#;Some "lol") (:: Monoid<Maybe> append #;None (#;Some "lol")))
+ (match #;None (: (Maybe Text) (:: Monoid<Maybe> append #;None #;None)))
+
+ (match #;None (:: Functor<Maybe> map (Text/append "yolo") #;None))
+ (match (#;Some "yololol") (:: Functor<Maybe> map (Text/append "yolo") (#;Some "lol")))
+
+ (match (#;Some "yolo") (:: Applicative<Maybe> wrap "yolo"))
+ (match (#;Some "yololol")
+ (let [(^open) Applicative<Maybe>]
+ (apply (wrap (Text/append "yolo")) (wrap "lol"))))
+
+ (match (#;Some "yololol")
+ (do Monad<Maybe>
+ [f (wrap Text/append)
+ a (wrap "yolo")
+ b (wrap "lol")]
+ (wrap (f a b))))
+
+ (match true (:: (Eq<Maybe> text;Eq<Text>) =
+ (: (Maybe Text) #;None)
+ (: (Maybe Text) #;None)))
+ (match true (:: (Eq<Maybe> text;Eq<Text>) =
+ (#;Some "yolo")
+ (#;Some "yolo")))
+ (match false (:: (Eq<Maybe> text;Eq<Text>) =
+ (#;Some "yolo")
+ (#;Some "lol")))
+ (match false (:: (Eq<Maybe> text;Eq<Text>) =
+ (#;Some "yolo")
+ (: (Maybe Text) #;None)))
+ ))
diff --git a/stdlib/test/test/lux/data/number.lux b/stdlib/test/test/lux/data/number.lux
new file mode 100644
index 000000000..adefb480a
--- /dev/null
+++ b/stdlib/test/test/lux/data/number.lux
@@ -0,0 +1,135 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data number
+ [text "Text/" Monoid<Text>]
+ text/format)
+ (math ["R" random])
+ pipe)
+ lux/test)
+
+(do-template [category rand-gen <Eq> <Ord>]
+ [(test: (format "[" category "] " "Eq & Ord")
+ [x rand-gen
+ y rand-gen]
+ (assert "" (and (:: <Eq> = x x)
+ (or (:: <Eq> = x y)
+ (:: <Ord> < y x)
+ (:: <Ord> > y x)))))]
+
+ ["Nat" R;nat Eq<Nat> Ord<Nat>]
+ ["Int" R;int Eq<Int> Ord<Int>]
+ ["Real" R;real Eq<Real> Ord<Real>]
+ ["Frac" R;frac Eq<Frac> Ord<Frac>]
+ )
+
+(do-template [category rand-gen <Number>]
+ [(test: (format "[" category "] " "Number")
+ [x rand-gen]
+ (assert "" (let [(^open) <Number>]
+ (and (>= x (abs x))
+ (<= x (negate (abs x)))
+ (= x (* (signum x)
+ (abs x)))))))]
+
+ ["Nat" R;nat Number<Nat>]
+ ["Int" R;int Number<Int>]
+ ["Real" R;real Number<Real>]
+ )
+
+(do-template [category rand-gen <Enum> <Number>]
+ [(test: (format "[" category "] " "Enum")
+ [x rand-gen]
+ (assert "" (let [(^open) <Number>]
+ (and (> x
+ (:: <Enum> succ x))
+ (< x
+ (:: <Enum> pred x))
+
+ (= x
+ (|> x (:: <Enum> pred) (:: <Enum> succ)))
+ (= x
+ (|> x (:: <Enum> succ) (:: <Enum> pred)))
+ ))))]
+
+ ["Nat" R;nat Enum<Nat> Number<Nat>]
+ ["Int" R;int Enum<Int> Number<Int>]
+ )
+
+(do-template [category rand-gen <Number> <Bounded>]
+ [(test: (format "[" category "] " "Bounded")
+ [x rand-gen]
+ (assert "" (let [(^open) <Number>]
+ (and (<= x (:: <Bounded> bottom))
+ (>= x (:: <Bounded> top))
+ ))))]
+
+ ["Nat" R;nat Number<Nat> Bounded<Nat>]
+ ["Int" R;int Number<Int> Bounded<Int>]
+ ["Real" R;real Number<Real> Bounded<Real>]
+ )
+
+(do-template [category rand-gen <Number> <Monoid> <cap>]
+ [(test: (format "[" category "] " "Monoid")
+ [x (:: @ map (|>. (:: <Number> abs) <cap>) rand-gen)]
+ (assert "" (let [(^open) <Number>
+ (^open) <Monoid>]
+ (and (= x (append unit x))
+ (= x (append x unit))
+ (= unit (append unit unit))
+ (>= x (append x x))))))]
+
+ ["Nat/Add" R;nat Number<Nat> Add@Monoid<Nat> (;%+ +1000)]
+ ["Nat/Mul" R;nat Number<Nat> Mul@Monoid<Nat> (;%+ +1000)]
+ ["Nat/Min" R;nat Number<Nat> Min@Monoid<Nat> (;%+ +1000)]
+ ["Nat/Max" R;nat Number<Nat> Max@Monoid<Nat> (;%+ +1000)]
+ ["Int/Add" R;int Number<Int> Add@Monoid<Int> (;% 1000)]
+ ["Int/Mul" R;int Number<Int> Mul@Monoid<Int> (;% 1000)]
+ ["Int/Min" R;int Number<Int> Min@Monoid<Int> (;% 1000)]
+ ["Int/Max" R;int Number<Int> Max@Monoid<Int> (;% 1000)]
+ ["Real/Add" R;real Number<Real> Add@Monoid<Real> (;%. 1000.0)]
+ ["Real/Mul" R;real Number<Real> Mul@Monoid<Real> (;%. 1000.0)]
+ ["Real/Min" R;real Number<Real> Min@Monoid<Real> (;%. 1000.0)]
+ ["Real/Max" R;real Number<Real> Max@Monoid<Real> (;%. 1000.0)]
+ )
+
+(do-template [category rand-gen <Number> <Codec>]
+ [(test: (format "[" category "] " "Codec")
+ [x rand-gen]
+ (assert "" (|> x
+ (:: <Codec> encode)
+ (:: <Codec> decode)
+ (case> (#;Right x')
+ (:: <Number> = x x')
+
+ (#;Left _)
+ false))))]
+
+ ["Nat" R;nat Number<Nat> Codec<Text,Nat>]
+ ["Int" R;int Number<Int> Codec<Text,Int>]
+ ["Real" R;real Number<Real> Codec<Text,Real>]
+ ## ["Frac" R;frac Number<Frac> Codec<Text,Frac>]
+ )
+
+(do-template [category rand-gen <Number> <Codec>]
+ [(test: (format "[" category "] " "Alternative formats")
+ [x rand-gen]
+ (assert "" (|> x
+ (:: <Codec> encode)
+ (:: <Codec> decode)
+ (case> (#;Right x')
+ (:: <Number> = x x')
+
+ (#;Left _)
+ false))))]
+
+ ["Nat/Binary" R;nat Number<Nat> Binary@Codec<Text,Nat>]
+ ["Nat/Octal" R;nat Number<Nat> Octal@Codec<Text,Nat>]
+ ["Nat/Hex" R;nat Number<Nat> Hex@Codec<Text,Nat>]
+ )
diff --git a/stdlib/test/test/lux/data/product.lux b/stdlib/test/test/lux/data/product.lux
new file mode 100644
index 000000000..51c23e47d
--- /dev/null
+++ b/stdlib/test/test/lux/data/product.lux
@@ -0,0 +1,20 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data product
+ [text "Text/" Monoid<Text>]
+ [number])
+ (codata function))
+ lux/test)
+
+(test: "Product operations"
+ (all (match 1 (left [1 2]))
+ (match 2 (right [1 2]))
+ (match [2 1] (swap [1 2]))
+ ))
diff --git a/stdlib/test/test/lux/data/struct/array.lux b/stdlib/test/test/lux/data/struct/array.lux
new file mode 100644
index 000000000..171631bd9
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/array.lux
@@ -0,0 +1,130 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control [monad])
+ (codata [io])
+ (data (struct ["&" array]
+ [list])
+ [number])
+ (math ["R" random])
+ pipe)
+ lux/test)
+
+(def: bounded-size
+ (R;Random Nat)
+ (|> R;nat
+ (:: R;Monad<Random> map (|>. (%+ +100) (++ +1)))))
+
+(test: "Arrays and their copies"
+ [size bounded-size
+ original (R;array size R;nat)
+ #let [clone (&;clone original)
+ copy (: (&;Array Nat)
+ (&;new size))
+ manual-copy (: (&;Array Nat)
+ (&;new size))]]
+ (all (assert "Size function must correctly return size of array."
+ (=+ size (&;size original)))
+ (assert "Cloning an array should yield and identical array, but not the same one."
+ (and (:: (&;Eq<Array> number;Eq<Nat>) = original clone)
+ (not (== original clone))))
+ (assert "Full-range manual copies should give the same result as cloning."
+ (exec (&;copy size +0 original +0 copy)
+ (and (:: (&;Eq<Array> number;Eq<Nat>) = original copy)
+ (not (== original copy)))))
+ (assert "Array folding should go over all values."
+ (exec (:: &;Fold<Array> fold
+ (lambda [x idx]
+ (exec (&;put idx x manual-copy)
+ (inc+ idx)))
+ +0
+ original)
+ (:: (&;Eq<Array> number;Eq<Nat>) = original manual-copy)))
+ (assert "Transformations between (full) arrays and lists shouldn't cause lose or change any values."
+ (|> original
+ &;to-list &;from-list
+ (:: (&;Eq<Array> number;Eq<Nat>) = original)))
+ ))
+
+(test: "Array mutation"
+ [size bounded-size
+ idx (:: @ map (%+ size) R;nat)
+ array (|> (R;array size R;nat)
+ (R;filter (|>. &;to-list (list;any? odd?+))))
+ #let [value (default (undefined)
+ (&;get idx array))]]
+ (all (assert "Shouldn't be able to find a value in an unoccupied cell."
+ (case (&;get idx (&;remove idx array))
+ (#;Some _) false
+ #;None true))
+ (assert "You should be able to access values put into the array."
+ (case (&;get idx (&;put idx value array))
+ (#;Some value') (=+ value' value)
+ #;None false))
+ (assert "All cells should be occupied on a full array."
+ (and (=+ size (&;occupied array))
+ (=+ +0 (&;vacant array))))
+ (assert "Filtering mutates the array to remove invalid values."
+ (exec (&;filter even?+ array)
+ (and (<+ size (&;occupied array))
+ (>+ +0 (&;vacant array))
+ (=+ size (++ (&;occupied array)
+ (&;vacant array))))))
+ ))
+
+(test: "Finding values."
+ [size bounded-size
+ array (|> (R;array size R;nat)
+ (R;filter (|>. &;to-list (list;any? even?+))))]
+ (all (assert "Can find values inside arrays."
+ (|> (&;find even?+ array)
+ (case> (#;Some _) true
+ #;None false)))
+ (assert "Can find values inside arrays (with access to indices)."
+ (|> (&;find+ (lambda [idx n]
+ (and (even?+ n)
+ (<+ size idx)))
+ array)
+ (case> (#;Some _) true
+ #;None false)))))
+
+(test: "Functor"
+ [size bounded-size
+ array (R;array size R;nat)]
+ (let [(^open) &;Functor<Array>
+ (^open) (&;Eq<Array> number;Eq<Nat>)]
+ (all (assert "Functor shouldn't alter original array."
+ (let [copy (map id array)]
+ (and (= array copy)
+ (not (== array copy)))))
+ (assert "Functor should go over all available array elements."
+ (let [there (map inc+ array)
+ back-again (map dec+ there)]
+ (and (not (= array there))
+ (= array back-again)))))))
+
+(test: "Monoid"
+ [sizeL bounded-size
+ sizeR bounded-size
+ left (R;array sizeL R;nat)
+ right (R;array sizeR R;nat)
+ #let [(^open) &;Monoid<Array>
+ (^open) (&;Eq<Array> number;Eq<Nat>)
+ fusion (append left right)]]
+ (all (assert "Appending two arrays should produce a new one twice as large."
+ (=+ (++ sizeL sizeR) (&;size fusion)))
+ (assert "First elements of fused array should equal the first array."
+ (|> (: (&;Array Nat)
+ (&;new sizeL))
+ (&;copy sizeL +0 fusion +0)
+ (= left)))
+ (assert "Last elements of fused array should equal the second array."
+ (|> (: (&;Array Nat)
+ (&;new sizeR))
+ (&;copy sizeR sizeL fusion +0)
+ (= right)))
+ ))
diff --git a/stdlib/test/test/lux/data/struct/dict.lux b/stdlib/test/test/lux/data/struct/dict.lux
new file mode 100644
index 000000000..06b9550aa
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/dict.lux
@@ -0,0 +1,136 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad
+ [eq])
+ (data [text "Text/" Monoid<Text>]
+ text/format
+ [number]
+ [char]
+ (struct ["&" dict]
+ [list "List/" Fold<List> Functor<List>]))
+ (codata function)
+ (math ["R" random])
+ pipe)
+ lux/test)
+
+(test: "Dictionaries."
+ [#let [capped-nat (:: R;Monad<Random> map (%+ +100) R;nat)]
+ size capped-nat
+ dict (R;dict char;Hash<Char> size R;char capped-nat)
+ non-key (|> R;char
+ (R;filter (lambda [key] (not (&;contains? key dict)))))
+ test-val (|> R;nat
+ (R;filter (lambda [val] (not (list;member? number;Eq<Nat> (&;values dict) val)))))]
+ (all (assert "Size function should correctly represent Dict size."
+ (=+ size (&;size dict)))
+
+ (assert "Dicts of size 0 should be considered empty."
+ (if (=+ +0 size)
+ (&;empty? dict)
+ (not (&;empty? dict))))
+
+ (assert "The functions 'entries', 'keys' and 'values' should be synchronized."
+ (:: (list;Eq<List> (eq;conj char;Eq<Char> number;Eq<Nat>)) =
+ (&;entries dict)
+ (list;zip2 (&;keys dict)
+ (&;values dict))))
+
+ (assert "Dict should be able to recognize it's own keys."
+ (list;every? (lambda [key] (&;contains? key dict))
+ (&;keys dict)))
+
+ (assert "Should be able to get every key."
+ (list;every? (lambda [key] (case (&;get key dict)
+ (#;Some _) true
+ _ false))
+ (&;keys dict)))
+
+ (assert "Shouldn't be able to access non-existant keys."
+ (case (&;get non-key dict)
+ (#;Some _) false
+ _ true))
+
+ (assert "Should be able to put and then get a value."
+ (case (&;get non-key (&;put non-key test-val dict))
+ (#;Some v) (=+ test-val v)
+ _ true))
+
+ (assert "Should be able to put~ and then get a value."
+ (case (&;get non-key (&;put~ non-key test-val dict))
+ (#;Some v) (=+ test-val v)
+ _ true))
+
+ (assert "Shouldn't be able to put~ an existing key."
+ (or (=+ +0 size)
+ (let [first-key (|> dict &;keys list;head (default (undefined)))]
+ (case (&;get first-key (&;put~ first-key test-val dict))
+ (#;Some v) (not (=+ test-val v))
+ _ true))))
+
+ (assert "Removing a key should make it's value inaccessible."
+ (let [base (&;put non-key test-val dict)]
+ (and (&;contains? non-key base)
+ (not (&;contains? non-key (&;remove non-key base))))))
+
+ (assert "Should be possible to update values via their keys."
+ (let [base (&;put non-key test-val dict)
+ updt (&;update non-key inc+ base)]
+ (case [(&;get non-key base) (&;get non-key updt)]
+ [(#;Some x) (#;Some y)]
+ (=+ (inc+ x) y)
+
+ _
+ false)))
+
+ (assert "Additions and removals to a Dict should affect its size."
+ (let [plus (&;put non-key test-val dict)
+ base (&;remove non-key plus)]
+ (and (=+ (inc+ (&;size dict)) (&;size plus))
+ (=+ (dec+ (&;size plus)) (&;size base)))))
+
+ (assert "A Dict should equal itself & going to<->from lists shouldn't change that."
+ (let [(^open) (&;Eq<Dict> number;Eq<Nat>)]
+ (and (= dict dict)
+ (|> dict &;entries (&;from-list char;Hash<Char>) (= dict)))))
+
+ (assert "Merging a Dict to itself changes nothing."
+ (let [(^open) (&;Eq<Dict> number;Eq<Nat>)]
+ (= dict (&;merge dict dict))))
+
+ (assert "If you merge, and the second dict has overlapping keys, it should overwrite yours."
+ (let [dict' (|> dict &;entries
+ (List/map (lambda [[k v]] [k (inc+ v)]))
+ (&;from-list char;Hash<Char>))
+ (^open) (&;Eq<Dict> number;Eq<Nat>)]
+ (= dict' (&;merge dict' dict))))
+
+ (assert "Can merge values in such a way that they become combined."
+ (list;every? (lambda [[x x*2]] (=+ (*+ +2 x) x*2))
+ (list;zip2 (&;values dict)
+ (&;values (&;merge-with ++ dict dict)))))
+
+ (assert "Should be able to select subset of keys from dict."
+ (|> dict
+ (&;put non-key test-val)
+ (&;select (list non-key))
+ &;size
+ (=+ +1)))
+
+ (assert "Should be able to re-bind existing values to different keys."
+ (or (=+ +0 size)
+ (let [first-key (|> dict &;keys list;head (default (undefined)))
+ rebound (&;re-bind first-key non-key dict)]
+ (and (=+ (&;size dict) (&;size rebound))
+ (&;contains? non-key rebound)
+ (not (&;contains? first-key rebound))
+ (=+ (default (undefined)
+ (&;get first-key dict))
+ (default (undefined)
+ (&;get non-key rebound)))))))
+ ))
diff --git a/stdlib/test/test/lux/data/struct/list.lux b/stdlib/test/test/lux/data/struct/list.lux
new file mode 100644
index 000000000..6baf13c6c
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/list.lux
@@ -0,0 +1,191 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data (struct ["&" list])
+ [text "Text/" Monoid<Text>]
+ [number]
+ [bool]
+ [product])
+ (math ["R" random])
+ pipe)
+ lux/test)
+
+(def: bounded-size
+ (R;Random Nat)
+ (|> R;nat
+ (:: R;Monad<Random> map (|>. (%+ +100) (++ +10)))))
+
+(test: "Lists"
+ [size bounded-size
+ idx (:: @ map (%+ size) R;nat)
+ sample (R;list size R;nat)
+ other-size bounded-size
+ other-sample (R;list other-size R;nat)
+ separator R;nat
+ #let [(^open) (&;Eq<List> number;Eq<Nat>)
+ (^open "&/") &;Functor<List>]]
+ (all (assert "The size function should correctly portray the size of the list."
+ (=+ size (&;size sample)))
+
+ (assert "The repeat function should produce as many elements as asked of it."
+ (=+ size (&;size (&;repeat size []))))
+
+ (assert "Reversing a list does not change it's size."
+ (=+ (&;size sample)
+ (&;size (&;reverse sample))))
+
+ (assert "Reversing a list twice results in the original list."
+ (= sample
+ (&;reverse (&;reverse sample))))
+
+ (assert "Filtering by a predicate and its complement should result in a number of elements equal to the original list."
+ (and (=+ (&;size sample)
+ (++ (&;size (&;filter even?+ sample))
+ (&;size (&;filter (bool;complement even?+) sample))))
+ (let [[plus minus] (&;partition even?+ sample)]
+ (=+ (&;size sample)
+ (++ (&;size plus)
+ (&;size minus))))))
+
+ (assert "If every element in a list satisfies a predicate, there can't be any that satisfy its complement."
+ (if (&;every? even?+ sample)
+ (and (not (&;any? (bool;complement even?+) sample))
+ (&;empty? (&;filter (bool;complement even?+) sample)))
+ (&;any? (bool;complement even?+) sample)))
+
+ (assert "Any element of the list can be considered it's member."
+ (let [elem (default (undefined)
+ (&;at idx sample))]
+ (&;member? number;Eq<Nat> sample elem)))
+
+ (assert "Appending the head and the tail should yield the original list."
+ (let [head (default (undefined)
+ (&;head sample))
+ tail (default (undefined)
+ (&;tail sample))]
+ (= sample
+ (#;Cons head tail))))
+
+ (assert "Appending the inits and the last should yield the original list."
+ (let [(^open) &;Monoid<List>
+ inits (default (undefined)
+ (&;inits sample))
+ last (default (undefined)
+ (&;last sample))]
+ (= sample
+ (append inits (list last)))))
+
+ (assert "Functor should go over every element of the list."
+ (let [(^open) &;Functor<List>
+ there (map inc+ sample)
+ back-again (map dec+ there)]
+ (and (not (= sample there))
+ (= sample back-again))))
+
+ (assert "Splitting a list into chunks and re-appending them should yield the original list."
+ (let [(^open) &;Monoid<List>
+ [left right] (&;split idx sample)
+ [left' right'] (&;split-with even?+ sample)]
+ (and (= sample
+ (append left right))
+ (= sample
+ (append left' right'))
+ (= sample
+ (append (&;take idx sample)
+ (&;drop idx sample)))
+ (= sample
+ (append (&;take-while even?+ sample)
+ (&;drop-while even?+ sample)))
+ )))
+
+ (assert "Segmenting the list in pairs should yield as many elements as N/2."
+ (=+ (/+ +2 size)
+ (&;size (&;as-pairs sample))))
+
+ (assert "Sorting a list shouldn't change it's size."
+ (=+ (&;size sample)
+ (&;size (&;sort <+ sample))))
+
+ (assert "Sorting a list with one order should yield the reverse of sorting it with the opposite order."
+ (= (&;sort <+ sample)
+ (&;reverse (&;sort >+ sample))))
+
+ (assert "If you zip 2 lists, the result's size will be that of the smaller list."
+ (=+ (&;size (&;zip2 sample other-sample))
+ (min+ (&;size sample) (&;size other-sample))))
+
+ (assert "I can pair-up elements of a list in order."
+ (let [(^open) &;Functor<List>
+ zipped (&;zip2 sample other-sample)
+ num-zipper (&;size zipped)]
+ (and (|> zipped (map product;left) (= (&;take num-zipper sample)))
+ (|> zipped (map product;right) (= (&;take num-zipper other-sample))))))
+
+ (assert "You can generate indices for any size, and they will be in ascending order."
+ (let [(^open) &;Functor<List>
+ indices (&;indices size)]
+ (and (=+ size (&;size indices))
+ (= indices
+ (&;sort <+ indices))
+ (&;every? (=+ (dec+ size))
+ (&;zip2-with ++
+ indices
+ (&;sort >+ indices)))
+ )))
+
+ (assert "The 'interpose' function places a value between every member of a list."
+ (let [(^open) &;Functor<List>
+ sample+ (&;interpose separator sample)]
+ (and (=+ (|> size (*+ +2) dec+)
+ (&;size sample+))
+ (|> sample+ &;as-pairs (map product;right) (&;every? (=+ separator))))))
+
+ (assert "List append is a monoid."
+ (let [(^open) &;Monoid<List>]
+ (and (= sample (append unit sample))
+ (= sample (append sample unit))
+ (let [[left right] (&;split size (append sample other-sample))]
+ (and (= sample left)
+ (= other-sample right))))))
+
+ (assert "Applicative allows you to create singleton lists, and apply lists of functions to lists of values."
+ (let [(^open) &;Applicative<List>]
+ (and (= (list separator) (wrap separator))
+ (= (map inc+ sample)
+ (apply (wrap inc+) sample)))))
+
+ (assert "List concatenation is a monad."
+ (let [(^open) &;Monad<List>
+ (^open) &;Monoid<List>]
+ (= (append sample other-sample)
+ (join (list sample other-sample)))))
+
+ (assert "You can find any value that satisfies some criterium, if such values exist in the list."
+ (case (&;find even?+ sample)
+ (#;Some found)
+ (and (even?+ found)
+ (&;any? even?+ sample)
+ (not (&;every? (bool;complement even?+) sample)))
+
+ #;None
+ (and (not (&;any? even?+ sample))
+ (&;every? (bool;complement even?+) sample))))
+
+ (assert "You can iteratively construct a list, generating values until you're done."
+ (= (&;range+ +0 (dec+ size))
+ (&;iterate (lambda [n] (if (<+ size n) (#;Some (inc+ n)) #;None))
+ +0)))
+
+ (assert "Can enumerate all elements in a list."
+ (let [enum-sample (&;enumerate sample)]
+ (and (= (&;indices (&;size enum-sample))
+ (&/map product;left enum-sample))
+ (= sample
+ (&/map product;right enum-sample)))))
+ ))
diff --git a/stdlib/test/test/lux/data/struct/queue.lux b/stdlib/test/test/lux/data/struct/queue.lux
new file mode 100644
index 000000000..895929ab4
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/queue.lux
@@ -0,0 +1,54 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data (struct ["&" queue])
+ [number])
+ (math ["R" random])
+ pipe)
+ lux/test)
+
+(test: "Queues"
+ [size (:: @ map (%+ +100) R;nat)
+ sample (R;queue size R;nat)
+ non-member (|> R;nat
+ (R;filter (. not (&;enqueued? number;Eq<Nat> sample))))]
+ (all (assert "I can query the size of a queue (and empty queues have size 0)."
+ (if (=+ +0 size)
+ (&;empty? sample)
+ (=+ size (&;size sample))))
+
+ (assert "Enqueueing and dequeing affects the size of queues."
+ (and (=+ (inc+ size) (&;size (&;enqueue non-member sample)))
+ (or (&;empty? sample)
+ (=+ (dec+ size) (&;size (&;dequeue sample))))
+ (=+ size (&;size (&;dequeue (&;enqueue non-member sample))))))
+
+ (assert "Transforming to/from list can't change the queue."
+ (let [(^open "&/") (&;Eq<Queue> number;Eq<Nat>)]
+ (|> sample
+ &;to-list &;from-list
+ (&/= sample))))
+
+ (assert "I can always peek at a non-empty queue."
+ (case (&;peek sample)
+ #;None (&;empty? sample)
+ (#;Some _) true))
+
+ (assert "I can query whether an element belongs to a queue."
+ (and (not (&;enqueued? number;Eq<Nat> sample non-member))
+ (&;enqueued? number;Eq<Nat> (&;enqueue non-member sample)
+ non-member)
+ (case (&;peek sample)
+ #;None
+ (&;empty? sample)
+
+ (#;Some first)
+ (and (&;enqueued? number;Eq<Nat> sample first)
+ (not (&;enqueued? number;Eq<Nat> (&;dequeue sample) first))))))
+ ))
diff --git a/stdlib/test/test/lux/data/struct/set.lux b/stdlib/test/test/lux/data/struct/set.lux
new file mode 100644
index 000000000..3725e7f93
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/set.lux
@@ -0,0 +1,67 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data (struct ["&" set]
+ [list "" Fold<List>])
+ [number])
+ (math ["R" random])
+ pipe)
+ lux/test)
+
+(def: gen-nat
+ (R;Random Nat)
+ (|> R;nat
+ (:: R;Monad<Random> map (%+ +100))))
+
+(test: "Sets"
+ [sizeL gen-nat
+ sizeR gen-nat
+ setL (R;set number;Hash<Nat> sizeL gen-nat)
+ setR (R;set number;Hash<Nat> sizeR gen-nat)
+ non-member (|> gen-nat
+ (R;filter (. not (&;member? setL))))
+ #let [(^open "&/") &;Eq<Set>]]
+ (all (assert "I can query the size of a set."
+ (and (=+ sizeL (&;size setL))
+ (=+ sizeR (&;size setR))))
+
+ (assert "Converting sets to/from lists can't change their values."
+ (|> setL
+ &;to-list (&;from-list number;Hash<Nat>)
+ (&/= setL)))
+
+ (assert "Every set is a sub-set of the union of itself with another."
+ (let [setLR (&;union setL setR)]
+ (and (&;sub? setLR setL)
+ (&;sub? setLR setR))))
+
+ (assert "Every set is a super-set of the intersection of itself with another."
+ (let [setLR (&;intersection setL setR)]
+ (and (&;super? setLR setL)
+ (&;super? setLR setR))))
+
+ (assert "Union with the empty set leaves a set unchanged."
+ (&/= setL
+ (&;union (&;new number;Hash<Nat>)
+ setL)))
+
+ (assert "Intersection with the empty set results in the empty set."
+ (let [empty-set (&;new number;Hash<Nat>)]
+ (&/= empty-set
+ (&;intersection empty-set setL))))
+
+ (assert "After substracting a set A from another B, no member of A can be a member of B."
+ (let [sub (&;difference setR setL)]
+ (not (list;any? (&;member? setL) (&;to-list setR)))))
+
+ (assert "Every member of a set must be identifiable."
+ (and (not (&;member? setL non-member))
+ (&;member? (&;add non-member setL) non-member)
+ (not (&;member? (&;remove non-member (&;add non-member setL)) non-member))))
+ ))
diff --git a/stdlib/test/test/lux/data/struct/stack.lux b/stdlib/test/test/lux/data/struct/stack.lux
new file mode 100644
index 000000000..dc3bb1e89
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/stack.lux
@@ -0,0 +1,47 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data (struct ["&" stack]
+ [list "" Fold<List>])
+ [number])
+ (math ["R" random])
+ pipe)
+ lux/test)
+
+(def: gen-nat
+ (R;Random Nat)
+ (|> R;nat
+ (:: R;Monad<Random> map (%+ +100))))
+
+(test: "Stacks"
+ [size gen-nat
+ sample (R;stack size gen-nat)
+ new-top gen-nat]
+ (all (assert "Can query the size of a stack."
+ (=+ size (&;size sample)))
+
+ (assert "Can peek inside non-empty stacks."
+ (case (&;peek sample)
+ #;None (&;empty? sample)
+ (#;Some _) (not (&;empty? sample))))
+
+ (assert "Popping empty stacks doesn't change anything.
+ But, if they're non-empty, the top of the stack is removed."
+ (let [sample' (&;pop sample)]
+ (or (=+ (&;size sample) (inc+ (&;size sample')))
+ (and (&;empty? sample) (&;empty? sample')))
+ ))
+
+ (assert "Pushing onto a stack always increases it by 1, adding a new value at the top."
+ (and (== sample
+ (&;pop (&;push new-top sample)))
+ (=+ (inc+ (&;size sample)) (&;size (&;push new-top sample)))
+ (|> (&;push new-top sample) &;peek (default (undefined))
+ (== new-top))))
+ ))
diff --git a/stdlib/test/test/lux/data/struct/tree.lux b/stdlib/test/test/lux/data/struct/tree.lux
new file mode 100644
index 000000000..0595ca7b3
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/tree.lux
@@ -0,0 +1,39 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data (struct ["&" tree]
+ [list "List/" Monad<List>])
+ [number])
+ (math ["R" random])
+ pipe)
+ lux/test)
+
+(def: gen-nat
+ (R;Random Nat)
+ (|> R;nat
+ (:: R;Monad<Random> map (%+ +100))))
+
+(test: "Trees"
+ [leaf (:: @ map &;leaf R;nat)
+ branchS gen-nat
+ branchV R;nat
+ branchC (R;list branchS R;nat)
+ #let [branch (&;branch branchV (List/map &;leaf branchC))]
+ #let [(^open "&/") (&;Eq<Tree> number;Eq<Nat>)
+ (^open "List/") (list;Eq<List> number;Eq<Nat>)]]
+ (all (assert "Can compare trees for equality."
+ (and (&/= leaf leaf)
+ (&/= branch branch)
+ (not (&/= leaf branch))
+ (not (&/= leaf (&;branch branchV (List/map &;leaf (list;reverse branchC)))))))
+
+ (assert "Can flatten a tree to get all the nodes as a flat tree."
+ (List/= (list& branchV branchC)
+ (&;flatten branch)))
+ ))
diff --git a/stdlib/test/test/lux/data/struct/vector.lux b/stdlib/test/test/lux/data/struct/vector.lux
new file mode 100644
index 000000000..87f8fa4cb
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/vector.lux
@@ -0,0 +1,84 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data (struct ["&" vector]
+ [list "List/" Fold<List> Functor<List>])
+ [text "Text/" Monoid<Text>]
+ text/format
+ [number])
+ (codata function)
+ (math ["R" random])
+ pipe)
+ lux/test)
+
+(test: "Vectors"
+ [size (|> R;nat (:: @ map (%+ +100)))
+ idx (|> R;nat (:: @ map (%+ size)))
+ sample (R;vector size R;nat)
+ other-sample (R;vector size R;nat)
+ non-member (|> R;nat (R;filter (. not (&;member? number;Eq<Nat> sample))))
+ #let [(^open "&/") (&;Eq<Vector> number;Eq<Nat>)
+ (^open "&/") &;Monad<Vector>
+ (^open "&/") &;Fold<Vector>
+ (^open "&/") &;Monoid<Vector>]]
+ (all (assert "Can query size of vector."
+ (if (&;empty? sample)
+ (and (=+ +0 size)
+ (=+ +0 (&;size sample)))
+ (=+ size (&;size sample))))
+
+ (assert "Can add and remove elements to vectors."
+ (and (=+ (inc+ size)
+ (&;size (&;add non-member sample)))
+ (=+ (dec+ size)
+ (&;size (&;pop sample)))))
+
+ (assert "Can put and get elements into vectors."
+ (|> sample
+ (&;put idx non-member)
+ (&;at idx)
+ (default (undefined))
+ (== non-member)))
+
+ (assert "Can update elements of vectors."
+ (|> sample
+ (&;put idx non-member)
+ (&;update idx inc+)
+ (&;at idx)
+ (default (undefined))
+ (=+ (inc+ non-member))))
+
+ (assert "Can safely transform to/from lists."
+ (|> sample
+ &;to-list &;from-list
+ (&/= sample)))
+
+ (assert "Can identify members of a vector."
+ (and (not (&;member? number;Eq<Nat> sample non-member))
+ (&;member? number;Eq<Nat> (&;add non-member sample) non-member)))
+
+ (assert "Can fold over elements of vector."
+ (=+ (List/fold ++ +0 (&;to-list sample))
+ (&/fold ++ +0 sample)))
+
+ (assert "Functor goes over every element."
+ (let [there (&/map inc+ sample)
+ back-again (&/map dec+ there)]
+ (and (not (&/= sample there))
+ (&/= sample back-again))))
+
+ (assert "Applicative allows you to create singleton vectors, and apply vectors of functions to vectors of values."
+ (and (&/= (&;vector non-member) (&/wrap non-member))
+ (&/= (&/map inc+ sample)
+ (&/apply (&/wrap inc+) sample))))
+
+ (assert "Vector concatenation is a monad."
+ (&/= (&/append sample other-sample)
+ (&/join (&;vector sample other-sample))))
+ ))
diff --git a/stdlib/test/test/lux/data/struct/zipper.lux b/stdlib/test/test/lux/data/struct/zipper.lux
new file mode 100644
index 000000000..a3bede88d
--- /dev/null
+++ b/stdlib/test/test/lux/data/struct/zipper.lux
@@ -0,0 +1,127 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data (struct ["&" zipper]
+ [tree]
+ [list "List/" Fold<List> Functor<List>])
+ [text "Text/" Monoid<Text>]
+ text/format
+ [number])
+ (codata function)
+ (math ["R" random])
+ pipe)
+ lux/test)
+
+(def: gen-tree
+ (R;Random (tree;Tree Nat))
+ (R;rec (lambda [gen-tree]
+ (do R;Monad<Random>
+ ## Each branch can have, at most, 1 child.
+ [size (|> R;nat (:: @ map (%+ +2)))]
+ (R;seq R;nat
+ (R;list size gen-tree))))))
+
+(def: (to-end zipper)
+ (All [a] (-> (&;Zipper a) (&;Zipper a)))
+ (loop [zipper zipper]
+ (if (&;end? zipper)
+ zipper
+ (recur (&;next zipper)))))
+
+(test: "Zippers"
+ [sample gen-tree
+ new-val R;nat
+ pre-val R;nat
+ post-val R;nat
+ #let [(^open "Tree/") (tree;Eq<Tree> number;Eq<Nat>)
+ (^open "List/") (list;Eq<List> number;Eq<Nat>)]]
+ (all (assert "Trees can be converted to/from zippers."
+ (|> sample
+ &;from-tree &;to-tree
+ (Tree/= sample)))
+
+ (assert "Creating a zipper gives you a root node."
+ (|> sample &;from-tree &;root?))
+
+ (assert "Can move down inside branches. Can move up from lower nodes."
+ (let [zipper (&;from-tree sample)]
+ (if (&;branch? zipper)
+ (let [child (|> zipper &;down)]
+ (and (not (Tree/= sample (&;to-tree child)))
+ (|> child &;parent (default (undefined)) (== zipper))
+ (|> child &;up (== zipper))
+ (|> child &;root (== zipper))))
+ (and (&;leaf? zipper)
+ (|> zipper (&;prepend-child new-val) &;branch?)))))
+
+ (assert "Can prepend and append children."
+ (let [zipper (&;from-tree sample)]
+ (if (&;branch? zipper)
+ (let [mid-val (|> zipper &;down &;value)
+ zipper (|> zipper
+ (&;prepend-child pre-val)
+ (&;append-child post-val))]
+ (and (|> zipper &;down &;value (== pre-val))
+ (|> zipper &;down &;right &;value (== mid-val))
+ (|> zipper &;down &;right &;right &;value (== post-val))
+ (|> zipper &;down &;rightmost &;leftmost &;value (== pre-val))
+ (|> zipper &;down &;right &;left &;value (== mid-val))
+ (|> zipper &;down &;rightmost &;value (== post-val))))
+ true)))
+
+ (assert "Can insert children around a node (unless it's root)."
+ (let [zipper (&;from-tree sample)]
+ (if (&;branch? zipper)
+ (let [mid-val (|> zipper &;down &;value)
+ zipper (|> zipper
+ &;down
+ (&;insert-left pre-val)
+ (default (undefined))
+ (&;insert-right post-val)
+ (default (undefined))
+ &;up)]
+ (and (|> zipper &;down &;value (== pre-val))
+ (|> zipper &;down &;right &;value (== mid-val))
+ (|> zipper &;down &;right &;right &;value (== post-val))
+ (|> zipper &;down &;rightmost &;leftmost &;value (== pre-val))
+ (|> zipper &;down &;right &;left &;value (== mid-val))
+ (|> zipper &;down &;rightmost &;value (== post-val))))
+ (and (|> zipper (&;insert-left pre-val) (case> (#;Some _) false
+ #;None true))
+ (|> zipper (&;insert-right post-val) (case> (#;Some _) false
+ #;None true))))))
+
+ (assert "Can set and update the value of a node."
+ (|> sample &;from-tree (&;set new-val) &;value (=+ new-val)))
+
+ (assert "Zipper traversal follows the outline of the tree depth-first."
+ (List/= (tree;flatten sample)
+ (loop [zipper (&;from-tree sample)]
+ (if (&;end? zipper)
+ (list)
+ (#;Cons (&;value zipper)
+ (recur (&;next zipper)))))))
+
+ (assert "Backwards zipper traversal yield reverse tree flatten."
+ (List/= (list;reverse (tree;flatten sample))
+ (loop [zipper (to-end (&;from-tree sample))]
+ (if (&;root? zipper)
+ (list)
+ (#;Cons (&;value zipper)
+ (recur (&;prev zipper)))))))
+
+ (assert "Can remove nodes (except root nodes)."
+ (let [zipper (&;from-tree sample)]
+ (if (&;branch? zipper)
+ (and (|> zipper &;down &;root? not)
+ (|> zipper &;down &;remove (case> #;None false
+ (#;Some node) (&;root? node))))
+ (|> zipper &;remove (case> #;None true
+ (#;Some _) false)))))
+ ))
diff --git a/stdlib/test/test/lux/data/sum.lux b/stdlib/test/test/lux/data/sum.lux
new file mode 100644
index 000000000..a23eeec00
--- /dev/null
+++ b/stdlib/test/test/lux/data/sum.lux
@@ -0,0 +1,32 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data sum
+ [text "Text/" Monoid<Text>]
+ [number])
+ (codata function))
+ lux/test)
+
+(test: "Sum operations"
+ (all (match (+0 1) (left 1))
+ (match (+1 2) (right 2))
+ (match (^ (list "0" "2"))
+ (lefts (: (List (| Text Text))
+ (list (+0 "0") (+1 "1") (+0 "2")))))
+ (match (^ (list "1"))
+ (rights (: (List (| Text Text))
+ (list (+0 "0") (+1 "1") (+0 "2")))))
+ (match (^ [(list "0" "2") (list "1")])
+ (partition (: (List (| Text Text))
+ (list (+0 "0") (+1 "1") (+0 "2")))))
+ (match 10
+ (either (lambda [_] 10) (lambda [_] 20) (: (| Text Text) (+0 ""))))
+ (match 20
+ (either (lambda [_] 10) (lambda [_] 20) (: (| Text Text) (+1 ""))))
+ ))
diff --git a/stdlib/test/test/lux/data/text.lux b/stdlib/test/test/lux/data/text.lux
new file mode 100644
index 000000000..640ae3f4c
--- /dev/null
+++ b/stdlib/test/test/lux/data/text.lux
@@ -0,0 +1,150 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data ["&" text]
+ [char]
+ text/format
+ [number]
+ (struct [list]))
+ (codata function)
+ (math ["R" random])
+ pipe)
+ lux/test)
+
+(test: "Size"
+ [size (:: @ map (%+ +100) R;nat)
+ sample (R;text size)]
+ (assert "" (or (and (=+ +0 size)
+ (&;empty? sample))
+ (=+ size (&;size sample)))))
+
+(def: bounded-size
+ (R;Random Nat)
+ (|> R;nat
+ (:: R;Monad<Random> map (|>. (%+ +100) (++ +1)))))
+
+(test: "Locations"
+ [size bounded-size
+ idx (:: @ map (%+ size) R;nat)
+ sample (R;text size)]
+ (assert "" (|> sample
+ (&;at idx)
+ (case> (^=> (#;Some char)
+ {(char;as-text char) char'}
+ {[(&;index-of char' sample)
+ (&;last-index-of char' sample)
+ (&;index-of' char' idx sample)
+ (&;last-index-of' char' idx sample)]
+ [(#;Some io) (#;Some lio)
+ (#;Some io') (#;Some lio')]})
+ (and (<=+ idx io)
+ (>=+ idx lio)
+
+ (=+ idx io')
+ (>=+ idx lio')
+
+ (&;contains? char' sample))
+
+ _
+ false
+ ))
+ ))
+
+(test: "Text functions"
+ [sizeL bounded-size
+ sizeR bounded-size
+ sampleL (R;text sizeL)
+ sampleR (R;text sizeR)
+ #let [sample (&;concat (list sampleL sampleR))
+ fake-sample (&;join-with " " (list sampleL sampleR))
+ dup-sample (&;join-with "" (list sampleL sampleR))
+ enclosed-sample (&;enclose [sampleR sampleR] sampleL)
+ (^open) &;Eq<Text>]]
+ (assert "" (and (not (= sample fake-sample))
+ (= sample dup-sample)
+ (&;starts-with? sampleL sample)
+ (&;ends-with? sampleR sample)
+ (= enclosed-sample
+ (&;enclose' sampleR sampleL))
+
+ (|> (&;split sizeL sample)
+ (case> (#;Right [_l _r])
+ (and (= sampleL _l)
+ (= sampleR _r)
+ (= sample (&;concat (list _l _r))))
+
+ _
+ false))
+
+ (|> [(&;sub +0 sizeL sample)
+ (&;sub sizeL (&;size sample) sample)
+ (&;sub' sizeL sample)
+ (&;sub' +0 sample)]
+ (case> [(#;Right _l) (#;Right _r) (#;Right _r') (#;Right _f)]
+ (and (= sampleL _l)
+ (= sampleR _r)
+ (= _r _r')
+ (= sample _f))
+
+ _
+ false))
+ )
+ ))
+
+(test: "More text functions"
+ [sizeS bounded-size
+ sizeP bounded-size
+ sizeL bounded-size
+ sep1 (R;text sizeS)
+ sep2 (R;text sizeS)
+ #let [part-gen (|> (R;text sizeP)
+ (R;filter (. not (&;contains? sep1))))]
+ parts (R;list sizeL part-gen)
+ #let [sample1 (&;concat (list;interpose sep1 parts))
+ sample2 (&;concat (list;interpose sep2 parts))
+ (^open) &;Eq<Text>]]
+ (assert "" (and (=+ (list;size parts)
+ (list;size (&;split-all-with sep1 sample1)))
+ (= sample2
+ (&;replace sep1 sep2 sample1))
+ )))
+
+(test: "Other text functions"
+ (all (match "abc" (&;lower-case "ABC"))
+ (match "ABC" (&;upper-case "abc"))
+ (match "ABC" (&;trim " \tABC\n\r"))
+ ))
+
+(test: "Structures"
+ (all (assert "" (:: &;Ord<Text> < "bcd" "abc"))
+ (assert "" (not (:: &;Ord<Text> < "abc" "abc")))
+ (assert "" (not (:: &;Ord<Text> < "abc" "bcd")))
+ (assert "" (:: &;Ord<Text> <= "bcd" "abc"))
+ (assert "" (:: &;Ord<Text> <= "abc" "abc"))
+ (assert "" (not (:: &;Ord<Text> <= "abc" "bcd")))
+ (assert "" (:: &;Ord<Text> > "abc" "bcd"))
+ (assert "" (not (:: &;Ord<Text> > "abc" "abc")))
+ (assert "" (not (:: &;Ord<Text> > "bcd" "abc")))
+ (assert "" (:: &;Ord<Text> >= "abc" "bcd"))
+ (assert "" (:: &;Ord<Text> >= "abc" "abc"))
+ (assert "" (not (:: &;Ord<Text> >= "bcd" "abc")))
+ ))
+
+(test: "Codec"
+ [size bounded-size
+ sample (R;text size)
+ #let [(^open) &;Eq<Text>]]
+ (assert "" (|> sample
+ (:: &;Codec<Text,Text> encode)
+ (:: &;Codec<Text,Text> decode)
+ (case> (#;Right decoded)
+ (= sample decoded)
+
+ _
+ false))))
diff --git a/stdlib/test/test/lux/data/text/format.lux b/stdlib/test/test/lux/data/text/format.lux
new file mode 100644
index 000000000..cd15c8584
--- /dev/null
+++ b/stdlib/test/test/lux/data/text/format.lux
@@ -0,0 +1,22 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data text/format
+ [number])
+ (codata function))
+ lux/test)
+
+(test: "Formatters"
+ (all (match "true" (%b true))
+ (match "123" (%i 123))
+ (match "123.456" (%r 123.456))
+ (match "#\"t\"" (%c #"t"))
+ (match "\"YOLO\"" (%t "YOLO"))
+ (match "User-id: 123 -- Active: true" (format "User-id: " (%i 123) " -- Active: " (%b true)))
+ ))
diff --git a/stdlib/test/test/lux/host.lux b/stdlib/test/test/lux/host.lux
new file mode 100644
index 000000000..109d8dfed
--- /dev/null
+++ b/stdlib/test/test/lux/host.lux
@@ -0,0 +1,54 @@
+(;module:
+ lux
+ (lux (control monad)
+ (data text/format
+ [number]
+ [product])
+ (codata function
+ [io])
+ host)
+ lux/test)
+
+(jvm-import java.lang.Object
+ (new []))
+
+(jvm-import java.lang.String)
+
+(jvm-import (java.lang.Class a)
+ (getName [] String))
+
+(test: "lux/host exports"
+ (let% [<conversions-0> (do-template [<value> <forward> <backward>]
+ [(match <value> (|> <value> <forward> <backward>))]
+
+ [123 l2d d2l]
+ [123 l2f f2l]
+ [123 l2i i2l]
+ [123.0 d2l l2d]
+ [123.0 d2f f2d]
+ [123.0 d2i i2d]
+ )
+ <conversions-1> (do-template [<forward> <backward>]
+ [(match 123 (|> 123 l2i <forward> <backward> i2l))]
+
+ [i2c c2i]
+ )]
+ (test-all (match "java.lang.Class" (Class.getName [] (class-for java.lang.Class)))
+ (match "java.lang.Class" (Class.getName [] (class-for Class)))
+ (match true (null? (: Object (null))))
+ (match false (null? (Object.new [])))
+ (match #;None (: (Maybe Object) (??? (null))))
+ (match (#;Some _) (: (Maybe Object) (??? (Object.new []))))
+ (match true (null? (!!! (: (Maybe Object) (??? (null))))))
+ (match false (null? (!!! (: (Maybe Object) (??? (Object.new []))))))
+ (match true (instance? Object (Object.new [])))
+ (match false (instance? String (Object.new [])))
+ (match 123 (synchronized (Object.new [])
+ 123))
+ (match +10 (array-length (array String +10)))
+ (match "YOLO" (let [array (array String +10)]
+ (exec (array-store +0 "YOLO" array)
+ (array-load +0 array))))
+ <conversions-0>
+ <conversions-1>
+ )))
diff --git a/stdlib/test/test/lux/lexer.lux b/stdlib/test/test/lux/lexer.lux
new file mode 100644
index 000000000..d0b17fe4b
--- /dev/null
+++ b/stdlib/test/test/lux/lexer.lux
@@ -0,0 +1,133 @@
+## 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/.
+
+(;module:
+ [lux #- not]
+ (lux (control monad)
+ (codata [io])
+ (data error)
+ [test #- fail assert]
+ lexer))
+
+## [Tests]
+(test: "Lexer end works"
+ (test-all (should-pass (run end ""))
+ (should-fail (run end "YOLO"))))
+
+(test: "Simple text lexers"
+ (test-all (match (#;Right "YO")
+ (run (this "YO") "YOLO"))
+ (should-fail (run (this "YO") "MEME"))))
+
+(test: "Char lexers"
+ (test-all (match (#;Right #"Y")
+ (run (this-char #"Y") "YOLO"))
+ (should-fail (run (this-char #"Y") "MEME"))
+ (match (#;Right #"Y")
+ (run (char-range #"X" #"Z") "YOLO"))
+ (should-fail (run (char-range #"X" #"Z") "MEME"))
+ (match (#;Right #"Y")
+ (run upper "YOLO"))
+ (should-fail (run upper "meme"))
+ (match (#;Right #"y")
+ (run lower "yolo"))
+ (should-fail (run lower "MEME"))
+ (match (#;Right #"1")
+ (run digit "1"))
+ (should-fail (run digit " "))
+ (match (#;Right #"7")
+ (run oct-digit "7"))
+ (should-fail (run oct-digit "8"))
+ (match (#;Right #"A")
+ (run any "A"))
+ (should-fail (run any ""))))
+
+(test: "Combinators"
+ (test-all (match (#;Right [#"Y" #"O"])
+ (run (seq any any) "YOLO"))
+ (should-fail (run (seq any any) "Y"))
+ (match+ (#;Left #"0")
+ (should-pass (run (alt digit upper) "0")))
+ (match+ (#;Right #"A")
+ (should-pass (run (alt digit upper) "A")))
+ (should-fail (run (alt digit upper) "a"))
+ (should-pass (run (not (alt digit upper)) "a"))
+ (should-fail (run (not (alt digit upper)) "A"))
+ (match (#;Right #"0")
+ (run (either digit upper) "0"))
+ (match (#;Right #"A")
+ (run (either digit upper) "A"))
+ (should-fail (run (either digit upper) "a"))
+ (match (#;Right #"A")
+ (run alpha "A"))
+ (match (#;Right #"a")
+ (run alpha "a"))
+ (should-fail (run alpha "1"))
+ (match (#;Right #"A")
+ (run alpha-num "A"))
+ (match (#;Right #"a")
+ (run alpha-num "a"))
+ (match (#;Right #"1")
+ (run alpha-num "1"))
+ (should-fail (run alpha-num " "))
+ (match (#;Right #"1")
+ (run hex-digit "1"))
+ (match (#;Right #"a")
+ (run hex-digit "a"))
+ (match (#;Right #"A")
+ (run hex-digit "A"))
+ (should-fail (run hex-digit " "))
+ (match (#;Right #" ")
+ (run space " "))
+ (should-fail (run space "8"))
+ (match (#;Right #"C")
+ (run (one-of "ABC") "C"))
+ (should-fail (run (one-of "ABC") "D"))
+ (match (#;Right #"D")
+ (run (none-of "ABC") "D"))
+ (should-fail (run (none-of "ABC") "C"))
+ (match (#;Right #"D")
+ (run (satisfies (lambda [c] true)) "D"))
+ (should-fail (run (satisfies (lambda [c] false)) "C"))
+ (match (#;Right "0123456789ABCDEF")
+ (run (many' hex-digit) "0123456789ABCDEF yolo"))
+ (should-fail (run (many' hex-digit) "yolo"))
+ (match (#;Right "")
+ (run (some' hex-digit) "yolo"))
+ ))
+
+(test: "Yet more combinators..."
+ (test-all (should-fail (run (fail "Well, it really SHOULD fail...") "yolo"))
+ (should-fail (run (assert false "Well, it really SHOULD fail...") "yolo"))
+ (should-pass (run (assert true "GO, GO, GO!") "yolo"))
+ (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F")))
+ (run (many hex-digit) "0123456789ABCDEF yolo"))
+ (should-fail (run (many hex-digit) "yolo"))
+ (match (^ (#;Right (list)))
+ (run (some hex-digit) "yolo"))
+ (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F")))
+ (run (exactly +16 hex-digit) "0123456789ABCDEF yolo"))
+ (match (^ (#;Right (list #"0" #"1" #"2")))
+ (run (exactly +3 hex-digit) "0123456789ABCDEF yolo"))
+ (should-fail (run (exactly +17 hex-digit) "0123456789ABCDEF yolo"))
+ (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F")))
+ (run (at-most +16 hex-digit) "0123456789ABCDEF yolo"))
+ (match (^ (#;Right (list #"0" #"1" #"2")))
+ (run (at-most +3 hex-digit) "0123456789ABCDEF yolo"))
+ (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F")))
+ (run (at-most +17 hex-digit) "0123456789ABCDEF yolo"))
+ (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F")))
+ (run (between +0 +16 hex-digit) "0123456789ABCDEF yolo"))
+ (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F")))
+ (run (between +3 +16 hex-digit) "0123456789ABCDEF yolo"))
+ (should-fail (run (between +17 +100 hex-digit) "0123456789ABCDEF yolo"))
+ (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"A" #"B" #"C" #"D" #"E" #"F")))
+ (run (between +15 +20 hex-digit) "0123456789ABCDEF yolo"))
+ (match (#;Right (#;Some #"1")) (run (opt hex-digit) "123abc"))
+ (match (#;Right #;None) (run (opt hex-digit) "yolo"))
+ (match (^ (#;Right (list #"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9" #"a" #"b" #"c" #"d" #"e" #"f")))
+ (run (sep-by space hex-digit) "0 1 2 3 4 5 6 7 8 9 a b c d e f YOLO"))
+ (match (#;Right "yolo") (run get-input "yolo"))
+ ))
diff --git a/stdlib/test/test/lux/macro/ast.lux b/stdlib/test/test/lux/macro/ast.lux
new file mode 100644
index 000000000..b06efce01
--- /dev/null
+++ b/stdlib/test/test/lux/macro/ast.lux
@@ -0,0 +1,31 @@
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data [text "Text/" Monoid<Text>]
+ [number])
+ (macro ast)
+ (codata function))
+ lux/test)
+
+(test: "lux/macro/ast exports"
+ (let% [<tests> (do-template [<expr> <text> <pattern>]
+ [(match <pattern> <expr>)
+ (match <text> (ast-to-text <expr>))
+ (match true (:: Eq<AST> = <expr> <expr>))]
+
+ [(bool true) "true" [["" -1 -1] (#;BoolS true)]]
+ [(bool false) "false" [_ (#;BoolS false)]]
+ [(int 123) "123" [_ (#;IntS 123)]]
+ [(real 123.0) "123.0" [_ (#;RealS 123.0)]]
+ [(char #"\n") "#\"\\n\"" [_ (#;CharS #"\n")]]
+ [(text "\n") "\"\\n\"" [_ (#;TextS "\n")]]
+ [(tag ["yolo" "lol"]) "#yolo;lol" [_ (#;TagS ["yolo" "lol"])]]
+ [(symbol ["yolo" "lol"]) "yolo;lol" [_ (#;SymbolS ["yolo" "lol"])]]
+ [(form (list (bool true) (int 123))) "(true 123)" (^ [_ (#;FormS (list [_ (#;BoolS true)] [_ (#;IntS 123)]))])]
+ [(tuple (list (bool true) (int 123))) "[true 123]" (^ [_ (#;TupleS (list [_ (#;BoolS true)] [_ (#;IntS 123)]))])]
+ [(record (list [(bool true) (int 123)])) "{true 123}" (^ [_ (#;RecordS (list [[_ (#;BoolS true)] [_ (#;IntS 123)]]))])]
+ [(local-tag "lol") "#lol" [_ (#;TagS ["" "lol"])]]
+ [(local-symbol "lol") "lol" [_ (#;SymbolS ["" "lol"])]]
+ )]
+ (test-all <tests>)))
diff --git a/stdlib/test/test/lux/macro/syntax.lux b/stdlib/test/test/lux/macro/syntax.lux
new file mode 100644
index 000000000..99f8550c0
--- /dev/null
+++ b/stdlib/test/test/lux/macro/syntax.lux
@@ -0,0 +1,176 @@
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data [text "Text/" Monoid<Text>]
+ [number])
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax])
+ (codata function))
+ lux/test)
+
+(test: "lux/macro/syntax exports [Part 1]"
+ (let% [<simple-tests> (do-template [<pattern> <expr> <get> <ask> <demand>]
+ [(match (#;Right [_ <pattern>])
+ (s;run (list <expr>)
+ <get>))
+ (match (#;Right [_ true])
+ (s;run (list <expr>)
+ (<ask> <pattern>)))
+ (match (#;Right [_ []])
+ (s;run (list <expr>)
+ (<demand> <pattern>)))]
+
+ [true (ast;bool true) s;bool s;bool? s;bool!]
+ [123 (ast;int 123) s;int s;int? s;int!]
+ [123.0 (ast;real 123.0) s;real s;real? s;real!]
+ [#"\n" (ast;char #"\n") s;char s;char? s;char!]
+ ["\n" (ast;text "\n") s;text s;text? s;text!]
+ [["yolo" "lol"] (ast;symbol ["yolo" "lol"]) s;symbol s;symbol? s;symbol!]
+ [["yolo" "lol"] (ast;tag ["yolo" "lol"]) s;tag s;tag? s;tag!]
+ )
+ <group-tests> (do-template [<parser> <ctor>]
+ [(match (#;Right [_ [true 123]])
+ (s;run (list (<ctor> (list (ast;bool true) (ast;int 123))))
+ (<parser> (s;seq s;bool s;int))))
+ (match (#;Right [_ true])
+ (s;run (list (<ctor> (list (ast;bool true))))
+ (<parser> s;bool)))
+ (match (#;Left _)
+ (s;run (list (<ctor> (list (ast;bool true) (ast;int 123))))
+ (<parser> s;bool)))
+ (match (#;Right [_ (#;Left true)])
+ (s;run (list (<ctor> (list (ast;bool true))))
+ (<parser> (s;alt s;bool s;int))))
+ (match (#;Right [_ (#;Right 123)])
+ (s;run (list (<ctor> (list (ast;int 123))))
+ (<parser> (s;alt s;bool s;int))))
+ (match (#;Left _)
+ (s;run (list (<ctor> (list (ast;real 123.0))))
+ (<parser> (s;alt s;bool s;int))))]
+
+ [s;form ast;form]
+ [s;tuple ast;tuple])]
+ (test-all (match (#;Right [_ [_ (#;BoolS true)]])
+ (s;run (list (ast;bool true) (ast;int 123))
+ s;any))
+ <simple-tests>
+ (match (#;Right [_ []])
+ (s;run (list (ast;bool true) (ast;int 123))
+ (s;assert true "yolo")))
+ (match (#;Left _)
+ (s;run (list (ast;bool true) (ast;int 123))
+ (s;assert false "yolo")))
+ (match (#;Right [_ +123])
+ (s;run (list (ast;nat +123))
+ s;nat))
+ (match (#;Left _)
+ (s;run (list (ast;int -123))
+ s;nat))
+ (match (#;Right [_ "yolo"])
+ (s;run (list (ast;local-symbol "yolo"))
+ s;local-symbol))
+ (match (#;Left _)
+ (s;run (list (ast;symbol ["yolo" "lol"]))
+ s;local-symbol))
+ (match (#;Right [_ "yolo"])
+ (s;run (list (ast;local-tag "yolo"))
+ s;local-tag))
+ (match (#;Left _)
+ (s;run (list (ast;tag ["yolo" "lol"]))
+ s;local-tag))
+ <group-tests>
+ )))
+
+(test: "lux/macro/syntax exports [Part 2]"
+ (test-all (match (#;Right [_ [true 123]])
+ (s;run (list (ast;record (list [(ast;bool true) (ast;int 123)])))
+ (s;record (s;seq s;bool s;int))))
+ (match (#;Right [_ (#;Some +123)])
+ (s;run (list (ast;nat +123))
+ (s;opt s;nat)))
+ (match (#;Right [_ #;None])
+ (s;run (list (ast;int -123))
+ (s;opt s;nat)))
+ (match (^ (#;Right [_ (list +123 +456 +789)]))
+ (s;run (list (ast;nat +123) (ast;nat +456) (ast;nat +789))
+ (s;some s;nat)))
+ (match (^ (#;Right [_ (list)]))
+ (s;run (list (ast;int -123))
+ (s;some s;nat)))
+ (match (^ (#;Right [_ (list +123 +456 +789)]))
+ (s;run (list (ast;nat +123) (ast;nat +456) (ast;nat +789))
+ (s;many s;nat)))
+ (match (^ (#;Right [_ (list +123)]))
+ (s;run (list (ast;nat +123))
+ (s;many s;nat)))
+ (match (#;Left _)
+ (s;run (list (ast;int -123))
+ (s;many s;nat)))
+ (match (#;Right [_ 123])
+ (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+ (s;either s;pos-int s;int)))
+ (match (#;Right [_ -123])
+ (s;run (list (ast;int -123) (ast;int 456) (ast;int 789))
+ (s;either s;pos-int s;int)))
+ (match (#;Left _)
+ (s;run (list (ast;bool true) (ast;int 456) (ast;int 789))
+ (s;either s;pos-int s;int)))
+ (match (#;Right [_ true])
+ (s;run (list)
+ s;end?))
+ (match (#;Right [_ false])
+ (s;run (list (ast;bool true))
+ s;end?))
+ (match (#;Right [_ []])
+ (s;run (list)
+ s;end))
+ (match (#;Left _)
+ (s;run (list (ast;bool true))
+ s;end))
+ (match (^ (#;Right [_ (list 123 456 789)]))
+ (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+ (s;exactly +3 s;int)))
+ (match (^ (#;Right [_ (list 123 456)]))
+ (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+ (s;exactly +2 s;int)))
+ (match (#;Left _)
+ (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+ (s;exactly +4 s;int)))
+ (match (^ (#;Right [_ (list 123 456 789)]))
+ (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+ (s;at-least +3 s;int)))
+ (match (^ (#;Right [_ (list 123 456 789)]))
+ (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+ (s;at-least +2 s;int)))
+ (match (#;Left _)
+ (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+ (s;at-least +4 s;int)))
+ (match (^ (#;Right [_ (list 123 456 789)]))
+ (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+ (s;at-most +3 s;int)))
+ (match (^ (#;Right [_ (list 123 456)]))
+ (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+ (s;at-most +2 s;int)))
+ (match (^ (#;Right [_ (list 123 456 789)]))
+ (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+ (s;at-most +4 s;int)))
+ (match (^ (#;Right [_ (list 123 456 789)]))
+ (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+ (s;between +3 +10 s;int)))
+ (match (#;Left _)
+ (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+ (s;between +4 +10 s;int)))
+ (match (^ (#;Right [_ (list 123 456 789)]))
+ (s;run (list (ast;int 123) (ast;text "YOLO") (ast;int 456) (ast;text "YOLO") (ast;int 789))
+ (s;sep-by (s;text! "YOLO") s;int)))
+ (match (^ (#;Right [_ (list 123 456)]))
+ (s;run (list (ast;int 123) (ast;text "YOLO") (ast;int 456) (ast;int 789))
+ (s;sep-by (s;text! "YOLO") s;int)))
+ (match (#;Left _)
+ (s;run (list (ast;int 123) (ast;int 456) (ast;int 789))
+ (s;not s;int)))
+ (match (#;Right [_ []])
+ (s;run (list (ast;bool true) (ast;int 456) (ast;int 789))
+ (s;not s;int)))
+ ))
diff --git a/stdlib/test/test/lux/math.lux b/stdlib/test/test/lux/math.lux
new file mode 100644
index 000000000..3d5e053f7
--- /dev/null
+++ b/stdlib/test/test/lux/math.lux
@@ -0,0 +1,45 @@
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data [text "Text/" Monoid<Text>]
+ text/format
+ [number]
+ (struct [list "List/" Fold<List> Functor<List>])
+ [product])
+ (codata function)
+ math)
+ lux/test)
+
+(test: "lux/math exports"
+ (test-all (match 1.0 (cos 0.0))
+ (match -1.0 (cos (/. 2.0 tau)))
+ ## (match 0.0 (cos (/. 4.0 tau)))
+ ## (match 0.0 (cos (*. (/. 4.0 3.0) tau)))
+
+ (match 1.0 (sin (/. 4.0 tau)))
+ (match -1.0 (sin (*. (/. 4.0 3.0) tau)))
+ ## (match 0.0 (sin 0.0))
+ ## (match 0.0 (sin (/. 2.0 tau)))
+
+ (match 4 (ceil 3.75))
+ (match 3 (floor 3.75))
+ (match 4 (round 3.75))
+ (match 3 (round 3.25))
+
+ (match 3.0 (cbrt 27.0))
+ (match 4.0 (sqrt 16.0))
+
+ (match 90.0 (degrees (/. 4.0 tau)))
+ (match true (=. tau (radians (degrees tau))))
+
+ (match 9 (gcd 450 27))
+ (match 40 (lcm 10 8))
+
+ (match 27 (infix 27))
+ (match 9 (infix [27 gcd 450]))
+ (match 9 (infix [(* 3 9) gcd 450]))
+ (match true (infix [#and 27 < 450 < 2000]))
+ (match true (infix [#and 27 < 450 > 200]))
+ (match true (infix [[27 < 450] and [200 < 2000]]))
+ ))
diff --git a/stdlib/test/test/lux/pipe.lux b/stdlib/test/test/lux/pipe.lux
new file mode 100644
index 000000000..a601bbf98
--- /dev/null
+++ b/stdlib/test/test/lux/pipe.lux
@@ -0,0 +1,47 @@
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data text/format
+ [number]
+ [product]
+ identity)
+ (codata function)
+ pipe)
+ lux/test)
+
+(test: "lux/pipe exports"
+ (test-all (match 1 (|> 20
+ (* 3)
+ (+ 4)
+ (_> 0 inc)))
+ (match 10 (|> 5
+ (@> [(+ @ @)])))
+ (match 15 (|> 5
+ (?> [even?] [(* 2)]
+ [odd?] [(* 3)]
+ [(_> -1)])))
+ (match 15 (|> 5
+ (?> [even?] [(* 2)]
+ [odd?] [(* 3)])))
+ (match 10 (|> 1
+ (!> [(< 10)]
+ [inc])))
+ (match 20 (|> 5
+ (%> Monad<Identity>
+ [(* 3)]
+ [(+ 4)]
+ [inc])))
+ (match "five" (|> 5
+ (case> 0 "zero"
+ 1 "one"
+ 2 "two"
+ 3 "three"
+ 4 "four"
+ 5 "five"
+ 6 "six"
+ 7 "seven"
+ 8 "eight"
+ 9 "nine"
+ _ "???")))
+ ))
diff --git a/stdlib/test/test/lux/regex.lux b/stdlib/test/test/lux/regex.lux
new file mode 100644
index 000000000..66355bdca
--- /dev/null
+++ b/stdlib/test/test/lux/regex.lux
@@ -0,0 +1,200 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data error
+ [product])
+ [compiler]
+ (macro [ast]
+ ["s" syntax #+ syntax:])
+ test
+ [lexer]
+ regex))
+
+(syntax: (should-regex {veredict (s;alt s;bool s;any)} {regex s;text} {input s;text})
+ (case veredict
+ (+0 ?)
+ (if ?
+ (wrap (list (` (match+ (~ (ast;text input))
+ (should-pass (lexer;run (regex (~ (ast;text regex)))
+ (~ (ast;text input))))))))
+ (wrap (list (` (should-fail (lexer;run (regex (~ (ast;text regex)))
+ (~ (ast;text input))))))))
+
+ (+1 result)
+ (wrap (list (` (match+ (~ result)
+ (should-pass (lexer;run (regex (~ (ast;text regex)))
+ (~ (ast;text input))))))))))
+
+## [Tests]
+(test: "Regular Expressions [Basics]"
+ (test-all (should-regex true "a" "a")
+ (should-regex false "a" ".")
+ (should-regex true "\\." ".")
+ (should-regex false "\\." "a")
+ ))
+
+(test: "Regular Expressions [System character classes]"
+ (test-all (should-regex true "." "a")
+
+ (should-regex true "\\d" "0")
+ (should-regex false "\\d" "m")
+ (should-regex true "\\D" "m")
+ (should-regex false "\\D" "0")
+
+ (should-regex true "\\s" " ")
+ (should-regex false "\\s" "m")
+ (should-regex true "\\S" "m")
+ (should-regex false "\\S" " ")
+
+ (should-regex true "\\w" "_")
+ (should-regex false "\\w" "^")
+ (should-regex true "\\W" ".")
+ (should-regex false "\\W" "a")
+
+ (should-regex true "\\p{Lower}" "m")
+ (should-regex false "\\p{Lower}" "M")
+
+ (should-regex true "\\p{Upper}" "M")
+ (should-regex false "\\p{Upper}" "m")
+
+ (should-regex true "\\p{Alpha}" "M")
+ (should-regex false "\\p{Alpha}" "0")
+
+ (should-regex true "\\p{Digit}" "1")
+ (should-regex false "\\p{Digit}" "n")
+
+ (should-regex true "\\p{Alnum}" "1")
+ (should-regex false "\\p{Alnum}" ".")
+
+ (should-regex true "\\p{Space}" " ")
+ (should-regex false "\\p{Space}" ".")
+
+ (should-regex true "\\p{HexDigit}" "a")
+ (should-regex false "\\p{HexDigit}" ".")
+
+ (should-regex true "\\p{OctDigit}" "6")
+ (should-regex false "\\p{OctDigit}" ".")
+
+ (should-regex true "\\p{Blank}" "\t")
+ (should-regex false "\\p{Blank}" ".")
+
+ (should-regex true "\\p{ASCII}" "\t")
+ (should-regex false "\\p{ASCII}" "\u1234")
+
+ (should-regex true "\\p{Contrl}" "\u0012")
+ (should-regex false "\\p{Contrl}" "a")
+
+ (should-regex true "\\p{Punct}" "@")
+ (should-regex false "\\p{Punct}" "a")
+
+ (should-regex true "\\p{Graph}" "@")
+ (should-regex false "\\p{Graph}" " ")
+
+ (should-regex true "\\p{Print}" "\u0020")
+ (should-regex false "\\p{Print}" "\u1234")
+ ))
+
+(test: "Regular Expressions [Custom character classes]"
+ (test-all (should-regex true "[abc]" "a")
+ (should-regex false "[abc]" "m")
+
+ (should-regex true "[a-z]" "a")
+ (should-regex true "[a-z]" "m")
+ (should-regex true "[a-z]" "z")
+
+ (should-regex true "[a-zA-Z]" "a")
+ (should-regex true "[a-zA-Z]" "m")
+ (should-regex true "[a-zA-Z]" "z")
+ (should-regex true "[a-zA-Z]" "A")
+ (should-regex true "[a-zA-Z]" "M")
+ (should-regex true "[a-zA-Z]" "Z")
+
+ (should-regex false "[^abc]" "a")
+ (should-regex true "[^abc]" "m")
+
+ (should-regex false "[^a-z]" "a")
+ (should-regex true "[^a-z]" "0")
+ (should-regex false "[^a-zA-Z]" "a")
+ (should-regex true "[^a-zA-Z]" "0")
+
+ (should-regex false "[a-z&&[def]]" "a")
+ (should-regex true "[a-z&&[def]]" "d")
+
+ (should-regex true "[a-z&&[^bc]]" "a")
+ (should-regex false "[a-z&&[^bc]]" "b")
+
+ (should-regex true "[a-z&&[^m-p]]" "a")
+ (should-regex false "[a-z&&[^m-p]]" "m")
+ (should-regex false "[a-z&&[^m-p]]" "p")
+ ))
+
+(test: "Regular Expressions [Reference]"
+ (test-all (let [number (regex "\\d+")]
+ (should-regex ["809-345-6789" "809" "345" "6789"] "(\\@<number>)-(\\@<number>)-(\\@<number>)" "809-345-6789"))
+ ))
+
+(test: "Regular Expressions [Quantifiers]"
+ (test-all (should-regex "aa" "aa" "aa")
+
+ (should-regex "a" "a?" "a")
+ (should-regex "" "a?" "")
+
+ (should-regex "aaa" "a*" "aaa")
+ (should-regex "" "a*" "")
+
+ (should-regex "aaa" "a+" "aaa")
+ (should-regex "a" "a+" "a")
+ (should-regex false "a+" "")
+
+ (should-regex "aa" "a{2}" "aa")
+ (should-regex "a" "a{1}" "aa")
+ (should-regex false "a{3}" "aa")
+
+ (should-regex "aa" "a{1,}" "aa")
+ (should-regex "aa" "a{2,}" "aa")
+ (should-regex false "a{3,}" "aa")
+
+ (should-regex "a" "a{,1}" "aa")
+ (should-regex "aa" "a{,2}" "aa")
+ (should-regex "aa" "a{,3}" "aa")
+
+ (should-regex "a" "a{1,2}" "a")
+ (should-regex "aa" "a{1,2}" "aa")
+ (should-regex "aa" "a{1,2}" "aaa")
+ ))
+
+(test: "Regular Expressions [Groups]"
+ (test-all (should-regex ["abc" "b"] "a(.)c" "abc")
+ (should-regex ["abbbbbc" "bbbbb"] "a(b+)c" "abbbbbc")
+ (should-regex ["809-345-6789" "809" "345" "6789"] "(\\d{3})-(\\d{3})-(\\d{4})" "809-345-6789")
+ (should-regex ["809-345-6789" "809" "6789"] "(\\d{3})-(?:\\d{3})-(\\d{4})" "809-345-6789")
+ (should-regex ["809-809-6789" "809" "6789"] "(\\d{3})-\\0-(\\d{4})" "809-809-6789")
+ (should-regex ["809-809-6789" "809" "6789"] "(?<code>\\d{3})-\\k<code>-(\\d{4})" "809-809-6789")
+ (should-regex ["809-809-6789-6789" "809" "6789"] "(?<code>\\d{3})-\\k<code>-(\\d{4})-\\0" "809-809-6789-6789")
+
+ (should-regex ["809-345-6789" "809" ["345-6789" "345" "6789"]] "(\\d{3})-((\\d{3})-(\\d{4}))" "809-345-6789")
+ ))
+
+(test: "Regular Expressions [Alternation]"
+ (test-all (should-regex ["a" (+0 [])] "a|b" "a")
+ (should-regex ["b" (+1 [])] "a|b" "b")
+ (should-regex false "a|b" "c")
+
+ (should-regex ["abc" (+0 "b")] "a(.)c|b(.)d" "abc")
+ (should-regex ["bcd" (+1 "c")] "a(.)c|b(.)d" "bcd")
+ (should-regex false "a(.)c|b(.)d" "cde")
+
+ (should-regex ["abc" (+0 ["b" "c"])] "a(.)(.)|b(.)(.)" "abc")
+ (should-regex ["bcd" (+1 ["c" "d"])] "a(.)(.)|b(.)(.)" "bcd")
+ (should-regex false "a(.)(.)|b(.)(.)" "cde")
+
+ (should-regex ["809-345-6789" (+0 ["809" "345-6789" "345" "6789"])]
+ "(\\d{3})-((\\d{3})-(\\d{4}))|b(.)d"
+ "809-345-6789")
+ ))
diff --git a/stdlib/test/test/lux/type.lux b/stdlib/test/test/lux/type.lux
new file mode 100644
index 000000000..8fa871e70
--- /dev/null
+++ b/stdlib/test/test/lux/type.lux
@@ -0,0 +1,41 @@
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad)
+ (data [text "Text/" Monoid<Text>]
+ [number])
+ type
+ (codata function))
+ lux/test)
+
+(test: "lux/type exports"
+ (let% [<eq-tests> (do-template [<type>]
+ [(match true (:: Eq<Type> = <type> <type>))]
+
+ [(#;HostT "java.util.List" (list Int))]
+ [#;UnitT]
+ [#;VoidT]
+ [(#;VarT +123)]
+ [(#;ExT +123)]
+ [(#;BoundT +123)]
+ [(#;LambdaT Bool Int)]
+ [(#;AppT List Int)]
+ [(#;NamedT ["" "Int-List"] (#;AppT List Int))]
+ [(#;SumT Bool Int)]
+ [(#;ProdT Bool Int)]
+ [(#;UnivQ (list) (#;ProdT Bool (#;BoundT +1)))]
+ [(#;ExQ (list) (#;ProdT Bool (#;BoundT +1)))]
+ )]
+ (test-all <eq-tests>
+ (match (^=> (#;Some _type) (:: Eq<Type> = _type (#;ProdT Bool Int)))
+ (apply-type (type (Meta Bool)) Int))
+ (match #;None (apply-type Text Bool))
+ (match true
+ (:: Eq<Type> =
+ (#;NamedT ["" "a"]
+ (#;ProdT Bool Int))
+ (un-alias (#;NamedT ["" "c"]
+ (#;NamedT ["" "b"]
+ (#;NamedT ["" "a"]
+ (#;ProdT Bool Int)))))))
+ )))
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
new file mode 100644
index 000000000..7b760c0f1
--- /dev/null
+++ b/stdlib/test/tests.lux
@@ -0,0 +1,84 @@
+## 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/.
+
+(;module:
+ lux
+ (lux (control monad)
+ (codata [io])
+ (concurrency [promise])
+ [cli #+ program:]
+ [test])
+ (test lux
+ (lux (data [bit]
+ [bool]
+ [char]
+ [error]
+ [ident]
+ [identity]
+ [log]
+ [maybe]
+ [number]
+ [product]
+ [sum]
+ [text]
+ [text/format]
+ (struct [array]
+ [dict]
+ [list]
+ [queue]
+ [set]
+ [stack]
+ [tree]
+ [vector]
+ [zipper]
+ )
+ )
+ ## (codata ["_;" io]
+ ## [env]
+ ## [state]
+ ## (struct [stream]))
+ ## (macro [ast]
+ ## [syntax])
+ ## [type]
+ ## (concurrency ["_;" promise]
+ ## [frp]
+ ## [stm]
+ ## [actor]
+ ## )
+ ## [host]
+ ## ["_;" cli]
+ ## [math]
+ ## [pipe]
+ ## [lexer]
+ ## [regex]
+ ## (data (format [json]))
+ )
+ )
+ ## (lux ## (codata [cont])
+ ## ## (data (struct [stack]
+ ## ## [tree]
+ ## ## [zipper])
+ ## ## (error exception))
+ ## ## (concurrency [atom])
+ ## ## [macro]
+ ## ## (macro [template]
+ ## ## [poly]
+ ## ## (poly ["poly_;" eq]
+ ## ## ["poly_;" text-encoder]
+ ## ## ["poly_;" functor]))
+ ## ## (math [ratio]
+ ## ## [complex]
+ ## ## [random])
+ ## ## (type [check] [auto])
+ ## ## (control [effect])
+ ## ["_;" lexer]
+ ## ["_;" regex]
+ ## (data (format ["_;" json]))
+ ## )
+ )
+
+## [Program]
+(program: args
+ (test;run))