diff options
| author | LuxLang | 2015-10-01 12:50:27 -0400 |
|---|---|---|
| committer | LuxLang | 2015-10-01 12:50:27 -0400 |
| commit | 3e2ce4d30fd457205b0d0268d870d47a8d1ec738 (patch) | |
| tree | 580b42a5024c8767b2f2dd78a77a9911593acb77 | |
| parent | e543739f21e03be7cc0192bf510f350f7065bfa5 (diff) | |
| parent | 6fcf9690f914e9b8b4f0ab767164bc97aeb12ca4 (diff) | |
Merge pull request #12 from LuxLang/v0.3
V0.3
Diffstat (limited to '')
89 files changed, 10916 insertions, 6770 deletions
@@ -38,7 +38,7 @@ Then, you can run the program like this: ### What's the license? -Eclipse Public License v1.0 +Mozilla Public License v2.0 ## What's interesting about the language? diff --git a/code_of_conduct.md b/code_of_conduct.md new file mode 100644 index 000000000..01b8644f1 --- /dev/null +++ b/code_of_conduct.md @@ -0,0 +1,22 @@ +# Contributor Code of Conduct + +As contributors and maintainers of this project, and in the interest of fostering an open and welcoming community, we pledge to respect all people who contribute through reporting issues, posting feature requests, updating documentation, submitting pull requests or patches, and other activities. + +We are committed to making participation in this project a harassment-free experience for everyone, regardless of level of experience, gender, gender identity and expression, sexual orientation, disability, personal appearance, body size, race, ethnicity, age, religion, or nationality. + +Examples of unacceptable behavior by participants include: + +* The use of sexualized language or imagery +* Personal attacks +* Trolling or insulting/derogatory comments +* Public or private harassment +* Publishing other's private information, such as physical or electronic addresses, without explicit permission +* Other unethical or unprofessional conduct. + +Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct. By adopting this Code of Conduct, project maintainers commit themselves to fairly and consistently applying these principles to every aspect of managing this project. Project maintainers who do not follow or enforce the Code of Conduct may be permanently removed from the project team. + +This code of conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. + +Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by opening an issue or contacting one or more of the project maintainers. + +This Code of Conduct is adapted from the [Contributor Covenant](http://contributor-covenant.org), version 1.2.0, available at [http://contributor-covenant.org/version/1/2/0/](http://contributor-covenant.org/version/1/2/0/) diff --git a/license.txt b/license.txt new file mode 100644 index 000000000..52d135112 --- /dev/null +++ b/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/project.clj b/project.clj index a0fd8d1cb..64b4141c2 100644 --- a/project.clj +++ b/project.clj @@ -1,10 +1,11 @@ -(defproject lux-jvm "0.2.0" +(defproject lux-jvm "0.3.0" :description "The JVM compiler for the Lux programming language." :url "https://github.com/LuxLang/lux" - :license {:name "Eclipse Public License" - :url "http://www.eclipse.org/legal/epl-v10.html"} + :license {:name "Mozilla Public License (Version 2.0)" + :url "https://www.mozilla.org/en-US/MPL/2.0/"} :dependencies [[org.clojure/clojure "1.6.0"] [org.clojure/core.match "0.2.1"] - [org.ow2.asm/asm-all "5.0.3"]] + [org.ow2.asm/asm-all "5.0.3"] + [org.apache.commons/commons-compress "1.10"]] :warn-on-reflection true :main lux) diff --git a/source/lux.lux b/source/lux.lux index 8861bc241..4d1c3fdef 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1,105 +1,139 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. ## First things first, must define functions -(_jvm_interface "Function" [] - ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) +(_jvm_interface "Function" [] [] + ("apply" ["public" "abstract"] [] [] ["java.lang.Object"] "java.lang.Object")) ## Basic types -(_lux_def Bool (#DataT "java.lang.Boolean")) +(_lux_def Bool (10 ["lux" "Bool"] + (0 "java.lang.Boolean" (0)))) (_lux_export Bool) -(_lux_def Int (#DataT "java.lang.Long")) +(_lux_def Int (10 ["lux" "Int"] + (0 "java.lang.Long" (0)))) (_lux_export Int) -(_lux_def Real (#DataT "java.lang.Double")) +(_lux_def Real (10 ["lux" "Real"] + (0 "java.lang.Double" (0)))) (_lux_export Real) -(_lux_def Char (#DataT "java.lang.Character")) +(_lux_def Char (10 ["lux" "Char"] + (0 "java.lang.Character" (0)))) (_lux_export Char) -(_lux_def Text (#DataT "java.lang.String")) +(_lux_def Text (10 ["lux" "Text"] + (0 "java.lang.String" (0)))) (_lux_export Text) -(_lux_def Unit (#TupleT #Nil)) +(_lux_def Unit (10 ["lux" "Unit"] + (2 (0)))) (_lux_export Unit) -(_lux_def Void (#VariantT #Nil)) +(_lux_def Void (10 ["lux" "Void"] + (1 (0)))) (_lux_export Void) -(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) +(_lux_def Ident (10 ["lux" "Ident"] + (2 (1 Text (1 Text (0)))))) (_lux_export Ident) ## (deftype (List a) ## (| #Nil -## (#Cons (, a (List a))))) +## (#Cons a (List a)))) (_lux_def List - (#AllT [(#Some #Nil) "lux;List" "a" - (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] - (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") - (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) - #Nil])]))] - #Nil])]))])) + (10 ["lux" "List"] + (7 (0) + (1 (1 ## "lux;Nil" + (2 (0)) + (1 ## "lux;Cons" + (2 (1 (4 1) + (1 (9 (4 0) (4 1)) + (0)))) + (0))))))) (_lux_export List) +(_lux_declare-tags [#Nil #Cons] List) ## (deftype (Maybe a) ## (| #None -## (#Some a))) +## (1 a))) (_lux_def Maybe - (#AllT [(#Some #Nil) "lux;Maybe" "a" - (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] - (#Cons [["lux;Some" (#BoundT "a")] - #Nil])]))])) + (10 ["lux" "Maybe"] + (7 (0) + (1 (1 ## "lux;None" + (2 (0)) + (1 ## "lux;Some" + (4 1) + (0))))))) (_lux_export Maybe) +(_lux_declare-tags [#None #Some] Maybe) ## (deftype #rec Type -## (| (#DataT Text) +## (| (#DataT (, Text (List Type))) +## (#VariantT (List Type)) ## (#TupleT (List Type)) -## (#VariantT (List (, Text Type))) -## (#RecordT (List (, Text Type))) -## (#LambdaT (, Type Type)) -## (#BoundT Text) +## (#LambdaT Type Type) +## (#BoundT Int) ## (#VarT Int) -## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) -## (#AppT (, Type Type)))) +## (#ExT Int) +## (#UnivQ (List Type) Type) +## (#ExQ (List Type) Type) +## (#AppT Type Type) +## (#NamedT Ident Type) +## )) (_lux_def Type - (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) - Type - (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) - TypeEnv - (#AppT [(#AllT [(#Some #Nil) "Type" "_" - (#VariantT (#Cons [["lux;DataT" Text] - (#Cons [["lux;TupleT" (#AppT [List Type])] - (#Cons [["lux;VariantT" TypeEnv] - (#Cons [["lux;RecordT" TypeEnv] - (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;BoundT" Text] - (#Cons [["lux;VarT" Int] - (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] - (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;ExT" Int] - #Nil])])])])])])])])])]))]) - Void])))) + (10 ["lux" "Type"] + (_lux_case (9 (4 0) (4 1)) + Type + (_lux_case (9 List Type) + TypeList + (9 (7 (0) + (1 (1 ## "lux;DataT" + (2 (1 Text (1 TypeList (0)))) + (1 ## "lux;VariantT" + TypeList + (1 ## "lux;TupleT" + TypeList + (1 ## "lux;LambdaT" + (2 (1 Type (1 Type (0)))) + (1 ## "lux;BoundT" + Int + (1 ## "lux;VarT" + Int + (1 ## "lux;ExT" + Int + (1 ## "lux;UnivQ" + (2 (1 TypeList (1 Type (0)))) + (1 ## "lux;ExQ" + (2 (1 TypeList (1 Type (0)))) + (1 ## "lux;AppT" + (2 (1 Type (1 Type (0)))) + (1 ## "lux;NamedT" + (2 (1 Ident (1 Type (0)))) + (0)))))))))))))) + Void))))) (_lux_export Type) +(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #UnivQ #ExQ #AppT #NamedT] Type) ## (deftype (Bindings k v) ## (& #counter Int ## #mappings (List (, k v)))) (_lux_def Bindings - (#AllT [(#Some #Nil) "lux;Bindings" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;counter" Int] - (#Cons [["lux;mappings" (#AppT [List - (#TupleT (#Cons [(#BoundT "k") - (#Cons [(#BoundT "v") - #Nil])]))])] - #Nil])]))])])) + (#NamedT ["lux" "Bindings"] + (#UnivQ #Nil + (#UnivQ #Nil + (#TupleT (#Cons ## "lux;counter" + Int + (#Cons ## "lux;mappings" + (#AppT List + (#TupleT (#Cons (#BoundT 3) + (#Cons (#BoundT 1) + #Nil)))) + #Nil))))))) (_lux_export Bindings) +(_lux_declare-tags [#counter #mappings] Bindings) ## (deftype (Env k v) ## (& #name Text @@ -107,191 +141,264 @@ ## #locals (Bindings k v) ## #closure (Bindings k v))) (_lux_def Env - (#AllT [(#Some #Nil) "lux;Env" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;name" Text] - (#Cons [["lux;inner-closures" Int] - (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - #Nil])])])]))])])) + (#NamedT ["lux" "Env"] + (#UnivQ #Nil + (#UnivQ #Nil + (#TupleT (#Cons ## "lux;name" + Text + (#Cons ## "lux;inner-closures" + Int + (#Cons ## "lux;locals" + (#AppT (#AppT Bindings (#BoundT 3)) + (#BoundT 1)) + (#Cons ## "lux;closure" + (#AppT (#AppT Bindings (#BoundT 3)) + (#BoundT 1)) + #Nil))))))))) (_lux_export Env) +(_lux_declare-tags [#name #inner-closures #locals #closure] Env) ## (deftype Cursor -## (, Text Int Int)) +## (& #module Text +## #line Int +## #column Int)) (_lux_def Cursor - (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) + (#NamedT ["lux" "Cursor"] + (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil)))))) (_lux_export Cursor) +(_lux_declare-tags [#module #line #column] Cursor) ## (deftype (Meta m v) -## (| (#Meta (, m v)))) +## (& #meta m +## #datum v)) (_lux_def Meta - (#AllT [(#Some #Nil) "lux;Meta" "m" - (#AllT [#None "" "v" - (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") - (#Cons [(#BoundT "v") - #Nil])]))] - #Nil]))])])) + (#NamedT ["lux" "Meta"] + (#UnivQ #Nil + (#UnivQ #Nil + (#TupleT (#Cons (#BoundT 3) + (#Cons (#BoundT 1) + #Nil))))))) (_lux_export Meta) +(_lux_declare-tags [#meta #datum] Meta) -## (deftype (Syntax' w) +## (deftype (AST' w) ## (| (#BoolS Bool) ## (#IntS Int) ## (#RealS Real) ## (#CharS Char) ## (#TextS Text) -## (#SymbolS (, Text Text)) -## (#TagS (, Text Text)) -## (#FormS (List (w (Syntax' w)))) -## (#TupleS (List (w (Syntax' w)))) -## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) -(_lux_def Syntax' - (_lux_case (#AppT [(#BoundT "w") - (#AppT [(#BoundT "lux;Syntax'") - (#BoundT "w")])]) - Syntax - (_lux_case (#AppT [List Syntax]) - SyntaxList - (#AllT [(#Some #Nil) "lux;Syntax'" "w" - (#VariantT (#Cons [["lux;BoolS" Bool] - (#Cons [["lux;IntS" Int] - (#Cons [["lux;RealS" Real] - (#Cons [["lux;CharS" Char] - (#Cons [["lux;TextS" Text] - (#Cons [["lux;SymbolS" Ident] - (#Cons [["lux;TagS" Ident] - (#Cons [["lux;FormS" SyntaxList] - (#Cons [["lux;TupleS" SyntaxList] - (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] - #Nil]) - ])])])])])])])])]) - )])))) -(_lux_export Syntax') - -## (deftype Syntax -## (Meta Cursor (Syntax' (Meta Cursor)))) -(_lux_def Syntax - (_lux_case (#AppT [Meta Cursor]) - w - (#AppT [w (#AppT [Syntax' w])]))) -(_lux_export Syntax) - -(_lux_def SyntaxList (#AppT [List Syntax])) +## (#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 + (#VariantT (#Cons ## "lux;BoolS" + Bool + (#Cons ## "lux;IntS" + Int + (#Cons ## "lux;RealS" + Real + (#Cons ## "lux;CharS" + Char + (#Cons ## "lux;TextS" + Text + (#Cons ## "lux;SymbolS" + Ident + (#Cons ## "lux;TagS" + Ident + (#Cons ## "lux;FormS" + ASTList + (#Cons ## "lux;TupleS" + ASTList + (#Cons ## "lux;RecordS" + (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) + #Nil) + ))))))))) + )))))) +(_lux_export AST') +(_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS] AST') + +## (deftype AST +## (Meta Cursor (AST' (Meta Cursor)))) +(_lux_def AST + (#NamedT ["lux" "AST"] + (_lux_case (#AppT Meta Cursor) + w + (#AppT w (#AppT AST' w))))) +(_lux_export AST) + +(_lux_def ASTList (#AppT List AST)) ## (deftype (Either l r) ## (| (#Left l) ## (#Right r))) (_lux_def Either - (#AllT [(#Some #Nil) "lux;Either" "l" - (#AllT [#None "" "r" - (#VariantT (#Cons [["lux;Left" (#BoundT "l")] - (#Cons [["lux;Right" (#BoundT "r")] - #Nil])]))])])) + (#NamedT ["lux" "Either"] + (#UnivQ #Nil + (#UnivQ #Nil + (#VariantT (#Cons ## "lux;Left" + (#BoundT 3) + (#Cons ## "lux;Right" + (#BoundT 1) + #Nil))))))) (_lux_export Either) +(_lux_declare-tags [#Left #Right] Either) ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) (_lux_def StateE - (#AllT [(#Some #Nil) "lux;StateE" "s" - (#AllT [#None "" "a" - (#LambdaT [(#BoundT "s") - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [(#BoundT "s") - (#Cons [(#BoundT "a") - #Nil])]))])])])])) - -## (deftype Reader + (#UnivQ #Nil + (#UnivQ #Nil + (#LambdaT (#BoundT 3) + (#AppT (#AppT Either Text) + (#TupleT (#Cons (#BoundT 3) + (#Cons (#BoundT 1) + #Nil)))))))) + +## (deftype Source ## (List (Meta Cursor Text))) -(_lux_def Reader - (#AppT [List - (#AppT [(#AppT [Meta Cursor]) - Text])])) -(_lux_export Reader) - -## (deftype HostState -## (& #writer (^ org.objectweb.asm.ClassWriter) -## #loader (^ java.net.URLClassLoader) -## #classes (^ clojure.lang.Atom))) -(_lux_def HostState - (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] - (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] - (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")] - #Nil])])]))) +(_lux_def Source + (#NamedT ["lux" "Source"] + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])]))) +(_lux_export Source) ## (deftype (DefData' m) -## (| #TypeD -## (#ValueD Type) +## (| (#TypeD Type) +## (#ValueD (, Type Unit)) ## (#MacroD m) ## (#AliasD Ident))) (_lux_def DefData' - (#AllT [(#Some #Nil) "lux;DefData'" "" - (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] - (#Cons [["lux;ValueD" Type] - (#Cons [["lux;MacroD" (#BoundT "")] - (#Cons [["lux;AliasD" Ident] - #Nil])])])]))])) + (#NamedT ["lux" "DefData'"] + (#UnivQ #Nil + (#VariantT (#Cons ## "lux;ValueD" + (#TupleT (#Cons Type (#Cons Unit #Nil))) + (#Cons ## "lux;TypeD" + Type + (#Cons ## "lux;MacroD" + (#BoundT 1) + (#Cons ## "lux;AliasD" + Ident + #Nil)))))))) (_lux_export DefData') -## (deftype LuxVar -## (| (#Local Int) -## (#Global Ident))) -(_lux_def LuxVar - (#VariantT (#Cons [["lux;Local" Int] - (#Cons [["lux;Global" Ident] - #Nil])]))) -(_lux_export LuxVar) +(_lux_def Analysis + (#NamedT ["lux" "Analysis"] + Void)) +(_lux_export Analysis) ## (deftype (Module Compiler) ## (& #module-aliases (List (, Text Text)) -## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))) -## #imports (List Text) +## #defs (List (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST))))))) +## #imports (List Text) +## #tags (List (, Text (, Int (List Ident) Type))) +## #types (List (, Text (, (List Ident) Type))) ## )) (_lux_def Module - (#AllT [(#Some #Nil) "lux;Module" "Compiler" - (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] - (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE (#BoundT "Compiler")]) - SyntaxList])])]) - #Nil])])) - #Nil])]))])] - (#Cons [["lux;imports" (#AppT [List Text])] - #Nil])])]))])) + (#NamedT ["lux" "Module"] + (#UnivQ #Nil + (#TupleT (#Cons ## "lux;module-aliases" + (#AppT List (#TupleT (#Cons Text (#Cons Text #Nil)))) + (#Cons ## "lux;defs" + (#AppT List (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons Bool (#Cons (#AppT DefData' (#LambdaT ASTList + (#AppT (#AppT StateE (#BoundT 1)) + ASTList))) + #Nil))) + #Nil)))) + (#Cons ## "lux;imports" + (#AppT List Text) + (#Cons ## "lux;tags" + (#AppT List + (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons Int + (#Cons (#AppT List Ident) + (#Cons Type + #Nil)))) + #Nil)))) + (#Cons ## "lux;types" + (#AppT List + (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons (#AppT List Ident) + (#Cons Type + #Nil))) + #Nil)))) + #Nil))))))))) (_lux_export Module) +(_lux_declare-tags [#module-aliases #defs #imports #tags #types] Module) ## (deftype #rec Compiler -## (& #source Reader +## (& #source Source +## #cursor Cursor ## #modules (List (, Text (Module Compiler))) -## #envs (List (Env Text (, LuxVar Type))) -## #types (Bindings Int Type) -## #host HostState +## #envs (List (Env Text (Meta (, Type Cursor) Analysis))) +## #type-vars (Bindings Int Type) +## #expected Type ## #seed Int -## #eval? Bool)) +## #eval? Bool +## #host Void +## )) (_lux_def Compiler - (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" - (#RecordT (#Cons [["lux;source" Reader] - (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) - #Nil])]))])] - (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] - (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] - (#Cons [["lux;host" HostState] - (#Cons [["lux;seed" Int] - (#Cons [["lux;eval?" Bool] - #Nil])])])])])])]))]) - Void])) + (#NamedT ["lux" "Compiler"] + (#AppT (#UnivQ #Nil + (#TupleT (#Cons ## "lux;source" + Source + (#Cons ## "lux;cursor" + Cursor + (#Cons ## "lux;modules" + (#AppT List (#TupleT (#Cons Text + (#Cons (#AppT Module (#AppT (#BoundT 0) (#BoundT 1))) + #Nil)))) + (#Cons ## "lux;envs" + (#AppT List (#AppT (#AppT Env Text) + (#AppT (#AppT Meta + (#TupleT (#Cons Type (#Cons Cursor #Nil)))) + Analysis))) + (#Cons ## "lux;type-vars" + (#AppT (#AppT Bindings Int) Type) + (#Cons ## "lux;expected" + Type + (#Cons ## "lux;seed" + Int + (#Cons ## "lux;eval?" + Bool + (#Cons ## "lux;host" + Void + #Nil))))))))))) + Void))) (_lux_export Compiler) +(_lux_declare-tags [#source #cursor #modules #envs #type-vars #expected #seed #eval? #host] Compiler) ## (deftype Macro -## (-> (List Syntax) (StateE Compiler (List Syntax)))) +## (-> (List AST) (StateE Compiler (List AST)))) (_lux_def Macro - (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE Compiler]) - SyntaxList])])) + (#NamedT ["lux" "Macro"] + (#LambdaT ASTList + (#AppT (#AppT StateE Compiler) + ASTList)))) (_lux_export Macro) +(_lux_def DefData + (#NamedT ["lux" "DefData"] + (#AppT DefData' Macro))) +(_lux_export DefData) +(_lux_declare-tags [#ValueD #TypeD #MacroD #AliasD] DefData) + +(_lux_def Definition + (#NamedT ["lux" "Definition"] + (#AppT (#AppT Meta Bool) DefData))) +(_lux_export Definition) + ## Base functions & macros ## (def _cursor ## Cursor @@ -300,14 +407,14 @@ (_lux_: Cursor ["" -1 -1])) ## (def (_meta data) -## (-> (Syntax' (Meta Cursor)) Syntax) -## (#Meta [["" -1 -1] data])) +## (-> (AST' (Meta Cursor)) AST) +## [["" -1 -1] data]) (_lux_def _meta - (_lux_: (#LambdaT [(#AppT [Syntax' - (#AppT [Meta Cursor])]) - Syntax]) + (_lux_: (#LambdaT (#AppT AST' + (#AppT Meta Cursor)) + AST) (_lux_lambda _ data - (#Meta [_cursor data])))) + [_cursor data]))) ## (def (return x) ## (All [a] @@ -315,16 +422,16 @@ ## (Either Text (, Compiler a)))) ## ...) (_lux_def return - (_lux_: (#AllT [(#Some #Nil) "" "a" - (#LambdaT [(#BoundT "a") - (#LambdaT [Compiler - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [Compiler - (#Cons [(#BoundT "a") - #Nil])]))])])])]) + (_lux_: (#UnivQ #Nil + (#LambdaT (#BoundT 1) + (#LambdaT Compiler + (#AppT (#AppT Either Text) + (#TupleT (#Cons Compiler + (#Cons (#BoundT 1) + #Nil))))))) (_lux_lambda _ val (_lux_lambda _ state - (#Right [state val]))))) + (#Right state val))))) ## (def (fail msg) ## (All [a] @@ -332,163 +439,183 @@ ## (Either Text (, Compiler a)))) ## ...) (_lux_def fail - (_lux_: (#AllT [(#Some #Nil) "" "a" - (#LambdaT [Text - (#LambdaT [Compiler - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [Compiler - (#Cons [(#BoundT "a") - #Nil])]))])])])]) + (_lux_: (#UnivQ #Nil + (#LambdaT Text + (#LambdaT Compiler + (#AppT (#AppT Either Text) + (#TupleT (#Cons Compiler + (#Cons (#BoundT 1) + #Nil))))))) (_lux_lambda _ msg (_lux_lambda _ state (#Left msg))))) +(_lux_def bool$ + (_lux_: (#LambdaT Bool AST) + (_lux_lambda _ value + (_meta (#BoolS value))))) + +(_lux_def int$ + (_lux_: (#LambdaT Int AST) + (_lux_lambda _ value + (_meta (#IntS value))))) + +(_lux_def real$ + (_lux_: (#LambdaT Real AST) + (_lux_lambda _ value + (_meta (#RealS value))))) + +(_lux_def char$ + (_lux_: (#LambdaT Char AST) + (_lux_lambda _ value + (_meta (#CharS value))))) + (_lux_def text$ - (_lux_: (#LambdaT [Text Syntax]) + (_lux_: (#LambdaT Text AST) (_lux_lambda _ text (_meta (#TextS text))))) (_lux_def symbol$ - (_lux_: (#LambdaT [Ident Syntax]) + (_lux_: (#LambdaT Ident AST) (_lux_lambda _ ident (_meta (#SymbolS ident))))) (_lux_def tag$ - (_lux_: (#LambdaT [Ident Syntax]) + (_lux_: (#LambdaT Ident AST) (_lux_lambda _ ident (_meta (#TagS ident))))) (_lux_def form$ - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_: (#LambdaT (#AppT List AST) AST) (_lux_lambda _ tokens (_meta (#FormS tokens))))) (_lux_def tuple$ - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_: (#LambdaT (#AppT List AST) AST) (_lux_lambda _ tokens (_meta (#TupleS tokens))))) (_lux_def record$ - (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) + (_lux_: (#LambdaT (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) AST) (_lux_lambda _ tokens (_meta (#RecordS tokens))))) -(_lux_def let' +(_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])) + (#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'"))))) -(_lux_declare-macro let') + (fail "Wrong syntax for let''"))))) +(_lux_declare-macro let'') -(_lux_def lambda' +(_lux_def lambda'' (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens - (#Cons [(#Meta [_ (#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 [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#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])) + (#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"))))) -(_lux_declare-macro lambda') + (fail "Wrong syntax for lambda''"))))) +(_lux_declare-macro lambda'') -(_lux_def def' +(_lux_def def'' (_lux_: Macro - (lambda' [tokens] - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#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])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#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])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#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])])]))) - #Nil])])]))) - #Nil])) - - (#Cons [name (#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])])]))) - #Nil])])]))) - #Nil])) + (lambda'' [tokens] + (_lux_case tokens + (#Cons [[_ (#TagS ["" "export"])] + (#Cons [[_ (#FormS (#Cons [name args]))] + (#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])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#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])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [[_ (#FormS (#Cons [name args]))] + (#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])])]))) + #Nil])])]))) + #Nil])) + + (#Cons [name (#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])])]))) + #Nil])])]))) + #Nil])) - _ - (fail "Wrong syntax for def") - )))) -(_lux_declare-macro def') + _ + (fail "Wrong syntax for def''")) + ))) +(_lux_declare-macro def'') -(def' (defmacro tokens) +(def'' (defmacro' tokens) Macro (_lux_case tokens - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])]) + (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(form$ (#Cons [name args])) (#Cons [(symbol$ ["lux" "Macro"]) (#Cons [body @@ -497,8 +624,8 @@ (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) #Nil])])) - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) - (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) + (#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 [(symbol$ ["lux" "Macro"]) @@ -509,587 +636,812 @@ #Nil])])) _ - (fail "Wrong syntax for defmacro"))) -(_lux_declare-macro defmacro) + (fail "Wrong syntax for defmacro'"))) +(_lux_declare-macro defmacro') -(defmacro #export (comment tokens) +(defmacro' #export (comment tokens) (return #Nil)) -(defmacro (->' tokens) +(defmacro' ($' tokens) (_lux_case tokens - (#Cons [input (#Cons [output #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) - #Nil])) - - (#Cons [input (#Cons [output others])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) - (#Cons [output others])]))) - #Nil])]))) - #Nil])]))) - #Nil])) + (#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 ->'"))) + (fail "Wrong syntax for $'"))) -(defmacro (All' tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS #Nil)]) - (#Cons [body #Nil])]) - (return (#Cons [body - #Nil])) - - (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) - (#Cons [body #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) - (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) - (#Cons [(_meta (#TextS "")) - (#Cons [(_meta (#TextS arg-name)) - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) - (#Cons [(_meta (#TupleS other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) - #Nil])) +(def'' (map f xs) + (#UnivQ #Nil + (#UnivQ #Nil + (#LambdaT (#LambdaT (#BoundT 3) (#BoundT 1)) + (#LambdaT ($' List (#BoundT 3)) + ($' List (#BoundT 1)))))) + (_lux_case xs + #Nil + #Nil - _ - (fail "Wrong syntax for All'"))) + (#Cons x xs') + (#Cons (f x) (map f xs')))) -(defmacro (B' tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) - #Nil]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) - (#Cons [(_meta (#TextS bound-name)) - #Nil])]))) - #Nil])) +(def'' RepEnv + Type + ($' List (#TupleT (#Cons Text (#Cons AST #Nil))))) + +(def'' (make-env xs ys) + (#LambdaT ($' List Text) (#LambdaT ($' List AST) RepEnv)) + (_lux_case [xs ys] + [(#Cons x xs') (#Cons y ys')] + (#Cons [x y] (make-env xs' ys')) _ - (fail "Wrong syntax for B'"))) + #Nil)) -(defmacro ($' tokens) - (_lux_case tokens - (#Cons [x #Nil]) - (return tokens) +(def'' (text:= x y) + (#LambdaT Text (#LambdaT Text Bool)) + (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] + x [y])) - (#Cons [x (#Cons [y xs])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) - (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) - #Nil])) +(def'' (get-rep key env) + (#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) + (#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 (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) + (lambda'' [slot] + (_lux_case slot + [k v] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))] + _ - (fail "Wrong syntax for $'"))) + syntax) + ) + +(def'' (update-bounds ast) + (#LambdaT AST AST) + (_lux_case ast + [_ (#BoolS value)] + (bool$ value) -(def' (foldL f init xs) - (All' [a b] - (->' (->' (B' a) (B' b) (B' a)) - (B' a) - ($' List (B' b)) - (B' a))) + [_ (#IntS value)] + (int$ value) + + [_ (#RealS value)] + (real$ value) + + [_ (#CharS value)] + (char$ value) + + [_ (#TextS value)] + (text$ value) + + [_ (#SymbolS value)] + (symbol$ value) + + [_ (#TagS value)] + (tag$ value) + + [_ (#TupleS members)] + (tuple$ (map update-bounds members)) + + [_ (#RecordS pairs)] + (record$ (map (_lux_: (#LambdaT (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) + (lambda'' [pair] + (let'' [name val] pair + [name (update-bounds val)]))) + pairs)) + + [_ (#FormS (#Cons [_ (#TagS "lux" "BoundT")] (#Cons [_ (#IntS idx)] #Nil)))] + (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ (_jvm_ladd 2 idx)) #Nil))) + + [_ (#FormS members)] + (form$ (map update-bounds members))) + ) + +(def'' (parse-univq-args args next) + ## (All [a] (-> (List AST) (-> (List Text) (Lux a)) (Lux a))) + (#UnivQ #Nil (#LambdaT ($' List AST) + (#LambdaT (#LambdaT ($' List Text) (#AppT (#AppT StateE Compiler) (#BoundT 1))) + (#AppT (#AppT StateE Compiler) (#BoundT 1))))) + (_lux_case args + #Nil + (next #Nil) + + (#Cons [_ (#SymbolS "" arg-name)] args') + (parse-univq-args args' (lambda'' [names] (next (#Cons arg-name names)))) + + _ + (fail "Expected symbol."))) + +(def'' (make-bound idx) + (#LambdaT Int AST) + (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ idx) #Nil)))) + +(def'' (foldL f init xs) + ## (All [a b] (-> (-> a b a) a (List b) a)) + (#UnivQ #Nil (#UnivQ #Nil (#LambdaT (#LambdaT (#BoundT 3) + (#LambdaT (#BoundT 1) + (#BoundT 3))) + (#LambdaT (#BoundT 3) + (#LambdaT ($' List (#BoundT 1)) + (#BoundT 3)))))) (_lux_case xs #Nil init - (#Cons [x xs']) + (#Cons x xs') (foldL f (f init x) xs'))) -(def' (reverse list) - (All' [a] - (->' ($' List (B' a)) ($' List (B' a)))) - (foldL (lambda' [tail head] (#Cons [head tail])) +(defmacro' #export (All tokens) + (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-univq-args args + (lambda'' [names] + (let'' body' (foldL (_lux_: (#LambdaT AST (#LambdaT Text AST)) + (lambda'' [body' name'] + (form$ (#Cons (tag$ ["lux" "UnivQ"]) + (#Cons (tag$ ["lux" "Nil"]) + (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil) + (update-bounds body')) #Nil)))))) + (replace-syntax (#Cons [self-name (make-bound -2)] #Nil) + body) + names) + (return (#Cons body' #Nil))))) + + _ + (fail "Wrong syntax for All")) + )) + +(defmacro' #export (Ex tokens) + (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-univq-args args + (lambda'' [names] + (let'' body' (foldL (_lux_: (#LambdaT AST (#LambdaT Text AST)) + (lambda'' [body' name'] + (form$ (#Cons (tag$ ["lux" "ExQ"]) + (#Cons (tag$ ["lux" "Nil"]) + (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil) + (update-bounds body')) #Nil)))))) + (replace-syntax (#Cons [self-name (make-bound -2)] #Nil) + body) + names) + (return (#Cons body' #Nil))))) + + _ + (fail "Wrong syntax for Ex")) + )) + +(def'' (reverse list) + (All [a] (#LambdaT ($' List a) ($' List a))) + (foldL (lambda'' [tail head] (#Cons head tail)) #Nil list)) -(defmacro (list xs) - (return (#Cons [(foldL (lambda' [tail head] - (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) - (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) - #Nil])])))) - (_meta (#TagS ["lux" "Nil"])) - (reverse xs)) - #Nil]))) +(defmacro' #export (-> tokens) + (_lux_case (reverse tokens) + (#Cons output inputs) + (return (#Cons (foldL (_lux_: (#LambdaT AST (#LambdaT AST AST)) + (lambda'' [o i] (form$ (#Cons (tag$ ["lux" "LambdaT"]) (#Cons i (#Cons o #Nil)))))) + output + inputs) + #Nil)) + + _ + (fail "Wrong syntax for ->"))) + +(defmacro' (@list xs) + (return (#Cons (foldL (lambda'' [tail head] + (form$ (#Cons (tag$ ["lux" "Cons"]) + (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) + #Nil)))) + (tag$ ["lux" "Nil"]) + (reverse xs)) + #Nil))) -(defmacro (list& xs) +(defmacro' (@list& xs) (_lux_case (reverse xs) - (#Cons [last init]) - (return (list (foldL (lambda' [tail head] - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list head tail))))))) - last - init))) + (#Cons last init) + (return (@list (foldL (lambda'' [tail head] + (form$ (@list (tag$ ["lux" "Cons"]) + (tuple$ (@list head tail))))) + last + init))) _ - (fail "Wrong syntax for list&"))) - -(defmacro #export (lambda tokens) - (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) - [name tokens'] - - _ - [["" ""] tokens])) - (_lux_case tokens' - (#Cons [(#Meta [_ (#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 - (foldL (lambda' [body' arg] - (form$ (list (symbol$ ["" "_lux_lambda"]) - (symbol$ ["" ""]) - arg - body'))) - body - (reverse targs))))))) + (fail "Wrong syntax for @list&"))) - _ - (fail "Wrong syntax for lambda")))) +(defmacro' #export (, tokens) + (return (@list (form$ (@list (tag$ ["lux" "TupleT"]) + (foldL (lambda'' [tail head] (form$ (@list (tag$ ["lux" "Cons"]) head tail))) + (tag$ ["lux" "Nil"]) + (reverse tokens))))))) + +(defmacro' (lambda' tokens) + (let'' [name tokens'] (_lux_case tokens + (#Cons [[_ (#SymbolS ["" name])] tokens']) + [name tokens'] -(defmacro (def'' 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 + (foldL (lambda'' [body' arg] + (form$ (@list (symbol$ ["" "_lux_lambda"]) + (symbol$ ["" ""]) + arg + body'))) + body + (reverse targs))))))) + + _ + (fail "Wrong syntax for lambda'")))) + +(defmacro' (def''' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [[_ (#TagS ["" "export"])] + (#Cons [[_ (#FormS (#Cons [name args]))] (#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)))))) - (form$ (list (symbol$ ["" "_lux_export"]) name)))) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (list (form$ (list (symbol$ ["" "_lux_def"]) - name - (form$ (list (symbol$ ["" "_lux_:"]) - type - body)))) - (form$ (list (symbol$ ["" "_lux_export"]) name)))) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (return (@list (form$ (@list (symbol$ ["" "_lux_def"]) + name + (form$ (@list (symbol$ ["" "_lux_:"]) + type + (form$ (@list (symbol$ ["lux" "lambda'"]) + name + (tuple$ args) + body)))))) + (form$ (@list (symbol$ ["" "_lux_export"]) name)))) + + (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (@list (form$ (@list (symbol$ ["" "_lux_def"]) + name + (form$ (@list (symbol$ ["" "_lux_:"]) + type + body)))) + (form$ (@list (symbol$ ["" "_lux_export"]) name)))) + + (#Cons [[_ (#FormS (#Cons [name args]))] (#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)))))))) + (return (@list (form$ (@list (symbol$ ["" "_lux_def"]) + name + (form$ (@list (symbol$ ["" "_lux_:"]) + type + (form$ (@list (symbol$ ["lux" "lambda'"]) + name + (tuple$ args) + body)))))))) (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (list (form$ (list (symbol$ ["" "_lux_def"]) - name - (form$ (list (symbol$ ["" "_lux_:"]) type body)))))) + (return (@list (form$ (@list (symbol$ ["" "_lux_def"]) + name + (form$ (@list (symbol$ ["" "_lux_:"]) type body)))))) _ - (fail "Wrong syntax for def") + (fail "Wrong syntax for def'") )) -(def'' (as-pairs xs) - (All' [a] - (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) +(def''' (as-pairs xs) + (All [a] (-> ($' List a) ($' List (, a a)))) (_lux_case xs - (#Cons [x (#Cons [y xs'])]) - (#Cons [[x y] (as-pairs xs')]) + (#Cons x (#Cons y xs')) + (#Cons [x y] (as-pairs xs')) _ #Nil)) -(defmacro #export (let tokens) +(defmacro' (let' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) - (return (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) - (lambda [body binding] - (_lux_case binding - [label value] - (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) - body - (reverse (as-pairs bindings))))) + (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) + (return (@list (foldL (_lux_: (-> AST (, AST AST) + AST) + (lambda' [body binding] + (_lux_case binding + [label value] + (form$ (@list (symbol$ ["" "_lux_case"]) value label body))))) + body + (reverse (as-pairs bindings))))) _ - (fail "Wrong syntax for let"))) + (fail "Wrong syntax for let'"))) -(def'' (map f xs) - (All' [a b] - (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) - (_lux_case xs - #Nil - #Nil - - (#Cons [x xs']) - (#Cons [(f x) (map f xs')]))) - -(def'' (any? p xs) - (All' [a] - (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) +(def''' (any? p xs) + (All [a] + (-> (-> a Bool) ($' List a) Bool)) (_lux_case xs #Nil false - (#Cons [x xs']) + (#Cons x xs') (_lux_case (p x) true true false (any? p xs')))) -(def'' (spliced? token) - (->' Syntax Bool) +(def''' (spliced? token) + (-> AST Bool) (_lux_case token - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))] true _ false)) -(def'' (wrap-meta content) - (->' Syntax Syntax) - (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) - (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) - content))))))) +(def''' (wrap-meta content) + (-> AST AST) + (tuple$ (@list (tuple$ (@list (text$ "") (int$ -1) (int$ -1))) + content))) -(def'' (untemplate-list tokens) - (->' ($' List Syntax) Syntax) +(def''' (untemplate-list tokens) + (-> ($' List AST) AST) (_lux_case tokens #Nil (_meta (#TagS ["lux" "Nil"])) (#Cons [token tokens']) - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list token (untemplate-list tokens'))))))))) + (_meta (#FormS (@list (_meta (#TagS ["lux" "Cons"])) token (untemplate-list tokens')))))) -(def'' #export (list:++ xs ys) - (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) +(def''' (list:++ xs ys) + (All [a] (-> ($' List a) ($' List a) ($' List a))) (_lux_case xs - (#Cons [x xs']) - (#Cons [x (list:++ xs' ys)]) + (#Cons x xs') + (#Cons x (list:++ xs' ys)) #Nil ys)) -(defmacro #export ($ tokens) +(def''' #export (splice-helper xs ys) + (-> ($' List AST) ($' List AST) ($' List AST)) + (_lux_case xs + (#Cons x xs') + (#Cons x (splice-helper xs' ys)) + + #Nil + ys)) + +(defmacro' #export ($ tokens) (_lux_case tokens - (#Cons [op (#Cons [init args])]) - (return (list (foldL (lambda [a1 a2] (form$ (list op a1 a2))) - init - args))) + (#Cons op (#Cons init args)) + (return (@list (foldL (lambda' [a1 a2] (form$ (@list op a1 a2))) + init + args))) _ (fail "Wrong syntax for $"))) -(def'' (splice replace? untemplate tag elems) - (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) +## (deftype (Lux a) +## (-> Compiler (Either Text (, Compiler a)))) +(def''' #export Lux + Type + (#NamedT ["lux" "Lux"] + (All [a] + (-> Compiler ($' Either Text (, Compiler a)))))) + +## (defsig (Monad m) +## (: (All [a] (-> a (m a))) +## return) +## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) +## bind)) +(def''' Monad + Type + (#NamedT ["lux" "Monad"] + (All [m] + (, (All [a] (-> a ($' m a))) + (All [a b] (-> (-> a ($' m b)) + ($' m a) + ($' m b))))))) +(_lux_declare-tags [#return #bind] Monad) + +(def''' Maybe/Monad + ($' Monad Maybe) + {#return + (lambda' return [x] + (#Some x)) + + #bind + (lambda' [f ma] + (_lux_case ma + #None #None + (#Some a) (f a)))}) + +(def''' Lux/Monad + ($' Monad Lux) + {#return + (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'))))}) + +(defmacro' (do tokens) + (_lux_case tokens + (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil))) + (let' [g!wrap (symbol$ ["" "wrap"]) + g!bind (symbol$ ["" "12bind34"]) + body' (foldL (_lux_: (-> AST (, AST AST) AST) + (lambda' [body' binding] + (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" "return"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind])) + body'))))) + + _ + (fail "Wrong syntax for do"))) + +(def''' (map% m f xs) + ## (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' [{#;return wrap #;bind _} m] + (_lux_case xs + #Nil + (wrap #Nil) + + (#Cons x xs') + (do m + [y (f x) + ys (map% m f xs')] + (wrap (#Cons y ys))) + ))) + +(defmacro' #export (if tokens) + (_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) + (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) + (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:++ x y) + (-> Text Text Text) + (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] + x [y])) + +(def''' (ident->text ident) + (-> Ident Text) + (let' [[module name] ident] + ($ text:++ module ";" name))) + +(def''' (resolve-global-symbol ident state) + (-> Ident ($' Lux Ident)) + (let' [[module name] ident + {#source source #modules modules + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} state] + (_lux_case (get module modules) + (#Some {#module-aliases _ #defs defs #imports _ #tags tags #types types}) + (_lux_case (get name defs) + (#Some [_ def-data]) + (_lux_case def-data + (#AliasD real-name) + (#Right [state real-name]) + + _ + (#Right [state ident])) + + #None + (#Left ($ text:++ "Unknown definition: " (ident->text ident)))) + + #None + (#Left ($ text:++ "Unknown module: " module " @ " (ident->text ident)))))) + +(def''' (splice replace? untemplate tag elems) + (-> Bool (-> AST ($' Lux AST)) AST ($' List AST) ($' Lux AST)) (_lux_case replace? true (_lux_case (any? spliced? elems) true - (let [elems' (map (lambda [elem] - (_lux_case elem - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) - spliced - - _ - (form$ (list (symbol$ ["" "_lux_:"]) - (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"]))))) - (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem) - (tag$ ["lux" "Nil"]))))))))) - elems)] - (wrap-meta (form$ (list tag - (form$ (list& (symbol$ ["lux" "$"]) - (symbol$ ["lux" "list:++"]) - elems')))))) + (do Lux/Monad + [elems' (_lux_: ($' Lux ($' List AST)) + (map% Lux/Monad + (_lux_: (-> AST ($' Lux AST)) + (lambda' [elem] + (_lux_case elem + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))] + (wrap spliced) + + _ + (do Lux/Monad + [=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 - (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))) + (do Lux/Monad + [=elems (map% Lux/Monad untemplate elems)] + (wrap (wrap-meta (form$ (@list tag (untemplate-list =elems))))))) false - (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) + (do Lux/Monad + [=elems (map% Lux/Monad untemplate elems)] + (wrap (wrap-meta (form$ (@list tag (untemplate-list =elems)))))))) -(def'' (untemplate replace? subst token) - (->' Bool Text Syntax Syntax) - (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token]) - [_ (#Meta [_ (#BoolS value)])] - (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) +(def''' (untemplate replace? subst token) + (-> Bool Text AST ($' Lux AST)) + (_lux_case [replace? token] + [_ [_ (#BoolS value)]] + (return (wrap-meta (form$ (@list (tag$ ["lux" "BoolS"]) (bool$ value))))) - [_ (#Meta [_ (#IntS value)])] - (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) + [_ [_ (#IntS value)]] + (return (wrap-meta (form$ (@list (tag$ ["lux" "IntS"]) (int$ value))))) - [_ (#Meta [_ (#RealS value)])] - (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) + [_ [_ (#RealS value)]] + (return (wrap-meta (form$ (@list (tag$ ["lux" "RealS"]) (real$ value))))) - [_ (#Meta [_ (#CharS value)])] - (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) + [_ [_ (#CharS value)]] + (return (wrap-meta (form$ (@list (tag$ ["lux" "CharS"]) (char$ value))))) - [_ (#Meta [_ (#TextS value)])] - (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) + [_ [_ (#TextS value)]] + (return (wrap-meta (form$ (@list (tag$ ["lux" "TextS"]) (text$ value))))) - [_ (#Meta [_ (#TagS [module name])])] - (let [module' (_lux_case module - "" - subst + [_ [_ (#TagS [module name])]] + (let' [module' (_lux_case module + "" + subst - _ - module)] - (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) + _ + module)] + (return (wrap-meta (form$ (@list (tag$ ["lux" "TagS"]) (tuple$ (@list (text$ module') (text$ name)))))))) - [_ (#Meta [_ (#SymbolS [module name])])] - (let [module' (_lux_case module - "" - subst + [true [_ (#SymbolS [module name])]] + (do Lux/Monad + [real-name (_lux_case module + "" + (resolve-global-symbol [subst name]) - _ - module)] - (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) + _ + (wrap [module name])) + #let [[module name] real-name]] + (return (wrap-meta (form$ (@list (tag$ ["lux" "SymbolS"]) (tuple$ (@list (text$ module) (text$ name)))))))) - [_ (#Meta [_ (#TupleS elems)])] + [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 (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] - unquoted + [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]] + (return unquoted) - [_ (#Meta [meta (#FormS elems)])] - (let [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] - (#Meta [meta form'])) + [_ [meta (#FormS elems)]] + (do Lux/Monad + [output (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) + #let [[_ form'] output]] + (return [meta form'])) - [_ (#Meta [_ (#RecordS fields)])] - (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) - (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) - (lambda [kv] - (let [[k v] kv] - (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) - fields))))) + [_ [_ (#RecordS fields)]] + (do Lux/Monad + [=fields (map% Lux/Monad + (_lux_: (-> (, AST AST) ($' Lux AST)) + (lambda' [kv] + (let' [[k v] kv] + (do Lux/Monad + [=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)))))) )) -(defmacro (`' tokens) +(defmacro' #export (^ tokens) (_lux_case tokens - (#Cons [template #Nil]) - (return (list (untemplate true "" template))) - - _ - (fail "Wrong syntax for `'"))) + (#Cons [_ (#SymbolS "" class-name)] #Nil) + (return (@list (form$ (@list (tag$ ["lux" "DataT"]) (text$ class-name) (tag$ ["lux" "Nil"]))))) -(defmacro (' tokens) - (_lux_case tokens - (#Cons [template #Nil]) - (return (list (untemplate false "" template))) + (#Cons [_ (#SymbolS "" class-name)] params) + (return (@list (form$ (@list (tag$ ["lux" "DataT"]) (text$ class-name) (untemplate-list params))))) _ - (fail "Wrong syntax for '"))) + (fail "Wrong syntax for ^"))) -(defmacro #export (|> tokens) - (_lux_case tokens - (#Cons [init apps]) - (return (list (foldL (lambda [acc app] - (_lux_case app - (#Meta [_ (#TupleS parts)]) - (tuple$ (list:++ parts (list acc))) +(def'' (get-module-name state) + ($' Lux Text) + (_lux_case state + {#source source #modules modules + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} + (_lux_case (reverse envs) + #Nil + (#Left "Can't get the module name without a module!") - (#Meta [_ (#FormS parts)]) - (form$ (list:++ parts (list acc))) + (#Cons {#name module-name #inner-closures _ #locals _ #closure _} _) + (#Right [state module-name])))) - _ - (`' ((~ app) (~ acc))))) - init - apps))) +(defmacro' #export (` tokens) + (_lux_case tokens + (#Cons template #Nil) + (do Lux/Monad + [current-module get-module-name + =template (untemplate true current-module template)] + (wrap (@list (form$ (@list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) _ - (fail "Wrong syntax for |>"))) + (fail "Wrong syntax for `"))) -(defmacro #export (if tokens) +(defmacro' #export (' tokens) (_lux_case tokens - (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (return (list (`' (_lux_case (~ test) - true (~ then) - false (~ else))))) + (#Cons template #Nil) + (do Lux/Monad + [=template (untemplate false "" template)] + (wrap (@list (form$ (@list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) _ - (fail "Wrong syntax for if"))) - -## (deftype (Lux a) -## (-> Compiler (Either Text (, Compiler a)))) -(def'' #export Lux - Type - (All' [a] - (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) - -## (defsig (Monad m) -## (: (All [a] (-> a (m a))) -## return) -## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) -## bind)) -(def'' Monad - Type - (All' [m] - (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] - ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) - ($' (B' m) (B' a)) - ($' (B' m) (B' b))))])))) - -(def'' Maybe/Monad - ($' Monad Maybe) - {#lux;return - (lambda return [x] - (#Some x)) - - #lux;bind - (lambda [f ma] - (_lux_case ma - #None #None - (#Some a) (f a)))}) - -(def'' Lux/Monad - ($' Monad Lux) - {#lux;return - (lambda [x] - (lambda [state] - (#Right [state x]))) - - #lux;bind - (lambda [f ma] - (lambda [state] - (_lux_case (ma state) - (#Left msg) - (#Left msg) - - (#Right [state' a]) - (f a state'))))}) + (fail "Wrong syntax for '"))) -(defmacro #export (^ tokens) +(defmacro' #export (|> tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) - (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) + (#Cons [init apps]) + (return (@list (foldL (_lux_: (-> AST AST AST) + (lambda' [acc app] + (_lux_case app + [_ (#TupleS parts)] + (tuple$ (list:++ parts (@list acc))) - _ - (fail "Wrong syntax for ^"))) + [_ (#FormS parts)] + (form$ (list:++ parts (@list acc))) + + _ + (` ((~ app) (~ acc)))))) + init + apps))) -(defmacro #export (-> tokens) - (_lux_case (reverse tokens) - (#Cons [output inputs]) - (return (list (foldL (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) - output - inputs))) - _ - (fail "Wrong syntax for ->"))) + (fail "Wrong syntax for |>"))) -(defmacro #export (, tokens) - (return (list (`' (#;TupleT (~ (untemplate-list tokens))))))) +(def''' (. f g) + (All [a b c] + (-> (-> b c) (-> a b) (-> a c))) + (lambda' [x] + (f (g x)))) -(defmacro (do tokens) - (_lux_case tokens - (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) - (let [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body' binding] - (let [[var value] binding] - (_lux_case var - (#Meta [_ (#TagS ["" "let"])]) - (`' (;let (~ value) (~ body'))) - - _ - (`' (;bind (_lux_lambda (~ (symbol$ ["" ""])) - (~ var) - (~ body')) - (~ value))))))) - body - (reverse (as-pairs bindings)))] - (return (list (`' (_lux_case (~ monad) - {#;return ;return #;bind ;bind} - (~ body')))))) +(def''' (get-ident x) + (-> AST ($' Maybe Ident)) + (_lux_case x + [_ (#SymbolS sname)] + (#Some sname) _ - (fail "Wrong syntax for do"))) + #None)) -(def'' (map% m f xs) - ## (All [m a b] - ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) - (All' [m a b] - (-> ($' Monad (B' m)) - (-> (B' a) ($' (B' m) (B' b))) - ($' List (B' a)) - ($' (B' m) ($' List (B' b))))) - (let [{#;return ;return #;bind _} m] - (_lux_case xs - #Nil - (;return #Nil) - - (#Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (;return (#Cons [y ys]))) - ))) +(def''' (get-tag x) + (-> AST ($' Maybe Ident)) + (_lux_case x + [_ (#TagS sname)] + (#Some sname) -(def'' #export (. f g) - (All' [a b c] - (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) - (lambda [x] - (f (g x)))) + _ + #None)) -(def'' (get-ident x) - (-> Syntax ($' Maybe Text)) +(def''' (get-name x) + (-> AST ($' Maybe Text)) (_lux_case x - (#Meta [_ (#SymbolS ["" sname])]) + [_ (#SymbolS "" sname)] (#Some sname) _ #None)) -(def'' (tuple->list tuple) - (-> Syntax ($' Maybe ($' List Syntax))) +(def''' (tuple->list tuple) + (-> AST ($' Maybe ($' List AST))) (_lux_case tuple - (#Meta [_ (#TupleS members)]) + [_ (#TupleS members)] (#Some members) _ #None)) -(def'' RepEnv - Type - ($' List (, Text Syntax))) - -(def'' (make-env xs ys) - (-> ($' List Text) ($' List Syntax) RepEnv) - (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) - [xs ys]) - [(#Cons [x xs']) (#Cons [y ys'])] - (#Cons [[x y] (make-env xs' ys')]) - - _ - #Nil)) - -(def'' (text:= x y) - (-> Text Text Bool) - (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] - x [y])) - -(def'' (get-rep key env) - (-> Text RepEnv ($' Maybe Syntax)) - (_lux_case env - #Nil - #None - - (#Cons [[k v] env']) - (if (text:= k key) - (#Some v) - (get-rep key env')))) - -(def'' (apply-template env template) - (-> RepEnv Syntax Syntax) +(def''' (apply-template env template) + (-> RepEnv AST AST) (_lux_case template - (#Meta [_ (#SymbolS ["" sname])]) + [_ (#SymbolS "" sname)] (_lux_case (get-rep sname env) (#Some subst) subst @@ -1097,25 +1449,25 @@ _ template) - (#Meta [_ (#TupleS elems)]) + [_ (#TupleS elems)] (tuple$ (map (apply-template env) elems)) - (#Meta [_ (#FormS elems)]) + [_ (#FormS elems)] (form$ (map (apply-template env) elems)) - (#Meta [_ (#RecordS members)]) - (record$ (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [kv] - (let [[slot value] kv] - [(apply-template env slot) (apply-template env value)]))) + [_ (#RecordS members)] + (record$ (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) - (All' [a b] - (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) +(def''' (join-map f xs) + (All [a b] + (-> (-> a ($' List b)) ($' List a) ($' List b))) (_lux_case xs #Nil #Nil @@ -1123,18 +1475,17 @@ (#Cons [x xs']) (list:++ (f x) (join-map f xs')))) -(defmacro #export (do-template tokens) +(defmacro' #export (do-template tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) - (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) - [(map% Maybe/Monad get-ident bindings) - (map% Maybe/Monad tuple->list data)]) + (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) + (_lux_case [(map% Maybe/Monad get-name bindings) + (map% Maybe/Monad tuple->list data)] [(#Some bindings') (#Some data')] - (let [apply (_lux_: (-> RepEnv ($' List Syntax)) - (lambda [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - return)) + (let' [apply (_lux_: (-> RepEnv ($' List AST)) + (lambda' [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + return)) _ (fail "Wrong syntax for do-template")) @@ -1143,20 +1494,17 @@ (fail "Wrong syntax for do-template"))) (do-template [<name> <cmp> <type>] - [(def'' #export (<name> x y) + [(def''' (<name> x y) (-> <type> <type> Bool) (<cmp> x y))] [i= _jvm_leq Int] [i> _jvm_lgt Int] [i< _jvm_llt Int] - [r= _jvm_deq Real] - [r> _jvm_dgt Real] - [r< _jvm_dlt Real] ) (do-template [<name> <cmp> <eq> <type>] - [(def'' #export (<name> x y) + [(def''' (<name> x y) (-> <type> <type> Bool) (if (<cmp> x y) true @@ -1164,12 +1512,10 @@ [i>= i> i= Int] [i<= i< i= Int] - [r>= r> r= Real] - [r<= r< r= Real] ) (do-template [<name> <cmp> <type>] - [(def'' #export (<name> x y) + [(def''' (<name> x y) (-> <type> <type> <type>) (<cmp> x y))] @@ -1178,143 +1524,33 @@ [i* _jvm_lmul Int] [i/ _jvm_ldiv Int] [i% _jvm_lrem Int] - [r+ _jvm_dadd Real] - [r- _jvm_dsub Real] - [r* _jvm_dmul Real] - [r/ _jvm_ddiv Real] - [r% _jvm_drem Real] ) -(def'' (multiple? div n) +(def''' (multiple? div n) (-> Int Int Bool) (i= 0 (i% n div))) -(def'' (length list) - (-> List Int) - (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) +(def''' (length list) + (All [a] (-> ($' List a) Int)) + (foldL (lambda' [acc _] (_jvm_ladd 1 acc)) 0 list)) -(def'' #export (not x) +(def''' #export (not x) (-> Bool Bool) (if x false true)) -(def'' (text:++ x y) - (-> Text Text Text) - (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] - x [y])) - -(def'' (ident->text ident) - (-> Ident Text) - (let [[module name] ident] - ($ text:++ module ";" name))) - -(def'' (replace-syntax reps syntax) - (-> RepEnv Syntax Syntax) - (_lux_case syntax - (#Meta [_ (#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_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[k v] slot] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))]) - - _ - syntax) - ) - -(defmacro #export (All tokens) - (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) - [self-ident tokens'] - - _ - ["" tokens]))] - (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case (map% Maybe/Monad get-ident args) - (#Some idents) - (_lux_case idents - #Nil - (return (list body)) - - (#Cons [harg targs]) - (let [replacements (map (_lux_: (-> Text (, Text Syntax)) - (lambda [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) - (list& self-ident idents)) - body' (foldL (lambda [body' arg'] - (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) - (replace-syntax replacements body) - (reverse targs))] - ## (#;Some #;Nil) - (return (list (`' (#;AllT [#;None (~ (text$ self-ident)) (~ (text$ harg)) (~ body')])))))) - - #None - (fail "'All' arguments must be symbols.")) - - _ - (fail "Wrong syntax for All")) - )) - -(def'' (get k plist) - (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) - (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'' (get-module-name state) - ($' Lux Text) - (_lux_case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (_lux_case (reverse envs) - #Nil - (#Left "Can't get the module name without a module!") - - (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) - (#Right [state module-name])))) +(def''' (->text x) + (-> (^ java.lang.Object) Text) + (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])) -(def'' (find-macro' modules current-module module name) +(def''' (find-macro' modules current-module module name) (-> ($' List (, Text ($' Module Compiler))) Text Text Text ($' Maybe Macro)) (do Maybe/Monad [$module (get module modules) - gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] - (get name bindings))] - (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) + gdef (let' [{#module-aliases _ #defs bindings #imports _ #tags tags #types types} (_lux_: ($' Module Compiler) $module)] + (get name bindings))] + (_lux_case (_lux_: Definition gdef) [exported? (#MacroD macro')] (if exported? (#Some macro') @@ -1328,78 +1564,45 @@ _ #None))) -(def'' (find-macro ident) - (-> Ident ($' Lux ($' Maybe Macro))) - (do Lux/Monad - [current-module get-module-name] - (let [[module name] ident] - (lambda [state] - (_lux_case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (#Right [state (find-macro' modules current-module module name)])))))) - -(def'' (list:join xs) - (All [a] - (-> ($' List ($' List a)) ($' List a))) - (foldL list:++ #Nil xs)) - -(def'' (normalize ident) +(def''' (normalize ident) (-> Ident ($' Lux Ident)) (_lux_case ident ["" name] (do Lux/Monad [module-name get-module-name] - (;return (_lux_: Ident [module-name name]))) + (wrap [module-name name])) _ (return ident))) -(defmacro #export (| tokens) +(def''' (find-macro ident) + (-> Ident ($' Lux ($' Maybe Macro))) (do Lux/Monad - [pairs (map% Lux/Monad - (_lux_: (-> Syntax ($' Lux Syntax)) - (lambda [token] - (_lux_case token - (#Meta [_ (#TagS ident)]) - (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) - - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) - (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for |")))) - tokens)] - (;return (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) + [current-module get-module-name] + (let' [[module name] ident] + (lambda' [state] + (_lux_case state + {#source source #modules modules + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} + (#Right state (find-macro' modules current-module module name))))))) + +(def''' (macro? ident) + (-> Ident ($' Lux Bool)) + (do Lux/Monad + [ident (normalize ident) + output (find-macro ident)] + (wrap (_lux_case output + (#Some _) true + #None false)))) -(defmacro #export (& tokens) - (if (not (multiple? 2 (length tokens))) - (fail "& expects an even number of arguments.") - (do Lux/Monad - [pairs (map% Lux/Monad - (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) - (lambda [pair] - (_lux_case pair - [(#Meta [_ (#TagS ident)]) value] - (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for &")))) - (as-pairs tokens))] - (;return (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) - -(def'' #export (->text x) - (-> (^ java.lang.Object) Text) - (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])) +(def''' (list:join xs) + (All [a] + (-> ($' List ($' List a)) ($' List a))) + (foldL list:++ #Nil xs)) -(def'' (interpose sep xs) +(def''' (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) (_lux_case xs @@ -1410,12 +1613,12 @@ xs (#Cons [x xs']) - (list& x sep (interpose sep xs')))) + (@list& x sep (interpose sep xs')))) -(def'' (macro-expand syntax) - (-> Syntax ($' Lux ($' List Syntax))) - (_lux_case syntax - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) +(def''' (macro-expand token) + (-> AST ($' Lux ($' List AST))) + (_lux_case token + [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))] (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -1424,272 +1627,347 @@ (do Lux/Monad [expansion (macro args) expansion' (map% Lux/Monad macro-expand expansion)] - (;return (list:join expansion'))) + (wrap (list:join expansion'))) + + #None + (return (@list token)))) + + _ + (return (@list token)))) + +(def''' (macro-expand-all syntax) + (-> AST ($' Lux ($' List AST))) + (_lux_case syntax + [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))] + (do Lux/Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) + (do Lux/Monad + [expansion (macro args) + expansion' (map% Lux/Monad macro-expand-all expansion)] + (wrap (list:join expansion'))) #None (do Lux/Monad - [parts' (map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] - (;return (list (form$ (list:join parts'))))))) + [args' (map% Lux/Monad macro-expand-all args)] + (wrap (@list (form$ (#Cons (symbol$ macro-name) (list:join args')))))))) - (#Meta [_ (#FormS (#Cons [harg targs]))]) + [_ (#FormS members)] (do Lux/Monad - [harg+ (macro-expand harg) - targs+ (map% Lux/Monad macro-expand targs)] - (;return (list (form$ (list:++ harg+ (list:join targs+)))))) + [members' (map% Lux/Monad macro-expand-all members)] + (wrap (@list (form$ (list:join members'))))) - (#Meta [_ (#TupleS members)]) + [_ (#TupleS members)] (do Lux/Monad - [members' (map% Lux/Monad macro-expand members)] - (;return (list (tuple$ (list:join members'))))) + [members' (map% Lux/Monad macro-expand-all members)] + (wrap (@list (tuple$ (list:join members'))))) _ - (return (list syntax)))) + (return (@list syntax)))) -(def'' (walk-type type) - (-> Syntax Syntax) +(def''' (walk-type type) + (-> AST AST) (_lux_case type - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) + [_ (#FormS (#Cons [[_ (#TagS tag)] parts]))] (form$ (#Cons [(tag$ tag) (map walk-type parts)])) - (#Meta [_ (#TupleS members)]) + [_ (#TupleS members)] (tuple$ (map walk-type members)) - (#Meta [_ (#FormS (#Cons [type-fn args]))]) - (foldL (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) + [_ (#FormS (#Cons [type-fn args]))] + (foldL (_lux_: (-> AST AST AST) + (lambda' [type-fn arg] (` (#;AppT [(~ type-fn) (~ arg)])))) (walk-type type-fn) (map walk-type args)) _ type)) -(defmacro #export (type tokens) +(defmacro' #export (@type tokens) (_lux_case tokens - (#Cons [type #Nil]) + (#Cons type #Nil) (do Lux/Monad - [type+ (macro-expand type)] + [type+ (macro-expand-all type)] (_lux_case type+ - (#Cons [type' #Nil]) - (;return (list (walk-type 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"))) + (fail "Wrong syntax for @type"))) -(defmacro #export (: tokens) +(defmacro' #export (: tokens) (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) - (return (list (`' (_lux_: (;type (~ type)) (~ value))))) + (#Cons type (#Cons value #Nil)) + (return (@list (` (;_lux_: (@type (~ type)) (~ value))))) _ (fail "Wrong syntax for :"))) -(defmacro #export (:! tokens) +(defmacro' #export (:! tokens) (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) - (return (list (`' (_lux_:! (;type (~ type)) (~ value))))) + (#Cons type (#Cons value #Nil)) + (return (@list (` (;_lux_:! (@type (~ type)) (~ value))))) _ (fail "Wrong syntax for :!"))) -(def'' (empty? xs) +(def''' (empty? xs) (All [a] (-> ($' List a) Bool)) (_lux_case xs #Nil true _ false)) -(defmacro #export (deftype tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] - - _ - [false tokens])) - [rec? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens']) - [true tokens'] +(do-template [<name> <type> <value>] + [(def''' (<name> xy) + (All [a b] (-> (, a b) <type>)) + (let' [[x y] xy] <value>))] - _ - [false tokens'])) - parts (: (Maybe (, Text (List Syntax) Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])]) - (#Some [name #Nil type]) + [first a x] + [second b y]) + +(def''' (unfold-type-def type) + (-> AST ($' Lux (, AST ($' Maybe ($' List AST))))) + (_lux_case type + [_ (#FormS (#Cons [_ (#SymbolS "" "|")] cases))] + (do Lux/Monad + [members (map% Lux/Monad + (: (-> 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]) + + _ + (fail "Wrong syntax for variant case.")))) + cases)] + (return [(` (#;VariantT (~ (untemplate-list (map second members))))) + (#Some (|> members + (map first) + (map (: (-> Text AST) + (lambda' [name] (tag$ ["" name]))))))])) + + [_ (#FormS (#Cons [_ (#SymbolS "" "&")] pairs))] + (do Lux/Monad + [members (map% Lux/Monad + (: (-> (, 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.")))) + (as-pairs pairs))] + (return [(` (#TupleT (~ (untemplate-list (map second members))))) + (#Some (|> members + (map first) + (map (: (-> Text AST) + (lambda' [name] (tag$ ["" name]))))))])) + + _ + (return [type #None]))) - (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])]) - (#Some [name args type]) +(def''' (gensym prefix state) + (-> Text ($' Lux AST)) + (_lux_case state + {#source source #modules modules + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} + (#Right {#source source #modules modules + #envs envs #type-vars types #host host + #seed (i+ 1 seed) #eval? eval? #expected expected + #cursor cursor} + (symbol$ ["" ($ text:++ "__gensym__" prefix (->text seed))])))) + +(defmacro' #export (Rec tokens) + (_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"))) - _ - #None))] - (_lux_case parts - (#Some [name args type]) - (let [with-export (: (List Syntax) - (if export? - (list (`' (_lux_export (~ (symbol$ ["" name]))))) - #Nil)) - type' (: (Maybe Syntax) - (if rec? - (if (empty? args) - (let [g!param (symbol$ ["" ""]) - prime-name (symbol$ ["" (text:++ name "'")]) - type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] - (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) - ;Void)))) - #None) - (_lux_case args - #Nil - (#Some type) +(defmacro' #export (deftype tokens) + (let' [[export? tokens'] (_lux_case tokens + (#Cons [_ (#TagS "" "export")] tokens') + [true tokens'] - _ - (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] - (_lux_case type' - (#Some type'') - (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) - with-export)) + _ + [false tokens]) + [rec? tokens'] (_lux_case tokens' + (#Cons [_ (#TagS "" "rec")] tokens') + [true tokens'] + + _ + [false tokens']) + parts (: (Maybe (, Text (List AST) AST)) + (_lux_case tokens' + (#Cons [_ (#SymbolS "" name)] (#Cons type #Nil)) + (#Some name #Nil type) + + (#Cons [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] (#Cons type #Nil)) + (#Some name args type) + + _ + #None))] + (_lux_case parts + (#Some name args type) + (do Lux/Monad + [type+tags?? (unfold-type-def type) + module-name get-module-name] + (let' [type-name (symbol$ ["" name]) + [type tags??] type+tags?? + with-export (: (List AST) + (if export? + (@list (` (;_lux_export (~ type-name)))) + #Nil)) + with-tags (: (List AST) + (_lux_case tags?? + (#Some tags) + (@list (` (;_lux_declare-tags [(~@ tags)] (~ type-name)))) + + _ + (@list))) + type' (: (Maybe AST) + (if rec? + (if (empty? args) + (let' [g!param (symbol$ ["" ""]) + prime-name (symbol$ ["" (text:++ name "'")]) + type+ (replace-syntax (@list [name (` ((~ prime-name) (~ g!param)))]) type)] + (#Some (` ((All (~ prime-name) [(~ g!param)] (~ type+)) + Void)))) + #None) + (_lux_case args + #Nil + (#Some type) + + _ + (#Some (` (All (~ type-name) [(~@ args)] (~ type)))))))] + (_lux_case type' + (#Some type'') + (return (@list& (` (;_lux_def (~ type-name) (@type (#;NamedT [(~ (text$ module-name)) + (~ (text$ name))] + (~ type''))))) + (list:++ with-export with-tags))) + + #None + (fail "Wrong syntax for deftype")))) #None - (fail "Wrong syntax for deftype"))) + (fail "Wrong syntax for deftype")) + )) - #None - (fail "Wrong syntax for deftype")) - )) -## (defmacro #export (deftype tokens) -## (let [[export? tokens'] (: (, Bool (List Syntax)) -## (_lux_case (:! (List Syntax) tokens) -## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) -## [true (:! (List Syntax) tokens')] - -## _ -## [false (:! (List Syntax) tokens)])) -## parts (: (Maybe (, Syntax (List Syntax) Syntax)) -## (_lux_case tokens' -## (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) -## (#Some [(symbol$ name) #Nil type]) - -## (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) -## (#Some [(symbol$ name) args type]) - -## _ -## #None))] -## (_lux_case parts -## (#Some [name args type]) -## (let [with-export (: (List Syntax) -## (if export? -## (list (`' (_lux_export (~ name)))) -## #Nil)) -## type' (: Syntax -## (_lux_case args -## #Nil -## type - -## _ -## (`' (;All (~ name) [(~@ args)] (~ type)))))] -## (return (list& (`' (_lux_def (~ name) (;type (~ type')))) -## with-export))) - -## #None -## (fail "Wrong syntax for deftype")) -## )) - -(defmacro #export (exec tokens) +(defmacro' #export (exec tokens) (_lux_case (reverse tokens) - (#Cons [value actions]) - (let [dummy (symbol$ ["" ""])] - (return (list (foldL (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) - value - actions)))) + (#Cons value actions) + (let' [dummy (symbol$ ["" ""])] + (return (@list (foldL (_lux_: (-> AST AST AST) + (lambda' [post pre] (` (;_lux_case (~ pre) (~ dummy) (~ post))))) + value + actions)))) _ (fail "Wrong syntax for exec"))) -(defmacro #export (def tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] - - _ - [false tokens])) - parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#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 [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (#Some [name args #None body]) - - (#Cons [name (#Cons [body #Nil])]) - (#Some [name #Nil #None body]) +(defmacro' (def' tokens) + (let' [[export? tokens'] (_lux_case tokens + (#Cons [_ (#TagS "" "export")] tokens') + [true tokens'] - _ - #None))] - (_lux_case parts - (#Some [name args ?type body]) - (let [body' (: Syntax - (_lux_case args - #Nil - body + _ + [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) - _ - (`' (;lambda (~ name) [(~@ args)] (~ body))))) - body'' (: Syntax - (_lux_case ?type - (#Some type) - (`' (: (~ type) (~ body'))) - - #None - body'))] - (return (list& (`' (_lux_def (~ name) (~ body''))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for def")))) + _ + #None))] + (_lux_case parts + (#Some name args ?type body) + (let' [body' (_lux_case args + #Nil + body -(def (rejoin-pair pair) - (-> (, Syntax Syntax) (List Syntax)) - (let [[left right] pair] - (list left right))) + _ + (` (lambda' (~ name) [(~@ args)] (~ body)))) + body'' (_lux_case ?type + (#Some type) + (` (: (~ type) (~ body'))) + + #None + body')] + (return (@list& (` (;_lux_def (~ name) (~ body''))) + (if export? + (@list (` (;_lux_export (~ name)))) + #Nil)))) + + #None + (fail "Wrong syntax for def'")))) -(defmacro #export (case tokens) - (_lux_case tokens - (#Cons [value branches]) - (do Lux/Monad - [expansions (map% Lux/Monad - (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) - (lambda expander [branch] - (let [[pattern body] branch] - (_lux_case pattern - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) - (do Lux/Monad - [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) - expansions (map% Lux/Monad expander (as-pairs expansion))] - (;return (list:join expansions))) +(def' (rejoin-pair pair) + (-> (, AST AST) (List AST)) + (let' [[left right] pair] + (@list left right))) - _ - (;return (list branch)))))) - (as-pairs branches))] - (;return (list (`' (_lux_case (~ value) - (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) +(defmacro' #export (case tokens) + (_lux_case tokens + (#Cons value branches) + (if (multiple? 2 (length branches)) + (do Lux/Monad + [expansions (map% Lux/Monad + (: (-> (, AST AST) (Lux (List (, AST AST)))) + (lambda' expander [branch] + (let' [[pattern body] branch] + (_lux_case pattern + [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))] + (do Lux/Monad + [??? (macro? macro-name)] + (if ??? + (do Lux/Monad + [expansion (macro-expand (form$ (@list& (symbol$ macro-name) body macro-args))) + expansions (map% Lux/Monad expander (as-pairs expansion))] + (wrap (list:join expansions))) + (wrap (@list branch)))) + + _ + (wrap (@list branch)))))) + (as-pairs branches))] + (wrap (@list (` (;_lux_case (~ value) + (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) + (fail "case expects an even number of tokens")) _ (fail "Wrong syntax for case"))) -(defmacro #export (\ tokens) +(defmacro' #export (\ tokens) (case tokens - (#Cons [body (#Cons [pattern #Nil])]) + (#Cons body (#Cons pattern #Nil)) (do Lux/Monad - [pattern+ (macro-expand pattern)] + [module-name get-module-name + pattern+ (macro-expand-all pattern)] (case pattern+ - (#Cons [pattern' #Nil]) - (;return (list pattern' body)) + (#Cons pattern' #Nil) + (wrap (@list pattern' body)) _ (fail "\\ can only expand to 1 pattern."))) @@ -1697,165 +1975,492 @@ _ (fail "Wrong syntax for \\"))) -(defmacro #export (\or tokens) +(defmacro' #export (\or tokens) (case tokens - (#Cons [body patterns]) + (#Cons body patterns) (case patterns #Nil (fail "\\or can't have 0 patterns") _ (do Lux/Monad - [patterns' (map% Lux/Monad macro-expand patterns)] - (;return (list:join (map (lambda [pattern] (list pattern body)) - (list:join patterns')))))) + [patterns' (map% Lux/Monad macro-expand-all patterns)] + (wrap (list:join (map (lambda' [pattern] (@list pattern body)) + (list:join patterns')))))) _ (fail "Wrong syntax for \\or"))) -(do-template [<name> <offset>] - [(def #export <name> (i+ <offset>))] +(def' (symbol? ast) + (-> AST Bool) + (case ast + [_ (#SymbolS _)] + true - [inc 1] - [dec -1]) + _ + false)) -(defmacro #export (` tokens) - (do Lux/Monad - [module-name get-module-name] - (case tokens - (\ (list template)) - (;return (list (untemplate true module-name template))) +(defmacro' #export (let tokens) + (case tokens + (\ (@list [_ (#TupleS bindings)] body)) + (if (multiple? 2 (length bindings)) + (|> bindings as-pairs reverse + (foldL (: (-> AST (, AST AST) AST) + (lambda' [body' lr] + (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 `")))) + _ + (fail "Wrong syntax for let"))) -(def (gensym prefix state) - (-> Text (Lux Syntax)) - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (#Right [{#source source #modules modules - #envs envs #types types #host host - #seed (inc seed) #eval? eval?} - (symbol$ ["__gensym__" (->text seed)])]))) - -(def (macro-expand-1 token) - (-> Syntax (Lux Syntax)) - (do Lux/Monad - [token+ (macro-expand token)] - (case token+ - (\ (list token')) - (;return token') +(defmacro' #export (lambda tokens) + (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+ (foldL (: (-> AST AST AST) + (lambda' [body' arg] + (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+)))))))) - _ - (fail "Macro expanded to more than 1 element.")))) + #None + (fail "Wrong syntax for lambda"))) -(defmacro #export (sig tokens) - (do Lux/Monad - [tokens' (map% Lux/Monad macro-expand tokens) - members (map% Lux/Monad - (: (-> Syntax (Lux (, Ident Syntax))) - (lambda [token] - (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) - (do Lux/Monad - [name' (normalize name)] - (;return (: (, Ident Syntax) [name' type]))) +(defmacro' #export (def tokens) + (let [[export? tokens'] (case tokens + (#Cons [_ (#TagS "" "export")] tokens') + [true tokens'] - _ - (fail "Signatures require typed members!")))) - (list:join tokens'))] - (;return (list (`' (#;RecordT (~ (untemplate-list (map (: (-> (, Ident Syntax) Syntax) - (lambda [pair] - (let [[name type] pair] - (`' [(~ (|> name ident->text text$)) - (~ type)])))) - members))))))))) + _ + [false tokens]) + parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) + (case tokens' + (\ (@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) + (let [body (case args + #Nil + body + + _ + (` (lambda (~ name) [(~@ args)] (~ body)))) + body (case ?type + (#Some type) + (` (: (~ type) (~ body))) + + #None + body)] + (return (@list& (` (;_lux_def (~ name) (~ body))) + (if export? + (@list (` (;_lux_export (~ name)))) + (@list))))) + + #None + (fail "Wrong syntax for def")))) + +(defmacro' #export (defmacro tokens) + (let [[exported? tokens] (case tokens + (\ (@list& [_ (#TagS ["" "export"])] tokens')) + [true tokens'] + + _ + [false tokens]) + name+args+body?? (: (Maybe (, Ident (List AST) AST)) + (case tokens + (\ (@list [_ (#;FormS (@list& [_ (#SymbolS name)] args))] body)) + (#Some [name args body]) + + (\ (@list [_ (#;SymbolS name)] body)) + (#Some [name #Nil body]) + + _ + #None))] + (case name+args+body?? + (#Some [name args body]) + (let [name (symbol$ name) + decls (: (List AST) + (list:++ (if exported? (@list (` (;_lux_export (~ name)))) #;Nil) + (@list (` (;;_lux_declare-macro (~ name)))))) + def-sig (case args + #;Nil name + _ (` ((~ name) (~@ args))))] + (return (@list& (` (;;def (~ def-sig) ;;Macro (~ body))) + decls))) + + + #None + (fail "Wrong syntax for defmacro")))) (defmacro #export (defsig tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) - [true tokens'] - - _ - [false tokens])) - ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) + (let [[export? tokens'] (case tokens + (\ (@list& [_ (#TagS "" "export")] tokens')) + [true tokens'] + + _ + [false tokens]) + ?parts (: (Maybe (, Ident (List AST) (List AST))) (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs)) - (#Some [name args sigs]) + (\ (@list& [_ (#FormS (@list& [_ (#SymbolS name)] args))] sigs)) + (#Some name args sigs) - (\ (list& name sigs)) - (#Some [name #Nil sigs]) + (\ (@list& [_ (#SymbolS name)] sigs)) + (#Some name #Nil sigs) _ #None))] (case ?parts - (#Some [name args sigs]) - (let [sigs' (: Syntax - (case args - #Nil - (`' (;sig (~@ sigs))) - - _ - (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (list& (`' (_lux_def (~ name) (~ sigs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) + (#Some name args sigs) + (do Lux/Monad + [name+ (normalize name) + sigs' (map% Lux/Monad macro-expand sigs) + members (map% Lux/Monad + (: (-> 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) + tags (: (List AST) (map (. (: (-> Text AST) (lambda [n] (tag$ ["" n]))) first) members)) + types (map second members) + sig-type (` (#TupleT (~ (untemplate-list types)))) + sig-decl (` (;_lux_declare-tags [(~@ tags)] (~ def-name))) + sig+ (case args + #Nil + sig-type + + _ + (` (#NamedT [(~ (text$ _module)) (~ (text$ _name))] (;All (~ def-name) [(~@ args)] (~ sig-type)))))]] + (return (@list& (` (;_lux_def (~ def-name) (~ sig+))) + sig-decl + (if export? + (@list (` (;_lux_export (~ def-name)))) + #Nil)))) #None (fail "Wrong syntax for defsig")))) +(def (some f xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #Nil + #None + + (#Cons x xs') + (case (f x) + #None + (some f xs') + + (#Some y) + (#Some y)))) + +(def (last-index-of part text) + (-> Text Text Int) + (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "lastIndexOf" ["java.lang.String"] + text [part]))) + +(def (index-of part text) + (-> Text Text Int) + (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "indexOf" ["java.lang.String"] + text [part]))) + +(def (substring1 idx text) + (-> Int Text Text) + (_jvm_invokevirtual "java.lang.String" "substring" ["int"] + text [(_jvm_l2i idx)])) + +(def (substring2 idx1 idx2 text) + (-> Int Int Text Text) + (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] + text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) + +(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) + (#Cons module #Nil) + (#Cons (substring2 0 idx module) + (split-module (substring1 (i+ 1 idx) module)))))) + +(def (@ idx xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #Nil + #None + + (#Cons x xs') + (if (i= idx 0) + (#Some x) + (@ (i- idx 1) xs') + ))) + +(def (beta-reduce env type) + (-> (List Type) Type Type) + (case type + (#VariantT ?cases) + (#VariantT (map (beta-reduce env) ?cases)) + + (#TupleT ?members) + (#TupleT (map (beta-reduce env) ?members)) + + (#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 (@ 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)) + + (#AppT F A) + (do Maybe/Monad + [type-fn* (apply-type F A)] + (apply-type type-fn* param)) + + (#NamedT name type) + (apply-type type param) + + _ + #None)) + +(def (resolve-struct-type type) + (-> Type (Maybe (List Type))) + (case type + (#TupleT slots) + (#Some slots) + + (#AppT fun arg) + (do Maybe/Monad + [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) + + _ + #None)) + +(def (find-module name) + (-> Text (Lux (Module Compiler))) + (lambda [state] + (let [{#source source #modules modules + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} state] + (case (get name modules) + (#Some module) + (#Right state module) + + _ + (#Left ($ text:++ "Unknown module: " name)))))) + +(def get-current-module + (Lux (Module Compiler)) + (do Lux/Monad + [module-name get-module-name] + (find-module module-name))) + +(def (resolve-tag [module name]) + (-> Ident (Lux (, Int (List Ident) Type))) + (do Lux/Monad + [=module (find-module module) + #let [{#module-aliases _ #defs bindings #imports _ #tags tags-table #types types} =module]] + (case (get name tags-table) + (#Some output) + (return output) + + _ + (fail (text:++ "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 Lux/Monad + [=module (find-module module) + #let [{#module-aliases _ #defs bindings #imports _ #tags tags #types types} =module]] + (case (get name types) + (#Some [tags (#NamedT _ _type)]) + (case (resolve-struct-type _type) + (#Some members) + (return (#Some [tags members])) + + _ + (return #None)) + + _ + (return #None))) + + _ + (return #None))) + +(def expected-type + (Lux Type) + (lambda [state] + (let [{#source source #modules modules + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} state] + (#Right state expected)))) + (defmacro #export (struct tokens) (do Lux/Monad [tokens' (map% Lux/Monad macro-expand tokens) + struct-type 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 (map% Lux/Monad - (: (-> Syntax (Lux (, Syntax Syntax))) + (: (-> AST (Lux (, AST AST))) (lambda [token] (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) - (do Lux/Monad - [name' (normalize name)] - (;return (: (, Syntax Syntax) [(tag$ name') value]))) + (\ [_ (#FormS (@list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS "" tag-name)] value))]) + (case (get tag-name tag-mappings) + (#Some tag) + (wrap [tag value]) + + _ + (fail (text:++ "Unknown structure member: " tag-name))) _ - (fail "Structures require defined members!")))) + (fail "Invalid structure member.")))) (list:join tokens'))] - (;return (list (record$ members))))) + (wrap (@list (record$ members))))) (defmacro #export (defstruct tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) - [true tokens'] - - _ - [false tokens])) - ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) + (let [[export? tokens'] (case tokens + (\ (@list& [_ (#TagS "" "export")] tokens')) + [true tokens'] + + _ + [false tokens]) + ?parts (: (Maybe (, AST (List AST) AST (List AST))) (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs)) - (#Some [name args type defs]) + (\ (@list& [_ (#FormS (@list& name args))] type defs)) + (#Some name args type defs) - (\ (list& name type defs)) - (#Some [name #Nil type defs]) + (\ (@list& name type defs)) + (#Some name #Nil type defs) _ #None))] (case ?parts - (#Some [name args type defs]) - (let [defs' (: Syntax - (case args - #Nil - (`' (;struct (~@ defs))) - - _ - (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (list& (`' (def (~ name) (~ type) (~ defs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) + (#Some name args type defs) + (let [defs' (case args + #Nil + (` (struct (~@ defs))) + + _ + (` (lambda (~ name) [(~@ args)] (;struct (~@ defs)))))] + (return (@list& (` (def (~ name) (~ type) (~ defs'))) + (if export? + (@list (` (;_lux_export (~ name)))) + #Nil)))) #None (fail "Wrong syntax for defstruct")))) @@ -1867,10 +2472,11 @@ (do-template [<name> <form> <message>] [(defmacro #export (<name> tokens) (case (reverse tokens) - (\ (list& last init)) - (return (list (foldL (lambda [post pre] (` <form>)) - last - init))) + (\ (@list& last init)) + (return (@list (foldL (: (-> AST AST AST) + (lambda [post pre] (` <form>))) + last + init))) _ (fail <message>)))] @@ -1887,16 +2493,16 @@ (deftype Openings (, Text (List Ident))) -(deftype Import +(deftype Importation (, Text (Maybe Text) Referrals (Maybe Openings))) (def (extract-defs defs) - (-> (List Syntax) (Lux (List Text))) + (-> (List AST) (Lux (List Text))) (map% Lux/Monad - (: (-> Syntax (Lux Text)) + (: (-> AST (Lux Text)) (lambda [def] (case def - (#Meta [_ (#SymbolS ["" name])]) + [_ (#SymbolS "" name)] (return name) _ @@ -1904,85 +2510,85 @@ defs)) (def (parse-alias tokens) - (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax)))) + (-> (List AST) (Lux (, (Maybe Text) (List AST)))) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "as"])]) (#Meta [_ (#SymbolS ["" alias])]) tokens')) - (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens'])) + (\ (@list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens')) + (return [(#Some alias) tokens']) _ - (return (: (, (Maybe Text) (List Syntax)) [#None tokens])))) + (return [#None tokens]))) (def (parse-referrals tokens) - (-> (List Syntax) (Lux (, Referrals (List Syntax)))) + (-> (List AST) (Lux (, Referrals (List AST)))) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "refer"])]) referral tokens')) + (\ (@list& [_ (#TagS "" "refer")] referral tokens')) (case referral - (#Meta [_ (#TagS ["" "all"])]) - (return (: (, Referrals (List Syntax)) [#All tokens'])) + [_ (#TagS "" "all")] + (return [#All tokens']) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))])) + (\ [_ (#FormS (@list& [_ (#TagS "" "only")] defs))]) (do Lux/Monad [defs' (extract-defs defs)] - (return (: (, Referrals (List Syntax)) [(#Only defs') tokens']))) + (return [(#Only defs') tokens'])) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "exclude"])]) defs))])) + (\ [_ (#FormS (@list& [_ (#TagS "" "exclude")] defs))]) (do Lux/Monad [defs' (extract-defs defs)] - (return (: (, Referrals (List Syntax)) [(#Exclude defs') tokens']))) + (return [(#Exclude defs') tokens'])) _ (fail "Incorrect syntax for referral.")) _ - (return (: (, Referrals (List Syntax)) [#Nothing tokens])))) + (return [#Nothing tokens]))) (def (extract-symbol syntax) - (-> Syntax (Lux Ident)) + (-> AST (Lux Ident)) (case syntax - (#Meta [_ (#SymbolS ident)]) + [_ (#SymbolS ident)] (return ident) _ (fail "Not a symbol."))) (def (parse-openings tokens) - (-> (List Syntax) (Lux (, (Maybe Openings) (List Syntax)))) + (-> (List AST) (Lux (, (Maybe Openings) (List AST)))) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "open"])]) (#Meta [_ (#FormS (list& (#Meta [_ (#TextS prefix)]) structs))]) tokens')) + (\ (@list& [_ (#TagS "" "open")] [_ (#FormS (@list& [_ (#TextS prefix)] structs))] tokens')) (do Lux/Monad [structs' (map% Lux/Monad extract-symbol structs)] - (return (: (, (Maybe Openings) (List Syntax)) [(#Some [prefix structs']) tokens']))) + (return [(#Some prefix structs') tokens'])) _ - (return (: (, (Maybe Openings) (List Syntax)) [#None tokens])))) + (return [#None tokens]))) (def (decorate-imports super-name tokens) - (-> Text (List Syntax) (Lux (List Syntax))) + (-> Text (List AST) (Lux (List AST))) (map% Lux/Monad - (: (-> Syntax (Lux Syntax)) + (: (-> AST (Lux AST)) (lambda [token] (case token - (#Meta [_ (#SymbolS ["" sub-name])]) + [_ (#SymbolS "" sub-name)] (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" sub-name])]) parts))])) - (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) + (\ [_ (#FormS (@list& [_ (#SymbolS "" sub-name)] parts))]) + (return (form$ (@list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) _ (fail "Wrong import syntax.")))) tokens)) (def (parse-imports imports) - (-> (List Syntax) (Lux (List Import))) + (-> (List AST) (Lux (List Importation))) (do Lux/Monad [imports' (map% Lux/Monad - (: (-> Syntax (Lux (List Import))) + (: (-> AST (Lux (List Importation))) (lambda [token] (case token - (#Meta [_ (#SymbolS ["" m-name])]) - (;return (list [m-name #None #All #None])) + [_ (#SymbolS "" m-name)] + (wrap (@list [m-name #None #All #None])) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) + (\ [_ (#FormS (@list& [_ (#SymbolS "" m-name)] extra))]) (do Lux/Monad [alias+extra (parse-alias extra) #let [[alias extra] alias+extra] @@ -1992,100 +2598,54 @@ #let [[openings extra] openings+extra] extra (decorate-imports m-name extra) sub-imports (parse-imports extra)] - (;return (case (: (, Referrals (Maybe Text) (Maybe Openings)) [referral alias openings]) - [#Nothing #None #None] sub-imports - _ (list& [m-name alias referral openings] sub-imports)))) + (wrap (case [referral alias openings] + [#Nothing #None #None] sub-imports + _ (@list& [m-name alias referral openings] sub-imports)))) _ (fail "Wrong syntax for import")))) imports)] - (;return (list:join imports')))) + (wrap (list:join imports')))) (def (module-exists? module state) (-> Text (Lux Bool)) (case state {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} (case (get module modules) (#Some =module) - (#Right [state true]) + (#Right state true) #None - (#Right [state false])) + (#Right state false)) )) (def (exported-defs module state) (-> Text (Lux (List Text))) (case state {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} (case (get module modules) (#Some =module) - (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) + (let [to-alias (map (: (-> (, Text Definition) (List Text)) (lambda [gdef] (let [[name [export? _]] gdef] (if export? - (list name) - (list))))) - (let [{#module-aliases _ #defs defs #imports _} =module] + (@list name) + (@list))))) + (let [{#module-aliases _ #defs defs #imports _ #tags tags #types types} =module] defs))] - (#Right [state (list:join to-alias)])) + (#Right state (list:join to-alias))) #None (#Left ($ text:++ "Unknown module: " module))) )) -(def (last-index-of part text) - (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "lastIndexOf" ["java.lang.String"] - text [part]))) - -(def (index-of part text) - (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "indexOf" ["java.lang.String"] - text [part]))) - -(def (substring1 idx text) - (-> Int Text Text) - (_jvm_invokevirtual "java.lang.String" "substring" ["int"] - text [(_jvm_l2i idx)])) - -(def (substring2 idx1 idx2 text) - (-> Int Int Text Text) - (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] - text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) - -(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) - (#Cons [module #Nil]) - (#Cons [(substring2 0 idx module) - (split-module (substring1 (inc idx) module))])))) - -(def (@ idx xs) - (All [a] - (-> Int (List a) (Maybe a))) - (case xs - #Nil - #None - - (#Cons [x xs']) - (if (i= idx 0) - (#Some x) - (@ (dec idx) xs') - ))) - (def (split-with' p ys xs) (All [a] (-> (-> a Bool) (List a) (List a) (, (List a) (List a)))) @@ -2093,9 +2653,9 @@ #Nil [ys xs] - (#Cons [x xs']) + (#Cons x xs') (if (p x) - (split-with' p (list& x ys) xs') + (split-with' p (@list& x ys) xs') [ys xs]))) (def (split-with p xs) @@ -2109,8 +2669,8 @@ (do Lux/Monad [module-name get-module-name] (case (split-module module) - (\ (list& "." parts)) - (return (|> (list& module-name parts) (interpose "/") (foldL text:++ ""))) + (\ (@list& "." parts)) + (return (|> (@list& module-name parts) (interpose "/") (foldL text:++ ""))) parts (let [[ups parts'] (split-with (text:= "..") parts) @@ -2122,7 +2682,7 @@ (fail (text:++ "Can't clean module: " module)) (#Some top-module) - (return (|> (list& top-module parts') (interpose "/") (foldL text:++ "")))) + (return (|> (@list& top-module parts') (interpose "/") (foldL text:++ "")))) ))) )) @@ -2130,11 +2690,11 @@ (All [a] (-> (-> a Bool) (List a) (List a))) (case xs #;Nil - (list) + (@list) - (#;Cons [x xs']) + (#;Cons x xs') (if (p x) - (#;Cons [x (filter p xs')]) + (#;Cons x (filter p xs')) (filter p xs')))) (def (is-member? cases name) @@ -2146,270 +2706,6 @@ cases)] output)) -(defmacro #export (import tokens) - (do Lux/Monad - [imports (parse-imports tokens) - imports (map% Lux/Monad - (: (-> Import (Lux Import)) - (lambda [import] - (case import - [m-name m-alias m-referrals m-openings] - (do Lux/Monad - [m-name (clean-module m-name)] - (;return (: Import [m-name m-alias m-referrals m-openings])))))) - imports) - unknowns' (map% Lux/Monad - (: (-> Import (Lux (List Text))) - (lambda [import] - (case import - [m-name _ _ _] - (do Lux/Monad - [? (module-exists? m-name)] - (;return (if ? - (list) - (list m-name))))))) - imports) - #let [unknowns (list:join unknowns')]] - (case unknowns - #Nil - (do Lux/Monad - [output' (map% Lux/Monad - (: (-> Import (Lux (List Syntax))) - (lambda [import] - (case import - [m-name m-alias m-referrals m-openings] - (do Lux/Monad - [defs (case m-referrals - #All - (exported-defs m-name) - - (#Only +defs) - (do Lux/Monad - [*defs (exported-defs m-name)] - (;return (filter (is-member? +defs) *defs))) - - (#Exclude -defs) - (do Lux/Monad - [*defs (exported-defs m-name)] - (;return (filter (. not (is-member? -defs)) *defs))) - - #Nothing - (;return (list))) - #let [openings (: (List Syntax) - (case m-openings - #None - (list) - - (#Some [prefix structs]) - (map (: (-> Ident Syntax) - (lambda [struct] - (let [[_ name] struct] - (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) - structs)))]] - (;return ($ list:++ - (list (` (_lux_import (~ (text$ m-name))))) - (case m-alias - #None (list) - (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) - (map (: (-> Text Syntax) - (lambda [def] - (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) - defs) - openings)))))) - imports)] - (;return (list:join output'))) - - _ - (;return (: (List Syntax) - (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) - unknowns) - (list (` (import (~@ tokens)))))))))) - -(def (some f xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (Maybe b))) - (case xs - #Nil - #None - - (#Cons [x xs']) - (case (f x) - #None - (some f xs') - - (#Some y) - (#Some y)))) - -(def (split-slot slot) - (-> Text (, Text Text)) - (let [idx (index-of ";" slot) - module (substring2 0 idx slot) - name (substring1 (inc idx) slot)] - [module name])) - -(def (type:show type) - (-> Type Text) - (case type - (#DataT name) - ($ text:++ "(^ " name ")") - - (#TupleT elems) - (case elems - #;Nil - "(,)" - - _ - ($ text:++ "(, " (|> elems (map type:show) (interpose " ") (foldL text:++ "")) ")")) - - (#VariantT cases) - (case cases - #;Nil - "(|)" - - _ - ($ text:++ "(| " - (|> cases - (map (: (-> (, Text Type) Text) - (lambda [kv] - (case kv - [k (#TupleT #;Nil)] - ($ text:++ "#" k) - - [k v] - ($ text:++ "(#" k " " (type:show v) ")"))))) - (interpose " ") - (foldL text:++ "")) - ")")) - - (#RecordT fields) - (case fields - #;Nil - "(&)" - - _ - ($ text:++ "(& " - (|> fields - (map (: (-> (, Text Type) Text) - (: (-> (, Text Type) Text) - (lambda [kv] - (let [[k v] kv] - ($ text:++ "(#" k " " (type:show v) ")")))))) - (interpose " ") - (foldL text:++ "")) - ")")) - - (#LambdaT [input output]) - ($ text:++ "(-> " (type:show input) " " (type:show output) ")") - - (#VarT id) - ($ text:++ "⌈" (->text id) "⌋") - - (#BoundT name) - name - - (#ExT ?id) - ($ text:++ "⟨" (->text ?id) "⟩") - - (#AppT [?lambda ?param]) - ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")") - - (#AllT [?env ?name ?arg ?body]) - ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")") - )) - -(def (beta-reduce env type) - (-> (List (, Text Type)) Type Type) - (case type - (#VariantT ?cases) - (#VariantT (map (: (-> (, Text Type) (, Text Type)) - (lambda [kv] - (let [[k v] kv] - [k (beta-reduce env v)]))) - ?cases)) - - (#RecordT ?fields) - (#RecordT (map (: (-> (, Text Type) (, Text Type)) - (lambda [kv] - (let [[k v] kv] - [k (beta-reduce env v)]))) - ?fields)) - - (#TupleT ?members) - (#TupleT (map (beta-reduce env) ?members)) - - (#AppT [?type-fn ?type-arg]) - (#AppT [(beta-reduce env ?type-fn) (beta-reduce env ?type-arg)]) - - (#AllT [?local-env ?local-name ?local-arg ?local-def]) - (case ?local-env - #None - (#AllT [(#Some env) ?local-name ?local-arg ?local-def]) - - (#Some _) - type) - - (#LambdaT [?input ?output]) - (#LambdaT [(beta-reduce env ?input) (beta-reduce env ?output)]) - - (#BoundT ?name) - (case (get ?name env) - (#Some bound) - bound - - _ - type) - - _ - type - )) - -(defmacro #export (? tokens) - (case tokens - (\ (list maybe else)) - (do Lux/Monad - [g!value (gensym "")] - (return (list (` (case (~ maybe) - (#;Some (~ g!value)) - (~ g!value) - - _ - (~ else)))))) - - _ - (fail "Wrong syntax for ?"))) - -(def (apply-type type-fn param) - (-> Type Type (Maybe Type)) - (case type-fn - (#AllT [env name arg body]) - (#Some (beta-reduce (|> (? env (list)) - (put name type-fn) - (put arg param)) - body)) - - (#AppT [F A]) - (do Maybe/Monad - [type-fn* (apply-type F A)] - (apply-type type-fn* param)) - - _ - #None)) - -(def (resolve-struct-type type) - (-> Type (Maybe Type)) - (case type - (#RecordT slots) - (#Some type) - - (#AppT [fun arg]) - (apply-type fun arg) - - (#AllT [_ _ _ body]) - (resolve-struct-type body) - - _ - #None)) - (def (try-both f x1 x2) (All [a b] (-> (-> a (Maybe b)) a a (Maybe b))) @@ -2418,223 +2714,241 @@ (#;Some y) (#;Some y))) (def (find-in-env name state) - (-> Ident Compiler (Maybe Type)) - (let [vname' (ident->text name)] - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) - (lambda [env] - (case env - {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} - (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= vname' bname) - (#Some type) - #None))))) - locals - closure)))) - envs)))) - -(def (show-envs envs) - (-> (List (Env Text (, LuxVar Type))) Text) - (|> envs - (map (lambda [env] - (case env - {#name name #inner-closures _ #locals {#counter _ #mappings locals} #closure _} - ($ text:++ name ": " (|> locals - (map (: (All [a] (-> (, Text a) Text)) - (lambda [b] (let [[label _] b] label)))) - (interpose " ") - (foldL text:++ "")))))) - (interpose "\n") - (foldL text:++ ""))) + (-> Text Compiler (Maybe Type)) + (case state + {#source source #modules modules + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} + (some (: (-> (Env Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) + (lambda [env] + (case env + {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} + (try-both (some (: (-> (, Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) + (lambda [[bname [[type _] _]]] + (if (text:= name bname) + (#Some type) + #None)))) + locals + closure)))) + envs))) (def (find-in-defs name state) (-> Ident Compiler (Maybe Type)) (let [[v-prefix v-name] name {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} state] + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} state] (case (get v-prefix modules) #None #None - (#Some {#defs defs #module-aliases _ #imports _}) + (#Some {#defs defs #module-aliases _ #imports _ #tags tags #types types}) (case (get v-name defs) #None #None (#Some [_ def-data]) (case def-data - #TypeD (#Some Type) - (#ValueD type) (#Some type) + (#TypeD _) (#Some Type) + (#ValueD type _) (#Some type) (#MacroD m) (#Some Macro) (#AliasD name') (find-in-defs name' state)))))) -## (def (find-in-defs name state) -## (-> Ident Compiler (Maybe Type)) -## (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] -## (_jvm_getstatic java.lang.System out) [($ text:++ "find-in-defs #1: " (ident->text name) "\n")]) -## (let [[v-prefix v-name] name -## {#source source #modules modules -## #envs envs #types types #host host -## #seed seed #eval? eval?} state] -## (do Maybe/Monad -## [module (get v-prefix modules) -## #let [{#defs defs #module-aliases _ #imports _} module] -## def (get v-name defs) -## #let [[_ def-data] def]] -## (case def-data -## #TypeD (;return Type) -## (#ValueD type) (;return type) -## (#MacroD m) (;return Macro) -## (#AliasD name') (find-in-defs name' state)))))) - -(def (find-var-type name) + +(def (find-var-type ident) (-> Ident (Lux Type)) (do Lux/Monad - [name' (normalize name)] + [#let [[module name] ident] + current-module get-module-name] (lambda [state] - (case (find-in-env name state) - (#Some struct-type) - (#Right [state struct-type]) + (if (text:= "" module) + (case (find-in-env name state) + (#Some struct-type) + (#Right state struct-type) - _ - (case (find-in-defs name' state) + _ + (case (find-in-defs [current-module name] state) + (#Some struct-type) + (#Right state struct-type) + + _ + (let [{#source source #modules modules + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} state] + (#Left ($ text:++ "Unknown var: " (ident->text ident)))))) + (case (find-in-defs ident state) (#Some struct-type) - (#Right [state struct-type]) + (#Right state struct-type) _ (let [{#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} state] - (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))) + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} state] + (#Left ($ text:++ "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 [module name] type) + (-> Ident Type (Lux (, AST AST))) + (do Lux/Monad + [output (resolve-type-tags type) + pattern (: (Lux AST) + (case output + (#Some [tags members]) + (do Lux/Monad + [slots (map% Lux/Monad + (: (-> (, Ident Type) (Lux (, AST AST))) + (lambda [[sname stype]] (use-field sname stype))) + (zip2 tags members))] + (return (record$ slots))) + + #None + (return (symbol$ ["" name]))))] + (return [(tag$ [module name]) pattern]))) (defmacro #export (using tokens) (case tokens - (\ (list struct body)) + (\ (@list struct body)) (case struct - (#Meta [_ (#SymbolS name)]) + [_ (#SymbolS name)] (do Lux/Monad - [struct-type (find-var-type name)] - (case (resolve-struct-type struct-type) - (#Some (#RecordT slots)) - (let [pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) - (lambda [slot] - (let [[sname stype] slot - [module name] (split-slot sname)] - [(tag$ [module name]) (symbol$ ["" name])]))) - slots))] - (return (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))) + [struct-type (find-var-type name) + output (resolve-type-tags struct-type)] + (case output + (#Some [tags members]) + (do Lux/Monad + [slots (map% Lux/Monad (: (-> (, Ident Type) (Lux (, AST AST))) + (lambda [[sname stype]] (use-field sname stype))) + (zip2 tags members)) + #let [pattern (record$ slots)]] + (return (@list (` (;_lux_case (~ struct) (~ pattern) (~ body)))))) _ (fail "Can only \"use\" records."))) + + [_ (#TupleS members)] + (return (@list (foldL (: (-> AST AST AST) + (lambda [body' struct'] (` (;;using (~ struct') (~ body'))))) + body + members))) _ (let [dummy (symbol$ ["" ""])] - (return (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) - (~ body)))))))) + (return (@list (` (;_lux_case (~ struct) + (~ dummy) + (;;using (~ dummy) + (~ body)))))))) _ (fail "Wrong syntax for using"))) -(def #export (flip f) - (All [a b c] - (-> (-> a b c) (-> b a c))) - (lambda [y x] - (f x 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)))) - (defmacro #export (cond tokens) (if (i= 0 (i% (length tokens) 2)) (fail "cond requires an even number of arguments.") (case (reverse tokens) - (\ (list& else branches')) - (return (list (foldL (: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [else branch] - (let [[right left] branch] - (` (if (~ left) (~ right) (~ else)))))) - else - (as-pairs branches')))) + (\ (@list& else branches')) + (return (@list (foldL (: (-> AST (, AST AST) AST) + (lambda [else branch] + (let [[right left] branch] + (` (if (~ left) (~ right) (~ else)))))) + else + (as-pairs branches')))) _ (fail "Wrong syntax for cond")))) +(def (enumerate' idx xs) + (All [a] (-> Int (List a) (List (, Int a)))) + (case xs + (#Cons x xs') + (#Cons [idx x] (enumerate' (i+ 1 idx) xs')) + + #Nil + #Nil)) + +(def (enumerate xs) + (All [a] (-> (List a) (List (, Int a)))) + (enumerate' 0 xs)) + (defmacro #export (get@ tokens) (case tokens - (\ (list (#Meta [_ (#TagS slot')]) record)) - (case record - (#Meta [_ (#SymbolS name)]) - (do Lux/Monad - [type (find-var-type name) - g!blank (gensym "") - g!output (gensym "")] - (case (resolve-struct-type type) - (#Some (#RecordT slots)) - (do Lux/Monad - [slot (normalize slot')] - (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) - (lambda [slot] - (let [[r-slot-name r-type] slot - [r-prefix r-name] (split-slot r-slot-name)] - [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) - (text:= s-name r-name)) - g!output - g!blank)]))) - slots))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ g!output))))))) + (\ (@list [_ (#TagS slot')] record)) + (do Lux/Monad + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags type] output] + g!_ (gensym "_") + g!output (gensym "")] + (case (resolve-struct-type type) + (#Some members) + (let [pattern (record$ (map (: (-> (, Ident (, Int Type)) (, AST AST)) + (lambda [[[r-prefix r-name] [r-idx r-type]]] + [(tag$ [r-prefix r-name]) (if (i= idx r-idx) + g!output + g!_)])) + (zip2 tags (enumerate members))))] + (return (@list (` (;_lux_case (~ record) (~ pattern) (~ g!output)))))) - _ - (fail "get@ can only use records."))) - - _ - (do Lux/Monad - [_record (gensym "")] - (return (list (` (let [(~ _record) (~ record)] - (get@ (~ (tag$ slot')) (~ _record)))))))) + _ + (fail "get@ can only use records."))) _ (fail "Wrong syntax for get@"))) +(def (open-field prefix [module name] source type) + (-> Text Ident AST Type (Lux (List AST))) + (do Lux/Monad + [output (resolve-type-tags type) + #let [source+ (` (get@ (~ (tag$ [module name])) (~ source)))]] + (case output + (#Some [tags members]) + (do Lux/Monad + [decls' (map% Lux/Monad + (: (-> (, 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:++ prefix name)])) (~ source+)))))))) + (defmacro #export (open tokens) (case tokens - (\ (list& (#Meta [_ (#SymbolS struct-name)]) tokens')) + (\ (@list& [_ (#SymbolS struct-name)] tokens')) (do Lux/Monad - [#let [prefix (case tokens' - (\ (list (#Meta [_ (#TextS prefix)]))) + [@module get-module-name + #let [prefix (case tokens' + (\ (@list [_ (#TextS prefix)])) prefix _ "")] - struct-type (find-var-type struct-name)] - (case (resolve-struct-type struct-type) - (#Some (#RecordT slots)) - (return (map (: (-> (, Text Type) Syntax) - (lambda [slot] - (let [[sname stype] slot - [module name] (split-slot sname)] - (` (_lux_def (~ (symbol$ ["" (text:++ prefix name)])) - (get@ (~ (tag$ [module name])) (~ (symbol$ struct-name)))))))) - slots)) + struct-type (find-var-type struct-name) + output (resolve-type-tags struct-type) + #let [source (symbol$ struct-name)]] + (case output + (#Some [tags members]) + (do Lux/Monad + [decls' (map% Lux/Monad (: (-> (, Ident Type) (Lux (List AST))) + (lambda [[sname stype]] (open-field prefix sname source stype))) + (zip2 tags members))] + (return (list:join decls'))) _ (fail "Can only \"open\" records."))) @@ -2642,12 +2956,91 @@ _ (fail "Wrong syntax for open"))) +(defmacro #export (import tokens) + (do Lux/Monad + [imports (parse-imports tokens) + imports (map% Lux/Monad + (: (-> Importation (Lux Importation)) + (lambda [import] + (case import + [m-name m-alias m-referrals m-openings] + (do Lux/Monad + [m-name (clean-module m-name)] + (wrap [m-name m-alias m-referrals m-openings]))))) + imports) + unknowns' (map% Lux/Monad + (: (-> Importation (Lux (List Text))) + (lambda [import] + (case import + [m-name _ _ _] + (do Lux/Monad + [? (module-exists? m-name)] + (wrap (if ? + (@list) + (@list m-name))))))) + imports) + #let [unknowns (list:join unknowns')]] + (case unknowns + #Nil + (do Lux/Monad + [output' (map% Lux/Monad + (: (-> Importation (Lux (List AST))) + (lambda [import] + (case import + [m-name m-alias m-referrals m-openings] + (do Lux/Monad + [defs (case m-referrals + #All + (exported-defs m-name) + + (#Only +defs) + (do Lux/Monad + [*defs (exported-defs m-name)] + (wrap (filter (is-member? +defs) *defs))) + + (#Exclude -defs) + (do Lux/Monad + [*defs (exported-defs m-name)] + (wrap (filter (. not (is-member? -defs)) *defs))) + + #Nothing + (wrap (@list))) + #let [openings (: (List AST) + (case m-openings + #None + (@list) + + (#Some prefix structs) + (map (: (-> Ident AST) + (lambda [struct] + (let [[_ name] struct] + (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) + structs)))]] + (wrap ($ list:++ + (: (List AST) (@list (` (;_lux_import (~ (text$ m-name)))))) + (: (List AST) + (case m-alias + #None (@list) + (#Some alias) (@list (` (;_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))) + (map (: (-> Text AST) + (lambda [def] + (` (;_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) + defs) + openings)))))) + imports)] + (wrap (list:join output'))) + + _ + (wrap (list:++ (map (: (-> Text AST) (lambda [m-name] (` (;_lux_import (~ (text$ m-name)))))) + unknowns) + (: (List AST) (@list (` (;import (~@ tokens)))))))))) + (def (foldL% M f x ys) (All [m a b] (-> (Monad m) (-> a b (m a)) a (List b) (m a))) (case ys - (#Cons [y ys']) + (#Cons y ys') (do M [x' (f x y)] (foldL% M f x' ys')) @@ -2657,137 +3050,111 @@ (defmacro #export (:: tokens) (case tokens - (\ (list& start parts)) + (\ (@list& start parts)) (do Lux/Monad [output (foldL% Lux/Monad - (: (-> Syntax Syntax (Lux Syntax)) + (: (-> AST AST (Lux AST)) (lambda [so-far part] (case part - (#Meta [_ (#SymbolS slot)]) - (return (` (get@ (~ (tag$ slot)) (~ so-far)))) + [_ (#SymbolS slot)] + (return (` (using (~ so-far) (~ (symbol$ slot))))) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))])) - (return (` ((get@ (~ (tag$ slot)) (~ so-far)) + (\ [_ (#FormS (@list& [_ (#SymbolS slot)] args))]) + (return (` ((using (~ so-far) (~ (symbol$ slot))) (~@ args)))) _ (fail "Wrong syntax for ::")))) start parts)] - (return (list output))) + (return (@list output))) _ (fail "Wrong syntax for ::"))) (defmacro #export (set@ tokens) (case tokens - (\ (list (#Meta [_ (#TagS slot')]) value record)) - (case record - (#Meta [_ (#SymbolS name)]) - (do Lux/Monad - [type (find-var-type name)] - (case (resolve-struct-type type) - (#Some (#RecordT slots)) - (do Lux/Monad - [pattern' (map% Lux/Monad - (: (-> (, Text Type) (Lux (, Text Syntax))) - (lambda [slot] - (let [[r-slot-name r-type] slot] - (do Lux/Monad - [g!slot (gensym "")] - (return [r-slot-name g!slot]))))) - slots) - slot (normalize slot')] - (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[r-slot-name r-var] slot] - [(tag$ (split-slot r-slot-name)) r-var]))) - pattern')) - output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[r-slot-name r-var] slot - [r-prefix r-name] (split-slot r-slot-name)] - [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) - (text:= s-name r-name)) - value - r-var)]))) - pattern'))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) + (\ (@list [_ (#TagS slot')] value record)) + (do Lux/Monad + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags type] output]] + (case (resolve-struct-type type) + (#Some members) + (do Lux/Monad + [pattern' (map% Lux/Monad + (: (-> (, Ident (, Int Type)) (Lux (, Ident Int AST))) + (lambda [[r-slot-name [r-idx r-type]]] + (do Lux/Monad + [g!slot (gensym "")] + (return [r-slot-name r-idx g!slot])))) + (zip2 tags (enumerate members)))] + (let [pattern (record$ (map (: (-> (, Ident Int AST) (, AST AST)) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) r-var])) + pattern')) + output (record$ (map (: (-> (, Ident Int AST) (, AST AST)) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) (if (i= idx r-idx) + value + r-var)])) + pattern'))] + (return (@list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) - _ - (fail "set@ can only use records."))) - - _ - (do Lux/Monad - [_record (gensym "")] - (return (list (` (let [(~ _record) (~ record)] - (set@ (~ (tag$ slot')) (~ value) (~ _record)))))))) + _ + (fail "set@ can only use records."))) _ (fail "Wrong syntax for set@"))) (defmacro #export (update@ tokens) (case tokens - (\ (list (#Meta [_ (#TagS slot')]) fun record)) - (case record - (#Meta [_ (#SymbolS name)]) - (do Lux/Monad - [type (find-var-type name)] - (case (resolve-struct-type type) - (#Some (#RecordT slots)) - (do Lux/Monad - [pattern' (map% Lux/Monad - (: (-> (, Text Type) (Lux (, Text Syntax))) - (lambda [slot] - (let [[r-slot-name r-type] slot] - (do Lux/Monad - [g!slot (gensym "")] - (return [r-slot-name g!slot]))))) - slots) - slot (normalize slot')] - (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[r-slot-name r-var] slot] - [(tag$ (split-slot r-slot-name)) r-var]))) - pattern')) - output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[r-slot-name r-var] slot - [r-prefix r-name] (split-slot r-slot-name)] - [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) - (text:= s-name r-name)) - (` ((~ fun) (~ r-var))) - r-var)]))) - pattern'))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) + (\ (@list [_ (#TagS slot')] fun record)) + (do Lux/Monad + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags type] output]] + (case (resolve-struct-type type) + (#Some members) + (do Lux/Monad + [pattern' (map% Lux/Monad + (: (-> (, Ident (, Int Type)) (Lux (, Ident Int AST))) + (lambda [[r-slot-name [r-idx r-type]]] + (do Lux/Monad + [g!slot (gensym "")] + (return [r-slot-name r-idx g!slot])))) + (zip2 tags (enumerate members)))] + (let [pattern (record$ (map (: (-> (, Ident Int AST) (, AST AST)) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) r-var])) + pattern')) + output (record$ (map (: (-> (, Ident Int AST) (, AST AST)) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) (if (i= idx r-idx) + (` ((~ fun) (~ r-var))) + r-var)])) + pattern'))] + (return (@list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) - _ - (fail "update@ can only use records."))) - - _ - (do Lux/Monad - [_record (gensym "")] - (return (list (` (let [(~ _record) (~ record)] - (update@ (~ (tag$ slot')) (~ fun) (~ _record)))))))) + _ + (fail "update@ can only use records."))) _ (fail "Wrong syntax for update@"))) (defmacro #export (\template tokens) (case tokens - (\ (list (#Meta [_ (#TupleS data)]) - (#Meta [_ (#TupleS bindings)]) - (#Meta [_ (#TupleS templates)]))) - (case (: (Maybe (List Syntax)) + (\ (@list [_ (#TupleS data)] + [_ (#TupleS bindings)] + [_ (#TupleS templates)])) + (case (: (Maybe (List AST)) (do Maybe/Monad - [bindings' (map% Maybe/Monad get-ident bindings) + [bindings' (map% Maybe/Monad get-name bindings) data' (map% Maybe/Monad tuple->list data)] - (let [apply (: (-> RepEnv (List Syntax)) + (let [apply (: (-> RepEnv (List AST)) (lambda [env] (map (apply-template env) templates)))] (|> data' (join-map (. apply (make-env bindings'))) - ;return)))) + wrap)))) (#Some output) (return output) @@ -2797,28 +3164,140 @@ _ (fail "Wrong syntax for \\template"))) -(def #export complement - (All [a] (-> (-> a Bool) (-> a Bool))) - (. not)) - -## (defmacro #export (loop tokens) -## (case tokens -## (\ (list bindings body)) -## (let [pairs (as-pairs bindings) -## vars (map first pairs) -## inits (map second pairs)] -## (if (every? symbol? inits) -## (do Lux/Monad -## [inits' (map% Maybe/Monad get-ident inits) -## init-types (map% Maybe/Monad find-var-type inits')] -## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)] -## (~ body)) -## (~@ inits)))))) -## (do Lux/Monad -## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)] -## (return (list (` (let [(~@ (interleave aliases inits))] -## (loop [(~@ (interleave vars aliases))] -## (~ body))))))))) - -## _ -## (fail "Wrong syntax for loop"))) +(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'))))) + +(do-template [<name> <init> <op>] + [(def (<name> p xs) + (All [a] + (-> (-> a Bool) (List a) Bool)) + (foldL (lambda [_1 _2] (<op> _1 (p _2))) <init> xs))] + + [every? true and]) + +(def (type->ast type) + (-> Type AST) + (case type + (#DataT name params) + (` (#DataT (~ (text$ name)) (~ (untemplate-list (map type->ast params))))) + + (#;VariantT cases) + (` (#VariantT (~ (untemplate-list (map type->ast cases))))) + + (#TupleT parts) + (` (#TupleT (~ (untemplate-list (map type->ast parts))))) + + (#LambdaT in out) + (` (#LambdaT (~ (type->ast in)) (~ (type->ast out)))) + + (#BoundT idx) + (` (#BoundT (~ (int$ idx)))) + + (#VarT id) + (` (#VarT (~ (int$ id)))) + + (#ExT id) + (` (#ExT (~ (int$ 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)))))) + +(defmacro #export (loop tokens) + (case tokens + (\ (@list [_ (#TupleS bindings)] body)) + (let [pairs (as-pairs bindings) + vars (map first pairs) + inits (map second pairs)] + (if (every? symbol? inits) + (do Lux/Monad + [inits' (: (Lux (List Ident)) + (case (map% Maybe/Monad get-ident inits) + (#Some inits') (return inits') + #None (fail "Wrong syntax for loop"))) + init-types (map% Lux/Monad find-var-type inits') + expected expected-type] + (return (@list (` ((: (-> (~@ (map type->ast init-types)) + (~ (type->ast expected))) + (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)] + (~ body))) + (~@ inits)))))) + (do Lux/Monad + [aliases (map% Lux/Monad + (: (-> AST (Lux AST)) + (lambda [_] (gensym ""))) + inits)] + (return (@list (` (let [(~@ (interleave aliases inits))] + (;loop [(~@ (interleave vars aliases))] + (~ body))))))))) + + _ + (fail "Wrong syntax for loop"))) + +(defmacro #export (export tokens) + (return (map (: (-> AST AST) (lambda [token] (` (;_lux_export (~ token))))) tokens))) + +(defmacro #export (\slots tokens) + (case tokens + (\ (@list body [_ (#TupleS (@list& hslot' tslots'))])) + (do Lux/Monad + [slots (: (Lux (, Ident (List Ident))) + (case (: (Maybe (, Ident (List Ident))) + (do Maybe/Monad + [hslot (get-tag hslot') + tslots (map% Maybe/Monad get-tag tslots')] + (wrap [hslot tslots]))) + (#Some slots) + (return slots) + + #None + (fail "Wrong syntax for \\slots"))) + #let [[hslot tslots] slots] + hslot (normalize hslot) + tslots (map% Lux/Monad normalize tslots) + output (resolve-tag hslot) + g!_ (gensym "_") + #let [[idx tags 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))) + + _ + (fail "Wrong syntax for \\slots"))) + +(do-template [<name> <diff>] + [(def #export <name> + (-> Int Int) + (i+ <diff>))] + + [inc 1] + [dec -1]) diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux new file mode 100644 index 000000000..1b7336049 --- /dev/null +++ b/source/lux/codata/function.lux @@ -0,0 +1,27 @@ +## 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/. + +(;import lux + (lux/control (monoid #as m))) + +## [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))) + +(def #export (. f g) + (All [a b c] + (-> (-> b c) (-> a b) (-> a c))) + (lambda [x] (f (g x)))) + +## [Structures] +(defstruct #export Comp/Monoid (All [a] (m;Monoid (-> a a))) + (def unit id) + (def ++ .)) diff --git a/source/lux/codata/io.lux b/source/lux/codata/io.lux new file mode 100644 index 000000000..195aef616 --- /dev/null +++ b/source/lux/codata/io.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/. + +(;import lux + (lux (control (functor #as F) + (monad #as M)) + (data list))) + +## [Types] +(deftype #export (IO a) + (-> (,) a)) + +## [Syntax] +(defmacro #export (@io tokens state) + (case tokens + (\ (@list value)) + (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])] + (#;Right [state (@list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))])) + + _ + (#;Left "Wrong syntax for @io"))) + +## [Structures] +(defstruct #export IO/Functor (F;Functor IO) + (def (map f ma) + (@io (f (ma []))))) + +(defstruct #export IO/Monad (M;Monad IO) + (def _functor IO/Functor) + + (def (wrap x) + (@io x)) + + (def (join mma) + (mma []))) + +## [Functions] +(def #export (run-io io) + (All [a] (-> (IO a) a)) + (io [])) diff --git a/source/lux/codata/lazy.lux b/source/lux/codata/lazy.lux new file mode 100644 index 000000000..c0c79fc1a --- /dev/null +++ b/source/lux/codata/lazy.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/. + +(;import lux + (lux (meta ast) + (control (functor #as F #refer #all) + (monad #as M #refer #all)) + (data list)) + (.. function)) + +## [Types] +(deftype #export (Lazy a) + (All [b] + (-> (-> a b) b))) + +## [Syntax] +(defmacro #export (... tokens state) + (case tokens + (\ (@list value)) + (let [blank (symbol$ ["" ""])] + (#;Right [state (@list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) + + _ + (#;Left "Wrong syntax for ..."))) + +## [Functions] +(def #export (! thunk) + (All [a] + (-> (Lazy a) a)) + (thunk id)) + +(def #export (call/cc f) + (All [a b c] (Lazy (-> a (Lazy b c)) (Lazy a c))) + (lambda [k] + (f (lambda [a _] + (k a)) + k))) + +(def #export (run-lazy l k) + (All [a z] (-> (Lazy a z) (-> a z) z)) + (l k)) + +## [Structs] +(defstruct #export Lazy/Functor (Functor Lazy) + (def (map f ma) + (lambda [k] (ma (. k f))))) + +(defstruct #export Lazy/Monad (Monad Lazy) + (def _functor Lazy/Functor) + + (def (wrap a) + (... a)) + + (def join !)) diff --git a/source/lux/codata/reader.lux b/source/lux/codata/reader.lux new file mode 100644 index 000000000..e776f73ec --- /dev/null +++ b/source/lux/codata/reader.lux @@ -0,0 +1,30 @@ +## 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/. + +(;import (lux #refer (#exclude Reader)) + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Reader r a) + (-> r a)) + +## [Structures] +(defstruct #export Reader/Functor (All [r] + (Functor (Reader r))) + (def (map f fa) + (lambda [env] + (f (fa env))))) + +(defstruct #export Reader/Monad (All [r] + (Monad (Reader r))) + (def _functor Reader/Functor) + + (def (wrap x) + (lambda [env] x)) + + (def (join mma) + (lambda [env] + (mma env env)))) diff --git a/source/lux/codata/state.lux b/source/lux/codata/state.lux new file mode 100644 index 000000000..311fce320 --- /dev/null +++ b/source/lux/codata/state.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/. + +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (State s a) + (-> s (, s a))) + +## [Structures] +(defstruct #export State/Functor (All [s] + (Functor (State s))) + (def (map f ma) + (lambda [state] + (let [[state' a] (ma state)] + [state' (f a)])))) + +(defstruct #export State/Monad (All [s] + (Monad (State s))) + (def _functor State/Functor) + + (def (wrap a) + (lambda [state] + [state a])) + + (def (join mma) + (lambda [state] + (let [[state' ma] (mma state)] + (ma state'))))) + +## [Functions] +(def #export (run-state state action) + (All [s a] (-> s (State s a) a)) + (let [[state' output] (action state)] + output)) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 1d6dd1b50..86ce99761 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -1,20 +1,20 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux - (lux (control (lazy #as L #refer #all) - (functor #as F #refer #all) + (lux (control (functor #as F #refer #all) (monad #as M #refer #all) (comonad #as CM #refer #all)) (meta lux - macro syntax) - (data (list #as l #refer (#only list list& List/Monad))))) + (data (list #as l #refer (#only @list @list& List/Monad) #open ("" List/Fold)) + (number (int #open ("i" Int/Number Int/Ord))) + bool) + (codata (lazy #as L #refer #all)))) + +(open List/Monad "list:") ## [Types] (deftype #export (Stream a) @@ -25,8 +25,8 @@ (All [a] (-> a (List a) a (List a) (Stream a))) (case xs - #;Nil (cycle' init full init full) - (#;Cons [y xs']) (... [x (cycle' y xs' init full)]))) + #;Nil (cycle' init full init full) + (#;Cons x' xs') (... [x (cycle' x' xs' init full)]))) ## [Functions] (def #export (iterate f x) @@ -43,8 +43,8 @@ (All [a] (-> (List a) (Maybe (Stream a)))) (case xs - #;Nil #;None - (#;Cons [x xs']) (#;Some (cycle' x xs' x xs')))) + #;Nil #;None + (#;Cons x xs') (#;Some (cycle' x xs' x xs')))) (do-template [<name> <return> <part>] [(def #export (<name> s) @@ -59,7 +59,7 @@ (All [a] (-> Int (Stream a) a)) (let [[h t] (! s)] (if (i> idx 0) - (@ (dec idx) t) + (@ (i+ -1 idx) t) h))) (do-template [<taker> <dropper> <splitter> <det-type> <det-test> <det-step>] @@ -68,8 +68,8 @@ (-> <det-type> (Stream a) (List a))) (let [[x xs'] (! xs)] (if <det-test> - (list& x (<taker> <det-step> xs')) - (list)))) + (@list& x (<taker> <det-step> xs')) + (@list)))) (def #export (<dropper> det xs) (All [a] @@ -86,10 +86,10 @@ (if <det-test> (let [[tail next] (<splitter> <det-step> xs')] [(#;Cons [x tail]) next]) - [(list) xs])))] + [(@list) xs])))] [take-while drop-while split-with (-> a Bool) (det x) det] - [take drop split Int (i> det 0) (dec det)] + [take drop split Int (i> det 0) (i+ -1 det)] ) (def #export (unfold step init) @@ -107,27 +107,34 @@ (def #export (partition p xs) (All [a] (-> (-> a Bool) (Stream a) (, (Stream a) (Stream a)))) - [(filter p xs) (filter (complement p) xs)]) + [(filter p xs) (filter (comp p) xs)]) ## [Structures] (defstruct #export Stream/Functor (Functor Stream) - (def (F;map f fa) + (def (map f fa) (let [[h t] (! fa)] - (... [(f h) (F;map f t)])))) + (... [(f h) (map f t)])))) (defstruct #export Stream/CoMonad (CoMonad Stream) - (def CM;_functor Stream/Functor) - (def CM;unwrap head) - (def (CM;split wa) - (:: Stream/Functor (F;map repeat wa)))) + (def _functor Stream/Functor) + (def unwrap head) + (def (split wa) + (let [[head tail] (! wa)] + (... [wa (split tail)])))) ## [Pattern-matching] -(defsyntax #export (\stream body [patterns' (+^ id^)]) - (do Lux/Monad - [patterns (map% Lux/Monad macro-expand-1 patterns') - g!s (gensym "s") - #let [patterns+ (: (List Syntax) - (do List/Monad - [pattern (l;reverse patterns)] - (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]] - (M;wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) +(defsyntax #export (\stream& body [patterns (+^ id^)]) + (case (l;reverse patterns) + (\ (@list& last prevs)) + (do Lux/Monad + [prevs (map% Lux/Monad macro-expand-1 prevs) + g!s (gensym "s") + #let [body+ (foldL (lambda [inner outer] + (` (let [[(~ outer) (~ g!s)] (! (~ g!s))] + (~ inner)))) + (` (let [(~ last) (~ g!s)] (~ body))) + prevs)]] + (wrap (@list g!s body+))) + + _ + (fail "Wrong syntax for \\stream&"))) diff --git a/source/lux/control/bounded.lux b/source/lux/control/bounded.lux new file mode 100644 index 000000000..b4c8a3e57 --- /dev/null +++ b/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/. + +(;import lux) + +## Signatures +(defsig #export (Bounded a) + (: a + top) + + (: a + bottom)) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux index ce9a7e7de..2543f34da 100644 --- a/source/lux/control/comonad.lux +++ b/source/lux/control/comonad.lux @@ -1,17 +1,13 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux (../functor #as F) - lux/data/list - lux/meta/macro) + (lux/data/list #refer #all #open ("" List/Fold))) -## Signatures +## [Signatures] (defsig #export (CoMonad w) (: (F;Functor w) _functor) @@ -22,33 +18,35 @@ (-> (w a) (w (w a)))) split)) -## Functions +## [Functions] (def #export (extend w f ma) (All [w a b] (-> (CoMonad w) (-> (w a) b) (w a) (w b))) (using w - (using _functor - (map f (split ma))))) + (map f (split ma)))) -## Syntax +## [Syntax] (defmacro #export (be tokens state) (case tokens - (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) - (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (#;Cons comonad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) + (let [g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) + g!split (: AST [["" -1 -1] (#;SymbolS ["" " split "])]) + body' (foldL (: (-> AST (, AST AST) AST) (lambda [body' binding] (let [[var value] binding] (case var - (#;Meta [_ (#;TagS ["" "let"])]) - (` (;let (~ value) (~ body'))) + [_ (#;TagS ["" "let"])] + (` (let (~ value) (~ body'))) _ - (` (extend (;lambda [(~ var)] (~ body')) - (~ value))))))) + (` (|> (~ value) (~ g!split) ((~ g!map) (lambda [(~ var)] (~ body'))))) + )))) body (reverse (as-pairs bindings)))] - (#;Right [state (list (` (;case (~ monad) - {#;return ;return #;bind ;bind} - (~ body'))))])) + (#;Right [state (#;Cons (` (case (~ comonad) + {#_functor {#F;map (~ g!map)} #unwrap (~ (' unwrap)) #split (~ g!split)} + (~ body'))) + #;Nil)])) _ (#;Left "Wrong syntax for be"))) diff --git a/source/lux/control/enum.lux b/source/lux/control/enum.lux new file mode 100644 index 000000000..4ce368e96 --- /dev/null +++ b/source/lux/control/enum.lux @@ -0,0 +1,25 @@ +## 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/. + +(;import lux + (lux/control ord)) + +## [Signatures] +(defsig #export (Enum e) + (: (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 (<= from to) + (#;Cons from (range' <= succ (succ from) to)) + #;Nil)) + +(def #export (range enum from to) + (All [a] (-> (Enum a) a a (List a))) + (using enum + (range' <= succ from to))) diff --git a/source/lux/control/eq.lux b/source/lux/control/eq.lux new file mode 100644 index 000000000..d86df5757 --- /dev/null +++ b/source/lux/control/eq.lux @@ -0,0 +1,11 @@ +## 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/. + +(;import lux) + +## [Signatures] +(defsig #export (Eq a) + (: (-> a a Bool) + =)) diff --git a/source/lux/control/fold.lux b/source/lux/control/fold.lux new file mode 100644 index 000000000..d0aef1576 --- /dev/null +++ b/source/lux/control/fold.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/. + +(;import lux + (lux (control monoid + eq) + (data/number/int #open ("i" Int/Number Int/Eq)))) + +## [Signatures] +(defsig #export (Fold F) + (: (All [a b] + (-> (-> a b a) a (F b) a)) + foldL) + (: (All [a b] + (-> (-> b a a) a (F b) a)) + foldR)) + +## [Functions] +(def #export (foldM mon fold xs) + (All [F a] (-> (Monoid a) (Fold F) (F a) a)) + (using [mon fold] + (foldL ++ unit xs))) + +(def #export (size fold xs) + (All [F a] (-> (Fold F) (F a) Int)) + (using fold + (foldL (lambda [count _] (i+ 1 count)) + 0 + xs))) + +(def #export (member? eq fold x xs) + (All [F a] (-> (Eq a) (Fold F) a (F a) Bool)) + (using [eq fold] + (foldL (lambda [prev x'] (or prev (= x x'))) + false + xs))) + +(def #export (empty? fold xs) + (All [F a] (-> (Fold F) (F a) Bool)) + (i= 0 (size fold xs))) diff --git a/source/lux/control/functor.lux b/source/lux/control/functor.lux index 6a9dcfff8..99c34a45c 100644 --- a/source/lux/control/functor.lux +++ b/source/lux/control/functor.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux) diff --git a/source/lux/control/hash.lux b/source/lux/control/hash.lux new file mode 100644 index 000000000..643c49e9d --- /dev/null +++ b/source/lux/control/hash.lux @@ -0,0 +1,11 @@ +## 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/. + +(;import lux) + +## [Signatures] +(defsig #export (Hash a) + (: (-> a Int) + hash)) diff --git a/source/lux/control/lazy.lux b/source/lux/control/lazy.lux deleted file mode 100644 index 22dac74fe..000000000 --- a/source/lux/control/lazy.lux +++ /dev/null @@ -1,47 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/meta macro) - (.. (functor #as F #refer #all) - (monad #as M #refer #all)) - (lux/data list)) - -## Types -(deftype #export (Lazy a) - (All [b] - (-> (-> a b) b))) - -## Syntax -(defmacro #export (... tokens state) - (case tokens - (\ (list value)) - (let [blank (symbol$ ["" ""])] - (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) - - _ - (#;Left "Wrong syntax for ..."))) - -## Functions -(def #export (! thunk) - (All [a] - (-> (Lazy a) a)) - (thunk id)) - -## Structs -(defstruct #export Lazy/Functor (Functor Lazy) - (def (F;map f ma) - (lambda [k] (ma (. k f))))) - -(defstruct #export Lazy/Monad (Monad Lazy) - (def M;_functor Lazy/Functor) - - (def (M;wrap a) - (... a)) - - (def M;join !)) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index a03c1499a..e5c5989cf 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -1,15 +1,11 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux (.. (functor #as F) - (monoid #as M)) - lux/meta/macro) + (monoid #as M))) ## [Utils] (def (foldL f init xs) @@ -19,21 +15,21 @@ #;Nil init - (#;Cons [x xs']) + (#;Cons x xs') (foldL f (f init x) xs'))) (def (reverse xs) (All [a] (-> (List a) (List a))) - (foldL (lambda [tail head] (#;Cons [head tail])) + (foldL (lambda [tail head] (#;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')]) + (#;Cons x1 (#;Cons x2 xs')) + (#;Cons [x1 x2] (as-pairs xs')) _ #;Nil)) @@ -52,27 +48,25 @@ ## [Syntax] (defmacro #export (do tokens state) (case tokens - ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) - (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) - (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (#;Cons monad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) + (let [g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) + g!join (: AST [["" -1 -1] (#;SymbolS ["" " join "])]) + body' (foldL (: (-> AST (, AST AST) AST) (lambda [body' binding] (let [[var value] binding] (case var - (#;Meta [_ (#;TagS ["" "let"])]) - (` (;let (~ value) (~ body'))) + [_ (#;TagS ["" "let"])] + (` (let (~ value) (~ body'))) _ - (` (;case ;;_functor - {#F;map F;map} - (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join)))) - ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join))) + (` (|> (~ value) ((~ g!map) (lambda [(~ var)] (~ body'))) (~ g!join))) )))) body (reverse (as-pairs bindings)))] - (#;Right [state (#;Cons [(` (;case (~ monad) - {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} - (~ body'))) - #;Nil])])) + (#;Right [state (#;Cons (` (case (~ monad) + {#_functor {#F;map (~ g!map)} #wrap (~ (' wrap)) #join (~ g!join)} + (~ body'))) + #;Nil)])) _ (#;Left "Wrong syntax for do"))) @@ -82,18 +76,32 @@ (All [m a b] (-> (Monad m) (-> a (m b)) (m a) (m b))) (using m - (join (:: _functor (F;map f ma))))) + (join (map f ma)))) -(def #export (map% m f xs) - (All [m a b] - (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) +(def #export (seq% 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 (seq% monad xs')] + (wrap (#;Cons _x _xs))) + )) + +(def #export (map% monad f xs) + (All [M a b] + (-> (Monad M) (-> a (M b)) (List a) (M (List b)))) (case xs #;Nil - (:: m (;;wrap #;Nil)) + (:: monad (wrap #;Nil)) - (#;Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (;;wrap (#;Cons [y ys]))) + (#;Cons x xs') + (do monad + [_x (f x) + _xs (map% monad f xs')] + (wrap (#;Cons _x _xs))) )) diff --git a/source/lux/control/monoid.lux b/source/lux/control/monoid.lux index d32baabc5..447ab8225 100644 --- a/source/lux/control/monoid.lux +++ b/source/lux/control/monoid.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux) diff --git a/source/lux/control/number.lux b/source/lux/control/number.lux new file mode 100644 index 000000000..b1bbec190 --- /dev/null +++ b/source/lux/control/number.lux @@ -0,0 +1,25 @@ +## 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/. + +(;import lux + (lux/control (monoid #as m) + (eq #as E) + (ord #as O) + (bounded #as B) + (show #as S))) + +## [Signatures] +(defsig #export (Number n) + (do-template [<name>] + [(: (-> n n n) <name>)] + [+] [-] [*] [/] [%]) + + (do-template [<name>] + [(: (-> n n) <name>)] + [negate] [signum] [abs]) + + (: (-> Int n) + from-int) + ) diff --git a/source/lux/data/ord.lux b/source/lux/control/ord.lux index 80f2e4fb5..cb77e7042 100644 --- a/source/lux/data/ord.lux +++ b/source/lux/control/ord.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux (../eq #as E)) @@ -27,11 +24,11 @@ (def < <) (def (<= x y) (or (< x y) - (:: eq (E;= x y)))) + (:: eq (= x y)))) (def > >) (def (>= x y) (or (> x y) - (:: eq (E;= x y)))))) + (:: eq (= x y)))))) ## [Functions] (do-template [<name> <op>] @@ -40,5 +37,5 @@ (-> (Ord a) a a a)) (if (:: ord (<op> x y)) x y))] - [max ;;>] - [min ;;<]) + [max >] + [min <]) diff --git a/source/lux/control/show.lux b/source/lux/control/show.lux new file mode 100644 index 000000000..706819ec2 --- /dev/null +++ b/source/lux/control/show.lux @@ -0,0 +1,11 @@ +## 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/. + +(;import lux) + +## [Signatures] +(defsig #export (Show a) + (: (-> a Text) + show)) diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux index d4f223612..a3e28733b 100644 --- a/source/lux/data/bool.lux +++ b/source/lux/data/bool.lux @@ -1,33 +1,36 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux - (lux/control (monoid #as m)) - (.. (eq #as E) - (show #as S))) + (lux (control (monoid #as m) + (eq #as E) + (show #as S)) + (codata function))) ## [Structures] (defstruct #export Bool/Eq (E;Eq Bool) - (def (E;= x y) + (def (= x y) (if x y (not y)))) (defstruct #export Bool/Show (S;Show Bool) - (def (S;show x) + (def (show x) (if x "true" "false"))) (do-template [<name> <unit> <op>] [(defstruct #export <name> (m;Monoid Bool) - (def m;unit <unit>) - (def (m;++ x y) + (def unit <unit>) + (def (++ x y) (<op> x y)))] [ Or/Monoid false or] [And/Monoid true and] ) + +## [Functions] +(def #export comp + (All [a] (-> (-> a Bool) (-> a Bool))) + (. not)) diff --git a/source/lux/data/bounded.lux b/source/lux/data/bounded.lux deleted file mode 100644 index 9d2dabde1..000000000 --- a/source/lux/data/bounded.lux +++ /dev/null @@ -1,17 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## Signatures -(defsig #export (Bounded a) - (: a - top) - - (: a - bottom)) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux index 5a811c006..b7b4c6bda 100644 --- a/source/lux/data/char.lux +++ b/source/lux/data/char.lux @@ -1,21 +1,22 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux - (.. (eq #as E) - (show #as S) - (text #as T #open ("text:" Text/Monoid)))) + (lux/control (eq #as E) + (show #as S)) + (.. (text #as T #open ("text:" Text/Monoid)))) ## [Structures] (defstruct #export Char/Eq (E;Eq Char) - (def (E;= x y) + (def (= x y) (_jvm_ceq x y))) (defstruct #export Char/Show (S;Show Char) - (def (S;show x) + (def (show x) ($ text:++ "#\"" (_jvm_invokevirtual "java.lang.Object" "toString" [] x []) "\""))) + +(def #export (->text c) + (-> Char Text) + (_jvm_invokevirtual "java.lang.Object" "toString" [] c [])) diff --git a/source/lux/data/dict.lux b/source/lux/data/dict.lux deleted file mode 100644 index 63a66d49b..000000000 --- a/source/lux/data/dict.lux +++ /dev/null @@ -1,83 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/data (eq #as E))) - -## Signatures -(defsig #export (Dict d) - (: (All [k v] - (-> k (d k v) (Maybe v))) - get) - (: (All [k v] - (-> k v (d k v) (d k v))) - put) - (: (All [k v] - (-> k (d k v) (d k v))) - remove)) - -## Types -(deftype #export (PList k v) - (| (#PList (, (E;Eq k) (List (, k v)))))) - -## Constructors -(def #export (plist eq) - (All [k v] - (-> (E;Eq k) (PList k v))) - (#PList [eq #;Nil])) - -## Utils -(def (pl-get eq k kvs) - (All [k v] - (-> (E;Eq k) k (List (, k v)) (Maybe v))) - (case kvs - #;Nil - #;None - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - (#;Some v') - (pl-get eq k kvs')))) - -(def (pl-put eq k v kvs) - (All [k v] - (-> (E;Eq k) k v (List (, k v)) (List (, k v)))) - (case kvs - #;Nil - (#;Cons [[k v] kvs]) - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - (#;Cons [[k v] kvs']) - (#;Cons [[k' v'] (pl-put eq k v kvs')])))) - -(def (pl-remove eq k kvs) - (All [k v] - (-> (E;Eq k) k (List (, k v)) (List (, k v)))) - (case kvs - #;Nil - kvs - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - kvs' - (#;Cons [[k' v'] (pl-remove eq k kvs')])))) - -## Structs -(defstruct #export PList/Dict (Dict PList) - (def (get k plist) - (let [(#PList [eq kvs]) plist] - (pl-get eq k kvs))) - - (def (put k v plist) - (let [(#PList [eq kvs]) plist] - (#PList [eq (pl-put eq k v kvs)]))) - - (def (remove k plist) - (let [(#PList [eq kvs]) plist] - (#PList [eq (pl-remove eq k kvs)])))) diff --git a/source/lux/data/either.lux b/source/lux/data/either.lux index eba6438db..38de1e2d1 100644 --- a/source/lux/data/either.lux +++ b/source/lux/data/either.lux @@ -1,13 +1,12 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux - (lux/data (list #refer (#exclude partition)))) + (lux (control (functor #as F #refer #all) + (monad #as M #refer #all)) + (data (list #refer (#exclude partition))))) ## [Types] ## (deftype (Either l r) @@ -33,14 +32,32 @@ [rights b #;Right] ) -(def #export (partition es) +(def #export (partition xs) (All [a b] (-> (List (Either a b)) (, (List a) (List b)))) - (foldL (: (All [a b] - (-> (, (List a) (List b)) (Either a b) (, (List a) (List b)))) - (lambda [tails e] - (let [[ltail rtail] tails] - (case e - (#;Left x) [(#;Cons [x ltail]) rtail] - (#;Right x) [ltail (#;Cons [x rtail])])))) - [(list) (list)] - (reverse es))) + (case xs + #;Nil + [#;Nil #;Nil] + + (#;Cons x xs') + (let [[lefts rights] (partition xs')] + (case x + (#;Left x') [(#;Cons x' lefts) rights] + (#;Right x') [lefts (#;Cons x' rights)])))) + +## [Structures] +(defstruct #export Error/Functor (All [a] (Functor (Either a))) + (def (map f ma) + (case ma + (#;Left msg) (#;Left msg) + (#;Right datum) (#;Right (f datum))))) + +(defstruct #export Error/Monad (All [a] (Monad (Either a))) + (def _functor Error/Functor) + + (def (wrap a) + (#;Right a)) + + (def (join mma) + (case mma + (#;Left msg) (#;Left msg) + (#;Right ma) ma))) diff --git a/source/lux/data/eq.lux b/source/lux/data/eq.lux deleted file mode 100644 index be3400208..000000000 --- a/source/lux/data/eq.lux +++ /dev/null @@ -1,14 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## [Signatures] -(defsig #export (Eq a) - (: (-> a a Bool) - =)) diff --git a/source/lux/data/error.lux b/source/lux/data/error.lux deleted file mode 100644 index cb5c309a6..000000000 --- a/source/lux/data/error.lux +++ /dev/null @@ -1,34 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Error a) - (| (#Fail Text) - (#Ok a))) - -## [Structures] -(defstruct #export Error/Functor (Functor Error) - (def (F;map f ma) - (case ma - (#Fail msg) (#Fail msg) - (#Ok datum) (#Ok (f datum))))) - -(defstruct #export Error/Monad (Monad Error) - (def M;_functor Error/Functor) - - (def (M;wrap a) - (#Ok a)) - - (def (M;join mma) - (case mma - (#Fail msg) (#Fail msg) - (#Ok ma) ma))) diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux index 0e3bdbee6..e4f2a775f 100644 --- a/source/lux/data/id.lux +++ b/source/lux/data/id.lux @@ -1,28 +1,27 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) + (monad #as M #refer #all) + (comonad #as CM #refer #all))) ## [Types] (deftype #export (Id a) - (| (#Id a))) + a) ## [Structures] (defstruct #export Id/Functor (Functor Id) - (def (F;map f fa) - (let [(#Id a) fa] - (#Id (f a))))) + (def map id)) (defstruct #export Id/Monad (Monad Id) - (def M;_functor Id/Functor) - (def (M;wrap a) (#Id a)) - (def (M;join mma) - (let [(#Id ma) mma] - ma))) + (def _functor Id/Functor) + (def wrap id) + (def join id)) + +(defstruct #export Id/CoMonad (CoMonad Id) + (def _functor Id/Functor) + (def unwrap id) + (def split id)) diff --git a/source/lux/data/ident.lux b/source/lux/data/ident.lux new file mode 100644 index 000000000..cb2353e43 --- /dev/null +++ b/source/lux/data/ident.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/. + +(;import lux + (lux (control (eq #as E) + (show #as S)) + (data (text #open ("text:" Text/Monoid Text/Eq))))) + +## [Types] +## (deftype Ident +## (, Text Text)) + +## [Functions] +(do-template [<name> <side>] + [(def #export (<name> [left right]) + (-> Ident Text) + <side>)] + + [module left] + [name right] + ) + +## [Structures] +(defstruct #export Ident/Eq (E;Eq Ident) + (def (= [xmodule xname] [ymodule yname]) + (and (text:= xmodule ymodule) + (text:= xname yname)))) + +(defstruct #export Ident/Show (S;Show Ident) + (def (show [module name]) + ($ text:++ module ";" name))) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux deleted file mode 100644 index a194fc854..000000000 --- a/source/lux/data/io.lux +++ /dev/null @@ -1,52 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/meta macro) - (lux/control (functor #as F) - (monad #as M)) - (.. list - (text #as T #open ("text:" Text/Monoid)))) - -## Types -(deftype #export (IO a) - (-> (,) a)) - -## Syntax -(defmacro #export (io tokens state) - (case tokens - (\ (list value)) - (let [blank (symbol$ ["" ""])] - (#;Right [state (list (` (_lux_lambda (~ blank) (~ blank) (~ value))))])) - - _ - (#;Left "Wrong syntax for io"))) - -## Structures -(defstruct #export IO/Functor (F;Functor IO) - (def (F;map f ma) - (io (f (ma []))))) - -(defstruct #export IO/Monad (M;Monad IO) - (def M;_functor IO/Functor) - - (def (M;wrap x) - (io x)) - - (def (M;join mma) - (mma []))) - -## Functions -(def #export (print x) - (-> Text (IO (,))) - (io (_jvm_invokevirtual "java.io.PrintStream" "print" ["java.lang.Object"] - (_jvm_getstatic "java.lang.System" "out") [x]))) - -(def #export (println x) - (-> Text (IO (,))) - (print (text:++ x "\n"))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 8fd5c2951..6bf050228 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -1,42 +1,51 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux - (lux/control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all)) - lux/meta/macro) - -## Types + (lux (control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all) + (eq #as E) + (ord #as O) + (fold #as f)) + (data (number (int #open ("i:" Int/Number Int/Ord Int/Show))) + bool + (text #open ("text:" Text/Monoid)) + tuple) + codata/function)) + +## [Types] ## (deftype (List a) ## (| #Nil ## (#Cons (, a (List a))))) -## Functions -(def #export (foldL f init xs) - (All [a b] - (-> (-> a b a) a (List b) a)) - (case xs - #;Nil - init +## [Functions] +(defstruct #export List/Fold (f;Fold List) + (def (foldL f init xs) + (case xs + #;Nil + init - (#;Cons [x xs']) - (foldL f (f init x) xs'))) + (#;Cons [x xs']) + (foldL f (f init x) xs'))) + + (def (foldR f init xs) + (case xs + #;Nil + init -(def #export (foldR f init xs) - (All [a b] - (-> (-> b a a) a (List b) a)) - (case xs - #;Nil - init + (#;Cons [x xs']) + (f x (foldR f init xs'))))) - (#;Cons [x xs']) - (f x (foldR f init xs')))) +(open List/Fold) + +(def #export (fold mon xs) + (All [a] + (-> (m;Monoid a) (List a) a)) + (using mon + (foldL ++ unit xs))) (def #export (reverse xs) (All [a] @@ -59,7 +68,7 @@ (def #export (partition p xs) (All [a] (-> (-> a Bool) (List a) (, (List a) (List a)))) - [(filter p xs) (filter (complement p) xs)]) + [(filter p xs) (filter (comp p) xs)]) (def #export (as-pairs xs) (All [a] (-> (List a) (List (, a a)))) @@ -74,7 +83,7 @@ [(def #export (<name> n xs) (All [a] (-> Int (List a) (List a))) - (if (i> n 0) + (if (i:> n 0) (case xs #;Nil #;Nil @@ -83,8 +92,8 @@ <then>) <else>))] - [take (#;Cons [x (take (dec n) xs')]) #;Nil] - [drop (drop (dec n) xs') xs] + [take (#;Cons [x (take (i:+ -1 n) xs')]) #;Nil] + [drop (drop (i:+ -1 n) xs') xs] ) (do-template [<name> <then> <else>] @@ -107,13 +116,13 @@ (def #export (split n xs) (All [a] (-> Int (List a) (, (List a) (List a)))) - (if (i> n 0) + (if (i:> n 0) (case xs #;Nil [#;Nil #;Nil] (#;Cons [x xs']) - (let [[tail rest] (split (dec n) xs')] + (let [[tail rest] (split (i:+ -1 n) xs')] [(#;Cons [x tail]) rest])) [#;Nil xs])) @@ -138,8 +147,8 @@ (def #export (repeat n x) (All [a] (-> Int a (List a))) - (if (i> n 0) - (#;Cons [x (repeat (dec n) x)]) + (if (i:> n 0) + (#;Cons [x (repeat (i:+ -1 n) x)]) #;Nil)) (def #export (iterate f x) @@ -181,8 +190,8 @@ (#;Cons [x (#;Cons [sep (interpose sep xs')])]))) (def #export (size list) - (-> List Int) - (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) + (All [a] (-> (List a) Int)) + (foldL (lambda [acc _] (i:+ 1 acc)) 0 list)) (do-template [<name> <init> <op>] [(def #export (<name> p xs) @@ -201,50 +210,135 @@ #;None (#;Cons [x xs']) - (if (i= 0 i) + (if (i:= 0 i) (#;Some x) - (@ (dec i) xs')))) + (@ (i:+ -1 i) xs')))) -## Syntax -(defmacro #export (list xs state) - (#;Right [state (#;Cons [(foldL (lambda [tail head] - (` (#;Cons [(~ head) (~ tail)]))) - (` #;Nil) - (reverse xs)) - #;Nil])])) +## [Syntax] +(defmacro #export (@list xs state) + (#;Right state (#;Cons (foldL (: (-> AST AST AST) + (lambda [tail head] (` (#;Cons (~ head) (~ tail))))) + (` #;Nil) + (reverse xs)) + #;Nil))) -(defmacro #export (list& xs state) +(defmacro #export (@list& xs state) (case (reverse xs) - (#;Cons [last init]) - (#;Right [state (list (foldL (lambda [tail head] - (` (#;Cons [(~ head) (~ tail)]))) + (#;Cons last init) + (#;Right state (@list (foldL (: (-> AST AST AST) + (lambda [tail head] (` (#;Cons (~ head) (~ tail))))) last - init))]) + init))) _ - (#;Left "Wrong syntax for list&"))) + (#;Left "Wrong syntax for @list&"))) + +## [Structures] +(defstruct #export (List/Eq eq) + (All [a] (-> (E;Eq a) (E;Eq (List a)))) + (def (= xs ys) + (case [xs ys] + [#;Nil #;Nil] + true + + [(#;Cons x xs') (#;Cons y ys')] + (and (:: eq (= x y)) + (= xs' ys')) + + [_ _] + false + ))) -## Structures (defstruct #export List/Monoid (All [a] (Monoid (List a))) - (def m;unit #;Nil) - (def (m;++ xs ys) + (def unit #;Nil) + (def (++ xs ys) (case xs - #;Nil ys - (#;Cons [x xs']) (#;Cons [x (m;++ xs' ys)])))) + #;Nil ys + (#;Cons x xs') (#;Cons x (++ xs' ys))))) (defstruct #export List/Functor (Functor List) - (def (F;map f ma) + (def (map f ma) (case ma - #;Nil #;Nil - (#;Cons [a ma']) (#;Cons [(f a) (F;map f ma')])))) + #;Nil #;Nil + (#;Cons a ma') (#;Cons (f a) (map f ma'))))) (defstruct #export List/Monad (Monad List) - (def M;_functor List/Functor) + (def _functor List/Functor) - (def (M;wrap a) - (#;Cons [a #;Nil])) + (def (wrap a) + (#;Cons a #;Nil)) - (def (M;join mma) + (def (join mma) (using List/Monoid (foldL ++ unit mma)))) + +## [Functions] +(def #export (sort ord xs) + (All [a] (-> (O;Ord a) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons x xs') + (using ord + (let [pre (filter (>= x) xs') + post (filter (< x) xs') + ++ (:: List/Monoid ++)] + ($ ++ (sort ord pre) (@list x) (sort ord post)))))) + +## [Syntax] +(def (symbol$ name) + (-> Text AST) + [["" -1 -1] (#;SymbolS "" name)]) + +(def (range from to) + (-> Int Int (List Int)) + (if (i:<= from to) + (@list& from (range (i:+ 1 from) to)) + (@list))) + +(defmacro #export (zip tokens state) + (case tokens + (\ (@list [_ (#;IntS num-lists)])) + (if (i:> num-lists 0) + (using List/Functor + (let [indices (range 0 (i:- num-lists 1)) + type-vars (: (List AST) (map (. symbol$ i:show) indices)) + zip-type (` (All [(~@ type-vars)] + (-> (~@ (map (: (-> AST AST) (lambda [var] (` (List (~ var))))) + type-vars)) + (List (, (~@ type-vars)))))) + vars+lists (map (lambda [idx] + (let [base (text:++ "_" (i:show idx))] + [(symbol$ base) + (symbol$ (text:++ base "s"))])) + indices) + pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) + vars+lists))]) + g!step (symbol$ "\tstep\t") + g!blank (symbol$ "\t_\t") + list-vars (map second vars+lists) + code (` (: (~ zip-type) + (lambda (~ g!step) [(~@ list-vars)] + (case [(~@ list-vars)] + (~ pattern) + (#;Cons [(~@ (map first vars+lists))] + ((~ g!step) (~@ list-vars))) + + (~ g!blank) + #;Nil))))] + (#;Right [state (@list code)]))) + (#;Left "Can't zip no lists.")) + + _ + (#;Left "Wrong syntax for zip"))) + +(def #export zip2 (zip 2)) +(def #export zip3 (zip 3)) + +(def #export (empty? xs) + (All [a] (-> (List a) Bool)) + (case xs + #;Nil true + _ false)) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux index faec53c2e..1303270a7 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -1,15 +1,12 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux - (lux/control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all))) + (lux (control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all)))) ## [Types] ## (deftype (Maybe a) @@ -17,26 +14,33 @@ ## (#;Some a))) ## [Structures] -(defstruct #export Maybe/Monoid (Monoid Maybe) - (def m;unit #;None) - (def (m;++ xs ys) +(defstruct #export Maybe/Monoid (All [a] (Monoid (Maybe a))) + (def unit #;None) + (def (++ xs ys) (case xs #;None ys (#;Some x) (#;Some x)))) (defstruct #export Maybe/Functor (Functor Maybe) - (def (F;map f ma) + (def (map f ma) (case ma #;None #;None (#;Some a) (#;Some (f a))))) (defstruct #export Maybe/Monad (Monad Maybe) - (def M;_functor Maybe/Functor) + (def _functor Maybe/Functor) - (def (M;wrap x) + (def (wrap x) (#;Some x)) - (def (M;join mma) + (def (join mma) (case mma #;None #;None (#;Some xs) xs))) + +## [Functions] +(def #export (? else maybe) + (All [a] (-> a (Maybe a) a)) + (case maybe + (#;Some x) x + _ else)) diff --git a/source/lux/data/number.lux b/source/lux/data/number.lux deleted file mode 100644 index 8771ef06e..000000000 --- a/source/lux/data/number.lux +++ /dev/null @@ -1,113 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/control (monoid #as m)) - (.. (eq #as E) - (ord #as O) - (bounded #as B) - (show #as S))) - -## Signatures -(defsig #export (Number n) - (do-template [<name>] - [(: (-> n n n) <name>)] - [+] [-] [*] [/] [%]) - - (: (-> Int n) - from-int) - - (do-template [<name>] - [(: (-> n n) <name>)] - [negate] [signum] [abs]) - ) - -## [Structures] -## Number -(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>] - [(defstruct #export <name> (Number <type>) - (def + <+>) - (def - <->) - (def * <*>) - (def / </>) - (def % <%>) - (def (from-int x) - (<from> x)) - (def (negate x) - (<*> <-1> x)) - (def (abs x) - (if (<<> x <0>) - (<*> <-1> x) - x)) - (def (signum x) - (cond (<=> x <0>) <0> - (<<> x <0>) <-1> - ## else - <1>)) - )] - - [ Int/Number Int i+ i- i* i/ i% i= i< id 0 1 -1] - [Real/Number Real r+ r- r* r/ r% r= r< _jvm_l2d 0.0 1.0 -1.0]) - -## Eq -(defstruct #export Int/Eq (E;Eq Int) - (def E;= i=)) - -(defstruct #export Real/Eq (E;Eq Real) - (def E;= r=)) - -## Ord -(do-template [<name> <type> <eq> <lt> <gt>] - [(defstruct #export <name> (O;Ord <type>) - (def O;_eq <eq>) - (def O;< <lt>) - (def (O;<= x y) - (or (<lt> x y) - (:: <eq> (E;= x y)))) - (def O;> <gt>) - (def (O;>= x y) - (or (<gt> x y) - (:: <eq> (E;= x y)))))] - - [ Int/Ord Int Int/Eq i< i>] - [Real/Ord Real Real/Eq r< r>]) - -## Bounded -(do-template [<name> <type> <top> <bottom>] - [(defstruct #export <name> (B;Bounded <type>) - (def B;top <top>) - (def B;bottom <bottom>))] - - [ Int/Bounded Int (_jvm_getstatic "java.lang.Long" "MAX_VALUE") (_jvm_getstatic "java.lang.Long" "MIN_VALUE")] - [Real/Bounded Real (_jvm_getstatic "java.lang.Double" "MAX_VALUE") (_jvm_getstatic "java.lang.Double" "MIN_VALUE")]) - -## Monoid -(do-template [<name> <type> <unit> <++>] - [(defstruct #export <name> (m;Monoid <type>) - (def m;unit <unit>) - (def m;++ <++>))] - - [ IntAdd/Monoid Int 0 i+] - [ IntMul/Monoid Int 1 i*] - [RealAdd/Monoid Real 0.0 r+] - [RealMul/Monoid Real 1.0 r*] - [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)] - [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)] - [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)] - [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)] - ) - -## Show -(do-template [<name> <type> <body>] - [(defstruct #export <name> (S;Show <type>) - (def (S;show x) - <body>))] - - [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] - [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] - ) diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux new file mode 100644 index 000000000..1e71b8a5a --- /dev/null +++ b/source/lux/data/number/int.lux @@ -0,0 +1,93 @@ +## 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/. + +(;import lux + (lux/control (number #as N) + (monoid #as m) + (eq #as E) + (ord #as O) + (enum #as EN) + (bounded #as B) + (show #as S))) + +## [Structures] +## Number +(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>] + [(defstruct #export <name> (N;Number <type>) + (def (+ x y) (<+> x y)) + (def (- x y) (<-> x y)) + (def (* x y) (<*> x y)) + (def (/ x y) (</> x y)) + (def (% x y) (<%> x y)) + (def (from-int x) + (<from> x)) + (def (negate x) + (<*> <-1> x)) + (def (abs x) + (if (<<> x <0>) + (<*> <-1> x) + x)) + (def (signum x) + (cond (<=> x <0>) <0> + (<<> x <0>) <-1> + ## else + <1>)) + )] + + [ Int/Number Int _jvm_ladd _jvm_lsub _jvm_lmul _jvm_ldiv _jvm_lrem _jvm_leq _jvm_llt id 0 1 -1]) + +## Eq +(defstruct #export Int/Eq (E;Eq Int) + (def (= x y) (_jvm_leq x y))) + +## Ord +(do-template [<name> <type> <eq> <=> <lt> <gt>] + [(defstruct #export <name> (O;Ord <type>) + (def _eq <eq>) + (def (< x y) (<lt> x y)) + (def (<= x y) + (or (<lt> x y) + (<=> x y))) + (def (> x y) (<gt> x y)) + (def (>= x y) + (or (<gt> x y) + (<=> x y))))] + + [ Int/Ord Int Int/Eq _jvm_leq _jvm_llt _jvm_lgt]) + +## Enum +(defstruct #export Int/Enum (EN;Enum Int) + (def _ord Int/Ord) + (def succ (lambda [n] (:: Int/Number (+ n 1)))) + (def pred (lambda [n] (:: Int/Number (- n 1))))) + +## Bounded +(do-template [<name> <type> <top> <bottom>] + [(defstruct #export <name> (B;Bounded <type>) + (def top <top>) + (def bottom <bottom>))] + + [ Int/Bounded Int (_jvm_getstatic "java.lang.Long" "MAX_VALUE") (_jvm_getstatic "java.lang.Long" "MIN_VALUE")]) + +## Monoid +(do-template [<name> <type> <unit> <++>] + [(defstruct #export <name> (m;Monoid <type>) + (def unit <unit>) + (def (++ x y) (<++> x y)))] + + [ IntAdd/Monoid Int 0 _jvm_ladd] + [ IntMul/Monoid Int 1 _jvm_lmul] + [ IntMax/Monoid Int (:: Int/Bounded bottom) (O;max Int/Ord)] + [ IntMin/Monoid Int (:: Int/Bounded top) (O;min Int/Ord)] + ) + +## Show +(do-template [<name> <type> <body>] + [(defstruct #export <name> (S;Show <type>) + (def (show x) + <body>))] + + [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] + ) diff --git a/source/lux/data/number/real.lux b/source/lux/data/number/real.lux new file mode 100644 index 000000000..7d5243385 --- /dev/null +++ b/source/lux/data/number/real.lux @@ -0,0 +1,93 @@ +## 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/. + +(;import lux + (lux/control (number #as N) + (monoid #as m) + (eq #as E) + (ord #as O) + (enum #as EN) + (bounded #as B) + (show #as S))) + +## [Structures] +## Number +(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>] + [(defstruct #export <name> (N;Number <type>) + (def (+ x y) (<+> x y)) + (def (- x y) (<-> x y)) + (def (* x y) (<*> x y)) + (def (/ x y) (</> x y)) + (def (% x y) (<%> x y)) + (def (from-int x) + (<from> x)) + (def (negate x) + (<*> <-1> x)) + (def (abs x) + (if (<<> x <0>) + (<*> <-1> x) + x)) + (def (signum x) + (cond (<=> x <0>) <0> + (<<> x <0>) <-1> + ## else + <1>)) + )] + + [Real/Number Real _jvm_dadd _jvm_dsub _jvm_dmul _jvm_ddiv _jvm_drem _jvm_deq _jvm_dlt _jvm_l2d 0.0 1.0 -1.0]) + +## Eq +(defstruct #export Real/Eq (E;Eq Real) + (def (= x y) (_jvm_deq x y))) + +## Ord +(do-template [<name> <type> <eq> <=> <lt> <gt>] + [(defstruct #export <name> (O;Ord <type>) + (def _eq <eq>) + (def (< x y) (<lt> x y)) + (def (<= x y) + (or (<lt> x y) + (<=> x y))) + (def (> x y) (<gt> x y)) + (def (>= x y) + (or (<gt> x y) + (<=> x y))))] + + [Real/Ord Real Real/Eq _jvm_deq _jvm_dlt _jvm_dgt]) + +## Enum +(defstruct Real/Enum (EN;Enum Real) + (def _ord Real/Ord) + (def succ (lambda [n] (:: Real/Number (+ n 1.0)))) + (def pred (lambda [n] (:: Real/Number (- n 1.0))))) + +## Bounded +(do-template [<name> <type> <top> <bottom>] + [(defstruct #export <name> (B;Bounded <type>) + (def top <top>) + (def bottom <bottom>))] + + [Real/Bounded Real (_jvm_getstatic "java.lang.Double" "MAX_VALUE") (_jvm_getstatic "java.lang.Double" "MIN_VALUE")]) + +## Monoid +(do-template [<name> <type> <unit> <++>] + [(defstruct #export <name> (m;Monoid <type>) + (def unit <unit>) + (def (++ x y) (<++> x y)))] + + [RealAdd/Monoid Real 0.0 _jvm_dadd] + [RealMul/Monoid Real 1.0 _jvm_dmul] + [RealMax/Monoid Real (:: Real/Bounded bottom) (O;max Real/Ord)] + [RealMin/Monoid Real (:: Real/Bounded top) (O;min Real/Ord)] + ) + +## Show +(do-template [<name> <type> <body>] + [(defstruct #export <name> (S;Show <type>) + (def (show x) + <body>))] + + [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] + ) diff --git a/source/lux/data/reader.lux b/source/lux/data/reader.lux deleted file mode 100644 index e91687c3a..000000000 --- a/source/lux/data/reader.lux +++ /dev/null @@ -1,33 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import (lux #refer (#exclude Reader)) - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Reader r a) - (-> r a)) - -## [Structures] -(defstruct #export Reader/Functor (All [r] - (Functor (Reader r))) - (def (F;map f fa) - (lambda [env] - (f (fa env))))) - -(defstruct #export Reader/Monad (All [r] - (Monad (Reader r))) - (def M;_functor Reader/Functor) - - (def (M;wrap x) - (lambda [env] x)) - - (def (M;join mma) - (lambda [env] - (mma env env)))) diff --git a/source/lux/data/show.lux b/source/lux/data/show.lux deleted file mode 100644 index f4e1cf762..000000000 --- a/source/lux/data/show.lux +++ /dev/null @@ -1,14 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## Signatures -(defsig #export (Show a) - (: (-> a Text) - show)) diff --git a/source/lux/data/state.lux b/source/lux/data/state.lux deleted file mode 100644 index bc9858a29..000000000 --- a/source/lux/data/state.lux +++ /dev/null @@ -1,35 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (State s a) - (-> s (, s a))) - -## [Structures] -(defstruct #export State/Functor (Functor State) - (def (F;map f ma) - (lambda [state] - (let [[state' a] (ma state)] - [state' (f a)])))) - -(defstruct #export State/Monad (All [s] - (Monad (State s))) - (def M;_functor State/Functor) - - (def (M;wrap x) - (lambda [state] - [state x])) - - (def (M;join mma) - (lambda [state] - (let [[state' ma] (mma state)] - (ma state'))))) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index 6ad9cfd63..af2de51ff 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -1,16 +1,16 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux - (lux/control (monoid #as m)) - (lux/data (eq #as E) - (ord #as O) - (show #as S))) + (lux (control (monoid #as m) + (eq #as E) + (ord #as O) + (show #as S) + (monad #as M #refer #all)) + (data (number (int #open ("i" Int/Number Int/Ord))) + maybe))) ## [Functions] (def #export (size x) @@ -112,12 +112,12 @@ ## [Structures] (defstruct #export Text/Eq (E;Eq Text) - (def (E;= x y) + (def (= x y) (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] x [y]))) (defstruct #export Text/Ord (O;Ord Text) - (def O;_eq Text/Eq) + (def _eq Text/Eq) (do-template [<name> <op>] [(def (<name> x y) @@ -125,17 +125,71 @@ x [y])) 0))] - [O;< i<] - [O;<= i<=] - [O;> i>] - [O;>= i>=])) + [< i<] + [<= i<=] + [> i>] + [>= i>=])) (defstruct #export Text/Show (S;Show Text) - (def (S;show x) - x)) + (def show id)) (defstruct #export Text/Monoid (m;Monoid Text) - (def m;unit "") - (def (m;++ x y) + (def unit "") + (def (++ x y) (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] x [y]))) + +## [Syntax] +(def (extract-var template) + (-> Text (Maybe (, Text Text Text))) + (do Maybe/Monad + [pre-idx (index-of "#{" template) + [pre in] (split pre-idx template) + [_ in] (split 2 in) + post-idx (index-of "}" in) + [var post] (split post-idx in) + #let [[_ post] (? ["" ""] (split 1 post))]] + (wrap [pre var post]))) + +(do-template [<name> <type> <tag>] + [(def (<name> value) + (-> <type> AST) + [["" -1 -1] (<tag> value)])] + + [text$ Text #;TextS] + [symbol$ Ident #;SymbolS]) + +(def (unravel-template template) + (-> Text (List AST)) + (case (extract-var template) + (#;Some [pre var post]) + (#;Cons (text$ pre) + (#;Cons (symbol$ ["" var]) + (unravel-template post))) + + #;None + (#;Cons (text$ template) #;Nil))) + +(defmacro #export (<> tokens state) + (case tokens + (#;Cons [_ (#;TextS template)] #;Nil) + (let [++ (symbol$ ["" ""])] + (#;Right state (#;Cons (` (;let [(~ ++) (get@ #m;++ Text/Monoid)] + (;$ (~ ++) (~@ (unravel-template template))))) + #;Nil))) + + _ + (#;Left "Wrong syntax for <>"))) + +(def #export (split-lines text) + (-> Text (List Text)) + (case (: (Maybe (List Text)) + (do Maybe/Monad + [idx (index-of "\n" text) + [head post] (split (inc idx) text)] + (wrap (#;Cons head (split-lines post))))) + #;None + (#;Cons text #;Nil) + + (#;Some xs) + xs)) diff --git a/source/lux/data/tuple.lux b/source/lux/data/tuple.lux new file mode 100644 index 000000000..6eef74670 --- /dev/null +++ b/source/lux/data/tuple.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/. + +(;import lux) + +## [Functions] +(do-template [<name> <type> <output>] + [(def #export (<name> xy) + (All [a b] (-> (, a b) <type>)) + (let [[x y] xy] + <output>))] + + [first a x] + [second 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/source/lux/data/writer.lux b/source/lux/data/writer.lux index f71492e35..3bf99c1ad 100644 --- a/source/lux/data/writer.lux +++ b/source/lux/data/writer.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux (lux/control (monoid #as m #refer #all) @@ -18,17 +15,17 @@ ## [Structures] (defstruct #export Writer/Functor (All [l] (Functor (Writer l))) - (def (F;map f fa) + (def (map f fa) (let [[log datum] fa] [log (f datum)]))) (defstruct #export (Writer/Monad mon) (All [l] (-> (Monoid l) (Monad (Writer l)))) - (def M;_functor Writer/Functor) + (def _functor Writer/Functor) - (def (M;wrap x) - [(:: mon m;unit) x]) + (def (wrap x) + [(:: mon unit) x]) - (def (M;join mma) + (def (join mma) (let [[log1 [log2 a]] mma] - [(:: mon (m;++ log1 log2)) a]))) + [(:: mon (++ log1 log2)) a]))) diff --git a/source/lux/host/io.lux b/source/lux/host/io.lux new file mode 100644 index 000000000..220f089a2 --- /dev/null +++ b/source/lux/host/io.lux @@ -0,0 +1,60 @@ +## 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/. + +(;import lux + (lux (data (list #refer #all #open ("" List/Fold))) + (codata io) + (meta ast + syntax + lux) + control/monad) + (.. jvm)) + +## [Functions] +(do-template [<name> <method> <type> <class>] + [(def #export (<name> x) + (-> <type> (IO (,))) + (@io (_jvm_invokevirtual "java.io.PrintStream" <method> [<class>] + (_jvm_getstatic "java.lang.System" "out") [x])))] + + [write-char "print" Char "char"] + [write "print" Text "java.lang.String"] + [write-line "println" Text "java.lang.String"] + ) + +(do-template [<name> <type> <op>] + [(def #export <name> + (IO (Maybe <type>)) + (let [in (_jvm_getstatic "java.lang.System" "in") + reader (_jvm_new "java.io.InputStreamReader" ["java.io.InputStream"] [in]) + buff-reader (_jvm_new "java.io.BufferedReader" ["java.io.Reader"] [reader])] + (@io (let [output (: (Either Text <type>) (try <op>)) + _close (: (Either Text (,)) (try (_jvm_invokeinterface "java.io.Closeable" "close" [] buff-reader [])))] + (case [output _close] + (\or [(#;Left _) _] [_ (#;Left _)]) #;None + [(#;Right input) (#;Right _)] (#;Some input))))))] + + [read-char Char (_jvm_i2c (_jvm_invokevirtual "java.io.BufferedReader" "read" [] buff-reader []))] + [read-line Text (_jvm_invokevirtual "java.io.BufferedReader" "readLine" [] buff-reader [])] + ) + +## [Syntax] +(def simple-bindings^ + (Parser (List (, Text AST))) + (tuple^ (*^ (&^ local-symbol^ id^)))) + +(defsyntax #export (with-open [bindings simple-bindings^] body) + (do Lux/Monad + [g!output (gensym "output") + #let [code (foldL (: (-> AST (, Text AST) AST) + (lambda [body [res-name res-value]] + (let [g!res-name (symbol$ ["" res-name])] + (` (let [(~ g!res-name) (~ res-value) + (~ g!output) (~ body)] + (exec (;_jvm_invokeinterface "java.io.Closeable" "close" [] (~ g!res-name) []) + (~ g!output))))))) + body + (reverse bindings))]] + (wrap (@list code)))) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 7af043969..737c1731d 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -1,238 +1,377 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux (lux (control (monoid #as m) (functor #as F) - (monad #as M #refer (#only do))) - (data (list #as l #refer #all #open ("" List/Functor)) - (text #as text)) + (monad #as M #refer (#only do seq%)) + (enum #as E)) + (data (list #refer #all #open ("" List/Functor List/Fold)) + (number/int #refer #all #open ("i:" Int/Ord Int/Number)) + maybe + tuple + (text #open ("text:" Text/Monoid))) (meta lux - macro + ast syntax))) +(open List/Monad "list:") + +## [Types] +(defsyntax #export (Array [dimensions (?^ nat^)] type) + (emit (@list (foldL (lambda [inner _] (` (#;DataT "#Array" (@list (~ inner))))) + type + (repeat (? 1 dimensions) []))))) + ## [Utils] +## Types +(deftype StackFrame (^ java.lang.StackTraceElement)) +(deftype StackTrace (Array StackFrame)) + +(deftype Modifier Text) +(deftype JvmType Text) + +(deftype AnnotationParam + (, Text AST)) + +(deftype Annotation + (& #ann-name Text + #ann-params (List AnnotationParam))) + +(deftype MemberDecl + (& #member-name Text + #member-modifiers (List Modifier) + #member-anns (List Annotation))) + +(deftype FieldDecl + JvmType) + +(deftype MethodDecl + (& #method-inputs (List JvmType) + #method-output JvmType + #method-exs (List JvmType))) + +(deftype ArgDecl + (& #arg-name Text + #arg-type JvmType)) + +(deftype MethodDef + (& #method-vars (List ArgDecl) + #return-type JvmType + #return-body AST + #throws-exs (List JvmType))) + +(deftype ExpectedInput + (& #opt-input? Bool + #input-type JvmType)) + +(deftype ExpectedOutput + (& #ex-output? Bool + #opt-output? Bool + #output-type JvmType)) + +## Functions +(def (prepare-args args) + (-> (List ExpectedInput) (Lux (, (List AST) (List AST) (List AST) (List Text)))) + (do Lux/Monad + [vars (seq% Lux/Monad (repeat (size args) (gensym ""))) + #let [pairings (map (: (-> (, (, Bool Text) AST) (, AST (List AST))) + (lambda [[[opt? arg-class] var]] + (if opt? + [(` (Maybe (^ (~ (symbol$ ["" arg-class]))))) + (@list var (` (: (^ (~ (symbol$ ["" arg-class]))) + (case (~ var) + (#;Some (~ var)) (~ var) + #;None ;_jvm_null))))] + [(` (^ (~ (symbol$ ["" arg-class])))) + (@list)]))) + (zip2 args vars)) + var-types (map first pairings) + var-rebinds (map second pairings) + arg-classes (map second args)]] + (wrap [vars var-types (list:join var-rebinds) arg-classes]))) + +(def (class->type class) + (-> JvmType AST) + (case class + "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) + _ + (` (^ (~ (symbol$ ["" class])))))) + ## Parsers -(def finally^ - (Parser Syntax) - (form^ (do Parser/Monad - [_ (symbol?^ ["" "finally"]) - expr id^] - (M;wrap expr)))) - -(def catch^ - (Parser (, Text Ident Syntax)) - (form^ (do Parser/Monad - [_ (symbol?^ ["" "catch"]) - ex-class local-symbol^ - ex symbol^ - expr id^] - (M;wrap [ex-class ex expr])))) +(def annotation-params^ + (Parser (List AnnotationParam)) + (record^ (*^ (tuple^ (&^ local-tag^ id^))))) + +(def annotation^ + (Parser Annotation) + (form^ (&^ local-symbol^ + annotation-params^))) + +(def annotations^' + (Parser (List Annotation)) + (do Parser/Monad + [_ (tag!^ ["" "ann"])] + (tuple^ (*^ annotation^)))) + +(def annotations^ + (Parser (List Annotation)) + (do Parser/Monad + [anns?? (?^ annotations^')] + (wrap (? (@list) anns??)))) + +(def member-decl^ + (Parser MemberDecl) + (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + anns annotations^] + (wrap [name modifiers anns]))) + +(def throws-decl'^ + (Parser (List JvmType)) + (do Parser/Monad + [_ (tag!^ ["" "throws"])] + (tuple^ (*^ local-symbol^)))) + +(def throws-decl^ + (Parser (List JvmType)) + (do Parser/Monad + [exs? (?^ throws-decl'^)] + (wrap (? (@list) exs?)))) + +(def method-decl'^ + (Parser MethodDecl) + (do Parser/Monad + [inputs (tuple^ (*^ local-symbol^)) + outputs local-symbol^ + exs throws-decl^] + (wrap [inputs outputs exs]))) (def method-decl^ - (Parser (, (List Text) Text (List Text) Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - inputs (tuple^ (*^ local-symbol^)) - output local-symbol^] - (M;wrap [modifiers name inputs output])))) + (Parser (, MemberDecl MethodDecl)) + (form^ (&^ member-decl^ + method-decl'^))) (def field-decl^ - (Parser (, (List Text) Text Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - class local-symbol^] - (M;wrap [modifiers name class])))) + (Parser (, MemberDecl FieldDecl)) + (form^ (&^ member-decl^ + local-symbol^))) (def arg-decl^ - (Parser (, Text Text)) - (form^ (do Parser/Monad - [arg-name local-symbol^ - arg-class local-symbol^] - (M;wrap [arg-name arg-class])))) + (Parser ArgDecl) + (form^ (&^ local-symbol^ local-symbol^))) + +(def method-def'^ + (Parser MethodDef) + (do Parser/Monad + [inputs (tuple^ (*^ arg-decl^)) + output local-symbol^ + exs throws-decl^ + body id^] + (wrap [inputs output body exs]))) (def method-def^ - (Parser (, (List Text) Text (List (, Text Text)) Text Syntax)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - inputs (tuple^ (*^ arg-decl^)) - output local-symbol^ - body id^] - (M;wrap [modifiers name inputs output body])))) - -(def method-call^ - (Parser (, Text (List Text) (List Syntax))) - (form^ (do Parser/Monad - [method local-symbol^ - arity-classes (tuple^ (*^ local-symbol^)) - arity-args (tuple^ (*^ id^)) - _ (: (Parser (,)) - (if (i= (size arity-classes) - (size arity-args)) - (M;wrap []) - (lambda [_] #;None)))] - (M;wrap [method arity-classes arity-args]) - ))) + (Parser (, MemberDecl MethodDef)) + (form^ (&^ member-decl^ + method-def'^))) -## [Syntax] -(defsyntax #export (throw ex) - (emit (list (` (_jvm_throw (~ ex)))))) - -(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) - (emit (list (` (_jvm_try (~ body) - (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident Syntax) Syntax) - (lambda [catch] - (let [[class ex body] catch] - (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) - catches) - (case finally - #;None - (list) - - (#;Some finally) - (list (` (_jvm_finally (~ finally))))))))))))) - -(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) - (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) - members)] - (emit (list (` (_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] - (~@ members'))))))) +(def exp-input^ + (Parser ExpectedInput) + (&^ (tag?^ ["" "?"]) + local-symbol^)) + +(def exp-output^ + (Parser ExpectedOutput) + (do Parser/Monad + [ex? (tag?^ ["" "!"]) + opt? (tag?^ ["" "?"]) + return local-symbol^] + (wrap [ex? opt? return]))) + +## Generators +(def (gen-annotation-param [name value]) + (-> AnnotationParam (, AST AST)) + [(text$ name) value]) + +(def (gen-annotation [name params]) + (-> Annotation AST) + (` ((~ (text$ name)) + (~ (record$ (map gen-annotation-param params)))))) + +(def (gen-method-decl [[name modifiers anns] [inputs output exs]]) + (-> (, MemberDecl MethodDecl) AST) + (` ((~ (text$ name)) + [(~@ (map text$ modifiers))] + [(~@ (map gen-annotation anns))] + [(~@ (map text$ exs))] + [(~@ (map text$ inputs))] + (~ (text$ output))))) + +(def (gen-field-decl [[name modifiers anns] class]) + (-> (, MemberDecl FieldDecl) AST) + (` ((~ (text$ name)) + [(~@ (map text$ modifiers))] + [(~@ (map gen-annotation anns))] + (~ (text$ class)) + ))) + +(def (gen-arg-decl [name type]) + (-> ArgDecl AST) + (form$ (@list (symbol$ ["" name]) (text$ type)))) +(def (gen-method-def [[name modifiers anns] [inputs output body exs]]) + (-> (, MemberDecl MethodDef) AST) + (` ((~ (text$ name)) + [(~@ (map text$ modifiers))] + [(~@ (map gen-annotation anns))] + [(~@ (map text$ exs))] + [(~@ (map gen-arg-decl inputs))] + (~ (text$ output)) + (~ body)))) + +(def (gen-expected-output [ex? opt? output] body) + (-> ExpectedOutput AST (, AST AST)) + (let [type (class->type output) + [body type] (if opt? + [(` (;;??? (~ body))) + (` (Maybe (~ type)))] + [body type]) + [body type] (if ex? + [(` (;;try (~ body))) + (` (Either Text (~ type)))] + [body type])] + [body type])) + +## [Functions] +(def (stack-trace->text trace) + (-> StackTrace Text) + (let [size (_jvm_arraylength trace) + idxs (E;range Int/Enum 0 (i:+ -1 size))] + (|> idxs + (map (: (-> Int Text) + (lambda [idx] + (_jvm_invokevirtual "java.lang.Object" "toString" [] (_jvm_aaload trace idx) [])))) + (interpose "\n") + (foldL text:++ "") + ))) + +(def (get-stack-trace t) + (-> (^ java.lang.Throwable) StackTrace) + (_jvm_invokevirtual "java.lang.Throwable" "getStackTrace" [] t [])) + +(def #export (throwable->text t) + (-> (^ java.lang.Throwable) Text) + ($ text:++ + (_jvm_invokevirtual "java.lang.Object" "toString" [] t []) + "\n" + (|> t get-stack-trace stack-trace->text))) + +## [Syntax] (defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] + [annotations annotations^] [fields (*^ field-decl^)] [methods (*^ method-def^)]) + (emit (@list (` (;_jvm_class (~ (text$ name)) (~ (text$ super)) + [(~@ (map text$ interfaces))] + [(~@ (map gen-annotation annotations))] + [(~@ (map gen-field-decl fields))] + [(~@ (map gen-method-def methods))]))))) + +(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] + [annotations annotations^] + [members (*^ method-decl^)]) + (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] + [(~@ (map gen-annotation annotations))] + (~@ (map gen-method-decl members))))))) + +(defsyntax #export (object [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] + [methods (*^ method-def^)]) + (emit (@list (` (;_jvm_anon-class (~ (text$ super)) + [(~@ (map text$ interfaces))] + [(~@ (map gen-method-def methods))]))))) + +(defsyntax #export (program [args symbol^] body) + (emit (@list (` (;_jvm_program (~ (symbol$ args)) + (~ body)))))) + +(defsyntax #export (??? expr) (do Lux/Monad - [current-module get-module-name - #let [fields' (map (: (-> (, (List Text) Text Text) Syntax) - (lambda [field] - (let [[modifiers name class] field] - (` ((~ (text$ name)) - (~ (text$ class)) - [(~@ (map text$ modifiers))]))))) - fields) - methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) - (lambda [methods] - (let [[modifiers name inputs output body] methods] - (` ((~ (text$ name)) - [(~@ (map (: (-> (, Text Text) Syntax) - (lambda [in] - (let [[left right] in] - (form$ (list (symbol$ ["" left]) - (text$ right)))))) - inputs))] - (~ (text$ output)) - [(~@ (map text$ modifiers))] - (~ body)))))) - methods)]] - (emit (list (` (_jvm_class (~ (text$ name)) (~ (text$ super)) - [(~@ (map text$ interfaces))] - [(~@ fields')] - [(~@ methods')])))))) - -(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) - (emit (list (` (_jvm_new (~ (text$ class)) - [(~@ (map text$ arg-classes))] - [(~@ args)]))))) + [g!temp (gensym "")] + (wrap (@list (` (let [(~ g!temp) (~ expr)] + (if (;_jvm_null? (~ g!temp)) + #;None + (#;Some (~ g!temp))))))))) + +(defsyntax #export (try expr) + (emit (@list (` (;_jvm_try (#;Right (~ expr)) + (~ (' (_jvm_catch "java.lang.Exception" e + (#;Left (throwable->text e)))))))))) (defsyntax #export (instance? [class local-symbol^] obj) - (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj)))))) + (emit (@list (` (;_jvm_instanceof (~ (text$ class)) (~ obj)))))) (defsyntax #export (locking lock body) (do Lux/Monad [g!lock (gensym "") - g!body (gensym "")] - (emit (list (` (;let [(~ g!lock) (~ lock) - _ (_jvm_monitorenter (~ g!lock)) + g!body (gensym "") + g!_ (gensym "")] + (emit (@list (` (let [(~ g!lock) (~ lock) + (~ g!_) (;_jvm_monitorenter (~ g!lock)) (~ g!body) (~ body) - _ (_jvm_monitorexit (~ g!lock))] - (~ g!body))))) + (~ g!_) (;_jvm_monitorexit (~ g!lock))] + (~ g!body))))) )) (defsyntax #export (null? obj) - (emit (list (` (_jvm_null? (~ obj)))))) + (emit (@list (` (;_jvm_null? (~ obj)))))) -(defsyntax #export (program [args symbol^] body) - (emit (list (` (_jvm_program (~ (symbol$ args)) - (~ body)))))) - -(defsyntax #export (.? [field local-symbol^] obj) - (case obj - (#;Meta [_ (#;SymbolS obj-name)]) - (do Lux/Monad - [obj-type (find-var-type obj-name)] - (case obj-type - (#;DataT class) - (emit (list (` (_jvm_getfield (~ (text$ class)) (~ (text$ field)))))) - - _ - (fail "Can only get field from object."))) +(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ exp-input^))] [unsafe? (tag?^ ["" "unsafe"])]) + (do Lux/Monad + [[vars var-types var-rebinds arg-classes] (prepare-args args) + #let [new-expr (` (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)])) + return-type (class->type class) + [new-expr return-type] (if unsafe? + [(` (try (~ new-expr))) (` (Either Text (~ return-type)))] + [new-expr return-type])]] + (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type)) + (lambda [[(~@ vars)]] + (let [(~@ var-rebinds)] + (~ new-expr))))))))) - _ - (do Lux/Monad - [g!obj (gensym "")] - (emit (list (` (;let [(~ g!obj) (~ obj)] - (.? (~ (text$ field)) (~ g!obj))))))))) - -(defsyntax #export (.= [field local-symbol^] value obj) - (case obj - (#;Meta [_ (#;SymbolS obj-name)]) - (do Lux/Monad - [obj-type (find-var-type obj-name)] - (case obj-type - (#;DataT class) - (emit (list (` (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ value))))) - - _ - (fail "Can only set field of object."))) +(do-template [<name> <op> <use-self?>] + [(defsyntax #export (<name> [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))] + [expected-output exp-output^] [unsafe? (tag?^ ["" "unsafe"])]) + (do Lux/Monad + [[vars var-types var-rebinds arg-classes] (prepare-args args) + g!self (gensym "self") + #let [included-self (: (List AST) + (if <use-self?> + (@list g!self) + (@list))) + [body return-type] (gen-expected-output expected-output + (` (<op> (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~@ included-self) [(~@ vars)]))) + [body return-type] (if unsafe? + [(` (try (~ body))) (` (Either Text (~ return-type)))] + [body return-type])]] + (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))) (~ return-type)) + (lambda [[(~@ vars)] (~@ included-self)] + (let [(~@ var-rebinds)] + (~ body))))))) + ))] - _ - (do Lux/Monad - [g!obj (gensym "")] - (emit (list (` (;let [(~ g!obj) (~ obj)] - (.= (~ (text$ field)) (~ value) (~ g!obj))))))))) - -(defsyntax #export (.! [call method-call^] obj) - (let [[m-name ?m-classes m-args] call] - (case obj - (#;Meta [_ (#;SymbolS obj-name)]) - (do Lux/Monad - [obj-type (find-var-type obj-name)] - (case obj-type - (#;DataT class) - (emit (list (` (_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))] - (~ obj) [(~@ m-args)])))) - - _ - (fail "Can only call method on object."))) - - _ - (do Lux/Monad - [g!obj (gensym "")] - (emit (list (` (;let [(~ g!obj) (~ obj)] - (.! ((~ (symbol$ ["" m-name])) - [(~@ (map (lambda [c] (symbol$ ["" c])) ?m-classes))] - [(~@ m-args)]) - (~ g!obj)))))))))) - -(defsyntax #export (..? [field local-symbol^] [class local-symbol^]) - (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) - -(defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) - (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) - -(defsyntax #export (..! [call method-call^] [class local-symbol^]) - (let [[m-name m-classes m-args] call] - (emit (list (` (_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) - [(~@ (map text$ m-classes))] - [(~@ m-args)])))))) + [invoke-virtual$ ;_jvm_invokevirtual true] + [invoke-interface$ ;_jvm_invokeinterface true] + [invoke-special$ ;_jvm_invokespecial true] + [invoke-static$ ;_jvm_invokestatic false] + ) diff --git a/source/lux/math.lux b/source/lux/math.lux index a495d130c..a60ce512c 100644 --- a/source/lux/math.lux +++ b/source/lux/math.lux @@ -1,12 +1,10 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. -(;import lux) +(;import lux + (lux/data/number/int #open ("i:" Int/Number))) ## [Constants] (do-template [<name> <value>] @@ -61,3 +59,22 @@ [atan2 "atan2"] [pow "pow"] ) + +(def (gcd' a b) + (-> Int Int Int) + (case b + 0 a + _ (gcd' b (i:% a b)))) + +(def #export (gcd a b) + (-> Int Int Int) + (gcd' (i:abs a) (i:abs b))) + +(def #export (lcm x y) + (-> Int Int Int) + (case [x y] + (\or [_ 0] [0 _]) + 0 + + _ + (i:abs (i:* (i:/ x (gcd x y)) y)))) diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux new file mode 100644 index 000000000..a9bc8b588 --- /dev/null +++ b/source/lux/meta/ast.lux @@ -0,0 +1,113 @@ +## 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/. + +(;import lux + (lux (control (show #as S #refer #all) + (eq #as E #refer #all)) + (data bool + (number int + real) + char + (text #refer (#only Text/Show Text/Eq) #open ("text:" Text/Monoid)) + ident + (list #refer #all #open ("" List/Functor List/Fold)) + ))) + +## [Types] +## (deftype (AST' w) +## (| (#;BoolS Bool) +## (#;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))))))) + +## (deftype 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] + [int$ Int #;IntS] + [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] + ) + +## [Structures] +(defstruct #export AST/Show (Show AST) + (def (show ast) + (case ast + (\template [<tag> <struct>] + [[_ (<tag> value)] + (:: <struct> (show value))]) + [[#;BoolS Bool/Show] + [#;IntS Int/Show] + [#;RealS Real/Show] + [#;CharS Char/Show] + [#;TextS Text/Show]] + + (\template [<tag> <prefix>] + [[_ (<tag> ident)] + (text:++ <prefix> (:: Ident/Show (show ident)))]) + [[#;SymbolS ""] [#;TagS "#"]] + + (\template [<tag> <open> <close>] + [[_ (<tag> members)] + ($ text:++ <open> (|> members (map show) (interpose "") (foldL text:++ text:unit)) <close>)]) + [[#;FormS "(" ")"] [#;TupleS "[" "]"]] + + [_ (#;RecordS pairs)] + ($ text:++ "{" (|> pairs (map (lambda [[left right]] ($ text:++ (show left) " " (show right)))) (interpose "") (foldL text:++ text:unit)) "}") + ))) + +(defstruct #export AST/Eq (Eq AST) + (def (= x y) + (case [x y] + (\template [<tag> <struct>] + [[[_ (<tag> x')] [_ (<tag> y')]] + (:: <struct> (= x' y'))]) + [[#;BoolS Bool/Eq] + [#;IntS Int/Eq] + [#;RealS Real/Eq] + [#;CharS Char/Eq] + [#;TextS Text/Eq] + [#;SymbolS Ident/Eq] + [#;TagS Ident/Eq]] + + (\template [<tag>] + [[[_ (<tag> xs')] [_ (<tag> ys')]] + (and (:: Int/Eq (= (size xs') (size ys'))) + (foldL (lambda [old [x' y']] + (and old (= x' y'))) + true + (zip2 xs' ys')))]) + [[#;FormS] [#;TupleS]] + + [[_ (#;RecordS xs')] [_ (#;RecordS ys')]] + (and (:: Int/Eq (= (size xs') (size ys'))) + (foldL (lambda [old [[xl' xr'] [yl' yr']]] + (and old (= xl' yl') (= xr' yr'))) + true + (zip2 xs' ys'))) + + _ + false))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 19b7dd9df..b6ff09f59 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -1,21 +1,19 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux - (.. macro) + (.. ast) (lux/control (monoid #as m) (functor #as F) - (monad #as M #refer (#only do))) - (lux/data list - maybe - (show #as S) - (number #as N) - (text #as T #open ("text:" Text/Monoid Text/Eq)))) + (monad #as M #refer (#only do)) + (show #as S)) + (lux/data (list #refer #all #open ("list:" List/Monoid List/Functor)) + (text #as T #open ("text:" Text/Monoid Text/Eq)) + (number/int #as I #open ("i" Int/Number)) + (tuple #as t) + ident)) ## [Types] ## (deftype (Lux a) @@ -29,7 +27,7 @@ ## [Structures] (defstruct #export Lux/Functor (F;Functor Lux) - (def (F;map f fa) + (def (map f fa) (lambda [state] (case (fa state) (#;Left msg) @@ -39,11 +37,11 @@ (#;Right [state' (f a)]))))) (defstruct #export Lux/Monad (M;Monad Lux) - (def M;_functor Lux/Functor) - (def (M;wrap x) + (def _functor Lux/Functor) + (def (wrap x) (lambda [state] (#;Right [state x]))) - (def (M;join mma) + (def (join mma) (lambda [state] (case (mma state) (#;Left msg) @@ -69,7 +67,7 @@ #;Nil #;None - (#;Cons [[k' v] plist']) + (#;Cons [k' v] plist') (if (text:= k k') (#;Some v) (get k plist')))) @@ -77,20 +75,27 @@ (def (find-macro' modules current-module module name) (-> (List (, Text (Module Compiler))) Text Text Text (Maybe Macro)) - (do Maybe/Monad - [$module (get module modules) - gdef (|> (: (Module Compiler) $module) (get@ #;defs) (get name))] - (case (: (, Bool (DefData' Macro)) gdef) - [exported? (#;MacroD macro')] - (if (or exported? (text:= module current-module)) - (#;Some macro') + (case (get module modules) + (#;Some $module) + (case (|> (: (Module Compiler) $module) (get@ #;defs) (get name)) + (#;Some gdef) + (case (: Definition gdef) + [exported? (#;MacroD macro')] + (if (or exported? (text:= module current-module)) + (#;Some macro') + #;None) + + [_ (#;AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ #;None) - - [_ (#;AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) _ - #;None))) + #;None) + + _ + #;None)) (def #export (find-macro ident) (-> Ident (Lux (Maybe Macro))) @@ -107,15 +112,15 @@ ["" name] (do Lux/Monad [module-name get-module-name] - (M;wrap (: Ident [module-name name]))) + (wrap [module-name name])) _ - (:: Lux/Monad (M;wrap ident)))) + (:: Lux/Monad (wrap ident)))) (def #export (macro-expand syntax) - (-> Syntax (Lux (List Syntax))) + (-> AST (Lux (List AST))) (case syntax - (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) + [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -124,31 +129,51 @@ (do Lux/Monad [expansion (macro args) expansion' (M;map% Lux/Monad macro-expand expansion)] - (M;wrap (:: List/Monad (M;join expansion')))) + (wrap (:: List/Monad (join expansion')))) + + #;None + (:: Lux/Monad (wrap (@list syntax))))) + + _ + (:: Lux/Monad (wrap (@list syntax))))) + +(def #export (macro-expand-all syntax) + (-> AST (Lux (List AST))) + (case syntax + [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] + (do Lux/Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (do Lux/Monad + [expansion (macro args) + expansion' (M;map% Lux/Monad macro-expand-all expansion)] + (wrap (:: List/Monad (join expansion')))) #;None (do Lux/Monad - [parts' (M;map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] - (M;wrap (list (form$ (:: List/Monad (M;join parts')))))))) + [parts' (M;map% Lux/Monad macro-expand-all (@list& (symbol$ macro-name) args))] + (wrap (@list (form$ (:: List/Monad (join parts')))))))) - (#;Meta [_ (#;FormS (#;Cons [harg targs]))]) + [_ (#;FormS (#;Cons [harg targs]))] (do Lux/Monad - [harg+ (macro-expand harg) - targs+ (M;map% Lux/Monad macro-expand targs)] - (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+)))))))) + [harg+ (macro-expand-all harg) + targs+ (M;map% Lux/Monad macro-expand-all targs)] + (wrap (@list (form$ (list:++ harg+ (:: List/Monad (join (: (List (List AST)) targs+)))))))) - (#;Meta [_ (#;TupleS members)]) + [_ (#;TupleS members)] (do Lux/Monad - [members' (M;map% Lux/Monad macro-expand members)] - (M;wrap (list (tuple$ (:: List/Monad (M;join members')))))) + [members' (M;map% Lux/Monad macro-expand-all members)] + (wrap (@list (tuple$ (:: List/Monad (join members')))))) _ - (:: Lux/Monad (M;wrap (list syntax))))) + (:: Lux/Monad (wrap (@list syntax))))) (def #export (gensym prefix state) - (-> Text (Lux Syntax)) - (#;Right [(update@ #;seed inc state) - (symbol$ ["__gensym__" (:: N;Int/Show (S;show (get@ #;seed state)))])])) + (-> Text (Lux AST)) + (#;Right [(update@ #;seed (i+ 1) state) + (symbol$ ["" ($ text:++ "__gensym__" prefix (:: I;Int/Show (show (get@ #;seed state))))])])) (def #export (emit datum) (All [a] @@ -163,12 +188,12 @@ (#;Left msg))) (def #export (macro-expand-1 token) - (-> Syntax (Lux Syntax)) + (-> AST (Lux AST)) (do Lux/Monad [token+ (macro-expand token)] (case token+ - (\ (list token')) - (M;wrap token') + (\ (@list token')) + (wrap token') _ (fail "Macro expanded to more than 1 element.")))) @@ -187,34 +212,18 @@ (case (get module (get@ #;modules state)) (#;Some =module) (using List/Monad - (#;Right [state (join (:: _functor (F;map (: (-> (, Text (, Bool (DefData' Macro))) - (List Text)) - (lambda [gdef] - (let [[name [export? _]] gdef] - (if export? - (list name) - (list))))) - (get@ #;defs =module))))])) + (#;Right [state (join (map (: (-> (, Text Definition) + (List Text)) + (lambda [gdef] + (let [[name [export? _]] gdef] + (if export? + (@list name) + (@list))))) + (get@ #;defs =module)))])) #;None (#;Left ($ text:++ "Unknown module: " module)))) -(def (show-envs envs) - (-> (List (Env Text (, LuxVar Type))) Text) - (|> envs - (F;map (lambda [env] - (case env - {#;name name #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure _} - ($ text:++ name ": " (|> locals - (F;map (: (All [a] (-> (, Text a) Text)) - (lambda [b] (let [[label _] b] label)))) - (:: List/Functor) - (interpose " ") - (foldL text:++ text:unit)))))) - (:: List/Functor) - (interpose "\n") - (foldL text:++ text:unit))) - (def (try-both f x1 x2) (All [a b] (-> (-> a (Maybe b)) a a (Maybe b))) @@ -222,56 +231,71 @@ #;None (f x2) (#;Some y) (#;Some y))) -(def (find-in-env name state) - (-> Ident Compiler (Maybe Type)) - (let [vname' (ident->text name)] - (case state - {#;source source #;modules modules - #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} - (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) - (lambda [env] - (case env - {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}} - (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= vname' bname) - (#;Some type) - #;None))))) - locals - closure)))) - envs)))) - -(def (find-in-defs name state) - (-> Ident Compiler (Maybe Type)) +(def #export (find-in-env name state) + (-> Text Compiler (Maybe Type)) + (case state + {#;source source #;modules modules + #;envs envs #;type-vars types #;host host + #;seed seed #;eval? eval? #;expected expected + #;cursor cursor} + (some (: (-> (Env Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) + (lambda [env] + (case env + {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}} + (try-both (some (: (-> (, Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) + (lambda [binding] + (let [[bname [[type _] _]] binding] + (if (text:= name bname) + (#;Some type) + #;None))))) + locals + closure)))) + envs))) + +(def (find-in-defs' name state) + (-> Ident Compiler (Maybe Definition)) (let [[v-prefix v-name] name {#;source source #;modules modules - #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} state] + #;envs envs #;type-vars types #;host host + #;seed seed #;eval? eval? #;expected expected + #;cursor cursor} state] (case (get v-prefix modules) #;None #;None - (#;Some {#;defs defs #;module-aliases _ #;imports _}) + (#;Some {#;defs defs #;module-aliases _ #;imports _ #;tags _ #;types _}) (case (get v-name defs) #;None #;None - (#;Some [_ def-data]) - (case def-data - #;TypeD (#;Some Type) - (#;ValueD type) (#;Some type) - (#;MacroD m) (#;Some Macro) - (#;AliasD name') (find-in-defs name' state)))))) + (#;Some def) + (case def + [_ (#;AliasD name')] (find-in-defs' name' state) + _ (#;Some def) + ))) + )) + +(def #export (find-in-defs name state) + (-> Ident Compiler (Maybe Type)) + (case (find-in-defs' name state) + (#;Some [_ def-data]) + (case def-data + (#;ValueD [type value]) (#;Some type) + (#;MacroD _) (#;Some Macro) + (#;TypeD _) (#;Some Type) + _ #;None) + + #;None + #;None)) (def #export (find-var-type name) (-> Ident (Lux Type)) (do Lux/Monad - [name' (normalize name)] + [#let [[_ _name] name] + name' (normalize name)] (: (Lux Type) (lambda [state] - (case (find-in-env name state) + (case (find-in-env _name state) (#;Some struct-type) (#;Right [state struct-type]) @@ -281,8 +305,62 @@ (#;Right [state struct-type]) _ - (let [{#;source source #;modules modules - #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} state] - (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))) + (#;Left ($ text:++ "Unknown var: " (ident->text name))))))) )) + +(def #export (find-type name) + (-> Ident (Lux Type)) + (do Lux/Monad + [name' (normalize name)] + (: (Lux Type) + (lambda [state] + (case (find-in-defs' name' state) + (#;Some def-data) + (case def-data + [_ (#;TypeD type)] (#;Right [state type]) + _ (#;Left ($ text:++ "Definition is not a type: " (ident->text name)))) + + _ + (#;Left ($ text:++ "Unknown var: " (ident->text name)))))) + )) + +(def #export (defs module-name state) + (-> Text (Lux (List (, Text Definition)))) + (case (get module-name (get@ #;modules state)) + #;None (#;Left ($ text:++ "Unknown module: " module-name)) + (#;Some module) (#;Right [state (get@ #;defs module)]) + )) + +(def #export (exports module-name) + (-> Text (Lux (List (, Text Definition)))) + (do Lux/Monad + [defs (defs module-name)] + (wrap (filter (lambda [[name [exported? data]]] exported?) + defs)))) + +(def #export (modules state) + (Lux (List Text)) + (|> state + (get@ #;modules) + (list:map t;first) + (#;Right state))) + +(def #export (find-module name state) + (-> Text (Lux (Module Compiler))) + (case (get name (get@ #;modules state)) + (#;Some module) + (#;Right state module) + + _ + (#;Left ($ text:++ "Unknown module: " name)))) + +(def #export (tags-for [module name]) + (-> Ident (Lux (Maybe (List Ident)))) + (do Lux/Monad + [module (find-module module)] + (case (get name (get@ #;types module)) + (#;Some [tags _]) + (wrap (#;Some tags)) + + _ + (wrap #;None)))) diff --git a/source/lux/meta/macro.lux b/source/lux/meta/macro.lux deleted file mode 100644 index 22aeaf874..000000000 --- a/source/lux/meta/macro.lux +++ /dev/null @@ -1,54 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## [Utils] -(def (_meta x) - (-> (Syntax' (Meta Cursor)) Syntax) - (#;Meta [["" -1 -1] x])) - -## [Syntax] -(def #export (defmacro tokens state) - Macro - (case tokens - (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])]) - (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) - (~ (_meta (#;SymbolS ["lux" "Macro"]))) - (~ body))) - (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) - #;Nil])])]) - - (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])]) - (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) (~ (_meta (#;TagS ["" "export"]))) ((~ name) (~@ args)) - (~ (_meta (#;SymbolS ["lux" "Macro"]))) - (~ body))) - (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) - #;Nil])])]) - - _ - (#;Left "Wrong syntax for defmacro"))) -(_lux_declare-macro defmacro) - -## [Functions] -(do-template [<name> <type> <tag>] - [(def #export (<name> x) - (-> <type> Syntax) - (#;Meta [["" -1 -1] (<tag> x)]))] - - [bool$ Bool #;BoolS] - [int$ Int #;IntS] - [real$ Real #;RealS] - [char$ Char #;CharS] - [text$ Text #;TextS] - [symbol$ Ident #;SymbolS] - [tag$ Ident #;TagS] - [form$ (List Syntax) #;FormS] - [tuple$ (List Syntax) #;TupleS] - [record$ (List (, Syntax Syntax)) #;RecordS] - ) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 63ab81475..641dfba0d 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -1,21 +1,20 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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/. (;import lux - (.. (macro #as m #refer #all) + (.. ast (lux #as l #refer (#only Lux/Monad gensym))) (lux (control (functor #as F) - (monad #as M #refer (#only do))) - (data (eq #as E) - (bool #as b) + (monad #as M #refer (#only do)) + (eq #as E)) + (data (bool #as b) (char #as c) (text #as t #open ("text:" Text/Monoid Text/Eq)) - list))) + (list #refer #all #open ("" List/Functor List/Fold)) + (number (int #open ("i" Int/Ord)) + (real #open ("r" Real/Eq)))))) ## [Utils] (def (first xy) @@ -27,15 +26,19 @@ (All [a] (-> (List (, a a)) (List a))) (case pairs #;Nil #;Nil - (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs')))) + (#;Cons [[x y] pairs']) (@list& x y (join-pairs pairs')))) -## Types +(def (pair->tuple [left right]) + (-> (, AST AST) AST) + (tuple$ (@list left right))) + +## [Types] (deftype #export (Parser a) - (-> (List Syntax) (Maybe (, (List Syntax) a)))) + (-> (List AST) (Maybe (, (List AST) a)))) -## Structures +## [Structures] (defstruct #export Parser/Functor (F;Functor Parser) - (def (F;map f ma) + (def (map f ma) (lambda [tokens] (case (ma tokens) #;None @@ -45,12 +48,12 @@ (#;Some [tokens' (f a)]))))) (defstruct #export Parser/Monad (M;Monad Parser) - (def M;_functor Parser/Functor) + (def _functor Parser/Functor) - (def (M;wrap x tokens) + (def (wrap x tokens) (#;Some [tokens x])) - (def (M;join mma) + (def (join mma) (lambda [tokens] (case (mma tokens) #;None @@ -59,9 +62,9 @@ (#;Some [tokens' ma]) (ma tokens'))))) -## Parsers +## [Parsers] (def #export (id^ tokens) - (Parser Syntax) + (Parser AST) (case tokens #;Nil #;None (#;Cons [t tokens']) (#;Some [tokens' t]))) @@ -70,7 +73,7 @@ [(def #export (<name> tokens) (Parser <type>) (case tokens - (#;Cons [(#;Meta [_ (<tag> x)]) tokens']) + (#;Cons [[_ (<tag> x)] tokens']) (#;Some [tokens' x]) _ @@ -85,11 +88,24 @@ [ tag^ Ident #;TagS] ) +(def #export (assert v tokens) + (-> Bool (Parser (,))) + (if v + (#;Some [tokens []]) + #;None)) + +(def #export nat^ + (Parser Int) + (do Parser/Monad + [n int^ + _ (assert (i>= n 0))] + (wrap n))) + (do-template [<name> <tag>] [(def #export (<name> tokens) (Parser Text) (case tokens - (#;Cons [(#;Meta [_ (<tag> ["" x])]) tokens']) + (#;Cons [[_ (<tag> ["" x])] tokens']) (#;Some [tokens' x]) _ @@ -108,32 +124,51 @@ (do-template [<name> <type> <tag> <eq>] [(def #export (<name> v tokens) - (-> <type> (Parser (,))) + (-> <type> (Parser Bool)) (case tokens - (#;Cons [(#;Meta [_ (<tag> x)]) tokens']) - (if (<eq> v x) - (#;Some [tokens' []]) - #;None) + (#;Cons [[_ (<tag> x)] tokens']) + (#;Some [tokens' (<eq> v x)]) _ - #;None))] + (#;Some [tokens false])))] - [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)] + [ bool?^ Bool #;BoolS (:: b;Bool/Eq =)] [ int?^ Int #;IntS i=] [ real?^ Real #;RealS r=] - [ char?^ Char #;CharS (:: c;Char/Eq E;=)] - [ text?^ Text #;TextS (:: t;Text/Eq E;=)] + [ char?^ Char #;CharS (:: c;Char/Eq =)] + [ text?^ Text #;TextS (:: t;Text/Eq =)] [symbol?^ Ident #;SymbolS ident:=] [ tag?^ Ident #;TagS ident:=] ) +(do-template [<name> <type> <tag> <eq>] + [(def #export (<name> v tokens) + (-> <type> (Parser Unit)) + (case tokens + (#;Cons [[_ (<tag> x)] tokens']) + (if (<eq> v x) + (#;Some [tokens' []]) + #;None) + + _ + #;None))] + + [ bool!^ Bool #;BoolS (:: b;Bool/Eq =)] + [ int!^ Int #;IntS i=] + [ real!^ Real #;RealS r=] + [ char!^ Char #;CharS (:: c;Char/Eq =)] + [ text!^ Text #;TextS (:: t;Text/Eq =)] + [symbol!^ Ident #;SymbolS ident:=] + [ tag!^ Ident #;TagS ident:=] + ) + (do-template [<name> <tag>] [(def #export (<name> p tokens) (All [a] (-> (Parser a) (Parser a))) (case tokens - (#;Cons [(#;Meta [_ (<tag> form)]) tokens']) - (case (p form) + (#;Cons [[_ (<tag> members)] tokens']) + (case (p members) (#;Some [#;Nil x]) (#;Some [tokens' x]) _ #;None) @@ -144,6 +179,18 @@ [tuple^ #;TupleS] ) +(def #export (record^ p tokens) + (All [a] + (-> (Parser a) (Parser a))) + (case tokens + (#;Cons [[_ (#;RecordS pairs)] tokens']) + (case (p (map pair->tuple pairs)) + (#;Some [#;Nil x]) (#;Some [tokens' x]) + _ #;None) + + _ + #;None)) + (def #export (?^ p tokens) (All [a] (-> (Parser a) (Parser (Maybe a)))) @@ -153,17 +200,17 @@ (def (run-parser p tokens) (All [a] - (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) a)))) + (-> (Parser a) (List AST) (Maybe (, (List AST) a)))) (p tokens)) (def #export (*^ p tokens) (All [a] (-> (Parser a) (Parser (List a)))) (case (p tokens) - #;None (#;Some [tokens (list)]) + #;None (#;Some [tokens (@list)]) (#;Some [tokens' x]) (run-parser (do Parser/Monad [xs (*^ p)] - (M;wrap (list& x xs))) + (wrap (@list& x xs))) tokens'))) (def #export (+^ p) @@ -172,7 +219,7 @@ (do Parser/Monad [x p xs (*^ p)] - (M;wrap (list& x xs)))) + (wrap (@list& x xs)))) (def #export (&^ p1 p2) (All [a b] @@ -180,17 +227,18 @@ (do Parser/Monad [x1 p1 x2 p2] - (M;wrap [x1 x2]))) + (wrap [x1 x2]))) (def #export (|^ p1 p2 tokens) (All [a b] - (-> (Parser a) (Parser b) (Parser (Either b)))) + (-> (Parser a) (Parser b) (Parser (Either a b)))) (case (p1 tokens) (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) #;None (run-parser (do Parser/Monad [x2 p2] - (M;wrap (#;Right x2))) - tokens))) + (wrap (#;Right x2))) + tokens) + )) (def #export (||^ ps tokens) (All [a] @@ -208,55 +256,51 @@ #;Nil (#;Some [tokens []]) _ #;None)) -## Syntax +## [Syntax] (defmacro #export (defsyntax tokens) - (let [[exported? tokens] (: (, Bool (List Syntax)) - (case tokens - (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) - [true tokens'] + (let [[exported? tokens] (case tokens + (\ (@list& [_ (#;TagS ["" "export"])] tokens')) + [true tokens'] - _ - [false tokens]))] + _ + [false tokens])] (case tokens - (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) - body)) + (\ (@list [_ (#;FormS (@list& [_ (#;SymbolS ["" name])] args))] + body)) (do Lux/Monad - [names+parsers (M;map% Lux/Monad - (: (-> Syntax (Lux (, Syntax Syntax))) - (lambda [arg] - (case arg - (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) - parser))])) - (M;wrap [(symbol$ var-name) parser]) - - (\ (#;Meta [_ (#;SymbolS var-name)])) - (M;wrap [(symbol$ var-name) (` id^)]) - - _ - (l;fail "Syntax pattern expects 2-tuples or symbols.")))) - args) + [vars+parsers (M;map% Lux/Monad + (: (-> AST (Lux (, AST AST))) + (lambda [arg] + (case arg + (\ [_ (#;TupleS (@list var parser))]) + (wrap [var parser]) + + (\ [_ (#;SymbolS var-name)]) + (wrap [(symbol$ var-name) (` id^)]) + + _ + (l;fail "Syntax pattern expects 2-tuples or symbols.")))) + args) g!tokens (gensym "tokens") g!_ (gensym "_") - #let [names (:: List/Functor (F;map first names+parsers)) - error-msg (text$ (text:++ "Wrong syntax for " name)) - body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + #let [error-msg (text$ (text:++ "Wrong syntax for " name)) + body' (foldL (: (-> AST (, AST AST) AST) (lambda [body name+parser] (let [[name parser] name+parser] - (` (_lux_case ((~ parser) (~ g!tokens)) - (#;Some [(~ g!tokens) (~ name)]) - (~ body) + (` (;_lux_case ((~ parser) (~ g!tokens)) + (#;Some [(~ g!tokens) (~ name)]) + (~ body) - (~ g!_) - (l;fail (~ error-msg))))))) + (~ g!_) + (l;fail (~ error-msg))))))) body - (: (List (, Syntax Syntax)) (list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers)))) - macro-def (: Syntax - (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) - (~ body'))))]] - (M;wrap (list& macro-def - (if exported? - (list (` (_lux_export (~ (symbol$ ["" name]))))) - (list))))) + (: (List (, AST AST)) (@list& [(symbol$ ["" ""]) (` end^)] (reverse vars+parsers)))) + macro-def (` (defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) + (~ body')))]] + (wrap (@list& macro-def + (if exported? + (@list (` (;_lux_export (~ (symbol$ ["" name]))))) + (@list))))) _ (l;fail "Wrong syntax for defsyntax")))) diff --git a/source/lux/meta/type.lux b/source/lux/meta/type.lux new file mode 100644 index 000000000..0938d104d --- /dev/null +++ b/source/lux/meta/type.lux @@ -0,0 +1,193 @@ +## 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/. + +(;import lux + (lux (control show + eq + monad) + (data (char #as c) + (text #as t #open ("text:" Text/Monoid Text/Eq)) + (number/int #open ("int:" Int/Number Int/Ord Int/Show)) + maybe + (list #refer #all #open ("list:" List/Monad List/Monoid List/Fold))) + )) + +(open List/Fold) + +## [Utils] +(def (unravel-fun type) + (-> Type (, Type (List Type))) + (case type + (#;LambdaT in out') + (let [[out ins] (unravel-fun out')] + [out (@list& in ins)]) + + _ + [type (@list)])) + +(def (unravel-app type) + (-> Type (, Type (List Type))) + (case type + (#;AppT left' right) + (let [[left rights] (unravel-app left')] + [left (list:++ rights (@list right))]) + + _ + [type (@list)])) + +## [Structures] +(defstruct #export Type/Show (Show Type) + (def (show type) + (case type + (#;DataT name params) + (case params + #;Nil + ($ text:++ "(^ " name ")") + + _ + ($ text:++ "(^ " name " " (|> params (list:map show) (interpose " ") (list:foldL text:++ "")) ")")) + + (#;TupleT members) + (case members + #;Nil + "(,)" + + _ + ($ text:++ "(, " (|> members (list:map show) (interpose " ") (foldL text:++ "")) ")")) + + (#;VariantT members) + (case members + #;Nil + "(|)" + + _ + ($ text:++ "(| " (|> members (list:map show) (interpose " ") (foldL text:++ "")) ")")) + + (#;LambdaT input output) + (let [[out ins] (unravel-fun type)] + ($ text:++ "(-> " (|> ins (list:map show) (interpose " ") (foldL text:++ "")) " " (show out) ")")) + + (#;VarT id) + ($ text:++ "⌈" (int:show id) "⌋") + + (#;BoundT idx) + (int:show idx) + + (#;ExT id) + ($ text:++ "⟨" (int:show id) "⟩") + + (#;AppT fun param) + (let [[type-fun type-args] (unravel-app type)] + ($ text:++ "(" (show type-fun) " " (|> type-args (list:map show) (interpose " ") (foldL text:++ "")) ")")) + + (#;UnivQ env body) + ($ text:++ "(All " (show body) ")") + + (#;ExQ env body) + ($ text:++ "(Ex " (show body) ")") + + (#;NamedT [module name] type) + ($ text:++ module ";" name) + ))) + +(defstruct #export Type/Eq (Eq Type) + (def (= x y) + (case [x y] + [(#;DataT xname xparams) (#;DataT yname yparams)] + (and (text:= xname yname) + (int:= (size xparams) (size yparams)) + (foldL (lambda [prev [x y]] + (and prev (= x y))) + true + (zip2 xparams yparams))) + + (\or [(#;VarT xid) (#;VarT yid)] + [(#;ExT xid) (#;ExT yid)] + [(#;BoundT xid) (#;BoundT yid)]) + (int:= xid yid) + + (\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)) + + (\or [(#;TupleT xmembers) (#;TupleT ymembers)] + [(#;VariantT xmembers) (#;VariantT ymembers)]) + (and (int:= (size xmembers) (size ymembers)) + (foldL (lambda [prev [x y]] + (and prev (= x y))) + true + (zip2 xmembers ymembers))) + + (\or [(#;UnivQ xenv xbody) (#;UnivQ yenv ybody)] + [(#;ExQ xenv xbody) (#;ExQ yenv ybody)]) + (and (int:= (size xenv) (size yenv)) + (foldL (lambda [prev [x y]] + (and prev (= x y))) + (= xbody ybody) + (zip2 xenv yenv))) + + _ + false + ))) + +## [Functions] +(def #export (beta-reduce env type) + (-> (List Type) Type Type) + (case type + (\template [<tag>] + [(<tag> members) + (<tag> (list:map (beta-reduce env) members))]) + [[#;VariantT] + [#;TupleT]] + + (\template [<tag>] + [(<tag> left right) + (<tag> (beta-reduce env left) (beta-reduce env right))]) + [[#;LambdaT] + [#;AppT]] + + (\template [<tag>] + [(<tag> env def) + (case env + #;Nil + (<tag> env def) + + _ + type)]) + [[#;UnivQ] + [#;ExQ]] + + (#;BoundT idx) + (? type (@ idx env)) + + (#;NamedT name type) + (beta-reduce env type) + + _ + type + )) + +(def #export (apply-type type-fun param) + (-> Type Type (Maybe Type)) + (case type-fun + (#;UnivQ env body) + (#;Some (beta-reduce (@list& type-fun param env) body)) + + (#;AppT F A) + (do Maybe/Monad + [type-fn* (apply-type F A)] + (apply-type type-fn* param)) + + (#;NamedT name type) + (apply-type type param) + + _ + #;None)) diff --git a/source/program.lux b/source/program.lux deleted file mode 100644 index 086506725..000000000 --- a/source/program.lux +++ /dev/null @@ -1,48 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux (codata (stream #as S)) - (control monoid - functor - monad - lazy - comonad) - (data bool - bounded - char - ## cont - dict - (either #as e) - eq - error - id - io - list - maybe - number - ord - (reader #as r) - show - state - (text #as t #open ("text:" Text/Monoid)) - writer) - (host jvm) - (meta lux - macro - syntax) - (math #as m) - )) - -(program args - (case args - (\ (list name)) - (println ($ text:++ "Hello, " name "!")) - - _ - (println "Hello, world!"))) diff --git a/src/lux.clj b/src/lux.clj index 7e3627cd7..4b1c15ef7 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -1,24 +1,33 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux (:gen-class) - (:require [lux.base :as &] + (:require [lux.base :as & :refer [|let |do return fail return* fail* |case]] + [lux.compiler.base :as &compiler-base] [lux.compiler :as &compiler] - :reload-all)) + [lux.packager.lib :as &lib] + :reload-all) + (:import (java.io File))) -(defn -main [& [program-module & _]] - (if program-module - (time (&compiler/compile-program program-module)) - (println "Please provide a module name to compile.")) +(defn -main [& args] + (|case (&/->list args) + (&/$Cons "compile" (&/$Cons program-module (&/$Nil))) + (if program-module + (time (&compiler/compile-program program-module)) + (println "Please provide a module name to compile.")) + + (&/$Cons "lib" (&/$Cons lib-module (&/$Nil))) + (&lib/package lib-module (new File &compiler-base/input-dir)) + + _ + (println "Can't understand command.")) (System/exit 0) ) (comment - (-main "program") + (-main "compile" "program") + (-main "lib" "lux") ) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index de7fc8497..70a4a6ee9 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -1,490 +1,652 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser (:require (clojure [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail return* fail*]] + (lux [base :as & :refer [|let |do return fail return* fail* |case]] [reader :as &reader] [parser :as &parser] [type :as &type] [host :as &host]) (lux.analyser [base :as &&] [lux :as &&lux] - [host :as &&host]))) + [host :as &&host] + [module :as &&module]))) ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] - (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_catch"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?ex-class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?ex-arg]]]] - ["lux;Cons" [?catch-body - ["lux;Nil" _]]]]]]]]]]]]] - (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+) - - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_finally"]]]] - ["lux;Cons" [?finally-body - ["lux;Nil" _]]]]]]]]] - (&/T catch+ (&/V "lux;Some" ?finally-body)))) - -(defn ^:private aba7 [analyse eval! compile-module exo-type token] - (matchv ::M/objects [token] + (|case token + [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_catch")] + (&/$Cons [_ (&/$TextS ?ex-class)] + (&/$Cons [_ (&/$SymbolS "" ?ex-arg)] + (&/$Cons ?catch-body + (&/$Nil))))))] + (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) + + [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_finally")] + (&/$Cons ?finally-body + (&/$Nil))))] + (return (&/T catch+ (&/V &/$Some ?finally-body))) + + _ + (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) + +(defn ^:private parse-tag [ast] + (|case ast + [_ (&/$TagS "" name)] + (return name) + + _ + (fail (str "[Analyser Error] Not a tag: " (&/show-ast ast))))) + +(defn ^:private extract-text [ast] + (|case ast + [_ (&/$TextS text)] + (return text) + + _ + (fail (str "[Analyser Error] Can't extract text: " (&/show-ast ast))))) + +(defn analyse-variant+ [analyser exo-type ident values] + (|do [[module tag-name] (&/normalize ident) + idx (&&module/tag-index module tag-name)] + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if (or ? (&&/type-tag? module tag-name)) + (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) + (|do [wanted-type (&&module/tag-type module tag-name) + [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (&&lux/analyse-variant analyser (&/V &/$Left wanted-type) idx values)) + _ (&type/check exo-type variant-type)] + (return (&/|list (&&/|meta exo-type variant-cursor variant-analysis)))))) + + _ + (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) + ))) + +(defn ^:private aba10 [analyse eval! compile-module compile-token exo-type token] + (|case token + ;; Arrays + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons ?length (&/$Nil)))) + (&&host/analyse-jvm-znewarray analyse exo-type ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-zastore analyse exo-type ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) + (&&host/analyse-jvm-zaload analyse exo-type ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) + (&&host/analyse-jvm-bnewarray analyse exo-type ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-bastore analyse exo-type ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_baload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) + (&&host/analyse-jvm-baload analyse exo-type ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_snewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) + (&&host/analyse-jvm-snewarray analyse exo-type ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_sastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-sastore analyse exo-type ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_saload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) + (&&host/analyse-jvm-saload analyse exo-type ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_inewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) + (&&host/analyse-jvm-inewarray analyse exo-type ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-iastore analyse exo-type ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) + (&&host/analyse-jvm-iaload analyse exo-type ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) + (&&host/analyse-jvm-lnewarray analyse exo-type ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-lastore analyse exo-type ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_laload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) + (&&host/analyse-jvm-laload analyse exo-type ?array ?idx) + + _ + (assert false (str "Unknown syntax: " (prn-str (&/show-ast (&/T (&/T "" -1 -1) token))))))) + +(defn ^:private aba9 [analyse eval! compile-module compile-token exo-type token] + (|case token ;; Arrays - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?length]]] - ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-new-array analyse ?class ?length) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aastore"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] - ["lux;Cons" [?elem - ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aaload"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] - ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-aaload analyse ?array ?idx) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) + (&&host/analyse-jvm-fnewarray analyse exo-type ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-fastore analyse exo-type ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_faload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) + (&&host/analyse-jvm-faload analyse exo-type ?array ?idx) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) + (&&host/analyse-jvm-dnewarray analyse exo-type ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-dastore analyse exo-type ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_daload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) + (&&host/analyse-jvm-daload analyse exo-type ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) + (&&host/analyse-jvm-cnewarray analyse exo-type ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_castore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-castore analyse exo-type ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_caload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) + (&&host/analyse-jvm-caload analyse exo-type ?array ?idx) + + _ + (aba10 analyse eval! compile-module compile-token exo-type token))) + +(defn ^:private aba8 [analyse eval! compile-module compile-token exo-type token] + (|case token + ;; Arrays + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?length (&/$Nil))))) + (&&host/analyse-jvm-anewarray analyse exo-type ?class ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-aastore analyse exo-type ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) + (&&host/analyse-jvm-aaload analyse exo-type ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_arraylength")] (&/$Cons ?array (&/$Nil)))) + (&&host/analyse-jvm-arraylength analyse exo-type ?array) + + _ + (aba9 analyse eval! compile-module compile-token exo-type token))) + +(defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] + (|case token ;; Classes & interfaces - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_class"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?super-class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?interfaces]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?methods]]] - ["lux;Nil" _]]]]]]]]]]]]]]] - (&&host/analyse-jvm-class analyse ?name ?super-class ?interfaces ?fields ?methods) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?supers]]] - ?methods]]]]]]]] - (&&host/analyse-jvm-interface analyse ?name ?supers ?methods) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] + (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TextS ?super-class)] + (&/$Cons [_ (&/$TupleS ?interfaces)] + (&/$Cons [_ (&/$TupleS ?anns)] + (&/$Cons [_ (&/$TupleS ?fields)] + (&/$Cons [_ (&/$TupleS ?methods)] + (&/$Nil))))))))) + (|do [=interfaces (&/map% extract-text ?interfaces)] + (&&host/analyse-jvm-class analyse compile-token ?name ?super-class =interfaces ?anns ?fields ?methods)) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] + (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TupleS ?supers)] + (&/$Cons [_ (&/$TupleS ?anns)] + ?methods))))) + (|do [=supers (&/map% extract-text ?supers)] + (&&host/analyse-jvm-interface analyse compile-token ?name =supers ?anns ?methods)) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anon-class")] + (&/$Cons [_ (&/$TextS ?super-class)] + (&/$Cons [_ (&/$TupleS ?interfaces)] + (&/$Cons [_ (&/$TupleS ?methods)] + (&/$Nil)))))) + (|do [=interfaces (&/map% extract-text ?interfaces)] + (&&host/analyse-jvm-anon-class analyse compile-token exo-type ?super-class =interfaces ?methods)) ;; Programs - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]] - ["lux;Cons" [?body - ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-program analyse ?args ?body) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] + (&/$Cons [_ (&/$SymbolS "" ?args)] + (&/$Cons ?body + (&/$Nil))))) + (&&host/analyse-jvm-program analyse compile-token ?args ?body) - [_] - (fail ""))) + _ + (aba8 analyse eval! compile-module compile-token exo-type token))) + +(defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] + (|case token + ;; Bitwise operators + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-iand analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-ior analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) -(defn ^:private aba6 [analyse eval! compile-module exo-type token] - (matchv ::M/objects [token] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-land analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-lor analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) + + _ + (aba7 analyse eval! compile-module compile-token exo-type token))) + +(defn ^:private aba5_5 [analyse eval! compile-module compile-token exo-type token] + (|case token ;; Primitive conversions - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2f analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2i analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2l analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2d analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2i analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2l analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2b")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2b analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2c")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2c analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2d analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2f analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2l analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2s")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2s analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2d analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2f analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2i analyse exo-type ?value) - ;; Bitwise operators - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-land analyse exo-type ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) + _ + (aba6 analyse eval! compile-module compile-token exo-type token))) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) - - [_] - (aba7 analyse eval! compile-module exo-type token))) - -(defn ^:private aba5 [analyse eval! compile-module exo-type token] - (matchv ::M/objects [token] +(defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] + (|case token ;; Objects - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_null?"]]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_null?")] + (&/$Cons ?object + (&/$Nil)))) (&&host/analyse-jvm-null? analyse exo-type ?object) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_instanceof"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_instanceof")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons ?object + (&/$Nil))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?args)] + (&/$Nil)))))) + (|do [=classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-new analyse exo-type ?class =classes ?args)) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getstatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] + (&/$Nil))))) (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getfield")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] + (&/$Cons ?object + (&/$Nil)))))) (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putstatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] + (&/$Cons ?value + (&/$Nil)))))) (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Cons" [?object - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]]]] - (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokestatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]] - (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokevirtual"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]] - (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokeinterface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]] - (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokespecial"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]] - (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putfield")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] + (&/$Cons ?value + (&/$Cons ?object + (&/$Nil))))))) + (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?value ?object) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?args)] + (&/$Nil))))))) + (|do [=classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method =classes ?args)) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons ?object + (&/$Cons [_ (&/$TupleS ?args)] + (&/$Nil)))))))) + (|do [=classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method =classes ?object ?args)) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons ?object + (&/$Cons [_ (&/$TupleS ?args)] + (&/$Nil)))))))) + (|do [=classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method =classes ?object ?args)) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons ?object + (&/$Cons [_ (&/$TupleS ?args)] + (&/$Nil)))))))) + (|do [=classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method =classes ?object ?args)) ;; Exceptions - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_try"]]]] - ["lux;Cons" [?body - ?handlers]]]]]] - (&&host/analyse-jvm-try analyse exo-type ?body (&/fold parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers)) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_throw"]]]] - ["lux;Cons" [?ex - ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] + (&/$Cons ?body + ?handlers))) + (|do [catches+finally (&/fold% parse-handler (&/T &/Nil$ &/None$) ?handlers)] + (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_throw")] + (&/$Cons ?ex + (&/$Nil)))) (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorenter"]]]] - ["lux;Cons" [?monitor - ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorenter")] + (&/$Cons ?monitor + (&/$Nil)))) (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorexit"]]]] - ["lux;Cons" [?monitor - ["lux;Nil" _]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorexit")] + (&/$Cons ?monitor + (&/$Nil)))) (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) - [_] - (aba6 analyse eval! compile-module exo-type token))) + _ + (aba5_5 analyse eval! compile-module compile-token exo-type token))) -(defn ^:private aba4 [analyse eval! compile-module exo-type token] - (matchv ::M/objects [token] +(defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] + (|case token ;; Float arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fdiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_frem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_feq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_flt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ddiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_drem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_deq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dlt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) + + _ + (aba5 analyse eval! compile-module compile-token exo-type token))) - [_] - (aba5 analyse eval! compile-module exo-type token))) - -(defn ^:private aba3 [analyse eval! compile-module exo-type token] - (matchv ::M/objects [token] +(defn ^:private aba3 [analyse eval! compile-module compile-token exo-type token] + (|case token ;; Host special forms ;; Characters - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ceq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ceq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_clt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_clt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_cgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_isub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_imul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_idiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_irem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ieq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ilt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_igt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ladd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ldiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lrem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_leq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_llt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) - [_] - (aba4 analyse eval! compile-module exo-type token))) + _ + (aba4 analyse eval! compile-module compile-token exo-type token))) -(defn ^:private aba2 [analyse eval! compile-module exo-type token] - (matchv ::M/objects [token] - [["lux;SymbolS" ?ident]] +(defn ^:private aba2 [analyse eval! compile-module compile-token exo-type token] + (|case token + (&/$SymbolS ?ident) (&&lux/analyse-symbol analyse exo-type ?ident) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_case"]]]] - ["lux;Cons" [?value ?branches]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_case")] + (&/$Cons ?value ?branches))) (&&lux/analyse-case analyse exo-type ?value ?branches) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?self]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?arg]]] - ["lux;Cons" [?body - ["lux;Nil" _]]]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_lambda")] + (&/$Cons [_ (&/$SymbolS "" ?self)] + (&/$Cons [_ (&/$SymbolS "" ?arg)] + (&/$Cons ?body + (&/$Nil)))))) (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_def"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-def analyse ?name ?value) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_def")] + (&/$Cons [_ (&/$SymbolS "" ?name)] + (&/$Cons ?value + (&/$Nil))))) + (&&lux/analyse-def analyse compile-token ?name ?value) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-macro")] + (&/$Cons [_ (&/$SymbolS "" ?name)] + (&/$Nil)))) + (&&lux/analyse-declare-macro analyse compile-token ?name) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-tags")] + (&/$Cons [_ (&/$TupleS tags)] + (&/$Cons [_ (&/$SymbolS "" type-name)] + (&/$Nil))))) + (|do [tags* (&/map% parse-tag tags)] + (&&lux/analyse-declare-tags tags* type-name)) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] - ["lux;Nil" _]]]]]]] - (&&lux/analyse-declare-macro analyse ?name) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] - ["lux;Nil" _]]]]]]] - (&&lux/analyse-import analyse compile-module ?path) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")] + (&/$Cons [_ (&/$TextS ?path)] + (&/$Nil)))) + (&&lux/analyse-import analyse compile-module compile-token ?path) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:")] + (&/$Cons ?type + (&/$Cons ?value + (&/$Nil))))) (&&lux/analyse-check analyse eval! exo-type ?type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:!"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]] + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:!")] + (&/$Cons ?type + (&/$Cons ?value + (&/$Nil))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] - ["lux;Nil" _]]]]]]] - (&&lux/analyse-export analyse ?ident) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_export")] + (&/$Cons [_ (&/$SymbolS "" ?ident)] + (&/$Nil)))) + (&&lux/analyse-export analyse compile-token ?ident) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]] - ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-alias analyse ?alias ?module) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_alias")] + (&/$Cons [_ (&/$TextS ?alias)] + (&/$Cons [_ (&/$TextS ?module)] + (&/$Nil))))) + (&&lux/analyse-alias analyse compile-token ?alias ?module) - [_] - (aba3 analyse eval! compile-module exo-type token))) - -(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list))))] - (defn ^:private aba1 [analyse eval! compile-module exo-type token] - (matchv ::M/objects [token] - ;; Standard special forms - [["lux;BoolS" ?value]] - (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) - - [["lux;IntS" ?value]] - (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/T (&/V "int" ?value) exo-type)))) - - [["lux;RealS" ?value]] - (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/T (&/V "real" ?value) exo-type)))) - - [["lux;CharS" ?value]] - (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/T (&/V "char" ?value) exo-type)))) - - [["lux;TextS" ?value]] - (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/T (&/V "text" ?value) exo-type)))) - - [["lux;TupleS" ?elems]] - (&&lux/analyse-tuple analyse exo-type ?elems) - - [["lux;RecordS" ?elems]] - (&&lux/analyse-record analyse exo-type ?elems) - - [["lux;TagS" ?ident]] - (&&lux/analyse-variant analyse exo-type ?ident unit) - - [["lux;SymbolS" [_ "_jvm_null"]]] - (&&host/analyse-jvm-null analyse exo-type) - - [_] - (aba2 analyse eval! compile-module exo-type token) - ))) + _ + (aba3 analyse eval! compile-module compile-token exo-type token))) + +(defn ^:private aba1 [analyse eval! compile-module compile-token exo-type token] + (|case token + ;; Standard special forms + (&/$BoolS ?value) + (|do [_ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$bool ?value))))) + + (&/$IntS ?value) + (|do [_ (&type/check exo-type &type/Int) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$int ?value))))) + + (&/$RealS ?value) + (|do [_ (&type/check exo-type &type/Real) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$real ?value))))) + + (&/$CharS ?value) + (|do [_ (&type/check exo-type &type/Char) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$char ?value))))) + + (&/$TextS ?value) + (|do [_ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$text ?value))))) + + (&/$TupleS ?elems) + (&&lux/analyse-tuple analyse (&/V &/$Right exo-type) ?elems) + + (&/$RecordS ?elems) + (&&lux/analyse-record analyse exo-type ?elems) + + (&/$TagS ?ident) + (analyse-variant+ analyse exo-type ?ident &/Nil$) + + (&/$SymbolS _ "_jvm_null") + (&&host/analyse-jvm-null analyse exo-type) + + _ + (aba2 analyse eval! compile-module compile-token exo-type token) + )) (defn ^:private add-loc [meta ^String msg] (if (.startsWith msg "@") @@ -492,63 +654,74 @@ (|let [[file line col] meta] (str "@ " file "," line "," col "\n" msg)))) -(defn ^:private analyse-basic-ast [analyse eval! compile-module exo-type token] +(defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) - (matchv ::M/objects [token] - [["lux;Meta" [meta ?token]]] + (|case token + [meta ?token] (fn [state] - (matchv ::M/objects [((aba1 analyse eval! compile-module exo-type ?token) state)] - [["lux;Right" [state* output]]] + (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + (catch Error e + (prn 'analyse-basic-ast/Error-1 e) + (prn 'analyse-basic-ast/Error-2 (&/show-ast token)) + (prn 'analyse-basic-ast/Error-3 (&type/show-type exo-type)) + (|case ((&type/deref+ exo-type) state) + (&/$Right [_state _exo-type]) + (prn 'analyse-basic-ast/Error-4 (&type/show-type _exo-type)) + + _ + (prn 'analyse-basic-ast/Error-4 'YOLO)) + (throw e)) + ) + (&/$Right state* output) (return* state* output) - [["lux;Left" ""]] - (fail* (add-loc meta (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) + (&/$Left "") + (fail* (add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) - [["lux;Left" msg]] - (fail* (add-loc meta msg)) + (&/$Left msg) + (fail* (add-loc (&/get$ &/$cursor state) msg)) )) - - ;; [_] - ;; (assert false (aget token 0)) )) -(defn ^:private just-analyse [analyse-ast eval! compile-module syntax] +(defn ^:private just-analyse [analyser syntax] (&type/with-var (fn [?var] - (|do [[?output-term ?output-type] (&&/analyse-1 (partial analyse-ast eval! compile-module) ?var syntax)] - (matchv ::M/objects [?var ?output-type] - [["lux;VarT" ?e-id] ["lux;VarT" ?a-id]] + (|do [[[?output-type ?output-cursor] ?output-term] (&&/analyse-1 analyser ?var syntax)] + (|case [?var ?output-type] + [(&/$VarT ?e-id) (&/$VarT ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] - (return (&/T ?output-term ?output-type*))) - (return (&/T ?output-term ?output-type))) + (return (&&/|meta ?output-type* ?output-cursor ?output-term))) + (return (&&/|meta ?output-type ?output-cursor ?output-term))) [_ _] - (return (&/T ?output-term ?output-type))) + (return (&&/|meta ?output-type ?output-cursor ?output-term))) )))) -(defn ^:private analyse-ast [eval! compile-module exo-type token] - (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] - (do (assert (.equals ^Object (&/|length ?values) 1) "[Analyser Error] Can only tag 1 value.") - (&&lux/analyse-variant (partial analyse-ast eval! compile-module) exo-type ?ident (&/|head ?values))) - - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] - (fn [state] - (matchv ::M/objects [((just-analyse analyse-ast eval! compile-module ?fn) state) - ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) - ] - [["lux;Right" [state* =fn]]] - (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type meta =fn ?args) state*)) - - [_] - ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state))) - - [_] - (analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token))) +(defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] + (|let [[cursor _] token] + (&/with-cursor cursor + (&/with-expected-type exo-type + (|case token + [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) (&/V &/$Right exo-type) idx ?values) + + [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] + (analyse-variant+ (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) + + [meta (&/$FormS (&/$Cons ?fn ?args))] + (fn [state] + (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) + (&/$Right state* =fn) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*) + + _ + ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) + + _ + (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token)))))) ;; [Resources] -(defn analyse [eval! compile-module] +(defn analyse [eval! compile-module compile-token] (|do [asts &parser/parse] - (&/flat-map% (partial analyse-ast eval! compile-module &type/$Void) asts))) + (&/flat-map% (partial analyse-ast eval! compile-module compile-token &type/$Void) asts))) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 9fc3f1030..664ba4450 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -1,35 +1,193 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.base - (:require [clojure.core.match :as M :refer [match matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail]] + (lux [base :as & :refer [deftags |let |do return fail |case]] [type :as &type]))) +;; [Tags] +(deftags + ["bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + + "jvm-znewarray" + "jvm-zastore" + "jvm-zaload" + "jvm-bnewarray" + "jvm-bastore" + "jvm-baload" + "jvm-snewarray" + "jvm-sastore" + "jvm-saload" + "jvm-inewarray" + "jvm-iastore" + "jvm-iaload" + "jvm-lnewarray" + "jvm-lastore" + "jvm-laload" + "jvm-fnewarray" + "jvm-fastore" + "jvm-faload" + "jvm-dnewarray" + "jvm-dastore" + "jvm-daload" + "jvm-cnewarray" + "jvm-castore" + "jvm-caload" + "jvm-anewarray" + "jvm-aastore" + "jvm-aaload" + "jvm-arraylength" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr"]) + ;; [Exports] -(defn expr-type [syntax+] - (matchv ::M/objects [syntax+] - [[_ type]] - (return type))) +(defn expr-type* [syntax+] + (|let [[[type _] _] syntax+] + type)) -(defn analyse-1 [analyse exo-type elem] - (|do [output (analyse exo-type elem)] - (matchv ::M/objects [output] - [["lux;Cons" [x ["lux;Nil" _]]]] +(def jvm-this "_jvm_this") + +(defn cap-1 [action] + (|do [result action] + (|case result + (&/$Cons x (&/$Nil)) (return x) - [_] + _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) +(defn analyse-1 [analyse exo-type elem] + (cap-1 (analyse exo-type elem))) + +(defn analyse-1+ [analyse ?token] + (&type/with-var + (fn [$var] + (|do [=expr (analyse-1 analyse $var ?token) + :let [[[?type ?cursor] ?item] =expr] + =type (&type/clean $var ?type)] + (return (&/T (&/T =type ?cursor) ?item)))))) + (defn resolved-ident [ident] - (|let [[?module ?name] ident] - (|do [module* (if (.equals "" ?module) - &/get-module-name - (return ?module))] - (return (&/ident->text (&/T module* ?name)))))) + (|do [:let [[?module ?name] ident] + module* (if (.equals "" ?module) + &/get-module-name + (return ?module))] + (return (&/T module* ?name)))) + +(let [tag-names #{"DataT" "VariantT" "TupleT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}] + (defn type-tag? [module name] + (and (= "lux" module) + (contains? tag-names name)))) + +(defn |meta [type cursor analysis] + (&/T (&/T type cursor) analysis)) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index ebbb6911a..ca4e0edeb 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -1,386 +1,363 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.case - (:require [clojure.core.match :as M :refer [match matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return fail |let]] + (lux [base :as & :refer [deftags |do return fail |let |case]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] - [env :as &env]))) + [env :as &env] + [module :as &module] + [record :as &&record]))) + +;; [Tags] +(deftags + ["DefaultTotal" + "BoolTotal" + "IntTotal" + "RealTotal" + "CharTotal" + "TextTotal" + "TupleTotal" + "VariantTotal"] + ) + +(deftags + ["StoreTestAC" + "BoolTestAC" + "IntTestAC" + "RealTestAC" + "CharTestAC" + "TextTestAC" + "TupleTestAC" + "VariantTestAC"] + ) ;; [Utils] +(def ^:private unit + (&/T (&/T "" -1 -1) (&/V &/$TupleS &/Nil$))) + (defn ^:private resolve-type [type] - (matchv ::M/objects [type] - [["lux;VarT" ?id]] + (|case type + (&/$VarT ?id) (|do [type* (&/try-all% (&/|list (&type/deref ?id) (fail "##9##")))] (resolve-type type*)) - [["lux;AllT" [_aenv _aname _aarg _abody]]] - ;; (&type/actual-type _abody) + (&/$UnivQ _) (|do [$var &type/existential =type (&type/apply-type type $var)] (&type/actual-type =type)) - ;; (&type/with-var - ;; (fn [$var] - ;; (|do [=type (&type/apply-type type $var)] - ;; (&type/actual-type =type)))) - [_] + _ (&type/actual-type type))) +(defn update-up-frame [frame] + (|let [[_env _idx _var] frame] + (&/T _env (+ 2 _idx) _var))) + (defn adjust-type* [up type] - "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" - (matchv ::M/objects [type] - [["lux;AllT" [_aenv _aname _aarg _abody]]] + "(-> (List (, (Maybe (List Type)) Int Type)) Type (Lux Type))" + (|case type + (&/$UnivQ _aenv _abody) (&type/with-var (fn [$var] (|do [=type (&type/apply-type type $var)] - (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) - - [["lux;TupleT" ?members]] - (|do [["lux;TupleT" ?members*] (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] - (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V "lux;TupleT" (&/|map (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) - v - up)) - ?members*)))) - - [["lux;RecordT" ?fields]] - (|do [["lux;RecordT" ?fields*] (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] - (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V "lux;RecordT" (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) - v - up)))) - ?fields*)))) - - [["lux;VariantT" ?cases]] - (|do [["lux;VariantT" ?cases*] (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] - (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V "lux;VariantT" (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) - v - up)))) - ?cases*)))) - - [["lux;AppT" [?tfun ?targ]]] + (adjust-type* (&/Cons$ (&/T _aenv 1 $var) (&/|map update-up-frame up)) =type)))) + + (&/$TupleT ?members) + (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aidx (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&type/Tuple$ (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aidx _avar] ena] + (&/V &/$UnivQ (&/T _aenv _abody)))) + v + up)) + ?members*)))) + + (&/$VariantT ?members) + (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aidx (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V &/$VariantT (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aidx _avar] ena] + (&/V &/$UnivQ (&/T _aenv _abody)))) + v + up)) + ?members*)))) + + (&/$AppT ?tfun ?targ) (|do [=type (&type/apply-type ?tfun ?targ)] (adjust-type* up =type)) - [["lux;VarT" ?id]] + (&/$VarT ?id) (|do [type* (&/try-all% (&/|list (&type/deref ?id) (fail "##9##")))] (adjust-type* up type*)) - ;; [_] - ;; (assert false (aget type 0)) + (&/$NamedT ?name ?type) + (adjust-type* up ?type) + + _ + (assert false (prn-str 'adjust-type* (&type/show-type type))) )) (defn adjust-type [type] "(-> Type (Lux Type))" - (adjust-type* (&/|list) type)) + (adjust-type* &/Nil$ type)) (defn ^:private analyse-pattern [value-type pattern kont] - (matchv ::M/objects [pattern] - [["lux;Meta" [_ pattern*]]] - (matchv ::M/objects [pattern*] - [["lux;SymbolS" ?ident]] - (|do [=kont (&env/with-local (&/ident->text ?ident) value-type + (|let [[meta pattern*] pattern] + (|case pattern* + (&/$SymbolS "" name) + (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] - (return (&/T (&/V "StoreTestAC" idx) =kont))) + (return (&/T (&/V $StoreTestAC idx) =kont))) + + (&/$SymbolS ident) + (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) - [["lux;BoolS" ?value]] + (&/$BoolS ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] - (return (&/T (&/V "BoolTestAC" ?value) =kont))) + (return (&/T (&/V $BoolTestAC ?value) =kont))) - [["lux;IntS" ?value]] + (&/$IntS ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] - (return (&/T (&/V "IntTestAC" ?value) =kont))) + (return (&/T (&/V $IntTestAC ?value) =kont))) - [["lux;RealS" ?value]] + (&/$RealS ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] - (return (&/T (&/V "RealTestAC" ?value) =kont))) + (return (&/T (&/V $RealTestAC ?value) =kont))) - [["lux;CharS" ?value]] + (&/$CharS ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] - (return (&/T (&/V "CharTestAC" ?value) =kont))) + (return (&/T (&/V $CharTestAC ?value) =kont))) - [["lux;TextS" ?value]] + (&/$TextS ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] - (return (&/T (&/V "TextTestAC" ?value) =kont))) + (return (&/T (&/V $TextTestAC ?value) =kont))) - [["lux;TupleS" ?members]] + (&/$TupleS ?members) (|do [value-type* (adjust-type value-type)] - (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) - (matchv ::M/objects [value-type*] - [["lux;TupleT" ?member-types]] - (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) - (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) - (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* vm] - (|let [[v m] vm] - (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/|cons =test =tests) =kont))))) - (|do [=kont kont] - (return (&/T (&/|list) =kont))) - (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V "TupleTestAC" =tests) =kont))))) - - [_] - (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) - - [["lux;RecordS" ?slots]] - (|do [;; :let [_ (prn 'PRE (&type/show-type value-type))] - value-type* (adjust-type value-type) - ;; :let [_ (prn 'POST (&type/show-type value-type*))] - ;; value-type* (resolve-type value-type) - ] - (matchv ::M/objects [value-type*] - [["lux;RecordT" ?slot-types]] - (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) - (fail (str "[Analyser Error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* slot] - (|let [[sn sv] slot] - (matchv ::M/objects [sn] - [["lux;Meta" [_ ["lux;TagS" ?ident]]]] - (|do [=tag (&&/resolved-ident ?ident)] - (if-let [=slot-type (&/|get =tag ?slot-types)] - (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] - (return (&/T (&/|put =tag =test =tests) =kont))) - (fail (str "[Pattern-matching Error] Record-type lacks slot: " =tag)))) - - [_] - (fail (str "[Pattern-matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) + (|case value-type* + (&/$TupleT ?member-types) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/Cons$ =test =tests) =kont))))) (|do [=kont kont] - (return (&/T (&/|table) =kont))) - (&/|reverse ?slots))] - (return (&/T (&/V "RecordTestAC" =tests) =kont)))) - - [_] - (fail "[Pattern-matching Error] Record requires record-type."))) - - [["lux;TagS" ?ident]] - (|do [=tag (&&/resolved-ident ?ident) + (return (&/T &/Nil$ =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V $TupleTestAC =tests) =kont)))) + + _ + (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*))))) + + (&/$RecordS pairs) + (|do [[rec-members rec-type] (&&record/order-record pairs)] + (analyse-pattern value-type (&/T meta (&/V &/$TupleS rec-members)) kont)) + + (&/$TagS ?ident) + (|do [[=module =name] (&&/resolved-ident ?ident) value-type* (adjust-type value-type) - case-type (&type/variant-case =tag value-type*) - [=test =kont] (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1) - (&/V "lux;TupleS" (&/|list)))) - kont)] - (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]] - (|do [=tag (&&/resolved-ident ?ident) + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + case-type (&type/variant-case idx value-type*) + [=test =kont] (analyse-pattern case-type unit kont)] + (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) + + (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] + ?values)) + (|do [[=module =name] (&&/resolved-ident ?ident) value-type* (adjust-type value-type) - case-type (&type/variant-case =tag value-type*) - [=test =kont] (analyse-pattern case-type ?value - kont)] - (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + case-type (&type/variant-case idx value-type*) + [=test =kont] (case (int (&/|length ?values)) + 0 (analyse-pattern case-type unit kont) + 1 (analyse-pattern case-type (&/|head ?values) kont) + ;; 1+ + (analyse-pattern case-type (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values)) kont))] + (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) + + _ + (fail (str "[Pattern-matching Error] Unrecognized pattern syntax: " (&/show-ast pattern))) ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] (|do [pattern+body (analyse-pattern value-type pattern (&&/analyse-1 analyse exo-type body))] - (return (&/|cons pattern+body patterns)))) + (return (&/Cons$ pattern+body patterns)))) (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private merge-total [struct test+body] (|let [[test ?body] test+body] - (matchv ::M/objects [struct test] - [["DefaultTotal" total?] ["StoreTestAC" ?idx]] - (return (&/V "DefaultTotal" true)) + (|case [struct test] + [($DefaultTotal total?) ($StoreTestAC ?idx)] + (return (&/V $DefaultTotal true)) - [[?tag [total? ?values]] ["StoreTestAC" ?idx]] + [[?tag [total? ?values]] ($StoreTestAC ?idx)] (return (&/V ?tag (&/T true ?values))) - [["DefaultTotal" total?] ["BoolTestAC" ?value]] - (return (&/V "BoolTotal" (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($BoolTestAC ?value)] + (return (&/V $BoolTotal (&/T total? (&/|list ?value)))) - [["BoolTotal" [total? ?values]] ["BoolTestAC" ?value]] - (return (&/V "BoolTotal" (&/T total? (&/|cons ?value ?values)))) + [($BoolTotal total? ?values) ($BoolTestAC ?value)] + (return (&/V $BoolTotal (&/T total? (&/Cons$ ?value ?values)))) - [["DefaultTotal" total?] ["IntTestAC" ?value]] - (return (&/V "IntTotal" (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($IntTestAC ?value)] + (return (&/V $IntTotal (&/T total? (&/|list ?value)))) - [["IntTotal" [total? ?values]] ["IntTestAC" ?value]] - (return (&/V "IntTotal" (&/T total? (&/|cons ?value ?values)))) + [($IntTotal total? ?values) ($IntTestAC ?value)] + (return (&/V $IntTotal (&/T total? (&/Cons$ ?value ?values)))) - [["DefaultTotal" total?] ["RealTestAC" ?value]] - (return (&/V "RealTotal" (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($RealTestAC ?value)] + (return (&/V $RealTotal (&/T total? (&/|list ?value)))) - [["RealTotal" [total? ?values]] ["RealTestAC" ?value]] - (return (&/V "RealTotal" (&/T total? (&/|cons ?value ?values)))) + [($RealTotal total? ?values) ($RealTestAC ?value)] + (return (&/V $RealTotal (&/T total? (&/Cons$ ?value ?values)))) - [["DefaultTotal" total?] ["CharTestAC" ?value]] - (return (&/V "CharTotal" (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($CharTestAC ?value)] + (return (&/V $CharTotal (&/T total? (&/|list ?value)))) - [["CharTotal" [total? ?values]] ["CharTestAC" ?value]] - (return (&/V "CharTotal" (&/T total? (&/|cons ?value ?values)))) + [($CharTotal total? ?values) ($CharTestAC ?value)] + (return (&/V $CharTotal (&/T total? (&/Cons$ ?value ?values)))) - [["DefaultTotal" total?] ["TextTestAC" ?value]] - (return (&/V "TextTotal" (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($TextTestAC ?value)] + (return (&/V $TextTotal (&/T total? (&/|list ?value)))) - [["TextTotal" [total? ?values]] ["TextTestAC" ?value]] - (return (&/V "TextTotal" (&/T total? (&/|cons ?value ?values)))) + [($TextTotal total? ?values) ($TextTestAC ?value)] + (return (&/V $TextTotal (&/T total? (&/Cons$ ?value ?values)))) - [["DefaultTotal" total?] ["TupleTestAC" ?tests]] + [($DefaultTotal total?) ($TupleTestAC ?tests)] (|do [structs (&/map% (fn [t] - (merge-total (&/V "DefaultTotal" total?) (&/T t ?body))) + (merge-total (&/V $DefaultTotal total?) (&/T t ?body))) ?tests)] - (return (&/V "TupleTotal" (&/T total? structs)))) + (return (&/V $TupleTotal (&/T total? structs)))) - [["TupleTotal" [total? ?values]] ["TupleTestAC" ?tests]] + [($TupleTotal total? ?values) ($TupleTestAC ?tests)] (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [v t] (merge-total v (&/T t ?body))) ?values ?tests)] - (return (&/V "TupleTotal" (&/T total? structs)))) + (return (&/V $TupleTotal (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent tuple-size.")) - [["DefaultTotal" total?] ["RecordTestAC" ?tests]] - (|do [structs (&/map% (fn [t] - (|let [[slot value] t] - (|do [struct* (merge-total (&/V "DefaultTotal" total?) (&/T value ?body))] - (return (&/T slot struct*))))) - (->> ?tests - &/->seq - (sort compare-kv) - &/->list))] - (return (&/V "RecordTotal" (&/T total? structs)))) - - [["RecordTotal" [total? ?values]] ["RecordTestAC" ?tests]] - (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) - (|do [structs (&/map2% (fn [left right] - (|let [[lslot sub-struct] left - [rslot value]right] - (if (.equals ^Object lslot rslot) - (|do [sub-struct* (merge-total sub-struct (&/T value ?body))] - (return (&/T lslot sub-struct*))) - (fail "[Pattern-matching Error] Record slots mismatch.")))) - ?values - (->> ?tests - &/->seq - (sort compare-kv) - &/->list))] - (return (&/V "RecordTotal" (&/T total? structs)))) - (fail "[Pattern-matching Error] Inconsistent record-size.")) - - [["DefaultTotal" total?] ["VariantTestAC" [?tag ?test]]] - (|do [sub-struct (merge-total (&/V "DefaultTotal" total?) - (&/T ?test ?body))] - (return (&/V "VariantTotal" (&/T total? (&/|put ?tag sub-struct (&/|table)))))) - - [["VariantTotal" [total? ?branches]] ["VariantTestAC" [?tag ?test]]] - (|do [sub-struct (merge-total (or (&/|get ?tag ?branches) - (&/V "DefaultTotal" total?)) - (&/T ?test ?body))] - (return (&/V "VariantTotal" (&/T total? (&/|put ?tag sub-struct ?branches))))) + [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total (&/V $DefaultTotal total?) + (&/T ?test ?body)) + structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/V $DefaultTotal total?))) + (&/$Some list) + (return list) + + (&/$None) + (fail "[Pattern-matching Error] YOLO"))] + (return (&/V $VariantTotal (&/T total? structs)))) + + [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) + (&/$Some sub) + sub + + (&/$None) + (&/V $DefaultTotal total?)) + (&/T ?test ?body)) + structs (|case (&/|list-put ?tag sub-struct ?branches) + (&/$Some list) + (return list) + + (&/$None) + (fail "[Pattern-matching Error] YOLO"))] + (return (&/V $VariantTotal (&/T total? structs)))) )))) -(defn ^:private check-totality [value-type struct] - (matchv ::M/objects [struct] - [["BoolTotal" [?total ?values]]] - (return (or ?total - (= #{true false} (set (&/->seq ?values))))) - - [["IntTotal" [?total _]]] - (return ?total) - - [["RealTotal" [?total _]]] - (return ?total) - - [["CharTotal" [?total _]]] - (return ?total) +(defn check-totality+ [check-totality] + (fn [?token] + (&type/with-var + (fn [$var] + (|do [=output (check-totality $var ?token) + ?type (&type/deref+ $var) + =type (&type/clean $var ?type)] + (return (&/T =output =type))))))) - [["TextTotal" [?total _]]] +(defn ^:private check-totality [value-type struct] + (|case struct + ($DefaultTotal ?total) (return ?total) - [["TupleTotal" [?total ?structs]]] - (if ?total - (return true) - (|do [value-type* (resolve-type value-type)] - (matchv ::M/objects [value-type*] - [["lux;TupleT" ?members]] - (|do [totals (&/map2% (fn [sub-struct ?member] - (check-totality ?member sub-struct)) - ?structs ?members)] - (return (&/fold #(and %1 %2) true totals))) - - [_] - (fail "[Pattern-maching Error] Tuple is not total.")))) - - [["RecordTotal" [?total ?structs]]] - (if ?total - (return true) - (|do [value-type* (resolve-type value-type)] - (matchv ::M/objects [value-type*] - [["lux;RecordT" ?fields]] - (|do [totals (&/map% (fn [field] - (|let [[?tk ?tv] field] - (if-let [sub-struct (&/|get ?tk ?structs)] - (check-totality ?tv sub-struct) - (return false)))) - ?fields)] - (return (&/fold #(and %1 %2) true totals))) - - [_] - (fail "[Pattern-maching Error] Record is not total.")))) - - [["VariantTotal" [?total ?structs]]] + ($BoolTotal ?total ?values) + (|do [_ (&type/check value-type &type/Bool)] + (return (or ?total + (= #{true false} (set (&/->seq ?values)))))) + + ($IntTotal ?total _) + (|do [_ (&type/check value-type &type/Int)] + (return ?total)) + + ($RealTotal ?total _) + (|do [_ (&type/check value-type &type/Real)] + (return ?total)) + + ($CharTotal ?total _) + (|do [_ (&type/check value-type &type/Char)] + (return ?total)) + + ($TextTotal ?total _) + (|do [_ (&type/check value-type &type/Text)] + (return ?total)) + + ($TupleTotal ?total ?structs) + (|do [unknown? (&type/unknown? value-type)] + (if unknown? + (|do [=structs (&/map% (check-totality+ check-totality) ?structs) + _ (&type/check value-type (&/V &/$TupleT (&/|map &/|second =structs)))] + (return (or ?total + (&/fold #(and %1 %2) true (&/|map &/|first =structs))))) + (if ?total + (return true) + (|do [value-type* (resolve-type value-type)] + (|case value-type* + (&/$TupleT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) + + _ + (fail "[Pattern-maching Error] Tuple is not total.")))))) + + ($VariantTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (matchv ::M/objects [value-type*] - [["lux;VariantT" ?cases]] - (|do [totals (&/map% (fn [case] - (|let [[?tk ?tv] case] - (if-let [sub-struct (&/|get ?tk ?structs)] - (check-totality ?tv sub-struct) - (return false)))) - ?cases)] + (|case value-type* + (&/$VariantT ?members) + (|do [totals (&/map2% check-totality ?members ?structs)] (return (&/fold #(and %1 %2) true totals))) - [_] + _ (fail "[Pattern-maching Error] Variant is not total.")))) - - [["DefaultTotal" ?total]] - (return ?total) )) ;; [Exports] @@ -388,9 +365,9 @@ (|do [patterns (&/fold% (fn [patterns branch] (|let [[pattern body] branch] (analyse-branch analyse exo-type value-type pattern body patterns))) - (&/|list) + &/Nil$ branches) - struct (&/fold% merge-total (&/V "DefaultTotal" false) patterns) + struct (&/fold% merge-total (&/V $DefaultTotal false) patterns) ? (check-totality value-type struct)] (if ? (return patterns) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index cac0f8cd4..81397a3f6 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -1,49 +1,45 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.env - (:require [clojure.core.match :as M :refer [matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return return* fail]]) + (lux [base :as & :refer [|do return return* fail |case]]) [lux.analyser.base :as &&])) ;; [Exports] (def next-local-idx (fn [state] - (return* state (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$COUNTER))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) (defn with-local [name type body] - ;; (prn 'with-local name) (fn [state] - (let [old-mappings (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS)) - =return (body (&/update$ &/$ENVS + (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) + =return (body (&/update$ &/$envs (fn [stack] - (let [bound-unit (&/V "lux;Local" (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))] - (&/|cons (&/update$ &/$LOCALS #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)))) + (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))] + (&/Cons$ (&/update$ &/$locals #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [m] (&/|put name (&&/|meta type &/empty-cursor bound-unit) m)))) (&/|head stack)) (&/|tail stack)))) state))] - (matchv ::M/objects [=return] - [["lux;Right" [?state ?value]]] - (return* (&/update$ &/$ENVS (fn [stack*] - (&/|cons (&/update$ &/$LOCALS #(->> % - (&/update$ &/$COUNTER dec) - (&/set$ &/$MAPPINGS old-mappings)) + (|case =return + (&/$Right ?state ?value) + (return* (&/update$ &/$envs (fn [stack*] + (&/Cons$ (&/update$ &/$locals #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings old-mappings)) (&/|head stack*)) (&/|tail stack*))) ?state) ?value) - [_] + _ =return)))) (def captured-vars (fn [state] - (return* state (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$closure) (&/get$ &/$mappings))))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 5033f4f2c..7e1f92d19 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -1,256 +1,480 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.host (:require (clojure [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail]] + (lux [base :as & :refer [|let |do return fail |case]] [parser :as &parser] [type :as &type] [host :as &host]) + [lux.type.host :as &host-type] (lux.analyser [base :as &&] - [env :as &&env]))) + [lambda :as &&lambda] + [env :as &&env]) + [lux.compiler.base :as &c!base]) + (:import (java.lang.reflect TypeVariable))) ;; [Utils] -(defn ^:private extract-text [text] - (matchv ::M/objects [text] - [["lux;Meta" [_ ["lux;TextS" ?text]]]] - (return ?text) - - [_] - (fail "[Analyser Error] Can't extract Text."))) - -(defn ^:private analyse-1+ [analyse ?token] - (&type/with-var - (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var ?token)] - (matchv ::M/objects [=expr] - [[?item ?type]] - (|do [=type (&type/clean $var ?type)] - (return (&/T ?item =type))) - ))))) - -(defn ^:private ensure-object [token] - "(-> Analysis (Lux (,)))" - (matchv ::M/objects [token] - [[_ ["lux;DataT" _]]] - (return nil) - - [_] - (fail "[Analyser Error] Expecting object"))) +(defn ^:private extract-text [ast] + (|case ast + [_ (&/$TextS text)] + (return text) + + _ + (fail "[Analyser/Host Error] Can't extract text."))) + +(defn ^:private ensure-catching [exceptions] + "(-> (List Text) (Lux (,)))" + (|do [class-loader &/loader] + (fn [state] + (let [exceptions (&/|map #(Class/forName % true class-loader) exceptions) + catching (->> state (&/get$ &/$host) (&/get$ &/$catching) + (&/|map #(Class/forName % true class-loader)))] + (if-let [missing-ex (&/fold (fn [prev ^Class now] + (or prev + (if (&/fold (fn [found? ^Class ex-catch] + (or found? + (.isAssignableFrom ex-catch now))) + false + catching) + nil + now))) + nil + exceptions)] + (&/fail* (str "[Analyser Error] Unhandled exception: " missing-ex)) + (&/return* state nil))) + ))) + +(defn ^:private with-catches [catches body] + "(All [a] (-> (List Text) (Lux a) (Lux a)))" + (fn [state] + (let [old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching)) + state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))] + (|case (&/run-state body state*) + (&/$Left msg) + (&/V &/$Left msg) + + (&/$Right state** output) + (&/V &/$Right (&/T (->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) + output)))) + )) + +(defn ^:private ensure-object [type] + "(-> Type (Lux (, Text (List Type))))" + (|case type + (&/$DataT payload) + (return payload) + + (&/$NamedT _ type*) + (ensure-object type*) + + (&/$UnivQ _ type*) + (ensure-object type*) + + (&/$ExQ _ type*) + (ensure-object type*) + + _ + (fail (str "[Analyser Error] Expecting object: " (&type/show-type type))))) (defn ^:private as-object [type] "(-> Type Type)" - (matchv ::M/objects [type] - [["lux;DataT" class]] - (&/V "lux;DataT" (&type/as-obj class)) + (|case type + (&/$DataT class params) + (&type/Data$ (&host-type/as-obj class) params) - [_] + _ type)) +(defn ^:private as-otype [tname] + (case tname + "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" + ;; else + tname + )) + +(defn ^:private as-otype+ [type] + "(-> Type Type)" + (|case type + (&/$DataT name params) + (&type/Data$ (as-otype name) params) + + _ + type)) + +(defn ^:private clean-gtype-var [idx gtype-var] + (|let [(&/$VarT id) gtype-var] + (|do [? (&type/bound? id)] + (if ? + (|do [real-type (&type/deref id)] + (return (&/T idx real-type))) + (return (&/T (+ 2 idx) (&type/Bound$ idx))))))) + +(defn ^:private clean-gtype-vars [gtype-vars] + (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] + (|do [:let [[idx types] idx+types] + [idx* real-type] (clean-gtype-var idx gtype-var)] + (return (&/T idx* (&/Cons$ real-type types))))) + (&/T 1 (&/|list)) + gtype-vars)] + (return clean-types))) + +(defn ^:private make-gtype [class-name type-args] + "(-> Text (List Type) Type)" + (&/fold (fn [base-type type-arg] + (|case type-arg + (&/$BoundT _) + (&type/Univ$ &type/empty-env base-type) + + _ + base-type)) + (&type/Data$ class-name type-args) + type-args)) + ;; [Resources] (do-template [<name> <output-tag> <input-class> <output-class>] - (let [input-type (&/V "lux;DataT" <input-class>) - output-type (&/V "lux;DataT" <output-class>)] - (defn <name> [analyse exo-type ?x ?y] - (|do [=x (&&/analyse-1 analyse input-type ?x) - =y (&&/analyse-1 analyse input-type ?y) - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V <output-tag> (&/T =x =y)) output-type)))))) - - analyse-jvm-iadd "jvm-iadd" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-isub "jvm-isub" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-imul "jvm-imul" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-idiv "jvm-idiv" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-irem "jvm-irem" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ieq "jvm-ieq" "java.lang.Integer" "java.lang.Boolean" - analyse-jvm-ilt "jvm-ilt" "java.lang.Integer" "java.lang.Boolean" - analyse-jvm-igt "jvm-igt" "java.lang.Integer" "java.lang.Boolean" - - analyse-jvm-ceq "jvm-ceq" "java.lang.Character" "java.lang.Boolean" - analyse-jvm-clt "jvm-clt" "java.lang.Character" "java.lang.Boolean" - analyse-jvm-cgt "jvm-cgt" "java.lang.Character" "java.lang.Boolean" - - analyse-jvm-ladd "jvm-ladd" "java.lang.Long" "java.lang.Long" - analyse-jvm-lsub "jvm-lsub" "java.lang.Long" "java.lang.Long" - analyse-jvm-lmul "jvm-lmul" "java.lang.Long" "java.lang.Long" - analyse-jvm-ldiv "jvm-ldiv" "java.lang.Long" "java.lang.Long" - analyse-jvm-lrem "jvm-lrem" "java.lang.Long" "java.lang.Long" - analyse-jvm-leq "jvm-leq" "java.lang.Long" "java.lang.Boolean" - analyse-jvm-llt "jvm-llt" "java.lang.Long" "java.lang.Boolean" - analyse-jvm-lgt "jvm-lgt" "java.lang.Long" "java.lang.Boolean" - - analyse-jvm-fadd "jvm-fadd" "java.lang.Float" "java.lang.Float" - analyse-jvm-fsub "jvm-fsub" "java.lang.Float" "java.lang.Float" - analyse-jvm-fmul "jvm-fmul" "java.lang.Float" "java.lang.Float" - analyse-jvm-fdiv "jvm-fdiv" "java.lang.Float" "java.lang.Float" - analyse-jvm-frem "jvm-frem" "java.lang.Float" "java.lang.Float" - analyse-jvm-feq "jvm-feq" "java.lang.Float" "java.lang.Boolean" - analyse-jvm-flt "jvm-flt" "java.lang.Float" "java.lang.Boolean" - analyse-jvm-fgt "jvm-fgt" "java.lang.Float" "java.lang.Boolean" - - analyse-jvm-dadd "jvm-dadd" "java.lang.Double" "java.lang.Double" - analyse-jvm-dsub "jvm-dsub" "java.lang.Double" "java.lang.Double" - analyse-jvm-dmul "jvm-dmul" "java.lang.Double" "java.lang.Double" - analyse-jvm-ddiv "jvm-ddiv" "java.lang.Double" "java.lang.Double" - analyse-jvm-drem "jvm-drem" "java.lang.Double" "java.lang.Double" - analyse-jvm-deq "jvm-deq" "java.lang.Double" "java.lang.Boolean" - analyse-jvm-dlt "jvm-dlt" "java.lang.Double" "java.lang.Boolean" - analyse-jvm-dgt "jvm-dgt" "java.lang.Double" "java.lang.Boolean" + (let [input-type (&type/Data$ <input-class> &/Nil$) + output-type (&type/Data$ <output-class> &/Nil$)] + (defn <name> [analyse exo-type x y] + (|do [=x (&&/analyse-1 analyse input-type x) + =y (&&/analyse-1 analyse input-type y) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V <output-tag> (&/T =x =y)))))))) + + analyse-jvm-iadd &&/$jvm-iadd "java.lang.Integer" "java.lang.Integer" + analyse-jvm-isub &&/$jvm-isub "java.lang.Integer" "java.lang.Integer" + analyse-jvm-imul &&/$jvm-imul "java.lang.Integer" "java.lang.Integer" + analyse-jvm-idiv &&/$jvm-idiv "java.lang.Integer" "java.lang.Integer" + analyse-jvm-irem &&/$jvm-irem "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ieq &&/$jvm-ieq "java.lang.Integer" "java.lang.Boolean" + analyse-jvm-ilt &&/$jvm-ilt "java.lang.Integer" "java.lang.Boolean" + analyse-jvm-igt &&/$jvm-igt "java.lang.Integer" "java.lang.Boolean" + + analyse-jvm-ceq &&/$jvm-ceq "java.lang.Character" "java.lang.Boolean" + analyse-jvm-clt &&/$jvm-clt "java.lang.Character" "java.lang.Boolean" + analyse-jvm-cgt &&/$jvm-cgt "java.lang.Character" "java.lang.Boolean" + + analyse-jvm-ladd &&/$jvm-ladd "java.lang.Long" "java.lang.Long" + analyse-jvm-lsub &&/$jvm-lsub "java.lang.Long" "java.lang.Long" + analyse-jvm-lmul &&/$jvm-lmul "java.lang.Long" "java.lang.Long" + analyse-jvm-ldiv &&/$jvm-ldiv "java.lang.Long" "java.lang.Long" + analyse-jvm-lrem &&/$jvm-lrem "java.lang.Long" "java.lang.Long" + analyse-jvm-leq &&/$jvm-leq "java.lang.Long" "java.lang.Boolean" + analyse-jvm-llt &&/$jvm-llt "java.lang.Long" "java.lang.Boolean" + analyse-jvm-lgt &&/$jvm-lgt "java.lang.Long" "java.lang.Boolean" + + analyse-jvm-fadd &&/$jvm-fadd "java.lang.Float" "java.lang.Float" + analyse-jvm-fsub &&/$jvm-fsub "java.lang.Float" "java.lang.Float" + analyse-jvm-fmul &&/$jvm-fmul "java.lang.Float" "java.lang.Float" + analyse-jvm-fdiv &&/$jvm-fdiv "java.lang.Float" "java.lang.Float" + analyse-jvm-frem &&/$jvm-frem "java.lang.Float" "java.lang.Float" + analyse-jvm-feq &&/$jvm-feq "java.lang.Float" "java.lang.Boolean" + analyse-jvm-flt &&/$jvm-flt "java.lang.Float" "java.lang.Boolean" + analyse-jvm-fgt &&/$jvm-fgt "java.lang.Float" "java.lang.Boolean" + + analyse-jvm-dadd &&/$jvm-dadd "java.lang.Double" "java.lang.Double" + analyse-jvm-dsub &&/$jvm-dsub "java.lang.Double" "java.lang.Double" + analyse-jvm-dmul &&/$jvm-dmul "java.lang.Double" "java.lang.Double" + analyse-jvm-ddiv &&/$jvm-ddiv "java.lang.Double" "java.lang.Double" + analyse-jvm-drem &&/$jvm-drem "java.lang.Double" "java.lang.Double" + analyse-jvm-deq &&/$jvm-deq "java.lang.Double" "java.lang.Boolean" + analyse-jvm-dlt &&/$jvm-dlt "java.lang.Double" "java.lang.Boolean" + analyse-jvm-dgt &&/$jvm-dgt "java.lang.Double" "java.lang.Boolean" ) -(defn analyse-jvm-getstatic [analyse exo-type ?class ?field] +(defn ^:private analyse-field-access-helper [obj-type gvars gtype] + "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))" + (|case obj-type + (&/$DataT class targs) + (if (= (&/|length targs) (&/|length gvars)) + (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/Cons$ (&/T (.getName g) t) m)) + (&/|table) + gvars + targs)] + (&host-type/instance-param &type/existential gtype-env gtype)) + (fail (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type)))) + + _ + (fail (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) + +(defn analyse-jvm-getstatic [analyse exo-type class field] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader ?class ?field) + [gvars gtype] (&host/lookup-static-field class-loader class field) + :let [=type (&host-type/class->type (cast Class gtype))] :let [output-type =type] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-getstatic" (&/T ?class ?field)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-getstatic (&/T class field output-type))))))) -(defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object] +(defn analyse-jvm-getfield [analyse exo-type class field object] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader ?class ?field) - =object (&&/analyse-1 analyse ?object) + =object (&&/analyse-1 analyse object) + _ (ensure-object (&&/expr-type* =object)) + [gvars gtype] (&host/lookup-field class-loader class field) + =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) :let [output-type =type] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-getfield" (&/T ?class ?field =object)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-getfield (&/T class field =object output-type))))))) -(defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value] +(defn analyse-jvm-putstatic [analyse exo-type class field value] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader ?class ?field) - =value (&&/analyse-1 analyse =type ?value) + [gvars gtype] (&host/lookup-static-field class-loader class field) + :let [=type (&host-type/class->type (cast Class gtype))] + =value (&&/analyse-1 analyse =type value) :let [output-type &type/Unit] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-putstatic" (&/T ?class ?field =value)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-putstatic (&/T class field =value output-type))))))) -(defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value] +(defn analyse-jvm-putfield [analyse exo-type class field value object] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader ?class ?field) - =object (&&/analyse-1 analyse ?object) - =value (&&/analyse-1 analyse =type ?value) + =object (&&/analyse-1 analyse object) + _ (ensure-object (&&/expr-type* =object)) + [gvars gtype] (&host/lookup-field class-loader class field) + =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) + =value (&&/analyse-1 analyse =type value) :let [output-type &type/Unit] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-putfield" (&/T ?class ?field =object =value)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-putfield (&/T class field =value =object (&&/expr-type* =object)))))))) + +(defn analyse-jvm-instanceof [analyse exo-type class object] + (|do [=object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + :let [output-type &type/Bool] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-instanceof (&/T class =object))))))) + +(defn ^:private analyse-method-call-helper [analyse gret gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + =gret (&host-type/instance-param &type/existential gtype-env gret)] + (return (&/T =gret =args))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|let [gtype-env* (&/Cons$ (&/T (.getName gtv) $var) gtype-env)] + (analyse-method-call-helper analyse gret gtype-env* gtype-vars* gtype-args args)))) + )) -(defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args] +(let [dummy-type-param (&type/Data$ "java.lang.Object" (&/|list))] + (do-template [<name> <tag>] + (defn <name> [analyse exo-type class method classes object args] + (|do [class-loader &/loader + [gret exceptions parent-gvars gvars gargs] (if (= "<init>" method) + (return (&/T Void/TYPE &/Nil$ &/Nil$ &/Nil$ &/Nil$)) + (&host/lookup-virtual-method class-loader class method classes)) + _ (ensure-catching exceptions) + =object (&&/analyse-1+ analyse object) + [sub-class sub-params] (ensure-object (&&/expr-type* =object)) + (&/$DataT super-class* super-params*) (&host-type/->super-type &type/existential class-loader class sub-class sub-params) + :let [gtype-env (&/fold2 (fn [m g t] (&/Cons$ (&/T g t) m)) + (&/|table) + parent-gvars + super-params*)] + [output-type =args] (analyse-method-call-helper analyse gret gtype-env gvars gargs args) + _ (&type/check exo-type (as-otype+ output-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V <tag> (&/T class method classes =object =args output-type))))))) + + analyse-jvm-invokevirtual &&/$jvm-invokevirtual + analyse-jvm-invokeinterface &&/$jvm-invokeinterface + analyse-jvm-invokespecial &&/$jvm-invokespecial + )) + +(defn analyse-jvm-invokestatic [analyse exo-type class method classes args] (|do [class-loader &/loader - =classes (&/map% extract-text ?classes) - =return (&host/lookup-static-method class-loader ?class ?method =classes) - ;; :let [_ (matchv ::M/objects [=return] - ;; [["lux;DataT" _return-class]] - ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] + [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader class method classes) + _ (ensure-catching exceptions) =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&/V "lux;DataT" _class) _arg)) - =classes - ?args) - :let [output-type =return] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-invokestatic" (&/T ?class ?method =classes =args)) output-type))))) - -(defn analyse-jvm-instanceof [analyse exo-type ?class ?object] - (|do [=object (analyse-1+ analyse ?object) - _ (ensure-object =object) + (&&/analyse-1 analyse (&type/Data$ _class &/Nil$) _arg)) + classes + args) + :let [output-type (&host-type/class->type (cast Class gret))] + _ (&type/check exo-type (as-otype+ output-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-invokestatic (&/T class method classes =args output-type))))))) + +(defn analyse-jvm-null? [analyse exo-type object] + (|do [=object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) :let [output-type &type/Bool] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-instanceof" (&/T ?class =object)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-null? =object)))))) -(do-template [<name> <tag>] - (defn <name> [analyse exo-type ?class ?method ?classes ?object ?args] - (|do [class-loader &/loader - =classes (&/map% extract-text ?classes) - =return (&host/lookup-virtual-method class-loader ?class ?method =classes) - =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) - =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) - =classes ?args) - :let [output-type =return] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V <tag> (&/T ?class ?method =classes =object =args)) output-type))))) - - analyse-jvm-invokevirtual "jvm-invokevirtual" - analyse-jvm-invokeinterface "jvm-invokeinterface" - ) +(defn analyse-jvm-null [analyse exo-type] + (|do [:let [output-type (&type/Data$ &host-type/null-data-tag &/Nil$)] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-null nil)))))) + +(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] + (return (&/T (make-gtype gtype gtype-vars*) + =args))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|let [gtype-env* (&/Cons$ (&/T (.getName gtv) $var) gtype-env)] + (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args)))) + )) -(defn analyse-jvm-invokespecial [analyse exo-type ?class ?method ?classes ?object ?args] +(defn analyse-jvm-new [analyse exo-type class classes args] (|do [class-loader &/loader - =classes (&/map% extract-text ?classes) - =return (if (= "<init>" ?method) - (return &type/Unit) - (&host/lookup-virtual-method class-loader ?class ?method =classes)) - =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) - =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) - =classes ?args) - :let [output-type =return] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-invokespecial" (&/T ?class ?method =classes =object =args)) output-type))))) - -(defn analyse-jvm-null? [analyse exo-type ?object] - (|do [=object (analyse-1+ analyse ?object) - _ (ensure-object =object) - :let [output-type &type/Bool] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-null?" =object) output-type))))) + [exceptions gvars gargs] (&host/lookup-constructor class-loader class classes) + _ (ensure-catching exceptions) + [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-new (&/T class classes =args))))))) + +(let [length-type &type/Int + idx-type &type/Int] + (do-template [<class> <new-name> <new-tag> <load-name> <load-tag> <store-name> <store-tag>] + (let [elem-type (&type/Data$ <class> &/Nil$) + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] + (defn <new-name> [analyse exo-type length] + (|do [=length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V <new-tag> =length)))))) + + (defn <load-name> [analyse exo-type array idx] + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type elem-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V <load-tag> (&/T =array =idx))))))) + + (defn <store-name> [analyse exo-type array idx elem] + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse elem-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V <store-tag> (&/T =array =idx =elem))))))) + ) + + "java.lang.Boolean" analyse-jvm-znewarray &&/$jvm-znewarray analyse-jvm-zaload &&/$jvm-zaload analyse-jvm-zastore &&/$jvm-zastore + "java.lang.Byte" analyse-jvm-bnewarray &&/$jvm-bnewarray analyse-jvm-baload &&/$jvm-baload analyse-jvm-bastore &&/$jvm-bastore + "java.lang.Short" analyse-jvm-snewarray &&/$jvm-snewarray analyse-jvm-saload &&/$jvm-saload analyse-jvm-sastore &&/$jvm-sastore + "java.lang.Integer" analyse-jvm-inewarray &&/$jvm-inewarray analyse-jvm-iaload &&/$jvm-iaload analyse-jvm-iastore &&/$jvm-iastore + "java.lang.Long" analyse-jvm-lnewarray &&/$jvm-lnewarray analyse-jvm-laload &&/$jvm-laload analyse-jvm-lastore &&/$jvm-lastore + "java.lang.Float" analyse-jvm-fnewarray &&/$jvm-fnewarray analyse-jvm-faload &&/$jvm-faload analyse-jvm-fastore &&/$jvm-fastore + "java.lang.Double" analyse-jvm-dnewarray &&/$jvm-dnewarray analyse-jvm-daload &&/$jvm-daload analyse-jvm-dastore &&/$jvm-dastore + "java.lang.Character" analyse-jvm-cnewarray &&/$jvm-cnewarray analyse-jvm-caload &&/$jvm-caload analyse-jvm-castore &&/$jvm-castore + )) -(defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&/V "lux;DataT" "null")] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-null" nil) output-type))))) - -(defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] - (|do [=classes (&/map% extract-text ?classes) - =args (&/map% (partial analyse-1+ analyse) ?args) - :let [output-type (&/V "lux;DataT" ?class)] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-new" (&/T ?class =classes =args)) output-type))))) - -(defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/T (&/V "jvm-new-array" (&/T ?class ?length)) (&/V "array" (&/T (&/V "lux;DataT" ?class) - (&/V "lux;Nil" nil))))))) - -(defn analyse-jvm-aastore [analyse ?array ?idx ?elem] - (|do [=array (analyse-1+ analyse ?array) - =elem (analyse-1+ analyse ?elem) - =array-type (&&/expr-type =array)] - (return (&/|list (&/T (&/V "jvm-aastore" (&/T =array ?idx =elem)) =array-type))))) - -(defn analyse-jvm-aaload [analyse ?array ?idx] - (|do [=array (analyse-1+ analyse ?array) - =array-type (&&/expr-type =array)] - (return (&/|list (&/T (&/V "jvm-aaload" (&/T =array ?idx)) =array-type))))) +(let [length-type &type/Int + idx-type &type/Int] + (defn analyse-jvm-anewarray [analyse exo-type class length] + (|do [elem-type (&host-type/dummy-gtype class) + :let [array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-anewarray (&/T class =length))))))) + + (defn analyse-jvm-aaload [analyse exo-type array idx] + (|do [=array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type inner-arr-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-aaload (&/T =array =idx))))))) + + (defn analyse-jvm-aastore [analyse exo-type array idx elem] + (|do [=array (&&/analyse-1+ analyse array) + :let [array-type (&&/expr-type* =array)] + [arr-class arr-params] (ensure-object array-type) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse inner-arr-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-aastore (&/T =array =idx =elem)))))))) + +(defn analyse-jvm-arraylength [analyse exo-type array] + (|do [=array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + _ (&type/check exo-type &type/Int) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-arraylength =array) + ))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] - (matchv ::M/objects [modif] - [["lux;Meta" [_ ["lux;TextS" "public"]]]] + (|case modif + [_ (&/$TextS "public")] (return (assoc so-far :visibility "public")) - [["lux;Meta" [_ ["lux;TextS" "private"]]]] + [_ (&/$TextS "private")] (return (assoc so-far :visibility "private")) - [["lux;Meta" [_ ["lux;TextS" "protected"]]]] + [_ (&/$TextS "protected")] (return (assoc so-far :visibility "protected")) - [["lux;Meta" [_ ["lux;TextS" "static"]]]] + [_ (&/$TextS "static")] (return (assoc so-far :static? true)) - [["lux;Meta" [_ ["lux;TextS" "final"]]]] + [_ (&/$TextS "final")] (return (assoc so-far :final? true)) - [["lux;Meta" [_ ["lux;TextS" "abstract"]]]] + [_ (&/$TextS "abstract")] (return (assoc so-far :abstract? true)) - [["lux;Meta" [_ ["lux;TextS" "synchronized"]]]] + [_ (&/$TextS "synchronized")] (return (assoc so-far :concurrency "synchronized")) - [["lux;Meta" [_ ["lux;TextS" "volatile"]]]] + [_ (&/$TextS "volatile")] (return (assoc so-far :concurrency "volatile")) - [_] + _ (fail (str "[Analyser Error] Unknown modifier: " (&/show-ast modif))))) {:visibility "default" :static? false @@ -259,181 +483,332 @@ :concurrency nil} modifiers)) -(defn ^:private as-otype [tname] - (case tname - "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" - ;; else - tname - )) - -(defn analyse-jvm-class [analyse ?name ?super-class ?interfaces ?fields ?methods] - (|do [=interfaces (&/map% extract-text ?interfaces) - =fields (&/map% (fn [?field] - (matchv ::M/objects [?field] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field-name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field-type]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?field-modifiers]]] - ["lux;Nil" _]]]]]]]]]]] - (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] - (return {:name ?field-name - :modifiers =field-modifiers - :type ?field-type})) - - [_] - (fail "[Analyser Error] Wrong syntax for field."))) - ?fields) - =methods (&/map% (fn [?method] - (matchv ::M/objects [?method] - [[?idx ["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-inputs]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-output]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-modifiers]]] - ["lux;Cons" [?method-body - ["lux;Nil" _]]]]]]]]]]]]]]]] - (|do [=method-inputs (&/map% (fn [minput] - (matchv ::M/objects [minput] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?input-name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?input-type]]] - ["lux;Nil" _]]]]]]]]] - (return (&/T (&/ident->text ?input-name) ?input-type)) - - [_] - (fail "[Analyser Error] Wrong syntax for method input."))) - ?method-inputs) - =method-modifiers (analyse-modifiers ?method-modifiers) - =method-body (&/with-scope (str ?name "_" ?idx) - (&/fold (fn [body* input*] - (|let [[iname itype] input*] - (&&env/with-local iname (&/V "lux;DataT" (as-otype itype)) - body*))) - (if (= "void" ?method-output) - (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&/V "lux;DataT" (as-otype ?method-output)) ?method-body)) - (&/|reverse (if (:static? =method-modifiers) - =method-inputs - (&/|cons (&/T ";this" ?super-class) - =method-inputs)))))] - (return {:name ?method-name - :modifiers =method-modifiers - :inputs (&/|map &/|second =method-inputs) - :output ?method-output - :body =method-body})) - - [_] - (fail "[Analyser Error] Wrong syntax for method."))) - (&/enumerate ?methods))] - (return (&/|list (&/V "jvm-class" (&/T ?name ?super-class =interfaces =fields =methods)))))) - -(defn analyse-jvm-interface [analyse ?name ?supers ?methods] - (|do [=supers (&/map% extract-text ?supers) - =methods (&/map% (fn [method] - (matchv ::M/objects [method] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?inputs]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?output]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?modifiers]]] - ["lux;Nil" _]]]]]]]]]]]]] - (|do [=inputs (&/map% extract-text ?inputs) - =modifiers (analyse-modifiers ?modifiers)] - (return {:name ?method-name - :modifiers =modifiers - :inputs =inputs - :output ?output})) - - [_] - (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) - ?methods)] - (return (&/|list (&/V "jvm-interface" (&/T ?name =supers =methods)))))) +(let [failure (fail (str "[Analyser Error] Invalid annotation parameter."))] + (defn ^:private extract-ann-param [param] + (|case param + [[_ (&/$TextS param-name)] param-value] + (|case param-value + [_ (&/$BoolS param-value*)] (return (&/T param-name (boolean param-value*))) + [_ (&/$IntS param-value*)] (return (&/T param-name (int param-value*))) + [_ (&/$RealS param-value*)] (return (&/T param-name (float param-value*))) + [_ (&/$CharS param-value*)] (return (&/T param-name (char param-value*))) + [_ (&/$TextS param-value*)] (return (&/T param-name param-value*)) + + _ + failure) + + _ + failure))) + +(defn ^:private analyse-ann [ann] + (|case ann + [_ (&/$FormS (&/$Cons [_ (&/$TextS ann-name)] (&/$Cons [_ (&/$RecordS ann-params)] (&/$Nil))))] + (|do [=ann-params (&/map% extract-ann-param ann-params)] + (return {:name ann-name + :params ann-params})) + + _ + (fail (str "[Analyser Error] Invalid annotation: " (&/show-ast ann))))) + +(defn ^:private analyse-field [field] + (|case field + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] + (&/$Cons [_ (&/$TupleS ?field-modifiers)] + (&/$Cons [_ (&/$TupleS ?anns)] + (&/$Cons [_ (&/$TextS ?field-type)] + (&/$Nil))))))] + (|do [=field-modifiers (analyse-modifiers ?field-modifiers) + =anns (&/map% analyse-ann ?anns)] + (return {:name ?field-name + :modifiers =field-modifiers + :anns =anns + :type ?field-type})) + + _ + (fail "[Analyser Error] Wrong syntax for field."))) + +(defn ^:private dummy-method-desc [method] + (|case method + [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS method-modifiers)] + (&/$Cons [_ (&/$TupleS method-anns)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons method-body + (&/$Nil)))))))))] + (|do [=method-modifiers (analyse-modifiers method-modifiers) + =method-exs (&/map% extract-text method-exs) + =method-inputs (&/map% (fn [minput] + (|case minput + [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" input-name)] + (&/$Cons [_ (&/$TextS input-type)] + (&/$Nil))))] + (return (&/T input-name input-type)) + + _ + (fail "[Analyser Error] Wrong syntax for method input."))) + method-inputs)] + (return {:name method-name + :modifiers =method-modifiers + :anns (&/|list) + :exceptions =method-exs + :inputs (&/|map &/|second =method-inputs) + :output method-output})) + + _ + (fail (str "[Analyser Error] Wrong syntax for method: " (&/show-ast method))))) + +(defn ^:private analyse-method [analyse owner-class method] + (|case method + [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS method-modifiers)] + (&/$Cons [_ (&/$TupleS method-anns)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons method-body + (&/$Nil)))))))))] + (|do [=method-modifiers (analyse-modifiers method-modifiers) + =anns (&/map% analyse-ann method-anns) + =method-exs (&/map% extract-text method-exs) + =method-inputs (&/map% (fn [minput] + (|case minput + [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" input-name)] + (&/$Cons [_ (&/$TextS input-type)] + (&/$Nil))))] + (return (&/T input-name input-type)) + + _ + (fail "[Analyser Error] Wrong syntax for method input."))) + method-inputs) + =method-body (&/fold (fn [body* input*] + (|let [[iname itype] input*] + (&&env/with-local iname (&type/Data$ (as-otype itype) &/Nil$) + body*))) + (if (= "void" method-output) + (&&/analyse-1+ analyse method-body) + (&&/analyse-1 analyse (&type/Data$ (as-otype method-output) &/Nil$) method-body)) + (&/|reverse (&/Cons$ (&/T &&/jvm-this owner-class) + =method-inputs)))] + (return {:name method-name + :modifiers =method-modifiers + :anns =anns + :exceptions =method-exs + :inputs (&/|map &/|second =method-inputs) + :output method-output + :body =method-body})) + + _ + (fail (str "[Analyser Error] Wrong syntax for method: " (&/show-ast method))))) + +(defn ^:private analyse-method-decl [method] + (|case method + [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS modifiers)] + (&/$Cons [_ (&/$TupleS ?anns)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons [_ (&/$TextS output)] + (&/$Nil))))))))] + (|do [=modifiers (analyse-modifiers modifiers) + =anns (&/map% analyse-ann ?anns) + =inputs (&/map% extract-text inputs) + =method-exs (&/map% extract-text method-exs)] + (return {:name method-name + :modifiers =modifiers + :anns =anns + :exceptions =method-exs + :inputs =inputs + :output output})) + + _ + (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) + +(defn ^:private mandatory-methods [supers] + (|do [class-loader &/loader] + (&/flat-map% (partial &host/abstract-methods class-loader) supers))) + +(defn ^:private check-method-completion [supers methods] + "(-> (List ClassName) (List MethodDesc) (Lux (,)))" + (|do [abstract-methods (mandatory-methods supers) + :let [methods-map (&/fold (fn [mmap mentry] + (assoc mmap (:name mentry) mentry)) + {} + methods) + missing-method (&/fold (fn [missing abs-meth] + (|let [[am-name am-inputs] abs-meth] + (or missing + (if-let [meth-struct (get methods-map am-name)] + (let [meth-inputs (:inputs meth-struct)] + (if (and (= (&/|length meth-inputs) (&/|length am-inputs)) + (&/fold2 (fn [prev mi ai] (and prev (= mi ai))) + true + meth-inputs am-inputs)) + nil + am-name)) + am-name)))) + nil + abstract-methods)]] + (if (nil? missing-method) + (return nil) + (fail (str "[Analyser Error] Missing method: " missing-method))))) + +(defn analyse-jvm-class [analyse compile-token name super-class interfaces anns fields methods] + (&/with-closure + (|do [module &/get-module-name + :let [full-name (str module "." name)] + ;; :let [_ (prn 'analyse-jvm-class/_0)] + =anns (&/map% analyse-ann anns) + =fields (&/map% analyse-field fields) + ;; :let [_ (prn 'analyse-jvm-class/_1)] + =method-descs (&/map% dummy-method-desc methods) + _ (&host/use-dummy-class name super-class interfaces =fields =method-descs) + =methods (&/map% (partial analyse-method analyse full-name) methods) + ;; :let [_ (prn 'analyse-jvm-class/_2)] + _ (check-method-completion (&/Cons$ super-class interfaces) =methods) + ;; :let [_ (prn 'analyse-jvm-class/_3)] + _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =anns =fields =methods nil))) + :let [_ (println 'DEF (str module "." name))]] + (return &/Nil$)))) + +(defn analyse-jvm-interface [analyse compile-token name supers anns methods] + (|do [module &/get-module-name + =anns (&/map% analyse-ann anns) + =methods (&/map% analyse-method-decl methods) + _ (compile-token (&/V &&/$jvm-interface (&/T name supers =anns =methods))) + :let [_ (println 'DEF (str module "." name))]] + (return &/Nil$))) + +(defn ^:private captured-source [env-entry] + (|case env-entry + [name [_ (&&/$captured _ _ source)]] + source)) + +(let [captured-slot-modifier {:visibility "private" + :static? false + :final? false + :abstract? false + :concurrency nil} + captured-slot-type "java.lang.Object"] + (defn analyse-jvm-anon-class [analyse compile-token exo-type super-class interfaces methods] + (&/with-closure + (|do [module &/get-module-name + scope &/get-scope-name + :let [name (&host/location (&/|tail scope)) + anon-class (str module "." name)] + =method-descs (&/map% dummy-method-desc methods) + _ (&host/use-dummy-class name super-class interfaces (&/|list) =method-descs) + =methods (&/map% (partial analyse-method analyse anon-class) methods) + _ (check-method-completion (&/Cons$ super-class interfaces) =methods) + =captured &&env/captured-vars + :let [=fields (&/|map (fn [^objects idx+capt] + {:name (str &c!base/closure-prefix (aget idx+capt 0)) + :modifiers captured-slot-modifier + :anns (&/|list) + :type captured-slot-type}) + (&/enumerate =captured))] + :let [sources (&/|map captured-source =captured)] + _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces (&/|list) =fields =methods =captured))) + _cursor &/cursor] + (return (&/|list (&&/|meta (&type/Data$ anon-class (&/|list)) _cursor + (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)) + ))) + )))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] - =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local (str ";" ?ex-arg) (&/V "lux;DataT" ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class &/Nil$) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) ?catches) - =finally (matchv ::M/objects [?finally] - [["lux;None" _]] (return (&/V "lux;None" nil)) - [["lux;Some" ?finally*]] (|do [=finally (analyse-1+ analyse ?finally*)] - (return (&/V "lux;Some" =finally))))] - (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) exo-type))))) + :let [catched-exceptions (&/|map #(aget ^objects % 0) =catches)] + =body (with-catches catched-exceptions + (&&/analyse-1 analyse exo-type ?body)) + =finally (|case ?finally + (&/$None) (return &/None$) + (&/$Some ?finally*) (|do [=finally (&&/analyse-1+ analyse ?finally*)] + (return (&/V &/$Some =finally)))) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-try (&/T =body =catches =finally))))))) (defn analyse-jvm-throw [analyse exo-type ?ex] - (|do [=ex (analyse-1+ analyse ?ex) - :let [[_obj _type] =ex] - _ (&type/check (&/V "lux;DataT" "java.lang.Throwable") _type)] - (return (&/|list (&/T (&/V "jvm-throw" =ex) &type/$Void))))) + (|do [=ex (&&/analyse-1 analyse (&type/Data$ "java.lang.Throwable" &/Nil$) ?ex) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-throw =ex)))))) (do-template [<name> <tag>] (defn <name> [analyse exo-type ?monitor] - (|do [=monitor (analyse-1+ analyse ?monitor) - _ (ensure-object =monitor) + (|do [=monitor (&&/analyse-1+ analyse ?monitor) + _ (ensure-object (&&/expr-type* =monitor)) :let [output-type &type/Unit] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V <tag> =monitor) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&/V <tag> =monitor)))))) - analyse-jvm-monitorenter "jvm-monitorenter" - analyse-jvm-monitorexit "jvm-monitorexit" + analyse-jvm-monitorenter &&/$jvm-monitorenter + analyse-jvm-monitorexit &&/$jvm-monitorexit ) (do-template [<name> <tag> <from-class> <to-class>] - (let [output-type (&/V "lux;DataT" <to-class>)] + (let [output-type (&type/Data$ <to-class> &/Nil$)] (defn <name> [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value) - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V <tag> =value) output-type)))))) - - analyse-jvm-d2f "jvm-d2f" "java.lang.Double" "java.lang.Float" - analyse-jvm-d2i "jvm-d2i" "java.lang.Double" "java.lang.Integer" - analyse-jvm-d2l "jvm-d2l" "java.lang.Double" "java.lang.Long" - - analyse-jvm-f2d "jvm-f2d" "java.lang.Float" "java.lang.Double" - analyse-jvm-f2i "jvm-f2i" "java.lang.Float" "java.lang.Integer" - analyse-jvm-f2l "jvm-f2l" "java.lang.Float" "java.lang.Long" - - analyse-jvm-i2b "jvm-i2b" "java.lang.Integer" "java.lang.Byte" - analyse-jvm-i2c "jvm-i2c" "java.lang.Integer" "java.lang.Character" - analyse-jvm-i2d "jvm-i2d" "java.lang.Integer" "java.lang.Double" - analyse-jvm-i2f "jvm-i2f" "java.lang.Integer" "java.lang.Float" - analyse-jvm-i2l "jvm-i2l" "java.lang.Integer" "java.lang.Long" - analyse-jvm-i2s "jvm-i2s" "java.lang.Integer" "java.lang.Short" - - analyse-jvm-l2d "jvm-l2d" "java.lang.Long" "java.lang.Double" - analyse-jvm-l2f "jvm-l2f" "java.lang.Long" "java.lang.Float" - analyse-jvm-l2i "jvm-l2i" "java.lang.Long" "java.lang.Integer" + (|do [=value (&&/analyse-1 analyse (&type/Data$ <from-class> &/Nil$) ?value) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&/V <tag> =value))))))) + + analyse-jvm-d2f &&/$jvm-d2f "java.lang.Double" "java.lang.Float" + analyse-jvm-d2i &&/$jvm-d2i "java.lang.Double" "java.lang.Integer" + analyse-jvm-d2l &&/$jvm-d2l "java.lang.Double" "java.lang.Long" + + analyse-jvm-f2d &&/$jvm-f2d "java.lang.Float" "java.lang.Double" + analyse-jvm-f2i &&/$jvm-f2i "java.lang.Float" "java.lang.Integer" + analyse-jvm-f2l &&/$jvm-f2l "java.lang.Float" "java.lang.Long" + + analyse-jvm-i2b &&/$jvm-i2b "java.lang.Integer" "java.lang.Byte" + analyse-jvm-i2c &&/$jvm-i2c "java.lang.Integer" "java.lang.Character" + analyse-jvm-i2d &&/$jvm-i2d "java.lang.Integer" "java.lang.Double" + analyse-jvm-i2f &&/$jvm-i2f "java.lang.Integer" "java.lang.Float" + analyse-jvm-i2l &&/$jvm-i2l "java.lang.Integer" "java.lang.Long" + analyse-jvm-i2s &&/$jvm-i2s "java.lang.Integer" "java.lang.Short" + + analyse-jvm-l2d &&/$jvm-l2d "java.lang.Long" "java.lang.Double" + analyse-jvm-l2f &&/$jvm-l2f "java.lang.Long" "java.lang.Float" + analyse-jvm-l2i &&/$jvm-l2i "java.lang.Long" "java.lang.Integer" ) (do-template [<name> <tag> <from-class> <to-class>] - (let [output-type (&/V "lux;DataT" <to-class>)] + (let [output-type (&type/Data$ <to-class> &/Nil$)] (defn <name> [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value) - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V <tag> =value) output-type)))))) - - analyse-jvm-iand "jvm-iand" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ior "jvm-ior" "java.lang.Integer" "java.lang.Integer" - - analyse-jvm-land "jvm-land" "java.lang.Long" "java.lang.Long" - analyse-jvm-lor "jvm-lor" "java.lang.Long" "java.lang.Long" - analyse-jvm-lxor "jvm-lxor" "java.lang.Long" "java.lang.Long" - - analyse-jvm-lshl "jvm-lshl" "java.lang.Long" "java.lang.Integer" - analyse-jvm-lshr "jvm-lshr" "java.lang.Long" "java.lang.Integer" - analyse-jvm-lushr "jvm-lushr" "java.lang.Long" "java.lang.Integer" + (|do [=value (&&/analyse-1 analyse (&type/Data$ <from-class> &/Nil$) ?value) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&/V <tag> =value))))))) + + analyse-jvm-iand &&/$jvm-iand "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ior &&/$jvm-ior "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ixor &&/$jvm-ixor "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ishl &&/$jvm-ishl "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ishr &&/$jvm-ishr "java.lang.Integer" "java.lang.Integer" + analyse-jvm-iushr &&/$jvm-iushr "java.lang.Integer" "java.lang.Integer" + + analyse-jvm-land &&/$jvm-land "java.lang.Long" "java.lang.Long" + analyse-jvm-lor &&/$jvm-lor "java.lang.Long" "java.lang.Long" + analyse-jvm-lxor &&/$jvm-lxor "java.lang.Long" "java.lang.Long" + analyse-jvm-lshl &&/$jvm-lshl "java.lang.Long" "java.lang.Integer" + analyse-jvm-lshr &&/$jvm-lshr "java.lang.Long" "java.lang.Integer" + analyse-jvm-lushr &&/$jvm-lushr "java.lang.Long" "java.lang.Integer" ) -(defn analyse-jvm-program [analyse ?args ?body] - (|let [[_module _name] ?args] +(let [input-type (&type/App$ &type/List &type/Text) + output-type (&type/App$ &type/IO &type/Unit)] + (defn analyse-jvm-program [analyse compile-token ?args ?body] (|do [=body (&/with-scope "" - (&&env/with-local (str _module ";" _name) (&/V "lux;AppT" (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body)))] - (return (&/|list (&/V "jvm-program" =body)))))) + (&&env/with-local ?args input-type + (&&/analyse-1 analyse output-type ?body))) + _ (compile-token (&/V &&/$jvm-program =body))] + (return &/Nil$)))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index b1b9e2c22..bbb5d2dc7 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -1,41 +1,33 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.lambda - (:require [clojure.core.match :as M :refer [matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail]] + (lux [base :as & :refer [|let |do return fail |case]] [host :as &host]) (lux.analyser [base :as &&] [env :as &env]))) ;; [Resource] (defn with-lambda [self self-type arg arg-type body] - (|let [[?module1 ?name1] self - [?module2 ?name2] arg] - (&/with-closure - (|do [scope-name &/get-scope-name] - (&env/with-local (str ?module1 ";" ?name1) self-type - (&env/with-local (str ?module2 ";" ?name2) arg-type - (|do [=return body - =captured &env/captured-vars] - (return (&/T scope-name =captured =return))))))))) + (&/with-closure + (|do [scope-name &/get-scope-name] + (&env/with-local self self-type + (&env/with-local arg arg-type + (|do [=return body + =captured &env/captured-vars] + (return (&/T scope-name =captured =return)))))))) -(defn close-over [scope ident register frame] - (matchv ::M/objects [register] - [[_ register-type]] - (|let [register* (&/T (&/V "captured" (&/T scope - (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) - register)) - register-type) - [?module ?name] ident - full-name (str ?module ";" ?name)] - (&/T register* (&/update$ &/$CLOSURE #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [mps] (&/|put full-name register* mps)))) - frame))))) +(defn close-over [scope name register frame] + (|let [[[register-type register-cursor] _] register + register* (&&/|meta register-type register-cursor + (&/V &&/$captured (&/T scope + (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) + register)))] + (&/T register* (&/update$ &/$closure #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) + frame)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 065e150d9..e938fa343 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -1,16 +1,13 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.lux (:require (clojure [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return return* fail fail* |let |list]] + (lux [base :as & :refer [|do return return* fail fail* |let |list |case]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -18,334 +15,442 @@ [lambda :as &&lambda] [case :as &&case] [env :as &&env] - [module :as &&module]))) - -(defn ^:private analyse-1+ [analyse ?token] - (&type/with-var - (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var ?token)] - (matchv ::M/objects [=expr] - [[?item ?type]] - (|do [=type (&type/clean $var ?type)] - (return (&/T ?item =type))) - ))))) - -(defn ^:private with-cursor [cursor form] - (matchv ::M/objects [form] - [["lux;Meta" [_ syntax]]] - (&/V "lux;Meta" (&/T cursor syntax)))) + [module :as &&module] + [record :as &&record]))) + +;; [Utils] +(defn ^:private count-univq [type] + "(-> Type Int)" + (|case type + (&/$UnivQ env type*) + (inc (count-univq type*)) + + _ + 0)) + +(defn ^:private next-bound-type [type] + "(-> Type Type)" + (&type/Bound$ (->> (count-univq type) (* 2) (+ 1)))) + +(defn ^:private embed-inferred-input [input output] + "(-> Type Type Type)" + (|case output + (&/$UnivQ env output*) + (&type/Univ$ env (embed-inferred-input input output*)) + + _ + (&type/Lambda$ input output))) ;; [Exports] -(defn analyse-tuple [analyse exo-type ?elems] - (|do [exo-type* (&type/actual-type exo-type)] - (matchv ::M/objects [exo-type*] - [["lux;TupleT" ?members]] - (|do [=elems (&/map2% (fn [elem-t elem] - (&&/analyse-1 analyse elem-t elem)) - ?members ?elems)] - (return (&/|list (&/T (&/V "tuple" =elems) - exo-type)))) - - [["lux;AllT" _]] - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-tuple analyse exo-type** ?elems)))) - - [_] - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) - -(defn analyse-variant [analyse exo-type ident ?value] - (|do [exo-type* (matchv ::M/objects [exo-type] - [["lux;VarT" ?id]] - (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] - (&type/actual-type exo-type*)) - (|do [_ (&type/set-var ?id &type/Type)] - (&type/actual-type &type/Type)))) - - [_] - (&type/actual-type exo-type))] - (matchv ::M/objects [exo-type*] - [["lux;VariantT" ?cases]] - (|do [?tag (&&/resolved-ident ident)] - (if-let [vtype (&/|get ?tag ?cases)] - (|do [=value (&&/analyse-1 analyse vtype ?value)] - (return (&/|list (&/T (&/V "variant" (&/T ?tag =value)) - exo-type)))) - (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) - - [["lux;AllT" _]] - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse exo-type** ident ?value)))) +(defn analyse-tuple [analyse ?exo-type ?elems] + (|case ?exo-type + (&/$Left exo-type) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left exo-type**) ?elems)) + =var (&type/resolve-type $var) + inferred-type (|case =var + (&/$VarT iid) + (|do [:let [=var* (next-bound-type tuple-type)] + _ (&type/set-var iid =var*) + tuple-type* (&type/clean $var tuple-type)] + (return (&type/Univ$ &/Nil$ tuple-type*))) + + _ + (&type/clean $var tuple-type))] + (return (&/|list (&&/|meta inferred-type tuple-cursor + tuple-analysis)))))) + + _ + (analyse-tuple analyse (&/V &/$Right exo-type*) ?elems))) + + (&/$Right exo-type) + (|do [unknown? (&type/unknown? exo-type)] + (if unknown? + (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] + (return =analysis)) + ?elems) + _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems))) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$tuple =elems) + )))) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$TupleT ?members) + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + ?members ?elems) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$tuple =elems) + )))) + + (&/$UnivQ _) + (|do [$var &type/existential + exo-type** (&type/apply-type exo-type* $var) + [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/V &/$Right exo-type**) ?elems))] + (return (&/|list (&&/|meta exo-type tuple-cursor + tuple-analysis)))) + + _ + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) + )))))) + +(defn with-attempt [m-value on-error] + (fn [state] + (|case (m-value state) + (&/$Left msg) + ((on-error msg) state) - [_] - (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) + output + output))) + +(defn ^:private analyse-variant-body [analyse exo-type ?values] + (|do [output (with-attempt + (|case ?values + (&/$Nil) + (analyse-tuple analyse (&/V &/$Right exo-type) &/Nil$) + + (&/$Cons ?value (&/$Nil)) + (analyse exo-type ?value) + + _ + (analyse-tuple analyse (&/V &/$Right exo-type) ?values)) + (fn [err] + (fail (str err "\n" + 'analyse-variant-body " " (&type/show-type exo-type) + " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) + ))] + (|case output + (&/$Cons x (&/$Nil)) + (return x) + + _ + (fail "[Analyser Error] Can't expand to other than 1 element.")))) + +(defn analyse-variant [analyse ?exo-type idx ?values] + (|case ?exo-type + (&/$Left exo-type) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx ?values)) + =var (&type/resolve-type $var) + inferred-type (|case =var + (&/$VarT iid) + (|do [:let [=var* (next-bound-type variant-type)] + _ (&type/set-var iid =var*) + variant-type* (&type/clean $var variant-type)] + (return (&type/Univ$ &/Nil$ variant-type*))) + + _ + (&type/clean $var variant-type))] + (return (&/|list (&&/|meta inferred-type variant-cursor + variant-analysis)))))) + + _ + (analyse-variant analyse (&/V &/$Right exo-type*) idx ?values))) + + (&/$Right exo-type) + (|do [exo-type* (|case exo-type + (&/$VarT ?id) + (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] + (&type/actual-type exo-type*)) + (|do [_ (&type/set-var ?id &type/Type)] + (&type/actual-type &type/Type)))) + + _ + (&type/actual-type exo-type))] + (|case exo-type* + (&/$VariantT ?cases) + (|case (&/|at idx ?cases) + (&/$Some vtype) + (|do [=value (with-attempt + (analyse-variant-body analyse vtype ?values) + (fn [err] + (|do [_exo-type (&type/deref+ exo-type)] + (fail (str err "\n" + 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type) + " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$variant (&/T idx =value)) + )))) + + (&/$None) + (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) + + (&/$UnivQ _) + (|do [$var &type/existential + exo-type** (&type/apply-type exo-type* $var)] + (analyse-variant analyse (&/V &/$Right exo-type**) idx ?values)) + + _ + (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*))))))) (defn analyse-record [analyse exo-type ?elems] - (|do [exo-type* (matchv ::M/objects [exo-type] - [["lux;VarT" ?id]] - (|do [exo-type* (&type/deref ?id)] - (&type/actual-type exo-type*)) - - [["lux;AllT" _]] - (|do [$var &type/existential - =type (&type/apply-type exo-type $var)] - (&type/actual-type =type)) - ;; (&type/with-var - ;; (fn [$var] - ;; (|do [=type (&type/apply-type exo-type $var)] - ;; (&type/actual-type =type)))) - - [_] - (&type/actual-type exo-type)) - types (matchv ::M/objects [exo-type*] - [["lux;RecordT" ?table]] - (return ?table) - - [_] - (fail (str "[Analyser Error] The type of a record must be a record type:\n" - (&type/show-type exo-type*) - "\n"))) - =slots (&/map% (fn [kv] - (matchv ::M/objects [kv] - [[["lux;Meta" [_ ["lux;TagS" ?ident]]] ?value]] - (|do [?tag (&&/resolved-ident ?ident) - slot-type (if-let [slot-type (&/|get ?tag types)] - (return slot-type) - (fail (str "[Analyser Error] Record type does not have slot: " ?tag))) - =value (&&/analyse-1 analyse slot-type ?value)] - (return (&/T ?tag =value))) - - [_] - (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) - ?elems)] - (return (&/|list (&/T (&/V "record" =slots) (&/V "lux;RecordT" exo-type)))))) + (|do [[rec-members rec-type] (&&record/order-record ?elems)] + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (analyse-tuple analyse (&/V &/$Right exo-type) rec-members) + (|do [[[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left rec-type) rec-members)) + _ (&type/check exo-type tuple-type)] + (return (&/|list (&&/|meta exo-type tuple-cursor + tuple-analysis)))))) + + _ + (analyse-tuple analyse (&/V &/$Right exo-type) rec-members) + ))) + +(defn ^:private analyse-global [analyse exo-type module name] + (|do [[[r-module r-name] $def] (&&module/find-def module name) + endo-type (|case $def + (&/$ValueD ?type _) + (return ?type) + + (&/$MacroD _) + (return &type/Macro) + + (&/$TypeD _) + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta endo-type _cursor + (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) + ))))) + +(defn ^:private analyse-local [analyse exo-type name] + (fn [state] + (|let [stack (&/get$ &/$envs state) + no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) + (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not)) + [inner outer] (&/|split-with no-binding? stack)] + (|case outer + (&/$Nil) + (&/run-state (|do [module-name &/get-module-name] + (analyse-global analyse exo-type module-name name)) + state) + + (&/$Cons ?genv (&/$Nil)) + (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] + (|case global + [(&/$Global ?module* name*) _] + ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) + endo-type (|case $def + (&/$ValueD ?type _) + (return ?type) + + (&/$MacroD _) + (return &type/Macro) + + (&/$TypeD _) + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta endo-type _cursor + (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) + )))) + state) + + _ + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")) + (fail* "")) + + (&/$Cons top-outer _) + (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/get$ &/$name %2) %1) + (&/|map #(&/get$ &/$name %) outer) + (&/|reverse inner))) + [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] + (|let [[register new-inner] register+new-inner + [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] + (&/T register* (&/Cons$ frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) + (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) + &/Nil$) + (&/|reverse inner) scopes)] + ((|do [_ (&type/check exo-type (&&/expr-type* =local))] + (return (&/|list =local))) + (&/set$ &/$envs (&/|++ inner* outer) state))) + )))) (defn analyse-symbol [analyse exo-type ident] - (|do [module-name &/get-module-name] - (fn [state] - (|let [[?module ?name] ident - ;; _ (prn 'analyse-symbol/_0 ?module ?name) - local-ident (str ?module ";" ?name) - stack (&/get$ &/$ENVS state) - no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not) - (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not)) - [inner outer] (&/|split-with no-binding? stack)] - (matchv ::M/objects [outer] - [["lux;Nil" _]] - (do ;; (prn 'analyse-symbol/_1 - ;; [?module ?name] - ;; [(if (.equals "" ?module) module-name ?module) - ;; ?name]) - ((|do [[[r-module r-name] $def] (&&module/find-def (if (.equals "" ?module) module-name ?module) - ?name) - ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state)) - - [["lux;Cons" [?genv ["lux;Nil" _]]]] - (do ;; (prn 'analyse-symbol/_2 ?module ?name local-ident (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))] - (do ;; (prn 'analyse-symbol/_2.1 ?module ?name local-ident (aget global 0)) - (matchv ::M/objects [global] - [[["lux;Global" [?module* ?name*]] _]] - ((|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*) - ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state) - - [_] - (do ;; (prn 'analyse-symbol/_2.1.2 ?module ?name local-ident) - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) - (fail* "_{_ analyse-symbol _}_"))) - - [["lux;Cons" [top-outer _]]] - (do ;; (prn 'analyse-symbol/_3 ?module ?name) - (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) - (&/|map #(&/get$ &/$NAME %) outer) - (&/|reverse inner))) - [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] - (|let [[register new-inner] register+new-inner - [register* frame*] (&&lambda/close-over (&/|reverse in-scope) ident register frame)] - (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident)) - (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident))) - (&/|list)) - (&/|reverse inner) scopes)] - ((|do [btype (&&/expr-type =local) - _ (&type/check exo-type btype)] - (return (&/|list =local))) - (&/set$ &/$ENVS (&/|++ inner* outer) state)))) - ))) + (|do [:let [[?module ?name] ident]] + (if (= "" ?module) + (analyse-local analyse exo-type ?name) + (analyse-global analyse exo-type ?module ?name)) )) (defn ^:private analyse-apply* [analyse exo-type fun-type ?args] - ;; (prn 'analyse-apply* (aget fun-type 0)) - (matchv ::M/objects [?args] - [["lux;Nil" _]] + (|case ?args + (&/$Nil) (|do [_ (&type/check exo-type fun-type)] - (return (&/T fun-type (&/|list)))) + (return (&/T fun-type &/Nil$))) - [["lux;Cons" [?arg ?args*]]] + (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] - (matchv ::M/objects [?fun-type*] - [["lux;AllT" [_aenv _aname _aarg _abody]]] - ;; (|do [$var &type/existential - ;; type* (&type/apply-type ?fun-type* $var)] - ;; (analyse-apply* analyse exo-type type* ?args)) + (|case ?fun-type* + (&/$UnivQ _) (&type/with-var (fn [$var] (|do [type* (&type/apply-type ?fun-type* $var) [=output-t =args] (analyse-apply* analyse exo-type type* ?args)] - (matchv ::M/objects [$var] - [["lux;VarT" ?id]] + (|case $var + (&/$VarT ?id) (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (&/V "lux;BoundT" _aarg))] + (|do [_ (&type/set-var ?id (&/V &/$BoundT 1))] (&type/clean $var =output-t)))] (return (&/T type** =args))) )))) - [["lux;LambdaT" [?input-t ?output-t]]] + (&/$LambdaT ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) - =arg (&&/analyse-1 analyse ?input-t ?arg)] - (return (&/T =output-t (&/|cons =arg =args)))) - - ;; [["lux;VarT" ?id-t]] - ;; (|do [ (&type/deref ?id-t)]) - - [_] + =arg (with-attempt + (&&/analyse-1 analyse ?input-t ?arg) + (fn [err] + (fail (str err "\n" + 'analyse-apply* " " (&type/show-type exo-type) " " (&type/show-type ?fun-type*) + " " "(_ " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) ")"))))] + (return (&/T =output-t (&/Cons$ =arg =args)))) + + _ (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) )) (defn analyse-apply [analyse exo-type form-cursor =fn ?args] (|do [loader &/loader] - (matchv ::M/objects [=fn] - [[=fn-form =fn-type]] - (matchv ::M/objects [=fn-form] - [["lux;Global" [?module ?name]]] - (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] - (matchv ::M/objects [$def] - [["lux;MacroD" macro]] + (|let [[[=fn-type =fn-cursor] =fn-form] =fn] + (|case =fn-form + (&&/$var (&/$Global ?module ?name)) + (|do [[real-name $def] (&&module/find-def ?module ?name)] + (|case $def + (&/$MacroD macro) (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) - :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - ;; :let [_ (when (and ;; (= "lux/control/monad" ?module) - ;; (= "case" ?name)) - ;; (->> (&/|map &/show-ast macro-expansion*) + ;; :let [_ (when (or (= "do" (aget real-name 1)) + ;; ;; (= "..?" (aget real-name 1)) + ;; ;; (= "try$" (aget real-name 1)) + ;; ) + ;; (->> (&/|map &/show-ast macro-expansion) ;; (&/|interpose "\n") ;; (&/fold str "") - ;; (prn ?module "case")))] + ;; (prn (&/ident->text real-name))))] ] - (&/flat-map% (partial analyse exo-type) macro-expansion*)) + (&/flat-map% (partial analyse exo-type) macro-expansion)) - [_] + _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) - =output-t)))))) + (return (&/|list (&&/|meta =output-t =fn-cursor + (&/V &&/$apply (&/T =fn =args)) + )))))) - [_] + _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) - =output-t))))) + (return (&/|list (&&/|meta =output-t =fn-cursor + (&/V &&/$apply (&/T =fn =args)) + ))))) ))) (defn analyse-case [analyse exo-type ?value ?branches] (|do [:let [num-branches (&/|length ?branches)] _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.") _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.") - =value (analyse-1+ analyse ?value) - =value-type (&&/expr-type =value) - =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))] - (return (&/|list (&/T (&/V "case" (&/T =value =match)) - exo-type))))) + =value (&&/analyse-1+ analyse ?value) + =match (&&case/analyse-branches analyse exo-type (&&/expr-type* =value) (&/|as-pairs ?branches)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$case (&/T =value =match)) + ))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] - (|do [exo-type* (&type/actual-type exo-type)] - (matchv ::M/objects [exo-type] - [["lux;AllT" _]] - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-lambda* analyse exo-type** ?self ?arg ?body)))) - ;; (|do [$var &type/existential - ;; exo-type** (&type/apply-type exo-type* $var)] - ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) - - [["lux;LambdaT" [?arg-t ?return-t]]] - (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* - ?arg ?arg-t - (&&/analyse-1 analyse ?return-t ?body))] - (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type*))) - - [_] - (fail (str "[Analyser Error] Functions require function types: " - (&type/show-type exo-type*)))))) + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (|do [exo-type* (&type/deref id)] + (analyse-lambda* analyse exo-type* ?self ?arg ?body)) + ;; Inference + (&type/with-var + (fn [$input] + (&type/with-var + (fn [$output] + (|do [[[lambda-type lambda-cursor] lambda-analysis] (analyse-lambda* analyse (&type/Lambda$ $input $output) ?self ?arg ?body) + =input (&type/resolve-type $input) + =output (&type/resolve-type $output) + inferred-type (|case =input + (&/$VarT iid) + (|do [:let [=input* (next-bound-type =output)] + _ (&type/set-var iid =input*) + =output* (&type/clean $input =output) + =output** (&type/clean $output =output*)] + (return (&type/Univ$ &/Nil$ (embed-inferred-input =input* =output**)))) + + _ + (|do [=output* (&type/clean $input =output) + =output** (&type/clean $output =output*)] + (return (embed-inferred-input =input =output**)))) + _ (&type/check exo-type inferred-type)] + (return (&&/|meta inferred-type lambda-cursor + lambda-analysis))) + )))))) + + _ + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type + (&/$UnivQ _) + (|do [$var &type/existential + exo-type** (&type/apply-type exo-type* $var)] + (analyse-lambda* analyse exo-type** ?self ?arg ?body)) + + (&/$LambdaT ?arg-t ?return-t) + (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* + ?arg ?arg-t + (&&/analyse-1 analyse ?return-t ?body)) + _cursor &/cursor] + (return (&&/|meta exo-type* _cursor + (&/V &&/$lambda (&/T =scope =captured =body))))) + + + + _ + (fail (str "[Analyser Error] Functions require function types: " + (&type/show-type exo-type*))))) + )) (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] - (matchv ::M/objects [exo-type] - [["lux;AllT" [_env _self _arg _body]]] - (&type/with-var - (fn [$var] - (|do [exo-type* (&type/apply-type exo-type $var) - [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] - (matchv ::M/objects [$var] - [["lux;VarT" ?id]] - (|do [? (&type/bound? ?id)] - (if ? - (|do [dtype (&type/deref ?id) - ;; dtype* (&type/actual-type dtype) - ] - (matchv ::M/objects [dtype] - [["lux;BoundT" ?vname]] - (return (&/T _expr exo-type)) - - [["lux;ExT" _]] - (return (&/T _expr exo-type)) - - [["lux;VarT" ?_id]] - (|do [?? (&type/bound? ?_id)] - ;; (return (&/T _expr exo-type)) - (if ?? - (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))) - (return (&/T _expr exo-type))) - ) - - [_] - (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) - (return (&/T _expr exo-type)))))))) + (|case exo-type + (&/$UnivQ _) + (|do [$var &type/existential + exo-type* (&type/apply-type exo-type $var) + [_ _expr] (analyse-lambda** analyse exo-type* ?self ?arg ?body) + _cursor &/cursor] + (return (&&/|meta exo-type _cursor _expr))) + + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (|do [exo-type* (&type/actual-type exo-type)] + (analyse-lambda* analyse exo-type* ?self ?arg ?body)) + ;; Inference + (analyse-lambda* analyse exo-type ?self ?arg ?body))) - [_] + _ (|do [exo-type* (&type/actual-type exo-type)] (analyse-lambda* analyse exo-type* ?self ?arg ?body)) )) @@ -354,75 +459,80 @@ (|do [output (analyse-lambda** analyse exo-type ?self ?arg ?body)] (return (&/|list output)))) -(defn analyse-def [analyse ?name ?value] - ;; (prn 'analyse-def/BEGIN ?name) +(defn analyse-def [analyse compile-token ?name ?value] (|do [module-name &/get-module-name ? (&&module/defined? module-name ?name)] (if ? (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) (|do [=value (&/with-scope ?name - (analyse-1+ analyse ?value)) - =value-type (&&/expr-type =value)] - (matchv ::M/objects [=value] - [[["lux;Global" [?r-module ?r-name]] _]] - (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) - ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) - ;; _ (println)] - ] - (return (&/|list))) - - [_] - (|do [=value-type (&&/expr-type =value) - :let [;; _ (prn 'analyse-def/END ?name) - _ (println 'DEF (str module-name ";" ?name)) - ;; _ (println) - def-data (cond (&type/type= &type/Type =value-type) - (&/V "lux;TypeD" nil) - - :else - (&/V "lux;ValueD" =value-type))] - _ (&&module/define module-name ?name def-data =value-type)] - (return (&/|list (&/V "def" (&/T ?name =value def-data)))))) + (&&/analyse-1+ analyse ?value))] + (|case =value + [_ (&&/$var (&/$Global ?r-module ?r-name))] + (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value))] + (return &/Nil$)) + + _ + (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) + :let [[[def-type def-cursor] def-analysis] =value + _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) + )]] + (return &/Nil$))) )))) -(defn analyse-declare-macro [analyse ?name] - (|do [module-name &/get-module-name] - (return (&/|list (&/V "declare-macro" (&/T module-name ?name)))))) +(defn analyse-declare-macro [analyse compile-token ?name] + (|do [module-name &/get-module-name + _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))] + (return &/Nil$))) + +(defn analyse-declare-tags [tags type-name] + (|do [module-name &/get-module-name + [_ def-data] (&&module/find-def module-name type-name) + def-type (&&module/ensure-type-def def-data) + _ (&&module/declare-tags module-name tags def-type)] + (return &/Nil$))) -(defn analyse-import [analyse compile-module ?path] +(defn analyse-import [analyse compile-module compile-token path] (|do [module-name &/get-module-name - _ (if (= module-name ?path) - (fail (str "[Analyser Error] Module can't import itself: " ?path)) + _ (if (= module-name path) + (fail (str "[Analyser Error] Module can't import itself: " path)) (return nil))] (&/save-module - (|do [already-compiled? (&&module/exists? ?path) - ;; :let [_ (prn 'analyse-import module-name ?path already-compiled?)] - _ (&&module/add-import ?path) - _ (&/when% (not already-compiled?) (compile-module ?path))] - (return (&/|list)))))) - -(defn analyse-export [analyse name] + (|do [already-compiled? (&&module/exists? path) + active? (&/active-module? path) + _ (&/assert! (not active?) (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " module-name)) + _ (&&module/add-import path) + _ (if (not already-compiled?) + (compile-module path) + (return nil))] + (return &/Nil$))))) + +(defn analyse-export [analyse compile-token name] (|do [module-name &/get-module-name _ (&&module/export module-name name)] - (return (&/|list)))) + (return &/Nil$))) -(defn analyse-alias [analyse ex-alias ex-module] +(defn analyse-alias [analyse compile-token ex-alias ex-module] (|do [module-name &/get-module-name _ (&&module/alias module-name ex-alias ex-module)] - (return (&/|list)))) + (return &/Nil$))) (defn analyse-check [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) _ (&type/check exo-type ==type) - =value (&&/analyse-1 analyse ==type ?value)] - (return (&/|list (&/T (&/V "ann" (&/T =value =type)) - ==type))))) + =value (&&/analyse-1 analyse ==type ?value) + _cursor &/cursor + ] + (return (&/|list (&&/|meta ==type _cursor + (&/V &&/$ann (&/T =value =type)) + ))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) _ (&type/check exo-type ==type) - =value (&&/analyse-1 analyse ==type ?value)] - (return (&/|list (&/T (&/V "ann" (&/T =value =type)) - ==type))))) + =value (&&/analyse-1+ analyse ?value) + _cursor &/cursor] + (return (&/|list (&&/|meta ==type _cursor + (&/V &&/$ann (&/T =value =type)) + ))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 68cdc4747..192e80153 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -1,32 +1,37 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.module (:refer-clojure :exclude [alias]) - (:require [clojure.string :as string] - [clojure.core.match :as M :refer [matchv]] + (:require (clojure [string :as string] + [template :refer [do-template]]) + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return return* fail fail*]] + (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] [type :as &type] - [host :as &host]) - [lux.analyser.base :as &&])) + [host :as &host]))) ;; [Utils] -(def ^:private $DEFS 0) -(def ^:private $ALIASES 1) -(def ^:private $IMPORTS 2) +(deftags + ["module-aliases" + "defs" + "imports" + "tags" + "types"]) + (def ^:private +init+ - (&/R ;; "lux;defs" + (&/T ;; "lux;module-aliases" (&/|table) - ;; "lux;module-aliases" + ;; "lux;defs" (&/|table) ;; "lux;imports" - (&/|list) + &/Nil$ + ;; "lux;tags" + (&/|table) + ;; "lux;types" + (&/|table) )) ;; [Exports] @@ -34,121 +39,154 @@ "(-> Text (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/update$ &/$MODULES + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/update$ $imports (partial &/Cons$ module) m)) + ms)) + state) + nil)))) + +(defn set-imports [imports] + "(-> (List Text) (Lux (,)))" + (|do [current-module &/get-module-name] + (fn [state] + (return* (&/update$ &/$modules (fn [ms] (&/|update current-module - (fn [m] (&/update$ $IMPORTS (partial &/|cons module) m)) + (fn [m] (&/set$ $imports imports m)) ms)) state) nil)))) -(defn define [module name def-data type] +(defn define [module name ^objects def-data type] (fn [state] - (matchv ::M/objects [(&/get$ &/$ENVS state)] - [["lux;Cons" [?env ["lux;Nil" _]]]] + (when (and (= "Macro" name) (= "lux" module)) + (&type/set-macro-type! (aget def-data 1))) + (|case (&/get$ &/$envs state) + (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/update$ &/$MODULES + (&/update$ &/$modules (fn [ms] (&/|update module (fn [m] - (&/update$ $DEFS + (&/update$ $defs #(&/|put name (&/T false def-data) %) m)) ms)))) nil) - [_] + _ (fail* (str "[Analyser Error] Can't create a new global definition outside of a global environment: " module ";" name))))) (defn def-type [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] - (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] - (matchv ::M/objects [$def] - [[_ ["lux;TypeD" _]]] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|case $def + [_ (&/$TypeD _)] (return* state &type/Type) - [[_ ["lux;MacroD" _]]] + [_ (&/$MacroD _)] (return* state &type/Macro) - [[_ ["lux;ValueD" _type]]] + [_ (&/$ValueD _type _)] (return* state _type) - [[_ ["lux;AliasD" [?r-module ?r-name]]]] + [_ (&/$AliasD ?r-module ?r-name)] (&/run-state (def-type ?r-module ?r-name) state)) (fail* (str "[Analyser Error] Unknown definition: " (str module ";" name)))) (fail* (str "[Analyser Error] Unknown module: " module))))) +(defn type-def [module name] + "(-> Text Text (Lux Type))" + (fn [state] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|case $def + [_ (&/$TypeD _type)] + (return* state _type) + + _ + (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/T module name))))) + (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T module name))))) + (fail* (str "[Analyser Error] Unknown module: " module))))) + (defn def-alias [a-module a-name r-module r-name type] - ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] - (matchv ::M/objects [(&/get$ &/$ENVS state)] - [["lux;Cons" [?env ["lux;Nil" _]]]] + (|case (&/get$ &/$envs state) + (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/update$ &/$MODULES + (&/update$ &/$modules (fn [ms] (&/|update a-module (fn [m] - (&/update$ $DEFS - #(&/|put a-name (&/T false (&/V "lux;AliasD" (&/T r-module r-name))) %) + (&/update$ $defs + #(&/|put a-name (&/T false (&/V &/$AliasD (&/T r-module r-name))) %) m)) ms)))) nil) - [_] + _ (fail* "[Analyser Error] Can't alias a global definition outside of a global environment.")))) (defn exists? [name] "(-> Text (Lux Bool))" (fn [state] (return* state - (->> state (&/get$ &/$MODULES) (&/|contains? name))))) - -(defn alias [module alias reference] - (fn [state] - (return* (->> state - (&/update$ &/$MODULES - (fn [ms] - (&/|update module - #(&/update$ $ALIASES - (fn [aliases] - (&/|put alias reference aliases)) - %) - ms)))) - nil))) + (->> state (&/get$ &/$modules) (&/|contains? name))))) (defn dealias [name] (|do [current-module &/get-module-name] (fn [state] - (if-let [real-name (->> state (&/get$ &/$MODULES) (&/|get current-module) (&/get$ $ALIASES) (&/|get name))] + (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] (return* state real-name) (fail* (str "Unknown alias: " name)))))) +(defn alias [module alias reference] + (fn [state] + (if-let [real-name (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $module-aliases) (&/|get alias))] + (fail* (str "Can't re-use alias \"" alias "\" @ " module)) + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module + #(&/update$ $module-aliases + (fn [aliases] + (&/|put alias reference aliases)) + %) + ms)))) + nil)))) + (defn find-def [module name] (|do [current-module &/get-module-name] (fn [state] - ;; (prn 'find-def/_0 module name 'current-module current-module) - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] - (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] - (matchv ::M/objects [$def] - [[exported? $$def]] - (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) - (if (or exported? (.equals ^Object current-module module)) - (matchv ::M/objects [$$def] - [["lux;AliasD" [?r-module ?r-name]]] - (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) - ((find-def ?r-module ?r-name) - state)) - - [_] - (return* state (&/T (&/T module name) $$def))) - (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) - (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|let [[exported? $$def] $def] + (if (or exported? (.equals ^Object current-module module)) + (|case $$def + (&/$AliasD ?r-module ?r-name) + ((find-def ?r-module ?r-name) + state) + + _ + (return* state (&/T (&/T module name) $$def))) + (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name))))) + (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) +(defn ensure-type-def [def-data] + "(-> DefData (Lux Type))" + (|case def-data + (&/$TypeD type) + (return type) + + _ + (fail (str "[Analyser Error] Not a type definition: " (&/adt->text def-data))))) + (defn defined? [module name] (&/try-all% (&/|list (|do [_ (find-def module name)] (return true)) @@ -156,57 +194,57 @@ (defn declare-macro [module name] (fn [state] - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))] (if-let [$def (&/|get name $module)] - (matchv ::M/objects [$def] - [[exported? ["lux;ValueD" ?type]]] + (|case $def + [exported? (&/$ValueD ?type _)] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader - :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name))) - (.getField "_datum") + :let [macro (-> (.loadClass loader (str (&host/->class-name module) "." (&/normalize-name name))) + (.getField &/datum-field) (.get nil))]] (fn [state*] - (return* (&/update$ &/$MODULES + (return* (&/update$ &/$modules (fn [$modules] (&/|update module (fn [m] - (&/update$ $DEFS - #(&/|put name (&/T exported? (&/V "lux;MacroD" macro)) %) + (&/update$ $defs + #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %) m)) $modules)) state*) nil))) state) - [[_ ["lux;MacroD" _]]] + [_ (&/$MacroD _)] (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name))) - [[_ ["lux;TypeD" _]]] + [_ _] (fail* (str "[Analyser Error] Definition does not have macro type: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Module does not exist: " module))))) (defn export [module name] (fn [state] - (matchv ::M/objects [(&/get$ &/$ENVS state)] - [["lux;Cons" [?env ["lux;Nil" _]]]] - (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS) (&/|get name))] - (matchv ::M/objects [$def] - [[true _]] + (|case (&/get$ &/$envs state) + (&/$Cons ?env (&/$Nil)) + (if-let [$def (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) (&/|get name))] + (|case $def + [true _] (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) - [[false ?data]] + [false ?data] (return* (->> state - (&/update$ &/$MODULES (fn [ms] + (&/update$ &/$modules (fn [ms] (&/|update module (fn [m] - (&/update$ $DEFS + (&/update$ $defs #(&/|put name (&/T true ?data) %) m)) ms)))) nil)) (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) - [_] + _ (fail* "[Analyser Error] Can't export a global definition outside of a global environment.")))) (def defs @@ -214,36 +252,104 @@ (fn [state] (return* state (&/|map (fn [kv] - (|let [[k v] kv] - (matchv ::M/objects [v] - [[?exported? ?def]] - (do ;; (prn 'defs k ?exported?) - (matchv ::M/objects [?def] - [["lux;AliasD" [?r-module ?r-name]]] - (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) - - [["lux;MacroD" _]] - (&/T ?exported? k "M") - - [["lux;TypeD" _]] - (&/T ?exported? k "T") - - [_] - (&/T ?exported? k "V")))))) - (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))))))) + (|let [[k [?exported? ?def]] kv] + (do ;; (prn 'defs k ?exported?) + (|case ?def + (&/$AliasD ?r-module ?r-name) + (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) + + (&/$MacroD _) + (&/T ?exported? k "M") + + (&/$TypeD _) + (&/T ?exported? k "T") + + _ + (&/T ?exported? k "V"))))) + (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))))))) (def imports (|do [module &/get-module-name] (fn [state] - (return* state (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $IMPORTS)))))) + (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports)))))) (defn create-module [name] + "(-> Text (Lux (,)))" (fn [state] - (return* (&/update$ &/$MODULES #(&/|put name +init+ %) state) nil))) + (return* (&/update$ &/$modules #(&/|put name +init+ %) state) nil))) (defn enter-module [name] + "(-> Text (Lux (,)))" (fn [state] (return* (->> state - (&/update$ &/$MODULES #(&/|put name +init+ %)) - (&/set$ &/$ENVS (&/|list (&/env name)))) + (&/update$ &/$modules #(&/|put name +init+ %)) + (&/set$ &/$envs (&/|list (&/env name)))) nil))) + +(do-template [<name> <tag> <type>] + (defn <name> [module] + <type> + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (return* state (&/get$ <tag> =module)) + (fail* (str "[Lux Error] Unknown module: " module))) + )) + + tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" + types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" + ) + +(defn ensure-undeclared-tags [module tags] + (|do [tags-table (tags-by-module module) + _ (&/map% (fn [tag] + (if (&/|get tag tags-table) + (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) + (return nil))) + tags)] + (return nil))) + +(defn ensure-undeclared-type [module name] + (|do [types-table (types-by-module module) + _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T module name))))] + (return nil))) + +(defn declare-tags [module tag-names type] + "(-> Text (List Text) Type (Lux (,)))" + (|do [_ (ensure-undeclared-tags module tag-names) + type-name (&type/type-name type) + :let [[_module _name] type-name] + _ (&/assert! (= module _module) + (str "[Module Error] Can't define tags for a type belonging to a foreign module: " (&/ident->text type-name))) + _ (ensure-undeclared-type _module _name)] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] + (return* (&/update$ &/$modules + (fn [=modules] + (&/|update module + #(->> % + (&/set$ $tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name (&/T idx tags type) table))) + (&/get$ $tags %) + (&/enumerate tag-names))) + (&/update$ $types (partial &/|put _name (&/T tags type)))) + =modules)) + state) + nil)) + (fail* (str "[Lux Error] Unknown module: " module)))))) + +(do-template [<name> <idx> <doc>] + (defn <name> [module tag-name] + <doc> + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags+type (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags+type <idx>)) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) + + tag-index 0 "(-> Text Text (Lux Int))" + tag-group 1 "(-> Text Text (Lux (List Ident)))" + tag-type 2 "(-> Text Text (Lux Type))" + ) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj new file mode 100644 index 000000000..ddc9616fd --- /dev/null +++ b/src/lux/analyser/record.clj @@ -0,0 +1,43 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.analyser.record + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [deftags |let |do return fail |case]] + [type :as &type]) + (lux.analyser [base :as &&] + [module :as &&module]))) + +;; [Exports] +(defn order-record [pairs] + "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" + (|do [[tag-group tag-type] (|case pairs + (&/$Nil) + (return (&/T &/Nil$ &type/Unit)) + + (&/$Cons [[_ (&/$TagS tag1)] _] _) + (|do [[module name] (&&/resolved-ident tag1) + tags (&&module/tag-group module name) + type (&&module/tag-type module name)] + (return (&/T tags type))) + + _ + (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) + =pairs (&/map% (fn [kv] + (|case kv + [[_ (&/$TagS k)] v] + (|do [=k (&&/resolved-ident k)] + (return (&/T (&/ident->text =k) v))) + + _ + (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) + pairs) + =members (&/map% (fn [tag] + (if-let [member (&/|get tag =pairs)] + (return member) + (fail (str "[Analyser Error] Unknown tag: " tag)))) + (&/|map &/ident->text tag-group))] + (return (&/T =members tag-type)))) diff --git a/src/lux/base.clj b/src/lux/base.clj index eb94c2c90..e9b8896bf 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -1,52 +1,139 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.base (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array)) -;; [Fields] +;; [Tags] +(defmacro deftags [names] + (assert (vector? names)) + `(do ~@(for [[name idx] (map vector names (range (count names)))] + `(def ~(symbol (str "$" name)) ~idx)))) + +;; List +(deftags + ["Nil" + "Cons"]) + +;; Maybe +(deftags + ["None" + "Some"]) + +;; Either +(deftags + ["Left" + "Right"]) + +;; AST +(deftags + ["BoolS" + "IntS" + "RealS" + "CharS" + "TextS" + "SymbolS" + "TagS" + "FormS" + "TupleS" + "RecordS"]) + +;; Type +(deftags + ["DataT" + "VariantT" + "TupleT" + "LambdaT" + "BoundT" + "VarT" + "ExT" + "UnivQ" + "ExQ" + "AppT" + "NamedT"]) + +;; Vars +(deftags + ["Local" + "Global"]) + +;; Definitions +(deftags + ["ValueD" + "TypeD" + "MacroD" + "AliasD"]) + ;; Binding -(def $COUNTER 0) -(def $MAPPINGS 1) +(deftags + ["counter" + "mappings"]) ;; Env -(def $CLOSURE 0) -(def $INNER-CLOSURES 1) -(def $LOCALS 2) -(def $NAME 3) +(deftags + ["name" + "inner-closures" + "locals" + "closure"]) + +;; ModuleState +(deftags + ["Active" + "Compiled" + "Cached"]) ;; Host -(def $CLASSES 0) -(def $LOADER 1) -(def $WRITER 2) - -;; CompilerState -(def $ENVS 0) -(def $EVAL? 1) -(def $HOST 2) -(def $MODULES 3) -(def $SEED 4) -(def $SOURCE 5) -(def $TYPES 6) +(deftags + ["writer" + "loader" + "classes" + "catching" + "module-states"]) + +;; Compiler +(deftags + ["source" + "cursor" + "modules" + "envs" + "type-vars" + "expected" + "seed" + "eval?" + "host"]) ;; [Exports] +(def datum-field "_datum") +(def meta-field "_meta") +(def name-field "_name") +(def hash-field "_hash") +(def compiler-field "_compiler") +(def imports-field "_imports") +(def defs-field "_defs") +(def eval-field "_eval") +(def tags-field "_tags") +(def module-class-name "_") (def +name-separator+ ";") +(def lib-dir "lib") (defn T [& elems] (to-array elems)) -(defn V [tag value] +(defn V [^Long tag value] (to-array [tag value])) -(defn R [& kvs] - (to-array kvs)) +;; Constructors +(def None$ (V $None nil)) +(defn Some$ [x] (V $Some x)) + +(def Nil$ (V $Nil nil)) +(defn Cons$ [h t] (V $Cons (T h t))) + +(def empty-cursor (T "" -1 -1)) (defn get$ [slot ^objects record] (aget record slot)) @@ -63,104 +150,128 @@ record#))) (defn fail* [message] - (V "lux;Left" message)) + (V $Left message)) (defn return* [state value] - (V "lux;Right" (T state value))) + (V $Right (T state value))) + +(defn transform-pattern [pattern] + (cond (vector? pattern) (mapv transform-pattern pattern) + (seq? pattern) (let [parts (mapv transform-pattern (rest pattern))] + (vec (cons (eval (first pattern)) + (list (case (count parts) + 0 '_ + 1 (first parts) + ;; else + `[~@parts]))))) + :else pattern + )) + +(defmacro |case [value & branches] + (assert (= 0 (mod (count branches) 2))) + (let [value* (if (vector? value) + [`(T ~@value)] + [value])] + `(matchv ::M/objects ~value* + ~@(mapcat (fn [[pattern body]] + (list [(transform-pattern pattern)] + body)) + (partition 2 branches))))) (defmacro |let [bindings body] (reduce (fn [inner [left right]] - `(matchv ::M/objects [~right] - [~left] + `(|case ~right + ~left ~inner)) body (reverse (partition 2 bindings)))) (defmacro |list [& elems] (reduce (fn [tail head] - `(V "lux;Cons" (T ~head ~tail))) - `(V "lux;Nil" nil) + `(V $Cons (T ~head ~tail))) + `Nil$ (reverse elems))) (defmacro |table [& elems] (reduce (fn [table [k v]] `(|put ~k ~v ~table)) - `(|list) + `Nil$ (reverse (partition 2 elems)))) (defn |get [slot table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) nil - [["lux;Cons" [[k v] table*]]] + ($Cons [k v] table*) (if (.equals ^Object k slot) v (|get slot table*)))) (defn |put [slot value table] - (matchv ::M/objects [table] - [["lux;Nil" _]] - (V "lux;Cons" (T (T slot value) (V "lux;Nil" nil))) + (|case table + ($Nil) + (V $Cons (T (T slot value) Nil$)) - [["lux;Cons" [[k v] table*]]] + ($Cons [k v] table*) (if (.equals ^Object k slot) - (V "lux;Cons" (T (T slot value) table*)) - (V "lux;Cons" (T (T k v) (|put slot value table*)))))) + (V $Cons (T (T slot value) table*)) + (V $Cons (T (T k v) (|put slot value table*)))) + )) (defn |remove [slot table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) table - [["lux;Cons" [[k v] table*]]] + ($Cons [k v] table*) (if (.equals ^Object k slot) table* - (V "lux;Cons" (T (T k v) (|remove slot table*)))))) + (V $Cons (T (T k v) (|remove slot table*)))))) (defn |update [k f table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) table - [["lux;Cons" [[k* v] table*]]] + ($Cons [k* v] table*) (if (.equals ^Object k k*) - (V "lux;Cons" (T (T k* (f v)) table*)) - (V "lux;Cons" (T (T k* v) (|update k f table*)))))) + (V $Cons (T (T k* (f v)) table*)) + (V $Cons (T (T k* v) (|update k f table*)))))) (defn |head [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] - (assert false) + (|case xs + ($Nil) + (assert false (prn-str '|head)) - [["lux;Cons" [x _]]] + ($Cons x _) x)) (defn |tail [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] - (assert false) + (|case xs + ($Nil) + (assert false (prn-str '|tail)) - [["lux;Cons" [_ xs*]]] + ($Cons _ xs*) xs*)) ;; [Resources/Monads] (defn fail [message] (fn [_] - (V "lux;Left" message))) + (V $Left message))) (defn return [value] (fn [state] - (V "lux;Right" (T state value)))) + (V $Right (T state value)))) (defn bind [m-value step] (fn [state] (let [inputs (m-value state)] - (matchv ::M/objects [inputs] - [["lux;Right" [?state ?datum]]] + (|case inputs + ($Right ?state ?datum) ((step ?datum) ?state) - [["lux;Left" _]] + ($Left _) inputs )))) @@ -172,110 +283,125 @@ ;; else `(bind ~computation (fn [val#] - (matchv ::M/objects [val#] - [~label] + (|case val# + ~label ~inner))))) return (reverse (partition 2 steps)))) ;; [Resources/Combinators] -(defn |cons [head tail] - (V "lux;Cons" (T head tail))) - (defn |++ [xs ys] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) ys - [["lux;Cons" [x xs*]]] - (V "lux;Cons" (T x (|++ xs* ys))))) + ($Cons x xs*) + (V $Cons (T x (|++ xs* ys))))) + +(let [array-class (class (to-array []))] + (defn adt->text [adt] + (if (= array-class (class adt)) + (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") + (pr-str adt)))) (defn |map [f xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [x xs*]]] - (V "lux;Cons" (T (f x) (|map f xs*))))) + ($Cons x xs*) + (V $Cons (T (f x) (|map f xs*))) + + _ + (assert false (prn-str '|map f (adt->text xs))) + )) (defn |empty? [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) true - [["lux;Cons" [_ _]]] + ($Cons _ _) false)) (defn |filter [p xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (if (p x) - (V "lux;Cons" (T x (|filter p xs*))) + (V $Cons (T x (|filter p xs*))) (|filter p xs*)))) (defn flat-map [f xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (|++ (f x) (flat-map f xs*)))) (defn |split-with [p xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (T xs xs) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (if (p x) (|let [[pre post] (|split-with p xs*)] - (T (|cons x pre) post)) - (T (V "lux;Nil" nil) xs)))) + (T (Cons$ x pre) post)) + (T Nil$ xs)))) (defn |contains? [k table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) false - [["lux;Cons" [[k* _] table*]]] + ($Cons [k* _] table*) (or (.equals ^Object k k*) (|contains? k table*)))) +(defn |member? [x xs] + (|case xs + ($Nil) + false + + ($Cons x* xs*) + (or (= x x*) (|member? x xs*)))) + (defn fold [f init xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) init - [["lux;Cons" [x xs*]]] - (fold f (f init x) xs*))) + ($Cons x xs*) + (recur f (f init x) xs*))) (defn fold% [f init xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (return init) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (|do [init* (f init x)] (fold% f init* xs*)))) (defn folds [f init xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (|list init) - [["lux;Cons" [x xs*]]] - (|cons init (folds f (f init x) xs*)))) + ($Cons x xs*) + (Cons$ init (folds f (f init x) xs*)))) (defn |length [xs] (fold (fn [acc _] (inc acc)) 0 xs)) (let [|range* (fn |range* [from to] (if (< from to) - (V "lux;Cons" (T from (|range* (inc from) to))) - (V "lux;Nil" nil)))] + (V $Cons (T from (|range* (inc from) to))) + Nil$))] (defn |range [n] (|range* 0 n))) @@ -288,69 +414,69 @@ _2)) (defn zip2 [xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] - (V "lux;Cons" (T (T x y) (zip2 xs* ys*))) + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + (V $Cons (T (T x y) (zip2 xs* ys*))) [_ _] - (V "lux;Nil" nil))) + Nil$)) (defn |keys [plist] - (matchv ::M/objects [plist] - [["lux;Nil" _]] - (|list) + (|case plist + ($Nil) + Nil$ - [["lux;Cons" [[k v] plist*]]] - (|cons k (|keys plist*)))) + ($Cons [k v] plist*) + (Cons$ k (|keys plist*)))) (defn |vals [plist] - (matchv ::M/objects [plist] - [["lux;Nil" _]] - (|list) + (|case plist + ($Nil) + Nil$ - [["lux;Cons" [[k v] plist*]]] - (|cons v (|vals plist*)))) + ($Cons [k v] plist*) + (Cons$ v (|vals plist*)))) (defn |interpose [sep xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [_ ["lux;Nil" _]]]] + ($Cons _ ($Nil)) xs - [["lux;Cons" [x xs*]]] - (V "lux;Cons" (T x (V "lux;Cons" (T sep (|interpose sep xs*))))))) + ($Cons x xs*) + (V $Cons (T x (V $Cons (T sep (|interpose sep xs*))))))) (do-template [<name> <joiner>] (defn <name> [f xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (return xs) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (|do [y (f x) ys (<name> f xs*)] (return (<joiner> y ys))))) - map% |cons + map% Cons$ flat-map% |++) (defn list-join [xss] - (fold |++ (V "lux;Nil" nil) xss)) + (fold |++ Nil$ xss)) (defn |as-pairs [xs] - (matchv ::M/objects [xs] - [["lux;Cons" [x ["lux;Cons" [y xs*]]]]] - (V "lux;Cons" (T (T x y) (|as-pairs xs*))) + (|case xs + ($Cons x ($Cons y xs*)) + (V $Cons (T (T x y) (|as-pairs xs*))) - [_] - (V "lux;Nil" nil))) + _ + Nil$)) (defn |reverse [xs] (fold (fn [tail head] - (|cons head tail)) - (|list) + (Cons$ head tail)) + Nil$ xs)) (defn assert! [test message] @@ -363,18 +489,18 @@ (return* state state))) (defn try-all% [monads] - (matchv ::M/objects [monads] - [["lux;Nil" _]] + (|case monads + ($Nil) (fail "There are no alternatives to try!") - [["lux;Cons" [m monads*]]] + ($Cons m monads*) (fn [state] (let [output (m state)] - (matchv ::M/objects [output monads*] - [["lux;Right" _] _] + (|case [output monads*] + [($Right _) _] output - [_ ["lux;Nil" _]] + [_ ($Nil)] output [_ _] @@ -385,16 +511,16 @@ (defn repeat% [monad] (try-all% (|list (|do [head monad tail (repeat% monad)] - (return (|cons head tail))) - (return (|list))))) + (return (Cons$ head tail))) + (return Nil$)))) (defn exhaust% [step] (fn [state] - (matchv ::M/objects [(step state)] - [["lux;Right" [state* _]]] + (|case (step state) + ($Right state* _) ((exhaust% step) state*) - [["lux;Left" msg]] + ($Left msg) (if (.equals "[Reader Error] EOF" msg) (return* state nil) (fail* msg))))) @@ -432,27 +558,27 @@ (def loader (fn [state] - (return* state (->> state (get$ $HOST) (get$ $LOADER))))) + (return* state (->> state (get$ $host) (get$ $loader))))) (def classes (fn [state] - (return* state (->> state (get$ $HOST) (get$ $CLASSES))))) + (return* state (->> state (get$ $host) (get$ $classes))))) (def +init-bindings+ - (R ;; "lux;counter" + (T ;; "lux;counter" 0 ;; "lux;mappings" (|table))) (defn env [name] - (R ;; "lux;closure" - +init-bindings+ + (T ;; "lux;name" + name ;; "lux;inner-closures" 0 ;; "lux;locals" +init-bindings+ - ;; "lux;name" - name + ;; "lux;closure" + +init-bindings+ )) (let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String @@ -469,118 +595,147 @@ (try (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) (catch java.lang.reflect.InvocationTargetException e (prn 'InvocationTargetException (.getCause e)) + (prn 'memory-class-loader/findClass class-name (get @store class-name)) (throw e))) (do (prn 'memory-class-loader/store class-name (keys @store)) (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name))))))))) + +;; (deftype Host +;; (& #writer (^ org.objectweb.asm.ClassWriter) +;; #loader (^ java.net.URLClassLoader) +;; #classes (^ clojure.lang.Atom) +;; #catching (List Text) +;; #module-states (List (, Text ModuleState)))) (defn host [_] (let [store (atom {})] - (R ;; "lux;classes" - store + (T ;; "lux;writer" + (V $None nil) ;; "lux;loader" (memory-class-loader store) - ;; "lux;writer" - (V "lux;None" nil)))) + ;; "lux;classes" + store + ;; "lux;catching" + Nil$ + ;; "lux;module-states" + (|table) + ))) (defn init-state [_] - (R ;; "lux;envs" - (|list) - ;; "lux;eval?" - false - ;; "lux;host" - (host nil) + (T ;; "lux;source" + (V $None nil) + ;; "lux;cursor" + (T "" -1 -1) ;; "lux;modules" (|table) - ;; "lux;seed" - 0 - ;; "lux;source" - (V "lux;None" nil) + ;; "lux;envs" + Nil$ ;; "lux;types" +init-bindings+ + ;; "lux;expected" + (V $VariantT Nil$) + ;; "lux;seed" + 0 + ;; "lux;eval?" + false + ;; "lux;host" + (host nil) )) (defn save-module [body] (fn [state] - (matchv ::M/objects [(body state)] - [["lux;Right" [state* output]]] + (|case (body state) + ($Right state* output) (return* (->> state* - (set$ $ENVS (get$ $ENVS state)) - (set$ $SOURCE (get$ $SOURCE state))) + (set$ $envs (get$ $envs state)) + (set$ $source (get$ $source state))) output) - [["lux;Left" msg]] + ($Left msg) (fail* msg)))) (defn with-eval [body] (fn [state] - (matchv ::M/objects [(body (set$ $EVAL? true state))] - [["lux;Right" [state* output]]] - (return* (set$ $EVAL? (get$ $EVAL? state) state*) output) + (|case (body (set$ $eval? true state)) + ($Right state* output) + (return* (set$ $eval? (get$ $eval? state) state*) output) - [["lux;Left" msg]] + ($Left msg) (fail* msg)))) (def get-eval (fn [state] - (return* state (get$ $EVAL? state)))) + (return* state (get$ $eval? state)))) (def get-writer (fn [state] - (let [writer* (->> state (get$ $HOST) (get$ $WRITER))] - (matchv ::M/objects [writer*] - [["lux;Some" datum]] + (let [writer* (->> state (get$ $host) (get$ $writer))] + (|case writer* + ($Some datum) (return* state datum) - [_] + _ (fail* "Writer hasn't been set."))))) (def get-top-local-env (fn [state] - (try (let [top (|head (get$ $ENVS state))] + (try (let [top (|head (get$ $envs state))] (return* state top)) (catch Throwable _ (fail* "No local environment."))))) (def gen-id (fn [state] - (let [seed (get$ $SEED state)] - (return* (set$ $SEED (inc seed) state) seed)))) + (let [seed (get$ $seed state)] + (return* (set$ $seed (inc seed) state) seed)))) (defn ->seq [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (list) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (cons x (->seq xs*)))) (defn ->list [seq] (if (empty? seq) - (|list) - (|cons (first seq) (->list (rest seq))))) + Nil$ + (Cons$ (first seq) (->list (rest seq))))) (defn |repeat [n x] (if (> n 0) - (|cons x (|repeat (dec n) x)) - (|list))) + (Cons$ x (|repeat (dec n) x)) + Nil$)) (def get-module-name (fn [state] - (matchv ::M/objects [(|reverse (get$ $ENVS state))] - [["lux;Nil"]] + (|case (|reverse (get$ $envs state)) + ($Nil) (fail* "[Analyser Error] Can't get the module-name without a module.") - [["lux;Cons" [?global _]]] - (return* state (get$ $NAME ?global))))) + ($Cons ?global _) + (return* state (get$ $name ?global))))) + +(defn find-module [name] + "(-> Text (Lux (Module Compiler)))" + (fn [state] + (if-let [module (|get name (get$ $modules state))] + (return* state module) + (fail* (str "Unknown module: " name))))) + +(def get-current-module + "(Lux (Module Compiler))" + (|do [module-name get-module-name] + (find-module module-name))) (defn with-scope [name body] (fn [state] - (let [output (body (update$ $ENVS #(|cons (env name) %) state))] - (matchv ::M/objects [output] - [["lux;Right" [state* datum]]] - (return* (update$ $ENVS |tail state*) datum) + (let [output (body (update$ $envs #(Cons$ (env name) %) state))] + (|case output + ($Right state* datum) + (return* (update$ $envs |tail state*) datum) - [_] + _ output)))) (defn run-state [monad state] @@ -588,65 +743,100 @@ (defn with-closure [body] (|do [closure-name (|do [top get-top-local-env] - (return (->> top (get$ $INNER-CLOSURES) str)))] + (return (->> top (get$ $inner-closures) str)))] (fn [state] (let [body* (with-scope closure-name body)] - (run-state body* (update$ $ENVS #(|cons (update$ $INNER-CLOSURES inc (|head %)) + (run-state body* (update$ $envs #(Cons$ (update$ $inner-closures inc (|head %)) (|tail %)) state)))))) (def get-scope-name (fn [state] - (return* state (->> state (get$ $ENVS) (|map #(get$ $NAME %)) |reverse)))) + (return* state (->> state (get$ $envs) (|map #(get$ $name %)) |reverse)))) (defn with-writer [writer body] (fn [state] - (let [output (body (update$ $HOST #(set$ $WRITER (V "lux;Some" writer) %) state))] - (matchv ::M/objects [output] - [["lux;Right" [?state ?value]]] - (return* (update$ $HOST #(set$ $WRITER (->> state (get$ $HOST) (get$ $WRITER)) %) ?state) + (let [old-writer (->> state (get$ $host) (get$ $writer)) + output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] + (|case output + ($Right ?state ?value) + (return* (update$ $host #(set$ $writer old-writer %) ?state) ?value) - [_] + _ output)))) +(defn with-expected-type [type body] + "(All [a] (-> Type (Lux a)))" + (fn [state] + (let [output (body (set$ $expected type state))] + (|case output + ($Right ?state ?value) + (return* (set$ $expected (get$ $expected state) ?state) + ?value) + + _ + output)))) + +(defn with-cursor [^objects cursor body] + "(All [a] (-> Cursor (Lux a)))" + (if (= "" (aget cursor 0)) + body + (fn [state] + (let [output (body (set$ $cursor cursor state))] + (|case output + ($Right ?state ?value) + (return* (set$ $cursor (get$ $cursor state) ?state) + ?value) + + _ + output))))) + +(def cursor + ;; (Lux Cursor) + (fn [state] + (return* state (get$ $cursor state)))) + (defn show-ast [ast] - (matchv ::M/objects [ast] - [["lux;Meta" [_ ["lux;BoolS" ?value]]]] + (|case ast + [_ ($BoolS ?value)] (pr-str ?value) - [["lux;Meta" [_ ["lux;IntS" ?value]]]] + [_ ($IntS ?value)] (pr-str ?value) - [["lux;Meta" [_ ["lux;RealS" ?value]]]] + [_ ($RealS ?value)] (pr-str ?value) - [["lux;Meta" [_ ["lux;CharS" ?value]]]] + [_ ($CharS ?value)] (pr-str ?value) - [["lux;Meta" [_ ["lux;TextS" ?value]]]] + [_ ($TextS ?value)] (str "\"" ?value "\"") - [["lux;Meta" [_ ["lux;TagS" [?module ?tag]]]]] + [_ ($TagS ?module ?tag)] (str "#" ?module ";" ?tag) - [["lux;Meta" [_ ["lux;SymbolS" [?module ?ident]]]]] + [_ ($SymbolS ?module ?name)] (if (.equals "" ?module) - ?ident - (str ?module ";" ?ident)) + ?name + (str ?module ";" ?name)) - [["lux;Meta" [_ ["lux;TupleS" ?elems]]]] + [_ ($TupleS ?elems)] (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - [["lux;Meta" [_ ["lux;RecordS" ?elems]]]] + [_ ($RecordS ?elems)] (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - [["lux;Meta" [_ ["lux;FormS" ?elems]]]] + [_ ($FormS ?elems)] (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") + + _ + (assert false (prn-str 'show-ast (adt->text ast))) )) (defn ident->text [ident] @@ -654,70 +844,154 @@ (str ?module ";" ?name))) (defn fold2% [f init xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (|do [init* (f init x y)] (fold2% f init* xs* ys*)) - [["lux;Nil" _] ["lux;Nil" _]] + [($Nil) ($Nil)] (return init) [_ _] (fail "Lists don't match in size."))) (defn map2% [f xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (|do [z (f x y) zs (map2% f xs* ys*)] - (return (|cons z zs))) + (return (Cons$ z zs))) - [["lux;Nil" _] ["lux;Nil" _]] - (return (V "lux;Nil" nil)) + [($Nil) ($Nil)] + (return Nil$) [_ _] (fail "Lists don't match in size."))) (defn map2 [f xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] - (|cons (f x y) (map2 f xs* ys*)) + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + (Cons$ (f x y) (map2 f xs* ys*)) [_ _] - (V "lux;Nil" nil))) + Nil$)) (defn fold2 [f init xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (and init (fold2 f (f init x y) xs* ys*)) - [["lux;Nil" _] ["lux;Nil" _]] + [($Nil) ($Nil)] init [_ _] false)) (defn ^:private enumerate* [idx xs] - (matchv ::M/objects [xs] - [["lux;Cons" [x xs*]]] - (V "lux;Cons" (T (T idx x) - (enumerate* (inc idx) xs*))) + "(All [a] (-> Int (List a) (List (, Int a))))" + (|case xs + ($Cons x xs*) + (V $Cons (T (T idx x) + (enumerate* (inc idx) xs*))) - [["lux;Nil" _]] + ($Nil) xs )) (defn enumerate [xs] + "(All [a] (-> (List a) (List (, Int a))))" (enumerate* 0 xs)) (def modules "(Lux (List Text))" (fn [state] - (return* state (|keys (get$ $MODULES state))))) + (return* state (|keys (get$ $modules state))))) (defn when% [test body] "(-> Bool (Lux (,)) (Lux (,)))" (if test body (return nil))) + +(defn |at [idx xs] + "(All [a] (-> Int (List a) (Maybe a)))" + ;; (prn '|at idx (aget idx 0)) + (|case xs + ($Cons x xs*) + (cond (< idx 0) + (V $None nil) + + (= idx 0) + (V $Some x) + + :else ;; > 1 + (|at (dec idx) xs*)) + + ($Nil) + (V $None nil) + )) + +(defn normalize [ident] + "(-> Ident (Lux Ident))" + (|case ident + ["" name] (|do [module get-module-name] + (return (T module name))) + _ (return ident))) + +(defn ident= [x y] + (|let [[xmodule xname] x + [ymodule yname] y] + (and (= xmodule ymodule) + (= xname yname)))) + +(defn |list-put [idx val xs] + (|case xs + ($Nil) + (V $None nil) + + ($Cons x xs*) + (if (= idx 0) + (V $Some (V $Cons (T val xs*))) + (|case (|list-put (dec idx) val xs*) + ($None) (V $None nil) + ($Some xs**) (V $Some (V $Cons (T x xs**)))) + ))) + +(do-template [<flagger> <asker> <tag>] + (do (defn <flagger> [module] + "(-> Text (Lux (,)))" + (fn [state] + (let [state* (update$ $host (fn [host] + (update$ $module-states + (fn [module-states] + (|put module (V <tag> nil) module-states)) + host)) + state)] + (V $Right (T state* nil))))) + (defn <asker> [module] + "(-> Text (Lux Bool))" + (fn [state] + (if-let [module-state (->> state (get$ $host) (get$ $module-states) (|get module))] + (V $Right (T state (|case module-state + (<tag>) true + _ false))) + (V $Right (T state false))) + ))) + + flag-active-module active-module? $Active + flag-compiled-module compiled-module? $Compiled + flag-cached-module cached-module? $Cached + ) + +(do-template [<name> <default> <op>] + (defn <name> [p xs] + (|case xs + ($Nil) + <default> + + ($Cons x xs*) + (<op> (p x) (|every? p xs*)))) + + |every? true and + |any? false or) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 3449900e0..3052ead09 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -1,19 +1,16 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler (:refer-clojure :exclude [compile]) (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail fail*]] + (lux [base :as & :refer [|let |do return* return fail fail* |case]] [type :as &type] [reader :as &reader] [lexer :as &lexer] @@ -29,334 +26,435 @@ [host :as &&host] [case :as &&case] [lambda :as &&lambda] - [package :as &&package])) + [module :as &&module] + [io :as &&io]) + [lux.packager.program :as &packager-program]) (:import (org.objectweb.asm Opcodes Label ClassWriter MethodVisitor))) ;; [Utils/Compilers] +(def ^:private !source->last-line (atom nil)) + (defn ^:private compile-expression [syntax] - (matchv ::M/objects [syntax] - [[?form ?type]] - (matchv ::M/objects [?form] - [["bool" ?value]] - (&&lux/compile-bool compile-expression ?type ?value) - - [["int" ?value]] - (&&lux/compile-int compile-expression ?type ?value) - - [["real" ?value]] - (&&lux/compile-real compile-expression ?type ?value) - - [["char" ?value]] - (&&lux/compile-char compile-expression ?type ?value) - - [["text" ?value]] - (&&lux/compile-text compile-expression ?type ?value) - - [["tuple" ?elems]] - (&&lux/compile-tuple compile-expression ?type ?elems) - - [["record" ?elems]] - (&&lux/compile-record compile-expression ?type ?elems) - - [["lux;Local" ?idx]] - (&&lux/compile-local compile-expression ?type ?idx) - - [["captured" [?scope ?captured-id ?source]]] - (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) - - [["lux;Global" [?owner-class ?name]]] - (&&lux/compile-global compile-expression ?type ?owner-class ?name) - - [["apply" [?fn ?args]]] - (&&lux/compile-apply compile-expression ?type ?fn ?args) - - [["variant" [?tag ?members]]] - (&&lux/compile-variant compile-expression ?type ?tag ?members) - - [["case" [?value ?match]]] - (&&case/compile-case compile-expression ?type ?value ?match) - - [["lambda" [?scope ?env ?body]]] - (&&lambda/compile-lambda compile-expression ?scope ?env ?body) - - [["ann" [?value-ex ?type-ex]]] - (&&lux/compile-ann compile-expression ?type ?value-ex ?type-ex) - - ;; Characters - [["jvm-ceq" [?x ?y]]] - (&&host/compile-jvm-ceq compile-expression ?type ?x ?y) - - [["jvm-clt" [?x ?y]]] - (&&host/compile-jvm-clt compile-expression ?type ?x ?y) - - [["jvm-cgt" [?x ?y]]] - (&&host/compile-jvm-cgt compile-expression ?type ?x ?y) - - ;; Integer arithmetic - [["jvm-iadd" [?x ?y]]] - (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) - - [["jvm-isub" [?x ?y]]] - (&&host/compile-jvm-isub compile-expression ?type ?x ?y) - - [["jvm-imul" [?x ?y]]] - (&&host/compile-jvm-imul compile-expression ?type ?x ?y) - - [["jvm-idiv" [?x ?y]]] - (&&host/compile-jvm-idiv compile-expression ?type ?x ?y) - - [["jvm-irem" [?x ?y]]] - (&&host/compile-jvm-irem compile-expression ?type ?x ?y) - - [["jvm-ieq" [?x ?y]]] - (&&host/compile-jvm-ieq compile-expression ?type ?x ?y) - - [["jvm-ilt" [?x ?y]]] - (&&host/compile-jvm-ilt compile-expression ?type ?x ?y) - - [["jvm-igt" [?x ?y]]] - (&&host/compile-jvm-igt compile-expression ?type ?x ?y) - - ;; Long arithmetic - [["jvm-ladd" [?x ?y]]] - (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) - - [["jvm-lsub" [?x ?y]]] - (&&host/compile-jvm-lsub compile-expression ?type ?x ?y) - - [["jvm-lmul" [?x ?y]]] - (&&host/compile-jvm-lmul compile-expression ?type ?x ?y) - - [["jvm-ldiv" [?x ?y]]] - (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y) - - [["jvm-lrem" [?x ?y]]] - (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) - - [["jvm-leq" [?x ?y]]] - (&&host/compile-jvm-leq compile-expression ?type ?x ?y) - - [["jvm-llt" [?x ?y]]] - (&&host/compile-jvm-llt compile-expression ?type ?x ?y) - - [["jvm-lgt" [?x ?y]]] - (&&host/compile-jvm-lgt compile-expression ?type ?x ?y) - - ;; Float arithmetic - [["jvm-fadd" [?x ?y]]] - (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) - - [["jvm-fsub" [?x ?y]]] - (&&host/compile-jvm-fsub compile-expression ?type ?x ?y) - - [["jvm-fmul" [?x ?y]]] - (&&host/compile-jvm-fmul compile-expression ?type ?x ?y) - - [["jvm-fdiv" [?x ?y]]] - (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y) - - [["jvm-frem" [?x ?y]]] - (&&host/compile-jvm-frem compile-expression ?type ?x ?y) - - [["jvm-feq" [?x ?y]]] - (&&host/compile-jvm-feq compile-expression ?type ?x ?y) - - [["jvm-flt" [?x ?y]]] - (&&host/compile-jvm-flt compile-expression ?type ?x ?y) - - [["jvm-fgt" [?x ?y]]] - (&&host/compile-jvm-fgt compile-expression ?type ?x ?y) - - ;; Double arithmetic - [["jvm-dadd" [?x ?y]]] - (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) - - [["jvm-dsub" [?x ?y]]] - (&&host/compile-jvm-dsub compile-expression ?type ?x ?y) - - [["jvm-dmul" [?x ?y]]] - (&&host/compile-jvm-dmul compile-expression ?type ?x ?y) - - [["jvm-ddiv" [?x ?y]]] - (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y) - - [["jvm-drem" [?x ?y]]] - (&&host/compile-jvm-drem compile-expression ?type ?x ?y) - - [["jvm-deq" [?x ?y]]] - (&&host/compile-jvm-deq compile-expression ?type ?x ?y) - - [["jvm-dlt" [?x ?y]]] - (&&host/compile-jvm-dlt compile-expression ?type ?x ?y) - - [["jvm-dgt" [?x ?y]]] - (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) - - [["jvm-null" _]] - (&&host/compile-jvm-null compile-expression ?type) - - [["jvm-null?" ?object]] - (&&host/compile-jvm-null? compile-expression ?type ?object) - - [["jvm-new" [?class ?classes ?args]]] - (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args) - - [["jvm-getstatic" [?class ?field]]] - (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field) - - [["jvm-getfield" [?class ?field ?object]]] - (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object) - - [["jvm-putstatic" [?class ?field ?value]]] - (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value) - - [["jvm-putfield" [?class ?field ?object ?value]]] - (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value) - - [["jvm-invokestatic" [?class ?method ?classes ?args]]] - (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args) - - [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] - (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args) - - [["jvm-invokeinterface" [?class ?method ?classes ?object ?args]]] - (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args) - - [["jvm-invokespecial" [?class ?method ?classes ?object ?args]]] - (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) - - [["jvm-new-array" [?class ?length]]] - (&&host/compile-jvm-new-array compile-expression ?type ?class ?length) + (|let [[[?type [_file-name _line _column]] ?form] syntax] + (|do [^MethodVisitor *writer* &/get-writer + :let [debug-label (new Label) + _ (when (not= _line (get @!source->last-line _file-name)) + (doto *writer* + (.visitLabel debug-label) + (.visitLineNumber (int _line) debug-label)) + (swap! !source->last-line assoc _file-name _line))]] + (|case ?form + (&a/$bool ?value) + (&&lux/compile-bool compile-expression ?value) + + (&a/$int ?value) + (&&lux/compile-int compile-expression ?value) + + (&a/$real ?value) + (&&lux/compile-real compile-expression ?value) + + (&a/$char ?value) + (&&lux/compile-char compile-expression ?value) + + (&a/$text ?value) + (&&lux/compile-text compile-expression ?value) + + (&a/$tuple ?elems) + (&&lux/compile-tuple compile-expression ?elems) + + (&a/$var (&/$Local ?idx)) + (&&lux/compile-local compile-expression ?idx) + + (&a/$captured ?scope ?captured-id ?source) + (&&lux/compile-captured compile-expression ?scope ?captured-id ?source) + + (&a/$var (&/$Global ?owner-class ?name)) + (&&lux/compile-global compile-expression ?owner-class ?name) + + (&a/$apply ?fn ?args) + (&&lux/compile-apply compile-expression ?fn ?args) + + (&a/$variant ?tag ?members) + (&&lux/compile-variant compile-expression ?tag ?members) + + (&a/$case ?value ?match) + (&&case/compile-case compile-expression ?value ?match) + + (&a/$lambda ?scope ?env ?body) + (&&lambda/compile-lambda compile-expression ?scope ?env ?body) + + (&a/$ann ?value-ex ?type-ex) + (&&lux/compile-ann compile-expression ?value-ex ?type-ex) + + ;; Characters + (&a/$jvm-ceq ?x ?y) + (&&host/compile-jvm-ceq compile-expression ?x ?y) + + (&a/$jvm-clt ?x ?y) + (&&host/compile-jvm-clt compile-expression ?x ?y) + + (&a/$jvm-cgt ?x ?y) + (&&host/compile-jvm-cgt compile-expression ?x ?y) + + ;; Integer arithmetic + (&a/$jvm-iadd ?x ?y) + (&&host/compile-jvm-iadd compile-expression ?x ?y) + + (&a/$jvm-isub ?x ?y) + (&&host/compile-jvm-isub compile-expression ?x ?y) + + (&a/$jvm-imul ?x ?y) + (&&host/compile-jvm-imul compile-expression ?x ?y) + + (&a/$jvm-idiv ?x ?y) + (&&host/compile-jvm-idiv compile-expression ?x ?y) + + (&a/$jvm-irem ?x ?y) + (&&host/compile-jvm-irem compile-expression ?x ?y) + + (&a/$jvm-ieq ?x ?y) + (&&host/compile-jvm-ieq compile-expression ?x ?y) + + (&a/$jvm-ilt ?x ?y) + (&&host/compile-jvm-ilt compile-expression ?x ?y) + + (&a/$jvm-igt ?x ?y) + (&&host/compile-jvm-igt compile-expression ?x ?y) + + ;; Long arithmetic + (&a/$jvm-ladd ?x ?y) + (&&host/compile-jvm-ladd compile-expression ?x ?y) + + (&a/$jvm-lsub ?x ?y) + (&&host/compile-jvm-lsub compile-expression ?x ?y) + + (&a/$jvm-lmul ?x ?y) + (&&host/compile-jvm-lmul compile-expression ?x ?y) + + (&a/$jvm-ldiv ?x ?y) + (&&host/compile-jvm-ldiv compile-expression ?x ?y) + + (&a/$jvm-lrem ?x ?y) + (&&host/compile-jvm-lrem compile-expression ?x ?y) + + (&a/$jvm-leq ?x ?y) + (&&host/compile-jvm-leq compile-expression ?x ?y) + + (&a/$jvm-llt ?x ?y) + (&&host/compile-jvm-llt compile-expression ?x ?y) + + (&a/$jvm-lgt ?x ?y) + (&&host/compile-jvm-lgt compile-expression ?x ?y) + + ;; Float arithmetic + (&a/$jvm-fadd ?x ?y) + (&&host/compile-jvm-fadd compile-expression ?x ?y) + + (&a/$jvm-fsub ?x ?y) + (&&host/compile-jvm-fsub compile-expression ?x ?y) + + (&a/$jvm-fmul ?x ?y) + (&&host/compile-jvm-fmul compile-expression ?x ?y) + + (&a/$jvm-fdiv ?x ?y) + (&&host/compile-jvm-fdiv compile-expression ?x ?y) + + (&a/$jvm-frem ?x ?y) + (&&host/compile-jvm-frem compile-expression ?x ?y) + + (&a/$jvm-feq ?x ?y) + (&&host/compile-jvm-feq compile-expression ?x ?y) + + (&a/$jvm-flt ?x ?y) + (&&host/compile-jvm-flt compile-expression ?x ?y) + + (&a/$jvm-fgt ?x ?y) + (&&host/compile-jvm-fgt compile-expression ?x ?y) + + ;; Double arithmetic + (&a/$jvm-dadd ?x ?y) + (&&host/compile-jvm-dadd compile-expression ?x ?y) + + (&a/$jvm-dsub ?x ?y) + (&&host/compile-jvm-dsub compile-expression ?x ?y) + + (&a/$jvm-dmul ?x ?y) + (&&host/compile-jvm-dmul compile-expression ?x ?y) + + (&a/$jvm-ddiv ?x ?y) + (&&host/compile-jvm-ddiv compile-expression ?x ?y) + + (&a/$jvm-drem ?x ?y) + (&&host/compile-jvm-drem compile-expression ?x ?y) + + (&a/$jvm-deq ?x ?y) + (&&host/compile-jvm-deq compile-expression ?x ?y) + + (&a/$jvm-dlt ?x ?y) + (&&host/compile-jvm-dlt compile-expression ?x ?y) + + (&a/$jvm-dgt ?x ?y) + (&&host/compile-jvm-dgt compile-expression ?x ?y) + + (&a/$jvm-null _) + (&&host/compile-jvm-null compile-expression) + + (&a/$jvm-null? ?object) + (&&host/compile-jvm-null? compile-expression ?object) + + (&a/$jvm-new ?class ?classes ?args) + (&&host/compile-jvm-new compile-expression ?class ?classes ?args) + + (&a/$jvm-getstatic ?class ?field ?output-type) + (&&host/compile-jvm-getstatic compile-expression ?class ?field ?output-type) + + (&a/$jvm-getfield ?class ?field ?object ?output-type) + (&&host/compile-jvm-getfield compile-expression ?class ?field ?object ?output-type) + + (&a/$jvm-putstatic ?class ?field ?value ?output-type) + (&&host/compile-jvm-putstatic compile-expression ?class ?field ?value) + + (&a/$jvm-putfield ?class ?field ?value ?object ?output-type) + (&&host/compile-jvm-putfield compile-expression ?class ?field ?object ?value) + + (&a/$jvm-invokestatic ?class ?method ?classes ?args ?output-type) + (&&host/compile-jvm-invokestatic compile-expression ?class ?method ?classes ?args ?output-type) + + (&a/$jvm-invokevirtual ?class ?method ?classes ?object ?args ?output-type) + (&&host/compile-jvm-invokevirtual compile-expression ?class ?method ?classes ?object ?args ?output-type) + + (&a/$jvm-invokeinterface ?class ?method ?classes ?object ?args ?output-type) + (&&host/compile-jvm-invokeinterface compile-expression ?class ?method ?classes ?object ?args ?output-type) + + (&a/$jvm-invokespecial ?class ?method ?classes ?object ?args ?output-type) + (&&host/compile-jvm-invokespecial compile-expression ?class ?method ?classes ?object ?args ?output-type) + + (&a/$jvm-znewarray ?length) + (&&host/compile-jvm-znewarray compile-expression ?length) + + (&a/$jvm-zastore ?array ?idx ?elem) + (&&host/compile-jvm-zastore compile-expression ?array ?idx ?elem) + + (&a/$jvm-zaload ?array ?idx) + (&&host/compile-jvm-zaload compile-expression ?array ?idx) + + (&a/$jvm-bnewarray ?length) + (&&host/compile-jvm-bnewarray compile-expression ?length) + + (&a/$jvm-bastore ?array ?idx ?elem) + (&&host/compile-jvm-bastore compile-expression ?array ?idx ?elem) + + (&a/$jvm-baload ?array ?idx) + (&&host/compile-jvm-baload compile-expression ?array ?idx) + + (&a/$jvm-snewarray ?length) + (&&host/compile-jvm-snewarray compile-expression ?length) + + (&a/$jvm-sastore ?array ?idx ?elem) + (&&host/compile-jvm-sastore compile-expression ?array ?idx ?elem) + + (&a/$jvm-saload ?array ?idx) + (&&host/compile-jvm-saload compile-expression ?array ?idx) + + (&a/$jvm-inewarray ?length) + (&&host/compile-jvm-inewarray compile-expression ?length) + + (&a/$jvm-iastore ?array ?idx ?elem) + (&&host/compile-jvm-iastore compile-expression ?array ?idx ?elem) + + (&a/$jvm-iaload ?array ?idx) + (&&host/compile-jvm-iaload compile-expression ?array ?idx) + + (&a/$jvm-lnewarray ?length) + (&&host/compile-jvm-lnewarray compile-expression ?length) - [["jvm-aastore" [?array ?idx ?elem]]] - (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-lastore ?array ?idx ?elem) + (&&host/compile-jvm-lastore compile-expression ?array ?idx ?elem) - [["jvm-aaload" [?array ?idx]]] - (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx) + (&a/$jvm-laload ?array ?idx) + (&&host/compile-jvm-laload compile-expression ?array ?idx) - [["jvm-try" [?body ?catches ?finally]]] - (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) + (&a/$jvm-fnewarray ?length) + (&&host/compile-jvm-fnewarray compile-expression ?length) - [["jvm-throw" ?ex]] - (&&host/compile-jvm-throw compile-expression ?type ?ex) + (&a/$jvm-fastore ?array ?idx ?elem) + (&&host/compile-jvm-fastore compile-expression ?array ?idx ?elem) - [["jvm-monitorenter" ?monitor]] - (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor) + (&a/$jvm-faload ?array ?idx) + (&&host/compile-jvm-faload compile-expression ?array ?idx) - [["jvm-monitorexit" ?monitor]] - (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor) + (&a/$jvm-dnewarray ?length) + (&&host/compile-jvm-dnewarray compile-expression ?length) - [["jvm-d2f" ?value]] - (&&host/compile-jvm-d2f compile-expression ?type ?value) + (&a/$jvm-dastore ?array ?idx ?elem) + (&&host/compile-jvm-dastore compile-expression ?array ?idx ?elem) - [["jvm-d2i" ?value]] - (&&host/compile-jvm-d2i compile-expression ?type ?value) + (&a/$jvm-daload ?array ?idx) + (&&host/compile-jvm-daload compile-expression ?array ?idx) - [["jvm-d2l" ?value]] - (&&host/compile-jvm-d2l compile-expression ?type ?value) - - [["jvm-f2d" ?value]] - (&&host/compile-jvm-f2d compile-expression ?type ?value) + (&a/$jvm-cnewarray ?length) + (&&host/compile-jvm-cnewarray compile-expression ?length) - [["jvm-f2i" ?value]] - (&&host/compile-jvm-f2i compile-expression ?type ?value) + (&a/$jvm-castore ?array ?idx ?elem) + (&&host/compile-jvm-castore compile-expression ?array ?idx ?elem) - [["jvm-f2l" ?value]] - (&&host/compile-jvm-f2l compile-expression ?type ?value) - - [["jvm-i2b" ?value]] - (&&host/compile-jvm-i2b compile-expression ?type ?value) + (&a/$jvm-caload ?array ?idx) + (&&host/compile-jvm-caload compile-expression ?array ?idx) - [["jvm-i2c" ?value]] - (&&host/compile-jvm-i2c compile-expression ?type ?value) + (&a/$jvm-anewarray ?class ?length) + (&&host/compile-jvm-anewarray compile-expression ?class ?length) - [["jvm-i2d" ?value]] - (&&host/compile-jvm-i2d compile-expression ?type ?value) + (&a/$jvm-aastore ?array ?idx ?elem) + (&&host/compile-jvm-aastore compile-expression ?array ?idx ?elem) - [["jvm-i2f" ?value]] - (&&host/compile-jvm-i2f compile-expression ?type ?value) + (&a/$jvm-aaload ?array ?idx) + (&&host/compile-jvm-aaload compile-expression ?array ?idx) - [["jvm-i2l" ?value]] - (&&host/compile-jvm-i2l compile-expression ?type ?value) + (&a/$jvm-arraylength ?array) + (&&host/compile-jvm-arraylength compile-expression ?array) - [["jvm-i2s" ?value]] - (&&host/compile-jvm-i2s compile-expression ?type ?value) + (&a/$jvm-try ?body ?catches ?finally) + (&&host/compile-jvm-try compile-expression ?body ?catches ?finally) - [["jvm-l2d" ?value]] - (&&host/compile-jvm-l2d compile-expression ?type ?value) + (&a/$jvm-throw ?ex) + (&&host/compile-jvm-throw compile-expression ?ex) - [["jvm-l2f" ?value]] - (&&host/compile-jvm-l2f compile-expression ?type ?value) + (&a/$jvm-monitorenter ?monitor) + (&&host/compile-jvm-monitorenter compile-expression ?monitor) - [["jvm-l2i" ?value]] - (&&host/compile-jvm-l2i compile-expression ?type ?value) + (&a/$jvm-monitorexit ?monitor) + (&&host/compile-jvm-monitorexit compile-expression ?monitor) - [["jvm-iand" [?x ?y]]] - (&&host/compile-jvm-iand compile-expression ?type ?x ?y) + (&a/$jvm-d2f ?value) + (&&host/compile-jvm-d2f compile-expression ?value) - [["jvm-ior" [?x ?y]]] - (&&host/compile-jvm-ior compile-expression ?type ?x ?y) + (&a/$jvm-d2i ?value) + (&&host/compile-jvm-d2i compile-expression ?value) - [["jvm-land" [?x ?y]]] - (&&host/compile-jvm-land compile-expression ?type ?x ?y) + (&a/$jvm-d2l ?value) + (&&host/compile-jvm-d2l compile-expression ?value) + + (&a/$jvm-f2d ?value) + (&&host/compile-jvm-f2d compile-expression ?value) - [["jvm-lor" [?x ?y]]] - (&&host/compile-jvm-lor compile-expression ?type ?x ?y) + (&a/$jvm-f2i ?value) + (&&host/compile-jvm-f2i compile-expression ?value) - [["jvm-lxor" [?x ?y]]] - (&&host/compile-jvm-lxor compile-expression ?type ?x ?y) + (&a/$jvm-f2l ?value) + (&&host/compile-jvm-f2l compile-expression ?value) + + (&a/$jvm-i2b ?value) + (&&host/compile-jvm-i2b compile-expression ?value) - [["jvm-lshl" [?x ?y]]] - (&&host/compile-jvm-lshl compile-expression ?type ?x ?y) + (&a/$jvm-i2c ?value) + (&&host/compile-jvm-i2c compile-expression ?value) - [["jvm-lshr" [?x ?y]]] - (&&host/compile-jvm-lshr compile-expression ?type ?x ?y) + (&a/$jvm-i2d ?value) + (&&host/compile-jvm-i2d compile-expression ?value) - [["jvm-lushr" [?x ?y]]] - (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) + (&a/$jvm-i2f ?value) + (&&host/compile-jvm-i2f compile-expression ?value) - [["jvm-instanceof" [?class ?object]]] - (&&host/compile-jvm-instanceof compile-expression ?type ?class ?object) - ) + (&a/$jvm-i2l ?value) + (&&host/compile-jvm-i2l compile-expression ?value) + + (&a/$jvm-i2s ?value) + (&&host/compile-jvm-i2s compile-expression ?value) + + (&a/$jvm-l2d ?value) + (&&host/compile-jvm-l2d compile-expression ?value) + + (&a/$jvm-l2f ?value) + (&&host/compile-jvm-l2f compile-expression ?value) + + (&a/$jvm-l2i ?value) + (&&host/compile-jvm-l2i compile-expression ?value) + + (&a/$jvm-iand ?x ?y) + (&&host/compile-jvm-iand compile-expression ?x ?y) + + (&a/$jvm-ior ?x ?y) + (&&host/compile-jvm-ior compile-expression ?x ?y) + + (&a/$jvm-ixor ?x ?y) + (&&host/compile-jvm-ixor compile-expression ?x ?y) + + (&a/$jvm-ishl ?x ?y) + (&&host/compile-jvm-ishl compile-expression ?x ?y) + + (&a/$jvm-ishr ?x ?y) + (&&host/compile-jvm-ishr compile-expression ?x ?y) + + (&a/$jvm-iushr ?x ?y) + (&&host/compile-jvm-iushr compile-expression ?x ?y) + + (&a/$jvm-land ?x ?y) + (&&host/compile-jvm-land compile-expression ?x ?y) + + (&a/$jvm-lor ?x ?y) + (&&host/compile-jvm-lor compile-expression ?x ?y) + + (&a/$jvm-lxor ?x ?y) + (&&host/compile-jvm-lxor compile-expression ?x ?y) + + (&a/$jvm-lshl ?x ?y) + (&&host/compile-jvm-lshl compile-expression ?x ?y) + + (&a/$jvm-lshr ?x ?y) + (&&host/compile-jvm-lshr compile-expression ?x ?y) + + (&a/$jvm-lushr ?x ?y) + (&&host/compile-jvm-lushr compile-expression ?x ?y) + + (&a/$jvm-instanceof ?class ?object) + (&&host/compile-jvm-instanceof compile-expression ?class ?object) + + _ + (assert false (prn-str 'compile-expression (&/adt->text syntax))) + )) )) -(defn ^:private compile-statement [syntax] - (matchv ::M/objects [syntax] - [["def" [?name ?body ?def-data]]] - (&&lux/compile-def compile-expression ?name ?body ?def-data) +(defn ^:private compile-token [syntax] + (|case syntax + (&a/$def ?name ?body) + (&&lux/compile-def compile-expression ?name ?body) - [["declare-macro" [?module ?name]]] + (&a/$declare-macro ?module ?name) (&&lux/compile-declare-macro compile-expression ?module ?name) - [["jvm-program" ?body]] + (&a/$jvm-program ?body) (&&host/compile-jvm-program compile-expression ?body) - [["jvm-interface" [?name ?supers ?methods]]] - (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) + (&a/$jvm-interface ?name ?supers ?anns ?methods) + (&&host/compile-jvm-interface compile-expression ?name ?supers ?anns ?methods) - [["jvm-class" [?name ?super-class ?interfaces ?fields ?methods]]] - (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods))) + (&a/$jvm-class ?name ?super-class ?interfaces ?anns ?fields ?methods ??env) + (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?anns ?fields ?methods ??env) + + _ + (compile-expression syntax))) (defn ^:private eval! [expr] (&/with-eval (|do [module &/get-module-name id &/gen-id + [file-name _ _] &/cursor :let [class-name (str (&host/->module-class module) "/" id) - ;; _ (prn 'eval! id class-name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) class-name nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_eval" "Ljava/lang/Object;" nil nil) - (doto (.visitEnd))))] + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil) + (doto (.visitEnd))) + (.visitSource file-name nil))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitCode *writer*)] _ (compile-expression expr) :let [_ (doto *writer* - (.visitFieldInsn Opcodes/PUTSTATIC class-name "_eval" "Ljava/lang/Object;") + (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;") (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd))]] @@ -365,73 +463,88 @@ .visitEnd))] _ (&&/save-class! (str id) bytecode) loader &/loader] - (-> (.loadClass ^ClassLoader loader (str (&host/->module-class module) "." id)) - (.getField "_eval") + (-> (.loadClass ^ClassLoader loader (str (&host/->class-name module) "." id)) + (.getField &/eval-field) (.get nil) return)))) (defn ^:private compile-module [name] - ;; (prn 'compile-module name (&&cache/cached? name)) - (let [file-name (str &&/input-dir "/" name ".lux") - file-content (slurp file-name) - file-hash (hash file-content)] - (if (&&cache/cached? name) - (&&cache/load name file-hash compile-module) - (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] - (&/map% compile-statement analysis+))] - (|do [module-exists? (&a-module/exists? name)] - (if module-exists? - (fail "[Compiler Error] Can't redefine a module!") - (|do [_ (&a-module/enter-module name) - :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil file-hash) - .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) - .visitEnd)) - ;; _ (prn 'compile-module name =class) - ]] - (fn [state] - (matchv ::M/objects [((&/with-writer =class - (&/exhaust% compiler-step)) - (&/set$ &/$SOURCE (&reader/from file-name file-content) state))] - [["lux;Right" [?state _]]] - (&/run-state (|do [defs &a-module/defs - imports &a-module/imports - :let [_ (doto =class - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil - (->> defs - (&/|map (fn [_def] - (|let [[?exported ?name ?ann] _def] - (str (if ?exported "1" "0") " " ?name " " ?ann)))) - (&/|interpose "\t") - (&/fold str ""))) - .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil - (->> imports (&/|interpose "\t") (&/fold str ""))) - .visitEnd) - (.visitEnd)) - ;; _ (prn 'CLOSED name =class) - ]] - (&&/save-class! "_" (.toByteArray =class))) - ?state) - - [["lux;Left" ?message]] - (fail* ?message))))))) - ))) + (let [file-name (str name ".lux")] + (|do [file-content (&&io/read-file file-name) + :let [file-hash (hash file-content)]] + (if (&&cache/cached? name) + (&&cache/load name file-hash compile-module) + (let [compiler-step (&optimizer/optimize eval! compile-module compile-token)] + (|do [module-exists? (&a-module/exists? name)] + (if module-exists? + (fail "[Compiler Error] Can't redefine a module!") + (|do [_ (&&cache/delete name) + _ (&a-module/enter-module name) + _ (&/flag-active-module name) + :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/hash-field "I" nil file-hash) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/compiler-field "Ljava/lang/String;" nil &&/version) + .visitEnd) + (.visitSource file-name nil))]] + (fn [state] + (|case ((&/with-writer =class + (&/exhaust% compiler-step)) + (&/set$ &/$source (&reader/from name file-content) state)) + (&/$Right ?state _) + (&/run-state (|do [defs &a-module/defs + imports &a-module/imports + tag-groups &&module/tag-groups + :let [_ (doto =class + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/defs-field "Ljava/lang/String;" nil + (->> defs + (&/|map (fn [_def] + (|let [[?exported ?name ?ann] _def] + (str (if ?exported &&/exported-true &&/exported-false) + &&/exported-separator + ?name + &&/exported-separator + ?ann)))) + (&/|interpose &&/def-separator) + (&/fold str ""))) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/imports-field "Ljava/lang/String;" nil + (->> imports (&/|interpose &&/import-separator) (&/fold str ""))) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/tags-field "Ljava/lang/String;" nil + (->> tag-groups + (&/|map (fn [group] + (|let [[type tags] group] + (->> tags (&/|interpose &&/tag-separator) (&/fold str "") + (str type &&/type-separator))))) + (&/|interpose &&/tag-group-separator) + (&/fold str ""))) + .visitEnd) + (.visitEnd)) + ] + _ (&/flag-compiled-module name)] + (&&/save-class! &/module-class-name (.toByteArray =class))) + ?state) + + (&/$Left ?message) + (fail* ?message))))))) + )) + )) (defn ^:private init! [] + (reset! !source->last-line {}) (.mkdirs (java.io.File. &&/output-dir))) ;; [Resources] (defn compile-program [program-module] (init!) - (matchv ::M/objects [((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil))] - [["lux;Right" [?state _]]] + (|case ((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil)) + (&/$Right ?state _) (do (println "Compilation complete!") (&&cache/clean ?state) - (&&package/package program-module)) + (&packager-program/package program-module)) - [["lux;Left" ?message]] + (&/$Left ?message) (assert false ?message))) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 28339c162..7825bef94 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.base (:require (clojure [template :refer [do-template]] @@ -27,30 +24,43 @@ (java.lang.reflect Field))) ;; [Constants] -(def ^String version "0.2") +(def ^String version "0.3") (def ^String input-dir "source") -(def ^String output-dir "target/jvm") -(def ^String output-package (str output-dir "/program.jar")) +(def ^String output-dir "target/jvm/") +(def ^String output-package (str output-dir "program.jar")) (def ^String function-class "lux/Function") +;; Formats (def ^String local-prefix "l") (def ^String partial-prefix "p") (def ^String closure-prefix "c") (def ^String apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;") +(def exported-true "1") +(def exported-false "0") +(def exported-separator " ") +(def def-separator "\t") +(def import-separator "\t") +(def tag-separator " ") +(def type-separator "\t") +(def tag-group-separator "\n") + ;; [Utils] -(defn ^:private write-file [^String file ^bytes data] - (with-open [stream (BufferedOutputStream. (FileOutputStream. file))] - (.write stream data))) +(defn ^:private write-file [^String file-name ^bytes data] + (let [;; file-name (.toLowerCase file-name) + ] + (do (assert (not (.exists (File. file-name))) (str "Can't overwrite file: " file-name)) + (with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))] + (.write stream data))))) (defn ^:private write-output [module name data] (let [module* (&host/->module-class module) - module-dir (str output-dir "/" module*)] + module-dir (str output-dir module*)] (.mkdirs (File. module-dir)) (write-file (str module-dir "/" name ".class") data))) ;; [Exports] -(defn load-class! [^ClassLoader loader name] +(defn ^Class load-class! [^ClassLoader loader name] ;; (prn 'load-class! name) (.loadClass loader name)) @@ -59,33 +69,28 @@ module &/get-module-name loader &/loader !classes &/classes - :let [real-name (str (&host/->module-class module) "." name) + :let [real-name (str (&host/->class-name module) "." name) _ (swap! !classes assoc real-name bytecode) _ (when (not eval?) (write-output module name bytecode)) _ (load-class! loader real-name)]] (return nil))) -(do-template [<name> <class> <sig> <dup>] - (defn <name> [^MethodVisitor writer] - (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str <sig> (&host/->type-signature <class>)))) - ;; (doto writer - ;; ;; X - ;; (.visitTypeInsn Opcodes/NEW <class>) ;; XW - ;; (.visitInsn <dup>) ;; WXW - ;; (.visitInsn <dup>) ;; WWXW - ;; (.visitInsn Opcodes/POP) ;; WWX - ;; (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>) ;; W - ;; ) - ) +(do-template [<wrap-name> <unwrap-name> <class> <unwrap-method> <prim> <dup>] + (do (defn <wrap-name> [^MethodVisitor writer] + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str "(" <prim> ")" (&host/->type-signature <class>))))) + (defn <unwrap-name> [^MethodVisitor writer] + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST <class>) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <unwrap-method> (str "()" <prim>))))) - wrap-boolean "java/lang/Boolean" "(Z)" Opcodes/DUP_X1 - wrap-byte "java/lang/Byte" "(B)" Opcodes/DUP_X1 - wrap-short "java/lang/Short" "(S)" Opcodes/DUP_X1 - wrap-int "java/lang/Integer" "(I)" Opcodes/DUP_X1 - wrap-long "java/lang/Long" "(J)" Opcodes/DUP_X2 - wrap-float "java/lang/Float" "(F)" Opcodes/DUP_X1 - wrap-double "java/lang/Double" "(D)" Opcodes/DUP_X2 - wrap-char "java/lang/Character" "(C)" Opcodes/DUP_X1 + wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes/DUP_X1 + wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes/DUP_X1 + wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes/DUP_X1 + wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes/DUP_X1 + wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes/DUP_X2 + wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes/DUP_X1 + wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes/DUP_X2 + wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes/DUP_X1 ) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index c0d978146..a35225acf 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -1,23 +1,21 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.cache (:refer-clojure :exclude [load]) (:require [clojure.string :as string] [clojure.java.io :as io] - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail*]] + (lux [base :as & :refer [|do return* return fail fail* |case |let]] [type :as &type] [host :as &host]) (lux.analyser [base :as &a] [module :as &a-module]) - (lux.compiler [base :as &&])) + (lux.compiler [base :as &&] + [io :as &&io])) (:import (java.io File BufferedOutputStream FileOutputStream) @@ -25,6 +23,7 @@ ;; [Utils] (defn ^:private read-file [^File file] + "(-> File (Array Byte))" (with-open [reader (io/input-stream file)] (let [length (.length file) buffer (byte-array length)] @@ -32,29 +31,29 @@ buffer))) (defn ^:private clean-file [^File file] - (if (.isDirectory file) - (do (doseq [f (seq (.listFiles file))] - (clean-file f)) - (.delete file)) - (.delete file))) + "(-> File (,))" + (doseq [^File f (seq (.listFiles file)) + :when (not (.isDirectory f))] + (.delete f))) (defn ^:private get-field [^String field-name ^Class class] + "(-> Text Class Object)" (-> class ^Field (.getField field-name) (.get nil))) ;; [Resources] (defn cached? [module] "(-> Text Bool)" - (.exists (new File (str &&/output-dir "/" (&host/->module-class module) "/_.class")))) + (.exists (new File (str &&/output-dir (&host/->module-class module) "/" &/module-class-name ".class")))) (defn delete [module] "(-> Text (Lux (,)))" (fn [state] - (do (clean-file (new File (str &&/output-dir "/" (&host/->module-class module)))) + (do (clean-file (new File (str &&/output-dir (&host/->module-class module)))) (return* state nil)))) (defn clean [state] "(-> Compiler (,))" - (let [needed-modules (->> state (&/get$ &/$MODULES) &/|keys &/->seq set) + (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) outdated? #(-> ^File % .getName (string/replace &host/module-separator "/") (->> (contains? needed-modules)) not) outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?)) program-file (new File &&/output-package)] @@ -65,6 +64,7 @@ nil)) (defn load [module module-hash compile-module] + "(-> Text Int (-> Text (Lux (,))) (Lux Bool))" (|do [loader &/loader !classes &/classes already-loaded? (&a-module/exists? module) @@ -72,67 +72,78 @@ :let [redo-cache (|do [_ (delete module) _ (compile-module module)] (return false))]] - (do ;; (prn 'load module 'sources already-loaded? - ;; (&/->seq _modules)) - (if already-loaded? - (return true) - (if (cached? module) - (do ;; (prn 'load/HASH module module-hash) - (let [module* (&host/->module-class module) - module-path (str &&/output-dir "/" module*) - class-name (str module* "._") - ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) - (&&/load-class! loader class-name))] - (if (and (= module-hash (get-field "_hash" module-meta)) - (= &&/version (get-field "_compiler" module-meta))) - (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") - ;; _ (prn 'load/IMPORTS module imports) - ] - (|do [loads (&/map% (fn [_import] - (load _import (-> (str &&/input-dir "/" _import ".lux") slurp hash) compile-module)) - (if (= [""] imports) - (&/|list) - (&/->list imports)))] - (if (->> loads &/->seq (every? true?)) - (do (doseq [^File file (seq (.listFiles (File. module-path))) - :let [file-name (.getName file)] - :when (not= "_.class" file-name)] - (let [real-name (second (re-find #"^(.*)\.class$" file-name)) - bytecode (read-file file) - ;; _ (prn 'load module real-name) - ] - (swap! !classes assoc (str module* "." real-name) bytecode))) - (let [defs (string/split (get-field "_defs" module-meta) #"\t")] - ;; (prn 'load module defs) - (|do [_ (&a-module/enter-module module) - _ (&/map% (fn [_def] - (let [[_exported? _name _ann] (string/split _def #" ") - ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) - ] - (|do [_ (case _ann - "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) - "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)] - (&a-module/declare-macro module _name)) - "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) - def-type (get-field "_meta" def-class)] - (matchv ::M/objects [def-type] - [["lux;ValueD" _def-type]] - (&a-module/define module _name def-type _def-type))) - ;; else - (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] - (|do [__type (&a-module/def-type __module __name)] - (do ;; (prn '__type [__module __name] (&type/show-type __type)) - (&a-module/def-alias module _name __module __name __type)))))] - (if (= "1" _exported?) - (&a-module/export module _name) - (return nil))) - )) - (if (= [""] defs) - (&/|list) - (&/->list defs)))] - (return true)))) - redo-cache))) - redo-cache) - )) - redo-cache))))) + (if already-loaded? + (return true) + (if (cached? module) + (let [module* (&host/->class-name module) + module-path (str &&/output-dir module) + class-name (str module* "._") + ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) + (&&/load-class! loader class-name))] + (if (and (= module-hash (get-field &/hash-field module-meta)) + (= &&/version (get-field &/compiler-field module-meta))) + (let [imports (string/split (get-field &/imports-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/import-separator)))] + (|do [loads (&/map% (fn [_import] + (|do [content (&&io/read-file (str _import ".lux")) + _ (load _import (hash content) compile-module)] + (&/cached-module? _import))) + (if (= [""] imports) + &/Nil$ + (&/->list imports)))] + (if (->> loads &/->seq (every? true?)) + (do (doseq [^File file (seq (.listFiles (File. module-path))) + :when (not (.isDirectory file)) + :let [file-name (.getName file)] + :when (not= "_.class" file-name)] + (let [real-name (second (re-find #"^(.*)\.class$" file-name)) + bytecode (read-file file)] + (swap! !classes assoc (str module* "." real-name) bytecode))) + (let [defs (string/split (get-field &/defs-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/def-separator))) + tag-groups (let [all-tags (get-field &/tags-field module-meta)] + (if (= "" all-tags) + &/Nil$ + (-> all-tags + (string/split (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator))) + (->> (map (fn [_group] + (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))] + (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) + &/->list)))] + (|do [_ (&a-module/enter-module module) + _ (&/flag-cached-module module) + _ (&a-module/set-imports imports) + _ (&/map% (fn [_def] + (let [[_exported? _name _ann] (string/split _def #" ")] + (|do [_ (case _ann + "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + def-value (get-field &/datum-field def-class)] + (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) + "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + def-value (get-field &/datum-field def-class)] + (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] + (&a-module/declare-macro module _name))) + "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + def-meta (get-field &/meta-field def-class)] + (|case def-meta + (&/$ValueD def-type _) + (&a-module/define module _name def-meta def-type))) + ;; else + (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] + (|do [__type (&a-module/def-type __module __name)] + (&a-module/def-alias module _name __module __name __type))))] + (if (= &&/exported-true _exported?) + (&a-module/export module _name) + (return nil))) + )) + (if (= [""] defs) + &/Nil$ + (&/->list defs))) + _ (&/map% (fn [group] + (|let [[_type _tags] group] + (|do [=type (&a-module/type-def module _type)] + (&a-module/declare-tags module _tags =type)))) + tag-groups)] + (return true)))) + redo-cache))) + redo-cache) + ) + redo-cache)))) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index fc0cce31f..64237f3db 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -1,22 +1,20 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.case (:require (clojure [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] [analyser :as &analyser] [host :as &host]) + [lux.analyser.case :as &a-case] [lux.compiler.base :as &&]) (:import (org.objectweb.asm Opcodes Label @@ -26,13 +24,13 @@ ;; [Utils] (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private compile-match [^MethodVisitor writer ?match $target $else] - (matchv ::M/objects [?match] - [["StoreTestAC" ?idx]] + (|case ?match + (&a-case/$StoreTestAC ?idx) (doto writer (.visitVarInsn Opcodes/ASTORE ?idx) (.visitJumpInsn Opcodes/GOTO $target)) - [["BoolTestAC" ?value]] + (&a-case/$BoolTestAC ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Boolean") (.visitInsn Opcodes/DUP) @@ -42,29 +40,29 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["IntTestAC" ?value]] + (&a-case/$IntTestAC ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long") (.visitInsn Opcodes/DUP) (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Long" "longValue" "()J") - (.visitLdcInsn ?value) + (.visitLdcInsn (long ?value)) (.visitInsn Opcodes/LCMP) (.visitJumpInsn Opcodes/IFNE $else) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["RealTestAC" ?value]] + (&a-case/$RealTestAC ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double") (.visitInsn Opcodes/DUP) (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Double" "doubleValue" "()D") - (.visitLdcInsn ?value) + (.visitLdcInsn (double ?value)) (.visitInsn Opcodes/DCMPL) (.visitJumpInsn Opcodes/IFNE $else) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["CharTestAC" ?value]] + (&a-case/$CharTestAC ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Character") (.visitInsn Opcodes/DUP) @@ -74,7 +72,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["TextTestAC" ?value]] + (&a-case/$TextTestAC ?value) (doto writer (.visitInsn Opcodes/DUP) (.visitLdcInsn ?value) @@ -83,7 +81,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["TupleTestAC" ?members]] + (&a-case/$TupleTestAC ?members) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (-> (doto (.visitInsn Opcodes/DUP) @@ -101,36 +99,14 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["RecordTestAC" ?slots]] - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (-> (doto (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)) - (.visitInsn Opcodes/AALOAD) - (compile-match test $next $sub-else) - (.visitLabel $sub-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else) - (.visitLabel $next)) - (->> (|let [[idx [_ test]] idx+member - $next (new Label) - $sub-else (new Label)]) - (doseq [idx+member (->> ?slots - &/->seq - (sort compare-kv) - &/->list - &/enumerate - &/->seq)]))) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target)) - - [["VariantTestAC" [?tag ?test]]] + (&a-case/$VariantTestAC ?tag ?count ?test) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) (.visitInsn Opcodes/AALOAD) (.visitLdcInsn ?tag) + (&&/wrap-long) (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") (.visitJumpInsn Opcodes/IFEQ $else) (.visitInsn Opcodes/DUP) @@ -185,7 +161,7 @@ )) ;; [Resources] -(defn compile-case [compile *type* ?value ?matches] +(defn compile-case [compile ?value ?matches] (|do [^MethodVisitor *writer* &/get-writer :let [$end (new Label)] _ (compile ?value) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 346b66fd2..c364091ba 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -1,30 +1,29 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.host (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] [analyser :as &analyser] [host :as &host]) + [lux.type.host :as &host-type] [lux.analyser.base :as &a] [lux.compiler.base :as &&] :reload) (:import (org.objectweb.asm Opcodes Label ClassWriter - MethodVisitor))) + MethodVisitor + AnnotationVisitor))) ;; [Utils] (let [class+method+sig {"boolean" [(&host/->class "java.lang.Boolean") "booleanValue" "()Z"] @@ -51,41 +50,47 @@ double-class "java.lang.Double" char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] - (matchv ::M/objects [*type*] - [["lux;TupleT" ["lux;Nil" _]]] + (|case *type* + (&/$TupleT (&/$Nil)) (.visitInsn *writer* Opcodes/ACONST_NULL) - [["lux;DataT" "boolean"]] + (&/$DataT "boolean" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class))) - [["lux;DataT" "byte"]] + (&/$DataT "byte" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class byte-class) "valueOf" (str "(B)" (&host/->type-signature byte-class))) - [["lux;DataT" "short"]] + (&/$DataT "short" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class short-class) "valueOf" (str "(S)" (&host/->type-signature short-class))) - [["lux;DataT" "int"]] + (&/$DataT "int" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class int-class) "valueOf" (str "(I)" (&host/->type-signature int-class))) - [["lux;DataT" "long"]] + (&/$DataT "long" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class long-class) "valueOf" (str "(J)" (&host/->type-signature long-class))) - [["lux;DataT" "float"]] + (&/$DataT "float" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class float-class) "valueOf" (str "(F)" (&host/->type-signature float-class))) - [["lux;DataT" "double"]] + (&/$DataT "double" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class double-class) "valueOf" (str "(D)" (&host/->type-signature double-class))) - [["lux;DataT" "char"]] + (&/$DataT "char" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) - [["lux;DataT" _]] - nil) + (&/$DataT _ _) + nil + + (&/$NamedT ?name ?type) + (prepare-return! *writer* ?type) + + _ + (assert false (str 'prepare-return! " " (&type/show-type *type*)))) *writer*)) ;; [Resources] (do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrap>] - (defn <name> [compile *type* ?x ?y] + (defn <name> [compile ?x ?y] (|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)] ^MethodVisitor *writer* &/get-writer _ (compile ?x) @@ -127,14 +132,14 @@ ) (do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig>] - (defn <name> [compile *type* ?x ?y] + (defn <name> [compile ?x ?y] (|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)] ^MethodVisitor *writer* &/get-writer - _ (compile ?x) + _ (compile ?y) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))] - _ (compile ?y) + _ (compile ?x) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>)) @@ -159,14 +164,14 @@ ) (do-template [<name> <cmpcode> <cmp-output> <wrapper-class> <value-method> <value-method-sig>] - (defn <name> [compile *type* ?x ?y] + (defn <name> [compile ?x ?y] (|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)] ^MethodVisitor *writer* &/get-writer - _ (compile ?x) + _ (compile ?y) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))] - _ (compile ?y) + _ (compile ?x) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>)) @@ -191,31 +196,32 @@ compile-jvm-flt Opcodes/FCMPG 1 "java.lang.Float" "floatValue" "()F" compile-jvm-fgt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F" - compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()I" - compile-jvm-dlt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()I" - compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()I" + compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()D" + compile-jvm-dlt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()D" + compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()D" ) -(defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] +(defn compile-jvm-invokestatic [compile ?class ?method ?classes ?args ?output-type] (|do [^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] + :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (&/map2% (fn [class-name arg] (|do [ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] (return ret))) ?classes ?args) :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&type/as-obj ?class)) ?method method-sig) - (prepare-return! *type*))]] + (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&host-type/as-obj ?class)) ?method method-sig) + (prepare-return! ?output-type))]] (return nil))) (do-template [<name> <op>] - (defn <name> [compile *type* ?class ?method ?classes ?object ?args] - (|do [:let [?class* (&host/->class (&type/as-obj ?class))] + (defn <name> [compile ?class ?method ?classes ?object ?args ?output-type] + (|do [:let [?class* (&host/->class (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] + :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (compile ?object) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] + :let [_ (when (not= "<init>" ?method) + (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] _ (&/map2% (fn [class-name arg] (|do [ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] @@ -223,38 +229,20 @@ ?classes ?args) :let [_ (doto *writer* (.visitMethodInsn <op> ?class* ?method method-sig) - (prepare-return! *type*))]] + (prepare-return! ?output-type))]] (return nil))) compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE - ;; compile-jvm-invokespecial Opcodes/INVOKESPECIAL + compile-jvm-invokespecial Opcodes/INVOKESPECIAL ) -(defn compile-jvm-invokespecial [compile *type* ?class ?method ?classes ?object ?args] - (|do [:let [?class* (&host/->class (&type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] - _ (compile ?object) - ;; :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] - :let [_ (when (not= "<init>" ?method) - (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] - _ (&/map2% (fn [class-name arg] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - ?classes ?args) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESPECIAL ?class* ?method method-sig) - (prepare-return! *type*))]] - (return nil))) - -(defn compile-jvm-null [compile *type*] +(defn compile-jvm-null [compile] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] (return nil))) -(defn compile-jvm-null? [compile *type* ?object] +(defn compile-jvm-null? [compile ?object] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?object) :let [$then (new Label) @@ -268,7 +256,7 @@ (.visitLabel $end))]] (return nil))) -(defn compile-jvm-new [compile *type* ?class ?classes ?args] +(defn compile-jvm-new [compile ?class ?classes ?args] (|do [^MethodVisitor *writer* &/get-writer :let [init-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")V") class* (&host/->class ?class) @@ -284,79 +272,129 @@ (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]] (return nil))) -(defn compile-jvm-new-array [compile *type* ?class ?length] +(do-template [<prim-type> <new-name> <load-name> <load-op> <store-name> <store-op> <wrapper> <unwrapper>] + (do (defn <new-name> [compile ?length] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile ?length) + :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY <prim-type>)]] + (return nil))) + + (defn <load-name> [compile ?array ?idx] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitInsn <load-op>) + <wrapper>)]] + (return nil))) + + (defn <store-name> [compile ?array ?idx ?elem] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?elem) + :let [_ (doto *writer* + <unwrapper> + (.visitInsn <store-op>))]] + (return nil))) + ) + + Opcodes/T_BOOLEAN compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean + Opcodes/T_BYTE compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte + Opcodes/T_SHORT compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short + Opcodes/T_INT compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int + Opcodes/T_LONG compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long + Opcodes/T_FLOAT compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float + Opcodes/T_DOUBLE compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double + Opcodes/T_CHAR compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char + ) + +(defn compile-jvm-anewarray [compile ?class ?length] (|do [^MethodVisitor *writer* &/get-writer + _ (compile ?length) + :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host/->class ?class))]] + (return nil))) + +(defn compile-jvm-aaload [compile ?array ?idx] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + _ (compile ?idx) :let [_ (doto *writer* - (.visitLdcInsn (int ?length)) - (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class ?class)))]] + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] (return nil))) -(defn compile-jvm-aastore [compile *type* ?array ?idx ?elem] +(defn compile-jvm-aastore [compile ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int ?idx)))] + &&/unwrap-long + (.visitInsn Opcodes/L2I))] _ (compile ?elem) :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) -(defn compile-jvm-aaload [compile *type* ?array ?idx] +(defn compile-jvm-arraylength [compile ?array] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] :let [_ (doto *writer* - (.visitLdcInsn (int ?idx)) - (.visitInsn Opcodes/AALOAD))]] + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] (return nil))) -(defn compile-jvm-getstatic [compile *type* ?class ?field] +(defn compile-jvm-getstatic [compile ?class ?field ?output-type] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*)) - (prepare-return! *type*))]] + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&host-type/as-obj ?class)) ?field (&host/->java-sig ?output-type)) + (prepare-return! ?output-type))]] (return nil))) -(defn compile-jvm-getfield [compile *type* ?class ?field ?object] - (|do [:let [class* (&host/->class (&type/as-obj ?class))] +(defn compile-jvm-getfield [compile ?class ?field ?object ?output-type] + (|do [:let [class* (&host/->class (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer _ (compile ?object) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST class*) - (.visitFieldInsn Opcodes/GETFIELD class* ?field (&host/->java-sig *type*)) - (prepare-return! *type*))]] + (.visitFieldInsn Opcodes/GETFIELD class* ?field (&host/->java-sig ?output-type)) + (prepare-return! ?output-type))]] (return nil))) -(defn compile-jvm-putstatic [compile *type* ?class ?field ?value] +(defn compile-jvm-putstatic [compile ?class ?field ?value ?output-type] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?value) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*))]] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&host-type/as-obj ?class)) ?field (&host/->java-sig ?output-type))] + :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] (return nil))) -(defn compile-jvm-putfield [compile *type* ?class ?field ?object ?value] - (|do [:let [class* (&host/->class (&type/as-obj ?class))] +(defn compile-jvm-putfield [compile ?class ?field ?object ?value ?output-type] + (|do [:let [class* (&host/->class (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer _ (compile ?object) + :let [_ (.visitInsn *writer* Opcodes/DUP)] _ (compile ?value) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] - :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD class* ?field (&host/->java-sig *type*))]] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD class* ?field (&host/->java-sig ?output-type))]] (return nil))) -(defn ^:private modifiers->int [mods] - (+ (case (:visibility mods) - "default" 0 - "public" Opcodes/ACC_PUBLIC - "private" Opcodes/ACC_PRIVATE - "protected" Opcodes/ACC_PROTECTED) - (if (:static? mods) Opcodes/ACC_STATIC 0) - (if (:final? mods) Opcodes/ACC_FINAL 0) - (if (:abstract? mods) Opcodes/ACC_ABSTRACT 0) - (case (:concurrency mods) - "synchronized" Opcodes/ACC_SYNCHRONIZED - "volatile" Opcodes/ACC_VOLATILE - ;; else - 0))) - -(defn compile-jvm-instanceof [compile *type* class object] +(defn compile-jvm-instanceof [compile class object] (|do [:let [class* (&host/->class class)] ^MethodVisitor *writer* &/get-writer _ (compile object) @@ -365,69 +403,147 @@ (&&/wrap-boolean))]] (return nil))) -(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods] - (|do [module &/get-module-name] - (let [super-class* (&host/->class ?super-class) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (str module "/" ?name) nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))) - _ (&/|map (fn [field] - (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) - (&host/->type-signature (:type field)) nil nil) - (.visitEnd))) - ?fields)] - (|do [_ (&/map% (fn [method] - (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" - (&host/->type-signature (:output method)))] - (&/with-writer (.visitMethod =class (modifiers->int (:modifiers method)) - (:name method) - signature nil nil) - (|do [^MethodVisitor =method &/get-writer - :let [_ (.visitCode =method)] - _ (compile (:body method)) - :let [_ (doto =method - (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))))) - ?methods)] - (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))))) - -(defn compile-jvm-interface [compile ?name ?supers ?methods] - ;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str)) - (|do [module &/get-module-name] +(defn ^:private compile-annotation [writer ann] + (doto ^AnnotationVisitor (.visitAnnotation writer (&host/->class (:name ann)) true) + (-> (.visit param-name param-value) + (->> (|let [[param-name param-value] param]) + (doseq [param (&/->seq (:params ann))]))) + (.visitEnd)) + nil) + +(defn ^:private compile-field [^ClassWriter writer field] + (let [=field (.visitField writer (&host/modifiers->int (:modifiers field)) (:name field) + (&host/->type-signature (:type field)) nil nil)] + (&/|map (partial compile-annotation =field) (:anns field)) + (.visitEnd =field) + nil)) + +(defn ^:private compile-method-return [^MethodVisitor writer output] + (case output + "void" (.visitInsn writer Opcodes/RETURN) + "boolean" (doto writer + &&/unwrap-boolean + (.visitInsn Opcodes/IRETURN)) + "byte" (doto writer + &&/unwrap-byte + (.visitInsn Opcodes/IRETURN)) + "short" (doto writer + &&/unwrap-short + (.visitInsn Opcodes/IRETURN)) + "int" (doto writer + &&/unwrap-int + (.visitInsn Opcodes/IRETURN)) + "long" (doto writer + &&/unwrap-long + (.visitInsn Opcodes/LRETURN)) + "float" (doto writer + &&/unwrap-float + (.visitInsn Opcodes/FRETURN)) + "double" (doto writer + &&/unwrap-double + (.visitInsn Opcodes/DRETURN)) + "char" (doto writer + &&/unwrap-char + (.visitInsn Opcodes/IRETURN)) + ;; else + (.visitInsn writer Opcodes/ARETURN))) + +(defn ^:private compile-method [compile ^ClassWriter class-writer method] + (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" + (&host/->type-signature (:output method)))] + (&/with-writer (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) + (:name method) + signature + nil + (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) (:anns method)) + _ (.visitCode =method)] + _ (compile (:body method)) + :let [_ (doto =method + (compile-method-return (:output method)) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) + +(defn ^:private compile-method-decl [^ClassWriter class-writer method] + (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" + (&host/->type-signature (:output method)))] + (let [=method (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String)))] + (&/|map (partial compile-annotation =method) (:anns method)) + nil))) + +(let [clo-field-sig (&host/->type-signature "java.lang.Object") + <init>-return "V"] + (defn ^:private anon-class-<init>-signature [env] + (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" + <init>-return)) + + (defn ^:private add-anon-class-<init> [^ClassWriter class-writer class-name env] + (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "<init>" (anon-class-<init>-signature env) nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V") + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) + (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [_ (&a/$captured _ ?captured-id ?source)]]) + (doseq [?name+?captured (&/->seq env)]))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ) + +(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?anns ?fields ?methods env] + (|do [module &/get-module-name + [file-name _ _] &/cursor + :let [full-name (str module "/" ?name) + super-class* (&host/->class ?super-class) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + full-name nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String))) + (.visitSource file-name nil)) + _ (&/|map (partial compile-annotation =class) ?anns) + _ (&/|map (partial compile-field =class) + ?fields)] + _ (&/map% (partial compile-method compile =class) ?methods) + :let [_ (when env + (add-anon-class-<init> =class full-name env))]] + (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) + +(defn compile-jvm-interface [compile ?name ?supers ?anns ?methods] + (|do [module &/get-module-name + [file-name _ _] &/cursor] (let [=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) - (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String)))) - _ (do (&/|map (fn [method] - (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" - (&host/->type-signature (:output method)))] - (.visitMethod =interface (modifiers->int (:modifiers method)) (:name method) signature nil nil))) - ?methods) + (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String))) + (.visitSource file-name nil)) + _ (&/|map (partial compile-annotation =interface) ?anns) + _ (do (&/|map (partial compile-method-decl =interface) ?methods) (.visitEnd =interface))] (&&/save-class! ?name (.toByteArray =interface))))) -(defn compile-jvm-try [compile *type* ?body ?catches ?finally] +(defn compile-jvm-try [compile ?body ?catches ?finally] (|do [^MethodVisitor *writer* &/get-writer :let [$from (new Label) $to (new Label) $end (new Label) $catch-finally (new Label) - compile-finally (matchv ::M/objects [?finally] - [["lux;Some" ?finally*]] (|do [_ (return nil) - _ (compile ?finally*) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) - [["lux;None" _]] (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) + compile-finally (|case ?finally + (&/$Some ?finally*) (|do [_ (return nil) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) + (&/$None) (|do [_ (return nil) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] + (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) ?catches) - _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) - ;; :let [_ (prn 'HANDLER ?ex-class (&host/->class ?ex-class) $handler-start $handler-end $from $to $catch-finally)] - ] + _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries)] (doto *writer* (.visitTryCatchBlock $from $to $handler-start (&host/->class ?ex-class)) (.visitTryCatchBlock $handler-start $handler-end $catch-finally nil))) @@ -445,28 +561,27 @@ compile-finally)) ?catches catch-boundaries) - ;; :let [_ (prn 'handlers (&/->seq handlers))] :let [_ (.visitLabel *writer* $catch-finally)] - _ (matchv ::M/objects [?finally] - [["lux;Some" ?finally*]] (|do [_ (compile ?finally*) - :let [_ (.visitInsn *writer* Opcodes/POP)] - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil)) - [["lux;None" _]] (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + _ (|case ?finally + (&/$Some ?finally*) (|do [_ (compile ?finally*) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) + (&/$None) (|do [_ (return nil) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] :let [_ (.visitLabel *writer* $end)]] (return nil))) -(defn compile-jvm-throw [compile *type* ?ex] +(defn compile-jvm-throw [compile ?ex] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?ex) :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] (return nil))) (do-template [<name> <op>] - (defn <name> [compile *type* ?monitor] + (defn <name> [compile ?monitor] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?monitor) :let [_ (doto *writer* @@ -479,7 +594,7 @@ ) (do-template [<name> <op> <from-class> <from-method> <from-sig> <to-class> <to-sig>] - (defn <name> [compile *type* ?value] + (defn <name> [compile ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW (&host/->class <to-class>)) @@ -513,7 +628,7 @@ ) (do-template [<name> <op> <from1-method> <from1-sig> <from1-class> <from2-method> <from2-sig> <from2-class> <to-class> <to-sig>] - (defn <name> [compile *type* ?x ?y] + (defn <name> [compile ?x ?y] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW (&host/->class <to-class>)) @@ -533,11 +648,14 @@ compile-jvm-iand Opcodes/IAND "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" compile-jvm-ior Opcodes/IOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-ixor Opcodes/IXOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-ishl Opcodes/ISHL "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-ishr Opcodes/ISHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-iushr Opcodes/IUSHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" compile-jvm-land Opcodes/LAND "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" compile-jvm-lor Opcodes/LOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" compile-jvm-lxor Opcodes/LXOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" - compile-jvm-lshl Opcodes/LSHL "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" compile-jvm-lshr Opcodes/LSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" compile-jvm-lushr Opcodes/LUSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" @@ -545,23 +663,20 @@ (defn compile-jvm-program [compile ?body] (|do [module-name &/get-module-name - ;; :let [_ (prn 'compile-jvm-program module-name)] ^ClassWriter *writer* &/get-writer] (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) (.visitCode)) (|do [^MethodVisitor main-writer &/get-writer - :let [;; _ (prn "#1" module-name *writer*) - $loop (new Label) - ;; _ (prn "#2") + :let [$loop (new Label) $end (new Label) - ;; _ (prn "#3") _ (doto main-writer ;; Tail: Begin (.visitLdcInsn (int 2)) ;; S (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI - (.visitLdcInsn "lux;Nil") ;; VVIT + (.visitLdcInsn &/$Nil) ;; VVIT + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -606,7 +721,8 @@ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; I2V (.visitInsn Opcodes/DUP) ;; I2VV (.visitLdcInsn (int 0)) ;; I2VVI - (.visitLdcInsn "lux;Cons") ;; I2VVIT + (.visitLdcInsn &/$Cons) ;; I2VVIT + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; I2V (.visitInsn Opcodes/DUP_X1) ;; IV2V (.visitInsn Opcodes/SWAP) ;; IVV2 @@ -621,20 +737,14 @@ (.visitInsn Opcodes/POP) ;; V (.visitVarInsn Opcodes/ASTORE (int 0)) ;; ) - ;; _ (prn "#4") ] _ (compile ?body) - :let [;; _ (prn "#5") - _ (doto main-writer + :let [_ (doto main-writer (.visitInsn Opcodes/ACONST_NULL) - (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature)) - ;; _ (prn "#6") - ] + (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature))] :let [_ (doto main-writer (.visitInsn Opcodes/POP) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) - (.visitEnd)) - ;; _ (prn "#7") - ]] + (.visitEnd))]] (return nil))))) diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj new file mode 100644 index 000000000..bc6fa854d --- /dev/null +++ b/src/lux/compiler/io.clj @@ -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/. + +(ns lux.compiler.io + (:require (lux [base :as & :refer [|let |do return* return fail fail*]]) + (lux.compiler [base :as &&]) + [lux.lib.loader :as &lib])) + +;; [Utils] +(def ^:private !libs (atom nil)) + +(defn ^:private libs-imported? [] + (not (nil? @!libs))) + +(defn ^:private init-libs! [] + (reset! !libs (&lib/load))) + +;; [Resources] +(defn read-file [^String file-name] + (let [file (new java.io.File (str &&/input-dir "/" file-name))] + (if (.exists file) + (return (slurp file)) + (do (when (not (libs-imported?)) + (init-libs!)) + (if-let [code (get @!libs file-name)] + (return code) + (fail (str "[I/O Error] File doesn't exist: " file-name))))))) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index ccd12e68a..cb8ad0037 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -1,18 +1,15 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.lambda (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail*]] + (lux [base :as & :refer [|do return* return fail fail* |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -46,8 +43,8 @@ (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (matchv ::M/objects [?name+?captured] - [[?name [["captured" [_ ?captured-id ?source]] _]]]) + (|case ?name+?captured + [?name [_ (&a/$captured _ ?captured-id ?source)]]) (doseq [?name+?captured (&/->seq env)]))) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -63,19 +60,20 @@ (.visitMaxs 0 0) (.visitEnd))) -(defn ^:private add-lambda-impl [class compile impl-signature impl-body] - (&/with-writer (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) - (.visitCode)) - (|do [^MethodVisitor *writer* &/get-writer - :let [$start (new Label) - $end (new Label)] - ret (compile impl-body) - :let [_ (doto *writer* - (.visitLabel $end) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return ret)))) +(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)] + (defn ^:private add-lambda-impl [class compile impl-signature impl-body] + (&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" impl-signature nil nil) + (.visitCode)) + (|do [^MethodVisitor *writer* &/get-writer + :let [$start (new Label) + $end (new Label)] + ret (compile impl-body) + :let [_ (doto *writer* + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return ret))))) (defn ^:private instance-closure [compile lambda-class closed-over init-signature] (|do [^MethodVisitor *writer* &/get-writer @@ -83,31 +81,34 @@ (.visitTypeInsn Opcodes/NEW lambda-class) (.visitInsn Opcodes/DUP))] _ (&/map% (fn [?name+?captured] - (matchv ::M/objects [?name+?captured] - [[?name [["captured" [_ _ ?source]] _]]] + (|case ?name+?captured + [?name [_ (&a/$captured _ _ ?source)]] (compile ?source))) closed-over) :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" init-signature)]] (return nil))) ;; [Exports] -(defn compile-lambda [compile ?scope ?env ?body] - ;; (prn 'compile-lambda (->> ?scope &/->seq)) - (|do [:let [name (&host/location (&/|tail ?scope)) - class-name (str (&host/->module-class (&/|head ?scope)) "/" name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - class-name nil "java/lang/Object" (into-array [&&/function-class])) - (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) - (.visitEnd)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (matchv ::M/objects [?name+?captured] - [[?name [["captured" [_ ?captured-id ?source]] _]]]) - (doseq [?name+?captured (&/->seq ?env)]))) - (add-lambda-apply class-name ?env) - (add-lambda-<init> class-name ?env) - )] - _ (add-lambda-impl =class compile lambda-impl-signature ?body) - :let [_ (.visitEnd =class)] - _ (&&/save-class! name (.toByteArray =class))] - (instance-closure compile class-name ?env (lambda-<init>-signature ?env)))) +(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)] + (defn compile-lambda [compile ?scope ?env ?body] + (|do [[file-name _ _] &/cursor + :let [name (&host/location (&/|tail ?scope)) + class-name (str (&host/->module-class (&/|head ?scope)) "/" name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 lambda-flags + class-name nil "java/lang/Object" (into-array [&&/function-class])) + (-> (doto (.visitField datum-flags captured-name clo-field-sig nil nil) + (.visitEnd)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [_ (&a/$captured _ ?captured-id ?source)]]) + (doseq [?name+?captured (&/->seq ?env)]))) + (.visitSource file-name nil) + (add-lambda-apply class-name ?env) + (add-lambda-<init> class-name ?env) + )] + _ (add-lambda-impl =class compile lambda-impl-signature ?body) + :let [_ (.visitEnd =class)] + _ (&&/save-class! name (.toByteArray =class))] + (instance-closure compile class-name ?env (lambda-<init>-signature ?env))))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index b1023689e..01e4ffd5b 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -1,18 +1,15 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.lux (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -29,13 +26,13 @@ MethodVisitor))) ;; [Exports] -(defn compile-bool [compile *type* ?value] +(defn compile-bool [compile ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] (return nil))) (do-template [<name> <class> <sig> <caster>] - (defn <name> [compile *type* value] + (defn <name> [compile value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW <class>) @@ -49,12 +46,12 @@ compile-char "java/lang/Character" "(C)V" char ) -(defn compile-text [compile *type* ?value] +(defn compile-text [compile ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitLdcInsn *writer* ?value)]] (return nil))) -(defn compile-tuple [compile *type* ?elems] +(defn compile-tuple [compile ?elems] (|do [^MethodVisitor *writer* &/get-writer :let [num-elems (&/|length ?elems) _ (doto *writer* @@ -70,28 +67,7 @@ (&/|range num-elems) ?elems)] (return nil))) -(defn compile-record [compile *type* ?elems] - (|do [^MethodVisitor *writer* &/get-writer - :let [elems* (->> ?elems - &/->seq - (sort #(compare (&/|first %1) (&/|first %2))) - &/->list) - num-elems (&/|length elems*) - _ (doto *writer* - (.visitLdcInsn (int num-elems)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] - _ (&/map2% (fn [idx kv] - (|let [[k v] kv] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - ret (compile v) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret)))) - (&/|range num-elems) elems*)] - (return nil))) - -(defn compile-variant [compile *type* ?tag ?value] +(defn compile-variant [compile ?tag ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitLdcInsn (int 2)) @@ -99,6 +75,7 @@ (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) (.visitLdcInsn ?tag) + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 1)))] @@ -106,12 +83,12 @@ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) -(defn compile-local [compile *type* ?idx] +(defn compile-local [compile ?idx] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] (return nil))) -(defn compile-captured [compile *type* ?scope ?captured-id ?source] +(defn compile-captured [compile ?scope ?captured-id ?source] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitVarInsn Opcodes/ALOAD 0) @@ -121,12 +98,12 @@ "Ljava/lang/Object;"))]] (return nil))) -(defn compile-global [compile *type* ?owner-class ?name] +(defn compile-global [compile ?owner-class ?name] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&/normalize-name ?name)) "_datum" "Ljava/lang/Object;")]] + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&/normalize-name ?name)) &/datum-field "Ljava/lang/Object;")]] (return nil))) -(defn compile-apply [compile *type* ?fn ?args] +(defn compile-apply [compile ?fn ?args] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?fn) _ (&/map% (fn [?arg] @@ -136,80 +113,106 @@ ?args)] (return nil))) -(defn ^:private compile-def-type [compile ?body ?def-data] +(defn ^:private compile-def-type [compile current-class ?body def-type] (|do [^MethodVisitor **writer** &/get-writer] - (matchv ::M/objects [?def-data] - [["lux;TypeD" _]] - (let [_ (doto **writer** - ;; Tail: Begin - (.visitLdcInsn (int 2)) ;; S - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V - (.visitInsn Opcodes/DUP) ;; VV - (.visitLdcInsn (int 0)) ;; VVI - (.visitLdcInsn "lux;TypeD") ;; VVIT - (.visitInsn Opcodes/AASTORE) ;; V - (.visitInsn Opcodes/DUP) ;; VV - (.visitLdcInsn (int 1)) ;; VVI - (.visitInsn Opcodes/ACONST_NULL) ;; VVIN - (.visitInsn Opcodes/AASTORE) ;; V - )] + (|case def-type + "type" + (|do [:let [_ (doto **writer** + ;; Tail: Begin + (.visitLdcInsn (int 2)) ;; S + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 0)) ;; VVI + (.visitLdcInsn &/$TypeD) ;; VVIT + (&&/wrap-long) + (.visitInsn Opcodes/AASTORE) ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 1)) ;; VVI + (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;") + (.visitInsn Opcodes/AASTORE) ;; V + )]] (return nil)) - [["lux;ValueD" _]] - (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0)) - [?def-value ?def-type] (matchv ::M/objects [?body] - [[["ann" [?def-value ?type-expr]] ?def-type]] - (&/T ?def-value ?type-expr) + "value" + (|let [?def-type (|case ?body + [[?def-type ?def-cursor] (&a/$ann ?def-value ?type-expr)] + ?type-expr - [[?def-value ?def-type]] - (&/T ?body (&&type/->analysis ?def-type)))] + [[?def-type ?def-cursor] ?def-value] + (&&type/->analysis ?def-type))] (|do [:let [_ (doto **writer** (.visitLdcInsn (int 2)) ;; S (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI - (.visitLdcInsn "lux;ValueD") ;; VVIT + (.visitLdcInsn &/$ValueD) ;; VVIT + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI )] + :let [_ (doto **writer** + (.visitLdcInsn (int 2)) ;; S + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 0)) ;; VVI + )] _ (compile ?def-type) + :let [_ (.visitInsn **writer** Opcodes/AASTORE)] + :let [_ (doto **writer** + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 1)) ;; VVI + (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;") + (.visitInsn Opcodes/AASTORE))] :let [_ (.visitInsn **writer** Opcodes/AASTORE)]] (return nil))) ))) -(defn compile-def [compile ?name ?body ?def-data] - (|do [^ClassWriter *writer* &/get-writer - module-name &/get-module-name - :let [datum-sig "Ljava/lang/Object;" - def-name (&/normalize-name ?name) - current-class (str (&host/->module-class module-name) "/" def-name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - current-class nil "java/lang/Object" (into-array [&&/function-class])) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_name" "Ljava/lang/String;" nil ?name) - (doto (.visitEnd))) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) - (doto (.visitEnd))) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_meta" datum-sig nil nil) - (doto (.visitEnd))))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) - (|do [^MethodVisitor **writer** &/get-writer - :let [_ (.visitCode **writer**)] - _ (compile ?body) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_datum" datum-sig)] - _ (compile-def-type compile ?body ?def-data) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_meta" datum-sig)] - :let [_ (doto **writer** - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [_ (.visitEnd *writer*)] - _ (&&/save-class! def-name (.toByteArray =class))] - (return nil))) - -(defn compile-ann [compile *type* ?value-ex ?type-ex] +(let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)] + (defn compile-def [compile ?name ?body] + (|do [:let [=value-type (&a/expr-type* ?body) + def-type (cond (&type/type= &type/Type =value-type) + "type" + + :else + "value")] + ^ClassWriter *writer* &/get-writer + module-name &/get-module-name + [file-name _ _] &/cursor + :let [datum-sig "Ljava/lang/Object;" + def-name (&/normalize-name ?name) + current-class (str (&host/->module-class module-name) "/" def-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 class-flags + current-class nil "java/lang/Object" (into-array [&&/function-class])) + (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) + (doto (.visitEnd))) + (-> (.visitField field-flags &/datum-field datum-sig nil nil) + (doto (.visitEnd))) + (-> (.visitField field-flags &/meta-field datum-sig nil nil) + (doto (.visitEnd))) + (.visitSource file-name nil))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) + (|do [^MethodVisitor **writer** &/get-writer + :let [_ (.visitCode **writer**)] + _ (compile ?body) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/datum-field datum-sig)] + _ (compile-def-type compile current-class ?body def-type) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)] + :let [_ (doto **writer** + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd *writer*)] + _ (&&/save-class! def-name (.toByteArray =class)) + class-loader &/loader + :let [def-class (&&/load-class! class-loader (&host/->class-name current-class))] + _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)] + (return nil)))) + +(defn compile-ann [compile ?value-ex ?type-ex] (compile ?value-ex)) (defn compile-declare-macro [compile module name] diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj new file mode 100644 index 000000000..b4b041049 --- /dev/null +++ b/src/lux/compiler/module.clj @@ -0,0 +1,25 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.module + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]] + [type :as &type]) + [lux.analyser.module :as &module])) + +;; [Exports] +(def tag-groups + "(Lux (List (, Text (List Text))))" + (|do [module &/get-current-module] + (return (&/|map (fn [pair] + (|case pair + [name [tags _]] + (&/T name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) + (&/get$ &module/$types module))) + )) diff --git a/src/lux/compiler/package.clj b/src/lux/compiler/package.clj deleted file mode 100644 index 40639e85a..000000000 --- a/src/lux/compiler/package.clj +++ /dev/null @@ -1,61 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. - -(ns lux.compiler.package - (:require [clojure.core.match :as M :refer [matchv]] - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail fail*]] - [host :as &host]) - (lux.compiler [base :as &&])) - (:import (java.io File - FileInputStream - FileOutputStream - BufferedInputStream) - (java.util.jar Manifest - Attributes$Name - JarEntry - JarOutputStream - ))) - -;; [Utils] -(def ^:private kilobyte 1024) - -(defn ^:private manifest [^String module] - "(-> Text Manifest)" - (doto (new Manifest) - (-> .getMainAttributes (doto (.put Attributes$Name/MAIN_CLASS (str (&host/->module-class module) "._")) - (.put Attributes$Name/MANIFEST_VERSION "1.0"))))) - -(defn ^:private write-class! [^String path ^File file ^JarOutputStream out] - "(-> Text File JarOutputStream Unit)" - (with-open [in (new BufferedInputStream (new FileInputStream file))] - (let [buffer (byte-array (* 10 kilobyte))] - (doto out - (.putNextEntry (new JarEntry (str path "/" (.getName file)))) - (-> (.write buffer 0 bytes-read) - (->> (when (not= -1 bytes-read)) - (loop [bytes-read (.read in buffer)]))) - (.flush) - (.closeEntry) - )) - )) - -(defn ^:private write-module! [^File file ^JarOutputStream out] - "(-> File JarOutputStream Unit)" - (let [module-name (.getName file)] - (doseq [$class (.listFiles file)] - (write-class! module-name $class out)))) - -;; [Resources] -(defn package [module] - "(-> Text (,))" - ;; (prn 'package module) - (with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))] - (doseq [$group (.listFiles (new File &&/output-dir))] - (write-module! $group out)) - )) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index a92911444..c1615f9b6 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -1,97 +1,86 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.type - (:require [clojure.core.match :as M :refer [matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] - [type :as &type]))) + (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [type :as &type]) + [lux.analyser.base :as &a])) ;; [Utils] (defn ^:private variant$ [tag body] "(-> Text Analysis Analysis)" - (&/T (&/V "variant" (&/T tag body)) - &type/$Void)) + (&a/|meta &type/$Void &/empty-cursor + (&/V &a/$variant (&/T tag body)) + )) (defn ^:private tuple$ [members] "(-> (List Analysis) Analysis)" - (&/T (&/V "tuple" members) - &type/$Void)) + (&a/|meta &type/$Void &/empty-cursor + (&/V &a/$tuple members) + )) + +(defn ^:private int$ [value] + "(-> Int Analysis)" + (&a/|meta &type/$Void &/empty-cursor + (&/V &a/$int value) + )) (defn ^:private text$ [text] "(-> Text Analysis)" - (&/T (&/V "text" text) - &type/$Void)) + (&a/|meta &type/$Void &/empty-cursor + (&/V &a/$text text) + )) (def ^:private $Nil "Analysis" - (variant$ "lux;Nil" (tuple$ (&/|list)))) + (variant$ &/$Nil (tuple$ &/Nil$))) (defn ^:private Cons$ [head tail] "(-> Analysis Analysis Analysis)" - (variant$ "lux;Cons" (tuple$ (&/|list head tail)))) + (variant$ &/$Cons (tuple$ (&/|list head tail)))) + +(defn ^:private List$ [elems] + (&/fold (fn [tail head] + (Cons$ head tail)) + $Nil + (&/|reverse elems))) ;; [Exports] (defn ->analysis [type] "(-> Type Analysis)" - (matchv ::M/objects [type] - [["lux;DataT" ?class]] - (variant$ "lux;DataT" (text$ ?class)) + (|case type + (&/$DataT class params) + (variant$ &/$DataT (tuple$ (&/|list (text$ class) + (List$ (&/|map ->analysis params))))) - [["lux;TupleT" ?members]] - (variant$ "lux;TupleT" - (&/fold (fn [tail head] - (Cons$ (->analysis head) tail)) - $Nil - (&/|reverse ?members))) - - [["lux;VariantT" ?cases]] - (variant$ "lux;VariantT" - (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) - tail))) - $Nil - (&/|reverse ?cases))) - - [["lux;RecordT" ?slots]] - (variant$ "lux;RecordT" - (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) - tail))) - $Nil - (&/|reverse ?slots))) - - [["lux;LambdaT" [?input ?output]]] - (variant$ "lux;LambdaT" (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) - - [["lux;AllT" [?env ?name ?arg ?body]]] - (variant$ "lux;AllT" - (tuple$ (&/|list (matchv ::M/objects [?env] - [["lux;None" _]] - (variant$ "lux;Some" (tuple$ (&/|list))) - - [["lux;Some" ??env]] - (variant$ "lux;Some" - (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) - tail))) - $Nil - (&/|reverse ??env)))) - (text$ ?name) - (text$ ?arg) - (->analysis ?body)))) - - [["lux;BoundT" ?name]] - (variant$ "lux;BoundT" (text$ ?name)) - - [["lux;AppT" [?fun ?arg]]] - (variant$ "lux;AppT" (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) + (&/$TupleT members) + (variant$ &/$TupleT (List$ (&/|map ->analysis members))) + + (&/$VariantT members) + (variant$ &/$VariantT (List$ (&/|map ->analysis members))) + + (&/$LambdaT input output) + (variant$ &/$LambdaT (tuple$ (&/|list (->analysis input) (->analysis output)))) + + (&/$UnivQ env body) + (variant$ &/$UnivQ + (tuple$ (&/|list (List$ (&/|map ->analysis env)) + (->analysis body)))) + + (&/$BoundT idx) + (variant$ &/$BoundT (int$ idx)) + + (&/$AppT fun arg) + (variant$ &/$AppT (tuple$ (&/|list (->analysis fun) (->analysis arg)))) + + (&/$NamedT [module name] type*) + (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ module) (text$ name))) + (->analysis type*)))) + + _ + (assert false (prn '->analysis (&type/show-type type) (&/adt->text type))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index 906e3c714..916f94419 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -1,47 +1,40 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.host (:require (clojure [string :as string] [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] - [type :as &type])) - (:import (java.lang.reflect Field Method Modifier))) + (lux [base :as & :refer [|do return* return fail fail* |let |case]] + [type :as &type]) + [lux.type.host :as &host-type]) + (:import (java.lang.reflect Field Method Constructor Modifier Type) + java.util.regex.Pattern + (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) ;; [Constants] (def prefix "lux.") (def function-class (str prefix "Function")) -(def module-separator "_") - -;; [Utils] -(defn ^:private class->type [^Class class] - (if-let [[_ base arr-level] (re-find #"^([^\[]+)(\[\])*$" - (str (if-let [pkg (.getPackage class)] - (str (.getName pkg) ".") - "") - (.getSimpleName class)))] - (if (.equals "void" base) - (return &type/Unit) - (return (&/V "lux;DataT" (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) - base))) - ))) - -(defn ^:private method->type [^Method method] - (class->type (.getReturnType method))) +(def module-separator "/") +(def class-name-separator ".") +(def class-separator "/") ;; [Resources] -(defn ^String ->class [class] - (string/replace class #"\." "/")) - -(defn ^String ->module-class [module-name] - (string/replace module-name #"/" module-separator)) +(do-template [<name> <old-sep> <new-sep>] + (let [regex (-> <old-sep> Pattern/quote re-pattern)] + (defn <name> [old] + (string/replace old regex <new-sep>))) + + ^String ->class class-name-separator class-separator + ^String ->class-name module-separator class-name-separator + ^String ->module-class module-separator class-separator + ) (def ->package ->module-class) @@ -64,27 +57,55 @@ (str "L" class* ";"))) )) -(defn ->java-sig [^objects type] - (matchv ::M/objects [type] - [["lux;DataT" ?name]] - (->type-signature ?name) +(defn unfold-array [type] + "(-> Type (, Int Type))" + (|case type + (&/$DataT "#Array" (&/$Cons param (&/$Nil))) + (|let [[count inner] (unfold-array param)] + (&/T (inc count) inner)) - [["lux;LambdaT" [_ _]]] + _ + (&/T 0 type))) + +(defn ->java-sig [^objects type] + "(-> Type Text)" + (|case type + (&/$DataT ?name params) + (cond (= &host-type/array-data-tag ?name) (|let [[level base] (unfold-array type) + base-sig (|case base + (&/$DataT base-class _) + (->class base-class) + + _ + (->java-sig base))] + (str (->> (&/|repeat level "[") (&/fold str "")) + "L" base-sig ";")) + (= &host-type/null-data-tag ?name) (->type-signature "java.lang.Object") + :else (->type-signature ?name)) + + (&/$LambdaT _ _) (->type-signature function-class) - [["lux;TupleT" ["lux;Nil" _]]] + (&/$TupleT (&/$Nil)) "V" + + (&/$NamedT ?name ?type) + (->java-sig ?type) + + _ + (assert false (str '->java-sig " " (&type/show-type type))) )) (do-template [<name> <static?>] (defn <name> [class-loader target field] - (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName (&type/as-obj target) true class-loader)) - :when (and (.equals ^Object field (.getName =field)) - (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =field))))] - (.getType =field)))] - (|do [=type (class->type type*)] - (return =type)) - (fail (str "[Analyser Error] Field does not exist: " target "." field)))) + (|let [target-class (Class/forName (&host-type/as-obj target) true class-loader)] + (if-let [^Type gtype (first (for [^Field =field (.getDeclaredFields target-class) + :when (and (.equals ^Object field (.getName =field)) + (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =field))))] + (.getGenericType =field)))] + (|let [gvars (->> target-class .getTypeParameters seq &/->list)] + (return (&/T gvars gtype))) + (fail (str "[Host Error] Field does not exist: " target "." field))))) lookup-static-field true lookup-field false @@ -92,21 +113,137 @@ (do-template [<name> <static?>] (defn <name> [class-loader target method-name args] - ;; (prn '<name> target method-name) - (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&type/as-obj target) true class-loader)) - :when (and (.equals ^Object method-name (.getName =method)) - (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =method))) - (&/fold2 #(and %1 (.equals ^Object %2 %3)) - true - args - (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))] - =method))] - (method->type method) - (fail (str "[Analyser Error] Method does not exist: " target "." method-name)))) + (|let [target-class (Class/forName (&host-type/as-obj target) true class-loader)] + (if-let [^Method method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj target) true class-loader)) + :when (and (.equals ^Object method-name (.getName =method)) + (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =method))) + (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types)))))] + =method))] + (|let [parent-gvars (->> target-class .getTypeParameters seq &/->list) + gvars (->> method .getTypeParameters seq &/->list) + gargs (->> method .getGenericParameterTypes seq &/->list)] + (return (&/T (.getGenericReturnType method) + (->> method .getExceptionTypes &/->list (&/|map #(.getName ^Class %))) + parent-gvars + gvars + gargs))) + (fail (str "[Host Error] Method does not exist: " target "." method-name))))) lookup-static-method true lookup-virtual-method false ) +(defn lookup-constructor [class-loader target args] + ;; (prn 'lookup-constructor class-loader target (&host-type/as-obj target)) + (let [target-class (Class/forName (&host-type/as-obj target) true class-loader)] + (if-let [^Constructor ctor (first (for [^Constructor =method (.getDeclaredConstructors target-class) + :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types))))] + =method))] + (|let [gvars (->> target-class .getTypeParameters seq &/->list) + gargs (->> ctor .getGenericParameterTypes seq &/->list) + exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName ^Class %)))] + (return (&/T exs gvars gargs))) + (fail (str "[Host Error] Constructor does not exist: " target))))) + +(defn abstract-methods [class-loader class] + (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj class) true class-loader)) + :when (Modifier/isAbstract (.getModifiers =method))] + (&/T (.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))))) + (defn location [scope] (->> scope (&/|map &/normalize-name) (&/|interpose "$") (&/fold str ""))) + +(defn modifiers->int [mods] + (+ (case (:visibility mods) + "default" 0 + "public" Opcodes/ACC_PUBLIC + "private" Opcodes/ACC_PRIVATE + "protected" Opcodes/ACC_PROTECTED) + (if (:static? mods) Opcodes/ACC_STATIC 0) + (if (:final? mods) Opcodes/ACC_FINAL 0) + (if (:abstract? mods) Opcodes/ACC_ABSTRACT 0) + (case (:concurrency mods) + "synchronized" Opcodes/ACC_SYNCHRONIZED + "volatile" Opcodes/ACC_VOLATILE + ;; else + 0))) + +(let [object-real-class (->class "java.lang.Object")] + (defn ^:private dummy-return [^MethodVisitor writer name output] + (case output + "void" (if (= "<init>" name) + (doto writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL object-real-class "<init>" "()V") + (.visitInsn Opcodes/RETURN)) + (.visitInsn writer Opcodes/RETURN)) + "boolean" (doto writer + (.visitLdcInsn false) + (.visitInsn Opcodes/IRETURN)) + "byte" (doto writer + (.visitLdcInsn (byte 0)) + (.visitInsn Opcodes/IRETURN)) + "short" (doto writer + (.visitLdcInsn (short 0)) + (.visitInsn Opcodes/IRETURN)) + "int" (doto writer + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/IRETURN)) + "long" (doto writer + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LRETURN)) + "float" (doto writer + (.visitLdcInsn (float 0.0)) + (.visitInsn Opcodes/FRETURN)) + "double" (doto writer + (.visitLdcInsn (double 0.0)) + (.visitInsn Opcodes/DRETURN)) + "char" (doto writer + (.visitLdcInsn (char 0)) + (.visitInsn Opcodes/IRETURN)) + ;; else + (doto writer + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN))))) + +(defn use-dummy-class [name super-class interfaces fields methods] + (|do [module &/get-module-name + :let [full-name (str module "/" name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + full-name nil (->class super-class) (->> interfaces (&/|map ->class) &/->seq (into-array String)))) + _ (&/|map (fn [field] + (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) + (->type-signature (:type field)) nil nil) + (.visitEnd))) + fields) + _ (&/|map (fn [method] + (|let [signature (str "(" (&/fold str "" (&/|map ->type-signature (:inputs method))) ")" + (->type-signature (:output method)))] + (doto (.visitMethod =class (modifiers->int (:modifiers method)) + (:name method) + signature + nil + (->> (:exceptions method) (&/|map ->class) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-return (:name method) (:output method)) + (.visitMaxs 0 0) + (.visitEnd)))) + methods) + bytecode (.toByteArray (doto =class .visitEnd))] + ^ClassLoader loader &/loader + !classes &/classes + :let [real-name (str (->class-name module) "." name) + _ (swap! !classes assoc real-name bytecode) + _ (.loadClass loader real-name)]] + (return nil))) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index bb6e54cb4..651f9ecce 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -1,17 +1,33 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.lexer (:require [clojure.template :refer [do-template]] - (lux [base :as & :refer [|do return* return fail fail*]] + (lux [base :as & :refer [deftags |do return* return fail fail*]] [reader :as &reader]) [lux.analyser.module :as &module])) +;; [Tags] +(deftags + ["White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace"] + ) + ;; [Utils] (defn ^:private escape-char [escaped] (cond (.equals ^Object escaped "\\t") (return "\t") @@ -39,31 +55,23 @@ ;; [Lexers] (def ^:private lex-white-space (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] - (return (&/V "lux;Meta" (&/T meta (&/V "White_Space" white-space)))))) + (return (&/T meta (&/V $White_Space white-space))))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") [meta comment] (&reader/read-regex #"^(.*)$")] - (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) + (return (&/T meta (&/V $Comment comment))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") - [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))") - ;; :let [_ (prn 'immediate comment)] - _ (&reader/read-text ")#")] + [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex+ #"(?is)^(?!#\()((?!\)#).)*")] (return (&/T meta comment))) - (|do [;; :let [_ (prn 'pre/_0)] - [meta pre] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)") - ;; :let [_ (prn 'pre pre)] - [_ inner] (lex-multi-line-comment nil) - ;; :let [_ (prn 'inner inner)] - [_ post] (&reader/read-regex #"(?is)^(.+?(?=\)#))") - ;; :let [_ (prn 'post post (str pre "#(" inner ")#" post))] - ] + (|do [[meta pre] (&reader/read-regex+ #"(?is)^((?!#\().)*") + [_ ($Comment inner)] (lex-multi-line-comment nil) + [_ post] (&reader/read-regex+ #"(?is)^((?!\)#).)*")] (return (&/T meta (str pre "#(" inner ")#" post)))))) - ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] - (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) + (return (&/T meta (&/V $Comment comment))))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment @@ -72,11 +80,11 @@ (do-template [<name> <tag> <regex>] (def <name> (|do [[meta token] (&reader/read-regex <regex>)] - (return (&/V "lux;Meta" (&/T meta (&/V <tag> token)))))) + (return (&/T meta (&/V <tag> token))))) - ^:private lex-bool "Bool" #"^(true|false)" - ^:private lex-int "Int" #"^(-?0|-?[1-9][0-9]*)" - ^:private lex-real "Real" #"^-?(-?0\.[0-9]+|-?[1-9][0-9]*\.[0-9]+)" + ^:private lex-bool $Bool #"^(true|false)" + ^:private lex-int $Int #"^-?(0|[1-9][0-9]*)" + ^:private lex-real $Real #"^-?(0\.[0-9]+|[1-9][0-9]*\.[0-9]+)" ) (def ^:private lex-char @@ -86,13 +94,13 @@ (|do [[_ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] - (return (&/V "lux;Meta" (&/T meta (&/V "Char" token)))))) + (return (&/T meta (&/V $Char token))))) (def ^:private lex-text (|do [[meta _] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] - (return (&/V "lux;Meta" (&/T meta (&/V "Text" token)))))) + (return (&/T meta (&/V $Text token))))) (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] @@ -101,10 +109,8 @@ ? (&module/exists? token)] (if ? (return (&/T meta (&/T token local-token))) - (|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token) - (&module/dealias token))] - (do ;; (prn "Unaliased: " unaliased ";" local-token) - (return (&/T meta (&/T unaliased local-token))))))) + (|do [unaliased (&module/dealias token)] + (return (&/T meta (&/T unaliased local-token)))))) (return (&/T meta (&/T "" token))) ))) (|do [[meta _] (&reader/read-text ";;") @@ -118,24 +124,24 @@ (def ^:private lex-symbol (|do [[meta ident] lex-ident] - (return (&/V "lux;Meta" (&/T meta (&/V "Symbol" ident)))))) + (return (&/T meta (&/V $Symbol ident))))) (def ^:private lex-tag (|do [[meta _] (&reader/read-text "#") [_ ident] lex-ident] - (return (&/V "lux;Meta" (&/T meta (&/V "Tag" ident)))))) + (return (&/T meta (&/V $Tag ident))))) (do-template [<name> <text> <tag>] (def <name> (|do [[meta _] (&reader/read-text <text>)] - (return (&/V "lux;Meta" (&/T meta (&/V <tag> nil)))))) - - ^:private lex-open-paren "(" "Open_Paren" - ^:private lex-close-paren ")" "Close_Paren" - ^:private lex-open-bracket "[" "Open_Bracket" - ^:private lex-close-bracket "]" "Close_Bracket" - ^:private lex-open-brace "{" "Open_Brace" - ^:private lex-close-brace "}" "Close_Brace" + (return (&/T meta (&/V <tag> nil))))) + + ^:private lex-open-paren "(" $Open_Paren + ^:private lex-close-paren ")" $Close_Paren + ^:private lex-open-bracket "[" $Open_Bracket + ^:private lex-close-bracket "]" $Close_Bracket + ^:private lex-open-brace "{" $Open_Brace + ^:private lex-close-brace "}" $Close_Brace ) (def ^:private lex-delimiter diff --git a/src/lux/lib/loader.clj b/src/lux/lib/loader.clj new file mode 100644 index 000000000..13810238a --- /dev/null +++ b/src/lux/lib/loader.clj @@ -0,0 +1,60 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.lib.loader + (:refer-clojure :exclude [load]) + (:require (lux [base :as & :refer [|let |do return fail return* fail* |case]])) + (:import (java.io InputStream + File + FileInputStream + ByteArrayInputStream + ByteArrayOutputStream) + java.util.zip.GZIPInputStream + (org.apache.commons.compress.archivers.tar TarArchiveEntry + TarArchiveInputStream))) + +;; [Utils] +(defn ^:private fetch-libs [] + (->> ^java.net.URLClassLoader (ClassLoader/getSystemClassLoader) + (.getURLs) + seq + (map #(.getFile ^java.net.URL %)) + (filter #(.endsWith ^String % ".tar.gz")) + (map #(new File ^String %)))) + +(let [init-capacity (* 100 1024) + buffer-size 1024] + (defn ^:private ^"[B" read-stream [^InputStream is] + (let [buffer (byte-array buffer-size)] + (with-open [os (new ByteArrayOutputStream init-capacity)] + (loop [bytes-read (.read is buffer 0 buffer-size)] + (when (not= -1 bytes-read) + (do (.write os buffer 0 bytes-read) + (recur (.read is buffer 0 buffer-size))))) + (.toByteArray os))))) + +(defn ^:private unpackage [^File lib-file] + (let [is (->> lib-file + (new FileInputStream) + (new GZIPInputStream) + (new TarArchiveInputStream))] + (loop [lib-data {} + entry (.getNextTarEntry is)] + (if entry + (recur (assoc lib-data (.getName entry) (new String (read-stream is))) + (.getNextTarEntry is)) + lib-data)))) + +;; [Exports] +(def lib-ext ".tar.gz") + +(defn load [] + (->> (fetch-libs) + (map unpackage) + (reduce merge {}))) + +(comment + (->> &/lib-dir load keys) + ) diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index 5056a09e0..1325a2e7d 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.optimizer (:require [lux.analyser :as &analyser])) @@ -22,5 +19,5 @@ ;; Local var aliasing. ;; [Exports] -(defn optimize [eval! compile-module] - (&analyser/analyse eval! compile-module)) +(defn optimize [eval! compile-module compile-token] + (&analyser/analyse eval! compile-module compile-token)) diff --git a/src/lux/packager/lib.clj b/src/lux/packager/lib.clj new file mode 100644 index 000000000..af48e31eb --- /dev/null +++ b/src/lux/packager/lib.clj @@ -0,0 +1,41 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.packager.lib + (:require [lux.lib.loader :as &lib]) + (:import (java.io File + FileOutputStream) + java.util.zip.GZIPOutputStream + (org.apache.commons.compress.archivers.tar TarArchiveEntry + TarArchiveOutputStream) + )) + +;; [Utils] +(defn ^:private read-file ^objects [^File file] + (with-open [is (java.io.FileInputStream. file)] + (let [data (byte-array (.length file))] + (.read is data) + data))) + +(defn ^:private add-to-tar! [prefix ^File file ^TarArchiveOutputStream os] + "(-> Text File TarArchiveOutputStream Unit)" + (let [file-name (str prefix "/" (.getName file))] + (if (.isDirectory file) + (doseq [file (seq (.listFiles file))] + (add-to-tar! file-name file os)) + (let [data (read-file file)] + (doto os + (.putArchiveEntry (doto (new TarArchiveEntry file-name) + (.setSize (.length file)))) + (.write data 0 (alength data)) + (.closeArchiveEntry)))))) + +;; [Exports] +(defn package [output-lib-name ^File source-dir] + "(-> Text File Unit)" + (with-open [out (->> (str output-lib-name &lib/lib-ext) (new FileOutputStream) (new GZIPOutputStream) (new TarArchiveOutputStream))] + (doseq [file (seq (.listFiles source-dir))] + (add-to-tar! "" file out)) + )) diff --git a/src/lux/packager/program.clj b/src/lux/packager/program.clj new file mode 100644 index 000000000..83927ba0d --- /dev/null +++ b/src/lux/packager/program.clj @@ -0,0 +1,99 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.packager.program + (:require [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail*]] + [host :as &host]) + (lux.compiler [base :as &&])) + (:import (java.io InputStream + File + FileInputStream + FileOutputStream + BufferedInputStream + ByteArrayOutputStream) + (java.util.jar Manifest + Attributes$Name + JarEntry + JarInputStream + JarOutputStream + ))) + +;; [Utils] +(def ^:private kilobyte 1024) + +(defn ^:private manifest [^String module] + "(-> Text Manifest)" + (doto (new Manifest) + (-> .getMainAttributes (doto (.put Attributes$Name/MAIN_CLASS (str (&host/->module-class module) "._")) + (.put Attributes$Name/MANIFEST_VERSION "1.0"))))) + +(defn ^:private write-class! [^String path ^File file ^JarOutputStream out] + "(-> Text File JarOutputStream Unit)" + (with-open [in (new BufferedInputStream (new FileInputStream file))] + (let [buffer (byte-array (* 10 kilobyte))] + (doto out + (.putNextEntry (new JarEntry (str path "/" (.getName file)))) + (-> (.write buffer 0 bytes-read) + (->> (when (not= -1 bytes-read)) + (loop [bytes-read (.read in buffer)]))) + (.flush) + (.closeEntry) + )) + )) + +(let [output-dir-size (.length &&/output-dir)] + (defn ^:private write-module! [^File file ^JarOutputStream out] + "(-> File JarOutputStream Unit)" + (let [module-name (.substring (.getPath file) output-dir-size) + inner-files (.listFiles file) + inner-modules (filter #(.isDirectory ^File %) inner-files) + inner-classes (filter #(not (.isDirectory ^File %)) inner-files)] + (doseq [$class inner-classes] + (write-class! module-name $class out)) + (doseq [$module inner-modules] + (write-module! $module out))))) + +(defn ^:private fetch-available-jars [] + (->> ^java.net.URLClassLoader (ClassLoader/getSystemClassLoader) + (.getURLs) + (map #(.getFile ^java.net.URL %)) + (filter #(.endsWith ^String % ".jar")))) + +(let [init-capacity (* 100 1024) + buffer-size 1024] + (defn ^:private ^"[B" read-stream [^InputStream is] + (let [buffer (byte-array buffer-size)] + (with-open [os (new ByteArrayOutputStream init-capacity)] + (loop [bytes-read (.read is buffer 0 buffer-size)] + (when (not= -1 bytes-read) + (do (.write os buffer 0 bytes-read) + (recur (.read is buffer 0 buffer-size))))) + (.toByteArray os))))) + +(defn ^:private add-jar! [^File jar-file ^JarOutputStream out] + (with-open [is (->> jar-file (new FileInputStream) (new JarInputStream))] + (loop [^JarEntry entry (.getNextJarEntry is)] + (when entry + (when (and (not (.isDirectory entry)) + (not (.startsWith (.getName entry) "META-INF/"))) + (let [entry-data (read-stream is)] + (doto out + (.putNextEntry entry) + (.write entry-data 0 (alength entry-data)) + (.flush) + (.closeEntry)))) + (recur (.getNextJarEntry is)))))) + +;; [Resources] +(defn package [module] + "(-> Text (,))" + (with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))] + (doseq [$group (.listFiles (new File &&/output-dir))] + (write-module! $group out)) + (doseq [^String jar-file (fetch-available-jars)] + (add-jar! (new File jar-file) out)) + )) diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 966c322bf..516b6a947 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -1,16 +1,13 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.parser (:require [clojure.template :refer [do-template]] - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return fail]] + (lux [base :as & :refer [deftags |do return fail |case]] [lexer :as &lexer]))) ;; [Utils] @@ -18,75 +15,74 @@ (defn <name> [parse] (|do [elems (&/repeat% parse) token &lexer/lex] - (matchv ::M/objects [token] - [["lux;Meta" [meta [<close-token> _]]]] - (return (&/V <tag> (&/fold &/|++ (&/|list) elems))) + (|case token + [meta [<close-token> _]] + (return (&/V <tag> (&/fold &/|++ &/Nil$ elems))) - [_] + _ (fail (str "[Parser Error] Unbalanced " <description> "."))))) - ^:private parse-form "Close_Paren" "parantheses" "lux;FormS" - ^:private parse-tuple "Close_Bracket" "brackets" "lux;TupleS" + ^:private parse-form &lexer/$Close_Paren "parantheses" &/$FormS + ^:private parse-tuple &lexer/$Close_Bracket "brackets" &/$TupleS ) (defn ^:private parse-record [parse] (|do [elems* (&/repeat% parse) token &lexer/lex - :let [elems (&/fold &/|++ (&/|list) elems*)]] - (matchv ::M/objects [token] - [["lux;Meta" [meta ["Close_Brace" _]]]] + :let [elems (&/fold &/|++ &/Nil$ elems*)]] + (|case token + [meta (&lexer/$Close_Brace _)] (if (even? (&/|length elems)) - (return (&/V "lux;RecordS" (&/|as-pairs elems))) + (return (&/V &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) - [_] + _ (fail (str "[Parser Error] Unbalanced braces."))))) ;; [Interface] (def parse - (|do [token &lexer/lex] - (matchv ::M/objects [token] - [["lux;Meta" [meta token*]]] - (matchv ::M/objects [token*] - [["White_Space" _]] - (return (&/|list)) + (|do [token &lexer/lex + :let [[meta token*] token]] + (|case token* + (&lexer/$White_Space _) + (return &/Nil$) - [["Comment" _]] - (return (&/|list)) - - [["Bool" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;BoolS" (Boolean/parseBoolean ?value)))))) + (&lexer/$Comment _) + (return &/Nil$) + + (&lexer/$Bool ?value) + (return (&/|list (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value))))) - [["Int" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;IntS" (Integer/parseInt ?value)))))) + (&lexer/$Int ?value) + (return (&/|list (&/T meta (&/V &/$IntS (Long/parseLong ?value))))) - [["Real" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;RealS" (Float/parseFloat ?value)))))) + (&lexer/$Real ?value) + (return (&/|list (&/T meta (&/V &/$RealS (Double/parseDouble ?value))))) - [["Char" ^String ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;CharS" (.charAt ?value 0)))))) + (&lexer/$Char ^String ?value) + (return (&/|list (&/T meta (&/V &/$CharS (.charAt ?value 0))))) - [["Text" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TextS" ?value))))) + (&lexer/$Text ?value) + (return (&/|list (&/T meta (&/V &/$TextS ?value)))) - [["Symbol" ?ident]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;SymbolS" ?ident))))) + (&lexer/$Symbol ?ident) + (return (&/|list (&/T meta (&/V &/$SymbolS ?ident)))) - [["Tag" ?ident]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TagS" ?ident))))) + (&lexer/$Tag ?ident) + (return (&/|list (&/T meta (&/V &/$TagS ?ident)))) - [["Open_Paren" _]] - (|do [syntax (parse-form parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - - [["Open_Bracket" _]] - (|do [syntax (parse-tuple parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + (&lexer/$Open_Paren _) + (|do [syntax (parse-form parse)] + (return (&/|list (&/T meta syntax)))) + + (&lexer/$Open_Bracket _) + (|do [syntax (parse-tuple parse)] + (return (&/|list (&/T meta syntax)))) - [["Open_Brace" _]] - (|do [syntax (parse-record parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + (&lexer/$Open_Brace _) + (|do [syntax (parse-record parse)] + (return (&/|list (&/T meta syntax)))) - [_] - (fail "[Parser Error] Unknown lexer token.") - )))) + _ + (fail "[Parser Error] Unknown lexer token.") + ))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 9fd9b14ea..751df7e6d 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -1,51 +1,53 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.reader (:require [clojure.string :as string] - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* |let]])) + [lux.base :as & :refer [deftags |do return* return fail fail* |let |case]])) + +;; [Tags] +(deftags + ["No" + "Done" + "Yes"]) ;; [Utils] (defn ^:private with-line [body] (fn [state] - (matchv ::M/objects [(&/get$ &/$SOURCE state)] - [["lux;Nil" _]] + (|case (&/get$ &/$source state) + (&/$Nil) (fail* "[Reader Error] EOF") - [["lux;Cons" [[[file-name line-num column-num] line] - more]]] - (matchv ::M/objects [(body file-name line-num column-num line)] - [["No" msg]] + (&/$Cons [[file-name line-num column-num] line] + more) + (|case (body file-name line-num column-num line) + ($No msg) (fail* msg) - [["Done" output]] - (return* (&/set$ &/$SOURCE more state) + ($Done output) + (return* (&/set$ &/$source more state) output) - [["Yes" [output line*]]] - (return* (&/set$ &/$SOURCE (&/|cons line* more) state) + ($Yes output line*) + (return* (&/set$ &/$source (&/Cons$ line* more) state) output)) ))) (defn ^:private with-lines [body] (fn [state] - (matchv ::M/objects [(body (&/get$ &/$SOURCE state))] - [["lux;Right" [reader* match]]] - (return* (&/set$ &/$SOURCE reader* state) + (|case (body (&/get$ &/$source state)) + (&/$Right reader* match) + (return* (&/set$ &/$source reader* state) match) - [["lux;Left" msg]] + (&/$Left msg) (fail* msg) ))) -;; [Exports] (defn ^:private re-find! [^java.util.regex.Pattern regex column ^String line] (let [matcher (doto (.matcher regex line) (.region column (.length line)) @@ -53,13 +55,6 @@ (when (.find matcher) (.group matcher 0)))) -(defn ^:private re-find1! [^java.util.regex.Pattern regex column ^String line] - (let [matcher (doto (.matcher regex line) - (.region column (.length line)) - (.useAnchoringBounds true))] - (when (.find matcher) - (.group matcher 1)))) - (defn ^:private re-find3! [^java.util.regex.Pattern regex column ^String line] (let [matcher (doto (.matcher regex line) (.region column (.length line)) @@ -69,78 +64,76 @@ (.group matcher 1) (.group matcher 2))))) +;; [Exports] (defn read-regex [regex] (with-line (fn [file-name line-num column-num ^String line] - ;; (prn 'read-regex [file-name line-num column-num regex line]) - (if-let [^String match (do ;; (prn '[regex line] [regex line]) - (re-find! regex column-num line))] - (let [;; _ (prn 'match match) - match-length (.length match) + (if-let [^String match (re-find! regex column-num line)] + (let [match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V "Done" (&/T (&/T file-name line-num column-num) match)) - (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) match) - (&/T (&/T file-name line-num column-num*) line))))) - (&/V "No" (str "[Reader Error] Pattern failed: " regex)))))) + (&/V $Done (&/T (&/T file-name line-num column-num) match)) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) match) + (&/T (&/T file-name line-num column-num*) line))))) + (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] (with-line (fn [file-name line-num column-num ^String line] - ;; (prn 'read-regex2 [file-name line-num column-num regex line]) (if-let [[^String match tok1 tok2] (re-find3! regex column-num line)] (let [match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V "Done" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) - (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) - (&/T (&/T file-name line-num column-num*) line))))) - (&/V "No" (str "[Reader Error] Pattern failed: " regex)))))) + (&/V $Done (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) + (&/T (&/T file-name line-num column-num*) line))))) + (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex+ [regex] (with-lines (fn [reader] (loop [prefix "" reader* reader] - (matchv ::M/objects [reader*] - [["lux;Nil" _]] - (&/V "lux;Left" "[Reader Error] EOF") - - [["lux;Cons" [[[file-name line-num column-num] ^String line] - reader**]]] - (if-let [^String match (do ;; (prn 'read-regex+ regex line) - (re-find1! regex column-num line))] + (|case reader* + (&/$Nil) + (&/V &/$Left "[Reader Error] EOF") + + (&/$Cons [[file-name line-num column-num] ^String line] + reader**) + (if-let [^String match (re-find! regex column-num line)] (let [match-length (.length match) - column-num* (+ column-num match-length)] + column-num* (+ column-num match-length) + prefix* (if (= 0 column-num) + (str prefix "\n" match) + (str prefix match))] (if (= column-num* (.length line)) - (recur (str prefix match "\n") reader**) - (&/V "lux;Right" (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) - reader**) - (&/T (&/T file-name line-num column-num) (str prefix match)))))) - (&/V "lux;Left" (str "[Reader Error] Pattern failed: " regex)))))))) + (recur prefix* reader**) + (&/V &/$Right (&/T (&/Cons$ (&/T (&/T file-name line-num column-num*) line) + reader**) + (&/T (&/T file-name line-num column-num) prefix*))))) + (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] (with-line (fn [file-name line-num column-num ^String line] - ;; (prn 'read-text [file-name line-num column-num text line]) (if (.startsWith line text column-num) (let [match-length (.length text) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V "Done" (&/T (&/T file-name line-num column-num) text)) - (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) text) - (&/T (&/T file-name line-num column-num*) line))))) - (&/V "No" (str "[Reader Error] Text failed: " text)))))) - -(def ^:private ^String +source-dir+ "input/") -(defn from [^String file-name ^String file-content] - (let [lines (&/->list (string/split-lines file-content)) - file-name (.substring file-name (.length +source-dir+))] - (&/|map (fn [line+line-num] - (|let [[line-num line] line+line-num] - (&/T (&/T file-name (inc line-num) 0) - line))) - (&/|filter (fn [line+line-num] - (|let [[line-num line] line+line-num] - (not= "" line))) - (&/enumerate lines))))) + (&/V $Done (&/T (&/T file-name line-num column-num) text)) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) text) + (&/T (&/T file-name line-num column-num*) line))))) + (&/V $No (str "[Reader Error] Text failed: " text)))))) + +(defn from [^String name ^String source-code] + (->> source-code + (string/split-lines) + (&/->list) + (&/enumerate) + (&/|filter (fn [line+line-num] + (|let [[line-num line] line+line-num] + (not= "" line)))) + (&/|map (fn [line+line-num] + (|let [[line-num line] line+line-num] + (&/T (&/T name (inc line-num) 0) + line)))))) diff --git a/src/lux/type.clj b/src/lux/type.clj index f5b8d3f25..6ae542b68 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -1,240 +1,184 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.type (:refer-clojure :exclude [deref apply merge bound?]) - (:require [clojure.core.match :as M :refer [match matchv]] + (:require clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* assert! |let]])) + (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]]) + [lux.type.host :as &&host])) (declare show-type) -;; [Util] -(def Bool (&/V "lux;DataT" "java.lang.Boolean")) -(def Int (&/V "lux;DataT" "java.lang.Long")) -(def Real (&/V "lux;DataT" "java.lang.Double")) -(def Char (&/V "lux;DataT" "java.lang.Character")) -(def Text (&/V "lux;DataT" "java.lang.String")) -(def Unit (&/V "lux;TupleT" (&/|list))) -(def $Void (&/V "lux;VariantT" (&/|list))) +;; [Utils] +(defn |list? [xs] + (|case xs + (&/$Nil) + true + + (&/$Cons x xs*) + (|list? xs*) + + _ + false)) + +(def empty-env &/Nil$) +(defn Data$ [name params] + (&/V &/$DataT (&/T name params))) +(defn Bound$ [idx] + (&/V &/$BoundT idx)) +(defn Var$ [id] + (&/V &/$VarT id)) +(defn Lambda$ [in out] + (&/V &/$LambdaT (&/T in out))) +(defn App$ [fun arg] + (&/V &/$AppT (&/T fun arg))) +(defn Tuple$ [members] + (&/V &/$TupleT members)) +(defn Variant$ [members] + (&/V &/$VariantT members)) +(defn Univ$ [env body] + (&/V &/$UnivQ (&/T env body))) +(defn Named$ [name type] + (&/V &/$NamedT (&/T name type))) + + +(def Bool (Named$ (&/T "lux" "Bool") (Data$ "java.lang.Boolean" &/Nil$))) +(def Int (Named$ (&/T "lux" "Int") (Data$ "java.lang.Long" &/Nil$))) +(def Real (Named$ (&/T "lux" "Real") (Data$ "java.lang.Double" &/Nil$))) +(def Char (Named$ (&/T "lux" "Char") (Data$ "java.lang.Character" &/Nil$))) +(def Text (Named$ (&/T "lux" "Text") (Data$ "java.lang.String" &/Nil$))) +(def Unit (Named$ (&/T "lux" "Unit") (Tuple$ &/Nil$))) +(def $Void (Named$ (&/T "lux" "Void") (Variant$ &/Nil$))) +(def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text)))) (def IO - (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "IO" "a" - (&/V "lux;LambdaT" (&/T Unit (&/V "lux;BoundT" "a")))))) + (Named$ (&/T "lux/data" "IO") + (Univ$ empty-env + (Lambda$ Unit (Bound$ 1))))) (def List - (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "lux;List" "a" - (&/V "lux;VariantT" (&/|list (&/T "lux;Nil" Unit) - (&/T "lux;Cons" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "a") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;List") - (&/V "lux;BoundT" "a"))))))))))) + (Named$ (&/T "lux" "List") + (Univ$ empty-env + (Variant$ (&/|list + ;; lux;Nil + Unit + ;; lux;Cons + (Tuple$ (&/|list (Bound$ 1) + (App$ (Bound$ 0) + (Bound$ 1)))) + ))))) (def Maybe - (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "lux;Maybe" "a" - (&/V "lux;VariantT" (&/|list (&/T "lux;None" Unit) - (&/T "lux;Some" (&/V "lux;BoundT" "a"))))))) + (Named$ (&/T "lux" "Maybe") + (Univ$ empty-env + (Variant$ (&/|list + ;; lux;None + Unit + ;; lux;Some + (Bound$ 1) + ))))) (def Type - (let [Type (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Type") (&/V "lux;BoundT" "_"))) - TypeEnv (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Type)))) - TypePair (&/V "lux;TupleT" (&/|list Type Type))] - (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "Type" "_" - (&/V "lux;VariantT" (&/|list (&/T "lux;DataT" Text) - (&/T "lux;TupleT" (&/V "lux;AppT" (&/T List Type))) - (&/T "lux;VariantT" TypeEnv) - (&/T "lux;RecordT" TypeEnv) - (&/T "lux;LambdaT" TypePair) - (&/T "lux;BoundT" Text) - (&/T "lux;VarT" Int) - (&/T "lux;AllT" (&/V "lux;TupleT" (&/|list (&/V "lux;AppT" (&/T Maybe TypeEnv)) Text Text Type))) - (&/T "lux;AppT" TypePair) - (&/T "lux;ExT" Int) - )))) - $Void)))) - -(defn fAll [name arg body] - (&/V "lux;AllT" (&/T (&/V "lux;None" nil) name arg body))) - -(def Bindings - (fAll "lux;Bindings" "k" - (fAll "" "v" - (&/V "lux;RecordT" (&/|list (&/T "lux;counter" Int) - (&/T "lux;mappings" (&/V "lux;AppT" (&/T List - (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "k") - (&/V "lux;BoundT" "v"))))))))))) - -(def Env - (let [bindings (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings (&/V "lux;BoundT" "k"))) - (&/V "lux;BoundT" "v")))] - (fAll "lux;Env" "k" - (fAll "" "v" - (&/V "lux;RecordT" - (&/|list (&/T "lux;name" Text) - (&/T "lux;inner-closures" Int) - (&/T "lux;locals" bindings) - (&/T "lux;closure" bindings) - )))))) - -(def Cursor - (&/V "lux;TupleT" (&/|list Text Int Int))) - -(def Meta - (fAll "lux;Meta" "m" - (fAll "" "v" - (&/V "lux;VariantT" (&/|list (&/T "lux;Meta" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "m") - (&/V "lux;BoundT" "v"))))))))) - -(def Ident (&/V "lux;TupleT" (&/|list Text Text))) - -(def Syntax* - (let [Syntax* (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "w") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Syntax'") - (&/V "lux;BoundT" "w"))))) - Syntax*List (&/V "lux;AppT" (&/T List Syntax*))] - (fAll "lux;Syntax'" "w" - (&/V "lux;VariantT" (&/|list (&/T "lux;BoolS" Bool) - (&/T "lux;IntS" Int) - (&/T "lux;RealS" Real) - (&/T "lux;CharS" Char) - (&/T "lux;TextS" Text) - (&/T "lux;SymbolS" Ident) - (&/T "lux;TagS" Ident) - (&/T "lux;FormS" Syntax*List) - (&/T "lux;TupleS" Syntax*List) - (&/T "lux;RecordS" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Syntax* Syntax*)))))) - )))) - -(def Syntax - (let [w (&/V "lux;AppT" (&/T Meta Cursor))] - (&/V "lux;AppT" (&/T w (&/V "lux;AppT" (&/T Syntax* w)))))) - -(def ^:private SyntaxList (&/V "lux;AppT" (&/T List Syntax))) - -(def Either - (fAll "lux;Either" "l" - (fAll "" "r" - (&/V "lux;VariantT" (&/|list (&/T "lux;Left" (&/V "lux;BoundT" "l")) - (&/T "lux;Right" (&/V "lux;BoundT" "r"))))))) - -(def StateE - (fAll "lux;StateE" "s" - (fAll "" "a" - (&/V "lux;LambdaT" (&/T (&/V "lux;BoundT" "s") - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Either Text)) - (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "s") - (&/V "lux;BoundT" "a")))))))))) - -(def Reader - (&/V "lux;AppT" (&/T List - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Meta Cursor)) - Text))))) - -(def HostState - (&/V "lux;RecordT" - (&/|list (&/T "lux;writer" (&/V "lux;DataT" "org.objectweb.asm.ClassWriter")) - (&/T "lux;loader" (&/V "lux;DataT" "java.lang.ClassLoader")) - (&/T "lux;classes" (&/V "lux;DataT" "clojure.lang.Atom"))))) - -(def DefData* - (fAll "lux;DefData'" "" - (&/V "lux;VariantT" (&/|list (&/T "lux;TypeD" Unit) - (&/T "lux;ValueD" Type) - (&/T "lux;MacroD" (&/V "lux;BoundT" "")) - (&/T "lux;AliasD" Ident))))) - -(def LuxVar - (&/V "lux;VariantT" (&/|list (&/T "lux;Local" Int) - (&/T "lux;Global" Ident)))) - -(def $Module - (fAll "lux;$Module" "Compiler" - (&/V "lux;RecordT" - (&/|list (&/T "lux;module-aliases" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Text))))) - (&/T "lux;defs" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" - (&/|list Text - (&/V "lux;TupleT" (&/|list Bool - (&/V "lux;AppT" (&/T DefData* - (&/V "lux;LambdaT" (&/T SyntaxList - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;BoundT" "Compiler"))) - SyntaxList))))))))))))) - (&/T "lux;imports" (&/V "lux;AppT" (&/T List Text))))))) - -(def $Compiler - (&/V "lux;AppT" (&/T (fAll "lux;Compiler" "" - (&/V "lux;RecordT" - (&/|list (&/T "lux;source" Reader) - (&/T "lux;modules" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" - (&/|list Text - (&/V "lux;AppT" (&/T $Module (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Compiler") (&/V "lux;BoundT" "")))))))))) - (&/T "lux;envs" (&/V "lux;AppT" (&/T List - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Env Text)) - (&/V "lux;TupleT" (&/|list LuxVar Type))))))) - (&/T "lux;types" (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings Int)) Type))) - (&/T "lux;host" HostState) - (&/T "lux;seed" Int) - (&/T "lux;eval?" Bool)))) - $Void))) - -(def Macro - (&/V "lux;LambdaT" (&/T SyntaxList - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE $Compiler)) - SyntaxList))))) + (Named$ (&/T "lux" "Type") + (let [Type (App$ (Bound$ 0) (Bound$ 1)) + TypeList (App$ List Type) + TypePair (Tuple$ (&/|list Type Type))] + (App$ (Univ$ empty-env + (Variant$ (&/|list + ;; DataT + (Tuple$ (&/|list Text TypeList)) + ;; VariantT + TypeList + ;; TupleT + TypeList + ;; LambdaT + TypePair + ;; BoundT + Int + ;; VarT + Int + ;; ExT + Int + ;; UnivQ + (Tuple$ (&/|list TypeList Type)) + ;; ExQ + (Tuple$ (&/|list TypeList Type)) + ;; AppT + TypePair + ;; NamedT + (Tuple$ (&/|list Ident Type)) + ))) + $Void)))) + +(def Macro) + +(defn set-macro-type! [type] + (def Macro type) + nil) (defn bound? [id] (fn [state] - (if-let [type (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (matchv ::M/objects [type] - [["lux;Some" type*]] + (if-let [type (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (|case type + (&/$Some type*) (return* state true) - [["lux;None" _]] + (&/$None) (return* state false)) (fail* (str "[Type Error] <bound?> Unknown type-var: " id))))) (defn deref [id] (fn [state] - (if-let [type* (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (matchv ::M/objects [type*] - [["lux;Some" type]] + (if-let [type* (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (|case type* + (&/$Some type) (return* state type) - [["lux;None" _]] + (&/$None) (fail* (str "[Type Error] Unbound type-var: " id))) (fail* (str "[Type Error] <deref> Unknown type-var: " id))))) +(defn deref+ [type] + (|case type + (&/$VarT id) + (deref id) + + _ + (fail (str "[Type Error] Type is not a variable: " (show-type type))) + )) + (defn set-var [id type] (fn [state] - (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (matchv ::M/objects [tvar] - [["lux;Some" bound]] + (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (|case tvar + (&/$Some bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) - [["lux;None" _]] - (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %) - ts)) + (&/$None) + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) + ts)) state) nil)) - (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length)))))) + (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) ;; [Exports] ;; Type vars (def ^:private create-var (fn [state] - (let [id (->> state (&/get$ &/$TYPES) (&/get$ &/$COUNTER))] - (return* (&/update$ &/$TYPES #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [ms] (&/|put id (&/V "lux;None" nil) ms)))) + (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] + (return* (&/update$ &/$type-vars #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [ms] (&/|put id &/None$ ms)))) state) id)))) (def existential + ;; (Lux Type) (|do [seed &/gen-id] - (return (&/V "lux;ExT" seed)))) + (return (&/V &/$ExT seed)))) (declare clean*) (defn ^:private delete-var [id] @@ -248,249 +192,190 @@ (|let [[?id ?type] binding] (if (.equals ^Object id ?id) (return binding) - (matchv ::M/objects [?type] - [["lux;None" _]] + (|case ?type + (&/$None) (return binding) - [["lux;Some" ?type*]] - (matchv ::M/objects [?type*] - [["lux;VarT" ?id*]] + (&/$Some ?type*) + (|case ?type* + (&/$VarT ?id*) (if (.equals ^Object id ?id*) - (return (&/T ?id (&/V "lux;None" nil))) + (return (&/T ?id &/None$)) (return binding)) - [_] + _ (|do [?type** (clean* id ?type*)] - (return (&/T ?id (&/V "lux;Some" ?type**))))) + (return (&/T ?id (&/V &/$Some ?type**))))) )))) - (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS)))] + (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] (fn [state] - (return* (&/update$ &/$TYPES #(->> % - (&/update$ &/$COUNTER dec) - (&/set$ &/$MAPPINGS (&/|remove id mappings*))) + (return* (&/update$ &/$type-vars #(&/set$ &/$mappings (&/|remove id mappings*) %) state) nil))) state)))) (defn with-var [k] (|do [id create-var - output (k (&/V "lux;VarT" id)) + output (k (Var$ id)) _ (delete-var id)] (return output))) -(defn with-vars [amount k] - (|do [=vars (&/map% (constantly create-var) (&/|range amount)) - output (k (&/|map #(&/V "lux;VarT" %) =vars)) - _ (&/map% delete-var (&/|reverse =vars))] - (return output))) - (defn clean* [?tid type] - (matchv ::M/objects [type] - [["lux;VarT" ?id]] + (|case type + (&/$VarT ?id) (if (.equals ^Object ?tid ?id) (deref ?id) (return type)) - [["lux;LambdaT" [?arg ?return]]] + (&/$LambdaT ?arg ?return) (|do [=arg (clean* ?tid ?arg) =return (clean* ?tid ?return)] - (return (&/V "lux;LambdaT" (&/T =arg =return)))) + (return (Lambda$ =arg =return))) - [["lux;AppT" [?lambda ?param]]] + (&/$AppT ?lambda ?param) (|do [=lambda (clean* ?tid ?lambda) =param (clean* ?tid ?param)] - (return (&/V "lux;AppT" (&/T =lambda =param)))) + (return (App$ =lambda =param))) - [["lux;TupleT" ?members]] + (&/$TupleT ?members) (|do [=members (&/map% (partial clean* ?tid) ?members)] - (return (&/V "lux;TupleT" =members))) + (return (Tuple$ =members))) - [["lux;VariantT" ?members]] - (|do [=members (&/map% (fn [[k v]] - (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) - ?members)] - (return (&/V "lux;VariantT" =members))) - - [["lux;RecordT" ?members]] - (|do [=members (&/map% (fn [[k v]] - (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) - ?members)] - (return (&/V "lux;RecordT" =members))) - - [["lux;AllT" [?env ?name ?arg ?body]]] - (|do [=env (matchv ::M/objects [?env] - [["lux;None" _]] - (return ?env) - - [["lux;Some" ?env*]] - (|do [clean-env (&/map% (fn [[k v]] - (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) - ?env*)] - (return (&/V "lux;Some" clean-env)))) + (&/$VariantT ?members) + (|do [=members (&/map% (partial clean* ?tid) ?members)] + (return (Variant$ =members))) + + (&/$UnivQ ?env ?body) + (|do [=env (&/map% (partial clean* ?tid) ?env) body* (clean* ?tid ?body)] - (return (&/V "lux;AllT" (&/T =env ?name ?arg body*)))) + (return (Univ$ =env body*))) - [_] + _ (return type) )) (defn clean [tvar type] - (matchv ::M/objects [tvar] - [["lux;VarT" ?id]] + (|case tvar + (&/$VarT ?id) (clean* ?id type) - [_] + _ (fail (str "[Type Error] Not type-var: " (show-type tvar))))) (defn ^:private unravel-fun [type] - (matchv ::M/objects [type] - [["lux;LambdaT" [?in ?out]]] + (|case type + (&/$LambdaT ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] - (&/T ??out (&/|cons ?in ?args))) + (&/T ??out (&/Cons$ ?in ?args))) - [_] - (&/T type (&/|list)))) + _ + (&/T type &/Nil$))) (defn ^:private unravel-app [fun-type] - (matchv ::M/objects [fun-type] - [["lux;AppT" [?left ?right]]] + (|case fun-type + (&/$AppT ?left ?right) (|let [[?fun-type ?args] (unravel-app ?left)] (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) - [_] - (&/T fun-type (&/|list)))) + _ + (&/T fun-type &/Nil$))) (defn show-type [^objects type] - (matchv ::M/objects [type] - [["lux;DataT" name]] - (str "(^ " name ")") + (|case type + (&/$DataT name params) + (|case params + (&/$Nil) + (str "(^ " name ")") + + _ + (str "(^ " name " " (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - [["lux;TupleT" elems]] + (&/$TupleT elems) (if (&/|empty? elems) "(,)" (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - [["lux;VariantT" cases]] + (&/$VariantT cases) (if (&/|empty? cases) "(|)" (str "(| " (->> cases - (&/|map (fn [kv] - (matchv ::M/objects [kv] - [[k ["lux;TupleT" ["lux;Nil" _]]]] - (str "#" k) - - [[k v]] - (str "(#" k " " (show-type v) ")")))) + (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - - [["lux;RecordT" fields]] - (str "(& " (->> fields - (&/|map (fn [kv] - (matchv ::M/objects [kv] - [[k v]] - (str "#" k " " (show-type v))))) - (&/|interpose " ") - (&/fold str "")) ")") - - [["lux;LambdaT" [input output]]] + (&/$LambdaT input output) (|let [[?out ?ins] (unravel-fun type)] (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) - [["lux;VarT" id]] + (&/$VarT id) (str "⌈" id "⌋") - [["lux;ExT" ?id]] + (&/$ExT ?id) (str "⟨" ?id "⟩") - [["lux;BoundT" name]] - name + (&/$BoundT idx) + (str idx) - [["lux;AppT" [_ _]]] + (&/$AppT _ _) (|let [[?call-fun ?call-args] (unravel-app type)] (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - [["lux;AllT" [?env ?name ?arg ?body]]] - (if (= "" ?name) - (let [[args body] (loop [args (list ?arg) - body* ?body] - (matchv ::M/objects [body*] - [["lux;AllT" [?env* ?name* ?arg* ?body*]]] - (recur (cons ?arg* args) ?body*) - - [_] - [args body*]))] - (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) - ?name) - )) + (&/$UnivQ ?env ?body) + (str "(All " (show-type ?body) ")") + + (&/$NamedT ?name ?type) + (&/ident->text ?name) + + _ + (assert false (prn-str 'show-type (&/adt->text type))))) (defn type= [x y] (or (clojure.lang.Util/identical x y) - (let [output (matchv ::M/objects [x y] - [["lux;DataT" xname] ["lux;DataT" yname]] - (.equals ^Object xname yname) + (let [output (|case [x y] + [(&/$NamedT [?xmodule ?xname] ?xtype) (&/$NamedT [?ymodule ?yname] ?ytype)] + (and (= ?xmodule ?ymodule) + (= ?xname ?yname)) + + [(&/$DataT xname xparams) (&/$DataT yname yparams)] + (and (.equals ^Object xname yname) + (= (&/|length xparams) (&/|length yparams)) + (&/fold2 #(and %1 (type= %2 %3)) true xparams yparams)) - [["lux;TupleT" xelems] ["lux;TupleT" yelems]] - (&/fold2 (fn [old x y] - (and old (type= x y))) + [(&/$TupleT xelems) (&/$TupleT yelems)] + (&/fold2 (fn [old x y] (and old (type= x y))) true xelems yelems) - [["lux;VariantT" xcases] ["lux;VariantT" ycases]] - (&/fold2 (fn [old xcase ycase] - (|let [[xname xtype] xcase - [yname ytype] ycase] - (and old (.equals ^Object xname yname) (type= xtype ytype)))) + [(&/$VariantT xcases) (&/$VariantT ycases)] + (&/fold2 (fn [old x y] (and old (type= x y))) true xcases ycases) - [["lux;RecordT" xslots] ["lux;RecordT" yslots]] - (&/fold2 (fn [old xslot yslot] - (|let [[xname xtype] xslot - [yname ytype] yslot] - (and old (.equals ^Object xname yname) (type= xtype ytype)))) - true - xslots yslots) - - [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]] + [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)] (and (type= xinput yinput) (type= xoutput youtput)) - [["lux;VarT" xid] ["lux;VarT" yid]] + [(&/$VarT xid) (&/$VarT yid)] (.equals ^Object xid yid) - [["lux;BoundT" xname] ["lux;BoundT" yname]] - (.equals ^Object xname yname) + [(&/$BoundT xidx) (&/$BoundT yidx)] + (= xidx yidx) - [["lux;ExT" xid] ["lux;ExT" yid]] + [(&/$ExT xid) (&/$ExT yid)] (.equals ^Object xid yid) - [["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]] + [(&/$AppT xlambda xparam) (&/$AppT ylambda yparam)] (and (type= xlambda ylambda) (type= xparam yparam)) - [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]] - (and (.equals ^Object xname yname) - (.equals ^Object xarg yarg) - ;; (matchv ::M/objects [xenv yenv] - ;; [["lux;None" _] ["lux;None" _]] - ;; true - - ;; [["lux;Some" xenv*] ["lux;Some" yenv*]] - ;; (&/fold (fn [old bname] - ;; (and old - ;; (type= (&/|get bname xenv*) (&/|get bname yenv*)))) - ;; (= (&/|length xenv*) (&/|length yenv*)) - ;; (&/|keys xenv*)) - - ;; [_ _] - ;; false) - (type= xbody ybody) - ) + [(&/$UnivQ xenv xbody) (&/$UnivQ yenv ybody)] + (type= xbody ybody) + + [(&/$NamedT ?xname ?xtype) _] + (type= ?xtype y) + [_ (&/$NamedT ?yname ?ytype)] + (type= x ?ytype) + [_ _] false )] @@ -498,19 +383,19 @@ (defn ^:private fp-get [k fixpoints] (|let [[e a] k] - (matchv ::M/objects [fixpoints] - [["lux;Nil" _]] - (&/V "lux;None" nil) + (|case fixpoints + (&/$Nil) + &/None$ - [["lux;Cons" [[[e* a*] v*] fixpoints*]]] + (&/$Cons [[e* a*] v*] fixpoints*) (if (and (type= e e*) (type= a a*)) - (&/V "lux;Some" v*) + (&/V &/$Some v*) (fp-get k fixpoints*)) ))) (defn ^:private fp-put [k v fixpoints] - (&/|cons (&/T k v) fixpoints)) + (&/Cons$ (&/T k v) fixpoints)) (defn ^:private check-error [expected actual] (str "[Type Checker]\nExpected: " (show-type expected) @@ -518,227 +403,157 @@ "\n")) (defn beta-reduce [env type] - (matchv ::M/objects [type] - [["lux;VariantT" ?cases]] - (&/V "lux;VariantT" (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (beta-reduce env v)))) - ?cases)) - - [["lux;RecordT" ?fields]] - (&/V "lux;RecordT" (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (beta-reduce env v)))) - ?fields)) - - [["lux;TupleT" ?members]] - (&/V "lux;TupleT" (&/|map (partial beta-reduce env) ?members)) - - [["lux;AppT" [?type-fn ?type-arg]]] - (&/V "lux;AppT" (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))) - - [["lux;AllT" [?local-env ?local-name ?local-arg ?local-def]]] - (matchv ::M/objects [?local-env] - [["lux;None" _]] - (&/V "lux;AllT" (&/T (&/V "lux;Some" env) ?local-name ?local-arg ?local-def)) - - [["lux;Some" _]] + (|case type + (&/$VariantT ?members) + (Variant$ (&/|map (partial beta-reduce env) ?members)) + + (&/$TupleT ?members) + (Tuple$ (&/|map (partial beta-reduce env) ?members)) + + (&/$AppT ?type-fn ?type-arg) + (App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) + + (&/$UnivQ ?local-env ?local-def) + (|case ?local-env + (&/$Nil) + (Univ$ env ?local-def) + + _ type) - [["lux;LambdaT" [?input ?output]]] - (&/V "lux;LambdaT" (&/T (beta-reduce env ?input) (beta-reduce env ?output))) + (&/$LambdaT ?input ?output) + (Lambda$ (beta-reduce env ?input) (beta-reduce env ?output)) - [["lux;BoundT" ?name]] - (if-let [bound (&/|get ?name env)] + (&/$BoundT ?idx) + (|case (&/|at ?idx env) + (&/$Some bound) (beta-reduce env bound) - type) - [_] + _ + (assert false (str "[Type Error] Unknown var: " ?idx " | " (&/->seq (&/|map show-type env))))) + + _ type )) -(defn slot-type [record slot] - (fn [state] - (matchv ::M/objects [(&/|get slot record)] - [["lux;Left" msg]] - (fail* msg) - - [["lux;Right" type]] - (return* state type)))) - (defn apply-type [type-fn param] - (matchv ::M/objects [type-fn] - [["lux;AllT" [local-env local-name local-arg local-def]]] - (let [local-env* (matchv ::M/objects [local-env] - [["lux;None" _]] - (&/|table) - - [["lux;Some" local-env*]] - local-env*)] - (return (beta-reduce (->> local-env* - (&/|put local-name type-fn) - (&/|put local-arg param)) - local-def))) - - [["lux;AppT" [F A]]] + (|case type-fn + (&/$UnivQ local-env local-def) + (return (beta-reduce (->> local-env + (&/Cons$ param) + (&/Cons$ type-fn)) + local-def)) + + (&/$AppT F A) (|do [type-fn* (apply-type F A)] (apply-type type-fn* param)) + + (&/$NamedT ?name ?type) + (apply-type ?type param) + + (&/$ExT id) + (return (App$ type-fn param)) - [_] - (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n")))) - -(defn as-obj [class] - (case class - "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" - ;; else - class)) - -(def ^:private primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}) - -(def ^:private init-fixpoints (&/|list)) - -(defn ^:private check* [class-loader fixpoints expected actual] + _ + (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) + +(def ^:private init-fixpoints &/Nil$) + +(defn ^:private check* [class-loader fixpoints invariant?? expected actual] (if (clojure.lang.Util/identical expected actual) (return (&/T fixpoints nil)) - (matchv ::M/objects [expected actual] - [["lux;VarT" ?eid] ["lux;VarT" ?aid]] + (|case [expected actual] + [(&/$VarT ?eid) (&/$VarT ?aid)] (if (.equals ^Object ?eid ?aid) (return (&/T fixpoints nil)) (|do [ebound (fn [state] - (matchv ::M/objects [((deref ?eid) state)] - [["lux;Right" [state* ebound]]] - (return* state* (&/V "lux;Some" ebound)) + (|case ((deref ?eid) state) + (&/$Right state* ebound) + (return* state* (&/V &/$Some ebound)) - [["lux;Left" _]] - (return* state (&/V "lux;None" nil)))) + (&/$Left _) + (return* state &/None$))) abound (fn [state] - (matchv ::M/objects [((deref ?aid) state)] - [["lux;Right" [state* abound]]] - (return* state* (&/V "lux;Some" abound)) - - [["lux;Left" _]] - (return* state (&/V "lux;None" nil))))] - (matchv ::M/objects [ebound abound] - [["lux;None" _] ["lux;None" _]] + (|case ((deref ?aid) state) + (&/$Right state* abound) + (return* state* (&/V &/$Some abound)) + + (&/$Left _) + (return* state &/None$)))] + (|case [ebound abound] + [(&/$None _) (&/$None _)] (|do [_ (set-var ?eid actual)] (return (&/T fixpoints nil))) - [["lux;Some" etype] ["lux;None" _]] - (check* class-loader fixpoints etype actual) + [(&/$Some etype) (&/$None _)] + (check* class-loader fixpoints invariant?? etype actual) - [["lux;None" _] ["lux;Some" atype]] - (check* class-loader fixpoints expected atype) + [(&/$None _) (&/$Some atype)] + (check* class-loader fixpoints invariant?? expected atype) - [["lux;Some" etype] ["lux;Some" atype]] - (check* class-loader fixpoints etype atype)))) + [(&/$Some etype) (&/$Some atype)] + (check* class-loader fixpoints invariant?? etype atype)))) - [["lux;VarT" ?id] _] + [(&/$VarT ?id) _] (fn [state] - (matchv ::M/objects [((set-var ?id actual) state)] - [["lux;Right" [state* _]]] + (|case ((set-var ?id actual) state) + (&/$Right state* _) (return* state* (&/T fixpoints nil)) - [["lux;Left" _]] + (&/$Left _) ((|do [bound (deref ?id)] - (check* class-loader fixpoints bound actual)) + (check* class-loader fixpoints invariant?? bound actual)) state))) - [_ ["lux;VarT" ?id]] + [_ (&/$VarT ?id)] (fn [state] - (matchv ::M/objects [((set-var ?id expected) state)] - [["lux;Right" [state* _]]] + (|case ((set-var ?id expected) state) + (&/$Right state* _) (return* state* (&/T fixpoints nil)) - [["lux;Left" _]] + (&/$Left _) ((|do [bound (deref ?id)] - (check* class-loader fixpoints expected bound)) + (check* class-loader fixpoints invariant?? expected bound)) state))) - [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] - (fn [state] - (matchv ::M/objects [((|do [F1 (deref ?eid)] - (fn [state] - (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" _]] - ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) - state)))) - state)] - [["lux;Right" [state* output]]] - (return* state* output) + [(&/$AppT (&/$ExT eid) eA) (&/$AppT (&/$ExT aid) aA)] + (if (= eid aid) + (check* class-loader fixpoints invariant?? eA aA) + (fail (check-error expected actual))) - [["lux;Left" _]] - (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" _]] - ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) - [fixpoints** _] (check* class-loader fixpoints* A1 A2)] - (return (&/T fixpoints** nil))) - state)))) - ;; (|do [_ (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) - ;; _ (check* class-loader fixpoints A1 A2)] - ;; (return (&/T fixpoints nil))) - - [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] + [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] - (matchv ::M/objects [((|do [F1 (deref ?id)] - (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) - state)] - [["lux;Right" [state* output]]] + (|case ((|do [F1 (deref ?id)] + (check* class-loader fixpoints invariant?? (App$ F1 A1) actual)) + state) + (&/$Right state* output) (return* state* output) - [["lux;Left" _]] - ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) + (&/$Left _) + ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (Var$ ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) - [fixpoints** _] (check* class-loader fixpoints* e* a*)] + [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)] (return (&/T fixpoints** nil))) state))) - ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) - ;; e* (apply-type F2 A1) - ;; a* (apply-type F2 A2) - ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] - ;; (return (&/T fixpoints** nil))) - [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] + [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] - (matchv ::M/objects [((|do [F2 (deref ?id)] - (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] + (|case ((|do [F2 (deref ?id)] + (check* class-loader fixpoints invariant?? expected (App$ F2 A2))) + state) + (&/$Right state* output) (return* state* output) - [["lux;Left" _]] - ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) + (&/$Left _) + ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? F1 (Var$ ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) - [fixpoints** _] (check* class-loader fixpoints* e* a*)] + [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)] (return (&/T fixpoints** nil))) state))) - ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) - ;; e* (apply-type F1 A1) - ;; a* (apply-type F1 A2) - ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] - ;; (return (&/T fixpoints** nil))) - - [["lux;AppT" [F A]] _] + + [(&/$AppT F A) _] (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) (println 'FIXPOINTS (->> (&/|keys fixpoints) @@ -748,132 +563,164 @@ (show-type a))))) (&/|interpose "\n\n") (&/fold str ""))) - (assert false))] - (matchv ::M/objects [(fp-get fp-pair fixpoints)] - [["lux;Some" ?]] + (assert false (prn-str 'check* '[(&/$AppT F A) _] (&/|length fixpoints) (show-type expected) (show-type actual))))] + (|case (fp-get fp-pair fixpoints) + (&/$Some ?) (if ? (return (&/T fixpoints nil)) (fail (check-error expected actual))) - [["lux;None" _]] + (&/$None) (|do [expected* (apply-type F A)] - (check* class-loader (fp-put fp-pair true fixpoints) expected* actual)))) + (check* class-loader (fp-put fp-pair true fixpoints) invariant?? expected* actual)))) - [_ ["lux;AppT" [F A]]] + [_ (&/$AppT F A)] (|do [actual* (apply-type F A)] - (check* class-loader fixpoints expected actual*)) + (check* class-loader fixpoints invariant?? expected actual*)) - [["lux;AllT" _] _] + [(&/$UnivQ _) _] + (|do [$arg existential + expected* (apply-type expected $arg)] + (check* class-loader fixpoints invariant?? expected* actual)) + + [_ (&/$UnivQ _)] (with-var (fn [$arg] - (|do [expected* (apply-type expected $arg)] - (check* class-loader fixpoints expected* actual)))) + (|do [actual* (apply-type actual $arg)] + (check* class-loader fixpoints invariant?? expected actual*)))) - [_ ["lux;AllT" _]] + [(&/$ExQ e!env e!def) _] (with-var (fn [$arg] - (|do [actual* (apply-type actual $arg)] - (check* class-loader fixpoints expected actual*)))) - - [["lux;DataT" e!name] ["lux;DataT" "null"]] - (if (contains? primitive-types e!name) - (fail (str "[Type Error] Can't use \"null\" with primitive types.")) - (return (&/T fixpoints nil))) - - [["lux;DataT" e!name] ["lux;DataT" a!name]] - (let [e!name (as-obj e!name) - a!name (as-obj a!name)] - (if (or (.equals ^Object e!name a!name) - (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) - (return (&/T fixpoints nil)) - (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) - - [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]] - (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] - (check* class-loader fixpoints* eO aO)) - - [["lux;TupleT" e!members] ["lux;TupleT" a!members]] + (|let [expected* (beta-reduce (->> e!env + (&/Cons$ $arg) + (&/Cons$ expected)) + e!def)] + (check* class-loader fixpoints invariant?? expected* actual)))) + + [_ (&/$ExQ a!env a!def)] + (|do [$arg existential] + (|let [actual* (beta-reduce (->> a!env + (&/Cons$ $arg) + (&/Cons$ expected)) + a!def)] + (check* class-loader fixpoints invariant?? expected actual*))) + + [(&/$DataT e!data) (&/$DataT a!data)] + (&&host/check-host-types (partial check* class-loader fixpoints true) + check-error + fixpoints + existential + class-loader + invariant?? + e!data + a!data) + + [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] + (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? aI eI)] + (check* class-loader fixpoints* invariant?? eO aO)) + + [(&/$TupleT e!members) (&/$TupleT a!members)] (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* class-loader fp e a)] + (|do [[fp* _] (check* class-loader fp invariant?? e a)] (return fp*))) fixpoints e!members a!members)] (return (&/T fixpoints* nil))) - [["lux;VariantT" e!cases] ["lux;VariantT" a!cases]] - (|do [fixpoints* (&/fold2% (fn [fp e!case a!case] - (|let [[e!name e!type] e!case - [a!name a!type] a!case] - (if (.equals ^Object e!name a!name) - (|do [[fp* _] (check* class-loader fp e!type a!type)] - (return fp*)) - (fail (check-error expected actual))))) - fixpoints - e!cases a!cases)] - (return (&/T fixpoints* nil))) + [_ (&/$VariantT (&/$Nil))] + (return (&/T fixpoints nil)) - [["lux;RecordT" e!slots] ["lux;RecordT" a!slots]] - (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot] - (|let [[e!name e!type] e!slot - [a!name a!type] a!slot] - (if (.equals ^Object e!name a!name) - (|do [[fp* _] (check* class-loader fp e!type a!type)] - (return fp*)) - (fail (check-error expected actual))))) + [(&/$VariantT e!cases) (&/$VariantT a!cases)] + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* class-loader fp invariant?? e a)] + (return fp*))) fixpoints - e!slots a!slots)] + e!cases a!cases)] (return (&/T fixpoints* nil))) - [["lux;ExT" e!id] ["lux;ExT" a!id]] + [(&/$ExT e!id) (&/$ExT a!id)] (if (.equals ^Object e!id a!id) (return (&/T fixpoints nil)) (fail (check-error expected actual))) + [(&/$NamedT ?ename ?etype) _] + (check* class-loader fixpoints invariant?? ?etype actual) + + [_ (&/$NamedT ?aname ?atype)] + (check* class-loader fixpoints invariant?? expected ?atype) + [_ _] (fail (check-error expected actual)) ))) (defn check [expected actual] (|do [class-loader &/loader - _ (check* class-loader init-fixpoints expected actual)] + _ (check* class-loader init-fixpoints false expected actual)] (return nil))) -(defn apply-lambda [func param] - (matchv ::M/objects [func] - [["lux;LambdaT" [input output]]] - (|do [_ (check* init-fixpoints input param)] - (return output)) - - [["lux;AllT" _]] - (with-var - (fn [$var] - (|do [func* (apply-type func $var) - =return (apply-lambda func* param)] - (clean $var =return)))) - - [_] - (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) - )) - (defn actual-type [type] - (matchv ::M/objects [type] - [["lux;AppT" [?all ?param]]] + "(-> Type (Lux Type))" + (|case type + (&/$AppT ?all ?param) (|do [type* (apply-type ?all ?param)] (actual-type type*)) - [["lux;VarT" ?id]] - (deref ?id) + (&/$VarT id) + (|do [=type (deref id)] + (actual-type =type)) + + (&/$NamedT ?name ?type) + (actual-type ?type) - [_] + _ (return type) )) -(defn variant-case [case type] - (matchv ::M/objects [type] - [["lux;VariantT" ?cases]] - (if-let [case-type (&/|get case ?cases)] +(defn variant-case [tag type] + (|case type + (&/$NamedT ?name ?type) + (variant-case tag ?type) + + (&/$VariantT ?cases) + (|case (&/|at tag ?cases) + (&/$Some case-type) (return case-type) - (fail (str "[Type Error] Variant lacks case: " case " | " (show-type type)))) - [_] + (&/$None) + (fail (str "[Type Error] Variant lacks case: " tag " | " (show-type type)))) + + _ (fail (str "[Type Error] Type is not a variant: " (show-type type))))) + +(defn type-name [type] + "(-> Type (Lux Ident))" + (|case type + (&/$NamedT name _) + (return name) + + _ + (fail (str "[Type Error] Type is not named: " (show-type type))) + )) + +(defn unknown? [type] + "(-> Type (Lux Bool))" + (|case type + (&/$VarT id) + (|do [? (bound? id)] + (return (not ?))) + + _ + (return false))) + +(defn resolve-type [type] + "(-> Type (Lux Type))" + (|case type + (&/$VarT id) + (|do [? (bound? id)] + (if ? + (deref id) + (return type))) + + _ + (return type))) diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj new file mode 100644 index 000000000..d4627b273 --- /dev/null +++ b/src/lux/type/host.clj @@ -0,0 +1,220 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.type.host + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]])) + (:import (java.lang.reflect GenericArrayType + ParameterizedType + TypeVariable + WildcardType))) + +;; [Exports] +(def array-data-tag "#Array") +(def null-data-tag "#Null") + +;; [Utils] +(defn ^:private trace-lineage* [^Class super-class ^Class sub-class] + "(-> Class Class (List Class))" + ;; Either they're both interfaces, of they're both classes + (cond (.isInterface sub-class) + (let [interface<=interface? #(if (or (= super-class %) + (.isAssignableFrom super-class %)) + % + nil)] + (loop [sub-class sub-class + stack (&/|list)] + (let [super-interface (some interface<=interface? + (.getInterfaces sub-class))] + (if (= super-class super-interface) + (&/Cons$ super-interface stack) + (let [super* (.getSuperclass sub-class)] + (recur super* (&/Cons$ super* stack))))))) + + (.isInterface super-class) + (let [class<=interface? #(if (= super-class %) % nil)] + (loop [sub-class sub-class + stack (&/|list)] + (if-let [super-interface (some class<=interface? (.getInterfaces sub-class))] + (&/Cons$ super-interface stack) + (let [super* (.getSuperclass sub-class)] + (recur super* (&/Cons$ super* stack)))))) + + :else + (loop [sub-class sub-class + stack (&/|list)] + (let [super* (.getSuperclass sub-class)] + (if (= super* super-class) + (&/Cons$ super* stack) + (recur super* (&/Cons$ super* stack))))))) + +(defn ^:private trace-lineage [^Class sub-class ^Class super-class] + "(-> Class Class (List Class))" + (if (= sub-class super-class) + (&/|list) + (&/|reverse (trace-lineage* super-class sub-class)))) + +(let [matcher (fn [m ^TypeVariable jt lt] (&/Cons$ (&/T (.getName jt) lt) m))] + (defn ^:private match-params [sub-type-params params] + (assert (and (= (&/|length sub-type-params) (&/|length params)) + (&/|every? (partial instance? TypeVariable) sub-type-params))) + (&/fold2 matcher (&/|table) sub-type-params params))) + +;; [Exports] +(let [class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+))" + Unit (&/V &/$TupleT (&/|list))] + (defn class->type [^Class class] + "(-> Class Type)" + (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] + (let [base (or arr-base simple-base)] + (if (.equals "void" base) + Unit + (reduce (fn [inner _] (&/V &/$DataT (&/T array-data-tag (&/|list inner)))) + (&/V &/$DataT (&/T base &/Nil$)) + (range (count (or arr-brackets ""))))) + )))) + +(defn instance-param [existential matchings refl-type] + "(-> (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))" + (cond (instance? Class refl-type) + (return (class->type refl-type)) + + (instance? GenericArrayType refl-type) + (let [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))] + (return (&/V &/$DataT (&/T array-data-tag (&/|list inner-type))))) + + (instance? ParameterizedType refl-type) + (|do [:let [refl-type* ^ParameterizedType refl-type] + params* (->> refl-type* + .getActualTypeArguments + seq &/->list + (&/map% (partial instance-param existential matchings)))] + (return (&/V &/$DataT (&/T (->> refl-type* ^Class (.getRawType) .getName) + params*)))) + + (instance? TypeVariable refl-type) + (let [gvar (.getName ^TypeVariable refl-type)] + (if-let [m-type (&/|get gvar matchings)] + (return m-type) + (fail (str "[Type Error] Unknown generic type variable: " gvar)))) + + (instance? WildcardType refl-type) + (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)] + (instance-param existential matchings bound) + existential))) + +;; [Utils] +(defn ^:private translate-params [existential super-type-params sub-type-params params] + "(-> (List (^ java.lang.reflect.Type)) (List (^ java.lang.reflect.Type)) (List Type) (Lux (List Type)))" + (|let [matchings (match-params sub-type-params params)] + (&/map% (partial instance-param existential matchings) super-type-params))) + +(defn ^:private raise* [existential sub+params ^Class super] + "(-> (, Class (List Type)) Class (Lux (, Class (List Type))))" + (|let [[^Class sub params] sub+params] + (if (.isInterface super) + (|do [:let [super-params (->> sub + .getGenericInterfaces + (some #(if (= super (if (instance? Class %) % (.getRawType ^ParameterizedType %))) + (if (instance? Class %) + (&/|list) + (->> ^ParameterizedType % .getActualTypeArguments seq &/->list)) + nil)))] + params* (translate-params existential + super-params + (->> sub .getTypeParameters seq &/->list) + params)] + (return (&/T super params*))) + (let [super* (.getGenericSuperclass sub)] + (cond (instance? Class super*) + (return (&/T super* (&/|list))) + + (instance? ParameterizedType super*) + (|do [params* (translate-params existential + (->> ^ParameterizedType super* .getActualTypeArguments seq &/->list) + (->> sub .getTypeParameters seq &/->list) + params)] + (return (&/T super params*))) + + :else + (assert false (prn-str super* (class super*) [sub super]))))))) + +(defn ^:private raise [existential lineage class params] + "(-> (List Class) Class (List Type) (Lux (, Class (List Type))))" + (&/fold% (partial raise* existential) (&/T class params) lineage)) + +;; [Exports] +(defn ->super-type [existential class-loader super-class sub-class sub-params] + "(-> Text Text (List Type) (Lux Type))" + (let [super-class+ (Class/forName super-class true class-loader) + sub-class+ (Class/forName sub-class true class-loader)] + (if (.isAssignableFrom super-class+ sub-class+) + (let [lineage (trace-lineage sub-class+ super-class+)] + (|do [[^Class sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] + (return (&/V &/$DataT (&/T (.getName sub-class*) sub-params*))))) + (fail (str "[Type Error] Classes don't have a subtyping relationship: " sub-class " </= " super-class))))) + +(defn as-obj [class] + (case class + "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" + ;; else + class)) + +(let [primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}] + (defn primitive-type? [type-name] + (contains? primitive-types type-name))) + +(defn check-host-types [check check-error fixpoints existential class-loader invariant?? expected actual] + (|let [[e!name e!params] expected + [a!name a!params] actual] + (cond (= "java.lang.Object" e!name) + (return (&/T fixpoints nil)) + + (= null-data-tag a!name) + (if (not (primitive-type? e!name)) + (return (&/T fixpoints nil)) + (fail (check-error (&/V &/$DataT expected) (&/V &/$DataT actual)))) + + (= null-data-tag e!name) + (if (= null-data-tag a!name) + (return (&/T fixpoints nil)) + (fail (check-error (&/V &/$DataT expected) (&/V &/$DataT actual)))) + + (and (= array-data-tag e!name) + (not= array-data-tag a!name)) + (fail (check-error (&/V &/$DataT expected) (&/V &/$DataT actual))) + + :else + (let [e!name (as-obj e!name) + a!name (as-obj a!name)] + (cond (and (.equals ^Object e!name a!name) + (= (&/|length e!params) (&/|length a!params))) + (|do [_ (&/map2% check e!params a!params)] + (return (&/T fixpoints nil))) + + (not invariant??) + (|do [actual* (->super-type existential class-loader e!name a!name a!params)] + (check (&/V &/$DataT expected) actual*)) + + :else + (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))))) + +(let [Void$ (&/V &/$VariantT (&/|list)) + gen-type (constantly Void$)] + (defn dummy-gtype [class] + (|do [class-loader &/loader] + (try (|let [=class (Class/forName class true class-loader) + params (->> =class .getTypeParameters seq &/->list (&/|map gen-type))] + (return (&/V &/$DataT (&/T class params)))) + (catch Exception e + (fail (str "[Type Error] Unknown type: " class))))))) diff --git a/test/test/lux/lexer.clj b/test/test/lux/lexer.clj new file mode 100644 index 000000000..72602639d --- /dev/null +++ b/test/test/lux/lexer.clj @@ -0,0 +1,269 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns test.lux.lexer + (:use clojure.test) + (:require (lux [base :as & :refer [deftags |do return* return fail fail* |let |case]] + [reader :as &reader] + [lexer :as &lexer]) + [lux.analyser.module :as &a-module] + :reload-all)) + +;; [Utils] +(def ^:private module-name "test") + +(defn ^:private make-state [source-code] + (&/set$ &/$source (&reader/from module-name source-code) + (&/init-state nil))) + +;; [Tests] +(deftest lex-white-space + (let [input " \t"] + (|case (&/run-state &lexer/lex (make-state input)) + (&/$Right state [cursor (&lexer/$White_Space output)]) + (is (= input output)) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-comment + ;; Should be capable of recognizing both single-line & multi-line comments. + (let [input1 " YOLO" + input2 "\nLOL\n" + input3 " NYAN\n#(\nCAT )#\n"] + (|case (&/run-state (|do [[_ single-line] &lexer/lex + [_ multi-line] &lexer/lex + [_ multi-line-embedded] &lexer/lex] + (return (&/T single-line multi-line multi-line-embedded))) + (make-state (str "##" input1 "\n" "#(" input2 ")#" "\n" "#(" input3 ")#"))) + (&/$Right state [(&lexer/$Comment output1) + (&lexer/$Comment output2) + (&lexer/$Comment output3)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + input3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-bool + (let [input1 "true" + input2 "false"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex] + (return (&/T output1 output2))) + (make-state (str input1 "\n" input2))) + (&/$Right state [(&lexer/$Bool output1) + (&lexer/$Bool output2)]) + (are [input output] (= input output) + input1 output1 + input2 output2) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-int + (let [input1 "0" + input2 "12" + input3 "-123"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex] + (return (&/T output1 output2 output3))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state [(&lexer/$Int output1) + (&lexer/$Int output2) + (&lexer/$Int output3)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + input3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-real + (let [input1 "0.00123" + input2 "12.01020300" + input3 "-12.3"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex] + (return (&/T output1 output2 output3))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state [(&lexer/$Real output1) + (&lexer/$Real output2) + (&lexer/$Real output3)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + input3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-char + (let [input1 "a" + input2 "\\n" + input3 " " + input4 "\\t" + input5 "\\b" + input6 "\\r" + input7 "\\f" + input8 "\\\"" + input9 "\\\\"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex + [_ output6] &lexer/lex + [_ output7] &lexer/lex + [_ output8] &lexer/lex + [_ output9] &lexer/lex] + (return (&/T output1 output2 output3 output4 output5 output6 output7 output8 output9))) + (make-state (str "#\"" input1 "\"" "\n" "#\"" input2 "\"" "\n" "#\"" input3 "\"" + "\n" "#\"" input4 "\"" "\n" "#\"" input5 "\"" "\n" "#\"" input6 "\"" + "\n" "#\"" input7 "\"" "\n" "#\"" input8 "\"" "\n" "#\"" input9 "\""))) + (&/$Right state [(&lexer/$Char output1) + (&lexer/$Char output2) + (&lexer/$Char output3) + (&lexer/$Char output4) + (&lexer/$Char output5) + (&lexer/$Char output6) + (&lexer/$Char output7) + (&lexer/$Char output8) + (&lexer/$Char output9)]) + (are [input output] (= input output) + input1 output1 + "\n" output2 + input3 output3 + "\t" output4 + "\b" output5 + "\r" output6 + "\f" output7 + "\"" output8 + "\\" output9) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-text + (let [input1 "" + input2 "abc" + input3 "yolo\\nlol\\tmeme"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex] + (return (&/T output1 output2 output3))) + (make-state (str "\"" input1 "\"" "\n" "\"" input2 "\"" "\n" "\"" input3 "\""))) + (&/$Right state [(&lexer/$Text output1) + (&lexer/$Text output2) + (&lexer/$Text output3)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + "yolo\nlol\tmeme" output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-symbol + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + [_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex] + (return (&/T output1 output2 output3 output4 output5))) + (make-state (str input1 "\n" input2 "\n" input3 "\n" input4 "\n" input5))) + (&/$Right state [(&lexer/$Symbol output1) + (&lexer/$Symbol output2) + (&lexer/$Symbol output3) + (&lexer/$Symbol output4) + (&lexer/$Symbol output5)]) + (are [input output] (&/ident= input output) + (&/T "" "foo") output1 + (&/T "test" "bar0123456789") output2 + (&/T "lux" "b1a2z3") output3 + (&/T "test" "quux") output4 + (&/T "" "!_@$%^&*-+=.<>?/|\\~`':") output5) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-tag + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + [_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex] + (return (&/T output1 output2 output3 output4 output5))) + (make-state (str "#" input1 "\n" "#" input2 "\n" "#" input3 "\n" "#" input4 "\n" "#" input5))) + (&/$Right state [(&lexer/$Tag output1) + (&lexer/$Tag output2) + (&lexer/$Tag output3) + (&lexer/$Tag output4) + (&lexer/$Tag output5)]) + (are [input output] (&/ident= input output) + (&/T "" "foo") output1 + (&/T "test" "bar0123456789") output2 + (&/T "lux" "b1a2z3") output3 + (&/T "test" "quux") output4 + (&/T "" "!_@$%^&*-+=.<>?/|\\~`':") output5) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-delimiter + (let [input1 "(" + input2 ")" + input3 "[" + input4 "]" + input5 "{" + input6 "}"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + [_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex + [_ output6] &lexer/lex] + (return (&/T output1 output2 output3 output4 output5 output6))) + (make-state (str input1 "\n" input2 "\n" input3 "\n" input4 "\n" input5 "\n" input6))) + (&/$Right state [(&lexer/$Open_Paren) + (&lexer/$Close_Paren) + (&lexer/$Open_Bracket) + (&lexer/$Close_Bracket) + (&lexer/$Open_Brace) + (&lexer/$Close_Brace)]) + (is true) + + _ + (is false "Couldn't read.") + ))) + +;; (run-all-tests) diff --git a/test/test/lux/parser.clj b/test/test/lux/parser.clj new file mode 100644 index 000000000..13bd3500c --- /dev/null +++ b/test/test/lux/parser.clj @@ -0,0 +1,269 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns test.lux.parser + (:use (clojure test + template)) + (:require (lux [base :as & :refer [deftags |do return* return fail fail* |let |case]] + [reader :as &reader] + [parser :as &parser]) + [lux.analyser.module :as &a-module] + :reload-all)) + +;; [Utils] +(def ^:private module-name "test") + +(defn ^:private make-state [source-code] + (&/set$ &/$source (&reader/from module-name source-code) + (&/init-state nil))) + +;; [Tests] +(deftest parse-white-space + (let [input " \t"] + (|case (&/run-state &parser/parse (make-state input)) + (&/$Right state (&/$Nil)) + (is true) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-comment + (let [input1 " YOLO" + input2 "\nLOL\n" + input3 " NYAN\n#(\nCAT )#\n"] + (|case (&/run-state &parser/parse (make-state (str "##" input1 "\n" "#(" input2 ")#" "\n" "#(" input3 ")#"))) + (&/$Right state (&/$Nil)) + (is true) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-bool + (let [input1 "true" + input2 "false"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse] + (return (&/|++ output1 output2))) + (make-state (str input1 "\n" input2))) + (&/$Right state (&/$Cons [_ (&/$BoolS output1)] (&/$Cons [_ (&/$BoolS output2)] (&/$Nil)))) + (are [input output] (= input output) + true output1 + false output2) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-int + (let [input1 "0" + input2 "12" + input3 "-123"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse] + (return (&/|++ output1 (&/|++ output2 output3)))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state (&/$Cons [_ (&/$IntS output1)] (&/$Cons [_ (&/$IntS output2)] (&/$Cons [_ (&/$IntS output3)] (&/$Nil))))) + (are [input output] (= input output) + 0 output1 + 12 output2 + -123 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-real + (let [input1 "0.00123" + input2 "12.01020300" + input3 "-12.3"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse] + (return (&/|++ output1 (&/|++ output2 output3)))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state (&/$Cons [_ (&/$RealS output1)] (&/$Cons [_ (&/$RealS output2)] (&/$Cons [_ (&/$RealS output3)] (&/$Nil))))) + (are [input output] (= input output) + 0.00123 output1 + 12.010203 output2 + -12.3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-char + (let [input1 "a" + input2 "\\n" + input3 " " + input4 "\\t" + input5 "\\b" + input6 "\\r" + input7 "\\f" + input8 "\\\"" + input9 "\\\\"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse + output4 &parser/parse + output5 &parser/parse + output6 &parser/parse + output7 &parser/parse + output8 &parser/parse + output9 &parser/parse] + (return (&/|++ output1 (&/|++ output2 (&/|++ output3 (&/|++ output4 (&/|++ output5 (&/|++ output6 (&/|++ output7 (&/|++ output8 output9)))))))))) + (make-state (str "#\"" input1 "\"" "\n" "#\"" input2 "\"" "\n" "#\"" input3 "\"" + "\n" "#\"" input4 "\"" "\n" "#\"" input5 "\"" "\n" "#\"" input6 "\"" + "\n" "#\"" input7 "\"" "\n" "#\"" input8 "\"" "\n" "#\"" input9 "\""))) + (&/$Right state (&/$Cons [_ (&/$CharS output1)] + (&/$Cons [_ (&/$CharS output2)] + (&/$Cons [_ (&/$CharS output3)] + (&/$Cons [_ (&/$CharS output4)] + (&/$Cons [_ (&/$CharS output5)] + (&/$Cons [_ (&/$CharS output6)] + (&/$Cons [_ (&/$CharS output7)] + (&/$Cons [_ (&/$CharS output8)] + (&/$Cons [_ (&/$CharS output9)] + (&/$Nil))))))))))) + (are [input output] (= input output) + \a output1 + \newline output2 + \space output3 + \tab output4 + \backspace output5 + \return output6 + \formfeed output7 + \" output8 + \\ output9) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-text + (let [input1 "" + input2 "abc" + input3 "yolo\\nlol\\tmeme"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse] + (return (&/|++ output1 (&/|++ output2 output3)))) + (make-state (str "\"" input1 "\"" "\n" "\"" input2 "\"" "\n" "\"" input3 "\""))) + (&/$Right state (&/$Cons [_ (&/$TextS output1)] (&/$Cons [_ (&/$TextS output2)] (&/$Cons [_ (&/$TextS output3)] (&/$Nil))))) + (are [input output] (= input output) + input1 output1 + input2 output2 + "yolo\nlol\tmeme" output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-symbol + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + output1 &parser/parse + output2 &parser/parse + output3 &parser/parse + output4 &parser/parse + output5 &parser/parse] + (return (&/|++ output1 (&/|++ output2 (&/|++ output3 (&/|++ output4 output5)))))) + (make-state (str input1 "\n" input2 "\n" input3 "\n" input4 "\n" input5))) + (&/$Right state (&/$Cons [_ (&/$SymbolS output1)] + (&/$Cons [_ (&/$SymbolS output2)] + (&/$Cons [_ (&/$SymbolS output3)] + (&/$Cons [_ (&/$SymbolS output4)] + (&/$Cons [_ (&/$SymbolS output5)] + (&/$Nil))))))) + (are [input output] (&/ident= input output) + (&/T "" "foo") output1 + (&/T "test" "bar0123456789") output2 + (&/T "lux" "b1a2z3") output3 + (&/T "test" "quux") output4 + (&/T "" "!_@$%^&*-+=.<>?/|\\~`':") output5) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-tag + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + output1 &parser/parse + output2 &parser/parse + output3 &parser/parse + output4 &parser/parse + output5 &parser/parse] + (return (&/|++ output1 (&/|++ output2 (&/|++ output3 (&/|++ output4 output5)))))) + (make-state (str "#" input1 "\n" "#" input2 "\n" "#" input3 "\n" "#" input4 "\n" "#" input5))) + (&/$Right state (&/$Cons [_ (&/$TagS output1)] + (&/$Cons [_ (&/$TagS output2)] + (&/$Cons [_ (&/$TagS output3)] + (&/$Cons [_ (&/$TagS output4)] + (&/$Cons [_ (&/$TagS output5)] + (&/$Nil))))))) + (are [input output] (&/ident= input output) + (&/T "" "foo") output1 + (&/T "test" "bar0123456789") output2 + (&/T "lux" "b1a2z3") output3 + (&/T "test" "quux") output4 + (&/T "" "!_@$%^&*-+=.<>?/|\\~`':") output5) + + _ + (is false "Couldn't read.") + ))) + +(do-template [<name> <tag> <open> <close>] + (deftest <name> + (let [input1 "yolo 123 \"lol\" #meme"] + (|case (&/run-state &parser/parse + (make-state (str <open> input1 <close>))) + (&/$Right state (&/$Cons [_ (<tag> (&/$Cons [_ (&/$SymbolS symv)] + (&/$Cons [_ (&/$IntS intv)] + (&/$Cons [_ (&/$TextS textv)] + (&/$Cons [_ (&/$TagS tagv)] + (&/$Nil))))))] + (&/$Nil))) + (do (is (&/ident= (&/T "" "yolo") symv)) + (is (= 123 intv)) + (is (= "lol" textv)) + (is (&/ident= (&/T "" "meme") tagv))) + + _ + (is false "Couldn't read.") + ))) + + parse-form &/$FormS "(" ")" + parse-tuple &/$TupleS "[" "]" + ) + +(deftest parse-record + (let [input1 "yolo 123 \"lol\" #meme"] + (|case (&/run-state &parser/parse + (make-state (str "{" input1 "}"))) + (&/$Right state (&/$Cons [_ (&/$RecordS (&/$Cons [[_ (&/$SymbolS symv)] [_ (&/$IntS intv)]] + (&/$Cons [[_ (&/$TextS textv)] [_ (&/$TagS tagv)]] + (&/$Nil))))] + (&/$Nil))) + (do (is (&/ident= (&/T "" "yolo") symv)) + (is (= 123 intv)) + (is (= "lol" textv)) + (is (&/ident= (&/T "" "meme") tagv))) + + _ + (is false "Couldn't read.") + ))) + +(run-all-tests) diff --git a/test/test/lux/reader.clj b/test/test/lux/reader.clj new file mode 100644 index 000000000..ca4797f10 --- /dev/null +++ b/test/test/lux/reader.clj @@ -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/. + +(ns test.lux.reader + (:use clojure.test) + (:require (lux [base :as & :refer [deftags |do return* return fail fail* |let |case]] + [reader :as &reader]) + :reload-all)) + +;; [Utils] +(def source (&reader/from "test" "lol\nmeme\nnyan cat\n\nlolcat")) +(def init-state (&/set$ &/$source source (&/init-state nil))) + +;; [Tests] +(deftest test-source-code-reading + (is (= 4 (&/|length source)))) + +(deftest test-text-reading + ;; Should be capable of recognizing literal texts. + (let [input "lo"] + (|case (&/run-state (&reader/read-text input) init-state) + (&/$Right state [cursor output]) + (is (= input output)) + + _ + (is false "Couldn't read.") + ))) + +(deftest test-regex-reading + ;; Should be capable of matching simple, grouping regex-patterns. + (|case (&/run-state (&reader/read-regex #"l(.)l") init-state) + (&/$Right state [cursor output]) + (is (= "lol" "lol")) + + _ + (is false "Couldn't read.") + )) + +(deftest test-regex2-reading + ;; Should be capable of matching double, grouping regex-patterns. + (|case (&/run-state (&reader/read-regex2 #"(.)(..)") init-state) + (&/$Right state [cursor [left right]]) + (is (and (= "l" left) + (= "ol" right))) + + _ + (is false "Couldn't read.") + )) + +(deftest test-regex+-reading + ;; Should be capable of matching multi-line regex-patterns. + (|case (&/run-state (&reader/read-regex+ #"(?is)^(.*?)(cat|$)") init-state) + (&/$Right state [cursor output]) + (is (= "lol\nmeme\nnyan " output)) + + _ + (is false "Couldn't read.") + )) + +;; (run-all-tests) |